diff --git a/src/c/eval.d b/src/c/eval.d index 6bfafe78a..a1957eb30 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -19,6 +19,28 @@ #include #include +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) { diff --git a/src/c/gfun.d b/src/c/gfun.d index bcb158c6a..916e609b9 100644 --- a/src/c/gfun.d +++ b/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; } } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 5ce523852..63cc490ee 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -14,6 +14,7 @@ */ #include +#include #include #include #include @@ -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; } diff --git a/src/c/list.d b/src/c/list.d index dedca3065..a16f18510 100644 --- a/src/c/list.d +++ b/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 diff --git a/src/c/main.d b/src/c/main.d index 8e22d6ad9..d2290faf1 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -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)); diff --git a/src/c/mapfun.d b/src/c/mapfun.d index bf65ee988..86415e2d1 100644 --- a/src/c/mapfun.d +++ b/src/c/mapfun.d @@ -18,31 +18,27 @@ #include #include -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); diff --git a/src/c/print.d b/src/c/print.d index bfb369e40..12eda67ef 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -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.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 diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index 6863d36ad..a42ac904d 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -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)) diff --git a/src/h/config.h.in b/src/h/config.h.in index 8fe5d75c1..c8789fee6 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -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 */ diff --git a/src/h/ecl.h b/src/h/ecl.h index 2a1d144de..70ab172d8 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -66,6 +66,12 @@ typedef unsigned short uint16_t; #include #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 */ diff --git a/src/h/external.h b/src/h/external.h index 3fa890a33..343077a94 100644 --- a/src/h/external.h +++ b/src/h/external.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); diff --git a/src/h/internal.h b/src/h/internal.h index 49c042dcc..bd683c11d 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -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 */ diff --git a/src/h/object.h b/src/h/object.h index 7555c2d69..fd58a2f2f 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -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? */ }; /* diff --git a/src/h/stacks.h b/src/h/stacks.h index 4ee788229..229077ff6 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -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); \