mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 13:52:16 -08:00
Code Issues Projects Releases Packages Wiki Activity

Slight simplification of the ecl_stack_frame structure, with changes associated to interpreter, gfun and apply

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-02-19 00:04:31 +01:00
parent 9fb6a858d2
commit 69bdd4f3ff
12 changed files with 124 additions and 116 deletions
Download patch file Download diff file Expand all files Collapse all files

1
src/aclocal.m4 vendored
View file

@ -573,6 +573,7 @@ case "${host_cpu}" in
EXTRA_OBJS="${EXTRA_OBJS} apply_x86.o"
AC_DEFINE(ECL_ASM_APPLY)
fi
AC_DEFINE(ECL_USE_VARARG_AS_POINTER)
dynamic_ffi=yes
;;
x86_64 )

2
src/c/Makefile.in
View file

@ -55,7 +55,7 @@ OBJS = main.o symbol.o package.o list.o\
all: $(DPP) ../libeclmin.a ../cinit.o
.c.S: $(HFILES)
.c.s: $(HFILES)
$(CC) -DECLDIR="\"@ecldir@\"" $(CFLAGS) -S -o $@ $<
.c.o: $(HFILES)
$(CC) -DECLDIR="\"@ecldir@\"" $(CFLAGS) -o $@ $<

25
src/c/compiler.d
View file

@ -2103,6 +2103,11 @@ for special form ~S.", 1, function);
static int
compile_body(cl_object body, int flags) {
if (ENV->lexical_level == 0 && !ecl_endp(body)) {
struct ecl_stack_frame frame;
frame.t = t_frame;
frame.stack = frame.base = 0;
frame.size = 0;
frame.env = ecl_process_env();
while (!ecl_endp(CDR(body))) {
struct cl_compiler_env *old_c_env = ENV;
struct cl_compiler_env new_c_env = *old_c_env;
@ -2115,7 +2120,7 @@ compile_body(cl_object body, int flags) {
VALUES(0) = Cnil;
NVALUES = 0;
bytecodes = asm_end(handle);
ecl_interpret(Cnil, ENV->lex_env, bytecodes, 0);
ecl_interpret((cl_object)&frame, ENV->lex_env, bytecodes, 0);
asm_clear(handle);
ENV = old_c_env;
#ifdef GBC_BOEHM
@ -2764,13 +2769,19 @@ si_make_lambda(cl_object name, cl_object rest)
VALUES(0) = Cnil;
NVALUES = 0;
{
cl_object output = ecl_interpret(Cnil, interpreter_env, bytecodes, 0);
struct ecl_stack_frame frame;
cl_object output;
frame.t = t_frame;
frame.stack = frame.base = 0;
frame.size = 0;
frame.env = the_env;
output = ecl_interpret((cl_object)&frame, interpreter_env, bytecodes, 0);
#ifdef GBC_BOEHM
GC_free(bytecodes->bytecodes.code);
GC_free(bytecodes->bytecodes.data);
GC_free(bytecodes);
GC_free(bytecodes->bytecodes.code);
GC_free(bytecodes->bytecodes.data);
GC_free(bytecodes);
#endif
ecl_ihs_pop(the_env);
return output;
ecl_ihs_pop(the_env);
return output;
}
@)

11
src/c/eval.d
View file

@ -38,8 +38,8 @@ _ecl_va_sp(cl_narg narg)
cl_object
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 *sp = frame->frame.base;
cl_index narg = frame->frame.size;
cl_object fun = x;
AGAIN:
frame->frame.env->function = fun;
@ -150,9 +150,10 @@ cl_funcall(cl_narg narg, cl_object function, ...)
}
if (type_of(lastarg) == t_frame) {
/* This could be replaced with a memcpy() */
cl_object *p = lastarg->frame.bottom;
while (p != lastarg->frame.top) {
ecl_stack_frame_push(frame, *(p++));
cl_object *p = lastarg->frame.base;
cl_index i;
for (i = 0; i < lastarg->frame.size; i++) {
ecl_stack_frame_push(frame, lastarg->frame.base[i]);
}
} else loop_for_in (lastarg) {
if (i >= CALL_ARGUMENTS_LIMIT) {

9
src/c/gfun.d
View file

@ -329,8 +329,8 @@ search_method_hash(cl_env_ptr env, cl_object keys)
static cl_object
get_spec_vector(cl_env_ptr env, cl_object frame, cl_object gf)
{
cl_object *args = frame->frame.bottom;
cl_index narg = frame->frame.top - args;
cl_object *args = frame->frame.base;
cl_index narg = frame->frame.size;
cl_object spec_how_list = GFUN_SPEC(gf);
cl_object vector = env->method_spec_vector;
cl_object *argtype = vector->vector.self.t;
@ -360,13 +360,14 @@ compute_applicable_method(cl_object frame, cl_object gf)
/* method not cached */
cl_object methods, arglist, func;
cl_object *p;
for (p = frame->frame.top, arglist = Cnil; p != frame->frame.bottom; ) {
for (p = frame->frame.base + frame->frame.size, arglist = Cnil;
p != frame->frame.base; ) {
arglist = CONS(*(--p), arglist);
}
methods = funcall(3, @'compute-applicable-methods', gf, arglist);
if (methods == Cnil) {
func = funcall(3, @'no-applicable-method', gf, arglist);
frame->frame.bottom[0] = OBJNULL;
frame->frame.base[0] = OBJNULL;
return func;
} else {
return funcall(4, @'clos::compute-effective-method', gf,

166
src/c/interpreter.d
View file

@ -138,19 +138,20 @@ ecl_stack_push_list(cl_env_ptr env, cl_object list)
cl_object
ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size)
{
cl_object *top = env->stack_top;
cl_object *base = env->stack_top;
if (size) {
if (env->stack_limit - top < size) {
if (env->stack_limit - base < size) {
cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
ecl_stack_set_size(env, env->stack_size + delta * LISP_PAGESIZE);
top = env->stack_top;
base = env->stack_top;
}
}
f->frame.t = t_frame;
f->frame.stack = env->stack;
f->frame.bottom = top;
f->frame.base = base;
f->frame.size = size;
f->frame.env = env;
env->stack_top = f->frame.top = (top + size);
env->stack_top = (base + size);
return f;
}
@ -159,22 +160,17 @@ ecl_stack_frame_enlarge(cl_object f, cl_index size)
{
cl_object *top;
cl_env_ptr env = f->frame.env;
if (f->frame.stack == 0) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
top = env->stack_top;
if ((env->stack_limit - top) < size) {
cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
ecl_stack_set_size(env, env->stack_size + delta * LISP_PAGESIZE);
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
} else if (top != f->frame.top) {
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.base = (f->frame.base - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
}
env->stack_top = f->frame.top = (top + size);
env->stack_top = (top += size);
f->frame.base = top - (f->frame.size += size);
f->frame.stack = env->stack;
}
void
@ -182,75 +178,67 @@ ecl_stack_frame_push(cl_object f, cl_object o)
{
cl_object *top;
cl_env_ptr env = f->frame.env;
if (f->frame.stack == 0) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
top = env->stack_top;
if (top >= env->stack_limit) {
ecl_stack_grow(env);
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
} else if (top != f->frame.top) {
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.base = (f->frame.base - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
}
*(top++) = o;
env->stack_top = f->frame.top = top;
*top = o;
env->stack_top = ++top;
f->frame.base = top - (++(f->frame.size));
f->frame.stack = env->stack;
}
void
ecl_stack_frame_push_values(cl_object f)
{
cl_env_ptr env = f->frame.env;
if (f->frame.stack == 0) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
ecl_stack_push_values(env);
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.base = env->stack_top - (f->frame.size += env->nvalues);
f->frame.stack = env->stack;
f->frame.top = env->stack_top;
}
cl_object
ecl_stack_frame_pop_values(cl_object f)
{
cl_index n = f->frame.top - f->frame.bottom;
NVALUES = n;
VALUES(0) = Cnil;
cl_env_ptr env = f->frame.env;
cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT;
cl_object o;
env->nvalues = n;
env->values[0] = o = Cnil;
while (n--) {
VALUES(n) = f->frame.bottom[n];
env->values[n] = o = f->frame.base[n];
}
return VALUES(0);
return o;
}
cl_object
ecl_stack_frame_elt(cl_object f, cl_index ndx)
{
if (ndx >= (f->frame.top - f->frame.bottom)) {
if (ndx >= f->frame.size) {
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
}
return f->frame.bottom[ndx];
return f->frame.base[ndx];
}
void
ecl_stack_frame_elt_set(cl_object f, cl_index ndx, cl_object o)
{
if (ndx >= (f->frame.top - f->frame.bottom)) {
if (ndx >= f->frame.size) {
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
}
f->frame.bottom[ndx] = o;
f->frame.base[ndx] = o;
}
cl_object
ecl_stack_frame_from_va_list(cl_env_ptr env, cl_object frame, cl_va_list args)
{
cl_index nargs = args[0].narg;
cl_index i, nargs = args[0].narg;
ecl_stack_frame_open(env, frame, nargs);
while (nargs) {
*(frame->frame.top-nargs) = cl_va_arg(args);
nargs--;
for (i = 0; i < nargs; i++) {
frame->frame.base[i] = cl_va_arg(args);
}
return frame;
}
@ -259,16 +247,16 @@ void
ecl_stack_frame_close(cl_object f)
{
if (f->frame.stack) {
ecl_stack_set_index(f->frame.env, f->frame.bottom - f->frame.stack);
ecl_stack_set_index(f->frame.env, f->frame.base - f->frame.stack);
}
}
cl_object
ecl_stack_frame_copy(cl_object dest, cl_object orig)
{
cl_index size = orig->frame.top - orig->frame.bottom;
cl_index size = orig->frame.size;
dest = ecl_stack_frame_open(orig->frame.env, dest, size);
memcpy(dest->frame.bottom, orig->frame.bottom, size * sizeof(cl_object));
memcpy(dest->frame.base, orig->frame.base, size * sizeof(cl_object));
return dest;
}
@ -295,48 +283,50 @@ ecl_lex_env_get_record(register cl_object env, register int s)
/* -------------------- LAMBDA FUNCTIONS -------------------- */
static cl_object
lambda_bind_var(cl_object env, cl_object var, cl_object val, cl_object specials)
{
const cl_env_ptr the_env = ecl_process_env();
if (!ecl_member_eq(var, specials))
env = bind_var(env, var, val);
else
ecl_bds_bind(the_env, var, val);
return env;
}
#define LAMBDA_BIND_VAR(env,lex_env,_var,_val,specials) \
{ \
cl_object var = _var, val = _val; \
if (!ecl_member_eq(var, specials)) \
lex_env = bind_var(lex_env, var, val); \
else \
ecl_bds_bind(env, var, val); \
}
static cl_object
lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp)
lambda_bind(cl_object frame, cl_object lex_env, cl_object lambda)
{
cl_object *data = lambda->bytecodes.data;
cl_object specials = lambda->bytecodes.specials;
int i, n;
cl_narg narg = frame->frame.size;
const cl_object *sp = frame->frame.base;
const cl_env_ptr the_env = frame->frame.env;
bool check_remaining = TRUE;
/* 1) REQUIRED ARGUMENTS: N var1 ... varN */
n = fix(*(data++));
if (narg < n)
FEwrong_num_arguments(lambda->bytecodes.name);
for (; n; n--, narg--)
env = lambda_bind_var(env, *(data++), *(sp++), specials);
for (; n; n--, narg--) {
LAMBDA_BIND_VAR(the_env, lex_env, *(data++), *(sp++), specials);
}
/* 2) OPTIONAL ARGUMENTS: N var1 value1 flag1 ... varN valueN flagN */
for (n = fix(*(data++)); n; n--, data+=3) {
if (narg) {
env = lambda_bind_var(env, data[0], *sp, specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[0], *sp, specials);
sp++; narg--;
if (!Null(data[2])) {
env = lambda_bind_var(env, data[2], Ct, specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[2], Ct, specials);
}
} else {
cl_object defaults = data[1];
if (FIXNUMP(defaults)) {
defaults = ecl_interpret(Cnil, env, lambda, fix(defaults));
/* Here FRAME is not used */
defaults = ecl_interpret(frame, lex_env, lambda, fix(defaults));
}
env = lambda_bind_var(env, data[0], defaults, specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[0], defaults, specials);
if (!Null(data[2])) {
env = lambda_bind_var(env, data[2], Cnil, specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[2], Cnil, specials);
}
}
}
@ -348,7 +338,7 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp)
for (i=narg; i; ) {
rest = CONS(sp[--i], rest);
}
env = lambda_bind_var(env, data[0], rest, specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[0], rest, specials);
}
data++;
@ -417,20 +407,21 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp)
}
for (i=0; i<n; i++, data+=4) {
if (spp[i] != unbound) {
env = lambda_bind_var(env, data[1],spp[i],specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[1], spp[i], specials);
} else {
cl_object defaults = data[2];
if (FIXNUMP(defaults)) {
defaults = ecl_interpret(Cnil, env, lambda, fix(defaults));
/* Here FRAME is not used */
defaults = ecl_interpret(frame, lex_env, lambda, fix(defaults));
}
env = lambda_bind_var(env, data[1],defaults,specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[1],defaults,specials);
}
if (!Null(data[3])) {
env = lambda_bind_var(env, data[3],(spp[i] != unbound)? Ct : Cnil,specials);
LAMBDA_BIND_VAR(the_env, lex_env, data[3], (spp[i] != unbound)? Ct : Cnil, specials);
}
}
}
return env;
return lex_env;
}
/* -------------------- AIDS TO THE INTERPRETER -------------------- */
@ -503,22 +494,21 @@ close_around(cl_object fun, cl_object lex) {
* lexical environment needs to be saved.
*/
#define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \
cl_index __n = narg; \
SETUP_ENV(the_env); \
frame.stack = the_env->stack; \
frame.top = the_env->stack_top; \
frame.bottom = frame.top - __n; \
reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \
the_env->stack_top -= __n; }
#define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \
cl_index __n = narg; \
SETUP_ENV(the_env); \
frame.stack = the_env->stack; \
frame.base = the_env->stack_top - (frame.size = __n); \
reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \
the_env->stack_top -= __n; }
/* -------------------- THE INTERPRETER -------------------- */
cl_object
ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offset)
{
ECL_OFFSET_TABLE
const cl_env_ptr the_env = ecl_process_env();
ECL_OFFSET_TABLE;
const cl_env_ptr the_env = frame->frame.env;
volatile cl_index old_bds_top_index = the_env->bds_top - the_env->bds_org;
cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code + offset;
cl_object *data = bytecodes->bytecodes.data;
@ -534,7 +524,8 @@ 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.stack = frame_aux.base = 0;
frame_aux.size = 0;
frame_aux.env = the_env;
reg0 = Cnil;
the_env->nvalues = 0;
@ -729,8 +720,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
DO_CALL: {
cl_object x = reg0;
cl_object frame = (cl_object)&frame_aux;
frame_aux.top = the_env->stack_top;
frame_aux.bottom = the_env->stack_top - narg;
frame_aux.size = narg;
frame_aux.base = the_env->stack_top - narg;
AGAIN:
if (reg0 == OBJNULL || reg0 == Cnil) {
FEundefined_function(x);
@ -740,14 +731,14 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
if (narg != (cl_index)reg0->cfunfixed.narg)
FEwrong_num_arguments(reg0);
reg0 = APPLY_fixed(narg, reg0->cfunfixed.entry_fixed,
frame_aux.bottom);
frame_aux.base);
break;
case t_cfun:
reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.bottom);
reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.base);
break;
case t_cclosure:
the_env->function = reg0;
reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.bottom);
reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.base);
break;
#ifdef CLOS
case t_instance:
@ -801,8 +792,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
CASE(OP_ENTRY); {
if (frame == Cnil)
ecl_internal_error("Not enough arguments to bytecodes.");
lex_env = lambda_bind(lex_env, frame->frame.top - frame->frame.bottom,
bytecodes, frame->frame.bottom);
lex_env = lambda_bind(frame, lex_env, bytecodes);
THREAD_NEXT;
}
/* OP_EXIT

2
src/c/mapfun.d
View file

@ -25,7 +25,7 @@
cdrs_frame = ecl_stack_frame_from_va_list(ecl_process_env(),\
(cl_object)&cdrs_frame_aux, list); \
cars_frame = ecl_stack_frame_copy((cl_object)&cars_frame_aux, cdrs_frame); \
nargs = ECL_STACK_FRAME_SIZE(cars_frame); \
nargs = cars_frame->frame.size; \
if (nargs == 0) { \
FEprogram_error("MAP*: Too few arguments", 0); \
}

4
src/c/print.d
View file

@ -1570,9 +1570,9 @@ si_write_ugly_object(cl_object x, cl_object stream)
case t_frame:
if (ecl_print_readably()) FEprint_not_readable(x);
write_str("#<frame ", stream);
write_decimal(x->frame.top - x->frame.bottom, stream);
write_decimal(x->frame.size, stream);
write_ch(' ', stream);
write_addr((void*)x->frame.bottom, stream);
write_addr((void*)x->frame.base, stream);
write_ch('>', stream);
break;
#ifdef ECL_THREADS

4
src/configure vendored
View file

@ -8323,6 +8323,10 @@ case "${host_cpu}" in
_ACEOF
fi
cat >>confdefs.h <<\_ACEOF
#define ECL_USE_VARARG_AS_POINTER 1
_ACEOF
dynamic_ffi=yes
;;
x86_64 )

1
src/h/external.h
View file

@ -471,7 +471,6 @@ extern ECL_API cl_object ecl_stack_frame_elt(cl_object f, cl_index n);
extern ECL_API void ecl_stack_frame_elt_set(cl_object f, cl_index n, cl_object o);
extern ECL_API cl_object ecl_stack_frame_copy(cl_object f, cl_object size);
extern ECL_API void ecl_stack_frame_close(cl_object f);
#define ECL_STACK_FRAME_SIZE(f) ((f)->frame.top - (f)->frame.bottom)
#define si_apply_from_stack_frame ecl_apply_from_stack_frame
extern ECL_API void ecl_stack_push(cl_env_ptr env, cl_object o);

11
src/h/internal.h
View file

@ -106,12 +106,13 @@ typedef struct cl_compiler_env *cl_compiler_env_ptr;
frame->frame.t = t_frame; \
frame->frame.stack = 0; \
frame->frame.env = env; \
frame->frame.size = narg; \
if (narg < C_ARGUMENTS_LIMIT) { \
va_list args; \
va_start(args, lastarg); \
frame->frame.top = (frame->frame.bottom = (void*)args) + narg; \
frame->frame.base = (void*)args; \
} else { \
frame->frame.bottom = (frame->frame.top = env->stack_top) - narg; \
frame->frame.base = env->stack_top - narg; \
}
#define ECL_STACK_FRAME_VARARGS_END(frame) \
/* No stack consumed, no need to close frame */
@ -122,19 +123,19 @@ typedef struct cl_compiler_env *cl_compiler_env_ptr;
const cl_env_ptr env = ecl_process_env(); \
frame->frame.t = t_frame; \
frame->frame.env = env; \
frame->frame.size = narg; \
if (narg < C_ARGUMENTS_LIMIT) { \
cl_index i; \
cl_object *p = frame->frame.bottom = env->values; \
cl_object *p = frame->frame.base = 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.base = env->stack_top - narg; \
frame->frame.stack = 0; \
}
#define ECL_STACK_FRAME_VARARGS_END(frame) \

4
src/h/object.h
View file

@ -741,9 +741,9 @@ struct ecl_foreign { /* user defined datatype */
struct ecl_stack_frame {
HEADER;
cl_object *bottom; /* Bottom part */
cl_object *top; /* Top part */
cl_object *stack; /* Is this relative to the lisp stack? */
cl_object *base; /* Start of frame */
cl_index size; /* Number of arguments */
struct cl_env_struct *env;
};