diff --git a/src/c/arch/ffi_x86.d b/src/c/arch/ffi_x86.d index 88558a1d2..a4fe8eb6e 100644 --- a/src/c/arch/ffi_x86.d +++ b/src/c/arch/ffi_x86.d @@ -137,7 +137,7 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer) } } - result = ecl_apply_from_stack_frame(env, frame, fun); + result = ecl_apply_from_stack_frame(frame, fun); ecl_stack_frame_close(frame); tag = ecl_foreign_type_code(rtype); diff --git a/src/c/eval.d b/src/c/eval.d index a68858dbe..67d873b8c 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -18,6 +18,7 @@ #include #include +#include cl_object * _ecl_va_sp(cl_narg narg) @@ -25,32 +26,6 @@ _ecl_va_sp(cl_narg narg) return ecl_process_env()->stack_top - narg; } -static cl_object -build_funcall_frame(cl_object f, cl_va_list args) -{ - cl_env_ptr env = ecl_process_env(); - cl_index n = args[0].narg; - cl_object *p = args[0].sp; - f->frame.stack = 0; - if (!p) { -#ifdef ECL_USE_VARARG_AS_POINTER - p = (cl_object*)(args[0].args); -#else - cl_index i; - p = env->values; - for (i = 0; i < n; i++) { - p[i] = va_arg(args[0].args, cl_object); - } - f->frame.stack = (void*)0x1; -#endif - } - f->frame.bottom = p; - f->frame.top = p + n; - f->frame.t = t_frame; - f->frame.env = env; - return f; -} - /* Calling conventions: Compiled C code calls lisp function supplying #args, and args. Linking function performs check_args, gets jmp_buf with _setjmp, then @@ -61,32 +36,29 @@ build_funcall_frame(cl_object f, cl_va_list args) */ cl_object -ecl_apply_from_stack_frame(cl_env_ptr env, cl_object frame, cl_object x) +ecl_apply_from_stack_frame(cl_object frame, cl_object x) { cl_object *sp = frame->frame.bottom; cl_index narg = frame->frame.top - sp; cl_object fun = x; AGAIN: + frame->frame.env->function = fun; if (fun == OBJNULL || fun == Cnil) FEundefined_function(x); switch (type_of(fun)) { case t_cfunfixed: - env->function = fun; if (narg != (cl_index)fun->cfun.narg) FEwrong_num_arguments(fun); return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); case t_cfun: - env->function = fun; return APPLY(narg, fun->cfun.entry, sp); case t_cclosure: - env->function = fun; return APPLY(narg, fun->cclosure.entry, sp); #ifdef CLOS case t_instance: switch (fun->instance.isgf) { case ECL_STANDARD_DISPATCH: - env->function = fun; - return _ecl_standard_dispatch(env, frame, fun); + return _ecl_standard_dispatch(frame, fun); case ECL_USER_DISPATCH: fun = fun->instance.slots[fun->instance.length - 1]; default: @@ -148,16 +120,23 @@ ecl_function_dispatch(cl_env_ptr env, cl_object x) } } -@(defun funcall (function &rest funargs) - struct ecl_stack_frame frame_aux; -@ - return ecl_apply_from_stack_frame(the_env, build_funcall_frame((cl_object)&frame_aux, funargs), function); -@) +cl_object +cl_funcall(cl_narg narg, cl_object function, ...) +{ + cl_object output; + --narg; + { + ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); + output = ecl_apply_from_stack_frame(frame, function); + ECL_STACK_FRAME_VARARGS_END(frame); + } + return output; +} @(defun apply (fun lastarg &rest args) @ if (narg == 2 && type_of(lastarg) == t_frame) { - return ecl_apply_from_stack_frame(the_env, lastarg, fun); + return ecl_apply_from_stack_frame(lastarg, fun); } else { cl_object out; cl_index i; @@ -183,7 +162,7 @@ ecl_function_dispatch(cl_env_ptr env, cl_object x) ecl_stack_frame_push(frame, CAR(lastarg)); i++; } end_loop_for_in; - out = ecl_apply_from_stack_frame(the_env, frame, fun); + out = ecl_apply_from_stack_frame(frame, fun); ecl_stack_frame_close(frame); return out; } diff --git a/src/c/gfun.d b/src/c/gfun.d index 319130b90..d6cce56d8 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -50,7 +50,7 @@ user_function_dispatch(cl_narg narg, ...) ecl_stack_frame_elt_set(frame, i, cl_va_arg(args)); } fun = fun->instance.slots[fun->instance.length - 1]; - output = ecl_apply_from_stack_frame(env, frame, fun); + output = ecl_apply_from_stack_frame(frame, fun); ecl_stack_frame_close(frame); return output; } @@ -375,9 +375,10 @@ compute_applicable_method(cl_object frame, cl_object gf) } cl_object -_ecl_standard_dispatch(cl_env_ptr env, cl_object frame, cl_object gf) +_ecl_standard_dispatch(cl_object frame, cl_object gf) { cl_object func, vector; + const cl_env_ptr env = frame->frame.env; /* * We have to copy the frame because it might be stored in cl_env.values * which will be wiped out by the next function call. However this only @@ -434,16 +435,9 @@ _ecl_standard_dispatch(cl_env_ptr env, cl_object frame, cl_object gf) static cl_object generic_function_dispatch_vararg(cl_narg narg, ...) { - int i; cl_object output; - cl_env_ptr env = ecl_process_env(); - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg); - cl_va_list args; cl_va_start(args, narg, narg, 0); - for (i = 0; i < narg; i++) { - ecl_stack_frame_elt_set(frame, i, cl_va_arg(args)); - } - output = _ecl_standard_dispatch(env, frame, env->function); - ecl_stack_frame_close(frame); + ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame); + output = _ecl_standard_dispatch(frame, frame->frame.env->function); + ECL_STACK_FRAME_VARARGS_END(frame); return output; } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index da49d2598..fa52213c2 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -19,6 +19,7 @@ #include #include #include +#include /* -------------------- INTERPRETER STACK -------------------- */ @@ -73,6 +74,8 @@ ecl_stack_pop(cl_env_ptr env) { return *(--env->stack_top); } +#undef ecl_stack_index + cl_index ecl_stack_index(cl_env_ptr env) { return env->stack_top - env->stack; @@ -435,35 +438,21 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) cl_object _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...) { - int i; cl_object output; - cl_env_ptr env = ecl_process_env(); - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg); - cl_va_list args; cl_va_start(args, narg, narg, 0); - for (i = 0; i < narg; i++) { - ecl_stack_frame_elt_set(frame, i, cl_va_arg(args)); - } - output = ecl_interpret(frame, Cnil, env->function, 0); - ecl_stack_frame_close(frame); + ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame); + output = ecl_interpret(frame, Cnil, frame->frame.env->function, 0); + ECL_STACK_FRAME_VARARGS_END(frame); return output; } cl_object _ecl_bclosure_dispatch_vararg(cl_narg narg, ...) { - int i; cl_object output; - cl_env_ptr env = ecl_process_env(); - cl_object fun = env->function; - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg); - cl_va_list args; cl_va_start(args, narg, narg, 0); - for (i = 0; i < narg; i++) { - ecl_stack_frame_elt_set(frame, i, cl_va_arg(args)); - } - output = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code, 0); - ecl_stack_frame_close(frame); + ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { + cl_object fun = frame->frame.env->function; + output = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code, 0); + } ECL_STACK_FRAME_VARARGS_END(frame); return output; } @@ -520,7 +509,7 @@ close_around(cl_object fun, cl_object lex) { frame.stack = the_env->stack; \ frame.top = the_env->stack_top; \ frame.bottom = frame.top - __n; \ - reg0 = ecl_apply_from_stack_frame(the_env, (cl_object)&frame, fun); \ + reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \ the_env->stack_top -= __n; } /* -------------------- THE INTERPRETER -------------------- */ @@ -546,6 +535,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs ecl_ihs_push(the_env, &ihs, bytecodes, lex_env); frame_aux.t = t_frame; frame_aux.stack = frame_aux.top = frame_aux.bottom = 0; + frame_aux.env = the_env; reg0 = Cnil; the_env->nvalues = 0; BEGIN: @@ -763,7 +753,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs case t_instance: switch (reg0->instance.isgf) { case ECL_STANDARD_DISPATCH: - reg0 = _ecl_standard_dispatch(the_env, frame, reg0); + reg0 = _ecl_standard_dispatch(frame, reg0); break; case ECL_USER_DISPATCH: reg0 = reg0->instance.slots[reg0->instance.length - 1]; diff --git a/src/c/mapfun.d b/src/c/mapfun.d index 81b7546aa..748b5a2ad 100644 --- a/src/c/mapfun.d +++ b/src/c/mapfun.d @@ -49,7 +49,7 @@ ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr)); ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = ecl_list1(ecl_apply_from_stack_frame(the_env, cars_frame, fun)); + *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); val = &ECL_CONS_CDR(*val); } } @) @@ -71,7 +71,7 @@ ecl_stack_frame_elt_set(cars_frame, i, cdr); ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = ecl_list1(ecl_apply_from_stack_frame(the_env, cars_frame, fun)); + *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); val = &ECL_CONS_CDR(*val); } } @) @@ -93,7 +93,7 @@ ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr)); ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - ecl_apply_from_stack_frame(the_env, cars_frame, fun); + ecl_apply_from_stack_frame(cars_frame, fun); } } @) @@ -114,7 +114,7 @@ ecl_stack_frame_elt_set(cars_frame, i, cdr); ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - ecl_apply_from_stack_frame(the_env, cars_frame, fun); + ecl_apply_from_stack_frame(cars_frame, fun); } } @) @@ -135,7 +135,7 @@ ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr)); ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = ecl_apply_from_stack_frame(the_env, cars_frame, fun); + *val = ecl_apply_from_stack_frame(cars_frame, fun); while (CONSP(*val)) val = &ECL_CONS_CDR(*val); } @@ -158,7 +158,7 @@ ecl_stack_frame_elt_set(cars_frame, i, cdr); ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = ecl_apply_from_stack_frame(the_env, cars_frame, fun); + *val = ecl_apply_from_stack_frame(cars_frame, fun); while (CONSP(*val)) val = &ECL_CONS_CDR(*val); } diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index 260e96604..f78016c06 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -77,7 +77,7 @@ (defun c1apply-from-stack-frame (args) (c1expr `(c-inline ,args (t t) (values &rest t) - "cl_env_copy->values[0]=ecl_apply_from_stack_frame(cl_env_copy,#0,#1);" + "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" :one-liner nil :side-effects t))) (put-sysprop 'with-stack 'C1 #'c1with-stack) diff --git a/src/h/external.h b/src/h/external.h index 247fd64d0..cd0e773e4 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -541,7 +541,7 @@ extern ECL_API cl_object cl_constantp(cl_narg narg, cl_object arg, ...); #define funcall cl_funcall extern ECL_API cl_object cl_apply_from_stack(cl_index narg, cl_object fun); -extern ECL_API cl_object ecl_apply_from_stack_frame(cl_env_ptr env, cl_object f, cl_object o); +extern ECL_API cl_object ecl_apply_from_stack_frame(cl_object f, cl_object o); extern ECL_API cl_objectfn ecl_function_dispatch(cl_env_ptr env, cl_object f); extern ECL_API cl_object _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_va_list args); @@ -684,7 +684,7 @@ extern ECL_API cl_object si_clear_gfun_hash(cl_object what); extern ECL_API cl_object clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t); extern ECL_API cl_object si_generic_function_p(cl_object instance); -extern ECL_API cl_object _ecl_standard_dispatch(cl_env_ptr env, cl_object frame, cl_object fun); +extern ECL_API cl_object _ecl_standard_dispatch(cl_object frame, cl_object fun); #endif /* CLOS */ diff --git a/src/h/internal.h b/src/h/internal.h index 6af2ff89a..855d5980b 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -98,6 +98,49 @@ typedef struct cl_compiler_env *cl_compiler_env_ptr; struct ecl_stack_frame frame;\ cl_object name = ecl_stack_frame_open(env, (cl_object)&frame, 0); +#ifdef ECL_USE_VARARG_AS_POINTER +#define ECL_STACK_FRAME_VARARGS_BEGIN(narg,lastarg,frame) \ + struct ecl_frame __ecl_frame; \ + const cl_object frame = (cl_object)&__ecl_frame; \ + const cl_env_ptr env = ecl_process_env(); \ + frame->frame.t = t_frame; \ + frame->frame.stack = 0; \ + frame->frame.env = env; \ + if (narg < C_ARGUMENTS_LIMIT) { \ + va_list args; \ + va_start(args, lastarg); \ + frame->frame.top = (frame->frame.bottom = (void*)args) + narg; \ + } else { \ + frame->frame.bottom = (frame->frame.top = env->stack_top) - narg; \ + } +#define ECL_STACK_FRAME_VARARGS_END(frame) \ + /* No stack consumed, no need to close frame */ +#else +#define ECL_STACK_FRAME_VARARGS_BEGIN(narg,lastarg,frame) \ + struct ecl_frame __ecl_frame; \ + const cl_object frame = (cl_object)&__ecl_frame; \ + const cl_env_ptr env = ecl_process_env(); \ + frame->frame.t = t_frame; \ + frame->frame.env = env; \ + if (narg < C_ARGUMENTS_LIMIT) { \ + cl_index i; \ + cl_object *p = frame->frame.bottom = env->values; \ + va_list args; \ + va_start(args, lastarg); \ + while (narg--) { \ + *p = va_arg(args, cl_object); \ + ++p; \ + } \ + frame->frame.top = p; \ + frame->frame.stack = (void*)0x1; \ + } else { \ + frame->frame.bottom = (frame->frame.top = env->stack_top) - narg; \ + frame->frame.stack = 0; \ + } +#define ECL_STACK_FRAME_VARARGS_END(frame) \ + /* No stack consumed, no need to close frame */ +#endif + extern cl_object _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...); extern cl_object _ecl_bclosure_dispatch_vararg(cl_narg narg, ...);