From 2d026f04cc581915f62b1f2f3be2f27026ee383e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 Feb 2010 21:53:24 +0100 Subject: [PATCH] abort always dispatches to VM bytecode, to detect same-invocation aborts * libguile/control.h: * libguile/control.c (scm_c_make_prompt): Take an extra arg, a cookie. Continuations will be rewindable only if the abort has the same cookie as the prompt. (scm_at_abort): Redefine from scm_abort, and instead of taking rest args, take the abort values as a list directly. Also, don't allow rewinding, because we won't support rewinding the C stack with delimited continuations. * libguile/eval.c (eval): Adapt to scm_c_make_prompt change. * libguile/vm-engine.c (vm_engine): Use vp->cookie to get a unique value corresponding to this VM invocation. * libguile/vm-i-system.c (prompt): Pass the cookie to scm_c_make_prompt. (abort): Take an additional tail arg. * libguile/vm.c (vm_abort): Parse out the abort tail arg. This is for the @abort case, or the (apply abort ...) case. (make_vm): Initialize the cookie to 0. * libguile/vm.h (struct scm_vm): Add cookie. * module/ice-9/boot-9.scm (abort): Define here as a trampoline to @abort. Needed to make sure that a call to abort dispatches to a VM opcode, so the cookie will be the same. * module/language/tree-il.scm (): Add a "tail" field to , for the (apply abort ...) case, or (@abort tag args). Should be # in the normal case. Add support throughout. * module/language/tree-il/analyze.scm (analyze-lexicals): Add abort-tail support here too. * module/language/tree-il/compile-glil.scm (flatten): Compile the tail argument appropriately. * module/language/tree-il/primitives.scm (*primitive-expand-table*): Fix @abort and abort cases to pass the tail arg to make-abort. --- libguile/control.c | 30 ++++++------------ libguile/control.h | 5 ++- libguile/eval.c | 2 +- libguile/vm-engine.c | 2 ++ libguile/vm-i-system.c | 4 +-- libguile/vm.c | 17 +++++++++-- libguile/vm.h | 1 + module/ice-9/boot-9.scm | 2 ++ module/language/tree-il.scm | 39 +++++++++++++----------- module/language/tree-il/analyze.scm | 8 ++--- module/language/tree-il/compile-glil.scm | 3 +- module/language/tree-il/primitives.scm | 10 ++++-- 12 files changed, 72 insertions(+), 51 deletions(-) diff --git a/libguile/control.c b/libguile/control.c index a243be037..371ec2d20 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -27,7 +27,8 @@ SCM -scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p) +scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p, + scm_t_int64 vm_cookie) { scm_t_bits tag; SCM ret; @@ -42,6 +43,7 @@ scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p) regs->fp = SCM_VM_DATA (vm)->fp; regs->sp = SCM_VM_DATA (vm)->sp; regs->ip = SCM_VM_DATA (vm)->ip; + regs->cookie = vm_cookie; SCM_SET_CELL_OBJECT (ret, 1, k); SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs); @@ -109,9 +111,9 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv) abort (); } -SCM_DEFINE (scm_abort, "abort", 1, 0, 1, (SCM tag, SCM args), +SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args), "Abort to the nearest prompt with tag @var{tag}.") -#define FUNC_NAME s_scm_abort +#define FUNC_NAME s_scm_at_abort { SCM *argv; size_t i, n; @@ -123,23 +125,11 @@ SCM_DEFINE (scm_abort, "abort", 1, 0, 1, (SCM tag, SCM args), scm_c_abort (scm_the_vm (), tag, n, argv); - /* Oh, what, you're still here? The abort must have been reinstated. OK, pull - args back from the stack, and keep going... */ - - { - SCM vals = SCM_EOL; - struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); - n = scm_to_size_t (vp->sp[0]); - for (i = 0; i < n; i++) - vals = scm_cons (vp->sp[-(i + 1)], vals); - /* The continuation call did reset the VM's registers, but then these values - were pushed on; so we need to pop them ourselves. */ - vp->sp -= n + 1; - /* FIXME NULLSTACK */ - - return (scm_is_pair (vals) && scm_is_null (scm_cdr (vals))) - ? scm_car (vals) : scm_values (vals); - } + /* Oh, what, you're still here? The abort must have been reinstated. Actually, + that's quite impossible, given that we're already in C-land here, so... + abort! */ + + abort (); } #undef FUNC_NAME diff --git a/libguile/control.h b/libguile/control.h index 3ec965705..6144a38c9 100644 --- a/libguile/control.h +++ b/libguile/control.h @@ -37,12 +37,15 @@ struct scm_prompt_registers scm_t_uint8 *ip; SCM *sp; SCM *fp; + scm_t_int64 cookie; scm_i_jmp_buf regs; }; -SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p); +SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p, + scm_t_int64 cookie); SCM_INTERNAL SCM scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv) SCM_NORETURN; +SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN; SCM_INTERNAL void scm_init_control (void); diff --git a/libguile/eval.c b/libguile/eval.c index 1b466de44..c82e5431d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -429,7 +429,7 @@ eval (SCM x, SCM env) { SCM prompt, handler, res; - prompt = scm_c_make_prompt (scm_the_vm (), eval (CAR (mx), env), 0); + prompt = scm_c_make_prompt (scm_the_vm (), eval (CAR (mx), env), 0, -1); handler = eval (CDDR (mx), env); scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ())); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 5d1e1d68d..8c188d33d 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -47,7 +47,9 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) SCM *objects = NULL; /* constant objects */ size_t object_count = 0; /* length of OBJECTS */ SCM *stack_limit = vp->stack_limit; /* stack limit address */ + SCM dynstate = SCM_I_CURRENT_THREAD->dynamic_state; + scm_t_int64 vm_cookie = vp->cookie++; /* Internal variables */ int nvalues = 0; diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 7a1700101..faae6ab3e 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1464,7 +1464,7 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 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, escape_only_p); + prompt = scm_c_make_prompt (vm, k, escape_only_p, vm_cookie); scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ())); if (SCM_PROMPT_SETJMP (prompt)) { @@ -1509,7 +1509,7 @@ VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1) { unsigned n = FETCH (); SYNC_REGISTER (); - if (sp - n - 1 <= SCM_FRAME_UPPER_ADDRESS (fp)) + if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp)) goto vm_error_stack_underflow; vm_abort (vm, n); /* vm_abort should not return */ diff --git a/libguile/vm.c b/libguile/vm.c index 7433a11e3..831200fdf 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -206,15 +206,25 @@ static void vm_abort (SCM vm, size_t n) { size_t i; - SCM tag, *argv; + ssize_t tail_len; + SCM tag, tail, *argv; + /* FIXME: VM_ENABLE_STACK_NULLING */ + tail = *(SCM_VM_DATA (vm)->sp--); + /* NULLSTACK (1) */ + tail_len = scm_ilength (tail); + if (tail_len < 0) + abort (); tag = SCM_VM_DATA (vm)->sp[-n]; - argv = alloca (n * sizeof (SCM)); + argv = alloca ((n + tail_len) * sizeof (SCM)); for (i = 0; i < n; i++) argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)]; + for (; i < n + tail_len; i++, tail = scm_cdr (tail)) + argv[i] = scm_car (tail); + /* NULLSTACK (n + 1) */ SCM_VM_DATA (vm)->sp -= n + 1; - scm_c_abort (vm, tag, n, argv); + scm_c_abort (vm, tag, n + tail_len, argv); } @@ -386,6 +396,7 @@ make_vm (void) vp->trace_level = 0; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) vp->hooks[i] = SCM_BOOL_F; + vp->cookie = 0; return scm_cell (scm_tc7_vm, (scm_t_bits)vp); } #undef FUNC_NAME diff --git a/libguile/vm.h b/libguile/vm.h index 17445ea51..6d76f12e8 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -51,6 +51,7 @@ struct scm_vm { SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ SCM options; /* options */ int trace_level; /* traces enabled if trace_level > 0 */ + scm_t_int64 cookie; /* used to detect unrewindable continuations */ }; SCM_API SCM scm_the_vm_fluid; diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 6dc2b68e1..a01e6be6c 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -404,6 +404,8 @@ ;;; Delimited continuations (define (prompt tag thunk handler) (@prompt tag (thunk) handler)) +(define (abort tag . args) + (@abort tag args)) ;;; apply-to-args is functionally redundant with apply and, worse, ;;; is less general than apply since it only takes two arguments. diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index cfd26bfc6..8daf49a19 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -50,7 +50,7 @@ dynref? make-dynref dynref-src dynref-fluid dynset? make-dynset dynset-src dynset-fluid dynset-exp prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler - abort? make-abort abort-src abort-tag abort-args + abort? make-abort abort-src abort-tag abort-args abort-tail parse-tree-il unparse-tree-il @@ -86,7 +86,7 @@ ( fluid) ( fluid exp) ( tag body handler) - ( tag args)) + ( tag args tail)) @@ -192,8 +192,8 @@ ((prompt ,tag ,body ,handler) (make-prompt loc (retrans tag) (retrans body) (retrans handler))) - ((abort ,tag ,type ,args) - (make-abort loc (retrans tag) type (map retrans args))) + ((abort ,tag ,args ,tail) + (make-abort loc (retrans tag) (map retrans args) (retrans tail))) (else (error "unrecognized tree-il" exp))))) @@ -276,8 +276,9 @@ (( tag body handler) `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler))) - (( tag args) - `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args))))) + (( tag args tail) + `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) + ,(unparse-tree-il tail))))) (define (tree-il->scheme e) (record-case e @@ -374,8 +375,9 @@ ,(tree-il->scheme handler))) - (( tag args) - `(@abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args))))) + (( tag args tail) + `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args) + ,(tree-il->scheme tail))))) (define (tree-il-fold leaf down up seed tree) @@ -444,8 +446,8 @@ This is an implementation of `foldts' as described by Andy Wingo in (up tree (loop tag (loop body (loop handler (down tree result)))))) - (( tag args) - (up tree (loop tag (loop args (down tree result))))) + (( tag args tail) + (up tree (loop tail (loop args (loop tag (down tree result)))))) (else (leaf tree result)))))) @@ -518,9 +520,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (let*-values (((seed ...) (foldts tag seed ...)) ((seed ...) (foldts body seed ...))) (foldts handler seed ...))) - (( tag args) - (let*-values (((seed ...) (foldts tag seed ...))) - (fold-values foldts args seed ...))) + (( tag args tail) + (let*-values (((seed ...) (foldts tag seed ...)) + ((seed ...) (fold-values foldts args seed ...))) + (foldts tail seed ...))) (else (values seed ...))))) (up tree seed ...))))))) @@ -599,9 +602,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (prompt-body x) (lp body)) (set! (prompt-handler x) (lp handler))) - (( tag args) + (( tag args tail) (set! (abort-tag x) (lp tag)) - (set! (abort-args x) (map lp args))) + (set! (abort-args x) (map lp args)) + (set! (abort-tail x) (lp tail))) (else #f)) @@ -681,9 +685,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (prompt-body x) (lp body)) (set! (prompt-handler x) (lp handler))) - (( tag args) + (( tag args tail) (set! (abort-tag x) (lp tag)) - (set! (abort-args x) (map lp args))) + (set! (abort-args x) (map lp args)) + (set! (abort-tail x) (lp tail))) (else #f)) x))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1e9d899e9..0c3cbf85d 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -351,8 +351,8 @@ (( tag body handler) (lset-union eq? (step tag) (step body) (step handler))) - (( tag args) - (apply lset-union eq? (step tag) (map step args))) + (( tag args tail) + (apply lset-union eq? (step tag) (step tail) (map step args))) (else '()))) @@ -525,8 +525,8 @@ (and cont-var (zero? (hashq-ref refcounts cont-var 0)))) (max (recur tag) (recur body) (recur handler)))) - (( tag args) - (apply max (recur tag) (map recur args))) + (( tag args tail) + (apply max (recur tag) (recur tail) (map recur args))) (else n))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index bfe6f05cb..7030430f0 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -1111,9 +1111,10 @@ (and (eq? context 'drop) (not RA))) (emit-label POST)))) - (( src tag args) + (( src tag args tail) (comp-push tag) (for-each comp-push args) + (comp-push tail) (emit-code src (make-glil-call 'abort (length args))) ;; so, the abort can actually return. if it does, the values will be on ;; the stack, then the MV marker, just as in an MV context. diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index f5320db38..43e53f45e 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -63,7 +63,7 @@ fluid-ref fluid-set! - @prompt prompt abort + @prompt prompt @abort abort struct? struct-vtable make-struct struct-ref struct-set! @@ -475,9 +475,15 @@ (else #f))) (else #f))) +(hashq-set! *primitive-expand-table* + '@abort + (case-lambda + ((src tag tail-args) + (make-abort src tag '() tail-args)) + (else #f))) (hashq-set! *primitive-expand-table* 'abort (case-lambda ((src tag . args) - (make-abort src tag args)) + (make-abort src tag args (make-const #f '()))) (else #f))) -- 2.20.1