From f7633962d91f5c9748201f34484ba32fdba2ae65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 28 Mar 2025 22:14:11 +0100 Subject: [PATCH] stacks: refactor file to separate low level and high level operators With this it will possible to move low level primitives earlier in the bootstrap process. --- src/c/main.d | 17 +- src/c/stacks.d | 682 ++++++++++++++++++++++++++--------------------- src/h/internal.h | 9 +- 3 files changed, 389 insertions(+), 319 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 0140087c1..399d3e30b 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -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) diff --git a/src/c/stacks.d b/src/c/stacks.d index b50984461..daf3f2726 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -13,6 +13,7 @@ */ #include +#include #include #include #ifdef HAVE_SYS_RESOURCE_H @@ -23,43 +24,84 @@ #include #include -/* ------------------------- 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 ------------------------------- */ +/* -- ByteVM stack ----------------------------------------------------------- */ static void run_init(cl_env_ptr env) @@ -147,7 +187,7 @@ run_init(cl_env_ptr env) } void -vms_set_limit(cl_env_ptr env, cl_index new_lim_size) +ecl_vms_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 @@ vms_set_limit(cl_env_ptr env, cl_index new_lim_size) cl_object * ecl_vms_extend(cl_env_ptr env) { - vms_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); + ecl_vms_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) { - vms_set_limit(env, env->run_stack.limit_size + size); + ecl_vms_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_vms_ndx = ecl_vms_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_vms_unwind(env, top->frs_vms_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_vms_ndx = ecl_vms_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_vms_unwind(env, top->frs_vms_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 FRS 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 BDS 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 VMS stack below ~D.", 1, limit); - vms_set_limit(env, request_size); + ecl_vms_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); -} diff --git a/src/h/internal.h b/src/h/internal.h index b284881f8..d716a0a13 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -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_vms_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_vms_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