diff options
-rw-r--r-- | module/system/repl/repl.scm | 2 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 131 |
2 files changed, 104 insertions, 29 deletions
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index a3496f3b8..8c54345ca 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -87,7 +87,7 @@ (catch #t (lambda () (%start-stack #t thunk)) default-catch-handler - default-pre-unwind-handler)) + debug-pre-unwind-handler)) (define-macro (with-backtrace form) `(call-with-backtrace (lambda () ,form))) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 04e3d64b9..960696f37 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -23,39 +23,114 @@ #:use-module (system vm vm) #:use-module (system vm frame) #:use-module (ice-9 format) - #:export (vm-debugger vm-backtrace)) + #:export (run-debugger debug-pre-unwind-handler)) ;;; ;;; Debugger ;;; -(define-record/keywords <debugger> vm chain index) - -(define (vm-debugger vm) - (let ((chain (vm-last-frame-chain vm))) - (if (null? chain) - (display "Nothing to debug\n") - (debugger-repl (make-debugger - #:vm vm #:chain chain #:index (length chain)))))) - -(define (debugger-repl db) - (let loop () - (display "debug> ") - (let ((cmd (read))) - (case cmd - ((bt) (vm-backtrace (debugger-vm db))) - ((stack) - (write (vm-fetch-stack (debugger-vm db))) - (newline)) - (else - (format #t "Unknown command: ~A" cmd)))))) +(define-record <debugger> vm level breakpoints module) - -;;; -;;; Backtrace -;;; +(define (make-debugger-module) + (let ((m (make-fresh-user-module))) + m)) + +(define vm-debugger + (let ((prop (make-object-property))) + (lambda (vm) + (or (prop vm) + (let ((debugger (make-debugger vm (make-fluid) '() (make-debugger-module)))) + (set! (prop vm) debugger) + debugger))))) + +(define* (run-debugger frame #:optional (vm (the-vm))) + (let* ((db (vm-debugger vm)) + (level (debugger-level db))) + (with-fluids ((level (or (and=> (fluid-ref level) 1+) 0))) + (debugger-repl db frame)))) + +(define (debugger-repl db frame) + (let ((top frame)) + (define (frame-index frame) + (let lp ((idx 0) (walk top)) + (if (= (frame-return-address frame) (frame-return-address walk)) + idx + (lp (1+ idx) (frame-previous walk))))) + (let loop () + (let ((index (frame-index frame)) + (level (fluid-ref (debugger-level db)))) + (let ((cmd (repl-reader + (lambda () + (format #f "debug[~a@~a]> " level index)) + read))) + (if (not (or (eof-object? cmd) + (memq cmd '(q quit c continue)))) + (begin + (case cmd + ((bt) + (display-backtrace (make-stack frame) (current-output-port))) + ((bindings) + (format #t "~a\n" (frame-bindings frame))) + ((frame f) + (format #t "~s\n" frame)) + ((up) + (let ((prev (frame-previous frame))) + (if prev + (begin + (set! index (1+ index)) + (set! frame prev) + (format #t "~s\n" frame)) + (format #t "Already at outermost frame.\n")))) + ((down) + (if (zero? index) + (format #t "Already at innermost frame.\n") + (begin + (set! frame (let lp ((n (1- index)) (frame top)) + (if (zero? n) + frame + (lp (1- n) (frame-previous top))))) + (format #t "~s\n" frame)))) + ((help ?) + (format #t "Type `c' to continue.\n")) + (else + (format #t "Unknown command: ~A\n" cmd))) + (loop)))))))) + +;; things this debugger should do: +;; +;; eval expression in context of frame +;; up/down stack for inspecting +;; print procedure and args for frame +;; print local variables for frame +;; set local variable in frame +;; display backtrace +;; display full backtrace +;; step until next instruction +;; step until next function call/return +;; step until return from frame +;; step until different source line +;; step until greater source line +;; watch expression +;; break on a function +;; remove breakpoints +;; set printing width +;; display a truncated backtrace +;; go to a frame by index +;; (reuse gdb commands perhaps) +;; help +;; disassemble a function +;; disassemble the current function +;; inspect any object +;; hm, trace via reassigning global vars. tricksy. +;; (state associated with vm ?) -(define (vm-backtrace vm) - (print-frame-chain-as-backtrace - (reverse (vm-last-frame-chain vm)))) +(define (debug-pre-unwind-handler key . args) + ;; herald + (format #t "Throw to key `~a' with args `~s'. +Entering the debugger. Type `bt' for a backtrace or `c' to continue. +This debugger implementation is temporary. See system/vm/debug.scm for +some ideas on how to make it better.\n" key args) + (run-debugger (stack-ref (make-stack #t) 1)) + (save-stack 1) + (apply throw key args)) |