mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +02:00
Code Activity

pop-continuation abort-continuation hooks pass return vals directly

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-05-23 15:07:37 +02:00
parent 27319ffaa9
commit c850a0ff4d
8 changed files with 111 additions and 112 deletions
Download patch file Download diff file Expand all files Collapse all files

23
doc/ref/api-debug.texi
View file

@ -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

79
libguile/vm-engine.c
View file

@ -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() \
@ -141,51 +173,6 @@
#define CHECK_OBJECT(_num)
#define CHECK_FREE_VARIABLE(_num)
/*
* 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;
}

4
libguile/vm-i-system.c
View file

@ -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;

31
libguile/vm.c
View file

@ -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;
}

23
module/system/repl/command.scm
View file

@ -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))))))

12
module/system/vm/frame.scm
View file

@ -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))))

21
module/system/vm/trace.scm
View file

@ -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))

28
module/system/vm/traps.scm
View file

@ -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