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