From c850a0ff4d0073364612ff5785bda8217ea9ae7f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 May 2013 15:07:37 +0200 Subject: [PATCH] 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. --- doc/ref/api-debug.texi | 23 +++++----- 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, 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() \ @@ -142,51 +174,6 @@ #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; } 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 -- 2.20.1