diff options
author | Andy Wingo <wingo@pobox.com> | 2010-10-05 21:53:29 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-10-05 21:53:29 +0200 |
commit | df067433a537a5e12e2b06e5dc72e593b097316c (patch) | |
tree | 22981787a7f48ed3355c38eb4e4171bc67cc98f2 | |
parent | 6a4a1ef0f4d4f97f5b5c423c919bef4294a6e662 (diff) | |
download | guile-df067433a537a5e12e2b06e5dc72e593b097316c.tar.gz |
(system vm trap-state): add-trap-at-frame-finish!
* module/system/vm/traps.scm: Fix a comment.
* module/system/vm/trap-state.scm (<trap-state>): Add next-ephemeral-idx
slot.
(wrapper-at-index): Use eqv? instead of = to avoid type errors in user
inputs.
(next-ephemeral-index!, ephemeral-handler-for-index): New functions,
allocate ephemeral trap ids for functions to be called only once.
(add-trap-at-frame-finish!): New export, traps when a frame finishes.
-rw-r--r-- | module/system/vm/trap-state.scm | 35 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 2 |
2 files changed, 34 insertions, 3 deletions
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm index 02a4c8818..f45f98121 100644 --- a/module/system/vm/trap-state.scm +++ b/module/system/vm/trap-state.scm @@ -38,7 +38,8 @@ add-trap-at-procedure-call! add-trace-at-procedure-call! - add-trap-at-source-location!)) + add-trap-at-source-location! + add-trap-at-frame-finish!)) (define %default-trap-handler (make-fluid)) @@ -57,6 +58,7 @@ (define-record <trap-state> (handler default-trap-handler) (next-idx 0) + (next-ephemeral-idx -1) (wrappers '())) (define (trap-wrapper<? t1 t2) @@ -103,7 +105,7 @@ ((null? wrappers) (warn "no wrapper found with index in trap-state" idx) #f) - ((= (trap-wrapper-index (car wrappers)) idx) + ((eqv? (trap-wrapper-index (car wrappers)) idx) (car wrappers)) (else (lp (cdr wrappers)))))) @@ -113,6 +115,11 @@ (set! (trap-state-next-idx trap-state) (1+ idx)) idx)) +(define (next-ephemeral-index! trap-state) + (let ((idx (trap-state-next-ephemeral-idx trap-state))) + (set! (trap-state-next-ephemeral-idx trap-state) (1- idx)) + idx)) + (define (handler-for-index trap-state idx) (lambda (frame) (let ((wrapper (wrapper-at-index trap-state idx)) @@ -122,6 +129,16 @@ (trap-wrapper-index wrapper) (trap-wrapper-name wrapper)))))) +(define (ephemeral-handler-for-index trap-state idx handler) + (lambda (frame) + (let ((wrapper (wrapper-at-index trap-state idx))) + (if wrapper + (begin + (if (trap-wrapper-enabled? wrapper) + (disable-trap-wrapper! wrapper)) + (remove-trap-wrapper! trap-state wrapper) + (handler frame)))))) + ;;; @@ -221,6 +238,20 @@ idx #t trap (format #f "Breakpoint at ~a:~a" file user-line))))) +;; handler := frame -> nothing +(define* (add-trap-at-frame-finish! frame handler + #:optional (trap-state (the-trap-state))) + (let* ((idx (next-ephemeral-index! trap-state)) + (trap (trap-frame-finish + frame + (ephemeral-handler-for-index trap-state idx handler) + (lambda (frame) (delete-trap! idx trap-state))))) + (add-trap-wrapper! + trap-state + (make-trap-wrapper + idx #t trap + (format #f "Return from ~a" frame))))) + (define* (add-trap! trap name #:optional (trap-state (the-trap-state))) (let* ((idx (next-index! trap-state))) (add-trap-wrapper! diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index 3b2a43875..dfaedc584 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -268,7 +268,7 @@ range)) ;; Building on trap-instructions-in-procedure, we have -;; trap-instructions-in-procedure. +;; trap-at-procedure-ip-in-range. ;; (define* (trap-at-procedure-ip-in-range proc range handler #:key current-frame (vm (the-vm)) |