summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/vm/trace.scm119
-rw-r--r--module/system/vm/trap-state.scm6
-rw-r--r--module/system/vm/traps.scm148
3 files changed, 206 insertions, 67 deletions
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 17f6e8381..4b66738cf 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -24,18 +24,25 @@
#:use-module (system vm frame)
#:use-module (system vm program)
#:use-module (system vm objcode)
+ #:use-module (system vm traps)
#:use-module (rnrs bytevectors)
#:use-module (system vm instruction)
#:use-module (ice-9 format)
- #:export (vm-trace))
+ #:export (trace-calls-in-procedure
+ trace-instructions-in-procedure
+ vm-trace))
;; FIXME: this constant needs to go in system vm objcode
(define *objcode-header-len* 8)
-(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
- (define *call-depth* #f)
- (define *saved-call-depth* #f)
-
+(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm)))
+ (define (frame-return-values frame)
+ (let* ((len (frame-num-locals frame))
+ (nvalues (frame-local-ref frame (1- len))))
+ (map (lambda (i)
+ (frame-local-ref frame (+ (- len nvalues) i)))
+ (iota nvalues))))
+
(define (print-application frame depth)
(format (current-error-port) "~a~v:@y\n"
(make-string depth #\|)
@@ -56,70 +63,50 @@
(format (current-error-port) "~a~d values:~{ ~a~}\n"
(make-string depth #\|)
nvalues
- (let lp ((vals '()) (i 0))
- (if (= i nvalues)
- vals
- (lp (cons (format #f "~v:@y" width
- (frame-local-ref frame (- len 2 i)))
- vals)
- (1+ i)))))))))
-
- (define (trace-push frame)
- (if *call-depth*
- (set! *call-depth* (1+ *call-depth*))))
-
- (define (trace-pop frame)
- (if *call-depth*
- (begin
- (print-return frame *call-depth*)
- (set! *call-depth*
- (if (zero? *call-depth*)
- #f
- (1- *call-depth*))))))
+ (map (lambda (val)
+ (format #f "~v:@y" width val))
+ (frame-return-values frame)))))))
- (define (trace-apply frame)
- (cond
- (*call-depth*
- (print-application frame *call-depth*))
- ((eq? (frame-procedure frame) thunk)
- (set! *call-depth* 0))))
-
(define (trace-next frame)
- (if *call-depth*
- (let* ((ip (frame-instruction-pointer frame))
- (objcode (program-objcode (frame-procedure frame)))
- (opcode (bytevector-u8-ref (objcode->bytecode objcode)
- (+ ip *objcode-header-len*))))
- (format #t "~8d: ~a\n" ip (opcode->instruction opcode)))))
+ (let* ((ip (frame-instruction-pointer frame))
+ (objcode (program-objcode (frame-procedure frame)))
+ (opcode (bytevector-u8-ref (objcode->bytecode objcode)
+ (+ ip *objcode-header-len*))))
+ (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
- (define (vm-trace-on!)
- (if calls?
- (begin
- (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)))
-
- (if instructions?
- (add-hook! (vm-next-hook vm) trace-next))
+ (trap-calls-in-dynamic-extent proc print-application print-return
+ #:vm vm))
- (set-vm-trace-level! vm (1+ (vm-trace-level vm)))
- (set! *call-depth* *saved-call-depth*))
+(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm)))
+ (define (trace-next frame)
+ (let* ((ip (frame-instruction-pointer frame))
+ (objcode (program-objcode (frame-procedure frame)))
+ (opcode (bytevector-u8-ref (objcode->bytecode objcode)
+ (+ ip *objcode-header-len*))))
+ (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
- (define (vm-trace-off!)
- (set! *saved-call-depth* *call-depth*)
- (set! *call-depth* #f)
- (set-vm-trace-level! vm (1- (vm-trace-level vm)))
-
- (if calls?
- (begin
- (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)))
-
- (if instructions?
- (remove-hook! (vm-next-hook vm) trace-next)))
+ (trap-instructions-in-dynamic-extent proc trace-next
+ #:vm vm))
- (dynamic-wind
- vm-trace-on!
- (lambda () (vm-apply vm thunk '()))
- vm-trace-off!))
+;; Note that because this procedure manipulates the VM trace level
+;; directly, it doesn't compose well with traps at the REPL.
+;;
+(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
+ (let ((call-trap #f)
+ (inst-trap #f))
+ (dynamic-wind
+ (lambda ()
+ (if calls?
+ (set! call-trap
+ (trace-calls-in-procedure thunk #:vm vm #:width width)))
+ (if instructions?
+ (set! inst-trap
+ (trace-instructions-in-procedure thunk #:vm vm #:width width)))
+ (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+ thunk
+ (lambda ()
+ (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+ (if call-trap (call-trap))
+ (if inst-trap (inst-trap))
+ (set! call-trap #f)
+ (set! inst-trap #f)))))
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 326450058..1e9f9e689 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -188,3 +188,9 @@
(make-trap-wrapper
idx #t trap
(format #f "breakpoint at ~a" proc)))))
+
+(define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
+ (let* ((idx (next-index! trap-state)))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper idx #t trap name))))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index e568ad804..95db75433 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -66,7 +66,11 @@
trap-in-procedure
trap-instructions-in-procedure
trap-at-procedure-ip-in-range
- trap-at-source-location))
+ trap-at-source-location
+ trap-frame-finish
+ trap-in-dynamic-extent
+ trap-calls-in-dynamic-extent
+ trap-instructions-in-dynamic-extent))
(define-syntax arg-check
(syntax-rules ()
@@ -334,3 +338,145 @@
(lambda (frame)
(for-each (lambda (trap) (trap frame)) traps)
(set! traps #f)))))
+
+
+
+;; On a different tack, now we're going to build up a set of traps that
+;; 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)))
+ (arg-check frame frame?)
+ (arg-check return-handler procedure?)
+ (arg-check abort-handler procedure?)
+ (let ((fp (frame-dynamic-link frame)))
+ (define (pop-cont-hook frame)
+ (if (and fp (eq? (frame-dynamic-link frame) fp))
+ (begin
+ (set! fp #f)
+ (return-handler frame))))
+
+ (define (abort-hook frame)
+ (if (and fp (<= (frame-dynamic-link frame) fp))
+ (begin
+ (set! fp #f)
+ (abort-handler frame))))
+
+ (new-enabled-trap
+ vm 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))
+ (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)))))
+
+;; 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)))
+ (arg-check proc procedure?)
+ (arg-check enter-handler procedure?)
+ (arg-check return-handler procedure?)
+ (arg-check abort-handler procedure?)
+ (let ((exit-trap #f))
+ (define (return-hook frame)
+ (exit-trap frame) ; disable the return/abort trap.
+ (set! exit-trap #f)
+ (return-handler frame))
+
+ (define (abort-hook frame)
+ (exit-trap frame) ; disable the return/abort trap.
+ (set! exit-trap #f)
+ (abort-handler frame))
+
+ (define (apply-hook frame)
+ (if (and (not exit-trap)
+ (eq? (frame-procedure frame) proc))
+ (begin
+ (enter-handler frame)
+ (set! exit-trap
+ (trap-frame-finish frame return-hook abort-hook
+ #:vm vm)))))
+
+ (new-enabled-trap
+ vm current-frame
+ (lambda (frame)
+ (add-hook! (vm-apply-hook vm) apply-hook))
+ (lambda (frame)
+ (if exit-trap
+ (abort-hook frame))
+ (set! exit-trap #f)
+ (remove-hook! (vm-apply-hook vm) 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)))
+ (arg-check proc procedure?)
+ (arg-check apply-handler procedure?)
+ (arg-check return-handler procedure?)
+ (let ((*call-depth* 0))
+ (define (trace-push frame)
+ (set! *call-depth* (1+ *call-depth*)))
+
+ (define (trace-pop frame)
+ (return-handler frame *call-depth*)
+ (set! *call-depth* (1- *call-depth*)))
+
+ (define (trace-apply frame)
+ (apply-handler frame *call-depth*))
+
+ ;; 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))
+
+ (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))
+
+ (define (return frame)
+ (leave frame))
+
+ (define (abort frame)
+ (leave frame))
+
+ (trap-in-dynamic-extent proc enter return abort
+ #:current-frame current-frame #:vm vm)))
+
+;; Trapping all retired intructions within a dynamic extent.
+;;
+(define* (trap-instructions-in-dynamic-extent proc next-handler
+ #:key current-frame (vm (the-vm)))
+ (arg-check proc procedure?)
+ (arg-check next-handler procedure?)
+ (let ()
+ (define (trace-next frame)
+ (next-handler frame))
+
+ (define (enter frame)
+ (add-hook! (vm-next-hook vm) trace-next))
+
+ (define (leave frame)
+ (remove-hook! (vm-next-hook vm) trace-next))
+
+ (define (return frame)
+ (leave frame))
+
+ (define (abort frame)
+ (leave frame))
+
+ (trap-in-dynamic-extent proc enter return abort
+ #:current-frame current-frame #:vm vm)))