diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-08 18:28:24 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-08 18:28:24 +0100 |
commit | 1c33be992e8120abd20add8021e4d91d226f5b6a (patch) | |
tree | 71f78961b6a29aa1e342049419f402af555e6f20 /libguile/vm-i-system.c | |
parent | 84680d238299c3b2c8be42b16a8be0ff6e02ba5c (diff) | |
download | guile-1c33be992e8120abd20add8021e4d91d226f5b6a.tar.gz |
Remove stack programs, objcode, and the old VM.
* libguile/Makefile.am:
* libguile/vm-i-loader.c:
* libguile/vm-i-scheme.c:
* libguile/vm-i-system.c: Remove the old VM files, and the rules to
build the .i files.
* libguile/vm-engine.c:
* libguile/vm.c: Remove the old VM. Woot!
* libguile/_scm.h (SCM_OBJCODE_COOKIE, SCM_OBJCODE_ENDIANNESS_OFFSET)
(SCM_OBJCODE_WORD_SIZE_OFFSET): Remove.
* libguile/evalext.c (scm_self_evaluating_p): Remove objcode and program
cases.
* libguile/frames.c (scm_frame_num_locals, scm_frame_previous): Remove
program cases.
* libguile/gc.c (scm_i_tag_name): Remove objcode case.
* libguile/goops.c (scm_class_of, create_standard_classes): Remove
objcode and program cases.
* libguile/instructions.h:
* libguile/instructions.c (scm_instruction_list, scm_instruction_p)
(scm_instruction_length, scm_instruction_pops, scm_instruction_pushes)
(scm_instruction_to_opcode, scm_opcode_to_instruction): Remove old VM
code.
* libguile/objcodes.h:
* libguile/objcodes.c: Remove the objcode data type, and handling for
objcode files.
* libguile/print.c: Remove objcode and program printers.
* libguile/procprop.c: Remove program cases.
* libguile/procs.c:
* libguile/programs.h:
* libguile/programs.c: Remove old program code.
* libguile/smob.c: Remove objcodes include.
* libguile/snarf.h: Remove static program defines.
* libguile/stacks.c: Remove program case.
* libguile/tags.h: Remove program and objcode tc7s.
* module/ice-9/session.scm (procedure-arguments)
* module/language/tree-il/analyze.scm (validate-arity)
* module/statprof.scm (get-call-data, procedure=?)
* module/system/vm/frame.scm (frame-bindings)
(frame-call-representation): Remove old program cases.
* module/system/repl/debug.scm (frame->module): Add a FIXME.
* module/system/vm/instruction.scm: Remove old exports.
* module/system/vm/program.scm: Remove old program code.
Diffstat (limited to 'libguile/vm-i-system.c')
-rw-r--r-- | libguile/vm-i-system.c | 1656 |
1 files changed, 0 insertions, 1656 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c deleted file mode 100644 index e023d562b..000000000 --- a/libguile/vm-i-system.c +++ /dev/null @@ -1,1656 +0,0 @@ -/* Copyright (C) 2001,2008,2009,2010,2011,2012,2013 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 - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - -/* This file is included in vm_engine.c */ - - -/* - * Basic operations - */ - -VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0) -{ - NEXT; -} - -VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) -{ - SCM ret; - - nvalues = SCM_I_INUM (*sp--); - NULLSTACK (1); - - if (nvalues == 1) - POP (ret); - else - { - SYNC_REGISTER (); - sp -= nvalues; - CHECK_UNDERFLOW (); - ret = scm_c_values (sp + 1, nvalues); - NULLSTACK (nvalues); - } - - { -#ifdef VM_ENABLE_STACK_NULLING - SCM *old_sp = sp; -#endif - - /* Restore registers */ - sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - /* Setting the ip here doesn't actually affect control flow, as the calling - code will restore its own registers, but it does help when walking the - stack */ - ip = SCM_FRAME_RETURN_ADDRESS (fp); - fp = SCM_FRAME_DYNAMIC_LINK (fp); - NULLSTACK (old_sp - sp); - } - - SYNC_ALL (); - return ret; -} - -VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0) -{ - DROP (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1) -{ - SCM x = *sp; - PUSH (x); - NEXT; -} - - -/* - * Object creation - */ - -VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1) -{ - PUSH (SCM_UNSPECIFIED); - NEXT; -} - -VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1) -{ - PUSH (SCM_BOOL_T); - NEXT; -} - -VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1) -{ - PUSH (SCM_BOOL_F); - NEXT; -} - -VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1) -{ - PUSH (SCM_ELISP_NIL); - NEXT; -} - -VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1) -{ - PUSH (SCM_EOL); - NEXT; -} - -VM_DEFINE_INSTRUCTION (9, 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) -{ - PUSH (SCM_INUM0); - NEXT; -} - -VM_DEFINE_INSTRUCTION (11, 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) -{ - int h = FETCH (); - int l = FETCH (); - PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1) -{ - scm_t_uint64 v = 0; - v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - PUSH (scm_from_int64 ((scm_t_int64) v)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1) -{ - scm_t_uint64 v = 0; - v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - PUSH (scm_from_uint64 (v)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1) -{ - scm_t_uint8 v = 0; - v = FETCH (); - - PUSH (SCM_MAKE_CHAR (v)); - /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The - contents of SCM_MAKE_CHAR may be evaluated more than once, - resulting in a double fetch. */ - NEXT; -} - -VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1) -{ - scm_t_wchar v = 0; - v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - PUSH (SCM_MAKE_CHAR (v)); - NEXT; -} - - - -VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) -{ - unsigned h = FETCH (); - unsigned l = FETCH (); - unsigned len = ((h << 8) + l); - POP_LIST (len); - NEXT; -} - -VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) -{ - unsigned h = FETCH (); - unsigned l = FETCH (); - unsigned len = ((h << 8) + l); - SCM vect; - - SYNC_REGISTER (); - sp++; sp -= len; - CHECK_UNDERFLOW (); - vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F); - memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len); - NULLSTACK (len); - *sp = vect; - - NEXT; -} - - -/* - * Variable access - */ - -#define OBJECT_REF(i) objects[i] -#define OBJECT_SET(i,o) objects[i] = o - -#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i) -#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o - -/* For the variable operations, we _must_ obviously avoid function calls to - `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do - nothing more than the corresponding macros. */ -#define VARIABLE_REF(v) SCM_VARIABLE_REF (v) -#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) -#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) - -#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i) - -/* ref */ - -VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1) -{ - register unsigned objnum = FETCH (); - CHECK_OBJECT (objnum); - PUSH (OBJECT_REF (objnum)); - NEXT; -} - -/* FIXME: necessary? elt 255 of the vector could be a vector... */ -VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1) -{ - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - PUSH (OBJECT_REF (objnum)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (21, 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) -{ - unsigned int i = FETCH (); - i <<= 8; - i += FETCH (); - PUSH (LOCAL_REF (i)); - ASSERT_BOUND (*sp); - NEXT; -} - -VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1) -{ - PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED))); - NEXT; -} - -VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1) -{ - unsigned int i = FETCH (); - i <<= 8; - i += FETCH (); - PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED))); - NEXT; -} - -VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1) -{ - SCM x = *sp; - - /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because, - unlike in top-variable-ref, it really isn't an internal assertion - that can be optimized out -- the variable could be coming directly - from the user. */ - VM_ASSERT (SCM_VARIABLEP (x), - vm_error_not_a_variable ("variable-ref", x)); - - if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x))) - { - SCM var_name; - - SYNC_ALL (); - /* Attempt to provide the variable name in the error message. */ - var_name = scm_module_reverse_lookup (scm_current_module (), x); - vm_error_unbound (program, scm_is_true (var_name) ? var_name : x); - } - else - { - SCM o = VARIABLE_REF (x); - *sp = o; - } - - NEXT; -} - -VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1) -{ - SCM x = *sp; - - VM_ASSERT (SCM_VARIABLEP (x), - vm_error_not_a_variable ("variable-bound?", x)); - - *sp = scm_from_bool (VARIABLE_BOUNDP (x)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1) -{ - unsigned objnum = FETCH (); - SCM what, resolved; - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_REGISTER (); - resolved = resolve_variable (what, scm_program_module (program)); - VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what)); - what = resolved; - OBJECT_SET (objnum, what); - } - - PUSH (VARIABLE_REF (what)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) -{ - SCM what, resolved; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_REGISTER (); - resolved = resolve_variable (what, scm_program_module (program)); - VM_ASSERT (VARIABLE_BOUNDP (resolved), - vm_error_unbound (program, what)); - what = resolved; - OBJECT_SET (objnum, what); - } - - PUSH (VARIABLE_REF (what)); - NEXT; -} - -/* set */ - -VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0) -{ - SCM x; - POP (x); - LOCAL_SET (FETCH (), x); - NEXT; -} - -VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0) -{ - SCM x; - unsigned int i = FETCH (); - i <<= 8; - i += FETCH (); - POP (x); - LOCAL_SET (i, x); - NEXT; -} - -VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0) -{ - VM_ASSERT (SCM_VARIABLEP (sp[0]), - vm_error_not_a_variable ("variable-set!", sp[0])); - VARIABLE_SET (sp[0], sp[-1]); - DROPN (2); - NEXT; -} - -VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0) -{ - unsigned objnum = FETCH (); - SCM what; - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_BEFORE_GC (); - what = resolve_variable (what, scm_program_module (program)); - OBJECT_SET (objnum, what); - } - - VARIABLE_SET (what, *sp); - DROP (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0) -{ - SCM what; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_BEFORE_GC (); - what = resolve_variable (what, scm_program_module (program)); - OBJECT_SET (objnum, what); - } - - VARIABLE_SET (what, *sp); - DROP (); - NEXT; -} - - -/* - * branch and jump - */ - -/* offset must be at least 24 bits wide, and signed */ -#define FETCH_OFFSET(offset) \ -{ \ - offset = FETCH () << 16; \ - offset += FETCH () << 8; \ - offset += FETCH (); \ - offset -= (offset & (1<<23)) << 1; \ -} - -#define BR(p) \ -{ \ - scm_t_int32 offset; \ - FETCH_OFFSET (offset); \ - if (p) \ - ip += offset; \ - if (offset < 0) \ - VM_HANDLE_INTERRUPTS; \ - NEXT; \ -} - -VM_DEFINE_INSTRUCTION (34, 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) -{ - SCM x; - POP (x); - BR (scm_is_true (x)); -} - -VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0) -{ - SCM x; - POP (x); - BR (scm_is_false (x)); -} - -VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0) -{ - SCM x, y; - POP2 (y, x); - BR (scm_is_eq (x, y)); -} - -VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0) -{ - SCM x, y; - POP2 (y, x); - BR (!scm_is_eq (x, y)); -} - -VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0) -{ - SCM x; - POP (x); - BR (scm_is_null (x)); -} - -VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) -{ - SCM x; - POP (x); - 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)); -} - -#undef BR - - -/* - * Subprogram call - */ - -VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) -{ - scm_t_ptrdiff n; - scm_t_int32 offset; - n = FETCH () << 8; - n += FETCH (); - FETCH_OFFSET (offset); - if (sp - (fp - 1) != n) - ip += offset; - NEXT; -} - -VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) -{ - scm_t_ptrdiff n; - scm_t_int32 offset; - n = FETCH () << 8; - n += FETCH (); - FETCH_OFFSET (offset); - if (sp - (fp - 1) < n) - ip += offset; - NEXT; -} - -VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) -{ - scm_t_ptrdiff n; - scm_t_int32 offset; - - n = FETCH () << 8; - n += FETCH (); - FETCH_OFFSET (offset); - if (sp - (fp - 1) > n) - ip += offset; - NEXT; -} - -VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) -{ - scm_t_ptrdiff n; - n = FETCH () << 8; - n += FETCH (); - VM_ASSERT (sp - (fp - 1) == n, - vm_error_wrong_num_args (program)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) -{ - scm_t_ptrdiff n; - n = FETCH () << 8; - n += FETCH (); - VM_ASSERT (sp - (fp - 1) >= n, - vm_error_wrong_num_args (program)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1) -{ - scm_t_ptrdiff n; - n = FETCH () << 8; - n += FETCH (); - while (sp - (fp - 1) < n) - PUSH (SCM_UNDEFINED); - NEXT; -} - -VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) -{ - SCM *walk; - scm_t_ptrdiff nreq, nreq_and_opt, ntotal; - nreq = FETCH () << 8; - nreq += FETCH (); - nreq_and_opt = FETCH () << 8; - nreq_and_opt += FETCH (); - ntotal = FETCH () << 8; - ntotal += FETCH (); - - /* look in optionals for first keyword or last positional */ - /* starting after the last required positional arg */ - walk = fp + nreq; - while (/* while we have args */ - walk <= sp - /* and we still have positionals to fill */ - && walk - fp < nreq_and_opt - /* and we haven't reached a keyword yet */ - && !scm_is_keyword (*walk)) - /* bind this optional arg (by leaving it in place) */ - walk++; - /* now shuffle up, from walk to ntotal */ - { - scm_t_ptrdiff nshuf = sp - walk + 1, i; - sp = (fp - 1) + ntotal + nshuf; - CHECK_OVERFLOW (); - for (i = 0; i < nshuf; i++) - sp[-i] = walk[nshuf-i-1]; - } - /* and fill optionals & keyword args with SCM_UNDEFINED */ - while (walk <= (fp - 1) + ntotal) - *walk++ = SCM_UNDEFINED; - - NEXT; -} - -/* See also bind-optionals/shuffle-or-br below. */ - -/* 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 (50, bind_kwargs, "bind-kwargs", 5, 0, 0) -{ - scm_t_uint16 idx; - scm_t_ptrdiff nkw; - int kw_and_rest_flags; - SCM kw; - idx = FETCH () << 8; - idx += FETCH (); - /* XXX: We don't actually use NKW. */ - nkw = FETCH () << 8; - nkw += FETCH (); - kw_and_rest_flags = FETCH (); - - VM_ASSERT ((kw_and_rest_flags & F_REST) - || ((sp - (fp - 1) - nkw) % 2) == 0, - vm_error_kwargs_length_not_even (program)) - - 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++) - { - SCM walk; - - 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; - } - } - VM_ASSERT (scm_is_pair (walk) - || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS), - vm_error_kwargs_unrecognized_keyword (program, sp[nkw])); - nkw++; - } - else - VM_ASSERT (kw_and_rest_flags & F_REST, - vm_error_kwargs_invalid_keyword (program, sp[nkw])); - } - - NEXT; -} - -#undef F_ALLOW_OTHER_KEYS -#undef F_REST - - -VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1) -{ - scm_t_ptrdiff n; - SCM rest = SCM_EOL; - n = FETCH () << 8; - n += FETCH (); - SYNC_BEFORE_GC (); - while (sp - (fp - 1) > n) - /* No need to check for underflow. */ - rest = scm_cons (*sp--, rest); - PUSH (rest); - NEXT; -} - -VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1) -{ - scm_t_ptrdiff n; - scm_t_uint32 i; - SCM rest = SCM_EOL; - n = FETCH () << 8; - n += FETCH (); - i = FETCH () << 8; - i += FETCH (); - SYNC_BEFORE_GC (); - while (sp - (fp - 1) > n) - /* No need to check for underflow. */ - rest = scm_cons (*sp--, rest); - LOCAL_SET (i, rest); - NEXT; -} - -VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1) -{ - SCM *old_sp; - scm_t_int32 n; - n = FETCH () << 8; - n += FETCH (); - old_sp = sp; - sp = (fp - 1) + n; - - if (old_sp < sp) - { - CHECK_OVERFLOW (); - while (old_sp < sp) - *++old_sp = SCM_UNDEFINED; - } - else - NULLSTACK (old_sp - sp); - - NEXT; -} - -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 */ - - /* We don't initialize the dynamic link here because we don't actually - know that this frame will point to the current fp: it could be - placed elsewhere on the stack if captured in a partial - continuation, and invoked from some other context. */ - PUSH (SCM_PACK (0)); /* dynamic link */ - PUSH (SCM_PACK (0)); /* mvra */ - PUSH (SCM_PACK (0)); /* ra */ - NEXT; -} - -VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1) -{ - nargs = FETCH (); - - vm_call: - VM_HANDLE_INTERRUPTS; - - { - SCM *old_fp = fp; - - fp = sp - nargs + 1; - - ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0); - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); - } - - PUSH_CONTINUATION_HOOK (); - - program = fp[-1]; - - if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) - goto apply; - - CACHE_PROGRAM (); - ip = SCM_C_OBJCODE_BASE (bp); - - APPLY_HOOK (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1) -{ - nargs = FETCH (); - - vm_tail_call: - VM_HANDLE_INTERRUPTS; - - { - int i; -#ifdef VM_ENABLE_STACK_NULLING - SCM *old_sp = sp; - CHECK_STACK_LEAK (); -#endif - - /* shuffle down the program and the arguments */ - for (i = -1, sp = sp - nargs + 1; i < nargs; i++) - SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i]; - - sp = fp + i - 1; - - NULLSTACK (old_sp - sp); - } - - program = fp[-1]; - - if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) - goto apply; - - CACHE_PROGRAM (); - ip = SCM_C_OBJCODE_BASE (bp); - - APPLY_HOOK (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1) -{ - SCM pointer, ret; - SCM (*subr)(); - - nargs = FETCH (); - POP (pointer); - - subr = SCM_POINTER_VALUE (pointer); - - VM_HANDLE_INTERRUPTS; - SYNC_REGISTER (); - - switch (nargs) - { - 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; - } -} - -/* Instruction 58 used to be smob-call. */ - -VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1) -{ - SCM foreign, ret; - nargs = FETCH (); - POP (foreign); - - VM_HANDLE_INTERRUPTS; - SYNC_REGISTER (); - - 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 (60, 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 (61, partial_cont_call, "partial-cont-call", 0, -1, 0) -{ - SCM vmcont; - POP (vmcont); - SYNC_REGISTER (); - VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), - vm_error_continuation_not_rewindable (vmcont)); - vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp, - ¤t_thread->dynstack, - ®isters); - - CACHE_REGISTER (); - program = SCM_FRAME_PROGRAM (fp); - CACHE_PROGRAM (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1) -{ - SCM x; - POP (x); - nargs = scm_to_int (x); - /* FIXME: should truncate values? */ - goto vm_tail_call; -} - -VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1) -{ - SCM x; - POP (x); - nargs = scm_to_int (x); - /* FIXME: should truncate values? */ - goto vm_call; -} - -VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1) -{ - scm_t_int32 offset; - scm_t_uint8 *mvra; - SCM *old_fp = fp; - - nargs = FETCH (); - FETCH_OFFSET (offset); - mvra = ip + offset; - - VM_HANDLE_INTERRUPTS; - - fp = sp - nargs + 1; - - ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0); - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); - - PUSH_CONTINUATION_HOOK (); - - program = fp[-1]; - - if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) - goto apply; - - CACHE_PROGRAM (); - ip = SCM_C_OBJCODE_BASE (bp); - - APPLY_HOOK (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1) -{ - int len; - SCM ls; - POP (ls); - - nargs = FETCH (); - ASSERT (nargs >= 2); - - len = scm_ilength (ls); - VM_ASSERT (len >= 0, - vm_error_apply_to_non_list (ls)); - PUSH_LIST (ls, SCM_NULL_OR_NIL_P); - - nargs += len - 2; - goto vm_call; -} - -VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1) -{ - int len; - SCM ls; - POP (ls); - - nargs = FETCH (); - ASSERT (nargs >= 2); - - len = scm_ilength (ls); - VM_ASSERT (len >= 0, - vm_error_apply_to_non_list (ls)); - PUSH_LIST (ls, SCM_NULL_OR_NIL_P); - - nargs += len - 2; - goto vm_tail_call; -} - -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 (); - 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) - { - PUSH (SCM_PACK (0)); /* dynamic link */ - PUSH (SCM_PACK (0)); /* mvra */ - PUSH (SCM_PACK (0)); /* ra */ - PUSH (proc); - PUSH (cont); - nargs = 1; - goto vm_call; - } - else - { - /* Otherwise, the vm continuation was reinstated, and - vm_return_to_continuation pushed on one value. We know only one - value was returned because we are in value context -- the - previous block jumped to vm_call, not vm_mv_call, after all. - - 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 (); - RESTORE_CONTINUATION_HOOK (); - NEXT; - } -} - -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) - { - PUSH (proc); - PUSH (cont); - nargs = 1; - goto vm_tail_call; - } - else - { - /* 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 (); - /* Unfortunately we don't know whether we are at the RA, and thus - have one value without an nvalues marker, or we are at the - MVRA and thus have multiple values and the nvalues - marker. Instead of adding heuristics here, we will let hook - client code do that. */ - RESTORE_CONTINUATION_HOOK (); - NEXT; - } -} - -VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1) -{ - vm_return: - POP_CONTINUATION_HOOK (sp, 1); - - VM_HANDLE_INTERRUPTS; - - { - SCM ret; - - POP (ret); - -#ifdef VM_ENABLE_STACK_NULLING - SCM *old_sp = sp; -#endif - - /* Restore registers */ - sp = SCM_FRAME_LOWER_ADDRESS (fp); - ip = SCM_FRAME_RETURN_ADDRESS (fp); - fp = SCM_FRAME_DYNAMIC_LINK (fp); - -#ifdef VM_ENABLE_STACK_NULLING - NULLSTACK (old_sp - sp); -#endif - - /* Set return value (sp is already pushed) */ - *sp = ret; - } - - /* Restore the last program */ - program = SCM_FRAME_PROGRAM (fp); - CACHE_PROGRAM (); - CHECK_IP (); - NEXT; -} - -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. */ - nvalues = FETCH (); - vm_return_values: - POP_CONTINUATION_HOOK (sp + 1 - nvalues, nvalues); - - VM_HANDLE_INTERRUPTS; - - if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp)) - { - /* A multiply-valued continuation */ - SCM *vals = sp - nvalues; - int i; - /* Restore registers */ - sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - ip = SCM_FRAME_MV_RETURN_ADDRESS (fp); - fp = SCM_FRAME_DYNAMIC_LINK (fp); - - /* Push return values, and the number of values */ - for (i = 0; i < nvalues; i++) - *++sp = vals[i+1]; - *++sp = SCM_I_MAKINUM (nvalues); - - /* Finally null the end of the stack */ - NULLSTACK (vals + nvalues - sp); - } - else if (nvalues >= 1) - { - /* Multiple values for a single-valued continuation -- here's where I - break with guile tradition and try and do something sensible. (Also, - this block handles the single-valued return to an mv - continuation.) */ - SCM *vals = sp - nvalues; - /* Restore registers */ - sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - ip = SCM_FRAME_RETURN_ADDRESS (fp); - fp = SCM_FRAME_DYNAMIC_LINK (fp); - - /* Push first value */ - *++sp = vals[1]; - - /* Finally null the end of the stack */ - NULLSTACK (vals + nvalues - sp); - } - else - { - SYNC_ALL (); - vm_error_no_values (); - } - - /* Restore the last program */ - program = SCM_FRAME_PROGRAM (fp); - CACHE_PROGRAM (); - CHECK_IP (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1) -{ - SCM l; - - nvalues = FETCH (); - ASSERT (nvalues >= 1); - - nvalues--; - POP (l); - while (scm_is_pair (l)) - { - PUSH (SCM_CAR (l)); - l = SCM_CDR (l); - nvalues++; - } - VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l)); - - goto vm_return_values; -} - -VM_DEFINE_INSTRUCTION (72, 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 (73, truncate_values, "truncate-values", 2, -1, -1) -{ - SCM x; - int nbinds, rest; - POP (x); - nvalues = scm_to_int (x); - nbinds = FETCH (); - rest = FETCH (); - - if (rest) - nbinds--; - - VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ()); - - if (rest) - POP_LIST (nvalues - nbinds); - else - DROPN (nvalues - nbinds); - - NEXT; -} - -VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0) -{ - SCM val; - POP (val); - SYNC_BEFORE_GC (); - LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val))); - NEXT; -} - -/* for letrec: - (let ((a *undef*) (b *undef*) ...) - (set! a (lambda () (b ...))) - ...) - */ -VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0) -{ - SYNC_BEFORE_GC (); - LOCAL_SET (FETCH (), - scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); - NEXT; -} - -VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1) -{ - SCM v = LOCAL_REF (FETCH ()); - ASSERT_BOUND_VARIABLE (v); - PUSH (VARIABLE_REF (v)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0) -{ - SCM v, val; - v = LOCAL_REF (FETCH ()); - POP (val); - ASSERT_VARIABLE (v); - VARIABLE_SET (v, val); - NEXT; -} - -VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1) -{ - scm_t_uint8 idx = FETCH (); - - CHECK_FREE_VARIABLE (idx); - PUSH (FREE_VARIABLE_REF (idx)); - NEXT; -} - -/* no free-set -- if a var is assigned, it should be in a box */ - -VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1) -{ - SCM v; - scm_t_uint8 idx = FETCH (); - CHECK_FREE_VARIABLE (idx); - v = FREE_VARIABLE_REF (idx); - ASSERT_BOUND_VARIABLE (v); - PUSH (VARIABLE_REF (v)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0) -{ - SCM v, val; - scm_t_uint8 idx = FETCH (); - POP (val); - CHECK_FREE_VARIABLE (idx); - v = FREE_VARIABLE_REF (idx); - ASSERT_BOUND_VARIABLE (v); - VARIABLE_SET (v, val); - NEXT; -} - -VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1) -{ - size_t n, len; - SCM closure; - - len = FETCH (); - len <<= 8; - len += FETCH (); - SYNC_BEFORE_GC (); - 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 (82, make_variable, "make-variable", 0, 0, 1) -{ - SYNC_BEFORE_GC (); - /* fixme underflow */ - PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); - NEXT; -} - -VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0) -{ - SCM x; - unsigned int i = FETCH (); - size_t n, len; - i <<= 8; - i += FETCH (); - /* FIXME CHECK_LOCAL (i) */ - x = LOCAL_REF (i); - /* FIXME ASSERT_PROGRAM (x); */ - 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 (84, define, "define", 0, 0, 2) -{ - SCM sym, val; - POP2 (sym, val); - SYNC_REGISTER (); - scm_define (sym, val); - NEXT; -} - -VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1) -{ - CHECK_UNDERFLOW (); - SYNC_REGISTER (); - *sp = scm_symbol_to_keyword (*sp); - NEXT; -} - -VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1) -{ - CHECK_UNDERFLOW (); - SYNC_REGISTER (); - *sp = scm_string_to_symbol (*sp); - NEXT; -} - -VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0) -{ - scm_t_int32 offset; - scm_t_uint8 escape_only_p; - SCM k; - scm_t_dynstack_prompt_flags flags; - - escape_only_p = FETCH (); - FETCH_OFFSET (offset); - POP (k); - - SYNC_REGISTER (); - /* Push the prompt onto the dynamic stack. */ - flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; - flags |= SCM_F_DYNSTACK_PROMPT_PUSH_NARGS; - scm_dynstack_push_prompt (¤t_thread->dynstack, flags, k, - fp, sp, ip + offset, ®isters); - NEXT; -} - -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. 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 (89, abort, "abort", 1, -1, -1) -{ - ptrdiff_t n = FETCH (); - SCM tag, *stack_args, tail; - PRE_CHECK_UNDERFLOW (n + 2); - SYNC_REGISTER (); - tail = sp[0]; - stack_args = sp - n; - tag = sp[-(n + 1)]; - /* Partial continuations are now RTL programs, and therefore not - resumable. Pass NULL as registers to indicate that fact. */ - vm_abort (vm, tag, n, stack_args, tail, sp - (n + 2), NULL); - /* vm_abort should not return */ - abort (); -} - -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_dynstack_pop (¤t_thread->dynstack); - NEXT; -} - -VM_DEFINE_INSTRUCTION (91, push_fluid, "push-fluid", 0, 2, 0) -{ - SCM fluid, val; - POP2 (val, fluid); - SYNC_REGISTER (); - scm_dynstack_push_fluid (¤t_thread->dynstack, fluid, val, - current_thread->dynamic_state); - NEXT; -} - -VM_DEFINE_INSTRUCTION (92, pop_fluid, "pop-fluid", 0, 0, 0) -{ - /* This function must not allocate. */ - scm_dynstack_unwind_fluid (¤t_thread->dynstack, - current_thread->dynamic_state); - NEXT; -} - -VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1) -{ - size_t num; - SCM fluids; - - CHECK_UNDERFLOW (); - fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state); - if (SCM_UNLIKELY (!SCM_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 - { - SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num); - if (scm_is_eq (val, SCM_UNDEFINED)) - val = SCM_I_FLUID_DEFAULT (*sp); - VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED), - vm_error_unbound_fluid (program, *sp)); - *sp = val; - } - - NEXT; -} - -VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0) -{ - size_t num; - SCM val, fluid, fluids; - - POP2 (val, fluid); - fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state); - if (SCM_UNLIKELY (!SCM_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 (); - - VM_ASSERT (sp - (fp - 1) == (n & 0x7), - vm_error_wrong_num_args (program)); - - old_sp = sp; - sp += (n >> 3); - CHECK_OVERFLOW (); - while (old_sp < sp) - *++old_sp = SCM_UNDEFINED; - - NEXT; -} - -/* Like bind-optionals/shuffle, but if there are too many positional - arguments, jumps to the next case-lambda clause. */ -VM_DEFINE_INSTRUCTION (96, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1) -{ - SCM *walk; - scm_t_ptrdiff nreq, nreq_and_opt, ntotal; - scm_t_int32 offset; - nreq = FETCH () << 8; - nreq += FETCH (); - nreq_and_opt = FETCH () << 8; - nreq_and_opt += FETCH (); - ntotal = FETCH () << 8; - ntotal += FETCH (); - FETCH_OFFSET (offset); - - /* look in optionals for first keyword or last positional */ - /* starting after the last required positional arg */ - walk = fp + nreq; - while (/* while we have args */ - walk <= sp - /* and we still have positionals to fill */ - && walk - fp < nreq_and_opt - /* and we haven't reached a keyword yet */ - && !scm_is_keyword (*walk)) - /* bind this optional arg (by leaving it in place) */ - walk++; - if (/* If we have filled all the positionals */ - walk - fp == nreq_and_opt - /* and there are still more arguments */ - && walk <= sp - /* and the next argument is not a keyword, */ - && !scm_is_keyword (*walk)) - { - /* Jump to the next case-lambda* clause. */ - ip += offset; - } - else - { - /* Otherwise, finish as in bind-optionals/shuffle: shuffle up, - from walk to ntotal */ - scm_t_ptrdiff nshuf = sp - walk + 1, i; - sp = (fp - 1) + ntotal + nshuf; - CHECK_OVERFLOW (); - for (i = 0; i < nshuf; i++) - sp[-i] = walk[nshuf-i-1]; - - /* and fill optionals & keyword args with SCM_UNDEFINED */ - while (walk <= (fp - 1) + ntotal) - *walk++ = SCM_UNDEFINED; - } - - NEXT; -} - - -/* -(defun renumber-ops () - "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" - (interactive "") - (save-excursion - (let ((counter -1)) (goto-char (point-min)) - (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) - (replace-match - (number-to-string (setq counter (1+ counter))) - t t nil 1))))) -(renumber-ops) -*/ -/* - Local Variables: - c-file-style: "gnu" - End: -*/ |