1 ;;; Traps: stepping, breakpoints, and such.
3 ;; Copyright (C) 2010, 2012, 2013 Free Software Foundation, Inc.
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Lesser General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 3 of the License, or (at your option) any later version.
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Lesser General Public License for more details.
15 ;;; You should have received a copy of the GNU Lesser General Public
16 ;;; License along with this library; if not, write to the Free Software
17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;;; Guile's debugging capabilities come from the hooks that its VM
22 ;;; provides. For example, there is a hook that is fired when a function
23 ;;; is called, and even a hook that gets fired at every retired
26 ;;; But as the firing of these hooks is interleaved with the program
27 ;;; execution, if we want to debug a program, we have to write an
28 ;;; imperative program that mutates the state of these hooks, and to
29 ;;; dispatch the hooks to a more semantic context.
31 ;;; For example if we have placed a breakpoint at foo.scm:38, and
32 ;;; determined that that location maps to the 18th instruction in
33 ;;; procedure `bar', then we will need per-instruction hooks within
34 ;;; `bar' -- but when running other procedures, we can have the
35 ;;; per-instruction hooks off.
37 ;;; Our approach is to define "traps". The behavior of a trap is
38 ;;; specified when the trap is created. After creation, traps expose a
39 ;;; limited, uniform interface: they are either on or off.
41 ;;; To take our foo.scm:38 example again, we can define a trap that
42 ;;; calls a function when control transfers to that source line --
43 ;;; trap-at-source-location below. Calling the trap-at-source-location
44 ;;; function adds to the VM hooks in such at way that it can do its job.
45 ;;; The result of calling the function is a "disable-hook" closure that,
46 ;;; when called, will turn off that trap.
48 ;;; The result of calling the "disable-hook" closure, in turn, is an
49 ;;; "enable-hook" closure, which when called turns the hook back on, and
50 ;;; returns a "disable-hook" closure.
52 ;;; It's a little confusing. The summary is, call these functions to add
53 ;;; a trap; and call their return value to disable the trap.
57 (define-module (system vm traps)
58 #:use-module (system base pmatch)
59 #:use-module (system vm vm)
60 #:use-module (system vm debug)
61 #:use-module (system vm frame)
62 #:use-module (system vm program)
63 #:use-module (system xref)
64 #:use-module (rnrs bytevectors)
65 #:export (trap-at-procedure-call
67 trap-instructions-in-procedure
68 trap-at-procedure-ip-in-range
69 trap-at-source-location
71 trap-in-dynamic-extent
72 trap-calls-in-dynamic-extent
73 trap-instructions-in-dynamic-extent
74 trap-calls-to-procedure
75 trap-matching-instructions))
77 (define-syntax arg-check
79 ((_ arg predicate? message)
80 (if (not (predicate? arg))
81 (error "bad argument ~a: ~a" 'arg message)))
83 (if (not (predicate? arg))
84 (error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
86 (define (new-disabled-trap enable disable)
88 (define-syntax disabled?
90 (disabled? (not enabled?))
91 ((set! disabled? val) (set! enabled? (not val)))))
93 (define* (enable-trap #:optional frame)
94 (if enabled? (error "trap already enabled"))
99 (define* (disable-trap #:optional frame)
100 (if disabled? (error "trap already disabled"))
107 (define (new-enabled-trap frame enable disable)
108 ((new-disabled-trap enable disable) frame))
110 ;; Returns an absolute IP.
111 (define (program-last-ip prog)
112 (let ((pdi (find-program-debug-info (program-code prog))))
113 (and pdi (program-debug-info-size pdi))))
115 (define (frame-matcher proc match-code?)
118 (let ((start (program-code proc))
119 (end (program-last-ip proc)))
121 (let ((ip (frame-instruction-pointer frame)))
122 (and (<= start ip) (< ip end)))))
125 (eq? (frame-procedure frame) proc))))
127 ;; A basic trap, fires when a procedure is called.
129 (define* (trap-at-procedure-call proc handler #:key (closure? #f)
130 (our-frame? (frame-matcher proc closure?)))
131 (arg-check proc procedure?)
132 (arg-check handler procedure?)
134 (define (apply-hook frame)
135 (if (our-frame? frame)
141 (add-hook! (vm-apply-hook) apply-hook))
143 (remove-hook! (vm-apply-hook) apply-hook)))))
145 ;; A more complicated trap, traps when control enters a procedure.
147 ;; Control can enter a procedure via:
148 ;; * A procedure call.
149 ;; * A return to a procedure's frame on the stack.
150 ;; * A continuation returning directly to an application of this
153 ;; Control can leave a procedure via:
154 ;; * A normal return from the procedure.
155 ;; * An application of another procedure.
156 ;; * An invocation of a continuation.
159 (define* (trap-in-procedure proc enter-handler exit-handler
160 #:key current-frame (closure? #f)
161 (our-frame? (frame-matcher proc closure?)))
162 (arg-check proc procedure?)
163 (arg-check enter-handler procedure?)
164 (arg-check exit-handler procedure?)
166 (define (enter-proc frame)
168 (warn "already in proc" frame)
170 (enter-handler frame)
171 (set! in-proc? #t))))
173 (define (exit-proc frame)
178 (warn "not in proc" frame)))
180 (define (apply-hook frame)
183 (if (our-frame? frame)
186 (define (push-cont-hook frame)
190 (define (pop-cont-hook frame . values)
193 (if (our-frame? (frame-previous frame))
194 (enter-proc (frame-previous frame))))
196 (define (abort-hook frame . values)
199 (if (our-frame? frame)
205 (add-hook! (vm-apply-hook) apply-hook)
206 (add-hook! (vm-push-continuation-hook) push-cont-hook)
207 (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
208 (add-hook! (vm-abort-continuation-hook) abort-hook)
209 (if (and frame (our-frame? frame))
214 (remove-hook! (vm-apply-hook) apply-hook)
215 (remove-hook! (vm-push-continuation-hook) push-cont-hook)
216 (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
217 (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
219 ;; Building on trap-in-procedure, we have trap-instructions-in-procedure
221 (define* (trap-instructions-in-procedure proc next-handler exit-handler
222 #:key current-frame (closure? #f)
224 (frame-matcher proc closure?)))
225 (arg-check proc procedure?)
226 (arg-check next-handler procedure?)
227 (arg-check exit-handler procedure?)
229 (define (next-hook frame)
230 (if (our-frame? frame)
231 (next-handler frame)))
233 (define (enter frame)
234 (add-hook! (vm-next-hook) next-hook)
235 (if frame (next-hook frame)))
239 (remove-hook! (vm-next-hook) next-hook))
241 (trap-in-procedure proc enter exit
242 #:current-frame current-frame
243 #:our-frame? our-frame?)))
245 (define (non-negative-integer? x)
246 (and (number? x) (integer? x) (exact? x) (not (negative? x))))
248 (define (positive-integer? x)
249 (and (number? x) (integer? x) (exact? x) (positive? x)))
255 (non-negative-integer? (car x))
256 (non-negative-integer? (cdr x))))
259 (define (in-range? range i)
260 (or-map (lambda (bounds)
261 (and (<= (car bounds) i)
265 ;; Building on trap-instructions-in-procedure, we have
266 ;; trap-at-procedure-ip-in-range.
268 (define* (trap-at-procedure-ip-in-range proc range handler
269 #:key current-frame (closure? #f)
271 (frame-matcher proc closure?)))
272 (arg-check proc procedure?)
273 (arg-check range range?)
274 (arg-check handler procedure?)
275 (let ((fp-stack '()))
276 (define (cull-frames! fp)
277 (let lp ((frames fp-stack))
278 (if (and (pair? frames) (< (car frames) fp))
280 (set! fp-stack frames))))
282 (define (next-handler frame)
283 (let ((fp (frame-address frame))
284 (ip (frame-instruction-pointer frame)))
286 (let ((now-in-range? (in-range? range ip))
287 (was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp))))
290 (if (not now-in-range?)
291 (set! fp-stack (cdr fp-stack))))
293 (set! fp-stack (cons fp fp-stack))
296 (define (exit-handler frame)
297 (if (and (pair? fp-stack)
298 (= (car fp-stack) (frame-address frame)))
299 (set! fp-stack (cdr fp-stack))))
301 (trap-instructions-in-procedure proc next-handler exit-handler
302 #:current-frame current-frame
303 #:our-frame? our-frame?)))
305 (define (program-sources-by-line proc file)
308 (let ((code (program-code proc)))
309 (let lp ((sources (program-sources proc))
313 (pmatch (car sources)
314 ((,start-ip ,start-file ,start-line . ,start-col)
315 (if (equal? start-file file)
317 (if (pair? (cdr sources))
318 (pmatch (cadr sources)
320 (cons (+ start-ip code)
322 (else (error "unexpected")))
323 (cons (+ start-ip code)
324 (program-last-ip proc)))
327 (else (error "unexpected"))))
332 (assv-set! alist (car pair)
334 (or (assv-ref alist (car pair))
337 (sort! alist (lambda (x y) (< (car x) (car y))))
341 (define (source->ip-range proc file line)
342 (or (or-map (lambda (line-and-ranges)
344 ((= (car line-and-ranges) line)
345 (cdr line-and-ranges))
346 ((> (car line-and-ranges) line)
347 (warn "no instructions found at" file ":" line
348 "; using line" (car line-and-ranges) "instead")
349 (cdr line-and-ranges))
351 (program-sources-by-line proc file))
353 (warn "no instructions found for" file ":" line)
356 (define (source-closures-or-procedures file line)
357 (let ((closures (source-closures file line)))
360 (values (source-procedures file line) #f))))
362 ;; Building on trap-on-instructions-in-procedure, we have
363 ;; trap-at-source-location. The parameter `user-line' is one-indexed, as
364 ;; a user counts lines, instead of zero-indexed, as Guile counts lines.
366 (define* (trap-at-source-location file user-line handler #:key current-frame)
367 (arg-check file string?)
368 (arg-check user-line positive-integer?)
369 (arg-check handler procedure?)
372 (lambda () (source-closures-or-procedures file (1- user-line)))
373 (lambda (procs closures?)
380 (let ((range (source->ip-range proc file (1- user-line))))
381 (trap-at-procedure-ip-in-range proc range handler
382 #:current-frame current-frame
383 #:closure? closures?)))
386 (error "No procedures found at ~a:~a." file user-line)))
388 (for-each (lambda (trap) (trap frame)) traps)
389 (set! traps #f)))))))
393 ;; On a different tack, now we're going to build up a set of traps that
394 ;; do useful things during the dynamic extent of a procedure's
395 ;; application. First, a trap for when a frame returns.
397 (define (trap-frame-finish frame return-handler abort-handler)
398 (arg-check frame frame?)
399 (arg-check return-handler procedure?)
400 (arg-check abort-handler procedure?)
401 (let ((fp (frame-address frame)))
402 (define (pop-cont-hook frame . values)
403 (if (and fp (eq? (frame-address frame) fp))
406 (apply return-handler frame values))))
408 (define (abort-hook frame . values)
409 (if (and fp (< (frame-address frame) fp))
412 (apply abort-handler frame values))))
418 (error "return-or-abort traps may only be enabled once"))
419 (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
420 (add-hook! (vm-abort-continuation-hook) abort-hook))
423 (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
424 (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
426 ;; A more traditional dynamic-wind trap. Perhaps this should not be
427 ;; based on the above trap-frame-finish?
429 (define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
430 #:key current-frame (closure? #f)
431 (our-frame? (frame-matcher proc closure?)))
432 (arg-check proc procedure?)
433 (arg-check enter-handler procedure?)
434 (arg-check return-handler procedure?)
435 (arg-check abort-handler procedure?)
436 (let ((exit-trap #f))
437 (define (return-hook frame . values)
438 (exit-trap frame) ; disable the return/abort trap.
440 (return-handler frame))
442 (define (abort-hook frame . values)
443 (exit-trap frame) ; disable the return/abort trap.
445 (abort-handler frame))
447 (define (apply-hook frame)
448 (if (and (not exit-trap) (our-frame? frame))
450 (enter-handler frame)
452 (trap-frame-finish frame return-hook abort-hook)))))
457 (add-hook! (vm-apply-hook) apply-hook))
462 (remove-hook! (vm-apply-hook) apply-hook)))))
464 ;; Trapping all procedure calls within a dynamic extent, recording the
465 ;; depth of the call stack relative to the original procedure.
467 (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
468 #:key current-frame (closure? #f)
470 (frame-matcher proc closure?)))
471 (arg-check proc procedure?)
472 (arg-check apply-handler procedure?)
473 (arg-check return-handler procedure?)
474 (let ((*call-depth* 0))
475 (define (trace-push frame)
476 (set! *call-depth* (1+ *call-depth*)))
478 (define (trace-pop frame . values)
479 (apply return-handler frame *call-depth* values)
480 (set! *call-depth* (1- *call-depth*)))
482 (define (trace-apply frame)
483 (apply-handler frame *call-depth*))
485 ;; FIXME: recalc depth on abort
487 (define (enter frame)
488 (add-hook! (vm-push-continuation-hook) trace-push)
489 (add-hook! (vm-pop-continuation-hook) trace-pop)
490 (add-hook! (vm-apply-hook) trace-apply))
492 (define (leave frame)
493 (remove-hook! (vm-push-continuation-hook) trace-push)
494 (remove-hook! (vm-pop-continuation-hook) trace-pop)
495 (remove-hook! (vm-apply-hook) trace-apply))
497 (define (return frame)
500 (define (abort frame)
503 (trap-in-dynamic-extent proc enter return abort
504 #:current-frame current-frame
505 #:our-frame? our-frame?)))
507 ;; Trapping all retired intructions within a dynamic extent.
509 (define* (trap-instructions-in-dynamic-extent proc next-handler
510 #:key current-frame (closure? #f)
512 (frame-matcher proc closure?)))
513 (arg-check proc procedure?)
514 (arg-check next-handler procedure?)
516 (define (trace-next frame)
517 (next-handler frame))
519 (define (enter frame)
520 (add-hook! (vm-next-hook) trace-next))
522 (define (leave frame)
523 (remove-hook! (vm-next-hook) trace-next))
525 (define (return frame)
528 (define (abort frame)
531 (trap-in-dynamic-extent proc enter return abort
532 #:current-frame current-frame
533 #:our-frame? our-frame?)))
535 ;; Traps calls and returns for a given procedure, keeping track of the call depth.
537 (define (trap-calls-to-procedure proc apply-handler return-handler)
538 (arg-check proc procedure?)
539 (arg-check apply-handler procedure?)
540 (arg-check return-handler procedure?)
541 (let ((pending-finish-traps '())
543 (define (apply-hook frame)
544 (let ((depth (length pending-finish-traps)))
546 (apply-handler frame depth)
548 (if (not (eq? (frame-address frame) last-fp))
549 (let ((finish-trap #f))
550 (define (frame-finished frame)
551 (finish-trap frame) ;; disables the trap.
552 (set! pending-finish-traps
553 (delq finish-trap pending-finish-traps))
554 (set! finish-trap #f))
556 (define (return-hook frame . values)
557 (frame-finished frame)
558 (apply return-handler frame depth values))
560 ;; FIXME: abort handler?
561 (define (abort-hook frame . values)
562 (frame-finished frame))
565 (trap-frame-finish frame return-hook abort-hook))
566 (set! pending-finish-traps
567 (cons finish-trap pending-finish-traps))))))
569 ;; The basic idea is that we install one trap that fires for calls,
570 ;; but that each call installs its own finish trap. Those finish
571 ;; traps remove themselves as their frames finish or abort.
573 ;; However since to the outside world we present the interface of
574 ;; just being one trap, disabling this calls-to-procedure trap
575 ;; should take care of disabling all of the pending finish traps. We
576 ;; keep track of pending traps through the pending-finish-traps
579 ;; So since we know that the trap-at-procedure will be enabled, and
580 ;; thus returning a disable closure, we make sure to wrap that
581 ;; closure in something that will disable pending finish traps.
582 (define (with-pending-finish-disablers trap)
583 (define (with-pending-finish-enablers trap)
584 (lambda* (#:optional frame)
585 (with-pending-finish-disablers (trap frame))))
587 (lambda* (#:optional frame)
588 (for-each (lambda (disable) (disable frame))
589 pending-finish-traps)
590 (set! pending-finish-traps '())
591 (with-pending-finish-enablers (trap frame))))
593 (with-pending-finish-disablers
594 (trap-at-procedure-call proc apply-hook))))
596 ;; Trap when the source location changes.
598 (define (trap-matching-instructions frame-pred handler)
599 (arg-check frame-pred procedure?)
600 (arg-check handler procedure?)
602 (define (next-hook frame)
603 (if (frame-pred frame)
609 (add-hook! (vm-next-hook) next-hook))
611 (remove-hook! (vm-next-hook) next-hook)))))