pop-continuation abort-continuation hooks pass return vals directly

* doc/ref/api-debug.texi (VM Hooks): Update documentation.

* libguile/vm.c (vm_dispatch_hook):
* libguile/vm-engine.c:  Rework the hook machinery so that they can
  receive an arbitrary number of arguments.  The return and abort
  hooks will pass the values that they return to their continuations.
  (vm_engine): Adapt to ABORT_CONTINUATION_HOOK change.

* libguile/vm-i-system.c (return, return/values): Adapt to
  POP_CONTINUATION_HOOK change.

* module/system/vm/frame.scm (frame-return-values): Remove.  The
  pop-continuation-hook will pass the values directly.

* module/system/vm/trace.scm (print-return):
  (trace-calls-to-procedure):
  (trace-calls-in-procedure): Update to receive return values
  directly.

* module/system/vm/traps.scm (trap-in-procedure)
  (trap-in-dynamic-extent): Ignore return values.
  (trap-frame-finish, trap-calls-in-dynamic-extent)
  (trap-calls-to-procedure): Pass return values to the handlers.

8 files changed, 111 insertions, 112 deletions

diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index f6c706c78..4e1b82295 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -799,10 +799,11 @@ To digress, Guile's VM has 6 different hooks (@pxref{Hooks}) that can be
 fired at different times, which may be accessed with the following
 procedures.
 
-All hooks are called with one argument, the frame in
-question. @xref{Frames}.  Since these hooks may be fired very
-frequently, Guile does a terrible thing: it allocates the frames on the
-C stack instead of the garbage-collected heap.
+The first argument of calls to these hooks is the frame in question.
+@xref{Frames}.  Some hooks may call their procedures with more
+arguments.  Since these hooks may be fired very frequently, Guile does a
+terrible thing: it allocates the frames on the C stack instead of the
+garbage-collected heap.
 
 The upshot here is that the frames are only valid within the dynamic
 extent of the call to the hook. If a hook procedure keeps a reference to
@@ -832,11 +833,8 @@ corresponding apply-hook.
 @deffn {Scheme Procedure} vm-pop-continuation-hook vm
 The hook that will be fired before returning from a frame.
 
-This hook is a bit trickier than the rest, in that there is a particular
-interpretation of the values on the stack. Specifically, the top value
-on the stack is the number of values being returned, and the next
-@var{n} values are the actual values being returned, with the last value
-highest on the stack.
+This hook fires with a variable number of arguments, corresponding to
+the values that the frame returns to its continuation.
 @end deffn
 
 @deffn {Scheme Procedure} vm-apply-hook vm
@@ -852,8 +850,11 @@ hook.
 
 @deffn {Scheme Procedure} vm-abort-continuation-hook vm
 The hook that will be called after aborting to a
-prompt. @xref{Prompts}. The stack will be in the same state as for
-@code{vm-pop-continuation-hook}.
+prompt.  @xref{Prompts}.
+
+Like the pop-continuation hook, this hook fires with a variable number
+of arguments, corresponding to the values that returned to the
+continuation.
 @end deffn
 
 @deffn {Scheme Procedure} vm-restore-continuation-hook vm
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 77c2e462a..1cd623d95 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -68,6 +68,38 @@
 # define ASSERT(condition)
 #endif
 
+#if VM_USE_HOOKS
+#define RUN_HOOK(h, args, n)                            \
+  do {                                                  \
+    if (SCM_UNLIKELY (vp->trace_level > 0))             \
+      {                                                 \
+        SYNC_REGISTER ();				\
+        vm_dispatch_hook (vm, h, args, n);              \
+      }                                                 \
+  } while (0)
+#else
+#define RUN_HOOK(h, args, n)
+#endif
+#define RUN_HOOK0(h) RUN_HOOK(h, NULL, 0)
+
+#define APPLY_HOOK()                            \
+  RUN_HOOK0 (SCM_VM_APPLY_HOOK)
+#define PUSH_CONTINUATION_HOOK()                \
+  RUN_HOOK0 (SCM_VM_PUSH_CONTINUATION_HOOK)
+#define POP_CONTINUATION_HOOK(vals, n)  \
+  RUN_HOOK (SCM_VM_POP_CONTINUATION_HOOK, vals, n)
+#define NEXT_HOOK()                             \
+  RUN_HOOK0 (SCM_VM_NEXT_HOOK)
+#define ABORT_CONTINUATION_HOOK(vals, n)        \
+  RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK, vals, n)
+#define RESTORE_CONTINUATION_HOOK()            \
+  RUN_HOOK0 (SCM_VM_RESTORE_CONTINUATION_HOOK)
+
+#define VM_HANDLE_INTERRUPTS                     \
+  SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
+
+
+
 
 /* Cache the VM's instruction, stack, and frame pointer in local variables.  */
 #define CACHE_REGISTER()			\
@@ -143,51 +175,6 @@
 
 
 /*
- * Hooks
- */
-
-#if VM_USE_HOOKS
-#define RUN_HOOK(h)                                     \
-  {                                                     \
-    if (SCM_UNLIKELY (vp->trace_level > 0))             \
-      {                                                 \
-        SYNC_REGISTER ();				\
-        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 APPLY_HOOK()                            \
-  RUN_HOOK (SCM_VM_APPLY_HOOK)
-#define PUSH_CONTINUATION_HOOK()                \
-  RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK)
-#define POP_CONTINUATION_HOOK(n)                \
-  RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n))
-#define NEXT_HOOK()                             \
-  RUN_HOOK (SCM_VM_NEXT_HOOK)
-#define ABORT_CONTINUATION_HOOK()               \
-  RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK)
-#define RESTORE_CONTINUATION_HOOK()            \
-  RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK)
-
-#define VM_HANDLE_INTERRUPTS                     \
-  SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
-
-
-/*
  * Stack operation
  */
 
@@ -352,7 +339,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
       CACHE_PROGRAM ();
       /* The stack contains the values returned to this continuation,
          along with a number-of-values marker -- like an MV return. */
-      ABORT_CONTINUATION_HOOK ();
+      ABORT_CONTINUATION_HOOK (sp - SCM_I_INUM (*sp), SCM_I_INUM (*sp));
       NEXT;
     }
 
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 4445d0c30..f64982260 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1150,7 +1150,7 @@ VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1)
 VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1)
 {
  vm_return:
-  POP_CONTINUATION_HOOK (1);
+  POP_CONTINUATION_HOOK (sp, 1);
 
   VM_HANDLE_INTERRUPTS;
 
@@ -1189,7 +1189,7 @@ VM_DEFINE_INSTRUCTION (70, return_values, "return/values", 1, -1, -1)
      that perhaps it might be used without declaration. Fooey to that, I say. */
   nvalues = FETCH ();
  vm_return_values:
-  POP_CONTINUATION_HOOK (nvalues);
+  POP_CONTINUATION_HOOK (sp + 1 - nvalues, nvalues);
 
   VM_HANDLE_INTERRUPTS;
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 0b0650d0f..f80d6071b 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -202,14 +202,16 @@ scm_i_capture_current_stack (void)
                                  0);
 }
 
+static void vm_dispatch_hook (SCM vm, int hook_num,
+                              SCM *argv, int n) SCM_NOINLINE;
+
 static void
-vm_dispatch_hook (SCM vm, int hook_num)
+vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
 {
   struct scm_vm *vp;
   SCM hook;
   struct scm_frame c_frame;
   scm_t_cell *frame;
-  SCM args[1];
   int saved_trace_level;
 
   vp = SCM_VM_DATA (vm);
@@ -242,9 +244,30 @@ vm_dispatch_hook (SCM vm, int hook_num)
 
   frame->word_0 = SCM_PACK (scm_tc7_frame);
   frame->word_1 = SCM_PACK_POINTER (&c_frame);
-  args[0] = SCM_PACK_POINTER (frame);
 
-  scm_c_run_hookn (hook, args, 1);
+  if (n == 0)
+    {
+      SCM args[1];
+
+      args[0] = SCM_PACK_POINTER (frame);
+      scm_c_run_hookn (hook, args, 1);
+    }
+  else if (n == 1)
+    {
+      SCM args[2];
+
+      args[0] = SCM_PACK_POINTER (frame);
+      args[1] = argv[0];
+      scm_c_run_hookn (hook, args, 2);
+    }
+  else
+    {
+      SCM args = SCM_EOL;
+
+      while (n--)
+        args = scm_cons (argv[n], args);
+      scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args));
+    }
 
   vp->trace_level = saved_trace_level;
 }
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index a3e43fe18..1a6f72a66 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -29,7 +29,6 @@
   #:use-module (system vm program)
   #:use-module (system vm trap-state)
   #:use-module (system vm vm)
-  #:use-module ((system vm frame) #:select (frame-return-values))
   #:autoload (system base language) (lookup-language language-reader)
   #:autoload (system vm trace) (call-with-trace)
   #:use-module (ice-9 format)
@@ -688,8 +687,8 @@ Note that the given source location must be inside a procedure."
       (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))
 
 (define (repl-pop-continuation-resumer repl msg)
-  ;; Capture the dynamic environment with this prompt thing. The
-  ;; result is a procedure that takes a frame.
+  ;; Capture the dynamic environment with this prompt thing. The result
+  ;; is a procedure that takes a frame and number of values returned.
   (% (call-with-values
          (lambda ()
            (abort
@@ -697,18 +696,18 @@ Note that the given source location must be inside a procedure."
               ;; Call frame->stack-vector before reinstating the
               ;; continuation, so that we catch the %stacks fluid at
               ;; the time of capture.
-              (lambda (frame)
+              (lambda (frame . values)
                 (k frame
                    (frame->stack-vector
-                    (frame-previous frame)))))))
-       (lambda (from stack)
+                    (frame-previous frame))
+                   values)))))
+       (lambda (from stack values)
          (format #t "~a~%" msg)
-         (let ((vals (frame-return-values from)))
-           (if (null? vals)
-               (format #t "No return values.~%")
-               (begin
-                 (format #t "Return values:~%")
-                 (for-each (lambda (x) (repl-print repl x)) vals))))
+         (if (null? values)
+             (format #t "No return values.~%")
+             (begin
+               (format #t "Return values:~%")
+               (for-each (lambda (x) (repl-print repl x)) values)))
          ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
           #:debug (make-debug stack 0 msg #t))))))
 
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 40d4080a3..b8077dba0 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -28,8 +28,7 @@
             frame-binding-ref frame-binding-set!
             frame-next-source frame-call-representation
             frame-environment
-            frame-object-binding frame-object-name
-            frame-return-values))
+            frame-object-binding frame-object-name))
 
 (define (frame-bindings frame)
   (let ((p (frame-procedure frame)))
@@ -158,12 +157,3 @@
 (define (frame-object-name frame obj)
   (cond ((frame-object-binding frame obj) => binding:name)
 	(else #f)))
-
-;; Nota bene, only if frame is in a return context (i.e. in a
-;; pop-continuation hook dispatch).
-(define (frame-return-values frame)
-  (let* ((len (frame-num-locals frame))
-         (nvalues (frame-local-ref frame (1- len))))
-    (map (lambda (i)
-           (frame-local-ref frame (+ (- len nvalues 1) i)))
-         (iota nvalues))))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index e27dc3784..7b96af5bd 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM tracer
 
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013 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
@@ -53,34 +53,33 @@
             width
             (frame-call-representation frame))))
 
-(define* (print-return frame depth width prefix max-indent)
+(define* (print-return frame depth width prefix max-indent values)
   (let* ((len (frame-num-locals frame))
-         (nvalues (frame-local-ref frame (1- len)))
          (prefix (build-prefix prefix depth "|  " "~d< "max-indent)))
-    (case nvalues
+    (case (length values)
       ((0)
        (format (current-error-port) "~ano values\n" prefix))
       ((1)
        (format (current-error-port) "~a~v:@y\n"
                prefix
                width
-               (frame-local-ref frame (- len 2))))
+               (car values)))
       (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"
-               prefix nvalues
+               prefix (length values)
                (map (lambda (val)
                       (format #f "~v:@y" width val))
-                    (frame-return-values frame)))))))
-  
+                    values))))))
+
 (define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
                                    (prefix "trace: ")
                                    (max-indent (- width 40)))
   (define (apply-handler frame depth)
     (print-application frame depth width prefix max-indent))
-  (define (return-handler frame depth)
-    (print-return frame depth width prefix max-indent))
+  (define (return-handler frame depth . values)
+    (print-return frame depth width prefix max-indent values))
   (trap-calls-to-procedure proc apply-handler return-handler
                            #:vm vm))
 
@@ -89,8 +88,8 @@
                                    (max-indent (- width 40)))
   (define (apply-handler frame depth)
     (print-application frame depth width prefix max-indent))
-  (define (return-handler frame depth)
-    (print-return frame depth width prefix max-indent))
+  (define (return-handler frame depth . values)
+    (print-return frame depth width prefix max-indent values))
   (trap-calls-in-dynamic-extent proc apply-handler return-handler
                                 #:vm vm))
 
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index cccd6eac9..14aee55cc 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -1,6 +1,6 @@
 ;;; Traps: stepping, breakpoints, and such.
 
-;; Copyright (C)  2010 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2012 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
@@ -184,13 +184,13 @@
       (if in-proc?
           (exit-proc frame)))
     
-    (define (pop-cont-hook frame)
+    (define (pop-cont-hook frame . values)
       (if in-proc?
           (exit-proc frame))
       (if (our-frame? (frame-previous frame))
           (enter-proc (frame-previous frame))))
 
-    (define (abort-hook frame)
+    (define (abort-hook frame . values)
       (if in-proc?
           (exit-proc frame))
       (if (our-frame? frame)
@@ -409,17 +409,17 @@
   (arg-check return-handler procedure?)
   (arg-check abort-handler procedure?)
   (let ((fp (frame-address frame)))
-    (define (pop-cont-hook frame)
+    (define (pop-cont-hook frame . values)
       (if (and fp (eq? (frame-address frame) fp))
           (begin
             (set! fp #f)
-            (return-handler frame))))
+            (apply return-handler frame values))))
     
-    (define (abort-hook frame)
+    (define (abort-hook frame . values)
       (if (and fp (< (frame-address frame) fp))
           (begin
             (set! fp #f)
-            (abort-handler frame))))
+            (apply abort-handler frame values))))
     
     (new-enabled-trap
      vm frame
@@ -447,12 +447,12 @@
   (arg-check return-handler procedure?)
   (arg-check abort-handler procedure?)
   (let ((exit-trap #f))
-    (define (return-hook frame)
+    (define (return-hook frame . values)
       (exit-trap frame) ; disable the return/abort trap.
       (set! exit-trap #f)
       (return-handler frame))
     
-    (define (abort-hook frame)
+    (define (abort-hook frame . values)
       (exit-trap frame) ; disable the return/abort trap.
       (set! exit-trap #f)
       (abort-handler frame))
@@ -490,8 +490,8 @@
     (define (trace-push frame)
       (set! *call-depth* (1+ *call-depth*)))
   
-    (define (trace-pop frame)
-      (return-handler frame *call-depth*)
+    (define (trace-pop frame . values)
+      (apply return-handler frame *call-depth* values)
       (set! *call-depth* (1- *call-depth*)))
   
     (define (trace-apply frame)
@@ -570,12 +570,12 @@
                       (delq finish-trap pending-finish-traps))
                 (set! finish-trap #f))
               
-              (define (return-hook frame)
+              (define (return-hook frame . values)
                 (frame-finished frame)
-                (return-handler frame depth))
+                (apply return-handler frame depth values))
         
               ;; FIXME: abort handler?
-              (define (abort-hook frame)
+              (define (abort-hook frame . values)
                 (frame-finished frame))
         
               (set! finish-trap