Commit | Line | Data |
---|---|---|
c939b127 AW |
1 | ;;; Traps: stepping, breakpoints, and such. |
2 | ||
ac371963 | 3 | ;; Copyright (C) 2010, 2012, 2013 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?) | |
116 | (if match-code? | |
0bd1e9c6 | 117 | (if (program? proc) |
d1100525 | 118 | (let ((start (program-code proc)) |
e391f179 AW |
119 | (end (program-last-ip proc))) |
120 | (lambda (frame) | |
121 | (let ((ip (frame-instruction-pointer frame))) | |
122 | (and (<= start ip) (< ip end))))) | |
123 | (lambda (frame) #f)) | |
f4a23f91 AW |
124 | (lambda (frame) |
125 | (eq? (frame-procedure frame) proc)))) | |
126 | ||
c939b127 AW |
127 | ;; A basic trap, fires when a procedure is called. |
128 | ;; | |
a222cbc9 | 129 | (define* (trap-at-procedure-call proc handler #:key (closure? #f) |
f4a23f91 | 130 | (our-frame? (frame-matcher proc closure?))) |
c939b127 AW |
131 | (arg-check proc procedure?) |
132 | (arg-check handler procedure?) | |
133 | (let () | |
134 | (define (apply-hook frame) | |
f4a23f91 | 135 | (if (our-frame? frame) |
c939b127 AW |
136 | (handler frame))) |
137 | ||
138 | (new-enabled-trap | |
a222cbc9 | 139 | #f |
c939b127 | 140 | (lambda (frame) |
972275ee | 141 | (add-hook! (vm-apply-hook) apply-hook)) |
c939b127 | 142 | (lambda (frame) |
972275ee | 143 | (remove-hook! (vm-apply-hook) apply-hook))))) |
c939b127 AW |
144 | |
145 | ;; A more complicated trap, traps when control enters a procedure. | |
146 | ;; | |
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 | |
151 | ;; procedure. | |
152 | ;; | |
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. | |
157 | ;; * An abort. | |
158 | ;; | |
159 | (define* (trap-in-procedure proc enter-handler exit-handler | |
a222cbc9 | 160 | #:key current-frame (closure? #f) |
f4a23f91 | 161 | (our-frame? (frame-matcher proc closure?))) |
c939b127 AW |
162 | (arg-check proc procedure?) |
163 | (arg-check enter-handler procedure?) | |
164 | (arg-check exit-handler procedure?) | |
165 | (let ((in-proc? #f)) | |
166 | (define (enter-proc frame) | |
167 | (if in-proc? | |
168 | (warn "already in proc" frame) | |
169 | (begin | |
170 | (enter-handler frame) | |
171 | (set! in-proc? #t)))) | |
172 | ||
173 | (define (exit-proc frame) | |
174 | (if in-proc? | |
175 | (begin | |
176 | (exit-handler frame) | |
177 | (set! in-proc? #f)) | |
178 | (warn "not in proc" frame))) | |
179 | ||
180 | (define (apply-hook frame) | |
181 | (if in-proc? | |
182 | (exit-proc frame)) | |
f4a23f91 | 183 | (if (our-frame? frame) |
c939b127 AW |
184 | (enter-proc frame))) |
185 | ||
186 | (define (push-cont-hook frame) | |
187 | (if in-proc? | |
188 | (exit-proc frame))) | |
189 | ||
c850a0ff | 190 | (define (pop-cont-hook frame . values) |
c939b127 AW |
191 | (if in-proc? |
192 | (exit-proc frame)) | |
f4a23f91 | 193 | (if (our-frame? (frame-previous frame)) |
262ce911 | 194 | (enter-proc (frame-previous frame)))) |
c939b127 | 195 | |
c850a0ff | 196 | (define (abort-hook frame . values) |
c939b127 AW |
197 | (if in-proc? |
198 | (exit-proc frame)) | |
f4a23f91 | 199 | (if (our-frame? frame) |
c939b127 AW |
200 | (enter-proc frame))) |
201 | ||
c939b127 | 202 | (new-enabled-trap |
a222cbc9 | 203 | current-frame |
c939b127 | 204 | (lambda (frame) |
972275ee AW |
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) | |
f4a23f91 | 209 | (if (and frame (our-frame? frame)) |
c939b127 AW |
210 | (enter-proc frame))) |
211 | (lambda (frame) | |
212 | (if in-proc? | |
213 | (exit-proc frame)) | |
972275ee AW |
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) | |
f689dd69 | 217 | (remove-hook! (vm-abort-continuation-hook) abort-hook))))) |
c939b127 AW |
218 | |
219 | ;; Building on trap-in-procedure, we have trap-instructions-in-procedure | |
220 | ;; | |
221 | (define* (trap-instructions-in-procedure proc next-handler exit-handler | |
a222cbc9 | 222 | #:key current-frame (closure? #f) |
f4a23f91 AW |
223 | (our-frame? |
224 | (frame-matcher proc closure?))) | |
c939b127 AW |
225 | (arg-check proc procedure?) |
226 | (arg-check next-handler procedure?) | |
227 | (arg-check exit-handler procedure?) | |
228 | (let () | |
229 | (define (next-hook frame) | |
f4a23f91 | 230 | (if (our-frame? frame) |
c939b127 AW |
231 | (next-handler frame))) |
232 | ||
233 | (define (enter frame) | |
972275ee | 234 | (add-hook! (vm-next-hook) next-hook) |
c939b127 AW |
235 | (if frame (next-hook frame))) |
236 | ||
237 | (define (exit frame) | |
238 | (exit-handler frame) | |
972275ee | 239 | (remove-hook! (vm-next-hook) next-hook)) |
c939b127 AW |
240 | |
241 | (trap-in-procedure proc enter exit | |
a222cbc9 | 242 | #:current-frame current-frame |
f4a23f91 | 243 | #:our-frame? our-frame?))) |
c939b127 AW |
244 | |
245 | (define (non-negative-integer? x) | |
246 | (and (number? x) (integer? x) (exact? x) (not (negative? x)))) | |
247 | ||
2c5fc8d0 AW |
248 | (define (positive-integer? x) |
249 | (and (number? x) (integer? x) (exact? x) (positive? x))) | |
250 | ||
c939b127 AW |
251 | (define (range? x) |
252 | (and (list? x) | |
253 | (and-map (lambda (x) | |
254 | (and (pair? x) | |
255 | (non-negative-integer? (car x)) | |
256 | (non-negative-integer? (cdr x)))) | |
257 | x))) | |
258 | ||
259 | (define (in-range? range i) | |
260 | (or-map (lambda (bounds) | |
262ce911 AW |
261 | (and (<= (car bounds) i) |
262 | (< i (cdr bounds)))) | |
c939b127 AW |
263 | range)) |
264 | ||
265 | ;; Building on trap-instructions-in-procedure, we have | |
df067433 | 266 | ;; trap-at-procedure-ip-in-range. |
c939b127 AW |
267 | ;; |
268 | (define* (trap-at-procedure-ip-in-range proc range handler | |
a222cbc9 | 269 | #:key current-frame (closure? #f) |
f4a23f91 AW |
270 | (our-frame? |
271 | (frame-matcher proc closure?))) | |
c939b127 AW |
272 | (arg-check proc procedure?) |
273 | (arg-check range range?) | |
274 | (arg-check handler procedure?) | |
6e197f3d AW |
275 | (let ((fp-stack '())) |
276 | (define (cull-frames! fp) | |
277 | (let lp ((frames fp-stack)) | |
278 | (if (and (pair? frames) (< (car frames) fp)) | |
279 | (lp (cdr frames)) | |
280 | (set! fp-stack frames)))) | |
281 | ||
c939b127 | 282 | (define (next-handler frame) |
6e197f3d AW |
283 | (let ((fp (frame-address frame)) |
284 | (ip (frame-instruction-pointer frame))) | |
285 | (cull-frames! fp) | |
286 | (let ((now-in-range? (in-range? range ip)) | |
287 | (was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp)))) | |
288 | (cond | |
289 | (was-in-range? | |
290 | (if (not now-in-range?) | |
291 | (set! fp-stack (cdr fp-stack)))) | |
292 | (now-in-range? | |
293 | (set! fp-stack (cons fp fp-stack)) | |
294 | (handler frame)))))) | |
c939b127 AW |
295 | |
296 | (define (exit-handler frame) | |
6e197f3d AW |
297 | (if (and (pair? fp-stack) |
298 | (= (car fp-stack) (frame-address frame))) | |
299 | (set! fp-stack (cdr fp-stack)))) | |
c939b127 AW |
300 | |
301 | (trap-instructions-in-procedure proc next-handler exit-handler | |
a222cbc9 | 302 | #:current-frame current-frame |
f4a23f91 | 303 | #:our-frame? our-frame?))) |
c939b127 | 304 | |
c939b127 | 305 | (define (program-sources-by-line proc file) |
e391f179 | 306 | (cond |
0bd1e9c6 | 307 | ((program? proc) |
d1100525 | 308 | (let ((code (program-code proc))) |
e391f179 AW |
309 | (let lp ((sources (program-sources proc)) |
310 | (out '())) | |
311 | (if (pair? sources) | |
312 | (lp (cdr sources) | |
313 | (pmatch (car sources) | |
314 | ((,start-ip ,start-file ,start-line . ,start-col) | |
315 | (if (equal? start-file file) | |
316 | (acons start-line | |
317 | (if (pair? (cdr sources)) | |
318 | (pmatch (cadr sources) | |
319 | ((,end-ip . _) | |
320 | (cons (+ start-ip code) | |
321 | (+ end-ip code))) | |
322 | (else (error "unexpected"))) | |
323 | (cons (+ start-ip code) | |
324 | (program-last-ip proc))) | |
325 | out) | |
326 | out)) | |
327 | (else (error "unexpected")))) | |
328 | (let ((alist '())) | |
329 | (for-each | |
330 | (lambda (pair) | |
331 | (set! alist | |
332 | (assv-set! alist (car pair) | |
333 | (cons (cdr pair) | |
334 | (or (assv-ref alist (car pair)) | |
335 | '()))))) | |
336 | out) | |
337 | (sort! alist (lambda (x y) (< (car x) (car y)))) | |
338 | alist))))) | |
339 | (else '()))) | |
c939b127 AW |
340 | |
341 | (define (source->ip-range proc file line) | |
342 | (or (or-map (lambda (line-and-ranges) | |
343 | (cond | |
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)) | |
350 | (else #f))) | |
351 | (program-sources-by-line proc file)) | |
352 | (begin | |
353 | (warn "no instructions found for" file ":" line) | |
354 | '()))) | |
355 | ||
f4a23f91 AW |
356 | (define (source-closures-or-procedures file line) |
357 | (let ((closures (source-closures file line))) | |
358 | (if (pair? closures) | |
359 | (values closures #t) | |
360 | (values (source-procedures file line) #f)))) | |
361 | ||
c939b127 | 362 | ;; Building on trap-on-instructions-in-procedure, we have |
2c5fc8d0 AW |
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. | |
c939b127 | 365 | ;; |
a222cbc9 | 366 | (define* (trap-at-source-location file user-line handler #:key current-frame) |
c939b127 | 367 | (arg-check file string?) |
2c5fc8d0 | 368 | (arg-check user-line positive-integer?) |
c939b127 AW |
369 | (arg-check handler procedure?) |
370 | (let ((traps #f)) | |
f4a23f91 | 371 | (call-with-values |
2c5fc8d0 | 372 | (lambda () (source-closures-or-procedures file (1- user-line))) |
f4a23f91 AW |
373 | (lambda (procs closures?) |
374 | (new-enabled-trap | |
a222cbc9 | 375 | current-frame |
f4a23f91 AW |
376 | (lambda (frame) |
377 | (set! traps | |
378 | (map | |
379 | (lambda (proc) | |
2c5fc8d0 | 380 | (let ((range (source->ip-range proc file (1- user-line)))) |
f4a23f91 AW |
381 | (trap-at-procedure-ip-in-range proc range handler |
382 | #:current-frame current-frame | |
f4a23f91 AW |
383 | #:closure? closures?))) |
384 | procs)) | |
385 | (if (null? traps) | |
2c5fc8d0 | 386 | (error "No procedures found at ~a:~a." file user-line))) |
f4a23f91 AW |
387 | (lambda (frame) |
388 | (for-each (lambda (trap) (trap frame)) traps) | |
389 | (set! traps #f))))))) | |
1bc1800f AW |
390 | |
391 | \f | |
392 | ||
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. | |
396 | ;; | |
a222cbc9 | 397 | (define (trap-frame-finish frame return-handler abort-handler) |
1bc1800f AW |
398 | (arg-check frame frame?) |
399 | (arg-check return-handler procedure?) | |
400 | (arg-check abort-handler procedure?) | |
8dde88e0 | 401 | (let ((fp (frame-address frame))) |
c850a0ff | 402 | (define (pop-cont-hook frame . values) |
8dde88e0 | 403 | (if (and fp (eq? (frame-address frame) fp)) |
1bc1800f AW |
404 | (begin |
405 | (set! fp #f) | |
c850a0ff | 406 | (apply return-handler frame values)))) |
1bc1800f | 407 | |
c850a0ff | 408 | (define (abort-hook frame . values) |
8dde88e0 | 409 | (if (and fp (< (frame-address frame) fp)) |
1bc1800f AW |
410 | (begin |
411 | (set! fp #f) | |
c850a0ff | 412 | (apply abort-handler frame values)))) |
1bc1800f AW |
413 | |
414 | (new-enabled-trap | |
a222cbc9 | 415 | frame |
1bc1800f AW |
416 | (lambda (frame) |
417 | (if (not fp) | |
418 | (error "return-or-abort traps may only be enabled once")) | |
972275ee | 419 | (add-hook! (vm-pop-continuation-hook) pop-cont-hook) |
f689dd69 | 420 | (add-hook! (vm-abort-continuation-hook) abort-hook)) |
1bc1800f AW |
421 | (lambda (frame) |
422 | (set! fp #f) | |
972275ee | 423 | (remove-hook! (vm-pop-continuation-hook) pop-cont-hook) |
f689dd69 | 424 | (remove-hook! (vm-abort-continuation-hook) abort-hook))))) |
1bc1800f AW |
425 | |
426 | ;; A more traditional dynamic-wind trap. Perhaps this should not be | |
427 | ;; based on the above trap-frame-finish? | |
428 | ;; | |
429 | (define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler | |
a222cbc9 | 430 | #:key current-frame (closure? #f) |
f4a23f91 | 431 | (our-frame? (frame-matcher proc closure?))) |
1bc1800f AW |
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)) | |
c850a0ff | 437 | (define (return-hook frame . values) |
1bc1800f AW |
438 | (exit-trap frame) ; disable the return/abort trap. |
439 | (set! exit-trap #f) | |
440 | (return-handler frame)) | |
441 | ||
c850a0ff | 442 | (define (abort-hook frame . values) |
1bc1800f AW |
443 | (exit-trap frame) ; disable the return/abort trap. |
444 | (set! exit-trap #f) | |
445 | (abort-handler frame)) | |
446 | ||
447 | (define (apply-hook frame) | |
f4a23f91 | 448 | (if (and (not exit-trap) (our-frame? frame)) |
1bc1800f AW |
449 | (begin |
450 | (enter-handler frame) | |
451 | (set! exit-trap | |
a222cbc9 | 452 | (trap-frame-finish frame return-hook abort-hook))))) |
1bc1800f AW |
453 | |
454 | (new-enabled-trap | |
a222cbc9 | 455 | current-frame |
1bc1800f | 456 | (lambda (frame) |
972275ee | 457 | (add-hook! (vm-apply-hook) apply-hook)) |
1bc1800f AW |
458 | (lambda (frame) |
459 | (if exit-trap | |
460 | (abort-hook frame)) | |
461 | (set! exit-trap #f) | |
972275ee | 462 | (remove-hook! (vm-apply-hook) apply-hook))))) |
1bc1800f AW |
463 | |
464 | ;; Trapping all procedure calls within a dynamic extent, recording the | |
465 | ;; depth of the call stack relative to the original procedure. | |
466 | ;; | |
467 | (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler | |
a222cbc9 | 468 | #:key current-frame (closure? #f) |
f4a23f91 AW |
469 | (our-frame? |
470 | (frame-matcher proc closure?))) | |
1bc1800f AW |
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*))) | |
477 | ||
c850a0ff AW |
478 | (define (trace-pop frame . values) |
479 | (apply return-handler frame *call-depth* values) | |
1bc1800f AW |
480 | (set! *call-depth* (1- *call-depth*))) |
481 | ||
482 | (define (trace-apply frame) | |
483 | (apply-handler frame *call-depth*)) | |
484 | ||
485 | ;; FIXME: recalc depth on abort | |
486 | ||
487 | (define (enter frame) | |
972275ee AW |
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)) | |
1bc1800f AW |
491 | |
492 | (define (leave frame) | |
972275ee AW |
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)) | |
1bc1800f AW |
496 | |
497 | (define (return frame) | |
498 | (leave frame)) | |
499 | ||
500 | (define (abort frame) | |
501 | (leave frame)) | |
502 | ||
503 | (trap-in-dynamic-extent proc enter return abort | |
a222cbc9 | 504 | #:current-frame current-frame |
f4a23f91 | 505 | #:our-frame? our-frame?))) |
1bc1800f AW |
506 | |
507 | ;; Trapping all retired intructions within a dynamic extent. | |
508 | ;; | |
509 | (define* (trap-instructions-in-dynamic-extent proc next-handler | |
a222cbc9 | 510 | #:key current-frame (closure? #f) |
f4a23f91 AW |
511 | (our-frame? |
512 | (frame-matcher proc closure?))) | |
1bc1800f AW |
513 | (arg-check proc procedure?) |
514 | (arg-check next-handler procedure?) | |
515 | (let () | |
516 | (define (trace-next frame) | |
517 | (next-handler frame)) | |
518 | ||
519 | (define (enter frame) | |
972275ee | 520 | (add-hook! (vm-next-hook) trace-next)) |
1bc1800f AW |
521 | |
522 | (define (leave frame) | |
972275ee | 523 | (remove-hook! (vm-next-hook) trace-next)) |
1bc1800f AW |
524 | |
525 | (define (return frame) | |
526 | (leave frame)) | |
527 | ||
528 | (define (abort frame) | |
529 | (leave frame)) | |
530 | ||
531 | (trap-in-dynamic-extent proc enter return abort | |
a222cbc9 | 532 | #:current-frame current-frame |
f4a23f91 | 533 | #:our-frame? our-frame?))) |
8dde88e0 AW |
534 | |
535 | ;; Traps calls and returns for a given procedure, keeping track of the call depth. | |
536 | ;; | |
a222cbc9 | 537 | (define (trap-calls-to-procedure proc apply-handler return-handler) |
8dde88e0 AW |
538 | (arg-check proc procedure?) |
539 | (arg-check apply-handler procedure?) | |
540 | (arg-check return-handler procedure?) | |
541 | (let ((pending-finish-traps '()) | |
542 | (last-fp #f)) | |
543 | (define (apply-hook frame) | |
544 | (let ((depth (length pending-finish-traps))) | |
545 | ||
546 | (apply-handler frame depth) | |
547 | ||
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)) | |
555 | ||
c850a0ff | 556 | (define (return-hook frame . values) |
8dde88e0 | 557 | (frame-finished frame) |
c850a0ff | 558 | (apply return-handler frame depth values)) |
8dde88e0 AW |
559 | |
560 | ;; FIXME: abort handler? | |
c850a0ff | 561 | (define (abort-hook frame . values) |
8dde88e0 AW |
562 | (frame-finished frame)) |
563 | ||
564 | (set! finish-trap | |
a222cbc9 | 565 | (trap-frame-finish frame return-hook abort-hook)) |
8dde88e0 AW |
566 | (set! pending-finish-traps |
567 | (cons finish-trap pending-finish-traps)))))) | |
568 | ||
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. | |
572 | ;; | |
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 | |
577 | ;; list. | |
578 | ;; | |
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)))) | |
586 | ||
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)))) | |
592 | ||
593 | (with-pending-finish-disablers | |
a222cbc9 | 594 | (trap-at-procedure-call proc apply-hook)))) |
439e032b AW |
595 | |
596 | ;; Trap when the source location changes. | |
597 | ;; | |
a222cbc9 | 598 | (define (trap-matching-instructions frame-pred handler) |
439e032b AW |
599 | (arg-check frame-pred procedure?) |
600 | (arg-check handler procedure?) | |
601 | (let () | |
602 | (define (next-hook frame) | |
603 | (if (frame-pred frame) | |
604 | (handler frame))) | |
605 | ||
606 | (new-enabled-trap | |
a222cbc9 | 607 | #f |
439e032b | 608 | (lambda (frame) |
972275ee | 609 | (add-hook! (vm-next-hook) next-hook)) |
439e032b | 610 | (lambda (frame) |
972275ee | 611 | (remove-hook! (vm-next-hook) next-hook))))) |