implement a silly debugger

* module/system/vm/debug.scm: Implement the skeleton of a debugger. Not
  very useful yet.

* module/system/repl/repl.scm (call-with-backtrace): Have the pre-unwind
  hook drop the user into the debugger. Hopefully we can have something
  better within a couple weeks.

diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index a3496f3..8c54345 100644 (file)
--- 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 04e3d64..960696f 100644 (file)
--- 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))
 
 \f
 ;;;
 ;;; 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)
 
-\f
-;;;
-;;; 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))