diff options
-rw-r--r-- | libguile/frames.c | 31 | ||||
-rw-r--r-- | libguile/vm-engine.c | 14 | ||||
-rw-r--r-- | libguile/vm.c | 39 | ||||
-rw-r--r-- | libguile/vm.h | 6 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 1 | ||||
-rw-r--r-- | module/system/vm/trace.scm | 15 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 131 | ||||
-rw-r--r-- | module/system/vm/vm.scm | 5 |
8 files changed, 132 insertions, 110 deletions
diff --git a/libguile/frames.c b/libguile/frames.c index d989d6292..0ad40edd3 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -28,8 +28,10 @@ #include "eval.h" #include "extensions.h" #include "gsubr.h" +#include "instructions.h" #include "modules.h" #include "numbers.h" +#include "pairs.h" #include "ports.h" #include "symbols.h" #include "threads.h" @@ -328,6 +330,33 @@ scm_frame_local_set_x (SCM frame, SCM index, SCM val, SCM representation) } #undef FUNC_NAME +static const char s_scm_frame_return_values[] = "frame-return-values"; +static SCM +scm_frame_return_values (SCM frame) +#define FUNC_NAME s_scm_frame_return_values +{ + const uint32_t *ip; + union scm_vm_stack_element *fp, *sp; + SCM vals = SCM_EOL; + size_t n; + + SCM_VALIDATE_VM_FRAME (1, frame); + + ip = SCM_VM_FRAME_IP (frame); + fp = SCM_VM_FRAME_FP (frame); + sp = SCM_VM_FRAME_SP (frame); + + if ((*ip & 0xff) != scm_op_return_values) + scm_wrong_type_arg_msg (FUNC_NAME, 1, frame, "not a return frame"); + + n = SCM_FRAME_NUM_LOCALS (fp, sp); + while (n--) + vals = scm_cons (SCM_FRAME_LOCAL (fp, n), vals); + + return vals; +} +#undef FUNC_NAME + SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0, (SCM frame), "Return the frame pointer for @var{frame}.") @@ -442,6 +471,8 @@ scm_init_frames_builtins (void *unused) (scm_t_subr) scm_frame_local_ref); scm_c_define_gsubr (s_scm_frame_local_set_x, 4, 0, 0, (scm_t_subr) scm_frame_local_set_x); + scm_c_define_gsubr (s_scm_frame_return_values, 1, 0, 0, + (scm_t_subr) scm_frame_return_values); } void diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 5ca75e0bc..4c8bf6ec5 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -126,8 +126,7 @@ #define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (thread, arg)) #define APPLY_HOOK() RUN_HOOK0 (apply) -#define PUSH_CONTINUATION_HOOK() RUN_HOOK0 (push_continuation) -#define POP_CONTINUATION_HOOK(old_fp) RUN_HOOK1 (pop_continuation, old_fp) +#define RETURN_HOOK() RUN_HOOK0 (return) #define NEXT_HOOK() RUN_HOOK0 (next) #define ABORT_CONTINUATION_HOOK() RUN_HOOK0 (abort) @@ -367,8 +366,6 @@ VM_NAME (scm_thread *thread) UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); - PUSH_CONTINUATION_HOOK (); - old_fp = VP->fp; VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1); SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp); @@ -409,8 +406,6 @@ VM_NAME (scm_thread *thread) UNPACK_24 (ip[1], nlocals); label = ip[2]; - PUSH_CONTINUATION_HOOK (); - old_fp = VP->fp; VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1); SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp); @@ -569,6 +564,8 @@ VM_NAME (scm_thread *thread) union scm_vm_stack_element *old_fp; size_t frame_size = 3; + RETURN_HOOK (); + old_fp = VP->fp; ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp); VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); @@ -577,8 +574,6 @@ VM_NAME (scm_thread *thread) while (frame_size--) old_fp[frame_size].as_scm = SCM_BOOL_F; - POP_CONTINUATION_HOOK (old_fp); - NEXT (0); } @@ -3014,8 +3009,7 @@ VM_NAME (scm_thread *thread) #undef SP_SET #undef NEXT #undef NEXT_HOOK -#undef POP_CONTINUATION_HOOK -#undef PUSH_CONTINUATION_HOOK +#undef RETURN_HOOK #undef RUN_HOOK #undef RUN_HOOK0 #undef RUN_HOOK1 diff --git a/libguile/vm.c b/libguile/vm.c index 1ad95babe..479e3a445 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -196,9 +196,7 @@ scm_i_capture_current_stack (void) } static void vm_dispatch_apply_hook (scm_thread *thread) SCM_NOINLINE; -static void vm_dispatch_push_continuation_hook (scm_thread *thread) SCM_NOINLINE; -static void vm_dispatch_pop_continuation_hook - (scm_thread *thread, union scm_vm_stack_element *old_fp) SCM_NOINLINE; +static void vm_dispatch_return_hook (scm_thread *thread) SCM_NOINLINE; static void vm_dispatch_next_hook (scm_thread *thread) SCM_NOINLINE; static void vm_dispatch_abort_hook (scm_thread *thread) SCM_NOINLINE; @@ -285,21 +283,18 @@ vm_dispatch_apply_hook (scm_thread *thread) { return vm_dispatch_hook (thread, SCM_VM_APPLY_HOOK, 0); } -static void vm_dispatch_push_continuation_hook (scm_thread *thread) -{ - return vm_dispatch_hook (thread, SCM_VM_PUSH_CONTINUATION_HOOK, 0); -} -static void vm_dispatch_pop_continuation_hook (scm_thread *thread, - union scm_vm_stack_element *old_fp) +static void +vm_dispatch_return_hook (scm_thread *thread) { - return vm_dispatch_hook (thread, SCM_VM_POP_CONTINUATION_HOOK, - SCM_FRAME_NUM_LOCALS (old_fp, thread->vm.sp)); + return vm_dispatch_hook (thread, SCM_VM_RETURN_HOOK, 0); } -static void vm_dispatch_next_hook (scm_thread *thread) +static void +vm_dispatch_next_hook (scm_thread *thread) { return vm_dispatch_hook (thread, SCM_VM_NEXT_HOOK, 0); } -static void vm_dispatch_abort_hook (scm_thread *thread) +static void +vm_dispatch_abort_hook (scm_thread *thread) { return vm_dispatch_hook (thread, SCM_VM_ABORT_CONTINUATION_HOOK, SCM_FRAME_NUM_LOCALS (thread->vm.fp, thread->vm.sp)); @@ -1023,9 +1018,6 @@ push_interrupt_frame (scm_thread *thread, uint8_t *mra) size_t old_frame_size = frame_locals_count (thread); SCM proc = scm_i_async_pop (thread); - /* No PUSH_CONTINUATION_HOOK, as we can't usefully - POP_CONTINUATION_HOOK because there are no return values. */ - /* Reserve space for frame and callee. */ alloc_frame (thread, old_frame_size + frame_overhead + 1); @@ -1464,21 +1456,12 @@ SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0, - (void), - "") -#define FUNC_NAME s_scm_vm_push_continuation_hook -{ - VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0, +SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 0, 0, 0, (void), "") -#define FUNC_NAME s_scm_vm_pop_continuation_hook +#define FUNC_NAME s_scm_vm_return_hook { - VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK); + VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK); } #undef FUNC_NAME diff --git a/libguile/vm.h b/libguile/vm.h index a5cdacbf0..6d6bd4e11 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -27,8 +27,7 @@ enum { SCM_VM_APPLY_HOOK, - SCM_VM_PUSH_CONTINUATION_HOOK, - SCM_VM_POP_CONTINUATION_HOOK, + SCM_VM_RETURN_HOOK, SCM_VM_NEXT_HOOK, SCM_VM_ABORT_CONTINUATION_HOOK, SCM_VM_NUM_HOOKS, @@ -68,8 +67,7 @@ SCM_API SCM scm_call_with_stack_overflow_handler (SCM limit, SCM thunk, SCM handler); SCM_API SCM scm_vm_apply_hook (void); -SCM_API SCM scm_vm_push_continuation_hook (void); -SCM_API SCM scm_vm_pop_continuation_hook (void); +SCM_API SCM scm_vm_return_hook (void); SCM_API SCM scm_vm_abort_continuation_hook (void); SCM_API SCM scm_vm_next_hook (void); SCM_API SCM scm_vm_trace_level (void); diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 2491ed0e0..2b55ce4f6 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -38,6 +38,7 @@ binding-ref binding-set! frame-call-representation + frame-return-values frame-environment frame-object-binding frame-object-name)) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 36fbe92a6..e9f17dae8 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, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2001,2009-2010,2012-2014,2018 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 @@ -48,8 +48,9 @@ width (frame-call-representation frame #:top-frame? #t)))) -(define (print-return depth width prefix max-indent values) - (let ((prefix (build-prefix prefix depth "| " "~d< "max-indent))) +(define (print-return frame depth width prefix max-indent) + (let ((prefix (build-prefix prefix depth "| " "~d< "max-indent)) + (values (frame-return-values frame))) (case (length values) ((0) (format (current-error-port) "~ano values\n" prefix)) @@ -72,8 +73,8 @@ (max-indent (- width 40))) (define (apply-handler frame depth) (print-application frame depth width prefix max-indent)) - (define (return-handler frame depth . values) - (print-return depth width prefix max-indent values)) + (define (return-handler frame depth values) + (print-return frame depth width prefix max-indent)) (trap-calls-to-procedure proc apply-handler return-handler)) (define* (trace-calls-in-procedure proc #:key (width 80) @@ -81,8 +82,8 @@ (max-indent (- width 40))) (define (apply-handler frame depth) (print-application frame depth width prefix max-indent)) - (define (return-handler frame depth . values) - (print-return depth width prefix max-indent values)) + (define (return-handler frame depth) + (print-return frame depth width prefix max-indent)) (trap-calls-in-dynamic-extent proc apply-handler return-handler)) (define* (trace-instructions-in-procedure proc #:key (width 80) diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index 8bee10355..a70168924 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, 2012, 2013, 2014, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2010,2012-2014,2017-2018 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 @@ -55,7 +55,7 @@ ;;; Code: (define-module (system vm traps) - #:use-module (system base pmatch) + #:use-module (ice-9 match) #:use-module (system vm vm) #:use-module (system vm debug) #:use-module (system vm frame) @@ -190,11 +190,12 @@ (if (our-frame? frame) (enter-proc frame))) - (define (pop-cont-hook frame . values) + (define (return-hook frame) (if in-proc? (exit-proc frame)) - (if (our-frame? frame) - (enter-proc frame))) + (let ((prev (frame-previous frame))) + (if (our-frame? prev) + (enter-proc prev)))) (define (abort-hook frame . values) (if in-proc? @@ -206,7 +207,7 @@ current-frame (lambda (frame) (add-hook! (vm-apply-hook) apply-hook) - (add-hook! (vm-pop-continuation-hook) pop-cont-hook) + (add-hook! (vm-return-hook) return-hook) (add-hook! (vm-abort-continuation-hook) abort-hook) (if (and frame (our-frame? frame)) (enter-proc frame))) @@ -214,7 +215,7 @@ (if in-proc? (exit-proc frame)) (remove-hook! (vm-apply-hook) apply-hook) - (remove-hook! (vm-pop-continuation-hook) pop-cont-hook) + (remove-hook! (vm-return-hook) return-hook) (remove-hook! (vm-abort-continuation-hook) abort-hook))))) ;; Building on trap-in-procedure, we have trap-instructions-in-procedure @@ -307,34 +308,31 @@ (let ((code (program-code proc))) (let lp ((sources (program-sources proc)) (out '())) - (if (pair? sources) - (lp (cdr sources) - (pmatch (car sources) - ((,start-ip ,start-file ,start-line . ,start-col) - (if (equal? start-file file) - (acons start-line - (if (pair? (cdr sources)) - (pmatch (cadr sources) - ((,end-ip . _) - (cons (+ start-ip code) - (+ end-ip code))) - (else (error "unexpected"))) - (cons (+ start-ip code) - (program-last-ip proc))) - out) - out)) - (else (error "unexpected")))) - (let ((alist '())) - (for-each - (lambda (pair) - (set! alist - (assv-set! alist (car pair) - (cons (cdr pair) - (or (assv-ref alist (car pair)) - '()))))) - out) - (sort! alist (lambda (x y) (< (car x) (car y)))) - alist))))) + (match sources + (((start-ip start-file start-line . start-col) . sources) + (lp sources + (if (equal? start-file file) + (acons start-line + (cons (+ start-ip code) + (match sources + (((end-ip . _) . _) + (+ end-ip code)) + (() + (program-last-ip proc)))) + out) + out))) + (() + (let ((alist '())) + (for-each + (lambda (pair) + (set! alist + (assv-set! alist (car pair) + (cons (cdr pair) + (or (assv-ref alist (car pair)) + '()))))) + out) + (sort! alist (lambda (x y) (< (car x) (car y)))) + alist)))))) (else '()))) (define (source->ip-range proc file line) @@ -398,14 +396,14 @@ (arg-check return-handler procedure?) (arg-check abort-handler procedure?) (let ((fp (frame-address frame))) - (define (pop-cont-hook frame . values) - (if (and fp (< (frame-address frame) fp)) + (define (return-hook frame) + (if (and fp (<= (frame-address frame) fp)) (begin (set! fp #f) - (apply return-handler frame values)))) + (return-handler frame)))) (define (abort-hook frame . values) - (if (and fp (< (frame-address frame) fp)) + (if (and fp (<= (frame-address frame) fp)) (begin (set! fp #f) (apply abort-handler frame values)))) @@ -415,11 +413,11 @@ (lambda (frame) (if (not fp) (error "return-or-abort traps may only be enabled once")) - (add-hook! (vm-pop-continuation-hook) pop-cont-hook) + (add-hook! (vm-return-hook) return-hook) (add-hook! (vm-abort-continuation-hook) abort-hook)) (lambda (frame) (set! fp #f) - (remove-hook! (vm-pop-continuation-hook) pop-cont-hook) + (remove-hook! (vm-return-hook) return-hook) (remove-hook! (vm-abort-continuation-hook) abort-hook))))) ;; A more traditional dynamic-wind trap. Perhaps this should not be @@ -433,7 +431,7 @@ (arg-check return-handler procedure?) (arg-check abort-handler procedure?) (let ((exit-trap #f)) - (define (return-hook frame . values) + (define (return-hook frame) (exit-trap frame) ; disable the return/abort trap. (set! exit-trap #f) (return-handler frame)) @@ -469,27 +467,44 @@ (arg-check proc procedure?) (arg-check apply-handler procedure?) (arg-check return-handler procedure?) - (let ((*call-depth* 0)) - (define (trace-push frame) - (set! *call-depth* (1+ *call-depth*))) - - (define (trace-pop frame . values) - (apply return-handler frame *call-depth* values) - (set! *call-depth* (1- *call-depth*))) + (let ((*stack* '())) + (define (trace-return frame) + (let ((fp* (frame-address frame))) + (let lp ((stack *stack*)) + (match stack + (() (values)) + ((fp . stack) + (cond + ((> fp fp*) + (set! *stack* stack) + (lp stack)) + ((= fp fp*) (set! *stack* stack)) + ((< fp fp*) (values))))))) + (return-handler frame (1+ (length *stack*)))) (define (trace-apply frame) - (apply-handler frame *call-depth*)) + (let ((fp* (frame-address frame))) + (define (same-fp? fp) (= fp fp*)) + (define (newer-fp? fp) (> fp fp*)) + (let lp ((stack *stack*)) + (match stack + (((? same-fp?) . stack) + ;; A tail call, nothing to do. + (values)) + (((? newer-fp?) . stack) + ;; Unless there are continuations, we shouldn't get here. + (set! *stack* stack) + (lp stack)) + (stack + (set! *stack* (cons fp* stack)))))) + (apply-handler frame (length *stack*))) - ;; FIXME: recalc depth on abort - (define (enter frame) - (add-hook! (vm-push-continuation-hook) trace-push) - (add-hook! (vm-pop-continuation-hook) trace-pop) + (add-hook! (vm-return-hook) trace-return) (add-hook! (vm-apply-hook) trace-apply)) (define (leave frame) - (remove-hook! (vm-push-continuation-hook) trace-push) - (remove-hook! (vm-pop-continuation-hook) trace-pop) + (remove-hook! (vm-return-hook) trace-return) (remove-hook! (vm-apply-hook) trace-apply)) (define (return frame) @@ -550,9 +565,9 @@ (delq finish-trap pending-finish-traps)) (set! finish-trap #f)) - (define (return-hook frame . values) + (define (return-hook frame) (frame-finished frame) - (apply return-handler frame depth values)) + (return-handler frame depth)) ;; FIXME: abort handler? (define (abort-hook frame . values) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm index 527468414..7da5d8cc2 100644 --- a/module/system/vm/vm.scm +++ b/module/system/vm/vm.scm @@ -1,6 +1,6 @@ ;;; Guile VM core -;;; Copyright (C) 2001, 2009, 2010, 2013, 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2001,2009-2010,2013-2014,2018 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 @@ -23,8 +23,7 @@ call-with-stack-overflow-handler vm-trace-level set-vm-trace-level! vm-engine set-vm-engine! set-default-vm-engine! - vm-push-continuation-hook vm-pop-continuation-hook - vm-apply-hook + vm-apply-hook vm-return-hook vm-next-hook vm-abort-continuation-hook)) |