diff options
Diffstat (limited to 'libguile/vm-i-system.c')
-rw-r--r-- | libguile/vm-i-system.c | 254 |
1 files changed, 97 insertions, 157 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index b8c18f077..ef559ae52 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -525,12 +525,25 @@ VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) BR (!scm_is_null (x)); } +VM_DEFINE_INSTRUCTION (41, br_if_nil, "br-if-nil", 3, 0, 0) +{ + SCM x; + POP (x); + BR (scm_is_lisp_false (x)); +} + +VM_DEFINE_INSTRUCTION (42, br_if_not_nil, "br-if-not-nil", 3, 0, 0) +{ + SCM x; + POP (x); + BR (!scm_is_lisp_false (x)); +} /* * Subprogram call */ -VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) +VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) { scm_t_ptrdiff n; scm_t_int32 offset; @@ -542,7 +555,7 @@ VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) +VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) { scm_t_ptrdiff n; scm_t_int32 offset; @@ -554,7 +567,7 @@ VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) +VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) { scm_t_ptrdiff n; scm_t_int32 offset; @@ -567,7 +580,7 @@ VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) +VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -577,7 +590,7 @@ VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) +VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -587,7 +600,7 @@ VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1) +VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -597,7 +610,7 @@ VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) +VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) { SCM *walk; scm_t_ptrdiff nreq, nreq_and_opt, ntotal; @@ -640,7 +653,7 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, #define F_ALLOW_OTHER_KEYS 1 #define F_REST 2 -VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) +VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0) { scm_t_uint16 idx; scm_t_ptrdiff nkw; @@ -694,7 +707,7 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) #undef F_REST -VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) +VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1) { scm_t_ptrdiff n; SCM rest = SCM_EOL; @@ -707,7 +720,7 @@ VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1) +VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1) { scm_t_ptrdiff n; scm_t_uint32 i; @@ -723,7 +736,7 @@ VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1) +VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1) { SCM *old_sp; scm_t_int32 n; @@ -744,7 +757,7 @@ VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) +VM_DEFINE_INSTRUCTION (54, new_frame, "new-frame", 0, 0, 3) { /* NB: if you change this, see frames.c:vm-frame-num-locals */ /* and frames.h, vm-engine.c, etc of course */ @@ -759,7 +772,7 @@ VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) NEXT; } -VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) +VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1) { nargs = FETCH (); @@ -775,7 +788,7 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) sp[-nargs] = SCM_STRUCT_PROCEDURE (program); goto vm_call; } - else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + else if (SCM_HAS_TYP7 (program, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (program)) { PUSH (program); @@ -810,7 +823,7 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) +VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1) { nargs = FETCH (); @@ -826,7 +839,7 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) sp[-nargs] = SCM_STRUCT_PROCEDURE (program); goto vm_tail_call; } - else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + else if (SCM_HAS_TYP7 (program, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (program)) { PUSH (program); @@ -864,7 +877,7 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) } } -VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1) +VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1) { SCM pointer, ret; SCM (*subr)(); @@ -933,54 +946,9 @@ VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1) } } -VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1) -{ - SCM smob, ret; - SCM (*subr)(); - nargs = FETCH (); - POP (smob); - - subr = SCM_SMOB_DESCRIPTOR (smob).apply; - - VM_HANDLE_INTERRUPTS; - SYNC_REGISTER (); - - switch (nargs) - { - case 0: - ret = subr (smob); - break; - case 1: - ret = subr (smob, sp[0]); - break; - case 2: - ret = subr (smob, sp[-1], sp[0]); - break; - case 3: - ret = subr (smob, sp[-2], sp[-1], sp[0]); - break; - default: - abort (); - } - - NULLSTACK_FOR_NONLOCAL_EXIT (); - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - { - /* multiple values returned to continuation */ - ret = scm_struct_ref (ret, SCM_INUM0); - nvalues = scm_ilength (ret); - PUSH_LIST (ret, scm_is_null); - goto vm_return_values; - } - else - { - PUSH (ret); - goto vm_return; - } -} +/* Instruction 58 used to be smob-call. */ -VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1) +VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1) { SCM foreign, ret; nargs = FETCH (); @@ -1008,7 +976,7 @@ VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1) } } -VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0) +VM_DEFINE_INSTRUCTION (60, continuation_call, "continuation-call", 0, -1, 0) { SCM contregs; POP (contregs); @@ -1024,32 +992,24 @@ VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0) abort (); } -VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0) +VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0) { - SCM vmcont, intwinds, prevwinds; - POP2 (intwinds, vmcont); + SCM vmcont; + POP (vmcont); SYNC_REGISTER (); VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), vm_error_continuation_not_rewindable (vmcont)); - prevwinds = scm_i_dynwinds (); - vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp, - vm_cookie); + vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp, + ¤t_thread->dynstack, + ®isters); - /* Rewind prompt jmpbuffers, if any. */ - { - SCM winds = scm_i_dynwinds (); - for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds)) - if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds))) - break; - } - CACHE_REGISTER (); program = SCM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); NEXT; } -VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1) { SCM x; POP (x); @@ -1058,7 +1018,7 @@ VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1) goto vm_tail_call; } -VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1) { SCM x; POP (x); @@ -1067,7 +1027,7 @@ VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) +VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1) { scm_t_int32 offset; scm_t_uint8 *mvra; @@ -1088,7 +1048,7 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) sp[-nargs] = SCM_STRUCT_PROCEDURE (program); goto vm_mv_call; } - else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + else if (SCM_HAS_TYP7 (program, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (program)) { PUSH (program); @@ -1123,7 +1083,7 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1) { int len; SCM ls; @@ -1141,7 +1101,7 @@ VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1) { int len; SCM ls; @@ -1159,13 +1119,16 @@ VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1) goto vm_tail_call; } -VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (67, call_cc, "call/cc", 0, 1, 1) { int first; SCM proc, vm_cont, cont; + scm_t_dynstack *dynstack; POP (proc); SYNC_ALL (); - vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0); + dynstack = scm_dynstack_capture_all (¤t_thread->dynstack); + vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, + dynstack, 0); cont = scm_i_make_continuation (&first, vm, vm_cont); if (first) { @@ -1194,19 +1157,22 @@ VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1) { int first; SCM proc, vm_cont, cont; + scm_t_dynstack *dynstack; POP (proc); SYNC_ALL (); /* In contrast to call/cc, tail-call/cc captures the continuation without the stack frame. */ + dynstack = scm_dynstack_capture_all (¤t_thread->dynstack); vm_cont = scm_i_vm_capture_stack (vp->stack_base, SCM_FRAME_DYNAMIC_LINK (fp), SCM_FRAME_LOWER_ADDRESS (fp) - 1, SCM_FRAME_RETURN_ADDRESS (fp), SCM_FRAME_MV_RETURN_ADDRESS (fp), + dynstack, 0); cont = scm_i_make_continuation (&first, vm, vm_cont); if (first) @@ -1234,7 +1200,7 @@ VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1) +VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1) { vm_return: POP_CONTINUATION_HOOK (1); @@ -1270,7 +1236,7 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1) +VM_DEFINE_INSTRUCTION (70, return_values, "return/values", 1, -1, -1) { /* nvalues declared at top level, because for some reason gcc seems to think that perhaps it might be used without declaration. Fooey to that, I say. */ @@ -1329,7 +1295,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1) +VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1) { SCM l; @@ -1349,7 +1315,7 @@ VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1) goto vm_return_values; } -VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1) +VM_DEFINE_INSTRUCTION (72, return_nvalues, "return/nvalues", 0, 1, -1) { SCM n; POP (n); @@ -1358,7 +1324,7 @@ VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1) goto vm_return_values; } -VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1) +VM_DEFINE_INSTRUCTION (73, truncate_values, "truncate-values", 2, -1, -1) { SCM x; int nbinds, rest; @@ -1380,7 +1346,7 @@ VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0) +VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0) { SCM val; POP (val); @@ -1394,7 +1360,7 @@ VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0) (set! a (lambda () (b ...))) ...) */ -VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0) +VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0) { SYNC_BEFORE_GC (); LOCAL_SET (FETCH (), @@ -1402,7 +1368,7 @@ VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1) { SCM v = LOCAL_REF (FETCH ()); ASSERT_BOUND_VARIABLE (v); @@ -1410,7 +1376,7 @@ VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0) { SCM v, val; v = LOCAL_REF (FETCH ()); @@ -1420,7 +1386,7 @@ VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1) { scm_t_uint8 idx = FETCH (); @@ -1431,7 +1397,7 @@ VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1) /* no free-set -- if a var is assigned, it should be in a box */ -VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1) { SCM v; scm_t_uint8 idx = FETCH (); @@ -1442,7 +1408,7 @@ VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0) { SCM v, val; scm_t_uint8 idx = FETCH (); @@ -1454,7 +1420,7 @@ VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1) +VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1) { size_t n, len; SCM closure; @@ -1473,7 +1439,7 @@ VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1) +VM_DEFINE_INSTRUCTION (82, make_variable, "make-variable", 0, 0, 1) { SYNC_BEFORE_GC (); /* fixme underflow */ @@ -1481,7 +1447,7 @@ VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0) +VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0) { SCM x; unsigned int i = FETCH (); @@ -1498,7 +1464,7 @@ VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2) +VM_DEFINE_INSTRUCTION (84, define, "define", 0, 0, 2) { SCM sym, val; POP2 (sym, val); @@ -1509,7 +1475,7 @@ VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2) NEXT; } -VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1) +VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@ -1517,7 +1483,7 @@ VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1) +VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@ -1525,11 +1491,12 @@ VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0) +VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0) { scm_t_int32 offset; scm_t_uint8 escape_only_p; - SCM k, prompt; + SCM k; + scm_t_dynstack_prompt_flags flags; escape_only_p = FETCH (); FETCH_OFFSET (offset); @@ -1537,92 +1504,66 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0) SYNC_REGISTER (); /* Push the prompt onto the dynamic stack. */ - prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie, - scm_i_dynwinds ()); - scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt))); - if (SCM_PROMPT_SETJMP (prompt)) - { - /* The prompt exited nonlocally. Cache the regs back from the vp, and go - to the handler. - - Note, at this point, we must assume that any variable local to - vm_engine that can be assigned *has* been assigned. So we need to pull - all our state back from the ip/fp/sp. - */ - CACHE_REGISTER (); - program = SCM_FRAME_PROGRAM (fp); - CACHE_PROGRAM (); - /* The stack contains the values returned to this prompt, along - with a number-of-values marker -- like an MV return. */ - ABORT_CONTINUATION_HOOK (); - NEXT; - } - - /* Otherwise setjmp returned for the first time, so we go to execute the - prompt's body. */ + flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; + scm_dynstack_push_prompt (¤t_thread->dynstack, flags, k, + fp, sp, ip + offset, ®isters); NEXT; } -VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0) +VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0) { SCM wind, unwind; POP2 (unwind, wind); SYNC_REGISTER (); /* Push wind and unwind procedures onto the dynamic stack. Note that neither are actually called; the compiler should emit calls to wind and unwind for - the normal dynamic-wind control flow. */ - VM_ASSERT (scm_to_bool (scm_thunk_p (wind)), - vm_error_not_a_thunk ("dynamic-wind", wind)); - VM_ASSERT (scm_to_bool (scm_thunk_p (unwind)), - vm_error_not_a_thunk ("dynamic-wind", unwind)); - scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ())); + the normal dynamic-wind control flow. Also note that the compiler + should have inserted checks that they wind and unwind procs are + thunks, if it could not prove that to be the case. */ + scm_dynstack_push_dynwind (¤t_thread->dynstack, wind, unwind); NEXT; } -VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1) +VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1) { unsigned n = FETCH (); SYNC_REGISTER (); PRE_CHECK_UNDERFLOW (n + 2); - vm_abort (vm, n, vm_cookie); + vm_abort (vm, n, ®isters); /* vm_abort should not return */ abort (); } -VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0) +VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0) { /* A normal exit from the dynamic extent of an expression. Pop the top entry off of the dynamic stack. */ - scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ())); + scm_dynstack_pop (¤t_thread->dynstack); NEXT; } -VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0) +VM_DEFINE_INSTRUCTION (91, wind_fluids, "wind-fluids", 1, -1, 0) { unsigned n = FETCH (); - SCM wf; SYNC_REGISTER (); sp -= 2 * n; CHECK_UNDERFLOW (); - wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n); + scm_dynstack_push_fluids (¤t_thread->dynstack, n, sp + 1, sp + 1 + n, + current_thread->dynamic_state); NULLSTACK (2 * n); - - scm_i_swap_with_fluids (wf, current_thread->dynamic_state); - scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ())); NEXT; } -VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) +VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0) { - SCM wf; - wf = scm_car (scm_i_dynwinds ()); - scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ())); - scm_i_swap_with_fluids (wf, current_thread->dynamic_state); + /* This function must not allocate. */ + scm_dynstack_unwind_fluids (¤t_thread->dynstack, + current_thread->dynamic_state); NEXT; } -VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1) +VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1) { size_t num; SCM fluids; @@ -1649,7 +1590,7 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0) +VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0) { size_t num; SCM val, fluid, fluids; @@ -1669,7 +1610,7 @@ VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0) NEXT; } -VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0) +VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0) { scm_t_ptrdiff n; SCM *old_sp; @@ -1689,7 +1630,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, NEXT; } - /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" |