[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-157-g7e9f960

[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=7e9f96021ac200f2fe5b25f4e02bd11b3331fb34

The branch, master has been updated
       via  7e9f96021ac200f2fe5b25f4e02bd11b3331fb34 (commit)
      from  a8fc38526a3e8fb9fef00042e1acc5b4a80b3f3f (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 7e9f96021ac200f2fe5b25f4e02bd11b3331fb34
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 13 22:49:14 2010 +0100

    vm-trace only traces execution of its thunk
    
    * module/system/vm/trace.scm (vm-trace): Change to just export the one
      procedure, vm-trace. This way it's threadsafe and more robust. Also
      refactor to not print any of Guile's internal bits. Hopefully Neil
      will be happier :)
    
    * module/system/repl/command.scm (option): Adapt to removal of
      vm-trace-on! and vm-trace-off!, as those are unlikely to DTRT.

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

Summary of changes:
 module/system/repl/command.scm |   13 +---
 module/system/vm/trace.scm     |  133 ++++++++++++++++++++++------------------
 2 files changed, 77 insertions(+), 69 deletions(-)

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 721d2b3..5626e1f 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -29,7 +29,7 @@
   #:use-module (system vm vm)
   #:autoload (system base language) (lookup-language language-reader)
   #:autoload (system vm debug) (vm-debugger vm-backtrace)
-  #:autoload (system vm trace) (vm-trace vm-trace-on! vm-trace-off!)
+  #:autoload (system vm trace) (vm-trace)
   #:autoload (system vm profile) (vm-profile)
   #:use-module (ice-9 format)
   #:use-module (ice-9 session)
@@ -228,14 +228,7 @@ List/show/set options."
      (display (repl-option-ref repl key))
      (newline))
     ((,key ,val)
-     (repl-option-set! repl key val)
-     (case key
-       ((trace)
-        (let ((vm (repl-vm repl)))
-          (if val
-              (apply vm-trace-on! vm val)
-              ;; fixme: asymmetry
-              (vm-trace-off! vm))))))))
+     (repl-option-set! repl key val))))
 
 (define-meta-command (quit repl)
   "quit
@@ -388,7 +381,7 @@ Start debugger."
 (define-meta-command (trace repl form . opts)
   "trace FORM
 Trace execution."
-  ;; FIXME: doc, or somehow deal with them better
+  ;; FIXME: doc options, or somehow deal with them better
   (apply vm-trace
          (repl-vm repl)
          (make-program (repl-compile repl (repl-parse repl form)))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 330b50f..8959e46 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -23,67 +23,82 @@
   #:use-module (system vm vm)
   #:use-module (system vm frame)
   #:use-module (ice-9 format)
-  #:export (vm-trace vm-trace-on! vm-trace-off!))
-
-(define (vm-trace vm thunk . opts)
-  (dynamic-wind
-      (lambda () (apply vm-trace-on! vm opts))
-      (lambda () (vm-apply vm thunk '()))
-      (lambda () (apply vm-trace-off! vm opts))))
-
-(define* (vm-trace-on! vm #:key (calls? #t) (instructions? #f))
-  (if calls?
-      (begin
-        (add-hook! (vm-exit-hook vm) trace-exit)
-        (add-hook! (vm-enter-hook vm) trace-enter)
-        (add-hook! (vm-apply-hook vm) trace-apply)
-        (add-hook! (vm-return-hook vm) trace-return)))
+  #:export (vm-trace))
+
+(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f))
+  (define *call-depth* #f)
+  (define *saved-call-depth* #f)
+  (define *last-printed-call-depth* 0)
+
+  (define (trace-enter frame)
+    (cond
+     (*call-depth*
+      (set! *call-depth* (1+ *call-depth*)))))
+
+  (define (trace-exit frame)
+    (cond
+     ((not *call-depth*))
+     ((< *call-depth* 0)
+      ;; leaving the thunk
+      (set! *call-depth* #f))
+     (else
+      (set! *call-depth* (1- *call-depth*)))))
   
-  (if instructions?
-      (add-hook! (vm-next-hook vm) trace-next))
-
-  ;; boot, halt, and break are the other ones
-
-  (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
-
-(define* (vm-trace-off! vm #:key (calls? #t) (instructions? #f))
-  (set-vm-trace-level! vm (1- (vm-trace-level vm)))
-
-  (if calls?
-      (begin
-        (remove-hook! (vm-exit-hook vm) trace-exit)
-        (remove-hook! (vm-enter-hook vm) trace-enter)
-        (remove-hook! (vm-apply-hook vm) trace-apply)
-        (remove-hook! (vm-return-hook vm) trace-return)))
+  (define (trace-apply frame)
+    (cond
+     (*call-depth*
+      (let ((last-depth *last-printed-call-depth*))
+        (set! *last-printed-call-depth* *call-depth*)
+        (format (current-error-port) "~a ~a~{ ~a~}\n"
+                (make-string *call-depth* #\*)
+                (let ((p (frame-procedure frame)))
+                  (or (procedure-name p) p))
+                (frame-arguments frame))))
+     ((eq? (frame-procedure frame) thunk)
+      (set! *call-depth* 0))))
+
+  (define (trace-return frame)
+    ;; nop, though we could print the return i guess
+    #t)
+
+  (define (trace-next frame)
+    (format #t "0x~8X" (frame-instruction-pointer frame))
+    ;; should disassemble the thingy; could print stack, or stack trace,
+    ;; ...
+    )
+
+  (define (vm-trace-on!)
+    (if calls?
+        (begin
+          (add-hook! (vm-exit-hook vm) trace-exit)
+          (add-hook! (vm-enter-hook vm) trace-enter)
+          (add-hook! (vm-apply-hook vm) trace-apply)
+          (add-hook! (vm-return-hook vm) trace-return)))
   
-  (if instructions?
-      (remove-hook! (vm-next-hook vm) trace-next)))
+    (if instructions?
+        (add-hook! (vm-next-hook vm) trace-next))
 
-(define (trace-next frame)
-  (format #t "0x~8X" (frame-instruction-pointer frame))
-  ;; should disassemble the thingy; could print stack, or stack trace,
-  ;; ...
-  )
+    ;; boot, halt, and break are the other ones
 
-(define *call-depth* 0)
-(define *last-printed-call-depth* 0)
-
-(define (trace-enter frame)
-  (set! *call-depth* (1+ *call-depth*)))
-
-(define (trace-exit frame)
-  (set! *call-depth* (1- *call-depth*)))
-
-(define (trace-apply frame)
-  (if (< *call-depth* 0) (set! *call-depth* 0))
-  (let ((last-depth *last-printed-call-depth*))
-    (set! *last-printed-call-depth* *call-depth*)
-    (format (current-error-port) "~a ~a~{ ~a~}\n"
-            (make-string *call-depth* #\*)
-            (let ((p (frame-procedure frame)))
-              (or (procedure-name p) p))
-            (frame-arguments frame))))
+    (set-vm-trace-level! vm (1+ (vm-trace-level vm)))
+    (set! *call-depth* *saved-call-depth*))
+  
+  (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-exit-hook vm) trace-exit)
+          (remove-hook! (vm-enter-hook vm) trace-enter)
+          (remove-hook! (vm-apply-hook vm) trace-apply)
+          (remove-hook! (vm-return-hook vm) trace-return)))
+  
+    (if instructions?
+        (remove-hook! (vm-next-hook vm) trace-next)))
 
-(define (trace-return frame)
-  ;; nop, though we could print the return i guess
-  #t)
+  (dynamic-wind
+    vm-trace-on!
+    (lambda () (vm-apply vm thunk '()))
+    vm-trace-off!))


hooks/post-receive
-- 
GNU Guile