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