* 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.
add-trap-at-procedure-call!
add-trace-at-procedure-call!
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))
(define %default-trap-handler (make-fluid))
(define-record <trap-state>
(handler default-trap-handler)
(next-idx 0)
(define-record <trap-state>
(handler default-trap-handler)
(next-idx 0)
+ (next-ephemeral-idx -1)
(wrappers '()))
(define (trap-wrapper<? t1 t2)
(wrappers '()))
(define (trap-wrapper<? t1 t2)
((null? wrappers)
(warn "no wrapper found with index in trap-state" idx)
#f)
((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))))))
(car wrappers))
(else
(lp (cdr wrappers))))))
(set! (trap-state-next-idx trap-state) (1+ idx))
idx))
(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))
(define (handler-for-index trap-state idx)
(lambda (frame)
(let ((wrapper (wrapper-at-index trap-state idx))
(trap-wrapper-index wrapper)
(trap-wrapper-name wrapper))))))
(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))))))
+
idx #t trap
(format #f "Breakpoint at ~a:~a" file user-line)))))
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!
(define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
(let* ((idx (next-index! trap-state)))
(add-trap-wrapper!
range))
;; Building on trap-instructions-in-procedure, we have
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))
;;
(define* (trap-at-procedure-ip-in-range proc range handler
#:key current-frame (vm (the-vm))