[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 07/10] pop-continuation abort-continuation hooks pass return vals
|
From: |
Andy Wingo |
|
Subject: |
[PATCH 07/10] pop-continuation abort-continuation hooks pass return vals directly |
|
Date: |
Thu, 23 May 2013 15:31:00 +0200 |
* 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.
---
doc/ref/api-debug.texi | 25 +++++++------
libguile/vm-engine.c | 79 +++++++++++++++++-----------------------
libguile/vm-i-system.c | 4 +-
libguile/vm.c | 31 ++++++++++++++--
module/system/repl/command.scm | 23 ++++++------
module/system/vm/frame.scm | 12 +-----
module/system/vm/trace.scm | 23 ++++++------
module/system/vm/traps.scm | 28 +++++++-------
8 files changed, 112 insertions(+), 113 deletions(-)
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index f6c706c..9a592d0 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.
address@hidden 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
@@ -829,14 +830,11 @@ before applying a procedure in a non-tail context, just
before the
corresponding apply-hook.
@end deffn
address@hidden {Scheme Procedure} vm-pop-continuation-hook vm
address@hidden {Scheme Procedure} vm-pop-continuation-hook vm value ...
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
address@hidden 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
address@hidden
+prompt. @xref{Prompts}.
+
+Like the pop-continuation hook, this hook fires with a variable number
+of arguments, corresponding to the values that the 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 77c2e46..1cd623d 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 4445d0c..f649822 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 0b0650d..f80d607 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 a3e43fe..1a6f72a 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 40d4080..b8077db 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 e27dc37..7b96af5 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 cccd6ea..14aee55 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
--
1.7.10.4
- Add RTL VM, Andy Wingo, 2013/05/23
- [PATCH 01/10] inline vm-engine.h into vm-engine.c, Andy Wingo, 2013/05/23
- [PATCH 03/10] minor vm-engine cleanups, Andy Wingo, 2013/05/23
- [PATCH 02/10] remove CONS macro in VM; use scm_cons instead, Andy Wingo, 2013/05/23
- [PATCH 04/10] remove some configurability in vm-engine, Andy Wingo, 2013/05/23
- [PATCH 05/10] vm-engine: remove register assignments, Andy Wingo, 2013/05/23
- [PATCH 06/10] Allow vm_engine caller to pass arguments on the stack., Andy Wingo, 2013/05/23
- [PATCH 08/10] cpp hygiene in the vm, Andy Wingo, 2013/05/23
- [PATCH 07/10] pop-continuation abort-continuation hooks pass return vals directly,
Andy Wingo <=
- [PATCH 09/10] refactor to resolve_variable, Andy Wingo, 2013/05/23
- [PATCH 10/10] add new rtl vm, Andy Wingo, 2013/05/23