mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 07:30:55 -08:00
Modify call frames to keep pointers and let cl_funcall() share frames among calls
This commit is contained in:
jgarcia
parent
60485cbbe3
commit
bd09f93e3c
14 changed files with 252 additions and 187 deletions
82
src/c/eval.d
82
src/c/eval.d
|
|
@ -19,6 +19,28 @@
|
|||
#include <ecl/ecl.h>
|
||||
#include <ecl/ecl-inl.h>
|
||||
|
||||
static cl_object
|
||||
build_funcall_frame(cl_va_list args)
|
||||
{
|
||||
cl_object f = (cl_object)&(cl_env.funcall_frame);
|
||||
cl_index n = args[0].narg;
|
||||
cl_object *p = args[0].sp;
|
||||
if (!p) {
|
||||
#ifdef ECL_USE_VARARG_AS_POINTER
|
||||
p = (cl_object*)(args[0].args);
|
||||
#else
|
||||
cl_index i;
|
||||
p = cl_env.values;
|
||||
for (i = 0; i < n; i++) {
|
||||
p[i] = va_arg(args[0].args, cl_object);
|
||||
}
|
||||
#endif
|
||||
}
|
||||
f->frame.bottom = p;
|
||||
f->frame.top = p + n;
|
||||
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
|
||||
|
|
@ -31,8 +53,8 @@
|
|||
cl_object
|
||||
ecl_apply_from_stack_frame(cl_object frame, cl_object x)
|
||||
{
|
||||
cl_index narg = frame->frame.narg;
|
||||
cl_object *sp = frame->frame.sp + cl_env.stack;
|
||||
cl_object *sp = frame->frame.bottom;
|
||||
cl_index narg = frame->frame.top - sp;
|
||||
cl_object fun = x;
|
||||
AGAIN:
|
||||
if (fun == OBJNULL || fun == Cnil)
|
||||
|
|
@ -87,13 +109,6 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v
|
|||
|
||||
if (fun == OBJNULL)
|
||||
FEerror("Undefined function.", 0);
|
||||
frame = (cl_object)&frame_aux;
|
||||
frame->frame.t = t_frame;
|
||||
frame->frame.narg = narg;
|
||||
if (args[0].sp)
|
||||
frame->frame.sp = args[0].sp;
|
||||
else
|
||||
frame->frame.sp = cl_stack_push_va_list(args);
|
||||
AGAIN:
|
||||
if (fun == OBJNULL)
|
||||
goto ERROR;
|
||||
|
|
@ -102,8 +117,9 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v
|
|||
if (fun->cfun.narg >= 0) {
|
||||
if (narg != fun->cfun.narg)
|
||||
FEwrong_num_arguments(fun);
|
||||
frame = build_funcall_frame(args);
|
||||
out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry,
|
||||
cl_env.stack + frame->frame.sp);
|
||||
frame->frame.bottom);
|
||||
} else {
|
||||
if (pLK) {
|
||||
si_put_sysprop(sym, @'si::link-from',
|
||||
|
|
@ -114,13 +130,15 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v
|
|||
cblock->cblock.links =
|
||||
CONS(sym, cblock->cblock.links);
|
||||
}
|
||||
out = APPLY(narg, fun->cfun.entry, cl_env.stack + frame->frame.sp);
|
||||
frame = build_funcall_frame(args);
|
||||
out = APPLY(narg, fun->cfun.entry, frame->frame.bottom);
|
||||
}
|
||||
break;
|
||||
#ifdef CLOS
|
||||
case t_instance:
|
||||
switch (fun->instance.isgf) {
|
||||
case ECL_STANDARD_DISPATCH:
|
||||
frame = build_funcall_frame(args);
|
||||
out = _ecl_standard_dispatch(frame, fun);
|
||||
break;
|
||||
case ECL_USER_DISPATCH:
|
||||
|
|
@ -132,18 +150,18 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v
|
|||
break;
|
||||
#endif /* CLOS */
|
||||
case t_cclosure:
|
||||
frame = build_funcall_frame(args);
|
||||
out = APPLY_closure(narg, fun->cclosure.entry,
|
||||
fun->cclosure.env, cl_env.stack + frame->frame.sp);
|
||||
fun->cclosure.env, frame->frame.bottom);
|
||||
break;
|
||||
case t_bytecodes:
|
||||
frame = build_funcall_frame(args);
|
||||
out = ecl_apply_lambda(frame, fun);
|
||||
break;
|
||||
default:
|
||||
ERROR:
|
||||
FEinvalid_function(fun);
|
||||
}
|
||||
if (!args[0].sp)
|
||||
ecl_stack_frame_close(frame);
|
||||
return out;
|
||||
}
|
||||
|
||||
|
|
@ -168,25 +186,8 @@ si_unlink_symbol(cl_object s)
|
|||
}
|
||||
|
||||
@(defun funcall (function &rest funargs)
|
||||
struct ecl_stack_frame frame_aux;
|
||||
cl_object frame;
|
||||
cl_object out;
|
||||
@
|
||||
frame = (cl_object)&frame_aux;
|
||||
frame->frame.t = t_frame;
|
||||
frame->frame.narg = narg-1;
|
||||
if (funargs[0].sp)
|
||||
frame->frame.sp = funargs[0].sp;
|
||||
else
|
||||
frame->frame.sp = cl_stack_push_va_list(funargs);
|
||||
out = ecl_apply_from_stack_frame(frame, function);
|
||||
if (!funargs[0].sp) {
|
||||
/* Closing a frame implies popping out all arguments.
|
||||
* If the arguments had been previously pushed, we must
|
||||
* avoid this and leave that task to the caller */
|
||||
ecl_stack_frame_close(frame);
|
||||
}
|
||||
return out;
|
||||
return ecl_apply_from_stack_frame(build_funcall_frame(funargs), function);
|
||||
@)
|
||||
|
||||
@(defun apply (fun lastarg &rest args)
|
||||
|
|
@ -197,20 +198,17 @@ si_unlink_symbol(cl_object s)
|
|||
cl_object out;
|
||||
cl_index i;
|
||||
struct ecl_stack_frame frame_aux;
|
||||
const cl_object frame = (cl_object)&frame_aux;
|
||||
frame->frame.t = t_frame;
|
||||
frame->frame.narg = frame->frame.sp = 0;
|
||||
narg -= 2;
|
||||
for (i = 0; narg; i++,narg--) {
|
||||
ecl_stack_frame_push(frame, lastarg);
|
||||
const cl_object frame = ecl_stack_frame_open((cl_object)&frame_aux,
|
||||
narg -= 2);
|
||||
for (i = 0; i < narg; i++) {
|
||||
ecl_stack_frame_elt_set(frame, i, lastarg);
|
||||
lastarg = cl_va_arg(args);
|
||||
}
|
||||
if (type_of(lastarg) == t_frame) {
|
||||
ecl_stack_frame_reserve(frame, lastarg->frame.narg);
|
||||
/* This could be replaced with a memcpy() */
|
||||
for (i = 0; i < lastarg->frame.narg; i++) {
|
||||
cl_object o = ecl_stack_frame_elt(lastarg, i);
|
||||
ecl_stack_frame_elt_set(frame, i, o);
|
||||
cl_object *p = lastarg->frame.bottom;
|
||||
while (p != lastarg->frame.top) {
|
||||
ecl_stack_frame_push(frame, *(p++));
|
||||
}
|
||||
} else loop_for_in (lastarg) {
|
||||
if (i >= CALL_ARGUMENTS_LIMIT) {
|
||||
|
|
|
|||
36
src/c/gfun.d
36
src/c/gfun.d
|
|
@ -283,8 +283,8 @@ search_method_hash(cl_object keys, cl_object table)
|
|||
static cl_object
|
||||
get_spec_vector(cl_object frame, cl_object gf)
|
||||
{
|
||||
cl_object *args = cl_env.stack + frame->frame.sp;
|
||||
cl_index narg = frame->frame.narg;
|
||||
cl_object *args = frame->frame.bottom;
|
||||
cl_index narg = frame->frame.top - args;
|
||||
cl_object spec_how_list = GFUN_SPEC(gf);
|
||||
cl_object vector = cl_env.method_spec_vector;
|
||||
cl_object *argtype = vector->vector.self.t;
|
||||
|
|
@ -313,14 +313,14 @@ compute_applicable_method(cl_object frame, cl_object gf)
|
|||
{
|
||||
/* method not cached */
|
||||
cl_object methods, arglist, func;
|
||||
int i;
|
||||
for (i = frame->frame.narg, arglist = Cnil; i; ) {
|
||||
arglist = CONS(ecl_stack_frame_elt(frame, --i), arglist);
|
||||
cl_object *p;
|
||||
for (p = frame->frame.top, arglist = Cnil; p != frame->frame.bottom; ) {
|
||||
arglist = CONS(*(--p), arglist);
|
||||
}
|
||||
methods = funcall(3, @'compute-applicable-methods', gf, arglist);
|
||||
if (methods == Cnil) {
|
||||
func = funcall(3, @'no-applicable-method', gf, arglist);
|
||||
ecl_stack_frame_elt_set(frame, 0, OBJNULL);
|
||||
frame->frame.bottom[0] = OBJNULL;
|
||||
return func;
|
||||
} else {
|
||||
return funcall(4, @'clos::compute-effective-method', gf,
|
||||
|
|
@ -332,6 +332,15 @@ cl_object
|
|||
_ecl_standard_dispatch(cl_object frame, cl_object gf)
|
||||
{
|
||||
cl_object func, vector;
|
||||
/*
|
||||
* We have to copy the frame because it might be cl_env.funcal_frame,
|
||||
* which will be wiped out by the next function call.
|
||||
*/
|
||||
struct ecl_stack_frame frame_aux;
|
||||
if (frame == (cl_object)&cl_env.funcall_frame) {
|
||||
frame = ecl_stack_frame_copy((cl_object)&frame_aux, frame);
|
||||
}
|
||||
|
||||
#ifdef ECL_THREADS
|
||||
/* See whether we have to clear the hash from some generic functions right now. */
|
||||
if (cl_env.method_hash_clear_list != Cnil) {
|
||||
|
|
@ -366,11 +375,18 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
|
|||
}
|
||||
}
|
||||
{
|
||||
ECL_BUILD_STACK_FRAME(frame1, aux);
|
||||
ecl_stack_frame_push(frame1, frame);
|
||||
ecl_stack_frame_push(frame1, Cnil);
|
||||
/* Stack allocated frame */
|
||||
cl_object frame1 = (cl_object)&(cl_env.funcall_frame);
|
||||
frame1->frame.bottom = cl_env.values;
|
||||
frame1->frame.top = frame1->frame.bottom + 2;
|
||||
frame1->frame.bottom[0] = frame;
|
||||
frame1->frame.bottom[1] = Cnil;
|
||||
|
||||
func = ecl_apply_from_stack_frame(frame1, func);
|
||||
ecl_stack_frame_close(frame1);
|
||||
|
||||
/* Only need to close the copy */
|
||||
if (frame == (cl_object)&frame_aux)
|
||||
ecl_stack_frame_close(frame);
|
||||
return func;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
*/
|
||||
|
||||
#include <ecl/ecl.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
#include <ecl/ecl-inl.h>
|
||||
|
|
@ -94,17 +95,6 @@ cl_stack_set_index(cl_index index) {
|
|||
cl_env.stack_top = new_top;
|
||||
}
|
||||
|
||||
void
|
||||
cl_stack_insert(cl_index where, cl_index n) {
|
||||
if (cl_env.stack_top + n > cl_env.stack_limit) {
|
||||
cl_index delta = (n + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
|
||||
cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE);
|
||||
}
|
||||
cl_env.stack_top += n;
|
||||
memmove(&cl_env.stack[where+n], &cl_env.stack[where],
|
||||
(cl_env.stack_top - cl_env.stack) * sizeof(cl_object));
|
||||
}
|
||||
|
||||
void
|
||||
cl_stack_pop_n(cl_index index) {
|
||||
cl_object *new_top = cl_env.stack_top - index;
|
||||
|
|
@ -128,19 +118,6 @@ cl_stack_pop_values(cl_index n) {
|
|||
VALUES(--n) = cl_stack_pop();
|
||||
}
|
||||
|
||||
cl_index
|
||||
cl_stack_push_va_list(cl_va_list args) {
|
||||
cl_index sp;
|
||||
|
||||
sp = cl_env.stack_top - cl_env.stack;
|
||||
while (cl_env.stack_top + args[0].narg > cl_env.stack_limit)
|
||||
cl_stack_grow();
|
||||
while (args[0].narg > 0) {
|
||||
*(cl_env.stack_top++) = cl_va_arg(args);
|
||||
}
|
||||
return sp;
|
||||
}
|
||||
|
||||
cl_index
|
||||
cl_stack_push_list(cl_object list)
|
||||
{
|
||||
|
|
@ -164,90 +141,137 @@ cl_stack_push_list(cl_object list)
|
|||
return n;
|
||||
}
|
||||
|
||||
void
|
||||
ecl_stack_frame_reserve(cl_object f, cl_index size)
|
||||
cl_object
|
||||
ecl_stack_frame_open(cl_object f, cl_index size)
|
||||
{
|
||||
cl_index sp = cl_stack_index();
|
||||
cl_index n = f->frame.narg;
|
||||
if (n == 0) {
|
||||
f->frame.sp = sp;
|
||||
} else if (sp != f->frame.sp + n) {
|
||||
cl_object *top = cl_env.stack_top;
|
||||
if (size) {
|
||||
if (cl_env.stack_limit - top < size) {
|
||||
cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
|
||||
cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE);
|
||||
top = cl_env.stack_top;
|
||||
}
|
||||
}
|
||||
f->frame.t = t_frame;
|
||||
f->frame.stack = cl_env.stack;
|
||||
f->frame.bottom = top;
|
||||
cl_env.stack_top = f->frame.top = (top + size);
|
||||
return f;
|
||||
}
|
||||
|
||||
void
|
||||
ecl_stack_frame_enlarge(cl_object f, cl_index size)
|
||||
{
|
||||
cl_object *top;
|
||||
if (f->frame.stack == 0) {
|
||||
ecl_internal_error("Inconsistency in interpreter stack frame");
|
||||
}
|
||||
f->frame.narg = n+size;
|
||||
cl_stack_insert(sp, size);
|
||||
top = cl_env.stack_top;
|
||||
if ((cl_env.stack_limit - top) < size) {
|
||||
cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
|
||||
cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE);
|
||||
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
|
||||
f->frame.stack = cl_env.stack;
|
||||
top = cl_env.stack_top;
|
||||
} else if (top != f->frame.top) {
|
||||
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
|
||||
f->frame.stack = cl_env.stack;
|
||||
top = cl_env.stack_top;
|
||||
}
|
||||
cl_env.stack_top = f->frame.top = (top + size);
|
||||
}
|
||||
|
||||
void
|
||||
ecl_stack_frame_push(cl_object f, cl_object o)
|
||||
{
|
||||
cl_index sp = cl_stack_index();
|
||||
cl_index n = f->frame.narg;
|
||||
if (n == 0) {
|
||||
f->frame.sp = sp;
|
||||
} else if (sp != f->frame.sp + n) {
|
||||
cl_object *top;
|
||||
if (f->frame.stack == 0) {
|
||||
ecl_internal_error("Inconsistency in interpreter stack frame");
|
||||
}
|
||||
f->frame.narg = n+1;
|
||||
cl_stack_push(o);
|
||||
top = cl_env.stack_top;
|
||||
if (top >= cl_env.stack_limit) {
|
||||
cl_stack_grow();
|
||||
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
|
||||
f->frame.stack = cl_env.stack;
|
||||
top = cl_env.stack_top;
|
||||
} else if (top != f->frame.top) {
|
||||
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
|
||||
f->frame.stack = cl_env.stack;
|
||||
top = cl_env.stack_top;
|
||||
}
|
||||
*(top++) = o;
|
||||
cl_env.stack_top = f->frame.top = top;
|
||||
}
|
||||
|
||||
void
|
||||
ecl_stack_frame_push_values(cl_object f)
|
||||
{
|
||||
cl_index sp = cl_stack_index();
|
||||
cl_index n = f->frame.narg;
|
||||
if (n == 0) {
|
||||
f->frame.sp = sp;
|
||||
} else if (sp != f->frame.sp + n) {
|
||||
if (f->frame.stack == 0) {
|
||||
ecl_internal_error("Inconsistency in interpreter stack frame");
|
||||
}
|
||||
f->frame.narg = n+cl_stack_push_values();
|
||||
}
|
||||
|
||||
void
|
||||
ecl_stack_frame_push_va_list(cl_object f, cl_va_list args)
|
||||
{
|
||||
cl_index sp = cl_stack_index();
|
||||
cl_index n = f->frame.narg;
|
||||
if (n == 0) {
|
||||
f->frame.sp = sp;
|
||||
} else if (sp != f->frame.sp + n) {
|
||||
ecl_internal_error("Inconsistency in interpreter stack frame");
|
||||
}
|
||||
f->frame.narg = n + args[0].narg;
|
||||
cl_stack_push_va_list(args);
|
||||
cl_stack_push_values();
|
||||
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
|
||||
f->frame.stack = cl_env.stack;
|
||||
f->frame.top = cl_env.stack_top;
|
||||
}
|
||||
|
||||
cl_object
|
||||
ecl_stack_frame_pop_values(cl_object f)
|
||||
{
|
||||
cl_stack_pop_values(f->frame.narg);
|
||||
cl_index n = f->frame.top - f->frame.bottom;
|
||||
NVALUES = n;
|
||||
VALUES(0) = Cnil;
|
||||
while (n--) {
|
||||
VALUES(n) = f->frame.bottom[n];
|
||||
}
|
||||
return VALUES(0);
|
||||
}
|
||||
|
||||
cl_object
|
||||
ecl_stack_frame_elt(cl_object f, cl_index ndx)
|
||||
{
|
||||
if (ndx >= f->frame.narg) {
|
||||
if (ndx >= (f->frame.top - f->frame.bottom)) {
|
||||
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
|
||||
}
|
||||
return cl_env.stack[f->frame.sp + ndx];
|
||||
return f->frame.bottom[ndx];
|
||||
}
|
||||
|
||||
void
|
||||
ecl_stack_frame_elt_set(cl_object f, cl_index ndx, cl_object o)
|
||||
{
|
||||
if (ndx >= f->frame.narg) {
|
||||
if (ndx >= (f->frame.top - f->frame.bottom)) {
|
||||
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
|
||||
}
|
||||
cl_env.stack[f->frame.sp + ndx] = o;
|
||||
f->frame.bottom[ndx] = o;
|
||||
}
|
||||
|
||||
cl_object
|
||||
ecl_stack_frame_from_va_list(cl_object frame, cl_va_list args)
|
||||
{
|
||||
cl_index nargs = args[0].narg;
|
||||
ecl_stack_frame_open(frame, nargs);
|
||||
while (nargs) {
|
||||
*(frame->frame.top-nargs) = cl_va_arg(args);
|
||||
nargs--;
|
||||
}
|
||||
return frame;
|
||||
}
|
||||
|
||||
void
|
||||
ecl_stack_frame_close(cl_object f)
|
||||
{
|
||||
if (f->frame.narg) cl_stack_set_index(f->frame.sp);
|
||||
if (f->frame.stack) {
|
||||
cl_stack_set_index(f->frame.bottom - f->frame.stack);
|
||||
}
|
||||
}
|
||||
|
||||
cl_object
|
||||
ecl_stack_frame_copy(cl_object dest, cl_object orig)
|
||||
{
|
||||
cl_index size = orig->frame.top - orig->frame.bottom;
|
||||
dest = ecl_stack_frame_open(dest, size);
|
||||
memcpy(dest->frame.bottom, orig->frame.bottom, size * sizeof(cl_object));
|
||||
return dest;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -288,7 +312,7 @@ lambda_bind_var(cl_object var, cl_object val, cl_object specials)
|
|||
}
|
||||
|
||||
static void
|
||||
lambda_bind(cl_narg narg, cl_object lambda, cl_index sp)
|
||||
lambda_bind(cl_narg narg, cl_object lambda, cl_object *sp)
|
||||
{
|
||||
cl_object *data = lambda->bytecodes.data;
|
||||
cl_object specials = lambda->bytecodes.specials;
|
||||
|
|
@ -300,12 +324,12 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_index sp)
|
|||
if (narg < n)
|
||||
FEwrong_num_arguments(lambda->bytecodes.name);
|
||||
for (; n; n--, narg--)
|
||||
lambda_bind_var(*(data++), cl_env.stack[sp++], specials);
|
||||
lambda_bind_var(*(data++), *(sp++), specials);
|
||||
|
||||
/* 2) OPTIONAL ARGUMENTS: N var1 value1 flag1 ... varN valueN flagN */
|
||||
for (n = fix(*(data++)); n; n--, data+=3) {
|
||||
if (narg) {
|
||||
lambda_bind_var(data[0], cl_env.stack[sp], specials);
|
||||
lambda_bind_var(data[0], *sp, specials);
|
||||
sp++; narg--;
|
||||
if (!Null(data[2]))
|
||||
lambda_bind_var(data[2], Ct, specials);
|
||||
|
|
@ -326,7 +350,7 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_index sp)
|
|||
cl_object rest = Cnil;
|
||||
check_remaining = FALSE;
|
||||
for (i=narg; i; )
|
||||
rest = CONS(cl_env.stack[sp+(--i)], rest);
|
||||
rest = CONS(sp[--i], rest);
|
||||
lambda_bind_var(data[0], rest, specials);
|
||||
}
|
||||
data++;
|
||||
|
|
@ -366,8 +390,8 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_index sp)
|
|||
spp[i] = unbound;
|
||||
#endif
|
||||
for (; narg; narg-=2) {
|
||||
cl_object key = cl_env.stack[sp++];
|
||||
cl_object value = cl_env.stack[sp++];
|
||||
cl_object key = *(sp++);
|
||||
cl_object value = *(sp++);
|
||||
if (!SYMBOLP(key))
|
||||
FEprogram_error("LAMBDA: Keyword expected, got ~S.", 1, key);
|
||||
keys = data;
|
||||
|
|
@ -425,7 +449,7 @@ ecl_apply_lambda(cl_object frame, cl_object fun)
|
|||
old_bds_top = cl_env.bds_top;
|
||||
|
||||
/* Establish bindings */
|
||||
lambda_bind(frame->frame.narg, fun, frame->frame.sp);
|
||||
lambda_bind(frame->frame.top - frame->frame.bottom, fun, frame->frame.bottom);
|
||||
|
||||
VALUES(0) = Cnil;
|
||||
NVALUES = 0;
|
||||
|
|
@ -459,13 +483,13 @@ interpret_funcall(cl_narg narg, cl_object fun)
|
|||
{
|
||||
cl_object lex_env = cl_env.lex_env;
|
||||
struct ecl_stack_frame frame_aux;
|
||||
cl_object frame = (cl_object)&frame_aux;
|
||||
frame->frame.t = t_frame;
|
||||
frame->frame.narg = narg;
|
||||
frame->frame.sp = (cl_env.stack_top - cl_env.stack) - narg;
|
||||
fun = ecl_apply_from_stack_frame(frame, fun);
|
||||
frame_aux.t = t_frame;
|
||||
frame_aux.stack = cl_env.stack;
|
||||
frame_aux.top = cl_env.stack_top;
|
||||
frame_aux.bottom = frame_aux.top - narg;
|
||||
fun = ecl_apply_from_stack_frame((cl_object)&frame_aux, fun);
|
||||
ecl_stack_frame_close((cl_object)&frame_aux);
|
||||
cl_env.lex_env = lex_env;
|
||||
ecl_stack_frame_close(frame);
|
||||
return fun;
|
||||
}
|
||||
|
||||
|
|
|
|||
18
src/c/list.d
18
src/c/list.d
|
|
@ -28,6 +28,7 @@ struct cl_test {
|
|||
struct ecl_stack_frame frame_key_aux;
|
||||
cl_object frame_test;
|
||||
struct ecl_stack_frame frame_test_aux;
|
||||
cl_object frame_args[3];
|
||||
};
|
||||
|
||||
static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree);
|
||||
|
|
@ -129,28 +130,31 @@ setup_test(struct cl_test *t, cl_object item, cl_object test,
|
|||
if (t->test_function != Cnil) {
|
||||
t->frame_test = (cl_object)&(t->frame_test_aux);
|
||||
t->frame_test_aux.t = t_frame;
|
||||
t->frame_test_aux.narg = 0;
|
||||
t->frame_test_aux.sp = 0;
|
||||
ecl_stack_frame_reserve(t->frame_test, 2);
|
||||
ecl_stack_frame_elt_set(t->frame_test, 0, item);
|
||||
t->frame_test_aux.bottom = t->frame_args;
|
||||
t->frame_test_aux.top = t->frame_args + 2;
|
||||
t->frame_test_aux.stack = 0;
|
||||
}
|
||||
if (t->key_function != Cnil) {
|
||||
t->frame_key = (cl_object)&(t->frame_key_aux);
|
||||
t->frame_key_aux.t = t_frame;
|
||||
t->frame_key_aux.narg = 0;
|
||||
t->frame_key_aux.sp = 0;
|
||||
ecl_stack_frame_reserve(t->frame_key, 1);
|
||||
t->frame_key_aux.bottom = t->frame_args;
|
||||
t->frame_key_aux.top = t->frame_args + 1;
|
||||
t->frame_key_aux.stack = 0;
|
||||
}
|
||||
}
|
||||
|
||||
static void close_test(struct cl_test *t)
|
||||
{
|
||||
/* No need to call ecl_stack_frame_close since this frame is not allocated
|
||||
* in the lisp stack. */
|
||||
/*
|
||||
if (t->key_function != Cnil) {
|
||||
ecl_stack_frame_close(t->frame_key);
|
||||
}
|
||||
if (t->test_function != Cnil) {
|
||||
ecl_stack_frame_close(t->frame_test);
|
||||
}
|
||||
*/
|
||||
}
|
||||
|
||||
cl_object
|
||||
|
|
|
|||
|
|
@ -73,6 +73,11 @@ ecl_init_env(struct cl_env_struct *env)
|
|||
env->stack_size = 0;
|
||||
cl_stack_set_size(16*LISP_PAGESIZE);
|
||||
|
||||
env->funcall_frame.t = t_frame;
|
||||
env->funcall_frame.stack = 0;
|
||||
env->funcall_frame.bottom =
|
||||
env->funcall_frame.top = env->funcall_frame_bottom;
|
||||
|
||||
#if !defined(ECL_CMU_FORMAT)
|
||||
env->print_pretty = FALSE;
|
||||
env->queue = cl_alloc_atomic(ECL_PPRINT_QUEUE_SIZE * sizeof(short));
|
||||
|
|
|
|||
|
|
@ -18,31 +18,27 @@
|
|||
#include <ecl/ecl.h>
|
||||
#include <ecl/internal.h>
|
||||
|
||||
static void
|
||||
prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame)
|
||||
{
|
||||
cl_index i;
|
||||
ecl_stack_frame_push_va_list(cdrs_frame, lists);
|
||||
if (cdrs_frame->frame.narg == 0) {
|
||||
FEprogram_error("MAP*: Too few arguments.", 0);
|
||||
#define PREPARE_MAP(list, cdrs_frame, cars_frame, nargs) \
|
||||
struct ecl_stack_frame cdrs_frame_aux, cars_frame_aux; \
|
||||
cl_object cdrs_frame, cars_frame; \
|
||||
cl_index nargs; \
|
||||
cdrs_frame = ecl_stack_frame_from_va_list((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); \
|
||||
if (nargs == 0) { \
|
||||
FEprogram_error("MAP*: Too few arguments", 0); \
|
||||
}
|
||||
ecl_stack_frame_reserve(cars_frame, cdrs_frame->frame.narg);
|
||||
for (i = 0; i < cars_frame->frame.narg; i++) {
|
||||
ecl_stack_frame_elt_set(cars_frame, i, Cnil);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@(defun mapcar (fun &rest lists)
|
||||
cl_object res, *val = &res;
|
||||
cl_index i;
|
||||
@ {
|
||||
ECL_BUILD_STACK_FRAME(cars_frame,frame1);
|
||||
ECL_BUILD_STACK_FRAME(cdrs_frame,frame2);
|
||||
prepare_map(lists, cdrs_frame, cars_frame);
|
||||
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
|
||||
res = Cnil;
|
||||
while (TRUE) {
|
||||
cl_index i;
|
||||
for (i = 0; i < cdrs_frame->frame.narg; i++) {
|
||||
for (i = 0; i < nargs; i++) {
|
||||
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
|
||||
if (ecl_endp(cdr)) {
|
||||
ecl_stack_frame_close(cars_frame);
|
||||
|
|
@ -60,13 +56,11 @@ prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame)
|
|||
@(defun maplist (fun &rest lists)
|
||||
cl_object res, *val = &res;
|
||||
@ {
|
||||
ECL_BUILD_STACK_FRAME(cars_frame,frame1);
|
||||
ECL_BUILD_STACK_FRAME(cdrs_frame,frame2);
|
||||
prepare_map(lists, cdrs_frame, cars_frame);
|
||||
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
|
||||
res = Cnil;
|
||||
while (TRUE) {
|
||||
cl_index i;
|
||||
for (i = 0; i < cdrs_frame->frame.narg; i++) {
|
||||
for (i = 0; i < nargs; i++) {
|
||||
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
|
||||
if (ecl_endp(cdr)) {
|
||||
ecl_stack_frame_close(cars_frame);
|
||||
|
|
@ -84,13 +78,11 @@ prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame)
|
|||
@(defun mapc (fun &rest lists)
|
||||
cl_object onelist;
|
||||
@ {
|
||||
ECL_BUILD_STACK_FRAME(cars_frame,frame1);
|
||||
ECL_BUILD_STACK_FRAME(cdrs_frame,frame2);
|
||||
prepare_map(lists, cdrs_frame, cars_frame);
|
||||
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
|
||||
onelist = ecl_stack_frame_elt(cdrs_frame, 0);
|
||||
while (TRUE) {
|
||||
cl_index i;
|
||||
for (i = 0; i < cdrs_frame->frame.narg; i++) {
|
||||
for (i = 0; i < nargs; i++) {
|
||||
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
|
||||
if (ecl_endp(cdr)) {
|
||||
ecl_stack_frame_close(cars_frame);
|
||||
|
|
@ -107,13 +99,11 @@ prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame)
|
|||
@(defun mapl (fun &rest lists)
|
||||
cl_object onelist;
|
||||
@ {
|
||||
ECL_BUILD_STACK_FRAME(cars_frame,frame1);
|
||||
ECL_BUILD_STACK_FRAME(cdrs_frame,frame2);
|
||||
prepare_map(lists, cdrs_frame, cars_frame);
|
||||
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
|
||||
onelist = ecl_stack_frame_elt(cdrs_frame, 0);
|
||||
while (TRUE) {
|
||||
cl_index i;
|
||||
for (i = 0; i < cdrs_frame->frame.narg; i++) {
|
||||
for (i = 0; i < nargs; i++) {
|
||||
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
|
||||
if (ecl_endp(cdr)) {
|
||||
ecl_stack_frame_close(cars_frame);
|
||||
|
|
@ -130,13 +120,11 @@ prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame)
|
|||
@(defun mapcan (fun &rest lists)
|
||||
cl_object res, *val = &res;
|
||||
@ {
|
||||
ECL_BUILD_STACK_FRAME(cars_frame,frame1);
|
||||
ECL_BUILD_STACK_FRAME(cdrs_frame,frame2);
|
||||
prepare_map(lists, cdrs_frame, cars_frame);
|
||||
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
|
||||
res = Cnil;
|
||||
while (TRUE) {
|
||||
cl_index i;
|
||||
for (i = 0; i < cdrs_frame->frame.narg; i++) {
|
||||
for (i = 0; i < nargs; i++) {
|
||||
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
|
||||
if (ecl_endp(cdr)) {
|
||||
ecl_stack_frame_close(cars_frame);
|
||||
|
|
@ -155,13 +143,11 @@ prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame)
|
|||
@(defun mapcon (fun &rest lists)
|
||||
cl_object res, *val = &res;
|
||||
@ {
|
||||
ECL_BUILD_STACK_FRAME(cars_frame,frame1);
|
||||
ECL_BUILD_STACK_FRAME(cdrs_frame,frame2);
|
||||
prepare_map(lists, cdrs_frame, cars_frame);
|
||||
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
|
||||
res = Cnil;
|
||||
while (TRUE) {
|
||||
cl_index i;
|
||||
for (i = 0; i < cdrs_frame->frame.narg; i++) {
|
||||
for (i = 0; i < nargs; i++) {
|
||||
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
|
||||
if (ecl_endp(cdr)) {
|
||||
ecl_stack_frame_close(cars_frame);
|
||||
|
|
|
|||
|
|
@ -1541,9 +1541,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.narg, stream);
|
||||
write_decimal(x->frame.top - x->frame.bottom, stream);
|
||||
write_ch(' ', stream);
|
||||
write_decimal(x->frame.sp, stream);
|
||||
write_decimal(x->frame.bottom, stream);
|
||||
write_ch('>', stream);
|
||||
break;
|
||||
#ifdef ECL_THREADS
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
(let* ((new-destination (tmp-destination *destination*))
|
||||
(*temp* *temp*))
|
||||
(wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;")
|
||||
(wt-nl *volatile* "cl_object _ecl_inner_frame = (_ecl_inner_frame_aux.narg=0,_ecl_inner_frame_aux.sp=0,_ecl_inner_frame_aux.t=t_frame,(cl_object)&_ecl_inner_frame_aux);")
|
||||
(wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open((cl_object)&_ecl_inner_frame_aux,0);")
|
||||
(let* ((*destination* new-destination)
|
||||
(*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*)))
|
||||
(c2expr* body))
|
||||
|
|
|
|||
|
|
@ -132,7 +132,7 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey;
|
|||
/* See cmplam.lsp if you change this value */
|
||||
#define C_ARGUMENTS_LIMIT 64
|
||||
|
||||
/* Maximum number of output arguments */
|
||||
/* Maximum number of output arguments (>= C_ARGUMENTS_LIMIT) */
|
||||
#define ECL_MULTIPLE_VALUES_LIMIT 64
|
||||
|
||||
/* A setjmp that does not save signals */
|
||||
|
|
|
|||
|
|
@ -66,6 +66,12 @@ typedef unsigned short uint16_t;
|
|||
#include <ecl/unify.h>
|
||||
#endif
|
||||
|
||||
#if defined(__cplusplus) || (defined(__GNUC__) && !defined(__STRICT_ANSI__))
|
||||
#define ECL_INLINE inline
|
||||
#else
|
||||
#define ECL_INLINE
|
||||
#endif
|
||||
|
||||
typedef void (*ecl_init_function_t)(cl_object block);
|
||||
|
||||
#endif /* ECL_H */
|
||||
|
|
|
|||
|
|
@ -69,6 +69,9 @@ struct cl_env_struct {
|
|||
cl_index nvalues;
|
||||
cl_object values[ECL_MULTIPLE_VALUES_LIMIT];
|
||||
|
||||
/* Stack frame used by cl_funcall() */
|
||||
struct ecl_stack_frame funcall_frame;
|
||||
|
||||
/* Private variables used by different parts of ECL: */
|
||||
/* ... the reader ... */
|
||||
cl_object string_pool;
|
||||
|
|
@ -435,15 +438,18 @@ extern ECL_API cl_object si_eval_with_env _ARGS((cl_narg narg, cl_object form, .
|
|||
/* interpreter.c */
|
||||
|
||||
extern ECL_API cl_object si_interpreter_stack _ARGS((cl_narg narg));
|
||||
extern ECL_API void ecl_stack_frame_reserve(cl_object f, cl_index size);
|
||||
extern ECL_API cl_object ecl_stack_frame_open(cl_object f, cl_index size);
|
||||
extern ECL_API void ecl_stack_frame_enlarge(cl_object f, cl_index size);
|
||||
extern ECL_API void ecl_stack_frame_push(cl_object f, cl_object o);
|
||||
extern ECL_API void ecl_stack_frame_push_values(cl_object f);
|
||||
extern ECL_API void ecl_stack_frame_push_va_list(cl_object f, cl_va_list args);
|
||||
extern ECL_API void ecl_stack_frame_close(cl_object f);
|
||||
extern ECL_API cl_object ecl_stack_frame_from_va_list(cl_object f, cl_va_list args);
|
||||
extern ECL_API cl_object ecl_stack_frame_pop_values(cl_object f);
|
||||
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);
|
||||
extern ECL_API cl_object ecl_apply_from_stack_frame(cl_object f, cl_object o);
|
||||
#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 cl_stack_push(cl_object o);
|
||||
|
|
@ -454,7 +460,6 @@ extern ECL_API void cl_stack_set_index(cl_index sp);
|
|||
extern ECL_API void cl_stack_pop_n(cl_index n);
|
||||
extern ECL_API void cl_stack_insert(cl_index where, cl_index n);
|
||||
extern ECL_API cl_index cl_stack_push_list(cl_object list);
|
||||
extern ECL_API cl_index cl_stack_push_va_list(cl_va_list args);
|
||||
extern ECL_API void cl_stack_push_n(cl_index n, cl_object *args);
|
||||
extern ECL_API cl_index cl_stack_push_values(void);
|
||||
extern ECL_API void cl_stack_pop_values(cl_index n);
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ struct cl_compiler_env {
|
|||
|
||||
#define ECL_BUILD_STACK_FRAME(name,frame) \
|
||||
struct ecl_stack_frame frame;\
|
||||
cl_object name=(frame.t=t_frame,frame.narg=frame.sp=0,(cl_object)(&frame))
|
||||
cl_object name = ecl_stack_frame_open((cl_object)&frame, 0);
|
||||
|
||||
/* ffi.d */
|
||||
|
||||
|
|
|
|||
|
|
@ -593,8 +593,9 @@ struct ecl_foreign { /* user defined datatype */
|
|||
|
||||
struct ecl_stack_frame {
|
||||
HEADER;
|
||||
cl_index narg; /* Size */
|
||||
cl_index sp; /* Stack pointer start */
|
||||
cl_object *bottom; /* Bottom part */
|
||||
cl_object *top; /* Top part */
|
||||
cl_object *stack; /* Is this relative to the lisp stack? */
|
||||
};
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -127,8 +127,28 @@ extern ECL_API ecl_frame_ptr _frs_push(register cl_object val);
|
|||
#define frs_pop() (cl_env.frs_top--)
|
||||
|
||||
/*******************
|
||||
* C CONTROL STACK
|
||||
*******************/
|
||||
* ARGUMENTS STACK
|
||||
*******************
|
||||
* Here we define how we handle the incoming arguments for a
|
||||
* function. Our calling conventions specify that at most
|
||||
* C_ARGUMENTS_LIMIT ar pushed onto the C stack. If the function
|
||||
* receives more than this number of arguments it will keep a copy of
|
||||
* _all_ those arguments _plus_ the remaining ones in the lisp
|
||||
* stack. The caller is responsible for storing and removing such
|
||||
* values.
|
||||
*
|
||||
* Given this structure, we need our own object for handling variable
|
||||
* argument list, cl_va_list. This object joins the C data type for
|
||||
* handling vararg lists and a pointer to the lisp stack, in case the
|
||||
* arguments were passed there.
|
||||
*
|
||||
* Note that keeping a direct reference to the lisp stack effectively
|
||||
* locks it in memory, preventing the block from being garbage
|
||||
* collected if the stack grows -- at least until all references are
|
||||
* eliminated --. This is something we have to live with and which
|
||||
* is somehow unavoidable, given that function arguments have to be
|
||||
* stored somewhere.
|
||||
*/
|
||||
|
||||
#define cl_va_start(a,p,n,k) { \
|
||||
a[0].narg = (n)-(k); \
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue