[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-35-g1ad7fef

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=1ad7fef5249f409317c20d5242bc3c4c2b8d9d18

The branch, master has been updated
       via  1ad7fef5249f409317c20d5242bc3c4c2b8d9d18 (commit)
       via  0dfe0e758890379d625e08d4deffbbbd5822e99f (commit)
      from  dca14012bd9c62178890ff82d29c655ae71d2977 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 1ad7fef5249f409317c20d5242bc3c4c2b8d9d18
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 22 23:38:06 2009 +0100

    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.

commit 0dfe0e758890379d625e08d4deffbbbd5822e99f
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 22 22:52:48 2009 +0100

    fix warning-caught bug in boot-9
    
    * module/ice-9/boot-9.scm: Fix bug caught by warnings.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/boot-9.scm     |    2 +-
 module/system/repl/repl.scm |    2 +-
 module/system/vm/debug.scm  |  131 +++++++++++++++++++++++++++++++++---------
 3 files changed, 105 insertions(+), 30 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 1b8b053..4bc1906 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1962,7 +1962,7 @@
       (let ((cv (car version-ref)))
         (cond ((eq? cv 'and) (every curried-version-matches? (cdr 
version-ref)))
               ((eq? cv 'or) (any curried-version-matches? (cdr version-ref)))
-              ((eq? cv 'not) (not version-matches? (cadr version-ref) target))
+              ((eq? cv 'not) (not (version-matches? (cadr version-ref) 
target)))
               (else (sub-versions-match? version-ref target))))))
 
 (define (find-versioned-module dir-hint name version-ref roots)
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index a3496f3..8c54345 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 04e3d64..960696f 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 "address@hidden> " 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))


hooks/post-receive
-- 
GNU Guile