[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-28-g9eaa8fe

[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=9eaa8fef80b3bf2ece73936fc3c9e5c136df8e78

The branch, master has been updated
       via  9eaa8fef80b3bf2ece73936fc3c9e5c136df8e78 (commit)
       via  8b0d7b9d94b9f142dc4f08ce12b345321359b3cd (commit)
       via  7656f194465ed50901c9cf3e31a68c3014b576ba (commit)
       via  86fd6dff2a77150148ed7b3d9152e0a431070666 (commit)
      from  700908288cdafd7d68dc2861e2348f38aeb38782 (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 9eaa8fef80b3bf2ece73936fc3c9e5c136df8e78
Author: Andy Wingo <address@hidden>
Date:   Mon Dec 21 23:03:43 2009 +0100

    (system vm trace) sorta working
    
    * module/system/vm/trace.scm: Update to work with the current VM and its
      tracing infrastructure.

commit 8b0d7b9d94b9f142dc4f08ce12b345321359b3cd
Author: Andy Wingo <address@hidden>
Date:   Mon Dec 21 22:12:31 2009 +0100

    don't take string-write mutex in read.c:read_token
    
    * libguile/read.c (read_token): Don't take the string-write mutex when
      reading a token into a buffer, because it's assumed that the buffer is
      fresh (not seen by other threads), and a soft port can call a
      procedure that needs the string-write mutex.

commit 7656f194465ed50901c9cf3e31a68c3014b576ba
Author: Andy Wingo <address@hidden>
Date:   Mon Dec 21 21:57:20 2009 +0100

    rework vm tracing
    
    * libguile/vm-engine.c (VM_NAME): Engines take the VM itself (not the
      vp), so they can pass the VM to hooks. No more hook args, we dispatch
      without them.
    
    * libguile/vm-engine.h (RUN_HOOK): Dispatch the hook if the trace level
      is positive (instead of if the hook is there). Don't cache registers
      on return from the dispatch.
    
    * libguile/vm.h:
    * libguile/vm.c (vm_dispatch_hook): Don't bother with a dynwind; instead
      decrement the trace level when going into a hook, and if we have a
      nonlocal exit, the trace level never gets incremented again. Worse is
      better.
      (make_vm, scm_vm_trace_level, scm_set_vm_trace_level_x): New concept,
      trace level. If positive, we run the hooks, otherwise we don't. Should
      work. Removed scm_vm_trace_frame, I don't think that was the right way
      to do it.
    
    * module/system/vm/vm.scm: Replace vm-trace-frame with vm-trace-level
      and set-vm-trace-level!; the hooks actually get the frame as an
      argument now.

commit 86fd6dff2a77150148ed7b3d9152e0a431070666
Author: Andy Wingo <address@hidden>
Date:   Mon Dec 21 21:06:27 2009 +0100

    add scm_call_n, scm_c_run_hookn
    
    * libguile/eval.h:
    * libguile/eval.c (scm_call_n): New function, applies a function to an
      array of args.
    
    * libguile/hooks.h:
    * libguile/hooks.c (scm_c_run_hookn): New function, runs a hook with an
      array of args.

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

Summary of changes:
 libguile/eval.c            |    6 ++
 libguile/eval.h            |    1 +
 libguile/hooks.c           |   11 ++++
 libguile/hooks.h           |    3 +-
 libguile/read.c            |    2 -
 libguile/vm-engine.c       |    7 +--
 libguile/vm-engine.h       |   17 +++----
 libguile/vm.c              |   51 ++++++++++++--------
 libguile/vm.h              |    7 ++-
 module/system/vm/trace.scm |  111 ++++++++++++++++++++++++-------------------
 module/system/vm/vm.scm    |    2 +-
 11 files changed, 127 insertions(+), 91 deletions(-)

diff --git a/libguile/eval.c b/libguile/eval.c
index 48d1d74..65103a1 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -552,6 +552,12 @@ scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM 
arg4)
   return scm_c_vm_run (scm_the_vm (), proc, args, 4);
 }
 
+SCM
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
+{
+  return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+}
+
 /* Simple procedure applies
  */
 
diff --git a/libguile/eval.h b/libguile/eval.h
index 6341f14..0715e04 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -69,6 +69,7 @@ SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
 SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2);
 SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
 SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4);
+SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs);
 SCM_API SCM scm_apply_0 (SCM proc, SCM args);
 SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
 SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
diff --git a/libguile/hooks.c b/libguile/hooks.c
index d7bf018..abba606 100644
--- a/libguile/hooks.c
+++ b/libguile/hooks.c
@@ -276,6 +276,17 @@ scm_c_run_hook (SCM hook, SCM args)
     }
 }
 
+void
+scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs)
+{
+  SCM procs = SCM_HOOK_PROCEDURES (hook);
+  while (SCM_NIMP (procs))
+    {
+      scm_call_n (SCM_CAR (procs), argv, nargs);
+      procs = SCM_CDR (procs);
+    }
+}
+
 
 SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0, 
             (SCM hook),
diff --git a/libguile/hooks.h b/libguile/hooks.h
index 15b57fa..dc930cb 100644
--- a/libguile/hooks.h
+++ b/libguile/hooks.h
@@ -3,7 +3,7 @@
 #ifndef SCM_HOOKS_H
 #define SCM_HOOKS_H
 
-/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software 
Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008, 2009 Free Software 
Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -87,6 +87,7 @@ SCM_API SCM scm_remove_hook_x (SCM hook, SCM thunk);
 SCM_API SCM scm_reset_hook_x (SCM hook);
 SCM_API SCM scm_run_hook (SCM hook, SCM args);
 SCM_API void scm_c_run_hook (SCM hook, SCM args);
+SCM_API void scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs);
 SCM_API SCM scm_hook_to_list (SCM hook);
 SCM_INTERNAL void scm_init_hooks (void);
 
diff --git a/libguile/read.c b/libguile/read.c
index 6388084..da4a174 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -195,7 +195,6 @@ read_token (SCM port, SCM buf, size_t *read)
   scm_t_wchar chr;
   *read = 0;
 
-  buf = scm_i_string_start_writing (buf);
   while (*read < scm_i_string_length (buf))
     {
       chr = scm_getc (port);
@@ -218,7 +217,6 @@ read_token (SCM port, SCM buf, size_t *read)
       scm_i_string_set_x (buf, *read, chr);
       (*read)++;
     }
-  scm_i_string_stop_writing ();
 
   return 1;
 }
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2d28bbf..4f2dff2 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -34,12 +34,13 @@
 
 
 static SCM
-VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
+VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
 {
   /* VM registers */
   register scm_t_uint8 *ip IP_REG;     /* instruction pointer */
   register SCM *sp SP_REG;             /* stack pointer */
   register SCM *fp FP_REG;             /* frame pointer */
+  struct scm_vm *vp = SCM_VM_DATA (vm);
 
   /* Cache variables */
   struct scm_objcode *bp = NULL;       /* program base pointer */
@@ -53,10 +54,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int 
nargs)
   int nvalues = 0;
   SCM finish_args;                      /* used both for returns: both in error
                                            and normal situations */
-#if VM_USE_HOOKS
-  SCM hook_args = SCM_EOL;
-#endif
-
 #ifdef HAVE_LABELS_AS_VALUES
   static void **jump_table = NULL;
 #endif
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 949e9c4..2cce734 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -206,15 +206,14 @@
 
 #undef RUN_HOOK
 #if VM_USE_HOOKS
-#define RUN_HOOK(h)                            \
-{                                              \
-  if (SCM_UNLIKELY (scm_is_true (vp->hooks[h])))\
-    {                                          \
-      SYNC_REGISTER ();                                \
-      vm_dispatch_hook (vp, vp->hooks[h], hook_args);      \
-      CACHE_REGISTER ();                       \
-    }                                          \
-}
+#define RUN_HOOK(h)                                     \
+  {                                                     \
+    if (SCM_UNLIKELY (vp->trace_level > 0))             \
+      {                                                 \
+        SYNC_REGISTER ();                              \
+        vm_dispatch_hook (vm, h);                       \
+      }                                                 \
+  }
 #else
 #define RUN_HOOK(h)
 #endif
diff --git a/libguile/vm.c b/libguile/vm.c
index cac3354..121beaa 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -144,26 +144,24 @@ scm_vm_reinstate_continuations (SCM conts)
     reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
 }
 
-static void enfalsen_frame (void *p)
-{ 
-  struct scm_vm *vp = p;
-  vp->trace_frame = SCM_BOOL_F;
-}
-
 static void
-vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
+vm_dispatch_hook (SCM vm, int hook_num)
 {
-  if (!scm_is_false (vp->trace_frame))
-    return;
-
-  scm_dynwind_begin (0);
-  /* FIXME, stack holder should be the vm */
-  vp->trace_frame = scm_c_make_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
-  scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
+  struct scm_vm *vp;
+  SCM hook;
+  SCM frame;
 
-  scm_c_run_hook (hook, hook_args);
+  vp = SCM_VM_DATA (vm);
+  hook = vp->hooks[hook_num];
 
-  scm_dynwind_end ();
+  if (SCM_LIKELY (scm_is_false (hook))
+      || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
+    return;
+  
+  vp->trace_level--;
+  frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
+  scm_c_run_hookn (hook, &frame, 1);
+  vp->trace_level++;
 }
 
 
@@ -363,9 +361,9 @@ make_vm (void)
   vp->fp         = NULL;
   vp->engine      = SCM_VM_DEBUG_ENGINE;
   vp->options     = SCM_EOL;
+  vp->trace_level = 0;
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
     vp->hooks[i] = SCM_BOOL_F;
-  vp->trace_frame = SCM_BOOL_F;
   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 }
 #undef FUNC_NAME
@@ -406,7 +404,7 @@ SCM
 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 {
   struct scm_vm *vp = SCM_VM_DATA (vm);
-  return vm_engines[vp->engine](vp, program, argv, nargs);
+  return vm_engines[vp->engine](vm, program, argv, nargs);
 }
 
 SCM
@@ -618,13 +616,24 @@ SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 
0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
+SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
            (SCM vm),
            "")
-#define FUNC_NAME s_scm_vm_trace_frame
+#define FUNC_NAME s_scm_vm_trace_level
 {
   SCM_VALIDATE_VM (1, vm);
-  return SCM_VM_DATA (vm)->trace_frame;
+  return scm_from_int (SCM_VM_DATA (vm)->trace_level);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
+           (SCM vm, SCM level),
+           "")
+#define FUNC_NAME s_scm_set_vm_trace_level_x
+{
+  SCM_VALIDATE_VM (1, vm);
+  SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
+  return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
 
diff --git a/libguile/vm.h b/libguile/vm.h
index cbd0c55..f18826e 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -34,7 +34,7 @@
 
 struct scm_vm;
 
-typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int 
nargs);
+typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, int nargs);
 
 #define SCM_VM_REGULAR_ENGINE 0
 #define SCM_VM_DEBUG_ENGINE 1
@@ -50,7 +50,7 @@ struct scm_vm {
   int engine;                   /* which vm engine we're using */
   SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
   SCM options;                 /* options */
-  SCM trace_frame;              /* a frame being traced */
+  int trace_level;              /* traces enabled if trace_level > 0 */
 };
 
 SCM_API SCM scm_the_vm_fluid;
@@ -83,7 +83,8 @@ SCM_API SCM scm_vm_exit_hook (SCM vm);
 SCM_API SCM scm_vm_return_hook (SCM vm);
 SCM_API SCM scm_vm_option (SCM vm, SCM key);
 SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
-SCM_API SCM scm_vm_trace_frame (SCM vm);
+SCM_API SCM scm_vm_trace_level (SCM vm);
+SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
 
 struct scm_vm_cont {
   scm_t_uint8 *ip;
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index d8165f2..c260ab4 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -23,54 +23,67 @@
   #:use-module (system vm vm)
   #:use-module (system vm frame)
   #:use-module (ice-9 format)
-  #:export (vm-trace vm-trace-on vm-trace-off))
+  #:export (vm-trace vm-trace-on! vm-trace-off!))
 
-(define (vm-trace vm objcode . opts)
+(define (vm-trace vm thunk . opts)
   (dynamic-wind
-      (lambda () (apply vm-trace-on vm opts))
-      (lambda () (vm-load vm objcode))
-      (lambda () (apply vm-trace-off vm opts))))
-
-(define (vm-trace-on vm . opts)
-  (set-vm-option! vm 'trace-first #t)
-  (if (memq #:b opts) (add-hook! (vm-next-hook vm) trace-next))
-  (set-vm-option! vm 'trace-options opts)
-  (add-hook! (vm-apply-hook vm) trace-apply)
-  (add-hook! (vm-return-hook vm) trace-return))
-
-(define (vm-trace-off vm . opts)
-  (if (memq #:b opts) (remove-hook! (vm-next-hook vm) trace-next))
-  (remove-hook! (vm-apply-hook vm) trace-apply)
-  (remove-hook! (vm-return-hook vm) trace-return))
-
-(define (trace-next vm)
-  (define (puts x) (display #\tab) (write x))
-  (define (truncate! x n)
-    (if (> (length x) n)
-      (list-cdr-set! x (1- n) '(...))) x)
-  ;; main
-  (format #t "0x~8X  ~16S" (vm:ip vm) (vm-fetch-code vm))
-  (do ((opts (vm-option vm 'trace-options) (cdr opts)))
-      ((null? opts) (newline))
-    (case (car opts)
-      ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
-      ((:l) (puts (vm-fetch-locals vm))))))
-
-(define (trace-apply vm)
-  (if (vm-option vm 'trace-first)
-    (set-vm-option! vm 'trace-first #f)
-    (let ((chain (vm-current-frame-chain vm)))
-      (print-indent chain)
-      (print-frame-call (car chain))
-      (newline))))
-
-(define (trace-return vm)
-  (let ((chain (vm-current-frame-chain vm)))
-    (print-indent chain)
-    (write (vm-return-value vm))
-    (newline)))
-
-(define (print-indent chain)
-  (cond ((pair? (cdr chain))
-        (display "| ")
-        (print-indent (cdr chain)))))
+      (lambda () (apply vm-trace-on! vm opts))
+      (lambda () (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)))
+  
+  (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)))
+  
+  (if instructions?
+      (remove-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,
+  ;; ...
+  )
+
+(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))))
+
+(define (trace-return frame)
+  ;; nop, though we could print the return i guess
+  #t)
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 9d8f977..76bdb57 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -27,7 +27,7 @@
             vm-load vm-option set-vm-option! vm-version
             vms:time vms:clock
 
-            vm-trace-frame
+            vm-trace-level set-vm-trace-level!
             vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
             vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
 


hooks/post-receive
-- 
GNU Guile