summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/control.c9
-rw-r--r--libguile/control.h6
-rw-r--r--libguile/vm-i-system.c8
-rw-r--r--module/language/tree-il.scm51
-rw-r--r--module/language/tree-il/analyze.scm10
-rw-r--r--module/language/tree-il/compile-glil.scm5
-rw-r--r--module/language/tree-il/inline.scm4
-rw-r--r--module/language/tree-il/primitives.scm7
8 files changed, 38 insertions, 62 deletions
diff --git a/libguile/control.c b/libguile/control.c
index bcbc6a136..0686924d5 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -49,19 +49,19 @@ SCM_DEFINE (scm_atprompt, "@prompt", 4, 0, 0,
#undef FUNC_NAME
SCM
-scm_c_make_prompt (SCM vm, SCM k, SCM handler, SCM pre_unwind,
- scm_t_uint8 inline_p, scm_t_uint8 escape_only_p)
+scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 inline_handler_p,
+ scm_t_uint8 escape_only_p)
{
scm_t_bits tag;
SCM ret;
struct scm_prompt_registers *regs;
tag = scm_tc7_prompt;
- if (inline_p)
+ if (inline_handler_p)
tag |= SCM_F_PROMPT_INLINE;
if (escape_only_p)
tag |= SCM_F_PROMPT_ESCAPE;
- ret = scm_words (tag, 6);
+ ret = scm_words (tag, 5);
regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
regs->fp = SCM_VM_DATA (vm)->fp;
@@ -72,7 +72,6 @@ scm_c_make_prompt (SCM vm, SCM k, SCM handler, SCM pre_unwind,
SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
SCM_SET_CELL_OBJECT (ret, 4, handler);
- SCM_SET_CELL_OBJECT (ret, 5, pre_unwind);
return ret;
}
diff --git a/libguile/control.h b/libguile/control.h
index b49856259..9fe880b11 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -31,7 +31,6 @@
#define SCM_PROMPT_REGISTERS(x) ((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
#define SCM_PROMPT_DYNENV(x) (SCM_CELL_OBJECT ((x), 3))
#define SCM_PROMPT_HANDLER(x) (SCM_CELL_OBJECT ((x), 4))
-#define SCM_PROMPT_PRE_UNWIND_HANDLER(x) (SCM_CELL_OBJECT ((x), 5))
#define SCM_PROMPT_SETJMP(p) (SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))
@@ -44,8 +43,9 @@ struct scm_prompt_registers
};
-SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler, SCM pre_unwind,
- scm_t_uint8 inline_p, scm_t_uint8 escape_only_p);
+SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler,
+ scm_t_uint8 inline_handler_p,
+ scm_t_uint8 escape_only_p);
SCM_INTERNAL void scm_register_control (void);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 003bdb443..15e339492 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1450,16 +1450,15 @@ VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 3, 0)
+VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 2, 0)
{
scm_t_int32 offset;
scm_t_uint8 inline_handler_p, escape_only_p;
- SCM k, handler, pre_unwind, prompt;
+ SCM k, handler, prompt;
inline_handler_p = FETCH ();
escape_only_p = FETCH ();
FETCH_OFFSET (offset);
- POP (pre_unwind);
POP (handler);
POP (k);
@@ -1467,8 +1466,7 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 3, 0)
/* Push the prompt onto the dynamic stack. The setjmp itself has to be local
to this procedure. */
/* FIXME: do more error checking */
- prompt = scm_c_make_prompt (vm, k, handler, pre_unwind,
- inline_handler_p, escape_only_p);
+ prompt = scm_c_make_prompt (vm, k, handler, inline_handler_p, escape_only_p);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
if (SCM_PROMPT_SETJMP (prompt))
{
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 726918d7d..47b2d831a 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -47,7 +47,7 @@
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
<dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
- <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler prompt-pre-unwind-handler
+ <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<control> control? make-control control-src control-tag control-type control-args
parse-tree-il
@@ -81,7 +81,7 @@
(<let-values> exp body)
(<dynwind> winder body unwinder)
(<dynlet> fluids vals body)
- (<prompt> tag body handler pre-unwind-handler)
+ (<prompt> tag body handler)
(<control> tag type args))
@@ -179,9 +179,8 @@
((dynlet ,fluids ,vals ,body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
- ((prompt ,tag ,body ,handler ,pre-unwind-handler)
- (make-prompt loc (retrans tag) (retrans body) (retrans handler)
- (and=> pre-unwind-handler retrans)))
+ ((prompt ,tag ,body ,handler)
+ (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
((control ,tag ,type ,args)
(make-control loc (retrans tag) type (map retrans args)))
@@ -258,9 +257,8 @@
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
,(unparse-tree-il body)))
- ((<prompt> tag body handler pre-unwind-handler)
- `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)
- ,(and=> pre-unwind-handler unparse-tree-il)))
+ ((<prompt> tag body handler)
+ `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)))
((<control> tag type args)
`(control ,(unparse-tree-il tag) ,type ,(map unparse-tree-il args)))))
@@ -348,10 +346,10 @@
(map tree-il->scheme vals))
,(tree-il->scheme body)))
- ((<prompt> tag body handler pre-unwind-handler)
+ ((<prompt> tag body handler)
`((@ (ice-9 control) prompt)
,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body))
- ,(tree-il->scheme handler) ,(and=> pre-unwind-handler tree-il->scheme)))
+ ,(tree-il->scheme handler)))
((<control> tag type args)
@@ -418,14 +416,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop body
(loop vals
(loop fluids (down tree result))))))
- ((<prompt> tag body handler pre-unwind-handler)
- (up tree (loop tag
- (loop body
- (loop handler
- (if pre-unwind-handler
- (loop pre-unwind-handler
- (down tree result))
- (down tree result)))))))
+ ((<prompt> tag body handler)
+ (up tree
+ (loop tag (loop body (loop handler
+ (down tree result))))))
((<control> tag type args)
(up tree (loop tag (loop args (down tree result)))))
(else
@@ -491,13 +485,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
- ((<prompt> tag body handler pre-unwind-handler)
+ ((<prompt> tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
- ((seed ...) (foldts body seed ...))
- ((seed ...) (foldts handler seed ...)))
- (if pre-unwind-handler
- (values seed ...)
- (foldts pre-unwind-handler seed ...))))
+ ((seed ...) (foldts body seed ...)))
+ (foldts handler seed ...)))
((<control> tag args)
(let*-values (((seed ...) (foldts tag seed ...)))
(fold-values foldts args seed ...)))
@@ -567,12 +558,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (dynlet-vals x) (map lp vals))
(set! (dynlet-body x) (lp body)))
- ((<prompt> tag body handler pre-unwind-handler)
+ ((<prompt> tag body handler)
(set! (prompt-tag x) (lp tag))
(set! (prompt-body x) (lp body))
- (set! (prompt-handler x) (lp handler))
- (if pre-unwind-handler
- (set! (prompt-pre-unwind-handler x) (lp pre-unwind-handler))))
+ (set! (prompt-handler x) (lp handler)))
((<control> tag args)
(set! (control-tag x) (lp tag))
@@ -644,12 +633,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (dynlet-vals x) (map lp vals))
(set! (dynlet-body x) (lp body)))
- ((<prompt> tag body handler pre-unwind-handler)
+ ((<prompt> tag body handler)
(set! (prompt-tag x) (lp tag))
(set! (prompt-body x) (lp body))
- (set! (prompt-handler x) (lp handler))
- (if pre-unwind-handler
- (set! (prompt-pre-unwind-handler x) (lp pre-unwind-handler))))
+ (set! (prompt-handler x) (lp handler)))
((<control> tag args)
(set! (control-tag x) (lp tag))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index c60bcce8e..3363103e0 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -342,9 +342,8 @@
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
- ((<prompt> tag body handler pre-unwind-handler)
- (lset-union eq? (step tag) (step handler)
- (if pre-unwind-handler (step pre-unwind-handler) '())))
+ ((<prompt> tag body handler)
+ (lset-union eq? (step tag) (step handler)))
((<control> tag type args)
(apply lset-union eq? (step tag) (map step args)))
@@ -506,14 +505,13 @@
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
- ((<prompt> tag body handler pre-unwind-handler)
+ ((<prompt> tag body handler)
(let ((cont-var (and (lambda-case? handler)
(pair? (lambda-case-vars handler))
(car (lambda-case-vars handler)))))
(hashq-set! allocation x
(and cont-var (zero? (hashq-ref refcounts cont-var 0))))
- (max (recur tag) (recur body) (recur handler)
- (if pre-unwind-handler (recur pre-unwind-handler) 0))))
+ (max (recur tag) (recur body) (recur handler))))
((<control> tag type args)
(apply max (recur tag) (map recur args)))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 887a24701..d85de2aa2 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1020,7 +1020,7 @@
;; if the continuation isn't referenced, we don't reify it. This makes it
;; possible to implement catch and throw with delimited continuations,
;; without any overhead.
- ((<prompt> src tag body handler pre-unwind-handler)
+ ((<prompt> src tag body handler)
(let ((H (make-label))
(POST (make-label))
(inline? (lambda-case? handler))
@@ -1030,9 +1030,6 @@
(if inline?
(emit-code #f (make-glil-const #f)) ;; push #f as handler
(comp-push handler))
- (if pre-unwind-handler
- (comp-push pre-unwind-handler)
- (emit-code #f (make-glil-const #f)))
(emit-code src (make-glil-prompt H inline? escape-only?))
;; Then we compile the body, with its normal return path, unwinding
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index ec030c89a..0653db188 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -110,14 +110,14 @@
((<fix> vars body)
(if (null? vars) body x))
- ((<prompt> src tag body handler pre-unwind-handler)
+ ((<prompt> src tag body handler)
;; If the handler is a simple lambda, inline it.
(if (and (lambda? handler)
(record-case (lambda-body handler)
((<lambda-case> req opt kw rest alternate)
(and (pair? req) (not opt) (not kw) (not alternate)))
(else #f)))
- (make-prompt src tag body (lambda-body handler) pre-unwind-handler)
+ (make-prompt src tag body (lambda-body handler))
x))
(else #f)))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 2593426e0..76bc88b7c 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -426,16 +426,13 @@
((src tag thunk handler)
(make-prompt src tag (make-application #f thunk '())
handler #f))
- ((src tag thunk handler pre)
- (make-prompt src tag (make-application #f thunk '())
- handler pre))
(else #f)))
(hashq-set! *primitive-expand-table*
'@prompt
(case-lambda
- ((src tag thunk handler pre)
+ ((src tag thunk handler)
(make-prompt src tag (make-application #f thunk '())
- handler pre))
+ handler))
(else #f)))
(hashq-set! *primitive-expand-table*