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.c454
1 files changed, 155 insertions, 299 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index ad0ec547e..377cbf916 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,25 +83,25 @@ 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 (57, make_nil, "make-nil", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (8, make_nil, "make-nil", 0, 0, 1)
{
PUSH (SCM_ELISP_NIL);
NEXT;
@@ -187,7 +181,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 (17, make_char32, "make-char32", 4, 0, 1)
{
scm_t_wchar v = 0;
v += FETCH ();
@@ -200,7 +194,7 @@ VM_DEFINE_INSTRUCTION (42, 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 ();
@@ -209,7 +203,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 ();
@@ -227,34 +221,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
@@ -277,7 +243,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 (20, object_ref, "object-ref", 1, 0, 1)
{
register unsigned objnum = FETCH ();
CHECK_OBJECT (objnum);
@@ -286,7 +252,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 (21, long_object_ref, "long-object-ref", 2, 0, 1)
{
unsigned int objnum = FETCH ();
objnum <<= 8;
@@ -296,14 +262,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 (22, 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 (23, long_local_ref, "long-local-ref", 2, 0, 1)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -313,7 +279,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 (24, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -332,7 +298,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 (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -355,7 +321,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 (26, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -382,14 +348,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 (27, 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 (28, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -399,14 +365,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 (29, 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 (30, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -425,7 +391,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 (31, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -470,7 +436,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 (32, br, "br", 2, 0, 0)
{
scm_t_int16 offset;
FETCH_OFFSET (offset);
@@ -478,34 +444,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 (33, 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 (34, 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 (35, 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 (36, 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 (37, 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 (38, br_if_not_null, "br-if-not-null", 2, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
@@ -515,7 +481,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 (39, new_frame, "new-frame", 0, 0, 3)
+{
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* mvra */
+ PUSH (0); /* ra */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (40, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -534,71 +508,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 */
@@ -611,32 +546,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 (41, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -647,151 +562,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 */
@@ -802,21 +621,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 (42, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -825,7 +639,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 (43, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -834,7 +648,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 (44, mv_call, "mv-call", 3, -1, 1)
{
SCM x;
scm_t_int16 offset;
@@ -854,8 +668,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;
@@ -865,13 +683,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;
@@ -884,20 +706,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 (45, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -916,7 +730,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 (46, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -935,7 +749,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 (47, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -944,6 +758,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;
@@ -969,7 +786,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 (48, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -1001,7 +818,7 @@ VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (49, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -1009,17 +826,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;
@@ -1039,28 +855,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 (50, 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++)
@@ -1079,8 +892,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];
@@ -1099,7 +912,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 (51, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1122,7 +935,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 (52, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1145,7 +958,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 (53, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1159,7 +972,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 (54, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1167,7 +980,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 (55, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1175,7 +988,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 (56, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1185,7 +998,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 (57, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1196,7 +1009,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 (58, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1207,7 +1020,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 (59, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1219,18 +1032,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 (60, 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 (61, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1238,6 +1051,48 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (62, fix_closure, "fix-closure", 2, 0, 1)
+{
+ SCM x, vect;
+ unsigned int i = FETCH ();
+ 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);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (63, define, "define", 0, 0, 2)
+{
+ SCM sym, val;
+ POP (sym);
+ POP (val);
+ SYNC_REGISTER ();
+ VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
+ SCM_BOOL_T),
+ val);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (64, make_keyword, "make-keyword", 0, 1, 1)
+{
+ CHECK_UNDERFLOW ();
+ SYNC_REGISTER ();
+ *sp = scm_symbol_to_keyword (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (65, make_symbol, "make-symbol", 0, 1, 1)
+{
+ CHECK_UNDERFLOW ();
+ SYNC_REGISTER ();
+ *sp = scm_string_to_symbol (*sp);
+ NEXT;
+}
+
/*
(defun renumber-ops ()
@@ -1249,6 +1104,7 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
(replace-match
(number-to-string (setq counter (1+ counter)))
t t nil 1)))))
+(renumber-ops)
*/
/*
Local Variables: