diff --git a/CHANGELOG b/CHANGELOG index d25ead65434009dbe3f52957246aedb73354cbfd..36293166bf126703593c0f5a4ac986138380eae5 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -29,7 +29,14 @@ * Pending changes since 24.5.10 -- Many internal improvements and bug fixes for the native compiler. +- Process initial bindings, when specified, are inherited when the process + is enabled (previously they were copied when the process was created) + +- Bytecodes VM stores locals on the stack (performance improvement) + +- Bytecodes closures capture now only closed over variables (not whole env) + +- MANY internal improvements and bug fixes for the native compiler. - Reduced function call overhead. diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 6c55be548a45025945f063429bc909bb60c62fea..0bb2b76745308eedde6c64d513dd23ef7b384ec2 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -676,12 +676,12 @@ void init_type_info (void) to_bitmap(&o, &(o.process.name)) | to_bitmap(&o, &(o.process.function)) | to_bitmap(&o, &(o.process.args)) | - to_bitmap(&o, &(o.process.env)) | to_bitmap(&o, &(o.process.interrupt)) | - to_bitmap(&o, &(o.process.initial_bindings)) | + to_bitmap(&o, &(o.process.inherit_bindings_p)) | to_bitmap(&o, &(o.process.parent)) | to_bitmap(&o, &(o.process.exit_values)) | - to_bitmap(&o, &(o.process.woken_up)); + to_bitmap(&o, &(o.process.woken_up)) | + to_bitmap(&o, &(o.process.env)); type_info[t_lock].descriptor = to_bitmap(&o, &(o.lock.name)) | to_bitmap(&o, &(o.lock.owner)); @@ -1152,19 +1152,18 @@ update_bytes_consed () { static void ecl_mark_env(struct cl_env_struct *env) { - if (env->stack) { - GC_push_conditional((void *)env->stack, (void *)env->stack_top, 1); - GC_set_mark_bit((void *)env->stack); - } - if (env->frs_top) { - GC_push_conditional((void *)env->frs_org, (void *)(env->frs_top+1), 1); - GC_set_mark_bit((void *)env->frs_org); - } - if (env->bds_top) { - GC_push_conditional((void *)env->bds_org, (void *)(env->bds_top+1), 1); - GC_set_mark_bit((void *)env->bds_org); - } - /* When not using threads, "env" is mmaped or statically allocated. */ + /* Environments and stacks are allocated without GC */ + if (env->run_stack.org) + GC_push_all((void *)env->run_stack.org, (void *)env->run_stack.top); + if (env->frs_stack.org) + GC_push_all((void *)env->frs_stack.org, (void *)(env->frs_stack.top+1)); + if (env->bds_stack.org) + GC_push_all((void *)env->bds_stack.org, (void *)(env->bds_stack.top+1)); +#ifdef ECL_THREADS + if (env->bds_stack.tl_bindings) + GC_push_all((void *)env->bds_stack.tl_bindings, + (void *)(env->bds_stack.tl_bindings + env->bds_stack.tl_bindings_size)); +#endif GC_push_all((void *)env, (void *)(env + 1)); } diff --git a/src/c/compiler.d b/src/c/compiler.d index ee76b09507c8afb308c3ec53afb624c500401a52..cce49e6263a6d90450f000728074106a20906743 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -55,7 +55,7 @@ typedef struct cl_compiler_env *cl_compiler_ptr; #define asm_begin(env) current_pc(env) #define current_pc(env) ECL_STACK_INDEX(env) #define set_pc(env,n) asm_clear(env,n) -#define asm_ref(env,n) (cl_fixnum)((env)->stack[n]) +#define asm_ref(env,n) (cl_fixnum)((env)->run_stack.org[n]) static void asm_clear(cl_env_ptr env, cl_index h); static void asm_op(cl_env_ptr env, cl_fixnum op); static void asm_op2(cl_env_ptr env, int op, int arg); @@ -192,7 +192,7 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { output->bytecodes.flex = ECL_NIL; output->bytecodes.nlcl = ecl_make_fixnum(c_env->env_width); for (i = 0, code = (cl_opcode *)output->bytecodes.code; i < code_size; i++) { - code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); + code[i] = (cl_opcode)(cl_fixnum)(env->run_stack.org[beginning+i]); } output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; ecl_set_function_source_file_info(output, (file == OBJNULL)? ECL_NIL : file, @@ -211,7 +211,7 @@ asm_op(cl_env_ptr env, cl_fixnum code) { static void asm_clear(cl_env_ptr env, cl_index h) { - ECL_STACK_SET_INDEX(env, h); + ECL_STACK_UNWIND(env, h); } static void @@ -257,7 +257,7 @@ asm_complete(cl_env_ptr env, int op, cl_index pc) { else if (ecl_unlikely(delta < -MAX_OPARG || delta > MAX_OPARG)) FEprogram_error("Too large jump", 0); else { - env->stack[pc] = (cl_object)(cl_fixnum)delta; + env->run_stack.org[pc] = (cl_object)(cl_fixnum)delta; } } @@ -1446,7 +1446,7 @@ c_catch(cl_env_ptr env, cl_object args, int flags) { static int c_compiler_let(cl_env_ptr env, cl_object args, int flags) { cl_object bindings; - cl_index old_bds_top_index = env->bds_top - env->bds_org; + cl_index old_bds_ndx = env->bds_stack.top - env->bds_stack.org; for (bindings = pop(&args); !Null(bindings); ) { cl_object form = pop(&bindings); @@ -1455,7 +1455,7 @@ c_compiler_let(cl_env_ptr env, cl_object args, int flags) { ecl_bds_bind(env, var, value); } flags = compile_toplevel_body(env, args, flags); - ecl_bds_unwind(env, old_bds_top_index); + ecl_bds_unwind(env, old_bds_ndx); return flags; } diff --git a/src/c/error.d b/src/c/error.d index c98417ba2b8b8bd5e00b90ffe5ada481ecb8498e..b420e47afe8a7eb55f8cdf20b9bc8035dc40c3c4 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -104,8 +104,8 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_unwind(the_env, destination); } } - if (the_env->frs_org <= the_env->frs_top) { - destination = ecl_process_env()->frs_org; + if (the_env->frs_stack.org <= the_env->frs_stack.top) { + destination = ecl_process_env()->frs_stack.org; ecl_unwind(the_env, destination); } else { ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); @@ -162,6 +162,24 @@ CEerror(cl_object c, const char *err, int narg, ...) * Conditions signaler * ***********************/ +void +CEstack_overflow(cl_object type, cl_object limit, cl_object resume) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_index the_size; + if (!Null(resume)) resume = @"Extend stack size"; + ECL_UNWIND_PROTECT_BEGIN(the_env) { + cl_cerror(6, resume, @'ext::stack-overflow', @':type', type, @':size', limit); + } ECL_UNWIND_PROTECT_EXIT { + /* reset the margin */ + si_set_limit(type, limit); + } ECL_UNWIND_PROTECT_END; + /* resize the stack */ + the_size = ecl_to_size(limit); + the_size = the_size + the_size/2; + si_set_limit(type, ecl_make_fixnum(the_size)); +} + void FEprogram_error(const char *s, int narg, ...) { @@ -287,7 +305,7 @@ FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type) struct ecl_ihs_frame tmp_ihs; function = cl_symbol_or_object(function); type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } si_signal_simple_error(8, @@ -311,7 +329,7 @@ FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_objec struct ecl_ihs_frame tmp_ihs; function = cl_symbol_or_object(function); type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } si_signal_simple_error(8, @@ -337,7 +355,7 @@ FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_obje function = cl_symbol_or_object(function); type = cl_symbol_or_object(type); key = cl_symbol_or_object(key); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } si_signal_simple_error(8, @@ -368,7 +386,7 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx, cl_env_ptr env = ecl_process_env(); struct ecl_ihs_frame tmp_ihs; function = cl_symbol_or_object(function); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } cl_error(9, @@ -506,8 +524,7 @@ universal_error_handler(cl_object continue_string, cl_object datum, ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(8)); ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL); ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - writestr_stream("\n;;; Unhandled lisp initialization error", - stream); + writestr_stream("\n;;; Unhandled lisp initialization error", stream); writestr_stream("\n;;; Message:\n", stream); si_write_ugly_object(datum, stream); writestr_stream("\n;;; Arguments:\n", stream); @@ -601,13 +618,6 @@ FEwin32_error(const char *msg, int narg, ...) cl_grab_rest_args(args))); } @) -@(defun si::serror (cformat eformat &rest args) -@ { - ecl_enable_interrupts(); - @(return funcall(4, @'si::stack-error-handler', cformat, eformat, - cl_grab_rest_args(args))); -} @) - void init_error(void) { diff --git a/src/c/eval.d b/src/c/eval.d index 237f5466022349604d88d5d9a4f79e1248044b34..97fb8166873df47e91d6e1299cf7c961a30b70d1 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -149,7 +149,7 @@ cl_funcall(cl_narg narg, cl_object function, ...) (cl_object)&frame_aux, narg -= 2); for (i = 0; i < narg; i++) { - ECL_STACK_FRAME_SET(frame, i, lastarg); + ecl_stack_frame_push(frame, lastarg); lastarg = ecl_va_arg(args); } if (ecl_t_of(lastarg) == t_frame) { diff --git a/src/c/ffi.d b/src/c/ffi.d index f6b3ff17ba0f7411524bfc5918d624cc51443c3a..9939d0c010d52d0c448cd9b00123ec8f3519eae9 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -942,7 +942,7 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); object = ecl_foreign_data_ref_elt(the_env->ffi_values, ecl_foreign_type_code(return_type)); - ECL_STACK_SET_INDEX(the_env, sp); + ECL_STACK_UNWIND(the_env, sp); if (object != ECL_NIL) { @(return object); } else { diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 8671f2487eb3f8d59282d9a34d83be230718183f..3b873197feeaa51787ef550f9ea2f698b6b39e57 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1089,13 +1089,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_BLOCK); { GET_DATA(reg0, vector, data); - reg1 = ecl_make_fixnum(the_env->frame_id++); + reg1 = ecl_make_fixnum(the_env->frs_stack.frame_id++); bind_frame(lcl_env, reg1, reg0); THREAD_NEXT; } CASE(OP_DO); { reg0 = ECL_NIL; - reg1 = ecl_make_fixnum(the_env->frame_id++); + reg1 = ecl_make_fixnum(the_env->frs_stack.frame_id++); bind_frame(lcl_env, reg1, reg0); THREAD_NEXT; } @@ -1270,13 +1270,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); unwind_lcl(lcl_env, ECL_STACK_POP_UNSAFE(the_env)); reg0 = the_env->values[0]; - ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->nlj_fr - the_env->frs_top)); + ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->frs_stack.nlj_fr - the_env->frs_stack.top)); goto PUSH_VALUES; } THREAD_NEXT; } CASE(OP_PROTECT_NORMAL); { - ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); + ecl_bds_unwind(the_env, the_env->frs_stack.top->frs_bds_ndx); ecl_frs_pop(the_env); (void)ECL_STACK_POP_UNSAFE(the_env); unwind_lcl(lcl_env, ECL_STACK_POP_UNSAFE(the_env)); @@ -1290,7 +1290,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) reg0 = the_env->values[0]; n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); if (n <= 0) - ecl_unwind(the_env, the_env->frs_top + n); + ecl_unwind(the_env, the_env->frs_stack.top + n); THREAD_NEXT; } @@ -1325,9 +1325,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) GET_DATA(form, vector, data); SETUP_ENV(the_env); the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); + n = ecl_data_stack_push_values(the_env); call_stepper(the_env, form, ecl_make_fixnum(1)); - ecl_stack_pop_values(the_env, n); + ecl_data_stack_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; } @@ -1345,9 +1345,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_index n; SETUP_ENV(the_env); the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); + n = ecl_data_stack_push_values(the_env); call_stepper(the_env, ECL_NIL, ecl_make_fixnum(-1)); - ecl_stack_pop_values(the_env, n); + ecl_data_stack_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; } diff --git a/src/c/main.d b/src/c/main.d index f2bedeb2246a967608e38d8e3334650d29096e5c..399d3e30b6873cd573fa19a363ffea0e7a6dbf13 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -194,13 +194,6 @@ ecl_init_first_env(cl_env_ptr env) { #ifdef ECL_THREADS init_threads(); -#endif -#ifdef ECL_THREADS - env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024), - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - env->thread_local_bindings_size = env->bindings_array->vector.dim; - env->thread_local_bindings = env->bindings_array->vector.self.t; #endif init_env_mp(env); init_env_int(env); @@ -222,8 +215,9 @@ ecl_init_env(cl_env_ptr env) void _ecl_dealloc_env(cl_env_ptr env) { - /* Environment cleanup. This is required becauyse the environment is allocated - * using mmap or some other method. We could do more cleaning here.*/ + /* Environment cleanup. This is required because the environment is allocated + * using mmap or some other method. */ + free_stacks(env); #ifdef ECL_THREADS ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock); #endif @@ -281,6 +275,9 @@ _ecl_alloc_env(cl_env_ptr parent) output->default_sigmask = cl_core.default_sigmask; } } + for (cl_index i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { + output->big_register[i] = ECL_NIL; + } output->method_cache = output->slot_cache = NULL; output->interrupt_struct = NULL; /* @@ -516,7 +513,6 @@ cl_boot(int argc, char **argv) env = cl_core.first_env; ecl_init_first_env(env); - ecl_cs_set_org(env); /* * 1) Initialize symbols and packages @@ -814,8 +810,8 @@ cl_boot(int argc, char **argv) } #endif ECL_SET(@'ext::*program-exit-code*', code); - if (the_env->frs_org <= the_env->frs_top) - ecl_unwind(the_env, the_env->frs_org); + if (the_env->frs_stack.org <= the_env->frs_stack.top) + ecl_unwind(the_env, the_env->frs_stack.org); si_exit(1, code); } @) diff --git a/src/c/read.d b/src/c/read.d index 8343635b5b6a1488652d3e296ee5903a6845c32f..dcb124730a5d5c48feb9dd9298a7ed87bf9fd9e7 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -954,7 +954,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) last = ECL_STACK_REF(env,-1); x = ecl_alloc_simple_vector(dim, ecl_aet_bit); for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? env->stack[sp+i] : last; + elt = (i < dimcount) ? env->run_stack.org[sp+i] : last; if (elt == ecl_make_fixnum(0)) x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); else diff --git a/src/c/stacks.d b/src/c/stacks.d index 3c883a59d2344761cc555aa8d831bcd39d83a293..2f09462c57c8157a69d7b90b7888f7cb20e0adef 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -2,7 +2,7 @@ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - * stacks.d - binding/history/frame stacks + * stacks.d - runtime, binding, history and frame stacks * * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya * Copyright (c) 1990 Giuseppe Attardi @@ -13,28 +13,40 @@ */ #include +#include #include #include #ifdef HAVE_SYS_RESOURCE_H # include # include #endif +#include #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]; -#if defined(ECL_CAN_SET_STACK_SIZE) + 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 +#ifdef ECL_CAN_SET_STACK_SIZE { struct rlimit rl; - if (!getrlimit(RLIMIT_STACK, &rl)) { - env->cs_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)) @@ -42,39 +54,92 @@ cs_set_size(cl_env_ptr env, cl_index new_size) } } else { rl.rlim_cur = new_size; + rl.rlim_max = max_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; + 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->cs_barrier = env->cs_org - new_size; + 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->cs_barrier = env->cs_org + new_size; + 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 +} + +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; +#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; + } + 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; + } else { + new_size = rl.rlim_cur; + } } #endif - env->cs_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 - if (&foo > (env->cs_org - new_size) + 16) { - env->cs_limit = (env->cs_org - new_size) + (2*margin); - if (env->cs_limit < env->cs_barrier) - env->cs_barrier = env->cs_limit; + 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 - if (&foo < (env->cs_org + new_size) - 16) { - env->cs_limit = (env->cs_org + new_size) - (2*margin); - if (env->cs_limit > env->cs_barrier) - env->cs_barrier = env->cs_limit; + 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->cs_size = new_size; } void @@ -86,143 +151,121 @@ ecl_cs_overflow(void) ";;;\n\n"; cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cl_index size = env->cs_size; + cl_index size = env->c_stack.size; #ifdef ECL_DOWN_STACK - if (env->cs_limit > env->cs_org - size) - env->cs_limit -= margin; + if (env->c_stack.limit > env->c_stack.org - size) + env->c_stack.limit -= margin; #else - if (env->cs_limit < env->cs_org + size) - env->cs_limit += margin; + if (env->c_stack.limit < env->c_stack.org + size) + env->c_stack.limit += margin; #endif else - ecl_unrecoverable_error(env, stack_overflow_msg); - - if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size) - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', - @':size', ecl_make_fixnum(size), - @':type', @'ext::c-stack'); + ecl_internal_error(stack_overflow_msg); + if (env->c_stack.max_size == (cl_index)0 || env->c_stack.size < env->c_stack.max_size) + CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_T); else - si_serror(6, ECL_NIL, - @'ext::stack-overflow', - @':size', ECL_NIL, - @':type', @'ext::c-stack'); - size += size/2; - if (size > env->cs_max_size) - size = env->cs_max_size; - cs_set_size(env, size); + CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_NIL); } -void -ecl_cs_set_org(cl_env_ptr env) -{ -#ifdef GBC_BOEHM - struct GC_stack_base base; - if (GC_get_stack_base(&base) == GC_SUCCESS) - env->cs_org = (char*)base.mem_base; - else -#endif - { - /* Rough estimate. Not very safe. We assume that cl_boot() - * is invoked from the main() routine of the program. - */ - env->cs_org = (char*)(&env); - } - env->cs_barrier = env->cs_org; - env->cs_max_size = 0; - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); -} +/* -- Data stack ------------------------------------------------------------ */ -/* ------------------------- LISP STACK ------------------------------- */ - -cl_object * -ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) +static void +run_init(cl_env_ptr env) { - cl_index top = env->stack_top - env->stack; - cl_object *new_stack, *old_stack; - cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; - cl_index new_size = tentative_new_size + 2*safety_area; - - /* Round to page size */ - new_size = ((new_size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE; - - if (ecl_unlikely(top > new_size)) { - FEerror("Internal error: cannot shrink stack below stack top.",0); - } - - old_stack = env->stack; - new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); - - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object)); - env->stack_size = new_size; - env->stack_limit_size = new_size - 2*safety_area; - env->stack = new_stack; - env->stack_top = env->stack + top; - env->stack_limit = env->stack + (new_size - 2*safety_area); - + cl_index size, limit_size, margin; + margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + limit_size = ecl_option_values[ECL_OPT_LISP_STACK_SIZE]; + size = limit_size + 2 * margin; + env->run_stack.org = (cl_object *)ecl_malloc(size * sizeof(cl_object)); + env->run_stack.top = env->run_stack.org; + env->run_stack.limit = &env->run_stack.org[limit_size]; + env->run_stack.size = size; + env->run_stack.limit_size = limit_size; /* A stack always has at least one element. This is assumed by cl__va_start - * and friends, which take a sp=0 to have no arguments. - */ - if (top == 0) { - *(env->stack_top++) = ecl_make_fixnum(0); - } - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_stack); - return env->stack_top; -} - -void -FEstack_underflow(void) -{ - FEerror("Internal error: stack underflow.",0); + and friends, which take a sp=0 to have no arguments. */ + *(env->run_stack.top++) = ecl_make_fixnum(0); } void -FEstack_advance(void) +ecl_data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size) { - FEerror("Internal error: stack advance beyond current point.",0); + cl_index margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + cl_object *old_org = env->run_stack.org; + cl_object *new_org = NULL; + cl_index osize = env->run_stack.size; + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->run_stack.top - old_org; + if (current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + env->run_stack.org = new_org; + env->run_stack.top = new_org + current_size; + env->run_stack.limit = new_org + new_lim_size; + /* Update indexes */ + env->run_stack.size = nsize; + env->run_stack.limit_size = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); } cl_object * -ecl_stack_grow(cl_env_ptr env) +ecl_data_stack_grow(cl_env_ptr env) { - return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); + ecl_data_stack_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); + return env->run_stack.top; } cl_index -ecl_stack_push_values(cl_env_ptr env) { +ecl_data_stack_push_values(cl_env_ptr env) { cl_index i = env->nvalues; - cl_object *b = env->stack_top; + cl_object *b = env->run_stack.top; cl_object *p = b + i; - if (p >= env->stack_limit) { - b = ecl_stack_grow(env); + while (p >= env->run_stack.limit) { + b = ecl_data_stack_grow(env); p = b + i; } - env->stack_top = p; - memcpy(b, env->values, i * sizeof(cl_object)); + env->run_stack.top = p; + ecl_copy(b, env->values, i * sizeof(cl_object)); return i; } void -ecl_stack_pop_values(cl_env_ptr env, cl_index n) { - cl_object *p = env->stack_top - n; - if (ecl_unlikely(p < env->stack)) - FEstack_underflow(); +ecl_data_stack_pop_values(cl_env_ptr env, cl_index n) { + cl_object *p = env->run_stack.top - n; + if (ecl_unlikely(p < env->run_stack.org)) + ecl_internal_error("data stack: stack underflow."); env->nvalues = n; - env->stack_top = p; - memcpy(env->values, p, n * sizeof(cl_object)); + env->run_stack.top = p; + ecl_copy(env->values, p, n * sizeof(cl_object)); } +/* A stack frame denotes a slice of the lisp stack [BASE,BASE+SIZE]. Between + these two values we maintain a stack pointer SP that shows where we push and + pop values when we use the frame. There are two nuances to keep in mind: + + 1. When we try to push-extend to the frame, it is possible only if the stack + top is aligned with the stack frame end: TOP_INDEX = SP = BASE+SIZE. This is + to avoid a situation where we override a newer frame. + + 2. When the stack top is aligned with the stack frame end, then push and pop + modifies the lisp stack TOP and the frame's SP and SIZE. This ensures that we + can use the topmost stack frame as if it were the stack, but also that we can + use some inner frames without corrupting it. + + Note that direct stack operations do not update existing frames, so it is + still possible to corrupt a stack frame if not carful. -- jd 2025-05-29 */ + cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) { - cl_object *base = env->stack_top; + cl_object *base = env->run_stack.top; cl_index bindex; if (size) { - if ((env->stack_limit - base) < size) { - base = ecl_stack_set_size(env, env->stack_size + size); + if ((env->run_stack.limit - base) < size) { + ecl_data_stack_set_limit(env, env->run_stack.limit_size + size); + base = env->run_stack.top; } } bindex = ECL_STACK_INDEX(env); @@ -232,43 +275,86 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) f->frame.size = size; f->frame.sp = bindex; f->frame.env = env; - env->stack_top = (base + size); + env->run_stack.top = (base + size); return f; } void ecl_stack_frame_push(cl_object f, cl_object o) { - cl_env_ptr env = f->frame.env; - cl_object *top = env->stack_top; - if (top >= env->stack_limit) { - top = ecl_stack_grow(env); + cl_env_ptr the_env = f->frame.env; + cl_object *frame_top = ECL_STACK_FRAME_TOP(f); + cl_index limit_index = f->frame.base + f->frame.size; + if (f->frame.sp < limit_index) { + *frame_top = o; + f->frame.sp++; + } else if (frame_top == the_env->run_stack.top) { + f->frame.sp++; + f->frame.size++; + ECL_STACK_PUSH(the_env, o); + } else { + ecl_internal_error("ecl_stack_frame_pop: frame overflow."); + } +} + +cl_object +ecl_stack_frame_pop(cl_object f) +{ + cl_env_ptr the_env = f->frame.env; + cl_object *frame_top = ECL_STACK_FRAME_TOP(f); + if (f->frame.sp <= f->frame.base) { + ecl_internal_error("ecl_stack_frame_pop: frame underflow."); + } else if (frame_top == the_env->run_stack.top) { + f->frame.sp--; + f->frame.size--; + return ECL_STACK_POP_UNSAFE(the_env); + } else { + f->frame.sp--; + return *ECL_STACK_FRAME_TOP(f); } - env->stack_top = ++top; - *(top-1) = o; - f->frame.size++; } void ecl_stack_frame_push_values(cl_object f) { - cl_env_ptr env = f->frame.env; - ecl_stack_push_values(env); - f->frame.size += env->nvalues; + cl_env_ptr the_env = f->frame.env; + cl_index limit_index = f->frame.base + f->frame.size; + cl_index vals_length = the_env->nvalues; + cl_index value_index = f->frame.sp + vals_length; + cl_object *frame_top = ECL_STACK_FRAME_TOP(f); + if (value_index <= limit_index) { + ecl_copy(frame_top, the_env->values, vals_length * sizeof(cl_object)); + f->frame.sp = value_index; + } else if (frame_top == the_env->run_stack.top) { + f->frame.sp = value_index; + f->frame.size = value_index - f->frame.base; + ecl_data_stack_push_values(the_env); + } else { + ecl_internal_error("ecl_stack_frame_pop: frame overflow."); + } } cl_object ecl_stack_frame_pop_values(cl_object f) { - cl_env_ptr env = f->frame.env; - cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT; - cl_object o; - env->nvalues = n; - env->values[0] = o = ECL_NIL; - while (n--) { - env->values[n] = o = ECL_STACK_FRAME_REF(f, n); + cl_env_ptr the_env = f->frame.env; + cl_index top_size = f->frame.sp - f->frame.base; + cl_index n = top_size % ECL_MULTIPLE_VALUES_LIMIT; + cl_object *frame_top = ECL_STACK_FRAME_TOP(f), result; + if (frame_top == the_env->run_stack.top) { + ecl_data_stack_pop_values(the_env, n); + f->frame.sp -= n; + f->frame.size -= n; + return the_env->values[0]; + } else { + the_env->nvalues = n; + the_env->values[0] = result = ECL_NIL; + while (n--) { + the_env->values[n] = result = ECL_STACK_FRAME_REF(f, n); + } + f->frame.sp -= n; + return result; } - return o; } void @@ -276,45 +362,27 @@ ecl_stack_frame_close(cl_object f) { if (f->frame.opened) { f->frame.opened = 0; - ECL_STACK_SET_INDEX(f->frame.env, f->frame.base); + ECL_STACK_UNWIND(f->frame.env, f->frame.base); } } -/* ------------------------- BINDING STACK ---------------------------- */ - -void -ecl_bds_unwind_n(cl_env_ptr env, int n) -{ - while (n--) ecl_bds_unwind1(env); -} +/* -- Binding stack ---------------------------------------------------------- */ static void -ecl_bds_set_size(cl_env_ptr env, cl_index new_size) +bds_init(cl_env_ptr env) { - ecl_bds_ptr old_org = env->bds_org; - cl_index limit = env->bds_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink the binding stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_ptr org; - env->bds_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->bds_top = org + limit; - env->bds_org = org; - env->bds_limit = org + (new_size - 2*margin); - env->bds_size = new_size; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_org); - } + cl_index size, margin, limit_size; + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + limit_size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE]; + size = limit_size + 2 * margin; + env->bds_stack.org = (ecl_bds_ptr)ecl_malloc(size * sizeof(*env->bds_stack.org)); + env->bds_stack.top = env->bds_stack.org-1; + env->bds_stack.limit = &env->bds_stack.org[limit_size]; + env->bds_stack.size = size; + env->bds_stack.limit_size = limit_size; } -ecl_bds_ptr +ecl_bds_ptr ecl_bds_overflow(void) { static const char *stack_overflow_msg = @@ -323,93 +391,36 @@ ecl_bds_overflow(void) ";;;\n\n"; cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - cl_index size = env->bds_size; - ecl_bds_ptr org = env->bds_org; + cl_index size = env->bds_stack.size; + cl_index limit_size = env->bds_stack.limit_size; + ecl_bds_ptr org = env->bds_stack.org; ecl_bds_ptr last = org + size; - if (env->bds_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); + if (env->bds_stack.limit >= last) { + ecl_internal_error(stack_overflow_msg); } - env->bds_limit += margin; - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::binding-stack'); - ecl_bds_set_size(env, size + (size / 2)); - return env->bds_top; + env->bds_stack.limit += margin; + CEstack_overflow(@'ext::binding-stack', ecl_make_fixnum(size), ECL_T); + return env->bds_stack.top; } void -ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index) +ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx) { - ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; - ecl_bds_ptr bds = env->bds_top; + ecl_bds_ptr new_bds_top = env->bds_stack.org + new_bds_ndx; + ecl_bds_ptr bds = env->bds_stack.top; for (; bds > new_bds_top; bds--) #ifdef ECL_THREADS ecl_bds_unwind1(env); #else bds->symbol->symbol.value = bds->value; #endif - env->bds_top = new_bds_top; + env->bds_stack.top = new_bds_top; } -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_top - env->bds_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_org + ecl_fixnum(x); - if (env->bds_org <= p && p <= env->bds_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_top - env->bds_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) +void +ecl_bds_unwind_n(cl_env_ptr env, int n) { - 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 @@ -441,17 +452,6 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol) return new_index; } -static cl_object -ecl_extend_bindings_array(cl_object vector) -{ - cl_index new_size = cl_core.last_var_index * 1.25; - cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim); - return new_vector; -} - static cl_index invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) { @@ -459,11 +459,18 @@ invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) if (index == ECL_MISSING_SPECIAL_BINDING) { index = ecl_new_binding_index(env, s); } - if (index >= env->thread_local_bindings_size) { - cl_object vector = env->bindings_array; - env->bindings_array = vector = ecl_extend_bindings_array(vector); - env->thread_local_bindings_size = vector->vector.dim; - env->thread_local_bindings = vector->vector.self.t; + if (index >= env->bds_stack.tl_bindings_size) { + cl_index osize = env->bds_stack.tl_bindings_size; + cl_index nsize = cl_core.last_var_index * 1.25; + cl_object *old_vector = env->bds_stack.tl_bindings; + cl_object *new_vector = ecl_realloc(old_vector, + osize*sizeof(cl_object*), + nsize*sizeof(cl_object*)); + while(osize < nsize) { + new_vector[osize++] = ECL_NO_TL_BINDING; + } + env->bds_stack.tl_bindings = new_vector; + env->bds_stack.tl_bindings_size = nsize; } return index; } @@ -479,15 +486,15 @@ ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v) cl_object *location; ecl_bds_ptr slot; cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { index = invalid_or_too_large_binding_index(env,s); } - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = *location; @@ -495,7 +502,7 @@ ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v) ecl_enable_interrupts_env(env); #else ecl_bds_check(env); - ecl_bds_ptr slot = ++(env->bds_top); + ecl_bds_ptr slot = ++(env->bds_stack.top); ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = s->symbol.value; @@ -511,15 +518,15 @@ ecl_bds_push(cl_env_ptr env, cl_object s) cl_object *location; ecl_bds_ptr slot; cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { index = invalid_or_too_large_binding_index(env,s); } - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = *location; @@ -527,7 +534,7 @@ ecl_bds_push(cl_env_ptr env, cl_object s) ecl_enable_interrupts_env(env); #else ecl_bds_check(env); - ecl_bds_ptr slot = ++(env->bds_top); + ecl_bds_ptr slot = ++(env->bds_stack.top); ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = s->symbol.value; @@ -538,14 +545,14 @@ ecl_bds_push(cl_env_ptr env, cl_object s) void ecl_bds_unwind1(cl_env_ptr env) { - cl_object s = env->bds_top->symbol; + cl_object s = env->bds_stack.top->symbol; #ifdef ECL_THREADS - cl_object *location = env->thread_local_bindings + s->symbol.binding; - *location = env->bds_top->value; + cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding; + *location = env->bds_stack.top->value; #else - s->symbol.value = env->bds_top->value; + s->symbol.value = env->bds_stack.top->value; #endif - --env->bds_top; + --env->bds_stack.top; } #ifdef ECL_THREADS @@ -553,8 +560,8 @@ cl_object ecl_bds_read(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object x = env->thread_local_bindings[index]; + if (index < env->bds_stack.tl_bindings_size) { + cl_object x = env->bds_stack.tl_bindings[index]; if (x != ECL_NO_TL_BINDING) return x; } return s->symbol.value; @@ -564,8 +571,8 @@ cl_object * ecl_bds_ref(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object *location = env->thread_local_bindings + index; + if (index < env->bds_stack.tl_bindings_size) { + cl_object *location = env->bds_stack.tl_bindings + index; if (*location != ECL_NO_TL_BINDING) return location; } @@ -579,92 +586,83 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) } #endif /* ECL_THREADS */ -/* ------------------------- INVOCATION STACK ------------------------- */ - -static ecl_ihs_ptr -get_ihs_ptr(cl_index n) -{ - cl_env_ptr env = ecl_process_env(); - ecl_ihs_ptr p = env->ihs_top; - if (n > p->index) - FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); - while (n < p->index) - p = p->next; - return p; -} - -cl_object -si_ihs_top(void) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->ihs_top->index)); -} - -cl_object -si_ihs_prev(cl_object x) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, cl_1M(x)); -} - -cl_object -si_ihs_next(cl_object x) +void +ecl_bds_set_limit(cl_env_ptr env, cl_index new_lim_size) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, cl_1P(x)); + 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"); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + 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); } -cl_object -si_ihs_bds(cl_object arg) +/* -- Invocation stack ------------------------------------------------------- */ +static void +ihs_init(cl_env_ptr env) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)); + static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; + env->ihs_stack.top = &ihs_org; + ihs_org.function = ECL_NIL; + ihs_org.lex_env = ECL_NIL; + ihs_org.index = 0; } -cl_object -si_ihs_fun(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function); -} +/* -- Frame stack ------------------------------------------------------------ */ -cl_object -si_ihs_env(cl_object arg) +static void +frs_init(cl_env_ptr env) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_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; } -/* ------------------------- FRAME STACK ------------------------------ */ - -static void -frs_set_size(cl_env_ptr env, cl_index new_size) +void +ecl_frs_set_limit(cl_env_ptr env, cl_index new_lim_size) { - ecl_frame_ptr old_org = env->frs_org; - cl_index limit = env->frs_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink frame stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - ecl_frame_ptr org; - env->frs_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->frs_top = org + limit; - env->frs_org = org; - env->frs_limit = org + (new_size - 2*margin); - env->frs_size = new_size; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_org); - } + 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"); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + 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) /* used as condition in list.d */ +frs_overflow(void) { static const char *stack_overflow_msg = "\n;;;\n;;; Frame stack overflow.\n" @@ -672,17 +670,15 @@ frs_overflow(void) /* used as condition in list.d */ ";;;\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_size; - ecl_frame_ptr org = env->frs_org; + 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_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); + if (env->frs_stack.limit >= last) { + ecl_internal_error(stack_overflow_msg); } - env->frs_limit += margin; - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::frame-stack'); - frs_set_size(env, size + size / 2); + env->frs_stack.limit += margin; + CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(limit_size), ECL_T); } ecl_frame_ptr @@ -693,55 +689,162 @@ _ecl_frs_push(cl_env_ptr env) * 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_top+1; - if (output >= env->frs_limit) { + ecl_frame_ptr output = env->frs_stack.top+1; + if (output >= env->frs_stack.limit) { frs_overflow(); - output = env->frs_top+1; + output = env->frs_stack.top+1; } output->frs_val = ECL_DUMMY_TAG; AO_nop_full(); - ++env->frs_top; - output->frs_bds_top_index = env->bds_top - env->bds_org; - output->frs_ihs = env->ihs_top; - output->frs_sp = ECL_STACK_INDEX(env); + ++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->nlj_fr = fr; - ecl_frame_ptr top = env->frs_top; + 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_top = top->frs_ihs; - ecl_bds_unwind(env, top->frs_bds_top_index); - ECL_STACK_SET_INDEX(env, top->frs_sp); - env->frs_top = top; - ecl_longjmp(env->frs_top->frs_jmpbuf, 1); + 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_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_frame_ptr top; - for (top = env->frs_top; top >= env->frs_org; top--) - if (top->frs_val == frame_id) - return(top); - return(NULL); + 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_org + ecl_fixnum(x); - if (env->frs_org <= p && p <= env->frs_top) + 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); @@ -751,14 +854,14 @@ cl_object si_frs_top() { cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->frs_top - env->frs_org)); + 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_top_index)); + ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx)); } cl_object @@ -781,13 +884,155 @@ 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_top && x->frs_ihs->index < y; + for (x = get_frame_ptr(fr); + x <= env->frs_stack.top && x->frs_ihs->index < y; x++); - ecl_return1(env, ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))); + 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) +{ + cl_env_ptr env = ecl_process_env(); + ecl_ihs_ptr p = env->ihs_stack.top; + if (n > p->index) + FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); + while (n < p->index) + p = p->next; + return p; +} + +cl_object +si_ihs_top(void) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(env->ihs_stack.top->index)); +} + +cl_object +si_ihs_prev(cl_object x) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, cl_1M(x)); +} + +cl_object +si_ihs_next(cl_object x) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, cl_1P(x)); +} + +cl_object +si_ihs_bds(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)); +} + +cl_object +si_ihs_fun(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function); +} + +cl_object +si_ihs_env(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env); +} + +/* -- General purpose stack implementation ----------------------------------- */ + +/* Stacks are based on actually adjustable simple vectors. */ +cl_object +ecl_make_stack(cl_index size) +{ + cl_object x = ecl_malloc(sizeof(struct ecl_vector)); + x->vector.elttype = ecl_aet_object; + x->vector.self.t = NULL; + x->vector.displaced = ECL_NIL; + x->vector.dim = size; + x->vector.fillp = 0; + x->vector.flags = ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER; + x->vector.self.t = (cl_object *)ecl_malloc(size * sizeof(cl_object)); + return x; +} +void +ecl_free_stack(cl_object self) +{ + ecl_free(self->vector.self.t); +} + +void +ecl_stack_resize(cl_object self, cl_index nsize) +{ + cl_index osize = self->vector.dim; + self->vector.self.t = (cl_object *)ecl_realloc(self->vector.self.t, + osize * sizeof(cl_object), + nsize * sizeof(cl_object)); + self->vector.dim = nsize; +} + +void +stack_ensure_size(cl_object self, cl_index nsize) +{ + if (nsize >= self->vector.dim) { + ecl_stack_resize(self, nsize); + } } -/* ------------------------- INITIALIZATION --------------------------- */ +cl_index +ecl_stack_index(cl_object self) { + return self->vector.fillp; +} + +cl_object +ecl_stack_push(cl_object self, cl_object elt) +{ + cl_index fillp = self->vector.fillp; + cl_index dim = self->vector.dim; + if (ecl_unlikely(fillp == dim)) { + cl_index new_dim = dim+dim/2+1; + ecl_stack_resize(self, new_dim); + } + self->vector.self.t[self->vector.fillp++] = elt; + return self; +} + +cl_object +ecl_stack_del(cl_object self, cl_object elt) +{ + cl_index idx; + cl_index ndx = self->vector.fillp; + cl_object *v = self->vector.self.t; + for(idx = 0; idx < ndx; idx++) { + if (v[idx] == elt) { + do { v[idx] = v[idx+1]; } while (++idx <= ndx); + ecl_stack_popu(self); + break; + } + } + return self; +} + +/* Unsafe operations */ + +cl_object +ecl_stack_popu(cl_object self) +{ + cl_object result = self->vector.self.t[--self->vector.fillp]; + self->vector.self.t[self->vector.fillp] = ECL_NIL; + return result; +} + +/* -- Lisp ops on stacks ---------------------------------------------------- */ cl_object si_set_limit(cl_object type, cl_object limit) @@ -795,20 +1040,27 @@ si_set_limit(cl_object type, cl_object limit) cl_env_ptr env = ecl_process_env(); cl_index margin; if (type == @'ext::frame-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - frs_set_size(env, the_size + 2*margin); + cl_index current_size = env->frs_stack.top - env->frs_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink frame stack below ~D.", 1, limit); + ecl_frs_set_limit(env, request_size); } else if (type == @'ext::binding-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_set_size(env, the_size + 2*margin); + 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); + 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); + 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); - } else if (type == @'ext::lisp-stack') { - cl_index the_size = ecl_to_size(limit); - ecl_stack_set_size(env, the_size); + 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() @@ -827,13 +1079,13 @@ si_get_limit(cl_object type) cl_env_ptr env = ecl_process_env(); cl_index output = 0; if (type == @'ext::frame-stack') - output = env->frs_limit_size; + output = env->frs_stack.limit_size; else if (type == @'ext::binding-stack') - output = env->bds_limit_size; - else if (type == @'ext::c-stack') - output = env->cs_limit_size; + output = env->bds_stack.limit_size; else if (type == @'ext::lisp-stack') - output = env->stack_limit_size; + output = env->run_stack.limit_size; + else if (type == @'ext::c-stack') + output = env->c_stack.limit_size; else if (type == @'ext::heap-size') { /* size_t can be larger than cl_index */ ecl_return1(env, ecl_make_unsigned_integer(cl_core.max_heap_size)); @@ -841,51 +1093,3 @@ si_get_limit(cl_object type) ecl_return1(env, ecl_make_unsigned_integer(output)); } - -cl_object -si_reset_margin(cl_object type) -{ - cl_env_ptr env = ecl_process_env(); - if (type == @'ext::frame-stack') - frs_set_size(env, env->frs_size); - else if (type == @'ext::binding-stack') - ecl_bds_set_size(env, env->bds_size); - else if (type == @'ext::c-stack') - cs_set_size(env, env->cs_size); - else - ecl_return1(env, ECL_NIL); - - ecl_return1(env, ECL_T); -} - -void -init_stacks(cl_env_ptr env) -{ - static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; - cl_index size, margin; - /* frame stack */ - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; - env->frs_size = size; - env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); - env->frs_top = env->frs_org-1; - env->frs_limit = &env->frs_org[size - 2*margin]; - /* bind stack */ - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; - env->bds_size = size; - env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); - env->bds_top = env->bds_org-1; - env->bds_limit = &env->bds_org[size - 2*margin]; - /* ihs stack */ - env->ihs_top = &ihs_org; - ihs_org.function = ECL_NIL; - ihs_org.lex_env = ECL_NIL; - ihs_org.index = 0; - /* lisp stack */ - env->stack = NULL; - env->stack_top = NULL; - env->stack_limit = NULL; - env->stack_size = 0; - ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); -} diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index f5da4b0720cb83607fe27e6ad014a089acc3e777..7a0d12046ae63993fc44e6bc667ee468c370ff14 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1270,7 +1270,6 @@ cl_symbols[] = { {EXT_ "SAFE-EVAL" ECL_FUN("si_safe_eval", ECL_NAME(si_safe_eval), -3) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {SYS_ "SCH-FRS-BASE" ECL_FUN("si_sch_frs_base", si_sch_frs_base, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SCHAR-SET" ECL_FUN("si_char_set", si_char_set, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "SERROR" ECL_FUN("si_serror", si_serror, -3) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SHARP-A-READER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SHARP-S-READER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SELECT-PACKAGE" ECL_FUN("si_select_package", si_select_package, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, @@ -1304,7 +1303,6 @@ cl_symbols[] = { {SYS_ "TERMINAL-INTERRUPT" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "TOP-LEVEL" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "UNIVERSAL-ERROR-HANDLER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "STACK-ERROR-HANDLER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "VALID-FUNCTION-NAME-P" ECL_FUN("si_valid_function_name_p", si_valid_function_name_p, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SEARCH-PRINT-CIRCLE" ECL_FUN("si_search_print_circle", si_search_print_circle, 1) ECL_VAR(SI_SPECIAL, OBJNULL)}, {SYS_ "WRITE-OBJECT-WITH-CIRCLE" ECL_FUN("si_write_object_with_circle", si_write_object_with_circle, 3) ECL_VAR(SI_SPECIAL, OBJNULL)}, @@ -1922,7 +1920,6 @@ cl_symbols[] = { {EXT_ "ILLEGAL-INSTRUCTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "SET-LIMIT" ECL_FUN("si_set_limit", si_set_limit, 2) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "GET-LIMIT" ECL_FUN("si_get_limit", si_get_limit, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, -{SYS_ "RESET-MARGIN" ECL_FUN("si_reset_margin", si_reset_margin, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "SEGMENTATION-VIOLATION" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "EXTENDED-STRING" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index ad06830ba3b5f80566dd1ba7ac9d0c24fad85c31..cdb2c33339b51f780e2f983214becabacdb49a95 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -222,7 +222,7 @@ thread_entry_point(void *arg) #ifndef ECL_WINDOWS_THREADS pthread_cleanup_push(thread_cleanup, (void *)process); #endif - ecl_cs_set_org(env); + ecl_cs_init(env); ecl_mutex_lock(&process->process.start_stop_lock); /* 2) Execute the code. The CATCH_ALL point is the destination @@ -273,26 +273,43 @@ thread_entry_point(void *arg) #endif } +static void +init_tl_bindings(cl_object process, cl_env_ptr env) +{ + cl_index bindings_size; + cl_object *bindings; + if (Null(process->process.inherit_bindings_p)) { + cl_index idx = 0, size = 256; + bindings_size = size; + bindings = (cl_object *)ecl_malloc(size*sizeof(cl_object*)); + for(idx=0; idx<256; idx++) { + bindings[idx] = ECL_NO_TL_BINDING; + } + } else { + cl_env_ptr parent_env = ecl_process_env(); + bindings_size = parent_env->bds_stack.tl_bindings_size; + bindings = (cl_object *)ecl_malloc(bindings_size*sizeof(cl_object*)); + ecl_copy(bindings, parent_env->bds_stack.tl_bindings, bindings_size*sizeof(cl_object*)); + } + env->bds_stack.tl_bindings_size = bindings_size; + env->bds_stack.tl_bindings = bindings; +} + static cl_object -alloc_process(cl_object name, cl_object initial_bindings) +alloc_process(cl_object name, cl_object initial_bindings_p) { cl_env_ptr env = ecl_process_env(); cl_object process = ecl_alloc_object(t_process), array; + cl_index bindings_size; + cl_object* bindings; process->process.phase = ECL_PROCESS_INACTIVE; process->process.name = name; process->process.function = ECL_NIL; process->process.args = ECL_NIL; process->process.interrupt = ECL_NIL; + process->process.inherit_bindings_p = Null(initial_bindings_p)? ECL_T : ECL_NIL; process->process.exit_values = ECL_NIL; process->process.env = NULL; - if (initial_bindings != ECL_NIL || env->bindings_array == OBJNULL) { - array = si_make_vector(ECL_T, ecl_make_fixnum(256), - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - } else { - array = cl_copy_seq(ecl_process_env()->bindings_array); - } - process->process.initial_bindings = array; process->process.woken_up = ECL_NIL; ecl_disable_interrupts_env(env); ecl_mutex_init(&process->process.start_stop_lock, TRUE); @@ -351,16 +368,14 @@ ecl_import_current_thread(cl_object name, cl_object bindings) /* Allocate real environment, link it together with process */ env = _ecl_alloc_env(0); - process = alloc_process(name, bindings); + process = alloc_process(name, ECL_NIL); process->process.env = env; process->process.phase = ECL_PROCESS_BOOTING; process->process.thread = current; /* Copy initial bindings from process to the fake environment */ env_aux->cleanup = registered; - env_aux->bindings_array = process->process.initial_bindings; - env_aux->thread_local_bindings_size = env_aux->bindings_array->vector.dim; - env_aux->thread_local_bindings = env_aux->bindings_array->vector.self.t; + init_tl_bindings(process, env_aux); /* Switch over to the real environment */ memcpy(env, env_aux, sizeof(*env)); @@ -390,10 +405,10 @@ ecl_release_current_thread(void) #endif } -@(defun mp::make-process (&key name ((:initial-bindings initial_bindings) ECL_T)) +@(defun mp::make-process (&key name ((:initial-bindings initial_bindings_p) ECL_T)) cl_object process; @ - process = alloc_process(name, initial_bindings); + process = alloc_process(name, initial_bindings_p); @(return process); @) @@ -515,11 +530,7 @@ mp_process_enable(cl_object process) ecl_init_env(process_env); process_env->trap_fpe_bits = process->process.trap_fpe_bits; - process_env->bindings_array = process->process.initial_bindings; - process_env->thread_local_bindings_size = - process_env->bindings_array->vector.dim; - process_env->thread_local_bindings = - process_env->bindings_array->vector.self.t; + init_tl_bindings(process, process_env); ecl_disable_interrupts_env(the_env); #ifdef ECL_WINDOWS_THREADS @@ -588,7 +599,7 @@ mp_exit_process(void) UNWIND-PROTECT. */ const cl_env_ptr the_env = ecl_process_env(); - ecl_unwind(the_env, the_env->frs_org); + ecl_unwind(the_env, the_env->frs_stack.org); /* Never reached */ } @@ -750,6 +761,7 @@ init_threads() ecl_thread_t main_thread; /* We have to set the environment before any allocation takes place, * so that the interrupt handling code works. */ + ecl_cs_init(the_env); ecl_set_process_self(main_thread); process = ecl_alloc_object(t_process); process->process.phase = ECL_PROCESS_ACTIVE; diff --git a/src/c/unixint.d b/src/c/unixint.d index adf30aa97cfc9edcc1fa9d5c7e64d4a867ad0c1e..7d6ad09ada3dfb8a6808ee3ec0251befd695ef14 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -389,24 +389,24 @@ handle_all_queued_interrupt_safe(cl_env_ptr env) cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER]; memcpy(big_register, env->big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object)); ecl_init_bignum_registers(env); - /* We might have been interrupted while we push/pop in the - * stack. Increasing env->stack_top ensures that we don't - * overwrite the topmost stack value. */ - env->stack_top++; + /* We might have been interrupted while we push/pop in the stack. Increasing + * env->run_stack.top ensures that we don't overwrite the topmost stack + * value. */ + env->run_stack.top++; /* We also need to save and restore the (top+1)'th frame and * binding stack value to prevent overwriting it. * INV: Due to the stack safety areas we don't need to check * for env->frs/bds_limit */ struct ecl_frame top_frame; - memcpy(&top_frame, env->frs_top+1, sizeof(struct ecl_frame)); + memcpy(&top_frame, env->frs_stack.top+1, sizeof(struct ecl_frame)); struct ecl_bds_frame top_binding; - memcpy(&top_binding, env->bds_top+1, sizeof(struct ecl_bds_frame)); + memcpy(&top_binding, env->bds_stack.top+1, sizeof(struct ecl_bds_frame)); /* Finally we can handle the queued signals ... */ handle_all_queued(env); /* ... and restore everything again */ - memcpy(env->bds_top+1, &top_binding, sizeof(struct ecl_bds_frame)); - memcpy(env->frs_top+1, &top_frame, sizeof(struct ecl_frame)); - env->stack_top--; + memcpy(env->bds_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame)); + memcpy(env->frs_stack.top+1, &top_frame, sizeof(struct ecl_frame)); + env->run_stack.top--; ecl_clear_bignum_registers(env); memcpy(env->big_register, big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object)); env->packages_to_be_created_p = packages_to_be_created_p; @@ -445,8 +445,7 @@ queue_signal(cl_env_ptr env, cl_object code, int allocate) ECL_RPLACA(record, code); ECL_RPLACD(record, ECL_NIL); env->interrupt_struct->pending_interrupt = - ecl_nconc(env->interrupt_struct->pending_interrupt, - record); + ecl_nconc(env->interrupt_struct->pending_interrupt, record); } #ifdef ECL_THREADS @@ -829,16 +828,16 @@ handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux) # endif /* ECL_USE_MPROTECT */ # ifdef ECL_DOWN_STACK if (sig == SIGSEGV && - (char*)info->si_addr > the_env->cs_barrier && - (char*)info->si_addr <= the_env->cs_org) { + (char*)info->si_addr > the_env->c_stack.max && + (char*)info->si_addr <= the_env->c_stack.org) { unblock_signal(the_env, sig); ecl_unrecoverable_error(the_env, stack_overflow_msg); return; } # else if (sig == SIGSEGV && - (char*)info->si_addr < the_env->cs_barrier && - (char*)info->si_addr >= the_env->cs_org) { + (char*)info->si_addr < the_env->c_stack.max && + (char*)info->si_addr >= the_env->c_stack.org) { unblock_signal(the_env, sig); ecl_unrecoverable_error(the_env, stack_overflow_msg); return; diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index fbc3686f71a424ffea7c7c7f4e4915fe652955e0..87c82a4a772d54f3d17d22a84a688ac5854b9231 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -879,10 +879,5 @@ strings." (signal condition) (invoke-debugger condition)))))) -(defun sys::stack-error-handler (continue-string datum args) - (unwind-protect (universal-error-handler continue-string datum args) - (si:reset-margin - (getf args :type)))) - (defun sys::tpl-continue-command (&rest any) (apply #'invoke-restart 'continue any)) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 9ab0f07cefd21283ee07f002252ea004a7b4d1e8..4993a8ed41692124565c1991c349eceec0a59e34 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -15,11 +15,6 @@ ;;; --------------------------------------------------------------------- ;;; Fixup -;;; Early version of the stack handler. -(defun sys::stack-error-handler (continue-string datum args) - (declare (ignore continue-string)) - (apply #'error datum args)) - (defun register-method-with-specializers (method) (declare (si::c-local)) (with-early-accessors (+standard-method-slots+ +specializer-slots+) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index f652e7058a94eab1b435689994dc90c65f0d8b64..cb8567f7b1705c92f82604106b1664c28a9c92f3 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -149,7 +149,7 @@ (wt-nl "volatile bool unwinding = FALSE;") (wt-nl "ecl_frame_ptr next_fr;") (with-unwind-frame ("ECL_PROTECT_TAG") - (wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;") + (wt-nl " unwinding = TRUE; next_fr=cl_env_copy->frs_stack.nlj_fr;") (let ((*destination* 'VALUEZ)) (c2expr* form))) (wt-nl "ecl_frs_pop(cl_env_copy);") diff --git a/src/doc/manual/extensions/mp_ref_process.txi b/src/doc/manual/extensions/mp_ref_process.txi index 3857d1a99d2714cddcb6edf1ea162a20f48be7f7..d25cd6976e8857aed434a0473249a92adee58665 100644 --- a/src/doc/manual/extensions/mp_ref_process.txi +++ b/src/doc/manual/extensions/mp_ref_process.txi @@ -96,8 +96,8 @@ set to @var{name} and no function to run. See also If @var{initial-bindings} is false, the new process inherits local bindings to special variables (i.e. binding a special variable with -@code{let} or @code{let*}) from the current thread, otherwise the new -thread possesses no local bindings. +@code{let} or @code{let*}) from the thread that enables it, otherwise +the new thread initially possesses no local bindings. @end defun diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index 16101fc939051182887a17f4655727e190f2c03f..c12bf08218552f938e811b51f99ecf9fd0282010 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -82,6 +82,44 @@ } else do { #define end_loop_for_on(list) } while (list = ECL_CONS_CDR(list), ECL_CONSP(list)) +/* + * Loops over a vector. + */ +#define loop_across_stack_fifo(var, obj) { \ + cl_index __ecl_idx; \ + cl_index __ecl_ndx = obj->vector.fillp; \ + cl_object *__ecl_v = obj->vector.self.t; \ + for(__ecl_idx = 0; __ecl_idx < __ecl_ndx; __ecl_idx++) { \ + cl_object var = __ecl_v[__ecl_idx]; + + +#define loop_across_stack_filo(var, obj) { \ + cl_index __ecl_idx; \ + cl_index __ecl_ndx = obj->vector.fillp; \ + cl_object *__ecl_v = obj->vector.self.t; \ + for(__ecl_idx = __ecl_ndx; __ecl_idx > 0; __ecl_idx--) { \ + cl_object var = __ecl_v[__ecl_idx-1]; + +#define end_loop_across_stack() }} + +/* + * Loops over a stack frame. + */ + +#define loop_across_frame_fifo(var, obj) { \ + cl_object *__ecl_ptr = ECL_STACK_FRAME_PTR(obj); \ + cl_object *__ecl_top = ECL_STACK_FRAME_TOP(obj); \ + while(__ecl_ptr++ < __ecl_top) { \ + cl_object var = *(__ecl_ptr-1); \ + +#define loop_across_frame_filo(var, obj) { \ + cl_object *__ecl_ptr = ECL_STACK_FRAME_PTR(obj); \ + cl_object *__ecl_top = ECL_STACK_FRAME_TOP(obj); \ + while(__ecl_ptr < __ecl_top--) { \ + cl_object var = *__ecl_top; + +#define end_loop_across_frame() }} + /* * Static constant definition. */ diff --git a/src/h/external.h b/src/h/external.h index d2775591474563470cdca94712b9932f5f00d159..e1af3207bf74a3e3136c18c436076c46527a1008 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -10,6 +10,56 @@ extern "C" { #define _ECL_ARGS(x) x +/* The runtime stack, which is used mainly for keeping the arguments of a + * function before it is invoked, and also by the compiler and by the reader + * when they are building some data structure. */ +struct ecl_runtime_stack { + cl_index size; + cl_index limit_size; + cl_object *org; + cl_object *top; + cl_object *limit; +}; + +/* The BinDing Stack stores the bindings of special variables. */ +struct ecl_binding_stack { + cl_index size; + cl_index limit_size; + struct ecl_bds_frame *org; + struct ecl_bds_frame *top; + struct ecl_bds_frame *limit; +#ifdef ECL_THREADS + cl_index tl_bindings_size; + cl_object *tl_bindings; +#endif +}; + +struct ecl_frames_stack { + cl_index size; + cl_index limit_size; + struct ecl_frame *org; + struct ecl_frame *top; + struct ecl_frame *limit; + /* extra */ + struct ecl_frame *nlj_fr; + cl_index frame_id; +}; + +struct ecl_history_stack { + struct ecl_ihs_frame *top; +}; + +struct ecl_c_stack { + cl_index size; /* current size */ + cl_index limit_size; /* maximum size minus safety area */ + char *org; /* origin address */ + char *max; /* overflow address (real maximum address) */ + char *limit; /* overflow address (spares recovery area) */ + /* extra */ + cl_index max_size; /* maximum possible size */ +}; + + /* * Per-thread data. */ @@ -19,109 +69,70 @@ struct cl_env_struct { /* Flag for disabling interrupts while we call C library functions. */ volatile int disable_interrupts; - /* Array where values are returned by functions. */ + /* -- ECL runtime ---------------------------------------------------- */ + /* Array where values are returned. */ cl_index nvalues; cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; + /* ECL stacks. */ + + /* The Runtime Stack is used mainly for keeping the arguments of a + * function before it is invoked, and also by the compiler and by the + * reader when they are building some data structure. */ + struct ecl_runtime_stack run_stack; + /* The BinDing Stack stores the bindings of special variables. */ + struct ecl_binding_stack bds_stack; + /* The FRames Stack (FRS) is a list of frames or jump points, and it is + * used by different high-level constructs (BLOCK, TAGBODY, CATCH...) + * to set return points. */ + struct ecl_frames_stack frs_stack; + /* The Invocation History Stack (IHS) keeps a list of the names of the + * functions that are invoked with their lexical environments. */ + struct ecl_history_stack ihs_stack; + /* The following pointers to the C Stack are used to ensure that a + * recursive function does not enter an infinite loop and exhausts all + * memory. They will eventually disappear, because most operating + * systems already take care of this. */ + struct ecl_c_stack c_stack; /* shadow stack */ + /* -- Invocation of closures, generic function, etc ------------------ */ cl_object function; cl_object stepper; /* Hook invoked by ByteVM */ cl_object stack_frame; /* Current stack frame */ - /* The four stacks in ECL. */ - - /* - * The lisp stack, which is used mainly for keeping the arguments of a - * function before it is invoked, and also by the compiler and by the - * reader when they are building some data structure. - */ - cl_index stack_size; - cl_index stack_limit_size; - cl_object *stack; - cl_object *stack_top; - cl_object *stack_limit; - - /* - * The BinDing Stack stores the bindings of special variables. - */ + /* -- System Processes (native threads) ------------------------------ */ #ifdef ECL_THREADS - cl_index thread_local_bindings_size; - cl_object *thread_local_bindings; - cl_object bindings_array; + cl_object own_process; /* Backpointer to the host process. */ + int cleanup; #endif - cl_index bds_size; - cl_index bds_limit_size; - struct ecl_bds_frame *bds_org; - struct ecl_bds_frame *bds_top; - struct ecl_bds_frame *bds_limit; - - /* - * The Invocation History Stack (IHS) keeps a list of the names of the - * functions that are invoked, together with their lexical - * environments. - */ - struct ecl_ihs_frame *ihs_top; - - /* - * The FRames Stack (FRS) is a list of frames or jump points, and it - * is used by different high-level constructs (BLOCK, TAGBODY, CATCH...) - * to set return points. - */ - cl_index frs_size; - cl_index frs_limit_size; - struct ecl_frame *frs_org; - struct ecl_frame *frs_top; - struct ecl_frame *frs_limit; - struct ecl_frame *nlj_fr; - cl_index frame_id; - /* - * The following pointers to the C Stack are used to ensure that a - * recursive function does not enter an infinite loop and exhausts all - * memory. They will eventually disappear, because most operating - * systems already take care of this. - */ - cl_index cs_size; /* current size */ - cl_index cs_limit_size; /* current size minus safety area */ - cl_index cs_max_size; /* maximum possible size */ - char *cs_org; /* origin address */ - char *cs_limit; /* limit address; if the stack pointer - goes beyond this value, a stack - overflow will be signaled ... */ - char *cs_barrier; /* ... but the area up to cs_barrier - is still available to allow - programs to recover from the - stack overflow */ - - /* Private variables used by different parts of ECL: */ + /* -- System Interrupts ---------------------------------------------- */ + /* The objects in this struct need to be writeable from a different + thread, if environment is write-protected by mprotect. Hence they + have to be allocated seperately. */ + struct ecl_interrupt_struct *interrupt_struct; + void *default_sigmask; + /* Floating point interrupts which are trapped */ + int trap_fpe_bits; + /* Segmentation fault address */ + void *fault_address; + + /* -- Private variables used by different parts of ECL ---------------- */ /* ... the reader and printer ... */ cl_object string_pool; - /* ... the compiler ... */ struct cl_compiler_env *c_env; - /* ... the formatter ... */ #if !defined(ECL_CMU_FORMAT) cl_object fmt_aux_stream; #endif - /* ... arithmetics ... */ cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER]; - - cl_object own_process; - /* The objects in this struct need to be writeable from a - different thread, if environment is write-protected by - mprotect. Hence they have to be allocated seperately. */ - struct ecl_interrupt_struct *interrupt_struct; - void *default_sigmask; - - /* The following is a hash table for caching invocations of - generic functions. In a multithreaded environment we must - queue operations in which the hash is cleared from updated - generic functions. */ + /* The following is a hash table for caching invocations of generic + functions. In a multithreaded environment we must queue operations in + which the hash is cleared from updated generic functions. */ struct ecl_cache *method_cache; struct ecl_cache *slot_cache; - /* foreign function interface */ #ifdef HAVE_LIBFFI cl_index ffi_args_limit; @@ -129,21 +140,10 @@ struct cl_env_struct { union ecl_ffi_values *ffi_values; union ecl_ffi_values **ffi_values_ptrs; #endif - - /* Floating point interrupts which are trapped */ - int trap_fpe_bits; - /* List of packages interned when loading a FASL but which have * to be explicitely created by the compiled code itself. */ cl_object packages_to_be_created; cl_object packages_to_be_created_p; - - /* Segmentation fault address */ - void *fault_address; - -#ifdef ECL_THREADS - int cleanup; -#endif }; struct ecl_interrupt_struct { @@ -318,6 +318,11 @@ extern ECL_API cl_index cl_num_symbols_in_core; extern ECL_API cl_object APPLY_fixed(cl_narg n, cl_object (*f)(), cl_object *x); extern ECL_API cl_object APPLY(cl_narg n, cl_objectfn, cl_object *x); +/* stack.c */ +extern ECL_API cl_object ecl_make_stack(cl_index dim); +extern ECL_API cl_object ecl_stack_push(cl_object stack, cl_object elt); +extern ECL_API cl_object ecl_stack_del(cl_object stack, cl_object elt); +extern ECL_API cl_object ecl_stack_popu(cl_object stack); /* array.c */ @@ -534,17 +539,16 @@ extern ECL_API cl_object si_eval_with_env _ECL_ARGS((cl_narg narg, cl_object for extern ECL_API cl_object si_interpreter_stack(); extern ECL_API cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size); extern ECL_API void ecl_stack_frame_push(cl_object f, cl_object o); +extern ECL_API cl_object ecl_stack_frame_pop(cl_object f); extern ECL_API void ecl_stack_frame_push_values(cl_object f); extern ECL_API cl_object ecl_stack_frame_pop_values(cl_object f); extern ECL_API void ecl_stack_frame_close(cl_object f); #define si_apply_from_stack_frame ecl_apply_from_stack_frame -extern ECL_API void FEstack_underflow(void) ecl_attr_noreturn; -extern ECL_API void FEstack_advance(void) ecl_attr_noreturn; -extern ECL_API cl_object *ecl_stack_grow(cl_env_ptr env); -extern ECL_API cl_object *ecl_stack_set_size(cl_env_ptr env, cl_index new_size); -extern ECL_API cl_index ecl_stack_push_values(cl_env_ptr env); -extern ECL_API void ecl_stack_pop_values(cl_env_ptr env, cl_index n); +extern ECL_API cl_object *ecl_data_stack_grow(cl_env_ptr env); +extern ECL_API cl_object *ecl_data_stack_set_size(cl_env_ptr env, cl_index new_size); +extern ECL_API cl_index ecl_data_stack_push_values(cl_env_ptr env); +extern ECL_API void ecl_data_stack_pop_values(cl_env_ptr env, cl_index n); extern ECL_API cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes); extern ECL_API cl_object _ecl_bytecodes_dispatch(cl_narg narg, ...); extern ECL_API cl_object _ecl_bclosure_dispatch(cl_narg narg, ...); @@ -596,6 +600,7 @@ extern ECL_API void FEtimeout() ecl_attr_noreturn; extern ECL_API void FEerror_not_owned(cl_object lock) ecl_attr_noreturn; extern ECL_API void FEunknown_lock_error(cl_object lock) ecl_attr_noreturn; extern ECL_API cl_object CEerror(cl_object c, const char *err_str, int narg, ...); +extern ECL_API void CEstack_overflow(cl_object type, cl_object limit, cl_object resume); extern ECL_API void FElibc_error(const char *msg, int narg, ...) ecl_attr_noreturn; #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) extern ECL_API void FEwin32_error(const char *msg, int narg, ...) ecl_attr_noreturn; @@ -1642,12 +1647,11 @@ extern ECL_API cl_object si_bds_var(cl_object arg); extern ECL_API cl_object si_bds_val(cl_object arg); extern ECL_API cl_object si_sch_frs_base(cl_object fr, cl_object ihs); extern ECL_API cl_object si_reset_stack_limits(void); -extern ECL_API cl_object si_reset_margin(cl_object type); extern ECL_API cl_object si_set_limit(cl_object type, cl_object size); extern ECL_API cl_object si_get_limit(cl_object type); extern ECL_API cl_index ecl_progv(cl_env_ptr env, cl_object vars, cl_object values); -extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index); +extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx); extern ECL_API void ecl_unwind(cl_env_ptr env, struct ecl_frame *fr) ecl_attr_noreturn; extern ECL_API struct ecl_frame *frs_sch(cl_object frame_id); diff --git a/src/h/internal.h b/src/h/internal.h index 296f7520b818b0120a05932b0d0ffe394d51d75a..ac05fa98a3549f189c42fbe0b4f9744566a2d158 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); @@ -298,9 +301,6 @@ struct cl_compiler_ref { extern void _ecl_unexpected_return() ecl_attr_noreturn; extern cl_object _ecl_strerror(int code); -extern ECL_API cl_object si_serror _ECL_ARGS -((cl_narg narg, cl_object cformat, cl_object eformat, ...)); - /* eval.d */ @@ -552,12 +552,16 @@ extern cl_object ecl_deserialize(uint8_t *data); /* stacks.d */ #define CL_NEWENV_BEGIN {\ const cl_env_ptr the_env = ecl_process_env(); \ - cl_index __i = ecl_stack_push_values(the_env); \ + cl_index __i = ecl_data_stack_push_values(the_env); \ #define CL_NEWENV_END \ - ecl_stack_pop_values(the_env,__i); } + ecl_data_stack_pop_values(the_env,__i); } -extern void ecl_cs_set_org(cl_env_ptr env); +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 diff --git a/src/h/object.h b/src/h/object.h index e0ee2fb348e54bf78cddf964eca659cc255d782b..1906181facf61f04a709c6a4a504b18de7a3fec3 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -989,7 +989,7 @@ struct ecl_process { cl_object args; struct cl_env_struct *env; cl_object interrupt; - cl_object initial_bindings; + cl_object inherit_bindings_p; cl_object parent; cl_object exit_values; cl_object woken_up; diff --git a/src/h/stacks.h b/src/h/stacks.h index 1c38c41c382db361c0c74e9ee7138dedb1f1a85c..9aa029f364dd28828796a6fc7ba38c9dd3a6e342 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -27,10 +27,10 @@ extern "C" { #ifdef ECL_DOWN_STACK #define ecl_cs_check(env,var) \ - if (ecl_unlikely((char*)(&var) <= (env)->cs_limit)) ecl_cs_overflow() + if (ecl_unlikely((char*)(&var) <= (env)->c_stack.limit)) ecl_cs_overflow() #else #define ecl_cs_check(env,var) \ - if (ecl_unlikely((char*)(&var) >= (env)->cs_limit)) ecl_cs_overflow() + if (ecl_unlikely((char*)(&var) >= (env)->c_stack.limit)) ecl_cs_overflow() #endif /********************************************************* @@ -78,7 +78,7 @@ typedef struct ecl_bds_frame { } *ecl_bds_ptr; #define ecl_bds_check(env) \ - (ecl_unlikely(env->bds_top >= env->bds_limit)? (ecl_bds_overflow(),1) : 0) + (ecl_unlikely(env->bds_stack.top >= env->bds_stack.limit)? (ecl_bds_overflow(),1) : 0) #define ECL_MISSING_SPECIAL_BINDING (~((cl_index)0)) @@ -100,25 +100,25 @@ extern ECL_API cl_object ecl_bds_set(cl_env_ptr env, cl_object s, cl_object v); # define ECL_SETQ(env,s,v) ((s)->symbol.value=(v)) #endif -#ifdef __GNUC__ -static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) +#ifdef ECL_THREADS +static inline void +ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) { ecl_bds_ptr slot; -# ifdef ECL_THREADS cl_object *location; const cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { ecl_bds_bind(env,s,v); } else { - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); /* First, we push a dummy symbol in the stack to * prevent segfaults when we are interrupted with a * call to ecl_bds_unwind. */ slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; /* Then we disable interrupts to ensure that * ecl_bds_unwind doesn't overwrite the symbol with * some random value. */ @@ -128,115 +128,102 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) *location = v; ecl_enable_interrupts_env(env); } -# else - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - ecl_disable_interrupts_env(env); - slot->symbol = s; - slot->value = s->symbol.value; - s->symbol.value = v; - ecl_enable_interrupts_env(env); -# endif /* !ECL_THREADS */ } -static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) +static inline void +ecl_bds_push_inl(cl_env_ptr env, cl_object s) { ecl_bds_ptr slot; -# ifdef ECL_THREADS cl_object *location; const cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { ecl_bds_push(env, s); } else { - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = *location; if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; ecl_enable_interrupts_env(env); } -# else - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - ecl_disable_interrupts_env(env); - slot->symbol = s; - slot->value = s->symbol.value; - ecl_enable_interrupts_env(env); -# endif /* !ECL_THREADS */ } -static inline void ecl_bds_unwind1_inl(cl_env_ptr env) +static inline void +ecl_bds_unwind1_inl(cl_env_ptr env) { - cl_object s = env->bds_top->symbol; -# ifdef ECL_THREADS - cl_object *location = env->thread_local_bindings + s->symbol.binding; - *location = env->bds_top->value; -# else - s->symbol.value = env->bds_top->value; -# endif - --env->bds_top; + cl_object s = env->bds_stack.top->symbol; + cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding; + *location = env->bds_stack.top->value; + --env->bds_stack.top; } -# ifdef ECL_THREADS -static inline cl_object ecl_bds_read_inl(cl_env_ptr env, cl_object s) +static inline cl_object +ecl_bds_read_inl(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object x = env->thread_local_bindings[index]; + if (index < env->bds_stack.tl_bindings_size) { + cl_object x = env->bds_stack.tl_bindings[index]; if (x != ECL_NO_TL_BINDING) return x; } return s->symbol.value; } -static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s) +static inline cl_object * +ecl_bds_ref_inl(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object *location = env->thread_local_bindings + index; + if (index < env->bds_stack.tl_bindings_size) { + cl_object *location = env->bds_stack.tl_bindings + index; if (*location != ECL_NO_TL_BINDING) return location; } return &s->symbol.value; } -# define ecl_bds_set(env,s,v) (*ecl_bds_ref_inl(env,s)=(v)) -# define ecl_bds_read ecl_bds_read_inl -# endif -# define ecl_bds_bind ecl_bds_bind_inl -# define ecl_bds_push ecl_bds_push_inl -# define ecl_bds_unwind1 ecl_bds_unwind1_inl -#else /* !__GNUC__ */ -# ifndef ECL_THREADS -# define ecl_bds_bind(env,sym,val) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = (sym); \ - const cl_object v = (val); \ - ecl_bds_check(env_copy); \ - ecl_bds_ptr slot = ++(env_copy->bds_top); \ - ecl_disable_interrupts_env(env_copy); \ - slot->symbol = s; \ - slot->value = s->symbol.value; \ - s->symbol.value = v; \ - ecl_enable_interrupts_env(env_copy); } while (0) -# define ecl_bds_push(env,sym) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = (sym); \ - const cl_object v = s->symbol.value; \ - ecl_bds_check(env_copy); \ - ecl_bds_ptr slot = ++(env_copy->bds_top); \ - ecl_disable_interrupts_env(env_copy); \ - slot->symbol = s; \ - slot->value = s->symbol.value; \ - ecl_enable_interrupts_env(env_copy); } while (0); -# define ecl_bds_unwind1(env) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = env_copy->bds_top->symbol; \ - s->symbol.value = env_copy->bds_top->value; \ - --(env_copy->bds_top); } while (0) -# endif /* !ECL_THREADS */ -#endif /* !__GNUC__ */ + +# define ecl_bds_set(env,s,v) (*ecl_bds_ref_inl(env,s)=(v)) +# define ecl_bds_read ecl_bds_read_inl + +#else /* ECL_THREADS */ +static inline void +ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) +{ + ecl_bds_ptr slot; + slot = ++env->bds_stack.top; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); + ecl_disable_interrupts_env(env); + slot->symbol = s; + slot->value = s->symbol.value; + s->symbol.value = v; + ecl_enable_interrupts_env(env); +} + +static inline void +ecl_bds_push_inl(cl_env_ptr env, cl_object s) +{ + ecl_bds_ptr slot; + slot = ++env->bds_stack.top; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); + ecl_disable_interrupts_env(env); + slot->symbol = s; + slot->value = s->symbol.value; + ecl_enable_interrupts_env(env); +} + +static inline void +ecl_bds_unwind1_inl(cl_env_ptr env) +{ + cl_object s = env->bds_stack.top->symbol; + s->symbol.value = env->bds_stack.top->value; + --env->bds_stack.top; +} +#endif /* ECL_THREADS */ + +#define ecl_bds_bind ecl_bds_bind_inl +#define ecl_bds_push ecl_bds_push_inl +#define ecl_bds_unwind1 ecl_bds_unwind1_inl /**************************** * INVOCATION HISTORY STACK @@ -253,18 +240,18 @@ typedef struct ecl_ihs_frame { #define ecl_ihs_push(env,rec,fun,lisp_env) do { \ const cl_env_ptr __the_env = (env); \ ecl_ihs_ptr const r = (ecl_ihs_ptr const)(rec); \ - r->next=__the_env->ihs_top; \ - r->function=(fun); \ - r->lex_env=(lisp_env); \ - r->index=__the_env->ihs_top->index+1; \ - r->bds=__the_env->bds_top - __the_env->bds_org; \ - __the_env->ihs_top = r; \ + r->next=__the_env->ihs_stack.top; \ + r->function=(fun); \ + r->lex_env=(lisp_env); \ + r->index=__the_env->ihs_stack.top->index+1; \ + r->bds=__the_env->bds_stack.top - __the_env->bds_stack.org; \ + __the_env->ihs_stack.top = r; \ } while(0) #define ecl_ihs_pop(env) do { \ const cl_env_ptr __the_env = (env); \ - ecl_ihs_ptr r = __the_env->ihs_top; \ - if (r) __the_env->ihs_top = r->next; \ + ecl_ihs_ptr r = __the_env->ihs_stack.top; \ + if (r) __the_env->ihs_stack.top = r->next; \ } while(0) /*************** @@ -293,9 +280,9 @@ typedef struct ecl_ihs_frame { typedef struct ecl_frame { jmp_buf frs_jmpbuf; cl_object frs_val; - cl_index frs_bds_top_index; ecl_ihs_ptr frs_ihs; - cl_index frs_sp; + cl_index frs_bds_ndx; + cl_index frs_run_ndx; } *ecl_frame_ptr; extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); @@ -306,8 +293,8 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); int __ecl_frs_push_result = ecl_setjmp(__frame->frs_jmpbuf); \ ecl_enable_interrupts_env(env) -#define ecl_frs_pop(env) ((env)->frs_top--) -#define ecl_frs_pop_n(env,n) ((env)->frs_top-=n) +#define ecl_frs_pop(env) ((env)->frs_stack.top--) +#define ecl_frs_pop_n(env,n) ((env)->frs_stack.top-=n) /******************* * ARGUMENTS STACK @@ -377,51 +364,65 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); * LISP STACK *************/ -#define ECL_STACK_INDEX(env) ((env)->stack_top - (env)->stack) - -#define ECL_STACK_PUSH(the_env,o) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->stack_top; \ - if (ecl_unlikely(__new_top >= __env->stack_limit)) { \ - __new_top = ecl_stack_grow(__env); \ - } \ - __env->stack_top = __new_top+1; \ - *__new_top = (o); } while (0) +static inline void +ecl_data_stack_push(cl_env_ptr env, cl_object o) { + cl_object *new_top = env->run_stack.top; + if (ecl_unlikely(new_top >= env->run_stack.limit)) { + new_top = ecl_data_stack_grow(env); + } + env->run_stack.top = new_top+1; + *new_top = (o); +} -#define ECL_STACK_POP_UNSAFE(env) *(--((env)->stack_top)) +static inline void +ecl_data_stack_push_n(cl_env_ptr env, cl_index n) { + cl_object *new_top = env->run_stack.top; + while (ecl_unlikely((env->run_stack.limit - new_top) <= n)) { + new_top = ecl_data_stack_grow(env); + } + env->run_stack.top = new_top + n; +} -#define ECL_STACK_REF(env,n) ((env)->stack_top[n]) +static inline cl_object +ecl_data_stack_pop_unsafe(cl_env_ptr env) +{ + return *(--((env)->run_stack.top)); +} -#define ECL_STACK_SET_INDEX(the_env,ndx) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->stack + (ndx); \ - if (ecl_unlikely(__new_top > __env->stack_top)) \ - FEstack_advance(); \ - __env->stack_top = __new_top; } while (0) +static inline void +ecl_data_stack_pop_n_unsafe(cl_env_ptr env, cl_index n) +{ + env->run_stack.top -= n; +} -#define ECL_STACK_POP_N(the_env,n) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->stack_top - (n); \ - if (ecl_unlikely(__new_top < __env->stack)) \ - FEstack_underflow(); \ - __env->stack_top = __new_top; } while (0) +static inline cl_index +ecl_data_stack_index(cl_env_ptr env) { + return (env)->run_stack.top - (env)->run_stack.org; +} -#define ECL_STACK_POP_N_UNSAFE(the_env,n) ((the_env)->stack_top -= (n)) +static inline void +ecl_data_stack_set_index(cl_env_ptr env, cl_index ndx) +{ + env->run_stack.top = env->run_stack.org + (ndx); +} -#define ECL_STACK_PUSH_N(the_env,n) do { \ - const cl_env_ptr __env = (the_env) ; \ - cl_index __aux = (n); \ - cl_object *__new_top = __env->stack_top; \ - while (ecl_unlikely((__env->stack_limit - __new_top) <= __aux)) { \ - __new_top = ecl_stack_grow(__env); \ - } \ - __env->stack_top = __new_top + __aux; } while (0) +#define ECL_STACK_REF(env,n) ((env)->run_stack.top[n]) +#define ECL_STACK_INDEX(env) ecl_data_stack_index(env) +#define ECL_STACK_UNWIND(env,ndx) ecl_data_stack_set_index(env,ndx) +#define ECL_STACK_PUSH_N(env,n) ecl_data_stack_push_n(env,n) +#define ECL_STACK_PUSH(env,o) ecl_data_stack_push(env,o) +#define ECL_STACK_POP_UNSAFE(env) ecl_data_stack_pop_unsafe(env) +#define ECL_STACK_POP_N_UNSAFE(env,o) ecl_data_stack_pop_n_unsafe(env,o) -#define ECL_STACK_FRAME_REF(f,ndx) ((f)->frame.env->stack[(f)->frame.base+(ndx)]) -#define ECL_STACK_FRAME_SET(f,ndx,o) do { ECL_STACK_FRAME_REF(f,ndx) = (o); } while(0) +#define ECL_STACK_FRAME_REF(f,ndx) \ + ((f)->frame.env->run_stack.org[(f)->frame.base+(ndx)]) +#define ECL_STACK_FRAME_SET(f,ndx,o) \ + do { ECL_STACK_FRAME_REF(f,ndx) = (o); } while(0) -#define ECL_STACK_FRAME_PTR(f) ((f)->frame.env->stack+(f)->frame.base) -#define ECL_STACK_FRAME_TOP(f) ((f)->frame.env->stack+(f)->frame.sp) +#define ECL_STACK_FRAME_PTR(f) \ + ((f)->frame.env->run_stack.org+(f)->frame.base) +#define ECL_STACK_FRAME_TOP(f) \ + ((f)->frame.env->run_stack.org+(f)->frame.sp) #define ECL_STACK_FRAME_COPY(dest,orig) do { \ cl_object __dst = (dest); \ @@ -443,16 +444,16 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); cl_index __nr; \ ecl_frs_push(__the_env,ECL_PROTECT_TAG); \ if (__ecl_frs_push_result) { \ - __unwinding=1; __next_fr=__the_env->nlj_fr; \ + __unwinding=1; __next_fr=__the_env->frs_stack.nlj_fr; \ } else { #define ECL_UNWIND_PROTECT_EXIT \ __unwinding=0; } \ ecl_frs_pop(__the_env); \ - __nr = ecl_stack_push_values(__the_env); + __nr = ecl_data_stack_push_values(__the_env); #define ECL_UNWIND_PROTECT_END \ - ecl_stack_pop_values(__the_env,__nr); \ + ecl_data_stack_pop_values(__the_env,__nr); \ if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) /* unwind-protect variant which disables interrupts during cleanup */ @@ -460,15 +461,15 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); __unwinding=0; } \ ecl_bds_bind(__the_env,ECL_INTERRUPTS_ENABLED,ECL_NIL); \ ecl_frs_pop(__the_env); \ - __nr = ecl_stack_push_values(__the_env); + __nr = ecl_data_stack_push_values(__the_env); #define ECL_UNWIND_PROTECT_THREAD_SAFE_END \ - ecl_stack_pop_values(__the_env,__nr); \ + ecl_data_stack_pop_values(__the_env,__nr); \ ecl_bds_unwind1(__the_env); \ ecl_check_pending_interrupts(__the_env); \ if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) -#define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frame_id++) +#define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frs_stack.frame_id++) #define ECL_BLOCK_BEGIN(the_env,id) do { \ const cl_object __id = ECL_NEW_FRAME_ID(the_env); \