X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/731dd0ce191bf4f3ba8fedfe0e08c0e67a966ce4..805b4179bfe44506e6dcd3e62c6868659ffdafb6:/libguile/vm-i-system.c?ds=sidebyside diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index f58ffce58..cedd43fd5 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. +/* Copyright (C) 2001,2008,2009,2010 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 License @@ -31,7 +31,6 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0) VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) { - vp->time += scm_c_get_internal_run_time () - start_time; HALT_HOOK (); nvalues = SCM_I_INUM (*sp--); NULLSTACK (1); @@ -105,31 +104,37 @@ VM_DEFINE_INSTRUCTION (7, make_false, "make-false", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1) +VM_DEFINE_INSTRUCTION (8, make_nil, "make-nil", 0, 0, 1) +{ + PUSH (SCM_ELISP_NIL); + NEXT; +} + +VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1) { PUSH (SCM_EOL); NEXT; } -VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1) +VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1) { PUSH (SCM_I_MAKINUM ((signed char) FETCH ())); NEXT; } -VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1) +VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1) { PUSH (SCM_INUM0); NEXT; } -VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1) +VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1) { PUSH (SCM_I_MAKINUM (1)); NEXT; } -VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1) +VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1) { int h = FETCH (); int l = FETCH (); @@ -137,7 +142,7 @@ VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@ -152,7 +157,7 @@ VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@ -167,7 +172,7 @@ VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1) +VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1) { scm_t_uint8 v = 0; v = FETCH (); @@ -179,7 +184,7 @@ VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1) +VM_DEFINE_INSTRUCTION (17, make_char32, "make-char32", 4, 0, 1) { scm_t_wchar v = 0; v += FETCH (); @@ -192,7 +197,7 @@ VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1) -VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) +VM_DEFINE_INSTRUCTION (18, list, "list", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@ -201,7 +206,7 @@ VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) +VM_DEFINE_INSTRUCTION (19, vector, "vector", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@ -237,11 +242,11 @@ VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED) -#define FREE_VARIABLE_REF(i) free_vars[i] +#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i) /* ref */ -VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (20, object_ref, "object-ref", 1, 0, 1) { register unsigned objnum = FETCH (); CHECK_OBJECT (objnum); @@ -250,7 +255,7 @@ VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1) } /* FIXME: necessary? elt 255 of the vector could be a vector... */ -VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1) +VM_DEFINE_INSTRUCTION (21, long_object_ref, "long-object-ref", 2, 0, 1) { unsigned int objnum = FETCH (); objnum <<= 8; @@ -260,14 +265,14 @@ VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); ASSERT_BOUND (*sp); NEXT; } -VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1) +VM_DEFINE_INSTRUCTION (23, long_local_ref, "long-local-ref", 2, 0, 1) { unsigned int i = FETCH (); i <<= 8; @@ -277,7 +282,7 @@ VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1) +VM_DEFINE_INSTRUCTION (24, local_bound, "local-bound?", 1, 0, 1) { if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED) PUSH (SCM_BOOL_F); @@ -286,7 +291,7 @@ VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1) +VM_DEFINE_INSTRUCTION (25, long_local_bound, "long-local-bound?", 2, 0, 1) { unsigned int i = FETCH (); i <<= 8; @@ -298,7 +303,7 @@ VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 0, 1) +VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref", 0, 1, 1) { SCM x = *sp; @@ -317,7 +322,7 @@ VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 0, 1) +VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 1, 1) { if (VARIABLE_BOUNDP (*sp)) *sp = SCM_BOOL_T; @@ -326,7 +331,7 @@ VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1) { unsigned objnum = FETCH (); SCM what; @@ -349,7 +354,7 @@ VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) +VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) { SCM what; unsigned int objnum = FETCH (); @@ -376,14 +381,14 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) /* set */ -VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0) { LOCAL_SET (FETCH (), *sp); DROP (); NEXT; } -VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0) +VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0) { unsigned int i = FETCH (); i <<= 8; @@ -393,14 +398,14 @@ VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 1, 0) +VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 2, 0) { VARIABLE_SET (sp[0], sp[-1]); DROPN (2); NEXT; } -VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0) { unsigned objnum = FETCH (); SCM what; @@ -419,7 +424,7 @@ VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0) +VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0) { SCM what; unsigned int objnum = FETCH (); @@ -460,49 +465,53 @@ VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0) FETCH_OFFSET (offset); \ if (p) \ ip += offset; \ + if (offset < 0) \ + VM_HANDLE_INTERRUPTS; \ NULLSTACK (1); \ DROP (); \ NEXT; \ } -VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0) +VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0) { scm_t_int32 offset; FETCH_OFFSET (offset); ip += offset; + if (offset < 0) + VM_HANDLE_INTERRUPTS; NEXT; } -VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0) +VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0) { - BR (scm_is_true_and_not_nil (*sp)); + BR (scm_is_true (*sp)); } -VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0) +VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0) { - BR (scm_is_false_or_nil (*sp)); + BR (scm_is_false (*sp)); } -VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0) +VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0) { sp--; /* underflow? */ - BR (SCM_EQ_P (sp[0], sp[1])); + BR (scm_is_eq (sp[0], sp[1])); } -VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0) +VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 3, 0, 0) { sp--; /* underflow? */ - BR (!SCM_EQ_P (sp[0], sp[1])); + BR (!scm_is_eq (sp[0], sp[1])); } -VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0) +VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0) { - BR (scm_is_null_or_nil (*sp)); + BR (scm_is_null (*sp)); } -VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) +VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0) { - BR (!scm_is_null_or_nil (*sp)); + BR (!scm_is_null (*sp)); } @@ -510,43 +519,44 @@ VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) * Subprogram call */ -VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) +VM_DEFINE_INSTRUCTION (42, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) { scm_t_ptrdiff n; + scm_t_int32 offset; n = FETCH () << 8; n += FETCH (); - scm_t_int32 offset; FETCH_OFFSET (offset); if (sp - (fp - 1) != n) ip += offset; NEXT; } -VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) +VM_DEFINE_INSTRUCTION (43, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) { scm_t_ptrdiff n; + scm_t_int32 offset; n = FETCH () << 8; n += FETCH (); - scm_t_int32 offset; FETCH_OFFSET (offset); if (sp - (fp - 1) < n) ip += offset; NEXT; } -VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) +VM_DEFINE_INSTRUCTION (44, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) { scm_t_ptrdiff n; + scm_t_int32 offset; + n = FETCH () << 8; n += FETCH (); - scm_t_int32 offset; FETCH_OFFSET (offset); if (sp - (fp - 1) > n) ip += offset; NEXT; } -VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) +VM_DEFINE_INSTRUCTION (45, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -556,7 +566,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 (46, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -566,7 +576,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 (47, bind_optionals, "bind-optionals", 2, -1, -1) { scm_t_ptrdiff n; n = FETCH () << 8; @@ -576,7 +586,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 (48, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) { SCM *walk; scm_t_ptrdiff nreq, nreq_and_opt, ntotal; @@ -613,55 +623,66 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, NEXT; } -VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) +/* Flags that determine whether other keywords are allowed, and whether a + rest argument is expected. These values must match those used by the + glil->assembly compiler. */ +#define F_ALLOW_OTHER_KEYS 1 +#define F_REST 2 + +VM_DEFINE_INSTRUCTION (49, bind_kwargs, "bind-kwargs", 5, 0, 0) { scm_t_uint16 idx; scm_t_ptrdiff nkw; - int allow_other_keys_and_rest; + int kw_and_rest_flags; SCM kw; idx = FETCH () << 8; idx += FETCH (); + /* XXX: We don't actually use NKW. */ nkw = FETCH () << 8; nkw += FETCH (); - allow_other_keys_and_rest = FETCH (); + kw_and_rest_flags = FETCH (); - if (!(allow_other_keys_and_rest & 2) - &&(sp - (fp - 1) - nkw) % 2) + if (!(kw_and_rest_flags & F_REST) + && ((sp - (fp - 1) - nkw) % 2)) goto vm_error_kwargs_length_not_even; CHECK_OBJECT (idx); kw = OBJECT_REF (idx); - /* switch nkw to be a negative index below sp */ - for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw += 2) + + /* Switch NKW to be a negative index below SP. */ + for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++) { SCM walk; - if (!scm_is_keyword (sp[nkw])) - { - if (allow_other_keys_and_rest & 2) - /* reached the end of keywords, but we have a rest arg; just cut - out */ - break; - else - goto vm_error_kwargs_invalid_keyword; - } - for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) - { - if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) - { - SCM si = SCM_CDAR (walk); - LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), - sp[nkw + 1]); - break; - } - } - if (!(allow_other_keys_and_rest & 1) && !scm_is_pair (walk)) - goto vm_error_kwargs_unrecognized_keyword; + + if (scm_is_keyword (sp[nkw])) + { + for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) + { + if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) + { + SCM si = SCM_CDAR (walk); + LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), + sp[nkw + 1]); + break; + } + } + if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk)) + goto vm_error_kwargs_unrecognized_keyword; + + nkw++; + } + else if (!(kw_and_rest_flags & F_REST)) + goto vm_error_kwargs_invalid_keyword; } NEXT; } -VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) +#undef F_ALLOW_OTHER_KEYS +#undef F_REST + + +VM_DEFINE_INSTRUCTION (50, push_rest, "push-rest", 2, -1, -1) { scm_t_ptrdiff n; SCM rest = SCM_EOL; @@ -674,7 +695,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 (51, bind_rest, "bind-rest", 4, -1, -1) { scm_t_ptrdiff n; scm_t_uint32 i; @@ -690,7 +711,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 (52, reserve_locals, "reserve-locals", 2, -1, -1) { SCM *old_sp; scm_t_int32 n; @@ -711,7 +732,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 (53, 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 */ @@ -721,81 +742,72 @@ VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) NEXT; } -VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) +VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1) { - SCM x; nargs = FETCH (); vm_call: - x = sp[-nargs]; + program = sp[-nargs]; - SYNC_REGISTER (); - SCM_TICK; /* allow interrupt here */ + VM_HANDLE_INTERRUPTS; - /* - * Subprogram call - */ - if (SCM_PROGRAM_P (x)) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) { - program = x; - CACHE_PROGRAM (); - fp = sp - nargs + 1; - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); - ip = bp->base; - ENTER_HOOK (); - APPLY_HOOK (); - NEXT; - } - /* - * Other interpreted or compiled call - */ - if (!SCM_FALSEP (scm_procedure_p (x))) - { - SCM args; - /* At this point, the stack contains the frame, the procedure and each one - of its arguments. */ - POP_LIST (nargs); - POP (args); - DROP (); /* drop the procedure */ - DROP_FRAME (); - - SYNC_REGISTER (); - PUSH (scm_apply (x, args, SCM_EOL)); - NULLSTACK_FOR_NONLOCAL_EXIT (); - if (SCM_UNLIKELY (SCM_VALUESP (*sp))) + if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) { - /* truncate values */ - SCM values; - POP (values); - values = scm_struct_ref (values, SCM_INUM0); - if (scm_is_null (values)) - goto vm_error_not_enough_values; - PUSH (SCM_CAR (values)); + sp[-nargs] = SCM_STRUCT_PROCEDURE (program); + goto vm_call; } - NEXT; + else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + && SCM_SMOB_APPLICABLE_P (program)) + { + SYNC_REGISTER (); + sp[-nargs] = scm_i_smob_apply_trampoline (program); + goto vm_call; + } + else + goto vm_error_wrong_type_apply; } - program = x; - goto vm_error_wrong_type_apply; + CACHE_PROGRAM (); + fp = sp - nargs + 1; + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); + ip = SCM_C_OBJCODE_BASE (bp); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; } -VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1) +VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1) { - register SCM x; nargs = FETCH (); - vm_goto_args: - x = sp[-nargs]; - SYNC_REGISTER (); - SCM_TICK; /* allow interrupt here */ + vm_tail_call: + program = sp[-nargs]; + + VM_HANDLE_INTERRUPTS; - /* - * Tail call - */ - if (SCM_PROGRAM_P (x)) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) + { + if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (program); + goto vm_tail_call; + } + else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + && SCM_SMOB_APPLICABLE_P (program)) + { + SYNC_REGISTER (); + sp[-nargs] = scm_i_smob_apply_trampoline (program); + goto vm_tail_call; + } + else + goto vm_error_wrong_type_apply; + } + else { int i; #ifdef VM_ENABLE_STACK_NULLING @@ -806,7 +818,6 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1) EXIT_HOOK (); /* switch programs */ - program = x; CACHE_PROGRAM (); /* shuffle down the program and the arguments */ for (i = -1, sp = sp - nargs + 1; i < nargs; i++) @@ -816,55 +827,211 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1) NULLSTACK (old_sp - sp); - ip = bp->base; + ip = SCM_C_OBJCODE_BASE (bp); ENTER_HOOK (); APPLY_HOOK (); NEXT; } +} + +VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1) +{ + SCM foreign, ret; + SCM (*subr)(); + nargs = FETCH (); + POP (foreign); + + subr = SCM_FOREIGN_POINTER (foreign, void); + + VM_HANDLE_INTERRUPTS; + SYNC_REGISTER (); - /* - * Other interpreted or compiled call - */ - if (!SCM_FALSEP (scm_procedure_p (x))) + switch (nargs) { - SCM args; - POP_LIST (nargs); - POP (args); + case 0: + ret = subr (); + break; + case 1: + ret = subr (sp[0]); + break; + case 2: + ret = subr (sp[-1], sp[0]); + break; + case 3: + ret = subr (sp[-2], sp[-1], sp[0]); + break; + case 4: + ret = subr (sp[-3], sp[-2], sp[-1], sp[0]); + break; + case 5: + ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); + break; + case 6: + ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); + break; + case 7: + ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); + break; + case 8: + ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); + break; + case 9: + ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); + break; + case 10: + ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], 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; + } +} - SYNC_REGISTER (); - *sp = scm_apply (x, args, SCM_EOL); - NULLSTACK_FOR_NONLOCAL_EXIT (); +VM_DEFINE_INSTRUCTION (57, smob_call, "smob-call", 1, -1, -1) +{ + SCM smob, ret; + SCM (*subr)(); + nargs = FETCH (); + POP (smob); - if (SCM_UNLIKELY (SCM_VALUESP (*sp))) - { - /* multiple values returned to continuation */ - SCM values; - POP (values); - values = scm_struct_ref (values, SCM_INUM0); - nvalues = scm_ilength (values); - PUSH_LIST (values, SCM_NULLP); - goto vm_return_values; - } - else - goto vm_return; + 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; + } +} - program = x; +VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1) +{ + SCM foreign, ret; + nargs = FETCH (); + POP (foreign); + + VM_HANDLE_INTERRUPTS; + SYNC_REGISTER (); - goto vm_error_wrong_type_apply; + ret = scm_i_foreign_call (foreign, sp - nargs + 1); + + 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; + } } -VM_DEFINE_INSTRUCTION (55, goto_nargs, "goto/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0) +{ + SCM contregs; + POP (contregs); + + SYNC_ALL (); + scm_i_check_continuation (contregs); + vm_return_to_continuation (scm_i_contregs_vm (contregs), + scm_i_contregs_vm_cont (contregs), + sp - (fp - 1), fp); + scm_i_reinstate_continuation (contregs); + + /* no NEXT */ + abort (); +} + +VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0) +{ + SCM vmcont, intwinds, prevwinds; + POP (intwinds); + POP (vmcont); + SYNC_REGISTER (); + if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont))) + { finish_args = vmcont; + goto vm_error_continuation_not_rewindable; + } + prevwinds = scm_i_dynwinds (); + vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp, + vm_cookie); + + /* 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 (59, tail_call_nargs, "tail-call/nargs", 0, 0, 1) { SCM x; POP (x); nargs = scm_to_int (x); /* FIXME: should truncate values? */ - goto vm_goto_args; + goto vm_tail_call; } -VM_DEFINE_INSTRUCTION (56, call_nargs, "call/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (60, call_nargs, "call/nargs", 0, 0, 1) { SCM x; POP (x); @@ -873,9 +1040,8 @@ VM_DEFINE_INSTRUCTION (56, call_nargs, "call/nargs", 0, 0, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1) +VM_DEFINE_INSTRUCTION (61, mv_call, "mv-call", 4, -1, 1) { - SCM x; scm_t_int32 offset; scm_t_uint8 *mvra; @@ -883,59 +1049,42 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1) FETCH_OFFSET (offset); mvra = ip + offset; - x = sp[-nargs]; + vm_mv_call: + program = sp[-nargs]; - /* - * Subprogram call - */ - if (SCM_PROGRAM_P (x)) - { - program = x; - CACHE_PROGRAM (); - fp = sp - nargs + 1; - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); - ip = bp->base; - ENTER_HOOK (); - APPLY_HOOK (); - NEXT; - } - /* - * Other interpreted or compiled call - */ - if (!SCM_FALSEP (scm_procedure_p (x))) + VM_HANDLE_INTERRUPTS; + + if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) { - SCM args; - /* At this point, the stack contains the procedure and each one of its - arguments. */ - POP_LIST (nargs); - POP (args); - DROP (); /* drop the procedure */ - DROP_FRAME (); - - SYNC_REGISTER (); - PUSH (scm_apply (x, args, SCM_EOL)); - NULLSTACK_FOR_NONLOCAL_EXIT (); - if (SCM_VALUESP (*sp)) + if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) { - SCM values, len; - POP (values); - values = scm_struct_ref (values, SCM_INUM0); - len = scm_length (values); - PUSH_LIST (values, SCM_NULLP); - PUSH (len); - ip = mvra; + sp[-nargs] = SCM_STRUCT_PROCEDURE (program); + goto vm_mv_call; } - NEXT; + else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob + && SCM_SMOB_APPLICABLE_P (program)) + { + SYNC_REGISTER (); + sp[-nargs] = scm_i_smob_apply_trampoline (program); + goto vm_mv_call; + } + else + goto vm_error_wrong_type_apply; } - program = x; - goto vm_error_wrong_type_apply; + CACHE_PROGRAM (); + fp = sp - nargs + 1; + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); + ip = SCM_C_OBJCODE_BASE (bp); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; } -VM_DEFINE_INSTRUCTION (58, apply, "apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (62, apply, "apply", 1, -1, 1) { int len; SCM ls; @@ -954,7 +1103,7 @@ VM_DEFINE_INSTRUCTION (58, apply, "apply", 1, -1, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (59, goto_apply, "goto/apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1) { int len; SCM ls; @@ -970,16 +1119,17 @@ VM_DEFINE_INSTRUCTION (59, goto_apply, "goto/apply", 1, -1, 1) PUSH_LIST (ls, SCM_NULL_OR_NIL_P); nargs += len - 2; - goto vm_goto_args; + goto vm_tail_call; } -VM_DEFINE_INSTRUCTION (60, call_cc, "call/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1) { int first; - SCM proc, cont; + SCM proc, vm_cont, cont; POP (proc); SYNC_ALL (); - cont = scm_make_continuation (&first); + vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0); + cont = scm_i_make_continuation (&first, vm, vm_cont); if (first) { PUSH ((SCM)fp); /* dynamic link */ @@ -990,65 +1140,59 @@ VM_DEFINE_INSTRUCTION (60, call_cc, "call/cc", 0, 1, 1) nargs = 1; goto vm_call; } - ASSERT (sp == vp->sp); - ASSERT (fp == vp->fp); - else if (SCM_VALUESP (cont)) + else { - /* multiple values returned to continuation */ - SCM values; - values = scm_struct_ref (cont, SCM_INUM0); - if (SCM_NULLP (values)) - goto vm_error_no_values; - /* non-tail context does not accept multiple values? */ - PUSH (SCM_CAR (values)); - NEXT; - } - else - { - PUSH (cont); + /* otherwise, the vm continuation was reinstated, and + scm_i_vm_return_to_continuation pushed on one value. So pull our regs + back down from the vp, and march on to the next instruction. */ + CACHE_REGISTER (); + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); NEXT; } } -VM_DEFINE_INSTRUCTION (61, goto_cc, "goto/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1) { int first; - SCM proc, cont; + SCM proc, vm_cont, cont; POP (proc); SYNC_ALL (); - cont = scm_make_continuation (&first); - ASSERT (sp == vp->sp); - ASSERT (fp == vp->fp); + /* In contrast to call/cc, tail-call/cc captures the continuation without the + stack frame. */ + 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), + 0); + cont = scm_i_make_continuation (&first, vm, vm_cont); if (first) { PUSH (proc); PUSH (cont); nargs = 1; - goto vm_goto_args; - } - else if (SCM_VALUESP (cont)) - { - /* multiple values returned to continuation */ - SCM values; - values = scm_struct_ref (cont, SCM_INUM0); - nvalues = scm_ilength (values); - PUSH_LIST (values, SCM_NULLP); - goto vm_return_values; + goto vm_tail_call; } else { - PUSH (cont); - goto vm_return; + /* Otherwise, cache regs and NEXT, as above. Invoking the continuation + does a return from the frame, either to the RA or MVRA. */ + CACHE_REGISTER (); + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + NEXT; } } -VM_DEFINE_INSTRUCTION (62, return, "return", 0, 1, 1) +VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1) { vm_return: EXIT_HOOK (); - RETURN_HOOK (); - SYNC_REGISTER (); - SCM_TICK; /* allow interrupt here */ + RETURN_HOOK (1); + + VM_HANDLE_INTERRUPTS; + { SCM ret; @@ -1078,14 +1222,16 @@ VM_DEFINE_INSTRUCTION (62, return, "return", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (63, return_values, "return/values", 1, -1, -1) +VM_DEFINE_INSTRUCTION (67, 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. */ nvalues = FETCH (); vm_return_values: EXIT_HOOK (); - RETURN_HOOK (); + RETURN_HOOK (nvalues); + + VM_HANDLE_INTERRUPTS; if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp)) { @@ -1133,7 +1279,7 @@ VM_DEFINE_INSTRUCTION (63, return_values, "return/values", 1, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1) +VM_DEFINE_INSTRUCTION (68, return_values_star, "return/values*", 1, -1, -1) { SCM l; @@ -1142,7 +1288,7 @@ VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1) nvalues--; POP (l); - while (SCM_CONSP (l)) + while (scm_is_pair (l)) { PUSH (SCM_CAR (l)); l = SCM_CDR (l); @@ -1156,7 +1302,16 @@ VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1) goto vm_return_values; } -VM_DEFINE_INSTRUCTION (65, truncate_values, "truncate-values", 2, -1, -1) +VM_DEFINE_INSTRUCTION (88, return_nvalues, "return/nvalues", 0, 1, -1) +{ + SCM n; + POP (n); + nvalues = scm_to_int (n); + ASSERT (nvalues >= 0); + goto vm_return_values; +} + +VM_DEFINE_INSTRUCTION (69, truncate_values, "truncate-values", 2, -1, -1) { SCM x; int nbinds, rest; @@ -1179,7 +1334,7 @@ VM_DEFINE_INSTRUCTION (65, truncate_values, "truncate-values", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (66, box, "box", 1, 1, 0) +VM_DEFINE_INSTRUCTION (70, box, "box", 1, 1, 0) { SCM val; POP (val); @@ -1193,7 +1348,7 @@ VM_DEFINE_INSTRUCTION (66, box, "box", 1, 1, 0) (set! a (lambda () (b ...))) ...) */ -VM_DEFINE_INSTRUCTION (67, empty_box, "empty-box", 1, 0, 0) +VM_DEFINE_INSTRUCTION (71, empty_box, "empty-box", 1, 0, 0) { SYNC_BEFORE_GC (); LOCAL_SET (FETCH (), @@ -1201,7 +1356,7 @@ VM_DEFINE_INSTRUCTION (67, empty_box, "empty-box", 1, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (68, local_boxed_ref, "local-boxed-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (72, local_boxed_ref, "local-boxed-ref", 1, 0, 1) { SCM v = LOCAL_REF (FETCH ()); ASSERT_BOUND_VARIABLE (v); @@ -1209,7 +1364,7 @@ VM_DEFINE_INSTRUCTION (68, local_boxed_ref, "local-boxed-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (69, local_boxed_set, "local-boxed-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (73, local_boxed_set, "local-boxed-set", 1, 1, 0) { SCM v, val; v = LOCAL_REF (FETCH ()); @@ -1219,7 +1374,7 @@ VM_DEFINE_INSTRUCTION (69, local_boxed_set, "local-boxed-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (70, free_ref, "free-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (74, free_ref, "free-ref", 1, 0, 1) { scm_t_uint8 idx = FETCH (); @@ -1230,7 +1385,7 @@ VM_DEFINE_INSTRUCTION (70, free_ref, "free-ref", 1, 0, 1) /* no free-set -- if a var is assigned, it should be in a box */ -VM_DEFINE_INSTRUCTION (71, free_boxed_ref, "free-boxed-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (75, free_boxed_ref, "free-boxed-ref", 1, 0, 1) { SCM v; scm_t_uint8 idx = FETCH (); @@ -1241,7 +1396,7 @@ VM_DEFINE_INSTRUCTION (71, free_boxed_ref, "free-boxed-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (72, free_boxed_set, "free-boxed-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (76, free_boxed_set, "free-boxed-set", 1, 1, 0) { SCM v, val; scm_t_uint8 idx = FETCH (); @@ -1253,18 +1408,26 @@ VM_DEFINE_INSTRUCTION (72, free_boxed_set, "free-boxed-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (73, make_closure, "make-closure", 0, 2, 1) +VM_DEFINE_INSTRUCTION (77, make_closure, "make-closure", 2, -1, 1) { - SCM vect; - POP (vect); + size_t n, len; + SCM closure; + + len = FETCH (); + len <<= 8; + len += FETCH (); SYNC_BEFORE_GC (); - /* fixme underflow */ - *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE (*sp), - (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp), (scm_t_bits)vect); + closure = scm_words (scm_tc7_program | (len<<16), len + 3); + SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len])); + SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len])); + sp[-len] = closure; + for (n = 0; n < len; n++) + SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]); + DROPN (len); NEXT; } -VM_DEFINE_INSTRUCTION (74, make_variable, "make-variable", 0, 0, 1) +VM_DEFINE_INSTRUCTION (78, make_variable, "make-variable", 0, 0, 1) { SYNC_BEFORE_GC (); /* fixme underflow */ @@ -1272,21 +1435,24 @@ VM_DEFINE_INSTRUCTION (74, make_variable, "make-variable", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (75, fix_closure, "fix-closure", 2, 0, 1) +VM_DEFINE_INSTRUCTION (79, fix_closure, "fix-closure", 2, -1, 0) { - SCM x, vect; + SCM x; unsigned int i = FETCH (); + size_t n, len; i <<= 8; i += FETCH (); - POP (vect); /* FIXME CHECK_LOCAL (i) */ x = LOCAL_REF (i); /* FIXME ASSERT_PROGRAM (x); */ - SCM_SET_CELL_WORD_3 (x, vect); + len = SCM_PROGRAM_NUM_FREE_VARIABLES (x); + for (n = 0; n < len; n++) + SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]); + DROPN (len); NEXT; } -VM_DEFINE_INSTRUCTION (76, define, "define", 0, 0, 2) +VM_DEFINE_INSTRUCTION (80, define, "define", 0, 0, 2) { SCM sym, val; POP (sym); @@ -1298,7 +1464,7 @@ VM_DEFINE_INSTRUCTION (76, define, "define", 0, 0, 2) NEXT; } -VM_DEFINE_INSTRUCTION (77, make_keyword, "make-keyword", 0, 1, 1) +VM_DEFINE_INSTRUCTION (81, make_keyword, "make-keyword", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@ -1306,7 +1472,7 @@ VM_DEFINE_INSTRUCTION (77, make_keyword, "make-keyword", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1) +VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1) { CHECK_UNDERFLOW (); SYNC_REGISTER (); @@ -1314,6 +1480,168 @@ VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1) NEXT; } +VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0) +{ + scm_t_int32 offset; + scm_t_uint8 escape_only_p; + SCM k, prompt; + + escape_only_p = FETCH (); + FETCH_OFFSET (offset); + POP (k); + + 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 (); + NEXT; + } + + /* Otherwise setjmp returned for the first time, so we go to execute the + prompt's body. */ + NEXT; +} + +VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0) +{ + SCM wind, unwind; + POP (unwind); + POP (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. */ + if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind)))) + { + finish_args = wind; + goto vm_error_not_a_thunk; + } + if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind)))) + { + finish_args = unwind; + goto vm_error_not_a_thunk; + } + scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1) +{ + unsigned n = FETCH (); + SYNC_REGISTER (); + if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp)) + goto vm_error_stack_underflow; + vm_abort (vm, n, vm_cookie); + /* vm_abort should not return */ + abort (); +} + +VM_DEFINE_INSTRUCTION (87, 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 ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (90, wind_fluids, "wind-fluids", 1, -1, 0) +{ + unsigned n = FETCH (); + SCM wf; + + if (sp - 2*n < SCM_FRAME_UPPER_ADDRESS (fp)) + goto vm_error_stack_underflow; + + SYNC_REGISTER (); + wf = scm_i_make_with_fluids (n, sp + 1 - 2*n, sp + 1 - n); + scm_i_swap_with_fluids (wf, dynstate); + scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (91, 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, dynstate); + NEXT; +} + +VM_DEFINE_INSTRUCTION (92, fluid_ref, "fluid-ref", 0, 1, 1) +{ + size_t num; + SCM fluids; + + CHECK_UNDERFLOW (); + fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate); + if (SCM_UNLIKELY (!SCM_I_FLUID_P (*sp)) + || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Punt dynstate expansion and error handling to the C proc. */ + SYNC_REGISTER (); + *sp = scm_fluid_ref (*sp); + } + else + *sp = SCM_SIMPLE_VECTOR_REF (fluids, num); + + NEXT; +} + +VM_DEFINE_INSTRUCTION (93, fluid_set, "fluid-set", 0, 2, 0) +{ + size_t num; + SCM val, fluid, fluids; + + POP (val); + POP (fluid); + fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate); + if (SCM_UNLIKELY (!SCM_I_FLUID_P (fluid)) + || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Punt dynstate expansion and error handling to the C proc. */ + SYNC_REGISTER (); + scm_fluid_set_x (fluid, val); + } + else + SCM_SIMPLE_VECTOR_SET (fluids, num, val); + + NEXT; +} + +VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0) +{ + scm_t_ptrdiff n; + SCM *old_sp; + + /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */ + n = FETCH (); + + if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7))) + goto vm_error_wrong_num_args; + + old_sp = sp; + sp += (n >> 3); + CHECK_OVERFLOW (); + while (old_sp < sp) + *++old_sp = SCM_UNDEFINED; + + NEXT; +} + /* (defun renumber-ops () @@ -1325,6 +1653,7 @@ VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1) (replace-match (number-to-string (setq counter (1+ counter))) t t nil 1))))) +(renumber-ops) */ /* Local Variables: