diff options
-rw-r--r-- | libguile/control.c | 9 | ||||
-rw-r--r-- | libguile/control.h | 6 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 8 | ||||
-rw-r--r-- | module/language/tree-il.scm | 51 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 10 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 5 | ||||
-rw-r--r-- | module/language/tree-il/inline.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 7 |
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* |