#:use-module (system vm debug)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:use-module (system vm instruction)
#:use-module (system xref)
#:use-module (rnrs bytevectors)
#:export (trap-at-procedure-call
(if (not (predicate? arg))
(error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
-(define (new-disabled-trap vm enable disable)
+(define (new-disabled-trap enable disable)
(let ((enabled? #f))
(define-syntax disabled?
(identifier-syntax
enable-trap))
-(define (new-enabled-trap vm frame enable disable)
- ((new-disabled-trap vm enable disable) frame))
+(define (new-enabled-trap frame enable disable)
+ ((new-disabled-trap enable disable) frame))
;; Returns an absolute IP.
(define (program-last-ip prog)
- (let ((pdi (find-program-debug-info (rtl-program-code prog))))
+ (let ((pdi (find-program-debug-info (program-code prog))))
(and pdi (program-debug-info-size pdi))))
(define (frame-matcher proc match-code?)
- (if match-code?
- (if (program? proc)
- (let ((start (rtl-program-code proc))
- (end (program-last-ip proc)))
- (lambda (frame)
- (let ((ip (frame-instruction-pointer frame)))
- (and (<= start ip) (< ip end)))))
- (lambda (frame) #f))
- (lambda (frame)
- (eq? (frame-procedure frame) proc))))
+ (let ((proc (if (struct? proc)
+ (procedure proc)
+ proc)))
+ (if match-code?
+ (if (program? proc)
+ (let ((start (program-code proc))
+ (end (program-last-ip proc)))
+ (lambda (frame)
+ (let ((ip (frame-instruction-pointer frame)))
+ (and (<= start ip) (< ip end)))))
+ (lambda (frame) #f))
+ (lambda (frame)
+ (eq? (frame-procedure frame) proc)))))
;; A basic trap, fires when a procedure is called.
;;
-(define* (trap-at-procedure-call proc handler #:key (vm (the-vm))
- (closure? #f)
+(define* (trap-at-procedure-call proc handler #:key (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check handler procedure?)
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; A more complicated trap, traps when control enters a procedure.
;;
;; * An abort.
;;
(define* (trap-in-procedure proc enter-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
(if (our-frame? frame)
(enter-proc frame)))
- (define (restore-hook frame)
- (if in-proc?
- (exit-proc frame))
- (if (our-frame? frame)
- (enter-proc frame)))
-
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook)
- (add-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) restore-hook)
+ (add-hook! (vm-apply-hook) apply-hook)
+ (add-hook! (vm-push-continuation-hook) push-cont-hook)
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook)
(if (and frame (our-frame? frame))
(enter-proc frame)))
(lambda (frame)
(if in-proc?
(exit-proc frame))
- (remove-hook! (vm-apply-hook vm) apply-hook)
- (remove-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) restore-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)
+ (remove-hook! (vm-push-continuation-hook) push-cont-hook)
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;;
(define* (trap-instructions-in-procedure proc next-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
(next-handler frame)))
(define (enter frame)
- (add-hook! (vm-next-hook vm) next-hook)
+ (add-hook! (vm-next-hook) next-hook)
(if frame (next-hook frame)))
(define (exit frame)
(exit-handler frame)
- (remove-hook! (vm-next-hook vm) next-hook))
+ (remove-hook! (vm-next-hook) next-hook))
(trap-in-procedure proc enter exit
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (non-negative-integer? x)
;; trap-at-procedure-ip-in-range.
;;
(define* (trap-at-procedure-ip-in-range proc range handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
(set! fp-stack (cdr fp-stack))))
(trap-instructions-in-procedure proc next-handler exit-handler
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (program-sources-by-line proc file)
(cond
((program? proc)
- (let ((code (rtl-program-code proc)))
+ (let ((code (program-code proc)))
(let lp ((sources (program-sources proc))
(out '()))
(if (pair? sources)
;; trap-at-source-location. The parameter `user-line' is one-indexed, as
;; a user counts lines, instead of zero-indexed, as Guile counts lines.
;;
-(define* (trap-at-source-location file user-line handler
- #:key current-frame (vm (the-vm)))
+(define* (trap-at-source-location file user-line handler #:key current-frame)
(arg-check file string?)
(arg-check user-line positive-integer?)
(arg-check handler procedure?)
(lambda () (source-closures-or-procedures file (1- user-line)))
(lambda (procs closures?)
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
(set! traps
(map
(let ((range (source->ip-range proc file (1- user-line))))
(trap-at-procedure-ip-in-range proc range handler
#:current-frame current-frame
- #:vm vm
#:closure? closures?)))
procs))
(if (null? traps)
;; do useful things during the dynamic extent of a procedure's
;; application. First, a trap for when a frame returns.
;;
-(define* (trap-frame-finish frame return-handler abort-handler
- #:key (vm (the-vm)))
+(define (trap-frame-finish frame return-handler abort-handler)
(arg-check frame frame?)
(arg-check return-handler procedure?)
(arg-check abort-handler procedure?)
(apply abort-handler frame values))))
(new-enabled-trap
- vm frame
+ frame
(lambda (frame)
(if (not fp)
(error "return-or-abort traps may only be enabled once"))
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) abort-hook))
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook))
(lambda (frame)
(set! fp #f)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
;; A more traditional dynamic-wind trap. Perhaps this should not be
;; based on the above trap-frame-finish?
;;
(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
(begin
(enter-handler frame)
(set! exit-trap
- (trap-frame-finish frame return-hook abort-hook
- #:vm vm)))))
+ (trap-frame-finish frame return-hook abort-hook)))))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
(if exit-trap
(abort-hook frame))
(set! exit-trap #f)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; Trapping all procedure calls within a dynamic extent, recording the
;; depth of the call stack relative to the original procedure.
;;
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
;; FIXME: recalc depth on abort
(define (enter frame)
- (add-hook! (vm-push-continuation-hook vm) trace-push)
- (add-hook! (vm-pop-continuation-hook vm) trace-pop)
- (add-hook! (vm-apply-hook vm) trace-apply))
+ (add-hook! (vm-push-continuation-hook) trace-push)
+ (add-hook! (vm-pop-continuation-hook) trace-pop)
+ (add-hook! (vm-apply-hook) trace-apply))
(define (leave frame)
- (remove-hook! (vm-push-continuation-hook vm) trace-push)
- (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
- (remove-hook! (vm-apply-hook vm) trace-apply))
+ (remove-hook! (vm-push-continuation-hook) trace-push)
+ (remove-hook! (vm-pop-continuation-hook) trace-pop)
+ (remove-hook! (vm-apply-hook) trace-apply))
(define (return frame)
(leave frame))
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Trapping all retired intructions within a dynamic extent.
;;
(define* (trap-instructions-in-dynamic-extent proc next-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
(next-handler frame))
(define (enter frame)
- (add-hook! (vm-next-hook vm) trace-next))
+ (add-hook! (vm-next-hook) trace-next))
(define (leave frame)
- (remove-hook! (vm-next-hook vm) trace-next))
+ (remove-hook! (vm-next-hook) trace-next))
(define (return frame)
(leave frame))
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Traps calls and returns for a given procedure, keeping track of the call depth.
;;
-(define* (trap-calls-to-procedure proc apply-handler return-handler
- #:key (vm (the-vm)))
+(define (trap-calls-to-procedure proc apply-handler return-handler)
(arg-check proc procedure?)
(arg-check apply-handler procedure?)
(arg-check return-handler procedure?)
(frame-finished frame))
(set! finish-trap
- (trap-frame-finish frame return-hook abort-hook #:vm vm))
+ (trap-frame-finish frame return-hook abort-hook))
(set! pending-finish-traps
(cons finish-trap pending-finish-traps))))))
(with-pending-finish-enablers (trap frame))))
(with-pending-finish-disablers
- (trap-at-procedure-call proc apply-hook #:vm vm))))
+ (trap-at-procedure-call proc apply-hook))))
;; Trap when the source location changes.
;;
-(define* (trap-matching-instructions frame-pred handler
- #:key (vm (the-vm)))
+(define (trap-matching-instructions frame-pred handler)
(arg-check frame-pred procedure?)
(arg-check handler procedure?)
(let ()
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-next-hook vm) next-hook))
+ (add-hook! (vm-next-hook) next-hook))
(lambda (frame)
- (remove-hook! (vm-next-hook vm) next-hook)))))
+ (remove-hook! (vm-next-hook) next-hook)))))
HCoop / bpt / guile.git / blobdiff