mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-15 15:21:03 -08:00
Code Issues Projects Releases Packages Wiki Activity

stacks: refactor file to separate low level and high level operators

Browse source 
With this it will possible to move low level primitives earlier in the bootstrap
process.
This commit is contained in:
Daniel Kochmański 2025-03-28 22:14:11 +01:00
parent fd2fae1a39
commit 03e9f9296c
3 changed files with 389 additions and 319 deletions
Download patch file Download diff file Expand all files Collapse all files

17
src/c/main.d
View file

@ -194,17 +194,6 @@ ecl_init_first_env(cl_env_ptr env)
{
#ifdef ECL_THREADS
init_threads();
#endif
#ifdef ECL_THREADS
{
cl_index idx;
cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*));
for(idx=0; idx<1024; idx++) {
vector[idx] = ECL_NO_TL_BINDING;
}
env->bds_stack.tl_bindings_size = 1024;
env->bds_stack.tl_bindings = vector;
}
#endif
init_env_mp(env);
init_env_int(env);
@ -228,12 +217,8 @@ _ecl_dealloc_env(cl_env_ptr env)
{
/* Environment cleanup. This is required because the environment is allocated
* using mmap or some other method. */
ecl_free(env->run_stack.org);
ecl_free(env->frs_stack.org);
ecl_free(env->bds_stack.org);
free_stacks(env);
#ifdef ECL_THREADS
ecl_free(env->bds_stack.tl_bindings);
env->bds_stack.tl_bindings_size = 0;
ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock);
#endif
#if defined(ECL_USE_MPROTECT)

682
src/c/stacks.d
View file

@ -13,6 +13,7 @@
*/
#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
#include <signal.h>
#include <string.h>
#ifdef HAVE_SYS_RESOURCE_H
@ -23,43 +24,84 @@
#include <ecl/internal.h>
#include <ecl/stack-resize.h>
/* ------------------------- C STACK ---------------------------------- */
static void
cs_set_size(cl_env_ptr env, cl_index new_size);
/* -- C Stack ---------------------------------------------------------------- */
void
ecl_cs_init(cl_env_ptr env)
{
volatile char foo = 0;
cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
cl_index new_size = ecl_option_values[ECL_OPT_C_STACK_SIZE];
cl_index max_size = new_size;
#ifdef GBC_BOEHM
struct GC_stack_base base;
if (GC_get_stack_base(&base) == GC_SUCCESS)
env->c_stack.org = (char*)base.mem_base;
else
env->c_stack.org = (char*)(&env);
#else
/* Rough estimate. Not very safe. We assume that cl_boot() is invoked from the
* main() routine of the program. */
env->c_stack.org = (char*)(&env);
#endif
{
/* Rough estimate. Not very safe. We assume that cl_boot()
* is invoked from the main() routine of the program. */
env->c_stack.org = (char*)(&env);
#ifdef ECL_CAN_SET_STACK_SIZE
{
struct rlimit rl;
if (!getrlimit(RLIMIT_STACK, &rl)) {
if (new_size > rl.rlim_cur) {
rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size;
if (setrlimit(RLIMIT_STACK, &rl))
ecl_internal_error("Can't set the size of the C stack");
}
} else {
rl.rlim_cur = new_size;
rl.rlim_max = max_size;
}
env->c_stack.max = env->c_stack.org;
env->c_stack.max_size = 0;
cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]);
if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) {
/* Either getrlimit failed or returned nonsense, either way we don't
* know the stack size. Use a default of 1 MB and hope for the best. */
new_size = 1048576;
max_size = 1048576;
} else {
new_size = rl.rlim_cur;
max_size = rl.rlim_max;
}
}
#endif
env->c_stack.limit_size = new_size - 2*margin;
env->c_stack.size = new_size;
env->c_stack.max_size = max_size;
#ifdef ECL_DOWN_STACK
env->c_stack.max = env->c_stack.org - new_size;
if (&foo > (env->c_stack.org - new_size) + 16) {
env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin);
if (env->c_stack.limit < env->c_stack.max)
env->c_stack.max = env->c_stack.limit;
} else {
ecl_internal_error("Can't set the size of the C stack: sanity check failed.");
}
#else
env->c_stack.max = env->c_stack.org + new_size;
if (&foo < (env->c_stack.org + new_size) - 16) {
env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin);
if (env->c_stack.limit > env->c_stack.max)
env->c_stack.max = env->c_stack.limit;
} else {
ecl_internal_error("Can't set the size of the C stack: sanity check failed.");
}
#endif
}
static void
cs_set_size(cl_env_ptr env, cl_index new_size)
void
ecl_cs_set_size(cl_env_ptr env, cl_index new_size)
{
volatile char foo = 0;
cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
if (new_size > env->c_stack.max_size)
new_size = env->c_stack.max_size;
#if defined(ECL_CAN_SET_STACK_SIZE)
#ifdef ECL_CAN_SET_STACK_SIZE
{
struct rlimit rl;
if (!getrlimit(RLIMIT_STACK, &rl)) {
env->c_stack.max_size = rl.rlim_max;
if (new_size > rl.rlim_cur) {
rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size;
if (setrlimit(RLIMIT_STACK, &rl))
@ -69,37 +111,35 @@ cs_set_size(cl_env_ptr env, cl_index new_size)
rl.rlim_cur = new_size;
}
if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) {
/* Either getrlimit failed or returned nonsense, either way we
* don't know the stack size. Use a default of 1 MB and hope for
* the best. */
/* Either getrlimit failed or returned nonsense, either way we don't know
* the stack size. Use a default of 1 MB and hope for the best. */
new_size = 1048576;
} else {
new_size = rl.rlim_cur;
}
#ifdef ECL_DOWN_STACK
env->c_stack.max = env->c_stack.org - new_size;
#else
env->c_stack.max = env->c_stack.org + new_size;
#endif
}
#endif
env->c_stack.limit_size = new_size - (2*margin);
env->c_stack.limit_size = new_size - 2*margin;
env->c_stack.size = new_size;
#ifdef ECL_DOWN_STACK
env->c_stack.max = env->c_stack.org - new_size;
if (&foo > (env->c_stack.org - new_size) + 16) {
env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin);
if (env->c_stack.limit < env->c_stack.max)
env->c_stack.max = env->c_stack.limit;
} else {
ecl_internal_error("Can't set the size of the C stack: sanity check failed.");
}
#else
env->c_stack.max = env->c_stack.org + new_size;
if (&foo < (env->c_stack.org + new_size) - 16) {
env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin);
if (env->c_stack.limit > env->c_stack.max)
env->c_stack.max = env->c_stack.limit;
} else {
ecl_internal_error("Can't set the size of the C stack: sanity check failed.");
}
#endif
else
ecl_internal_error("Can't set the size of the C stack: sanity check failed");
env->c_stack.size = new_size;
}
void
@ -127,7 +167,7 @@ ecl_cs_overflow(void)
CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_NIL);
}
/* ------------------------- LISP STACK ------------------------------- */
/* -- Data stack ------------------------------------------------------------ */
static void
run_init(cl_env_ptr env)
@ -147,7 +187,7 @@ run_init(cl_env_ptr env)
}
void
data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size)
ecl_data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size)
{
cl_index margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA];
cl_object *old_org = env->run_stack.org;
@ -173,7 +213,7 @@ data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size)
cl_object *
ecl_data_stack_grow(cl_env_ptr env)
{
data_stack_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2);
ecl_data_stack_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2);
return env->run_stack.top;
}
@ -208,7 +248,7 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size)
cl_index bindex;
if (size) {
if ((env->run_stack.limit - base) < size) {
data_stack_set_limit(env, env->run_stack.limit_size + size);
ecl_data_stack_set_limit(env, env->run_stack.limit_size + size);
base = env->run_stack.top;
}
}
@ -267,13 +307,7 @@ ecl_stack_frame_close(cl_object f)
}
}
/* ------------------------- BINDING STACK ---------------------------- */
void
ecl_bds_unwind_n(cl_env_ptr env, int n)
{
while (n--) ecl_bds_unwind1(env);
}
/* -- Binding stack ---------------------------------------------------------- */
static void
bds_init(cl_env_ptr env)
@ -289,31 +323,7 @@ bds_init(cl_env_ptr env)
env->bds_stack.limit_size = limit_size;
}
static void
bds_set_limit(cl_env_ptr env, cl_index new_lim_size)
{
cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
ecl_bds_ptr old_org = env->bds_stack.org;
ecl_bds_ptr new_org = NULL;
cl_index osize = env->bds_stack.size;
cl_index nsize = new_lim_size + 2*margin;
cl_index current_size = env->bds_stack.top - old_org;
if (current_size > new_lim_size)
ecl_internal_error("Cannot shrink frame stack below its minimal element");
new_org = ecl_realloc(old_org,
osize * sizeof(*old_org),
nsize * sizeof(*old_org));
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
env->bds_stack.org = new_org;
env->bds_stack.top = new_org + current_size;
env->bds_stack.limit = new_org + new_lim_size;
/* Update indexes */
env->bds_stack.size = nsize;
env->bds_stack.limit_size = new_lim_size;
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
}
ecl_bds_ptr
ecl_bds_ptr
ecl_bds_overflow(void)
{
static const char *stack_overflow_msg =
@ -348,65 +358,10 @@ ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx)
env->bds_stack.top = new_bds_top;
}
cl_index
ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
void
ecl_bds_unwind_n(cl_env_ptr env, int n)
{
cl_object vars = vars0, values = values0;
cl_index n = env->bds_stack.top - env->bds_stack.org;
for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
if (Null(vars)) {
return n;
} else {
cl_object var = ECL_CONS_CAR(vars);
if (!ECL_SYMBOLP(var))
FEillegal_variable_name(var);
if (ecl_symbol_type(var) & ecl_stp_constant)
FEbinding_a_constant(var);
if (Null(values)) {
ecl_bds_bind(env, var, OBJNULL);
} else {
ecl_bds_bind(env, var, ECL_CONS_CAR(values));
values = ECL_CONS_CDR(values);
}
}
}
FEerror("Wrong arguments to special form PROGV. Either~%"
"~A~%or~%~A~%are not proper lists",
2, vars0, values0);
}
static ecl_bds_ptr
get_bds_ptr(cl_object x)
{
if (ECL_FIXNUMP(x)) {
cl_env_ptr env = ecl_process_env();
ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x);
if (env->bds_stack.org <= p && p <= env->bds_stack.top)
return(p);
}
FEerror("~S is an illegal bds index.", 1, x);
}
cl_object
si_bds_top()
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org));
}
cl_object
si_bds_var(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_bds_ptr(arg)->symbol);
}
cl_object
si_bds_val(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
cl_object v = get_bds_ptr(arg)->value;
ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v));
while (n--) ecl_bds_unwind1(env);
}
#ifdef ecl_bds_bind
@ -572,8 +527,31 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value)
}
#endif /* ECL_THREADS */
/* ------------------------- INVOCATION STACK ------------------------- */
void
ecl_bds_set_limit(cl_env_ptr env, cl_index new_lim_size)
{
cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
ecl_bds_ptr old_org = env->bds_stack.org;
ecl_bds_ptr new_org = NULL;
cl_index osize = env->bds_stack.size;
cl_index nsize = new_lim_size + 2*margin;
cl_index current_size = env->bds_stack.top - old_org;
if (current_size > new_lim_size)
ecl_internal_error("Cannot shrink frame stack below its minimal element");
new_org = ecl_realloc(old_org,
osize * sizeof(*old_org),
nsize * sizeof(*old_org));
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
env->bds_stack.org = new_org;
env->bds_stack.top = new_org + current_size;
env->bds_stack.limit = new_org + new_lim_size;
/* Update indexes */
env->bds_stack.size = nsize;
env->bds_stack.limit_size = new_lim_size;
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
}
/* -- Invocation stack ------------------------------------------------------- */
static void
ihs_init(cl_env_ptr env)
{
@ -584,6 +562,279 @@ ihs_init(cl_env_ptr env)
ihs_org.index = 0;
}
/* -- Frame stack ------------------------------------------------------------ */
static void
frs_init(cl_env_ptr env)
{
cl_index size, margin, limit_size;
margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
limit_size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE];
size = limit_size + 2 * margin;
env->frs_stack.org = (ecl_frame_ptr)ecl_malloc(size * sizeof(*env->frs_stack.org));
env->frs_stack.top = env->frs_stack.org-1;
env->frs_stack.limit = &env->frs_stack.org[limit_size];
env->frs_stack.size = size;
env->frs_stack.limit_size = limit_size;
}
void
ecl_frs_set_limit(cl_env_ptr env, cl_index new_lim_size)
{
cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
ecl_frame_ptr old_org = env->frs_stack.org;
ecl_frame_ptr new_org = NULL;
cl_index osize = env->frs_stack.size;
cl_index nsize = new_lim_size + 2*margin;
cl_index current_size = env->frs_stack.top - old_org;
if(current_size > new_lim_size)
ecl_internal_error("Cannot shrink frame stack below its minimal element");
new_org = ecl_realloc(old_org,
osize * sizeof(*old_org),
nsize * sizeof(*old_org));
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
env->frs_stack.org = new_org;
env->frs_stack.top = new_org + current_size;
env->frs_stack.limit = new_org + new_lim_size;
/* Update indexes. */
env->frs_stack.size = nsize;
env->frs_stack.limit_size = new_lim_size;
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
}
static void
frs_overflow(void)
{
static const char *stack_overflow_msg =
"\n;;;\n;;; Frame stack overflow.\n"
";;; Jumping to the outermost toplevel prompt\n"
";;;\n\n";
cl_env_ptr env = ecl_process_env();
cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
cl_index size = env->frs_stack.size;
cl_index limit_size = env->frs_stack.limit_size;
ecl_frame_ptr org = env->frs_stack.org;
ecl_frame_ptr last = org + size;
if (env->frs_stack.limit >= last) {
ecl_internal_error(stack_overflow_msg);
}
env->frs_stack.limit += margin;
CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(limit_size), ECL_T);
}
ecl_frame_ptr
_ecl_frs_push(cl_env_ptr env)
{
/* We store a dummy tag first, to make sure that it is safe to
* interrupt this method with a call to ecl_unwind. Otherwise, a
* stray ECL_PROTECT_TAG will lead to segfaults. AO_nop_full is
* needed to ensure that the CPU doesn't reorder the memory
* stores. */
ecl_frame_ptr output = env->frs_stack.top+1;
if (output >= env->frs_stack.limit) {
frs_overflow();
output = env->frs_stack.top+1;
}
output->frs_val = ECL_DUMMY_TAG;
AO_nop_full();
++env->frs_stack.top;
output->frs_bds_ndx = env->bds_stack.top - env->bds_stack.org;
output->frs_run_ndx = ECL_STACK_INDEX(env);
output->frs_ihs = env->ihs_stack.top;
return output;
}
ecl_frame_ptr
frs_sch (cl_object frame_id)
{
cl_env_ptr env = ecl_process_env();
ecl_frame_ptr top;
for (top = env->frs_stack.top; top >= env->frs_stack.org; top--)
if (top->frs_val == frame_id)
return(top);
return(NULL);
}
/* -- Initialization -------------------------------------------------------- */
cl_object
init_stacks(cl_env_ptr the_env)
{
#ifdef ECL_THREADS
if (the_env == cl_core.first_env) {
cl_index idx;
cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*));
for(idx=0; idx<1024; idx++) {
vector[idx] = ECL_NO_TL_BINDING;
}
the_env->bds_stack.tl_bindings_size = 1024;
the_env->bds_stack.tl_bindings = vector;
}
#endif
frs_init(the_env);
bds_init(the_env);
run_init(the_env);
ihs_init(the_env);
/* FIXME ecl_cs_init must be called from the thread entry point at the
beginning to correctly determine the stack base. */
#if 0
cs_init(the_env);
#endif
return ECL_NIL;
}
cl_object
free_stacks(cl_env_ptr the_env)
{
#ifdef ECL_THREADS
ecl_free(the_env->bds_stack.tl_bindings);
the_env->bds_stack.tl_bindings_size = 0;
#endif
ecl_free(the_env->run_stack.org);
ecl_free(the_env->bds_stack.org);
ecl_free(the_env->frs_stack.org);
return ECL_NIL;
}
/* -- High level interface -------------------------------------------------- */
void
ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr)
{
env->frs_stack.nlj_fr = fr;
ecl_frame_ptr top = env->frs_stack.top;
while (top != fr && top->frs_val != ECL_PROTECT_TAG){
top->frs_val = ECL_DUMMY_TAG;
--top;
}
env->ihs_stack.top = top->frs_ihs;
ecl_bds_unwind(env, top->frs_bds_ndx);
ECL_STACK_UNWIND(env, top->frs_run_ndx);
env->frs_stack.top = top;
ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1);
/* never reached */
}
cl_index
ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
{
cl_object vars = vars0, values = values0;
cl_index n = env->bds_stack.top - env->bds_stack.org;
for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
if (Null(vars)) {
return n;
} else {
cl_object var = ECL_CONS_CAR(vars);
if (!ECL_SYMBOLP(var))
FEillegal_variable_name(var);
if (ecl_symbol_type(var) & ecl_stp_constant)
FEbinding_a_constant(var);
if (Null(values)) {
ecl_bds_bind(env, var, OBJNULL);
} else {
ecl_bds_bind(env, var, ECL_CONS_CAR(values));
values = ECL_CONS_CDR(values);
}
}
}
FEerror("Wrong arguments to special form PROGV. Either~%"
"~A~%or~%~A~%are not proper lists",
2, vars0, values0);
}
/* -- Bindings stack -------------------------------------------------------- */
static ecl_bds_ptr
get_bds_ptr(cl_object x)
{
if (ECL_FIXNUMP(x)) {
cl_env_ptr env = ecl_process_env();
ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x);
if (env->bds_stack.org <= p && p <= env->bds_stack.top)
return(p);
}
FEerror("~S is an illegal bds index.", 1, x);
}
cl_object
si_bds_top()
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org));
}
cl_object
si_bds_var(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_bds_ptr(arg)->symbol);
}
cl_object
si_bds_val(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
cl_object v = get_bds_ptr(arg)->value;
ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v));
}
/* -- Frame stack ----------------------------------------------------------- */
static ecl_frame_ptr
get_frame_ptr(cl_object x)
{
if (ECL_FIXNUMP(x)) {
cl_env_ptr env = ecl_process_env();
ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x);
if (env->frs_stack.org <= p && p <= env->frs_stack.top)
return p;
}
FEerror("~S is an illegal frs index.", 1, x);
}
cl_object
si_frs_top()
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org));
}
cl_object
si_frs_bds(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx));
}
cl_object
si_frs_tag(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_frame_ptr(arg)->frs_val);
}
cl_object
si_frs_ihs(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index));
}
cl_object
si_sch_frs_base(cl_object fr, cl_object ihs)
{
cl_env_ptr env = ecl_process_env();
ecl_frame_ptr x;
cl_index y = ecl_to_size(ihs);
for (x = get_frame_ptr(fr);
x <= env->frs_stack.top && x->frs_ihs->index < y;
x++);
ecl_return1(env, ((x > env->frs_stack.top)
? ECL_NIL
: ecl_make_fixnum(x - env->frs_stack.org)));
}
/* -- Invocation stack ------------------------------------------------------ */
static ecl_ihs_ptr
get_ihs_ptr(cl_index n)
{
@ -638,171 +889,7 @@ si_ihs_env(cl_object arg)
ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env);
}
/* ------------------------- FRAME STACK ------------------------------ */
static void
frs_init(cl_env_ptr env)
{
cl_index size, margin, limit_size;
margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
limit_size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE];
size = limit_size + 2 * margin;
env->frs_stack.org = (ecl_frame_ptr)ecl_malloc(size * sizeof(*env->frs_stack.org));
env->frs_stack.top = env->frs_stack.org-1;
env->frs_stack.limit = &env->frs_stack.org[limit_size];
env->frs_stack.size = size;
env->frs_stack.limit_size = limit_size;
}
static void
frs_set_limit(cl_env_ptr env, cl_index new_lim_size)
{
cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
ecl_frame_ptr old_org = env->frs_stack.org;
ecl_frame_ptr new_org = NULL;
cl_index osize = env->frs_stack.size;
cl_index nsize = new_lim_size + 2*margin;
cl_index current_size = env->frs_stack.top - old_org;
if(current_size > new_lim_size)
ecl_internal_error("Cannot shrink frame stack below its minimal element");
new_org = ecl_realloc(old_org,
osize * sizeof(*old_org),
nsize * sizeof(*old_org));
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
env->frs_stack.org = new_org;
env->frs_stack.top = new_org + current_size;
env->frs_stack.limit = new_org + new_lim_size;
/* Update indexes. */
env->frs_stack.size = nsize;
env->frs_stack.limit_size = new_lim_size;
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
}
static void
frs_overflow(void)
{
static const char *stack_overflow_msg =
"\n;;;\n;;; Frame stack overflow.\n"
";;; Jumping to the outermost toplevel prompt\n"
";;;\n\n";
cl_env_ptr env = ecl_process_env();
cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
cl_index size = env->frs_stack.size;
cl_index limit_size = env->frs_stack.limit_size;
ecl_frame_ptr org = env->frs_stack.org;
ecl_frame_ptr last = org + size;
if (env->frs_stack.limit >= last) {
ecl_internal_error(stack_overflow_msg);
}
env->frs_stack.limit += margin;
CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(size), ECL_T);
}
ecl_frame_ptr
_ecl_frs_push(cl_env_ptr env)
{
/* We store a dummy tag first, to make sure that it is safe to
* interrupt this method with a call to ecl_unwind. Otherwise, a
* stray ECL_PROTECT_TAG will lead to segfaults. AO_nop_full is
* needed to ensure that the CPU doesn't reorder the memory
* stores. */
ecl_frame_ptr output = env->frs_stack.top+1;
if (output >= env->frs_stack.limit) {
frs_overflow();
output = env->frs_stack.top+1;
}
output->frs_val = ECL_DUMMY_TAG;
AO_nop_full();
++env->frs_stack.top;
output->frs_bds_ndx = env->bds_stack.top - env->bds_stack.org;
output->frs_run_ndx = ECL_STACK_INDEX(env);
output->frs_ihs = env->ihs_stack.top;
return output;
}
void
ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr)
{
env->frs_stack.nlj_fr = fr;
ecl_frame_ptr top = env->frs_stack.top;
while (top != fr && top->frs_val != ECL_PROTECT_TAG){
top->frs_val = ECL_DUMMY_TAG;
--top;
}
env->ihs_stack.top = top->frs_ihs;
ecl_bds_unwind(env, top->frs_bds_ndx);
ECL_STACK_UNWIND(env, top->frs_run_ndx);
env->frs_stack.top = top;
ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1);
/* never reached */
}
ecl_frame_ptr
frs_sch (cl_object frame_id)
{
cl_env_ptr env = ecl_process_env();
ecl_frame_ptr top;
for (top = env->frs_stack.top; top >= env->frs_stack.org; top--)
if (top->frs_val == frame_id)
return(top);
return(NULL);
}
static ecl_frame_ptr
get_frame_ptr(cl_object x)
{
if (ECL_FIXNUMP(x)) {
cl_env_ptr env = ecl_process_env();
ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x);
if (env->frs_stack.org <= p && p <= env->frs_stack.top)
return p;
}
FEerror("~S is an illegal frs index.", 1, x);
}
cl_object
si_frs_top()
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org));
}
cl_object
si_frs_bds(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx));
}
cl_object
si_frs_tag(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_frame_ptr(arg)->frs_val);
}
cl_object
si_frs_ihs(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index));
}
cl_object
si_sch_frs_base(cl_object fr, cl_object ihs)
{
cl_env_ptr env = ecl_process_env();
ecl_frame_ptr x;
cl_index y = ecl_to_size(ihs);
for (x = get_frame_ptr(fr);
x <= env->frs_stack.top && x->frs_ihs->index < y;
x++);
ecl_return1(env, ((x > env->frs_stack.top)
? ECL_NIL
: ecl_make_fixnum(x - env->frs_stack.org)));
}
/* ------------------------- INITIALIZATION --------------------------- */
/* -- Lisp ops on stacks ---------------------------------------------------- */
cl_object
si_set_limit(cl_object type, cl_object limit)
@ -814,23 +901,23 @@ si_set_limit(cl_object type, cl_object limit)
cl_index request_size = ecl_to_size(limit);
if(current_size > request_size)
FEerror("Cannot shrink frame stack below ~D.", 1, limit);
frs_set_limit(env, request_size);
ecl_frs_set_limit(env, request_size);
} else if (type == @'ext::binding-stack') {
cl_index current_size = env->bds_stack.top - env->bds_stack.org;
cl_index request_size = ecl_to_size(limit);
if(current_size > request_size)
FEerror("Cannot shrink binding stack below ~D.", 1, limit);
bds_set_limit(env, request_size);
ecl_bds_set_limit(env, request_size);
} else if (type == @'ext::lisp-stack') {
cl_index current_size = env->run_stack.top - env->run_stack.org;
cl_index request_size = ecl_to_size(limit);
if(current_size > request_size)
FEerror("Cannot shrink lisp stack below ~D.", 1, limit);
data_stack_set_limit(env, request_size);
ecl_data_stack_set_limit(env, request_size);
} else if (type == @'ext::c-stack') {
cl_index the_size = ecl_to_size(limit);
margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
cs_set_size(env, the_size + 2*margin);
ecl_cs_set_size(env, the_size + 2*margin);
} else if (type == @'ext::heap-size') {
/*
* size_t can be larger than cl_index, and ecl_to_size()
@ -863,12 +950,3 @@ si_get_limit(cl_object type)
ecl_return1(env, ecl_make_unsigned_integer(output));
}
void
init_stacks(cl_env_ptr env)
{
frs_init(env);
bds_init(env);
ihs_init(env);
run_init(env);
}

9
src/h/internal.h
View file

@ -36,7 +36,10 @@ extern void init_GC(void);
#endif
extern void init_macros(void);
extern void init_read(void);
extern void init_stacks(cl_env_ptr);
extern cl_object init_stacks(cl_env_ptr);
extern cl_object free_stacks(cl_env_ptr);
extern void init_unixint(int pass);
extern void init_unixtime(void);
extern void init_compiler(void);
@ -555,6 +558,10 @@ extern cl_object ecl_deserialize(uint8_t *data);
ecl_data_stack_pop_values(the_env,__i); }
extern void ecl_cs_init(cl_env_ptr env);
extern void ecl_frs_set_limit(cl_env_ptr env, cl_index n);
extern void ecl_bds_set_limit(cl_env_ptr env, cl_index n);
extern void ecl_data_stack_set_limit(cl_env_ptr env, cl_index n);
extern void ecl_cs_set_size(cl_env_ptr env, cl_index n);
#ifndef RLIM_SAVED_MAX
# define RLIM_SAVED_MAX RLIM_INFINITY