[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-159-g7ea3e4f

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

The branch, master has been updated
       via  7ea3e4ff28fb02b0c82a2e304ba8d958528bc2ae (commit)
       via  45cc48673a75c8318d2e6ca3651d94e64a08ad47 (commit)
      from  7e9f96021ac200f2fe5b25f4e02bd11b3331fb34 (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 7ea3e4ff28fb02b0c82a2e304ba8d958528bc2ae
Author: Andy Wingo <address@hidden>
Date:   Thu Jan 14 00:09:54 2010 +0100

    vm-trace prints return values
    
    * module/system/vm/trace.scm (vm-trace): Add a #:width argument. Print
      return values, as Chez Scheme does.

commit 45cc48673a75c8318d2e6ca3651d94e64a08ad47
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 13 23:14:12 2010 +0100

    RETURN_HOOK communicates the number of returned values
    
    * libguile/vm-engine.h (RUN_HOOK1): Add some machinery whereby a hook
      can push an arg on the stack, run the hook, then drop the value.
      (RETURN_HOOK): Use it here, so we push the number of returned values.
    
    * libguile/vm-i-system.c (return, return-values): Adapt to RETURN_HOOK
      changes.

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

Summary of changes:
 libguile/vm-engine.h       |   14 ++++++++++++-
 libguile/vm-i-system.c     |    4 +-
 module/system/vm/trace.scm |   47 +++++++++++++++++++++++++++++--------------
 3 files changed, 47 insertions(+), 18 deletions(-)

diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 51c462c..ccc1408 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -195,6 +195,7 @@
  */
 
 #undef RUN_HOOK
+#undef RUN_HOOK1
 #if VM_USE_HOOKS
 #define RUN_HOOK(h)                                     \
   {                                                     \
@@ -204,8 +205,19 @@
         vm_dispatch_hook (vm, h);                       \
       }                                                 \
   }
+#define RUN_HOOK1(h, x)                                 \
+  {                                                     \
+    if (SCM_UNLIKELY (vp->trace_level > 0))             \
+      {                                                 \
+        PUSH (x);                                       \
+        SYNC_REGISTER ();                              \
+        vm_dispatch_hook (vm, h);                       \
+        DROP();                                         \
+      }                                                 \
+  }
 #else
 #define RUN_HOOK(h)
+#define RUN_HOOK1(h, x)
 #endif
 
 #define BOOT_HOOK()    RUN_HOOK (SCM_VM_BOOT_HOOK)
@@ -215,7 +227,7 @@
 #define ENTER_HOOK()   RUN_HOOK (SCM_VM_ENTER_HOOK)
 #define APPLY_HOOK()   RUN_HOOK (SCM_VM_APPLY_HOOK)
 #define EXIT_HOOK()    RUN_HOOK (SCM_VM_EXIT_HOOK)
-#define RETURN_HOOK()  RUN_HOOK (SCM_VM_RETURN_HOOK)
+#define RETURN_HOOK(n) RUN_HOOK1 (SCM_VM_RETURN_HOOK, SCM_I_MAKINUM (n))
 
 #define VM_HANDLE_INTERRUPTS                     \
   SCM_ASYNC_TICK_WITH_CODE (SYNC_REGISTER ())
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 2e1dae9..8297c5b 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1123,7 +1123,7 @@ VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
 {
  vm_return:
   EXIT_HOOK ();
-  RETURN_HOOK ();
+  RETURN_HOOK (1);
 
   VM_HANDLE_INTERRUPTS;
 
@@ -1163,7 +1163,7 @@ VM_DEFINE_INSTRUCTION (64, return_values, 
"return/values", 1, -1, -1)
   nvalues = FETCH ();
  vm_return_values:
   EXIT_HOOK ();
-  RETURN_HOOK ();
+  RETURN_HOOK (nvalues);
 
   VM_HANDLE_INTERRUPTS;
 
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 8959e46..dca516c 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -25,10 +25,9 @@
   #:use-module (ice-9 format)
   #:export (vm-trace))
 
-(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f))
+(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
   (define *call-depth* #f)
   (define *saved-call-depth* #f)
-  (define *last-printed-call-depth* 0)
 
   (define (trace-enter frame)
     (cond
@@ -38,29 +37,47 @@
   (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*)))))
   
   (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))))
+      (format (current-error-port) "~a~v:@y\n"
+              (make-string (1- *call-depth*) #\|)
+              (max (- width *call-depth* 1) 1)
+              (frame-call-representation frame)))
      ((eq? (frame-procedure frame) thunk)
-      (set! *call-depth* 0))))
+      (set! *call-depth* 1))))
 
   (define (trace-return frame)
     ;; nop, though we could print the return i guess
-    #t)
-
+    (cond
+     ((and *call-depth* (< *call-depth* 0))
+      ;; leaving the thunk
+      (set! *call-depth* #f))
+     (*call-depth*
+      (let* ((len (frame-num-locals frame))
+             (nvalues (frame-local-ref frame (1- len))))
+        (cond
+         ((= nvalues 1)
+          (format (current-error-port) "~a~v:@y\n"
+                  (make-string *call-depth* #\|)
+                  width (frame-local-ref frame (- len 2))))
+         (else
+          ;; this should work, but there appears to be a bug
+          ;; "~a~d values:~:{ ~v:@y~}\n"
+          (format (current-error-port) "~a~d values:~{ ~a~}\n"
+                  (make-string *call-depth* #\|)
+                  nvalues
+                  (let lp ((vals '()) (i 0))
+                    (if (= i nvalues)
+                        vals
+                        (lp (cons (format #f "~v:@y" width
+                                          (frame-local-ref frame (- len 2 i)))
+                                  vals)
+                            (1+ i)))))))))))
+  
   (define (trace-next frame)
     (format #t "0x~8X" (frame-instruction-pointer frame))
     ;; should disassemble the thingy; could print stack, or stack trace,


hooks/post-receive
-- 
GNU Guile