Commit | Line | Data |
---|---|---|
c939b127 AW |
1 | ;;; Traps: stepping, breakpoints, and such. |
2 | ||
ae4d761f | 3 | ;; Copyright (C) 2010, 2012, 2013, 2014 Free Software Foundation, Inc. |
c939b127 AW |
4 | |
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. | |
9 | ;;; | |
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. | |
14 | ;;; | |
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 | |
18 | ||
19 | ;;; Commentary: | |
20 | ;;; | |
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 | |
24 | ;;; instruction. | |
25 | ;;; | |
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. | |
30 | ;;; | |
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. | |
36 | ;;; | |
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. | |
40 | ;;; | |
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. | |
47 | ;;; | |
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. | |
51 | ;;; | |
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. | |
54 | ;;; | |
55 | ;;; Code: | |
56 | ||
57 | (define-module (system vm traps) | |
58 | #:use-module (system base pmatch) | |
59 | #:use-module (system vm vm) | |
e391f179 | 60 | #:use-module (system vm debug) |
c939b127 AW |
61 | #:use-module (system vm frame) |
62 | #:use-module (system vm program) | |
c939b127 AW |
63 | #:use-module (system xref) |
64 | #:use-module (rnrs bytevectors) | |
65 | #:export (trap-at-procedure-call | |
66 | trap-in-procedure | |
67 | trap-instructions-in-procedure | |
68 | trap-at-procedure-ip-in-range | |
1bc1800f AW |
69 | trap-at-source-location |
70 | trap-frame-finish | |
71 | trap-in-dynamic-extent | |
72 | trap-calls-in-dynamic-extent | |
8dde88e0 | 73 | trap-instructions-in-dynamic-extent |
439e032b AW |
74 | trap-calls-to-procedure |
75 | trap-matching-instructions)) | |
c939b127 AW |
76 | |
77 | (define-syntax arg-check | |
78 | (syntax-rules () | |
79 | ((_ arg predicate? message) | |
80 | (if (not (predicate? arg)) | |
81 | (error "bad argument ~a: ~a" 'arg message))) | |
82 | ((_ arg predicate?) | |
83 | (if (not (predicate? arg)) | |
84 | (error "bad argument ~a: expected ~a" 'arg 'predicate?))))) | |
85 | ||
a222cbc9 | 86 | (define (new-disabled-trap enable disable) |
c939b127 AW |
87 | (let ((enabled? #f)) |
88 | (define-syntax disabled? | |
89 | (identifier-syntax | |
90 | (disabled? (not enabled?)) | |
91 | ((set! disabled? val) (set! enabled? (not val))))) | |
92 | ||
93 | (define* (enable-trap #:optional frame) | |
94 | (if enabled? (error "trap already enabled")) | |
95 | (enable frame) | |
c939b127 AW |
96 | (set! enabled? #t) |
97 | disable-trap) | |
98 | ||
99 | (define* (disable-trap #:optional frame) | |
100 | (if disabled? (error "trap already disabled")) | |
101 | (disable frame) | |
c939b127 AW |
102 | (set! disabled? #t) |
103 | enable-trap) | |
104 | ||
105 | enable-trap)) | |
106 | ||
a222cbc9 AW |
107 | (define (new-enabled-trap frame enable disable) |
108 | ((new-disabled-trap enable disable) frame)) | |
c939b127 | 109 | |
e391f179 AW |
110 | ;; Returns an absolute IP. |
111 | (define (program-last-ip prog) | |
d1100525 | 112 | (let ((pdi (find-program-debug-info (program-code prog)))) |
e391f179 AW |
113 | (and pdi (program-debug-info-size pdi)))) |
114 | ||
115 | (define (frame-matcher proc match-code?) | |
306cc01d IP |
116 | (let ((proc (if (struct? proc) |
117 | (procedure proc) | |
118 | proc))) | |
1df515a0 MW |
119 | (if match-code? |
120 | (if (program? proc) | |
121 | (let ((start (program-code proc)) | |
122 | (end (program-last-ip proc))) | |
123 | (lambda (frame) | |
124 | (let ((ip (frame-instruction-pointer frame))) | |
125 | (and (<= start ip) (< ip end))))) | |
126 | (lambda (frame) #f)) | |
306cc01d IP |
127 | (lambda (frame) |
128 | (eq? (frame-procedure frame) proc))))) | |
f4a23f91 | 129 | |
c939b127 AW |
130 | ;; A basic trap, fires when a procedure is called. |
131 | ;; | |
a222cbc9 | 132 | (define* (trap-at-procedure-call proc handler #:key (closure? #f) |
f4a23f91 | 133 | (our-frame? (frame-matcher proc closure?))) |
c939b127 AW |
134 | (arg-check proc procedure?) |
135 | (arg-check handler procedure?) | |
136 | (let () | |
137 | (define (apply-hook frame) | |
f4a23f91 | 138 | (if (our-frame? frame) |
c939b127 AW |
139 | (handler frame))) |
140 | ||
141 | (new-enabled-trap | |
a222cbc9 | 142 | #f |
c939b127 | 143 | (lambda (frame) |
972275ee | 144 | (add-hook! (vm-apply-hook) apply-hook)) |
c939b127 | 145 | (lambda (frame) |
972275ee | 146 | (remove-hook! (vm-apply-hook) apply-hook))))) |
c939b127 AW |
147 | |
148 | ;; A more complicated trap, traps when control enters a procedure. | |
149 | ;; | |
150 | ;; Control can enter a procedure via: | |
151 | ;; * A procedure call. | |
152 | ;; * A return to a procedure's frame on the stack. | |
153 | ;; * A continuation returning directly to an application of this | |
154 | ;; procedure. | |
155 | ;; | |
156 | ;; Control can leave a procedure via: | |
157 | ;; * A normal return from the procedure. | |
158 | ;; * An application of another procedure. | |
159 | ;; * An invocation of a continuation. | |
160 | ;; * An abort. | |
161 | ;; | |
162 | (define* (trap-in-procedure proc enter-handler exit-handler | |
a222cbc9 | 163 | #:key current-frame (closure? #f) |
f4a23f91 | 164 | (our-frame? (frame-matcher proc closure?))) |
c939b127 AW |
165 | (arg-check proc procedure?) |
166 | (arg-check enter-handler procedure?) | |
167 | (arg-check exit-handler procedure?) | |
168 | (let ((in-proc? #f)) | |
169 | (define (enter-proc frame) | |
170 | (if in-proc? | |
171 | (warn "already in proc" frame) | |
172 | (begin | |
173 | (enter-handler frame) | |
174 | (set! in-proc? #t)))) | |
175 | ||
176 | (define (exit-proc frame) | |
177 | (if in-proc? | |
178 | (begin | |
179 | (exit-handler frame) | |
180 | (set! in-proc? #f)) | |
181 | (warn "not in proc" frame))) | |
182 | ||
183 | (define (apply-hook frame) | |
184 | (if in-proc? | |
185 | (exit-proc frame)) | |
f4a23f91 | 186 | (if (our-frame? frame) |
c939b127 AW |
187 | (enter-proc frame))) |
188 | ||
189 | (define (push-cont-hook frame) | |
190 | (if in-proc? | |
191 | (exit-proc frame))) | |
192 | ||
c850a0ff | 193 | (define (pop-cont-hook frame . values) |
c939b127 AW |
194 | (if in-proc? |
195 | (exit-proc frame)) | |
ae4d761f AW |
196 | (if (our-frame? frame) |
197 | (enter-proc frame))) | |
c939b127 | 198 | |
c850a0ff | 199 | (define (abort-hook frame . values) |
c939b127 AW |
200 | (if in-proc? |
201 | (exit-proc frame)) | |
f4a23f91 | 202 | (if (our-frame? frame) |
c939b127 AW |
203 | (enter-proc frame))) |
204 | ||
c939b127 | 205 | (new-enabled-trap |
a222cbc9 | 206 | current-frame |
c939b127 | 207 | (lambda (frame) |
972275ee AW |
208 | (add-hook! (vm-apply-hook) apply-hook) |
209 | (add-hook! (vm-push-continuation-hook) push-cont-hook) | |
210 | (add-hook! (vm-pop-continuation-hook) pop-cont-hook) | |
211 | (add-hook! (vm-abort-continuation-hook) abort-hook) | |
f4a23f91 | 212 | (if (and frame (our-frame? frame)) |
c939b127 AW |
213 | (enter-proc frame))) |
214 | (lambda (frame) | |
215 | (if in-proc? | |
216 | (exit-proc frame)) | |
972275ee AW |
217 | (remove-hook! (vm-apply-hook) apply-hook) |
218 | (remove-hook! (vm-push-continuation-hook) push-cont-hook) | |
219 | (remove-hook! (vm-pop-continuation-hook) pop-cont-hook) | |
f689dd69 | 220 | (remove-hook! (vm-abort-continuation-hook) abort-hook))))) |
c939b127 AW |
221 | |
222 | ;; Building on trap-in-procedure, we have trap-instructions-in-procedure | |
223 | ;; | |
224 | (define* (trap-instructions-in-procedure proc next-handler exit-handler | |
a222cbc9 | 225 | #:key current-frame (closure? #f) |
f4a23f91 AW |
226 | (our-frame? |
227 | (frame-matcher proc closure?))) | |
c939b127 AW |
228 | (arg-check proc procedure?) |
229 | (arg-check next-handler procedure?) | |
230 | (arg-check exit-handler procedure?) | |
231 | (let () | |
232 | (define (next-hook frame) | |
f4a23f91 | 233 | (if (our-frame? frame) |
c939b127 AW |
234 | (next-handler frame))) |
235 | ||
236 | (define (enter frame) | |
972275ee | 237 | (add-hook! (vm-next-hook) next-hook) |
c939b127 AW |
238 | (if frame (next-hook frame))) |
239 | ||
240 | (define (exit frame) | |
241 | (exit-handler frame) | |
972275ee | 242 | (remove-hook! (vm-next-hook) next-hook)) |
c939b127 AW |
243 | |
244 | (trap-in-procedure proc enter exit | |
a222cbc9 | 245 | #:current-frame current-frame |
f4a23f91 | 246 | #:our-frame? our-frame?))) |
c939b127 AW |
247 | |
248 | (define (non-negative-integer? x) | |
249 | (and (number? x) (integer? x) (exact? x) (not (negative? x)))) | |
250 | ||
2c5fc8d0 AW |
251 | (define (positive-integer? x) |
252 | (and (number? x) (integer? x) (exact? x) (positive? x))) | |
253 | ||
c939b127 AW |
254 | (define (range? x) |
255 | (and (list? x) | |
256 | (and-map (lambda (x) | |
257 | (and (pair? x) | |
258 | (non-negative-integer? (car x)) | |
259 | (non-negative-integer? (cdr x)))) | |
260 | x))) | |
261 | ||
262 | (define (in-range? range i) | |
263 | (or-map (lambda (bounds) | |
262ce911 AW |
264 | (and (<= (car bounds) i) |
265 | (< i (cdr bounds)))) | |
c939b127 AW |
266 | range)) |
267 | ||
268 | ;; Building on trap-instructions-in-procedure, we have | |
df067433 | 269 | ;; trap-at-procedure-ip-in-range. |
c939b127 AW |
270 | ;; |
271 | (define* (trap-at-procedure-ip-in-range proc range handler | |
a222cbc9 | 272 | #:key current-frame (closure? #f) |
f4a23f91 AW |
273 | (our-frame? |
274 | (frame-matcher proc closure?))) | |
c939b127 AW |
275 | (arg-check proc procedure?) |
276 | (arg-check range range?) | |
277 | (arg-check handler procedure?) | |
6e197f3d AW |
278 | (let ((fp-stack '())) |
279 | (define (cull-frames! fp) | |
280 | (let lp ((frames fp-stack)) | |
281 | (if (and (pair? frames) (< (car frames) fp)) | |
282 | (lp (cdr frames)) | |
283 | (set! fp-stack frames)))) | |
284 | ||
c939b127 | 285 | (define (next-handler frame) |
6e197f3d AW |
286 | (let ((fp (frame-address frame)) |
287 | (ip (frame-instruction-pointer frame))) | |
288 | (cull-frames! fp) | |
289 | (let ((now-in-range? (in-range? range ip)) | |
290 | (was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp)))) | |
291 | (cond | |
292 | (was-in-range? | |
293 | (if (not now-in-range?) | |
294 | (set! fp-stack (cdr fp-stack)))) | |
295 | (now-in-range? | |
296 | (set! fp-stack (cons fp fp-stack)) | |
297 | (handler frame)))))) | |
c939b127 AW |
298 | |
299 | (define (exit-handler frame) | |
6e197f3d AW |
300 | (if (and (pair? fp-stack) |
301 | (= (car fp-stack) (frame-address frame))) | |
302 | (set! fp-stack (cdr fp-stack)))) | |
c939b127 AW |
303 | |
304 | (trap-instructions-in-procedure proc next-handler exit-handler | |
a222cbc9 | 305 | #:current-frame current-frame |
f4a23f91 | 306 | #:our-frame? our-frame?))) |
c939b127 | 307 | |
c939b127 | 308 | (define (program-sources-by-line proc file) |
e391f179 | 309 | (cond |
0bd1e9c6 | 310 | ((program? proc) |
d1100525 | 311 | (let ((code (program-code proc))) |
e391f179 AW |
312 | (let lp ((sources (program-sources proc)) |
313 | (out '())) | |
314 | (if (pair? sources) | |
315 | (lp (cdr sources) | |
316 | (pmatch (car sources) | |
317 | ((,start-ip ,start-file ,start-line . ,start-col) | |
318 | (if (equal? start-file file) | |
319 | (acons start-line | |
320 | (if (pair? (cdr sources)) | |
321 | (pmatch (cadr sources) | |
322 | ((,end-ip . _) | |
323 | (cons (+ start-ip code) | |
324 | (+ end-ip code))) | |
325 | (else (error "unexpected"))) | |
326 | (cons (+ start-ip code) | |
327 | (program-last-ip proc))) | |
328 | out) | |
329 | out)) | |
330 | (else (error "unexpected")))) | |
331 | (let ((alist '())) | |
332 | (for-each | |
333 | (lambda (pair) | |
334 | (set! alist | |
335 | (assv-set! alist (car pair) | |
336 | (cons (cdr pair) | |
337 | (or (assv-ref alist (car pair)) | |
338 | '()))))) | |
339 | out) | |
340 | (sort! alist (lambda (x y) (< (car x) (car y)))) | |
341 | alist))))) | |
342 | (else '()))) | |
c939b127 AW |
343 | |
344 | (define (source->ip-range proc file line) | |
345 | (or (or-map (lambda (line-and-ranges) | |
346 | (cond | |
347 | ((= (car line-and-ranges) line) | |
348 | (cdr line-and-ranges)) | |
349 | ((> (car line-and-ranges) line) | |
350 | (warn "no instructions found at" file ":" line | |
351 | "; using line" (car line-and-ranges) "instead") | |
352 | (cdr line-and-ranges)) | |
353 | (else #f))) | |
354 | (program-sources-by-line proc file)) | |
355 | (begin | |
356 | (warn "no instructions found for" file ":" line) | |
357 | '()))) | |
358 | ||
f4a23f91 AW |
359 | (define (source-closures-or-procedures file line) |
360 | (let ((closures (source-closures file line))) | |
361 | (if (pair? closures) | |
362 | (values closures #t) | |
363 | (values (source-procedures file line) #f)))) | |
364 | ||
c939b127 | 365 | ;; Building on trap-on-instructions-in-procedure, we have |
2c5fc8d0 AW |
366 | ;; trap-at-source-location. The parameter `user-line' is one-indexed, as |
367 | ;; a user counts lines, instead of zero-indexed, as Guile counts lines. | |
c939b127 | 368 | ;; |
a222cbc9 | 369 | (define* (trap-at-source-location file user-line handler #:key current-frame) |
c939b127 | 370 | (arg-check file string?) |
2c5fc8d0 | 371 | (arg-check user-line positive-integer?) |
c939b127 AW |
372 | (arg-check handler procedure?) |
373 | (let ((traps #f)) | |
f4a23f91 | 374 | (call-with-values |
2c5fc8d0 | 375 | (lambda () (source-closures-or-procedures file (1- user-line))) |
f4a23f91 AW |
376 | (lambda (procs closures?) |
377 | (new-enabled-trap | |
a222cbc9 | 378 | current-frame |
f4a23f91 AW |
379 | (lambda (frame) |
380 | (set! traps | |
381 | (map | |
382 | (lambda (proc) | |
2c5fc8d0 | 383 | (let ((range (source->ip-range proc file (1- user-line)))) |
f4a23f91 AW |
384 | (trap-at-procedure-ip-in-range proc range handler |
385 | #:current-frame current-frame | |
f4a23f91 AW |
386 | #:closure? closures?))) |
387 | procs)) | |
388 | (if (null? traps) | |
2c5fc8d0 | 389 | (error "No procedures found at ~a:~a." file user-line))) |
f4a23f91 AW |
390 | (lambda (frame) |
391 | (for-each (lambda (trap) (trap frame)) traps) | |
392 | (set! traps #f))))))) | |
1bc1800f AW |
393 | |
394 | \f | |
395 | ||
396 | ;; On a different tack, now we're going to build up a set of traps that | |
397 | ;; do useful things during the dynamic extent of a procedure's | |
398 | ;; application. First, a trap for when a frame returns. | |
399 | ;; | |
a222cbc9 | 400 | (define (trap-frame-finish frame return-handler abort-handler) |
1bc1800f AW |
401 | (arg-check frame frame?) |
402 | (arg-check return-handler procedure?) | |
403 | (arg-check abort-handler procedure?) | |
8dde88e0 | 404 | (let ((fp (frame-address frame))) |
c850a0ff | 405 | (define (pop-cont-hook frame . values) |
ae4d761f | 406 | (if (and fp (< (frame-address frame) fp)) |
1bc1800f AW |
407 | (begin |
408 | (set! fp #f) | |
c850a0ff | 409 | (apply return-handler frame values)))) |
1bc1800f | 410 | |
c850a0ff | 411 | (define (abort-hook frame . values) |
8dde88e0 | 412 | (if (and fp (< (frame-address frame) fp)) |
1bc1800f AW |
413 | (begin |
414 | (set! fp #f) | |
c850a0ff | 415 | (apply abort-handler frame values)))) |
1bc1800f AW |
416 | |
417 | (new-enabled-trap | |
a222cbc9 | 418 | frame |
1bc1800f AW |
419 | (lambda (frame) |
420 | (if (not fp) | |
421 | (error "return-or-abort traps may only be enabled once")) | |
972275ee | 422 | (add-hook! (vm-pop-continuation-hook) pop-cont-hook) |
f689dd69 | 423 | (add-hook! (vm-abort-continuation-hook) abort-hook)) |
1bc1800f AW |
424 | (lambda (frame) |
425 | (set! fp #f) | |
972275ee | 426 | (remove-hook! (vm-pop-continuation-hook) pop-cont-hook) |
f689dd69 | 427 | (remove-hook! (vm-abort-continuation-hook) abort-hook))))) |
1bc1800f AW |
428 | |
429 | ;; A more traditional dynamic-wind trap. Perhaps this should not be | |
430 | ;; based on the above trap-frame-finish? | |
431 | ;; | |
432 | (define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler | |
a222cbc9 | 433 | #:key current-frame (closure? #f) |
f4a23f91 | 434 | (our-frame? (frame-matcher proc closure?))) |
1bc1800f AW |
435 | (arg-check proc procedure?) |
436 | (arg-check enter-handler procedure?) | |
437 | (arg-check return-handler procedure?) | |
438 | (arg-check abort-handler procedure?) | |
439 | (let ((exit-trap #f)) | |
c850a0ff | 440 | (define (return-hook frame . values) |
1bc1800f AW |
441 | (exit-trap frame) ; disable the return/abort trap. |
442 | (set! exit-trap #f) | |
443 | (return-handler frame)) | |
444 | ||
c850a0ff | 445 | (define (abort-hook frame . values) |
1bc1800f AW |
446 | (exit-trap frame) ; disable the return/abort trap. |
447 | (set! exit-trap #f) | |
448 | (abort-handler frame)) | |
449 | ||
450 | (define (apply-hook frame) | |
f4a23f91 | 451 | (if (and (not exit-trap) (our-frame? frame)) |
1bc1800f AW |
452 | (begin |
453 | (enter-handler frame) | |
454 | (set! exit-trap | |
a222cbc9 | 455 | (trap-frame-finish frame return-hook abort-hook))))) |
1bc1800f AW |
456 | |
457 | (new-enabled-trap | |
a222cbc9 | 458 | current-frame |
1bc1800f | 459 | (lambda (frame) |
972275ee | 460 | (add-hook! (vm-apply-hook) apply-hook)) |
1bc1800f AW |
461 | (lambda (frame) |
462 | (if exit-trap | |
463 | (abort-hook frame)) | |
464 | (set! exit-trap #f) | |
972275ee | 465 | (remove-hook! (vm-apply-hook) apply-hook))))) |
1bc1800f AW |
466 | |
467 | ;; Trapping all procedure calls within a dynamic extent, recording the | |
468 | ;; depth of the call stack relative to the original procedure. | |
469 | ;; | |
470 | (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler | |
a222cbc9 | 471 | #:key current-frame (closure? #f) |
f4a23f91 AW |
472 | (our-frame? |
473 | (frame-matcher proc closure?))) | |
1bc1800f AW |
474 | (arg-check proc procedure?) |
475 | (arg-check apply-handler procedure?) | |
476 | (arg-check return-handler procedure?) | |
477 | (let ((*call-depth* 0)) | |
478 | (define (trace-push frame) | |
479 | (set! *call-depth* (1+ *call-depth*))) | |
480 | ||
c850a0ff AW |
481 | (define (trace-pop frame . values) |
482 | (apply return-handler frame *call-depth* values) | |
1bc1800f AW |
483 | (set! *call-depth* (1- *call-depth*))) |
484 | ||
485 | (define (trace-apply frame) | |
486 | (apply-handler frame *call-depth*)) | |
487 | ||
488 | ;; FIXME: recalc depth on abort | |
489 | ||
490 | (define (enter frame) | |
972275ee AW |
491 | (add-hook! (vm-push-continuation-hook) trace-push) |
492 | (add-hook! (vm-pop-continuation-hook) trace-pop) | |
493 | (add-hook! (vm-apply-hook) trace-apply)) | |
1bc1800f AW |
494 | |
495 | (define (leave frame) | |
972275ee AW |
496 | (remove-hook! (vm-push-continuation-hook) trace-push) |
497 | (remove-hook! (vm-pop-continuation-hook) trace-pop) | |
498 | (remove-hook! (vm-apply-hook) trace-apply)) | |
1bc1800f AW |
499 | |
500 | (define (return frame) | |
501 | (leave frame)) | |
502 | ||
503 | (define (abort frame) | |
504 | (leave frame)) | |
505 | ||
506 | (trap-in-dynamic-extent proc enter return abort | |
a222cbc9 | 507 | #:current-frame current-frame |
f4a23f91 | 508 | #:our-frame? our-frame?))) |
1bc1800f AW |
509 | |
510 | ;; Trapping all retired intructions within a dynamic extent. | |
511 | ;; | |
512 | (define* (trap-instructions-in-dynamic-extent proc next-handler | |
a222cbc9 | 513 | #:key current-frame (closure? #f) |
f4a23f91 AW |
514 | (our-frame? |
515 | (frame-matcher proc closure?))) | |
1bc1800f AW |
516 | (arg-check proc procedure?) |
517 | (arg-check next-handler procedure?) | |
518 | (let () | |
519 | (define (trace-next frame) | |
520 | (next-handler frame)) | |
521 | ||
522 | (define (enter frame) | |
972275ee | 523 | (add-hook! (vm-next-hook) trace-next)) |
1bc1800f AW |
524 | |
525 | (define (leave frame) | |
972275ee | 526 | (remove-hook! (vm-next-hook) trace-next)) |
1bc1800f AW |
527 | |
528 | (define (return frame) | |
529 | (leave frame)) | |
530 | ||
531 | (define (abort frame) | |
532 | (leave frame)) | |
533 | ||
534 | (trap-in-dynamic-extent proc enter return abort | |
a222cbc9 | 535 | #:current-frame current-frame |
f4a23f91 | 536 | #:our-frame? our-frame?))) |
8dde88e0 AW |
537 | |
538 | ;; Traps calls and returns for a given procedure, keeping track of the call depth. | |
539 | ;; | |
a222cbc9 | 540 | (define (trap-calls-to-procedure proc apply-handler return-handler) |
8dde88e0 AW |
541 | (arg-check proc procedure?) |
542 | (arg-check apply-handler procedure?) | |
543 | (arg-check return-handler procedure?) | |
544 | (let ((pending-finish-traps '()) | |
545 | (last-fp #f)) | |
546 | (define (apply-hook frame) | |
547 | (let ((depth (length pending-finish-traps))) | |
548 | ||
549 | (apply-handler frame depth) | |
550 | ||
ae4d761f | 551 | (if (not (eqv? (frame-address frame) last-fp)) |
8dde88e0 AW |
552 | (let ((finish-trap #f)) |
553 | (define (frame-finished frame) | |
554 | (finish-trap frame) ;; disables the trap. | |
555 | (set! pending-finish-traps | |
556 | (delq finish-trap pending-finish-traps)) | |
557 | (set! finish-trap #f)) | |
558 | ||
c850a0ff | 559 | (define (return-hook frame . values) |
8dde88e0 | 560 | (frame-finished frame) |
c850a0ff | 561 | (apply return-handler frame depth values)) |
8dde88e0 AW |
562 | |
563 | ;; FIXME: abort handler? | |
c850a0ff | 564 | (define (abort-hook frame . values) |
8dde88e0 AW |
565 | (frame-finished frame)) |
566 | ||
567 | (set! finish-trap | |
a222cbc9 | 568 | (trap-frame-finish frame return-hook abort-hook)) |
8dde88e0 AW |
569 | (set! pending-finish-traps |
570 | (cons finish-trap pending-finish-traps)))))) | |
571 | ||
572 | ;; The basic idea is that we install one trap that fires for calls, | |
573 | ;; but that each call installs its own finish trap. Those finish | |
574 | ;; traps remove themselves as their frames finish or abort. | |
575 | ;; | |
576 | ;; However since to the outside world we present the interface of | |
577 | ;; just being one trap, disabling this calls-to-procedure trap | |
578 | ;; should take care of disabling all of the pending finish traps. We | |
579 | ;; keep track of pending traps through the pending-finish-traps | |
580 | ;; list. | |
581 | ;; | |
582 | ;; So since we know that the trap-at-procedure will be enabled, and | |
583 | ;; thus returning a disable closure, we make sure to wrap that | |
584 | ;; closure in something that will disable pending finish traps. | |
585 | (define (with-pending-finish-disablers trap) | |
586 | (define (with-pending-finish-enablers trap) | |
587 | (lambda* (#:optional frame) | |
588 | (with-pending-finish-disablers (trap frame)))) | |
589 | ||
590 | (lambda* (#:optional frame) | |
591 | (for-each (lambda (disable) (disable frame)) | |
592 | pending-finish-traps) | |
593 | (set! pending-finish-traps '()) | |
594 | (with-pending-finish-enablers (trap frame)))) | |
595 | ||
596 | (with-pending-finish-disablers | |
a222cbc9 | 597 | (trap-at-procedure-call proc apply-hook)))) |
439e032b AW |
598 | |
599 | ;; Trap when the source location changes. | |
600 | ;; | |
a222cbc9 | 601 | (define (trap-matching-instructions frame-pred handler) |
439e032b AW |
602 | (arg-check frame-pred procedure?) |
603 | (arg-check handler procedure?) | |
604 | (let () | |
605 | (define (next-hook frame) | |
606 | (if (frame-pred frame) | |
607 | (handler frame))) | |
608 | ||
609 | (new-enabled-trap | |
a222cbc9 | 610 | #f |
439e032b | 611 | (lambda (frame) |
972275ee | 612 | (add-hook! (vm-next-hook) next-hook)) |
439e032b | 613 | (lambda (frame) |
972275ee | 614 | (remove-hook! (vm-next-hook) next-hook))))) |