summaryrefslogtreecommitdiff
path: root/libguile/vm-i-system.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/vm-i-system.c')
-rw-r--r--libguile/vm-i-system.c429
1 files changed, 121 insertions, 308 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index b298c88a6..0662f8188 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -71,13 +71,7 @@ VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (4, mark, "mark", 0, 0, 1)
-{
- PUSH (SCM_UNDEFINED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (4, dup, "dup", 0, 0, 1)
{
SCM x = *sp;
PUSH (x);
@@ -89,49 +83,49 @@ VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
* Object creation
*/
-VM_DEFINE_INSTRUCTION (6, void, "void", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (5, void, "void", 0, 0, 1)
{
PUSH (SCM_UNSPECIFIED);
NEXT;
}
-VM_DEFINE_INSTRUCTION (7, make_true, "make-true", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (6, make_true, "make-true", 0, 0, 1)
{
PUSH (SCM_BOOL_T);
NEXT;
}
-VM_DEFINE_INSTRUCTION (8, make_false, "make-false", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (7, make_false, "make-false", 0, 0, 1)
{
PUSH (SCM_BOOL_F);
NEXT;
}
-VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
{
PUSH (SCM_EOL);
NEXT;
}
-VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
{
PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
NEXT;
}
-VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
{
PUSH (SCM_INUM0);
NEXT;
}
-VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
{
PUSH (SCM_I_MAKINUM (1));
NEXT;
}
-VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
{
int h = FETCH ();
int l = FETCH ();
@@ -139,7 +133,7 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
{
scm_t_uint64 v = 0;
v += FETCH ();
@@ -154,7 +148,7 @@ VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
{
scm_t_uint64 v = 0;
v += FETCH ();
@@ -169,7 +163,7 @@ VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
{
scm_t_uint8 v = 0;
v = FETCH ();
@@ -181,7 +175,7 @@ VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
+VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
{
scm_t_wchar v = 0;
v += FETCH ();
@@ -221,34 +215,6 @@ VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0)
-{
- POP_LIST_MARK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0)
-{
- POP_CONS_MARK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0)
-{
- POP_LIST_MARK ();
- SYNC_REGISTER ();
- *sp = scm_vector (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
-{
- SCM l;
- POP (l);
- PUSH_LIST (l, SCM_NULLP);
- NEXT;
-}
-
/*
* Variable access
@@ -271,7 +237,7 @@ VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
/* ref */
-VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1)
{
register unsigned objnum = FETCH ();
CHECK_OBJECT (objnum);
@@ -280,7 +246,7 @@ VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
}
/* FIXME: necessary? elt 255 of the vector could be a vector... */
-VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
{
unsigned int objnum = FETCH ();
objnum <<= 8;
@@ -290,14 +256,14 @@ VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
ASSERT_BOUND (*sp);
NEXT;
}
-VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -307,7 +273,7 @@ VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (23, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -326,7 +292,7 @@ VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (24, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -349,7 +315,7 @@ VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (25, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -376,14 +342,14 @@ VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (27, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -393,14 +359,14 @@ VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -419,7 +385,7 @@ VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (30, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -464,7 +430,7 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
{
scm_t_int16 offset;
FETCH_OFFSET (offset);
@@ -472,34 +438,34 @@ VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
{
BR (!SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
{
BR (SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
{
sp--; /* underflow? */
BR (SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
{
sp--; /* underflow? */
BR (!SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
{
BR (SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
@@ -509,7 +475,15 @@ VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3)
+{
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* mvra */
+ PUSH (0); /* ra */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -528,71 +502,32 @@ VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- NEW_FRAME ();
+ fp = sp - bp->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);
+ INIT_FRAME ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
-#ifdef ENABLE_TRAMPOLINE
- /* Seems to slow down the fibo test, dunno why */
- /*
- * Subr call
- */
- switch (nargs)
- {
- case 0:
- {
- scm_t_trampoline_0 call = scm_trampoline_0 (x);
- if (call)
- {
- SYNC_ALL ();
- *sp = call (x);
- NEXT;
- }
- break;
- }
- case 1:
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (x);
- if (call)
- {
- SCM arg1;
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1);
- NEXT;
- }
- break;
- }
- case 2:
- {
- scm_t_trampoline_2 call = scm_trampoline_2 (x);
- if (call)
- {
- SCM arg1, arg2;
- POP (arg2);
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1, arg2);
- NEXT;
- }
- break;
- }
- }
-#endif
/*
* Other interpreted or compiled call
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
- /* At this point, the stack contains the procedure and each one of its
- arguments. */
+ 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 ();
- /* keep args on stack so they are marked */
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ PUSH (scm_apply (x, args, SCM_EOL));
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
{
/* truncate values */
@@ -605,32 +540,12 @@ VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
}
NEXT;
}
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (x))
- {
- program = x;
- vm_call_continuation:
- /* Check the number of arguments */
- /* FIXME multiple args */
- if (nargs != 1)
- scm_wrong_num_args (program);
-
- /* Reinstate the continuation */
- EXIT_HOOK ();
- reinstate_vm_cont (vp, program);
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- NEXT;
- }
program = x;
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -641,151 +556,55 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
SCM_TICK; /* allow interrupt here */
/*
- * Tail recursive call
- */
- if (SCM_EQ_P (x, program))
- {
- int i;
-
- /* Move arguments */
- INIT_ARGS ();
- sp -= bp->nargs - 1;
- for (i = 0; i < bp->nargs; i++)
- LOCAL_SET (i, sp[i]);
-
- /* Drop the first argument and the program itself. */
- sp -= 2;
- NULLSTACK (bp->nargs + 1);
-
- /* Init locals to valid SCM values */
- for (i = 0; i < bp->nlocs; i++)
- LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
-
- /* Call itself */
- ip = bp->base;
- APPLY_HOOK ();
- NEXT;
- }
-
- /*
- * Tail call, but not to self -- reuse the frame, keeping the ra and dl
+ * Tail call
*/
if (SCM_PROGRAM_P (x))
{
- SCM *data, *tail_args, *dl;
int i;
- scm_byte_t *ra, *mvra;
#ifdef VM_ENABLE_STACK_NULLING
SCM *old_sp;
#endif
EXIT_HOOK ();
- /* save registers */
- tail_args = stack_base + 2;
- ra = SCM_FRAME_RETURN_ADDRESS (fp);
- mvra = SCM_FRAME_MV_RETURN_ADDRESS (fp);
- dl = SCM_FRAME_DYNAMIC_LINK (fp);
-
/* switch programs */
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- /* delay updating the frame so that if INIT_ARGS has to cons up a rest
- arg, going into GC, the stack still makes sense */
- fp[-1] = program;
- nargs = bp->nargs;
#ifdef VM_ENABLE_STACK_NULLING
old_sp = sp;
CHECK_STACK_LEAK ();
#endif
- /* new registers -- logically this would be better later, but let's make
- sure we have space for the locals now */
- data = SCM_FRAME_DATA_ADDRESS (fp);
- ip = bp->base;
- stack_base = data + 2;
- sp = stack_base;
- CHECK_OVERFLOW ();
-
- /* copy args, bottom-up */
- for (i = 0; i < nargs; i++)
- fp[i] = tail_args[i];
+ /* delay shuffling the new program+args down so that if INIT_ARGS had to
+ cons up a rest arg, going into GC, the stack still made sense */
+ for (i = -1, sp = sp - bp->nargs + 1; i < bp->nargs; i++)
+ fp[i] = sp[i];
+ sp = fp + i - 1;
NULLSTACK (old_sp - sp);
- /* init locals */
- for (i = bp->nlocs; i; i--)
- data[-i] = SCM_UNDEFINED;
-
- /* Set frame data */
- data[2] = (SCM)ra;
- data[1] = (SCM)mvra;
- data[0] = (SCM)dl;
+ INIT_FRAME ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
-#ifdef ENABLE_TRAMPOLINE
- /* This seems to actually slow down the fibo test -- dunno why */
- /*
- * Subr call
- */
- switch (nargs)
- {
- case 0:
- {
- scm_t_trampoline_0 call = scm_trampoline_0 (x);
- if (call)
- {
- SYNC_ALL ();
- *sp = call (x);
- goto vm_return;
- }
- break;
- }
- case 1:
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (x);
- if (call)
- {
- SCM arg1;
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1);
- goto vm_return;
- }
- break;
- }
- case 2:
- {
- scm_t_trampoline_2 call = scm_trampoline_2 (x);
- if (call)
- {
- SCM arg1, arg2;
- POP (arg2);
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1, arg2);
- goto vm_return;
- }
- break;
- }
- }
-#endif
/*
* Other interpreted or compiled call
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
+ SCM args;
POP_LIST (nargs);
+ POP (args);
+
SYNC_REGISTER ();
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ *sp = scm_apply (x, args, SCM_EOL);
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
+
if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
{
/* multiple values returned to continuation */
@@ -796,21 +615,16 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
PUSH_LIST (values, SCM_NULLP);
goto vm_return_values;
}
- goto vm_return;
+ else
+ goto vm_return;
}
program = x;
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (program))
- goto vm_call_continuation;
-
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -819,7 +633,7 @@ VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -828,7 +642,7 @@ VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
{
SCM x;
scm_t_int16 offset;
@@ -848,8 +662,12 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- NEW_FRAME ();
- SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra;
+ fp = sp - bp->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);
+ INIT_FRAME ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -859,13 +677,17 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
+ 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 ();
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ PUSH (scm_apply (x, args, SCM_EOL));
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
if (SCM_VALUESP (*sp))
{
SCM values, len;
@@ -878,20 +700,12 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
}
NEXT;
}
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (x))
- {
- program = x;
- goto vm_call_continuation;
- }
program = x;
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -910,7 +724,7 @@ VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -929,7 +743,7 @@ VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -938,6 +752,9 @@ VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
cont = scm_make_continuation (&first);
if (first)
{
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (proc);
PUSH (cont);
nargs = 1;
@@ -963,7 +780,7 @@ VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -995,7 +812,7 @@ VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -1003,17 +820,16 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
SYNC_REGISTER ();
SCM_TICK; /* allow interrupt here */
{
- SCM ret, *data;
- data = SCM_FRAME_DATA_ADDRESS (fp);
+ SCM ret;
POP (ret);
ASSERT (sp == stack_base);
- ASSERT (stack_base == data + 2);
+ ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
- ip = SCM_FRAME_BYTE_CAST (data[2]);
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
{
#ifdef VM_ENABLE_STACK_NULLING
int nullcount = stack_base - sp;
@@ -1033,28 +849,25 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (49, 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. */
- SCM *data;
-
nvalues = FETCH ();
vm_return_values:
EXIT_HOOK ();
RETURN_HOOK ();
- data = SCM_FRAME_DATA_ADDRESS (fp);
- ASSERT (stack_base == data + 2);
+ ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
/* data[1] is the mv return address */
- if (nvalues != 1 && data[1])
+ if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ 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++)
@@ -1073,8 +886,8 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
continuation.) */
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push first value */
*++sp = stack_base[1];
@@ -1093,7 +906,7 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1116,7 +929,7 @@ VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1139,7 +952,7 @@ VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1153,7 +966,7 @@ VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1161,7 +974,7 @@ VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1169,7 +982,7 @@ VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1179,7 +992,7 @@ VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1190,7 +1003,7 @@ VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1201,7 +1014,7 @@ VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1213,18 +1026,18 @@ VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
SYNC_BEFORE_GC ();
/* fixme underflow */
- SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
- SCM_PROGRAM_OBJTABLE (*sp), vect);
+ *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);
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1232,7 +1045,7 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
{
SCM x, vect;
unsigned int i = FETCH ();
@@ -1246,7 +1059,7 @@ VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (66, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@@ -1258,7 +1071,7 @@ VM_DEFINE_INSTRUCTION (66, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (67, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1266,7 +1079,7 @@ VM_DEFINE_INSTRUCTION (67, make_keyword, "make-keyword", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (68, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (64, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();