summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/repl/repl.scm2
-rw-r--r--module/system/vm/debug.scm131
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))