diff options
-rw-r--r-- | module/system/vm/trace.scm | 119 | ||||
-rw-r--r-- | module/system/vm/trap-state.scm | 6 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 148 |
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))) |