[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/04: Remove push continuation hook; return hook runs b
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 03/04: Remove push continuation hook; return hook runs before FP pop |
|
Date: |
Tue, 7 Aug 2018 05:07:57 -0400 (EDT) |
wingo pushed a commit to branch lightning
in repository guile.
commit f4c50447dd74f4440f48cdeaebcb555cafd699b5
Author: Andy Wingo <address@hidden>
Date: Mon Aug 6 17:00:45 2018 +0200
Remove push continuation hook; return hook runs before FP pop
* libguile/frames.c (scm_frame_return_values): New function, for use
when a frame is at "return-values".
(scm_init_frames_builtins): Register frame-return-values.
* libguile/vm-engine.c (RETURN_HOOK): Rename from POP_CONTINUATION_HOOK.
(call, call-label): Remove PUSH_CONTINUATION_HOOK; it's unneeded, as
you can always check the FP from an apply hook.
(return-values): Run return hook before popping frame.
* libguile/vm.c (vm_dispatch_return_hook): Rename from
vm_dispatch_pop_continuation_hook. Remove push continuation hook.
(scm_vm_return_hook):
* libguile/vm.h (SCM_VM_PUSH_CONTINUATION_HOOK): Remove.
(SCM_VM_RETURN_HOOK): Rename from SCM_VM_POP_CONTINUATION_HOOK.
* module/system/vm/frame.scm (frame-return-values): Export.
* module/system/vm/trace.scm (print-return, trace-calls-to-procedure)
(trace-calls-in-procedure): Adapt to not receiving values as
arguments.
* module/system/vm/traps.scm (trap-in-procedure, trap-frame-finish):
Adapt to return hook coming from returning frame.
(program-sources-by-line): Update to use match instead of pmatch.
* module/system/vm/traps.scm (trap-in-dynamic-extent)
(trap-calls-to-procedure): Adapt to return hook not receiving values.
* module/system/vm/vm.scm: Remove push continuation hook and rename
return hook.
---
libguile/frames.c | 31 +++++++++++
libguile/vm-engine.c | 14 ++---
libguile/vm.c | 39 ++++----------
libguile/vm.h | 6 +--
module/system/vm/frame.scm | 1 +
module/system/vm/trace.scm | 15 +++---
module/system/vm/traps.scm | 131 +++++++++++++++++++++++++--------------------
module/system/vm/vm.scm | 5 +-
8 files changed, 132 insertions(+), 110 deletions(-)
diff --git a/libguile/frames.c b/libguile/frames.c
index d989d62..0ad40ed 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 5ca75e0..4c8bf6e 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 1ad95ba..479e3a4 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 a5cdacb..6d6bd4e 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 2491ed0..2b55ce4 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 36fbe92..e9f17da 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 8bee103..a701689 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 5274684..7da5d8c 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))