Commit 912f4e49 authored by Marius Gerbershagen's avatar Marius Gerbershagen
Browse files

apply_from_stack_frame: use correct frame base

Previously, we assumed that all stack frames were lying at the top of
the lisp stack. This is not always true due to e.g.
multiple-value-prog1 pushing onto the lisp stack.
parent adace6ba
......@@ -19,7 +19,7 @@
cl_object *
_ecl_va_sp(cl_narg narg)
{
return ecl_process_env()->stack_top - narg;
return ecl_process_env()->stack_frame->frame.base + narg;
}
/* Calling conventions:
......@@ -37,6 +37,8 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
cl_object *sp = frame->frame.base;
cl_index narg = frame->frame.size;
cl_object fun = x;
cl_object ret;
frame->frame.env->stack_frame = frame;
AGAIN:
frame->frame.env->function = fun;
if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL))
......@@ -45,37 +47,47 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
case t_cfunfixed:
if (ecl_unlikely(narg != (cl_index)fun->cfun.narg))
FEwrong_num_arguments(fun);
return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
break;
case t_cfun:
return APPLY(narg, fun->cfun.entry, sp);
ret = APPLY(narg, fun->cfun.entry, sp);
break;
case t_cclosure:
return APPLY(narg, fun->cclosure.entry, sp);
ret = APPLY(narg, fun->cclosure.entry, sp);
break;
case t_instance:
switch (fun->instance.isgf) {
case ECL_STANDARD_DISPATCH:
case ECL_RESTRICTED_DISPATCH:
return _ecl_standard_dispatch(frame, fun);
ret = _ecl_standard_dispatch(frame, fun);
break;
case ECL_USER_DISPATCH:
fun = fun->instance.slots[fun->instance.length - 1];
goto AGAIN;
case ECL_READER_DISPATCH:
case ECL_WRITER_DISPATCH:
return APPLY(narg, fun->instance.entry, sp);
ret = APPLY(narg, fun->instance.entry, sp);
break;
default:
FEinvalid_function(fun);
}
break;
case t_symbol:
if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro))
FEundefined_function(x);
fun = ECL_SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
return ecl_interpret(frame, ECL_NIL, fun);
ret = ecl_interpret(frame, ECL_NIL, fun);
break;
case t_bclosure:
return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
break;
default:
FEinvalid_function(x);
}
frame->frame.env->stack_frame = NULL; /* for gc's sake */
return ret;
}
cl_objectfn
......
......@@ -510,6 +510,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
cl_object frame = (cl_object)&frame_aux;
frame_aux.size = narg;
frame_aux.base = the_env->stack_top - narg;
the_env->stack_frame = frame;
SETUP_ENV(the_env);
AGAIN:
if (ecl_unlikely(reg0 == OBJNULL || reg0 == ECL_NIL))
......@@ -561,11 +562,12 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
FEinvalid_function(reg0);
}
ECL_STACK_POP_N_UNSAFE(the_env, narg);
the_env->stack_frame = NULL; /* for gc's sake */
THREAD_NEXT;
}
/* OP_POP
Pops a singe value pushed by a OP_PUSH* operator.
Pops a single value pushed by a OP_PUSH* operator.
*/
CASE(OP_POP); {
reg0 = ECL_STACK_POP_UNSAFE(the_env);
......
......@@ -384,6 +384,7 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
cl_index nvalues = env->nvalues;
cl_object values[ECL_MULTIPLE_VALUES_LIMIT];
memcpy(values, env->values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
cl_object stack_frame = env->stack_frame;
cl_object big_register[3];
memcpy(big_register, env->big_register, 3*sizeof(cl_object));
cl_object packages_to_be_created = env->packages_to_be_created;
......@@ -409,6 +410,7 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
env->packages_to_be_created_p = packages_to_be_created_p;
env->packages_to_be_created = packages_to_be_created;
memcpy(env->big_register, big_register, 3*sizeof(cl_object));
env->stack_frame = stack_frame;
memcpy(env->values, values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
env->nvalues = nvalues;
env->function = fun;
......
......@@ -26,6 +26,9 @@ struct cl_env_struct {
/* Environment for calling closures, CLOS generic functions, etc */
cl_object function;
/* Current stack frame */
cl_object stack_frame;
/* The four stacks in ECL. */
/*
......
......@@ -340,7 +340,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr);
#define ecl_va_start(a,p,n,k) { \
a[0].narg = (n)-(k); \
va_start(a[0].args,p); \
a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(a[0].narg); }
a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(k); }
#define ecl_va_arg(a) \
(a[0].narg--,(a[0].sp? *(a[0].sp++) : va_arg(a[0].args,cl_object)))
#define ecl_va_copy(dest,orig) { \
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment