mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-15 05:43:19 -08:00
Factor the code for creating stack frames from varargs. Removed some arguments from ecl_apply_from_stack_frame and _ecl_standard_dispatch.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
f927dbd2f8
commit
44d23d1cdf
8 changed files with 90 additions and 84 deletions
|
|
@ -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);
|
||||
|
|
|
|||
57
src/c/eval.d
57
src/c/eval.d
|
|
@ -18,6 +18,7 @@
|
|||
|
||||
#include <ecl/ecl.h>
|
||||
#include <ecl/ecl-inl.h>
|
||||
#include <ecl/internal.h>
|
||||
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
18
src/c/gfun.d
18
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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
#include <stdio.h>
|
||||
#include <ecl/ecl-inl.h>
|
||||
#include <ecl/bytecodes.h>
|
||||
#include <ecl/internal.h>
|
||||
|
||||
/* -------------------- 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];
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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, ...);
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue