From f365ebe079f99d7220ae93ff302471797010d796 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 3 Apr 2024 12:51:17 +0200 Subject: [PATCH 01/23] stacks: move the binding stack to a separate structure --- src/c/alloc_2.d | 6 +-- src/c/compiler.d | 2 +- src/c/main.d | 10 ++-- src/c/stacks.d | 104 ++++++++++++++++++++--------------------- src/c/threads/thread.d | 20 ++++---- src/c/unixint.d | 4 +- src/h/external.h | 28 +++++------ src/h/stacks.h | 98 +++++++++++++++++++------------------- 8 files changed, 137 insertions(+), 135 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 6c55be548..5a7b64402 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1160,9 +1160,9 @@ ecl_mark_env(struct cl_env_struct *env) 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); + if (env->bds_stack.top) { + GC_push_conditional((void *)env->bds_stack.org, (void *)(env->bds_stack.top+1), 1); + GC_set_mark_bit((void *)env->bds_stack.org); } /* When not using threads, "env" is mmaped or statically allocated. */ GC_push_all((void *)env, (void *)(env + 1)); diff --git a/src/c/compiler.d b/src/c/compiler.d index ee76b0950..73d53f349 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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_top_index = env->bds_stack.top - env->bds_stack.org; for (bindings = pop(&args); !Null(bindings); ) { cl_object form = pop(&bindings); diff --git a/src/c/main.d b/src/c/main.d index f2bedeb22..259a06c36 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -196,11 +196,11 @@ ecl_init_first_env(cl_env_ptr env) 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; + env->bds_stack.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->bds_stack.bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); + env->bds_stack.thread_local_bindings_size = env->bds_stack.bindings_array->vector.dim; + env->bds_stack.thread_local_bindings = env->bds_stack.bindings_array->vector.self.t; #endif init_env_mp(env); init_env_int(env); diff --git a/src/c/stacks.d b/src/c/stacks.d index 3c883a59d..37a064b04 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -291,23 +291,23 @@ ecl_bds_unwind_n(cl_env_ptr env, int n) static void ecl_bds_set_size(cl_env_ptr env, cl_index new_size) { - ecl_bds_ptr old_org = env->bds_org; - cl_index limit = env->bds_top - old_org; + ecl_bds_ptr old_org = env->bds_stack.org; + cl_index limit = env->bds_stack.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; + env->bds_stack.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; + env->bds_stack.top = org + limit; + env->bds_stack.org = org; + env->bds_stack.limit = org + (new_size - 2*margin); + env->bds_stack.size = new_size; ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); ecl_dealloc(old_org); @@ -323,39 +323,39 @@ 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; + ecl_bds_ptr org = env->bds_stack.org; ecl_bds_ptr last = org + size; - if (env->bds_limit >= last) { + if (env->bds_stack.limit >= last) { ecl_unrecoverable_error(env, stack_overflow_msg); } - env->bds_limit += margin; + env->bds_stack.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; + return env->bds_stack.top; } void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index) { - 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 = new_bds_top_index + env->bds_stack.org; + 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; + 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; @@ -383,8 +383,8 @@ 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) + 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); @@ -394,7 +394,7 @@ cl_object si_bds_top() { cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->bds_top - env->bds_org)); + ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org)); } cl_object @@ -459,11 +459,11 @@ 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.thread_local_bindings_size) { + cl_object vector = env->bds_stack.bindings_array; + env->bds_stack.bindings_array = vector = ecl_extend_bindings_array(vector); + env->bds_stack.thread_local_bindings_size = vector->vector.dim; + env->bds_stack.thread_local_bindings = vector->vector.self.t; } return index; } @@ -479,15 +479,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.thread_local_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.thread_local_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 +495,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 +511,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.thread_local_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.thread_local_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 +527,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 +538,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.thread_local_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 +553,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.thread_local_bindings_size) { + cl_object x = env->bds_stack.thread_local_bindings[index]; if (x != ECL_NO_TL_BINDING) return x; } return s->symbol.value; @@ -564,8 +564,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.thread_local_bindings_size) { + cl_object *location = env->bds_stack.thread_local_bindings + index; if (*location != ECL_NO_TL_BINDING) return location; } @@ -701,7 +701,7 @@ _ecl_frs_push(cl_env_ptr env) 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_bds_top_index = env->bds_stack.top - env->bds_stack.org; output->frs_ihs = env->ihs_top; output->frs_sp = ECL_STACK_INDEX(env); return output; @@ -829,7 +829,7 @@ si_get_limit(cl_object type) if (type == @'ext::frame-stack') output = env->frs_limit_size; else if (type == @'ext::binding-stack') - output = env->bds_limit_size; + output = env->bds_stack.limit_size; else if (type == @'ext::c-stack') output = env->cs_limit_size; else if (type == @'ext::lisp-stack') @@ -849,7 +849,7 @@ si_reset_margin(cl_object type) 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); + ecl_bds_set_size(env, env->bds_stack.size); else if (type == @'ext::c-stack') cs_set_size(env, env->cs_size); else @@ -873,10 +873,10 @@ init_stacks(cl_env_ptr env) /* 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]; + env->bds_stack.size = size; + env->bds_stack.org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_stack.org)); + env->bds_stack.top = env->bds_stack.org-1; + env->bds_stack.limit = &env->bds_stack.org[size - 2*margin]; /* ihs stack */ env->ihs_top = &ihs_org; ihs_org.function = ECL_NIL; diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index ad06830ba..032d6d634 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -285,12 +285,12 @@ alloc_process(cl_object name, cl_object initial_bindings) process->process.interrupt = ECL_NIL; process->process.exit_values = ECL_NIL; process->process.env = NULL; - if (initial_bindings != ECL_NIL || env->bindings_array == OBJNULL) { + if (initial_bindings != ECL_NIL || env->bds_stack.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); + array = cl_copy_seq(ecl_process_env()->bds_stack.bindings_array); } process->process.initial_bindings = array; process->process.woken_up = ECL_NIL; @@ -358,9 +358,9 @@ ecl_import_current_thread(cl_object name, cl_object bindings) /* 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; + env_aux->bds_stack.bindings_array = process->process.initial_bindings; + env_aux->bds_stack.thread_local_bindings_size = env_aux->bds_stack.bindings_array->vector.dim; + env_aux->bds_stack.thread_local_bindings = env_aux->bds_stack.bindings_array->vector.self.t; /* Switch over to the real environment */ memcpy(env, env_aux, sizeof(*env)); @@ -515,11 +515,11 @@ 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; + process_env->bds_stack.bindings_array = process->process.initial_bindings; + process_env->bds_stack.thread_local_bindings_size = + process_env->bds_stack.bindings_array->vector.dim; + process_env->bds_stack.thread_local_bindings = + process_env->bds_stack.bindings_array->vector.self.t; ecl_disable_interrupts_env(the_env); #ifdef ECL_WINDOWS_THREADS diff --git a/src/c/unixint.d b/src/c/unixint.d index adf30aa97..dfbbcfd15 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -400,11 +400,11 @@ handle_all_queued_interrupt_safe(cl_env_ptr env) struct ecl_frame top_frame; memcpy(&top_frame, env->frs_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->bds_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame)); memcpy(env->frs_top+1, &top_frame, sizeof(struct ecl_frame)); env->stack_top--; ecl_clear_bignum_registers(env); diff --git a/src/h/external.h b/src/h/external.h index d27755914..58013165b 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -10,6 +10,20 @@ extern "C" { #define _ECL_ARGS(x) x +/* The BinDing Stack stores the bindings of special variables. */ +struct ecl_binding_stack { +#ifdef ECL_THREADS + cl_index thread_local_bindings_size; + cl_object *thread_local_bindings; + cl_object bindings_array; +#endif + cl_index size; + cl_index limit_size; + struct ecl_bds_frame * org; + struct ecl_bds_frame * top; + struct ecl_bds_frame * limit; +}; + /* * Per-thread data. */ @@ -41,19 +55,7 @@ struct cl_env_struct { cl_object *stack_top; cl_object *stack_limit; - /* - * The BinDing Stack stores the bindings of special variables. - */ -#ifdef ECL_THREADS - cl_index thread_local_bindings_size; - cl_object *thread_local_bindings; - cl_object bindings_array; -#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; + struct ecl_binding_stack bds_stack; /* * The Invocation History Stack (IHS) keeps a list of the names of the diff --git a/src/h/stacks.h b/src/h/stacks.h index 1c38c41c3..e7087a376 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -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)) @@ -107,18 +107,18 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) # 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.thread_local_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.thread_local_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. */ @@ -129,8 +129,8 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) ecl_enable_interrupts_env(env); } # else - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + 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; @@ -145,15 +145,15 @@ static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) # 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.thread_local_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.thread_local_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; @@ -161,8 +161,8 @@ static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) ecl_enable_interrupts_env(env); } # else - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + 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; @@ -172,22 +172,22 @@ static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) static inline void ecl_bds_unwind1_inl(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.thread_local_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 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.thread_local_bindings_size) { + cl_object x = env->bds_stack.thread_local_bindings[index]; if (x != ECL_NO_TL_BINDING) return x; } return s->symbol.value; @@ -195,8 +195,8 @@ static inline cl_object ecl_bds_read_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.thread_local_bindings_size) { + cl_object *location = env->bds_stack.thread_local_bindings + index; if (*location != ECL_NO_TL_BINDING) return location; } return &s->symbol.value; @@ -209,32 +209,32 @@ static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s) # 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; \ +# 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_stack.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 { \ +# define ecl_bds_push(env,sym) 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) + const cl_object s = (sym); \ + const cl_object v = s->symbol.value; \ + ecl_bds_check(env_copy); \ + ecl_bds_ptr slot = ++(env_copy->bds_stack.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_stack.top->symbol; \ + s->symbol.value = env_copy->bds_stack.top->value; \ + --(env_copy->bds_stack.top); } while (0) # endif /* !ECL_THREADS */ #endif /* !__GNUC__ */ @@ -257,7 +257,7 @@ typedef struct ecl_ihs_frame { 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; \ + r->bds=__the_env->bds_stack.top - __the_env->bds_stack.org; \ __the_env->ihs_top = r; \ } while(0) -- GitLab From 8f00f3494a113f5fd2471a3f6329bc4d71ed3fba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 2 May 2025 15:27:38 +0200 Subject: [PATCH 02/23] stacks: rename thread_local_bindings{,_size} to tl_bindings{,_size} This is strictly cosmetic change. --- src/c/main.d | 7 +++++-- src/c/stacks.d | 24 ++++++++++++------------ src/c/threads/thread.d | 16 ++++++++-------- src/h/external.h | 4 ++-- src/h/stacks.h | 18 +++++++++--------- 5 files changed, 36 insertions(+), 33 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 259a06c36..13cfaf603 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -199,8 +199,8 @@ ecl_init_first_env(cl_env_ptr env) env->bds_stack.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->bds_stack.bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - env->bds_stack.thread_local_bindings_size = env->bds_stack.bindings_array->vector.dim; - env->bds_stack.thread_local_bindings = env->bds_stack.bindings_array->vector.self.t; + env->bds_stack.tl_bindings_size = env->bds_stack.bindings_array->vector.dim; + env->bds_stack.tl_bindings = env->bds_stack.bindings_array->vector.self.t; #endif init_env_mp(env); init_env_int(env); @@ -281,6 +281,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; /* diff --git a/src/c/stacks.d b/src/c/stacks.d index 37a064b04..64a49099b 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -459,11 +459,11 @@ 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->bds_stack.thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { cl_object vector = env->bds_stack.bindings_array; env->bds_stack.bindings_array = vector = ecl_extend_bindings_array(vector); - env->bds_stack.thread_local_bindings_size = vector->vector.dim; - env->bds_stack.thread_local_bindings = vector->vector.self.t; + env->bds_stack.tl_bindings_size = vector->vector.dim; + env->bds_stack.tl_bindings = vector->vector.self.t; } return index; } @@ -479,10 +479,10 @@ 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->bds_stack.thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { index = invalid_or_too_large_binding_index(env,s); } - location = env->bds_stack.thread_local_bindings + index; + 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; @@ -511,10 +511,10 @@ 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->bds_stack.thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { index = invalid_or_too_large_binding_index(env,s); } - location = env->bds_stack.thread_local_bindings + index; + 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; @@ -540,7 +540,7 @@ ecl_bds_unwind1(cl_env_ptr env) { cl_object s = env->bds_stack.top->symbol; #ifdef ECL_THREADS - cl_object *location = env->bds_stack.thread_local_bindings + s->symbol.binding; + cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding; *location = env->bds_stack.top->value; #else s->symbol.value = env->bds_stack.top->value; @@ -553,8 +553,8 @@ cl_object ecl_bds_read(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->bds_stack.thread_local_bindings_size) { - cl_object x = env->bds_stack.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 +564,8 @@ cl_object * ecl_bds_ref(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->bds_stack.thread_local_bindings_size) { - cl_object *location = env->bds_stack.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; } diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 032d6d634..eb58ba09d 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -274,7 +274,7 @@ thread_entry_point(void *arg) } 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; @@ -285,7 +285,7 @@ alloc_process(cl_object name, cl_object initial_bindings) process->process.interrupt = ECL_NIL; process->process.exit_values = ECL_NIL; process->process.env = NULL; - if (initial_bindings != ECL_NIL || env->bds_stack.bindings_array == OBJNULL) { + if (initial_bindings_p != ECL_NIL || env->bds_stack.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); @@ -359,8 +359,8 @@ ecl_import_current_thread(cl_object name, cl_object bindings) /* Copy initial bindings from process to the fake environment */ env_aux->cleanup = registered; env_aux->bds_stack.bindings_array = process->process.initial_bindings; - env_aux->bds_stack.thread_local_bindings_size = env_aux->bds_stack.bindings_array->vector.dim; - env_aux->bds_stack.thread_local_bindings = env_aux->bds_stack.bindings_array->vector.self.t; + env_aux->bds_stack.tl_bindings_size = env_aux->bds_stack.bindings_array->vector.dim; + env_aux->bds_stack.tl_bindings = env_aux->bds_stack.bindings_array->vector.self.t; /* Switch over to the real environment */ memcpy(env, env_aux, sizeof(*env)); @@ -390,10 +390,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); @) @@ -516,9 +516,9 @@ mp_process_enable(cl_object process) process_env->trap_fpe_bits = process->process.trap_fpe_bits; process_env->bds_stack.bindings_array = process->process.initial_bindings; - process_env->bds_stack.thread_local_bindings_size = + process_env->bds_stack.tl_bindings_size = process_env->bds_stack.bindings_array->vector.dim; - process_env->bds_stack.thread_local_bindings = + process_env->bds_stack.tl_bindings = process_env->bds_stack.bindings_array->vector.self.t; ecl_disable_interrupts_env(the_env); diff --git a/src/h/external.h b/src/h/external.h index 58013165b..5f2e02d4a 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -13,8 +13,8 @@ extern "C" { /* The BinDing Stack stores the bindings of special variables. */ struct ecl_binding_stack { #ifdef ECL_THREADS - cl_index thread_local_bindings_size; - cl_object *thread_local_bindings; + cl_index tl_bindings_size; + cl_object *tl_bindings; cl_object bindings_array; #endif cl_index size; diff --git a/src/h/stacks.h b/src/h/stacks.h index e7087a376..535fade06 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -107,10 +107,10 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) # ifdef ECL_THREADS cl_object *location; const cl_index index = s->symbol.binding; - if (index >= env->bds_stack.thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { ecl_bds_bind(env,s,v); } else { - location = env->bds_stack.thread_local_bindings + index; + 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 @@ -145,10 +145,10 @@ static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) # ifdef ECL_THREADS cl_object *location; const cl_index index = s->symbol.binding; - if (index >= env->bds_stack.thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { ecl_bds_push(env, s); } else { - location = env->bds_stack.thread_local_bindings + index; + 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; @@ -174,7 +174,7 @@ static inline void ecl_bds_unwind1_inl(cl_env_ptr env) { cl_object s = env->bds_stack.top->symbol; # ifdef ECL_THREADS - cl_object *location = env->bds_stack.thread_local_bindings + s->symbol.binding; + cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding; *location = env->bds_stack.top->value; # else s->symbol.value = env->bds_stack.top->value; @@ -186,8 +186,8 @@ static inline void ecl_bds_unwind1_inl(cl_env_ptr env) static inline cl_object ecl_bds_read_inl(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->bds_stack.thread_local_bindings_size) { - cl_object x = env->bds_stack.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; @@ -195,8 +195,8 @@ static inline cl_object ecl_bds_read_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->bds_stack.thread_local_bindings_size) { - cl_object *location = env->bds_stack.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; -- GitLab From 326a914fff4ca68416d264908392d93f8e4fb4c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 10 Apr 2024 10:45:54 +0200 Subject: [PATCH 03/23] stacks: clean up inlined versions for bds operators We remove defines in favor of 'static inline' that is available in all c99 compilers. Previously it was specialcased only for GNUC. --- src/h/stacks.h | 119 ++++++++++++++++++++++--------------------------- 1 file changed, 53 insertions(+), 66 deletions(-) diff --git a/src/h/stacks.h b/src/h/stacks.h index 535fade06..89087dfbc 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -100,11 +100,11 @@ 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->bds_stack.tl_bindings_size) { @@ -128,21 +128,12 @@ 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_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); -# 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->bds_stack.tl_bindings_size) { @@ -160,30 +151,19 @@ static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; ecl_enable_interrupts_env(env); } -# else - 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); -# 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_stack.top->symbol; -# ifdef ECL_THREADS cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding; *location = env->bds_stack.top->value; -# else - s->symbol.value = env->bds_stack.top->value; -# endif --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->bds_stack.tl_bindings_size) { @@ -192,7 +172,8 @@ static inline cl_object ecl_bds_read_inl(cl_env_ptr env, cl_object s) } 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->bds_stack.tl_bindings_size) { @@ -201,42 +182,48 @@ static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s) } 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_stack.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_stack.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_stack.top->symbol; \ - s->symbol.value = env_copy->bds_stack.top->value; \ - --(env_copy->bds_stack.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 -- GitLab From 9687a1d33a810397ae04b26439b1c9fada4ef366 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 3 Apr 2024 13:17:35 +0200 Subject: [PATCH 04/23] stacks: move frames stack to a separate structure --- src/c/alloc_2.d | 6 +-- src/c/error.d | 4 +- src/c/interpreter.d | 10 ++-- src/c/main.d | 4 +- src/c/stacks.d | 64 ++++++++++++------------ src/c/threads/thread.d | 2 +- src/c/unixint.d | 4 +- src/cmp/cmpbackend-cxx/cmppass2-cont.lsp | 2 +- src/h/external.h | 33 ++++++------ src/h/stacks.h | 8 +-- 10 files changed, 71 insertions(+), 66 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 5a7b64402..36ae11144 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1156,9 +1156,9 @@ ecl_mark_env(struct cl_env_struct *env) 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->frs_stack.top) { + GC_push_conditional((void *)env->frs_stack.org, (void *)(env->frs_stack.top+1), 1); + GC_set_mark_bit((void *)env->frs_stack.org); } if (env->bds_stack.top) { GC_push_conditional((void *)env->bds_stack.org, (void *)(env->bds_stack.top+1), 1); diff --git a/src/c/error.d b/src/c/error.d index c98417ba2..8e2359864 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;;;"); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 8671f2487..b3a8d7413 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_top_index); 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; } diff --git a/src/c/main.d b/src/c/main.d index 13cfaf603..dabf0eb07 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -817,8 +817,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/stacks.d b/src/c/stacks.d index 64a49099b..23a9d0bc3 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -640,23 +640,23 @@ si_ihs_env(cl_object arg) static void frs_set_size(cl_env_ptr env, cl_index new_size) { - ecl_frame_ptr old_org = env->frs_org; - cl_index limit = env->frs_top - old_org; + ecl_frame_ptr old_org = env->frs_stack.org; + cl_index limit = env->frs_stack.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; + env->frs_stack.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; + env->frs_stack.top = org + limit; + env->frs_stack.org = org; + env->frs_stack.limit = org + (new_size - 2*margin); + env->frs_stack.size = new_size; ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); ecl_dealloc(old_org); @@ -672,13 +672,13 @@ 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; + ecl_frame_ptr org = env->frs_stack.org; ecl_frame_ptr last = org + size; - if (env->frs_limit >= last) { + if (env->frs_stack.limit >= last) { ecl_unrecoverable_error(env, stack_overflow_msg); } - env->frs_limit += margin; + env->frs_stack.limit += margin; si_serror(6, @"Extend stack size", @'ext::stack-overflow', @':size', ecl_make_fixnum(size), @':type', @'ext::frame-stack'); @@ -693,14 +693,14 @@ _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; + ++env->frs_stack.top; output->frs_bds_top_index = env->bds_stack.top - env->bds_stack.org; output->frs_ihs = env->ihs_top; output->frs_sp = ECL_STACK_INDEX(env); @@ -710,8 +710,8 @@ _ecl_frs_push(cl_env_ptr env) 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; @@ -719,8 +719,8 @@ ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) 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->frs_stack.top = top; + ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); /* never reached */ } @@ -729,7 +729,7 @@ frs_sch (cl_object frame_id) { cl_env_ptr env = ecl_process_env(); ecl_frame_ptr top; - for (top = env->frs_top; top >= env->frs_org; top--) + for (top = env->frs_stack.top; top >= env->frs_stack.org; top--) if (top->frs_val == frame_id) return(top); return(NULL); @@ -740,8 +740,8 @@ 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,7 +751,7 @@ 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 @@ -782,9 +782,11 @@ si_sch_frs_base(cl_object fr, cl_object ihs) 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; + 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))); } /* ------------------------- INITIALIZATION --------------------------- */ @@ -827,7 +829,7 @@ 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_stack.limit_size; else if (type == @'ext::c-stack') @@ -847,7 +849,7 @@ 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); + frs_set_size(env, env->frs_stack.size); else if (type == @'ext::binding-stack') ecl_bds_set_size(env, env->bds_stack.size); else if (type == @'ext::c-stack') @@ -866,10 +868,10 @@ init_stacks(cl_env_ptr env) /* 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]; + env->frs_stack.size = size; + env->frs_stack.org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_stack.org)); + env->frs_stack.top = env->frs_stack.org-1; + env->frs_stack.limit = &env->frs_stack.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; diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index eb58ba09d..bb2817d79 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -588,7 +588,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 */ } diff --git a/src/c/unixint.d b/src/c/unixint.d index dfbbcfd15..0ae8bf410 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -398,14 +398,14 @@ handle_all_queued_interrupt_safe(cl_env_ptr env) * 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_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_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame)); - memcpy(env->frs_top+1, &top_frame, sizeof(struct ecl_frame)); + memcpy(env->frs_stack.top+1, &top_frame, sizeof(struct ecl_frame)); env->stack_top--; ecl_clear_bignum_registers(env); memcpy(env->big_register, big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object)); diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index f652e7058..cb8567f7b 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/h/external.h b/src/h/external.h index 5f2e02d4a..e903ad449 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -19,9 +19,23 @@ struct ecl_binding_stack { #endif cl_index size; cl_index limit_size; - struct ecl_bds_frame * org; - struct ecl_bds_frame * top; - struct ecl_bds_frame * limit; + struct ecl_bds_frame *org; + struct ecl_bds_frame *top; + struct ecl_bds_frame *limit; +}; + +/* 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 { + struct ecl_frame *nlj_fr; + cl_index frame_id; + + cl_index size; + cl_index limit_size; + struct ecl_frame *org; + struct ecl_frame *top; + struct ecl_frame *limit; }; /* @@ -56,6 +70,7 @@ struct cl_env_struct { cl_object *stack_limit; struct ecl_binding_stack bds_stack; + struct ecl_frames_stack frs_stack; /* * The Invocation History Stack (IHS) keeps a list of the names of the @@ -64,18 +79,6 @@ struct cl_env_struct { */ 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 diff --git a/src/h/stacks.h b/src/h/stacks.h index 89087dfbc..531516aca 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -293,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 @@ -430,7 +430,7 @@ 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 \ @@ -455,7 +455,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); 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); \ -- GitLab From 593d9d2190bc85f4fc2c199edcd27278ed781816 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 3 Apr 2024 13:22:14 +0200 Subject: [PATCH 05/23] stacks: move invocation history stack to a separate structure --- src/c/error.d | 8 ++++---- src/c/stacks.d | 10 +++++----- src/h/external.h | 17 ++++++++--------- src/h/stacks.h | 14 +++++++------- 4 files changed, 24 insertions(+), 25 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index 8e2359864..7e4c1b62b 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -287,7 +287,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 +311,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 +337,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 +368,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, diff --git a/src/c/stacks.d b/src/c/stacks.d index 23a9d0bc3..84ec64edf 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -585,7 +585,7 @@ static ecl_ihs_ptr get_ihs_ptr(cl_index n) { cl_env_ptr env = ecl_process_env(); - ecl_ihs_ptr p = env->ihs_top; + 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) @@ -597,7 +597,7 @@ cl_object si_ihs_top(void) { cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->ihs_top->index)); + ecl_return1(env, ecl_make_fixnum(env->ihs_stack.top->index)); } cl_object @@ -702,7 +702,7 @@ _ecl_frs_push(cl_env_ptr env) AO_nop_full(); ++env->frs_stack.top; output->frs_bds_top_index = env->bds_stack.top - env->bds_stack.org; - output->frs_ihs = env->ihs_top; + output->frs_ihs = env->ihs_stack.top; output->frs_sp = ECL_STACK_INDEX(env); return output; } @@ -716,7 +716,7 @@ ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) top->frs_val = ECL_DUMMY_TAG; --top; } - env->ihs_top = top->frs_ihs; + env->ihs_stack.top = top->frs_ihs; ecl_bds_unwind(env, top->frs_bds_top_index); ECL_STACK_SET_INDEX(env, top->frs_sp); env->frs_stack.top = top; @@ -880,7 +880,7 @@ init_stacks(cl_env_ptr env) env->bds_stack.top = env->bds_stack.org-1; env->bds_stack.limit = &env->bds_stack.org[size - 2*margin]; /* ihs stack */ - env->ihs_top = &ihs_org; + env->ihs_stack.top = &ihs_org; ihs_org.function = ECL_NIL; ihs_org.lex_env = ECL_NIL; ihs_org.index = 0; diff --git a/src/h/external.h b/src/h/external.h index e903ad449..1d32394c5 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -38,6 +38,12 @@ struct ecl_frames_stack { struct ecl_frame *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_history_stack { + struct ecl_ihs_frame *top; +}; + /* * Per-thread data. */ @@ -70,15 +76,8 @@ struct cl_env_struct { cl_object *stack_limit; struct ecl_binding_stack bds_stack; - struct ecl_frames_stack frs_stack; - - /* - * 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; - + struct ecl_frames_stack frs_stack; + struct ecl_history_stack ihs_stack; /* * The following pointers to the C Stack are used to ensure that a diff --git a/src/h/stacks.h b/src/h/stacks.h index 531516aca..a7698927c 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -240,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->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_top = r; \ + __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) /*************** -- GitLab From 45f3be3aa13ebf4ed83a4ff64e244d6f42b3bff1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 3 Apr 2024 13:41:45 +0200 Subject: [PATCH 06/23] stacks: move C shadow stack to a separate structure --- src/c/stacks.d | 54 ++++++++++++++++++++++++------------------------ src/c/unixint.d | 8 +++---- src/h/external.h | 34 ++++++++++++++---------------- src/h/stacks.h | 4 ++-- 4 files changed, 49 insertions(+), 51 deletions(-) diff --git a/src/c/stacks.d b/src/c/stacks.d index 84ec64edf..49ef664de 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -34,7 +34,7 @@ cs_set_size(cl_env_ptr env, cl_index new_size) struct rlimit rl; if (!getrlimit(RLIMIT_STACK, &rl)) { - env->cs_max_size = rl.rlim_max; + env->c_stack.max_size = rl.rlim_max; if (new_size > rl.rlim_cur) { rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size; if (setrlimit(RLIMIT_STACK, &rl)) @@ -52,29 +52,29 @@ cs_set_size(cl_env_ptr env, cl_index new_size) new_size = rl.rlim_cur; } #ifdef ECL_DOWN_STACK - env->cs_barrier = env->cs_org - new_size; + env->c_stack.max = env->c_stack.org - new_size; #else - env->cs_barrier = env->cs_org + new_size; + env->c_stack.max = env->c_stack.org + new_size; #endif } #endif - env->cs_limit_size = new_size - (2*margin); + env->c_stack.limit_size = new_size - (2*margin); #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; + 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 - 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; + 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; } #endif else ecl_internal_error("Can't set the size of the C stack: sanity check failed"); - env->cs_size = new_size; + env->c_stack.size = new_size; } void @@ -86,18 +86,18 @@ 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) + if (env->c_stack.max_size == (cl_index)0 || env->c_stack.size < env->c_stack.max_size) si_serror(6, @"Extend stack size", @'ext::stack-overflow', @':size', ecl_make_fixnum(size), @@ -108,8 +108,8 @@ ecl_cs_overflow(void) @':size', ECL_NIL, @':type', @'ext::c-stack'); size += size/2; - if (size > env->cs_max_size) - size = env->cs_max_size; + if (size > env->c_stack.max_size) + size = env->c_stack.max_size; cs_set_size(env, size); } @@ -119,17 +119,17 @@ 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; + env->c_stack.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->c_stack.org = (char*)(&env); } - env->cs_barrier = env->cs_org; - env->cs_max_size = 0; + env->c_stack.max = env->c_stack.org; + env->c_stack.max_size = 0; cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); } @@ -833,7 +833,7 @@ si_get_limit(cl_object type) else if (type == @'ext::binding-stack') output = env->bds_stack.limit_size; else if (type == @'ext::c-stack') - output = env->cs_limit_size; + output = env->c_stack.limit_size; else if (type == @'ext::lisp-stack') output = env->stack_limit_size; else if (type == @'ext::heap-size') { @@ -853,7 +853,7 @@ si_reset_margin(cl_object type) else if (type == @'ext::binding-stack') ecl_bds_set_size(env, env->bds_stack.size); else if (type == @'ext::c-stack') - cs_set_size(env, env->cs_size); + cs_set_size(env, env->c_stack.size); else ecl_return1(env, ECL_NIL); diff --git a/src/c/unixint.d b/src/c/unixint.d index 0ae8bf410..2cb283e0d 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -829,16 +829,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/h/external.h b/src/h/external.h index 1d32394c5..2ffb02b4a 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -44,6 +44,21 @@ struct ecl_history_stack { struct ecl_ihs_frame *top; }; +/* 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 { + cl_index max_size; /* maximum possible size */ + + 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) */ +}; + + /* * Per-thread data. */ @@ -78,24 +93,7 @@ struct cl_env_struct { struct ecl_binding_stack bds_stack; struct ecl_frames_stack frs_stack; 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. - */ - 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 */ + struct ecl_c_stack c_stack; /* Private variables used by different parts of ECL: */ /* ... the reader and printer ... */ diff --git a/src/h/stacks.h b/src/h/stacks.h index a7698927c..6cab0d97e 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 /********************************************************* -- GitLab From 51157bbf9d68d12e13de9269d17ac2d2cce82253 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 3 Apr 2024 14:00:38 +0200 Subject: [PATCH 07/23] stacks: move runtime stack to a separate structure --- src/c/alloc_2.d | 6 ++--- src/c/compiler.d | 6 ++--- src/c/read.d | 2 +- src/c/stacks.d | 58 ++++++++++++++++++++++++------------------------ src/c/unixint.d | 10 ++++----- src/h/external.h | 25 +++++++++++---------- src/h/stacks.h | 32 +++++++++++++------------- 7 files changed, 70 insertions(+), 69 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 36ae11144..acbd71b78 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1152,9 +1152,9 @@ 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->run_stack.org) { + GC_push_conditional((void *)env->run_stack.org, (void *)env->run_stack.top, 1); + GC_set_mark_bit((void *)env->run_stack.org); } if (env->frs_stack.top) { GC_push_conditional((void *)env->frs_stack.org, (void *)(env->frs_stack.top+1), 1); diff --git a/src/c/compiler.d b/src/c/compiler.d index 73d53f349..f3c054576 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, @@ -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; } } diff --git a/src/c/read.d b/src/c/read.d index 8343635b5..dcb124730 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 49ef664de..a078d04bc 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -138,7 +138,7 @@ ecl_cs_set_org(cl_env_ptr env) cl_object * ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) { - cl_index top = env->stack_top - env->stack; + cl_index top = env->run_stack.top - env->run_stack.org; 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; @@ -150,27 +150,27 @@ ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) FEerror("Internal error: cannot shrink stack below stack top.",0); } - old_stack = env->stack; + old_stack = env->run_stack.org; 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); + memcpy(new_stack, old_stack, env->run_stack.size * sizeof(cl_object)); + env->run_stack.size = new_size; + env->run_stack.limit_size = new_size - 2*safety_area; + env->run_stack.org = new_stack; + env->run_stack.top = env->run_stack.org + top; + env->run_stack.limit = env->run_stack.org + (new_size - 2*safety_area); /* 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); + *(env->run_stack.top++) = ecl_make_fixnum(0); } ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); ecl_dealloc(old_stack); - return env->stack_top; + return env->run_stack.top; } void @@ -188,41 +188,41 @@ FEstack_advance(void) cl_object * ecl_stack_grow(cl_env_ptr env) { - return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); + return ecl_stack_set_size(env, env->run_stack.size + env->run_stack.size / 2); } cl_index ecl_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) { + if (p >= env->run_stack.limit) { b = ecl_stack_grow(env); p = b + i; } - env->stack_top = p; + env->run_stack.top = p; memcpy(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)) + cl_object *p = env->run_stack.top - n; + if (ecl_unlikely(p < env->run_stack.org)) FEstack_underflow(); env->nvalues = n; - env->stack_top = p; + env->run_stack.top = p; memcpy(env->values, p, n * sizeof(cl_object)); } 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) { + base = ecl_stack_set_size(env, env->run_stack.size + size); } } bindex = ECL_STACK_INDEX(env); @@ -232,7 +232,7 @@ 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; } @@ -240,11 +240,11 @@ 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) { + cl_object *top = env->run_stack.top; + if (top >= env->run_stack.limit) { top = ecl_stack_grow(env); } - env->stack_top = ++top; + env->run_stack.top = ++top; *(top-1) = o; f->frame.size++; } @@ -835,7 +835,7 @@ si_get_limit(cl_object type) else if (type == @'ext::c-stack') output = env->c_stack.limit_size; else if (type == @'ext::lisp-stack') - output = env->stack_limit_size; + output = env->run_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)); @@ -885,9 +885,9 @@ init_stacks(cl_env_ptr env) 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; + env->run_stack.org = NULL; + env->run_stack.top = NULL; + env->run_stack.limit = NULL; + env->run_stack.size = 0; ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); } diff --git a/src/c/unixint.d b/src/c/unixint.d index 2cb283e0d..43a7e4b92 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -389,10 +389,10 @@ 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 @@ -406,7 +406,7 @@ handle_all_queued_interrupt_safe(cl_env_ptr env) /* ... and restore everything again */ 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->stack_top--; + 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; diff --git a/src/h/external.h b/src/h/external.h index 2ffb02b4a..ca4816f8e 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -10,6 +10,17 @@ 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 { #ifdef ECL_THREADS @@ -79,21 +90,11 @@ struct cl_env_struct { /* 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; - + struct ecl_runtime_stack run_stack; struct ecl_binding_stack bds_stack; struct ecl_frames_stack frs_stack; struct ecl_history_stack ihs_stack; - struct ecl_c_stack c_stack; + struct ecl_c_stack c_stack; /* shadow stack */ /* Private variables used by different parts of ECL: */ /* ... the reader and printer ... */ diff --git a/src/h/stacks.h b/src/h/stacks.h index 6cab0d97e..27f5cc57a 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -364,45 +364,45 @@ 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_INDEX(env) ((env)->run_stack.top - (env)->run_stack.org) #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)) { \ + cl_object *__new_top = __env->run_stack.top; \ + if (ecl_unlikely(__new_top >= __env->run_stack.limit)) { \ __new_top = ecl_stack_grow(__env); \ } \ - __env->stack_top = __new_top+1; \ + __env->run_stack.top = __new_top+1; \ *__new_top = (o); } while (0) -#define ECL_STACK_POP_UNSAFE(env) *(--((env)->stack_top)) +#define ECL_STACK_POP_UNSAFE(env) *(--((env)->run_stack.top)) -#define ECL_STACK_REF(env,n) ((env)->stack_top[n]) +#define ECL_STACK_REF(env,n) ((env)->run_stack.top[n]) #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)) \ + cl_object *__new_top = __env->run_stack.org + (ndx); \ + if (ecl_unlikely(__new_top > __env->run_stack.top)) \ FEstack_advance(); \ - __env->stack_top = __new_top; } while (0) + __env->run_stack.top = __new_top; } while (0) #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)) \ + cl_object *__new_top = __env->run_stack.top - (n); \ + if (ecl_unlikely(__new_top < __env->run_stack.org)) \ FEstack_underflow(); \ - __env->stack_top = __new_top; } while (0) + __env->run_stack.top = __new_top; } while (0) -#define ECL_STACK_POP_N_UNSAFE(the_env,n) ((the_env)->stack_top -= (n)) +#define ECL_STACK_POP_N_UNSAFE(the_env,n) ((the_env)->run_stack.top -= (n)) #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)) { \ + cl_object *__new_top = __env->run_stack.top; \ + while (ecl_unlikely((__env->run_stack.limit - __new_top) <= __aux)) { \ __new_top = ecl_stack_grow(__env); \ } \ - __env->stack_top = __new_top + __aux; } while (0) + __env->run_stack.top = __new_top + __aux; } while (0) #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) -- GitLab From 0a8de3f23446e026d5a67b9c333f6c25e9c4f950 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 26 May 2025 08:34:06 +0200 Subject: [PATCH 08/23] stacks: make runtime stack accessors inline functions Also remove an unused operator FEstack_advance. Macro definition names do not change and they expand (when appropriate) to the inline function. New function names refer to data_stack, while upcased macro names mentions only the STACK. This is in line with how forth refers to the data stack when it is not ambiguous. --- src/c/interpreter.d | 8 ++-- src/c/stacks.d | 28 +++++------ src/h/external.h | 9 ++-- src/h/internal.h | 4 +- src/h/stacks.h | 112 +++++++++++++++++++++++++------------------- 5 files changed, 84 insertions(+), 77 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index b3a8d7413..6685844b6 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -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/stacks.d b/src/c/stacks.d index a078d04bc..8f4f36ed4 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -136,7 +136,7 @@ ecl_cs_set_org(cl_env_ptr env) /* ------------------------- LISP STACK ------------------------------- */ cl_object * -ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) +ecl_data_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) { cl_index top = env->run_stack.top - env->run_stack.org; cl_object *new_stack, *old_stack; @@ -179,25 +179,19 @@ FEstack_underflow(void) FEerror("Internal error: stack underflow.",0); } -void -FEstack_advance(void) -{ - FEerror("Internal error: stack advance beyond current point.",0); -} - cl_object * -ecl_stack_grow(cl_env_ptr env) +ecl_data_stack_grow(cl_env_ptr env) { - return ecl_stack_set_size(env, env->run_stack.size + env->run_stack.size / 2); + return ecl_data_stack_set_size(env, env->run_stack.size + env->run_stack.size / 2); } 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->run_stack.top; cl_object *p = b + i; if (p >= env->run_stack.limit) { - b = ecl_stack_grow(env); + b = ecl_data_stack_grow(env); p = b + i; } env->run_stack.top = p; @@ -206,7 +200,7 @@ ecl_stack_push_values(cl_env_ptr env) { } void -ecl_stack_pop_values(cl_env_ptr env, cl_index n) { +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)) FEstack_underflow(); @@ -222,7 +216,7 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) cl_index bindex; if (size) { if ((env->run_stack.limit - base) < size) { - base = ecl_stack_set_size(env, env->run_stack.size + size); + base = ecl_data_stack_set_size(env, env->run_stack.size + size); } } bindex = ECL_STACK_INDEX(env); @@ -242,7 +236,7 @@ ecl_stack_frame_push(cl_object f, cl_object o) cl_env_ptr env = f->frame.env; cl_object *top = env->run_stack.top; if (top >= env->run_stack.limit) { - top = ecl_stack_grow(env); + top = ecl_data_stack_grow(env); } env->run_stack.top = ++top; *(top-1) = o; @@ -253,7 +247,7 @@ void ecl_stack_frame_push_values(cl_object f) { cl_env_ptr env = f->frame.env; - ecl_stack_push_values(env); + ecl_data_stack_push_values(env); f->frame.size += env->nvalues; } @@ -810,7 +804,7 @@ si_set_limit(cl_object type, cl_object limit) 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_data_stack_set_size(env, the_size); } else if (type == @'ext::heap-size') { /* * size_t can be larger than cl_index, and ecl_to_size() @@ -889,5 +883,5 @@ init_stacks(cl_env_ptr env) env->run_stack.top = NULL; env->run_stack.limit = NULL; env->run_stack.size = 0; - ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); + ecl_data_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); } diff --git a/src/h/external.h b/src/h/external.h index ca4816f8e..d77f148f5 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -543,11 +543,10 @@ 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, ...); diff --git a/src/h/internal.h b/src/h/internal.h index 296f7520b..a368f7537 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -552,10 +552,10 @@ 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); diff --git a/src/h/stacks.h b/src/h/stacks.h index 27f5cc57a..9dd587497 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -364,51 +364,65 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); * LISP STACK *************/ -#define ECL_STACK_INDEX(env) ((env)->run_stack.top - (env)->run_stack.org) - -#define ECL_STACK_PUSH(the_env,o) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->run_stack.top; \ - if (ecl_unlikely(__new_top >= __env->run_stack.limit)) { \ - __new_top = ecl_stack_grow(__env); \ - } \ - __env->run_stack.top = __new_top+1; \ - *__new_top = (o); } while (0) - -#define ECL_STACK_POP_UNSAFE(env) *(--((env)->run_stack.top)) - -#define ECL_STACK_REF(env,n) ((env)->run_stack.top[n]) - -#define ECL_STACK_SET_INDEX(the_env,ndx) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->run_stack.org + (ndx); \ - if (ecl_unlikely(__new_top > __env->run_stack.top)) \ - FEstack_advance(); \ - __env->run_stack.top = __new_top; } while (0) - -#define ECL_STACK_POP_N(the_env,n) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->run_stack.top - (n); \ - if (ecl_unlikely(__new_top < __env->run_stack.org)) \ - FEstack_underflow(); \ - __env->run_stack.top = __new_top; } while (0) - -#define ECL_STACK_POP_N_UNSAFE(the_env,n) ((the_env)->run_stack.top -= (n)) - -#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->run_stack.top; \ - while (ecl_unlikely((__env->run_stack.limit - __new_top) <= __aux)) { \ - __new_top = ecl_stack_grow(__env); \ - } \ - __env->run_stack.top = __new_top + __aux; } while (0) - -#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_PTR(f) ((f)->frame.env->stack+(f)->frame.base) -#define ECL_STACK_FRAME_TOP(f) ((f)->frame.env->stack+(f)->frame.sp) +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); +} + +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; +} + +static inline cl_object +ecl_data_stack_pop_unsafe(cl_env_ptr env) +{ + return *(--((env)->run_stack.top)); +} + +static inline void +ecl_data_stack_pop_n_unsafe(cl_env_ptr env, cl_index n) +{ + env->run_stack.top -= n; +} + +static inline cl_index +ecl_data_stack_index(cl_env_ptr env) { + return (env)->run_stack.top - (env)->run_stack.org; +} + +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_REF(env,n) ((env)->run_stack.top[n]) +#define ECL_STACK_INDEX(env) ecl_data_stack_index(env) +#define ECL_STACK_SET_INDEX(env,ndx) ecl_data_stack_set_index(env,ndx) +#define ECL_STACK_PUSH(env,o) ecl_data_stack_push(env,o) +#define ECL_STACK_PUSH_N(env,n) ecl_data_stack_push_n(env,n) +#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->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->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); \ @@ -436,10 +450,10 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); #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 */ @@ -447,10 +461,10 @@ 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) -- GitLab From 1b058f0e3a357de851c214c53ee0d832dd336c37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 2 May 2025 15:16:59 +0200 Subject: [PATCH 09/23] stacks: manually allocate bindings table This commit removes initial bindings array from the process and allocates it only in the bds stack. To make fields in the structure less confusing we rename initial_bindings slot to inherit_bindings_p. On observable behavior change is that bindings are inherited when the process is enabled, not when it is created. That was not specified in documentation so it should be fine to change this behavior. Moreover it makes more sense from the programmer perspective -- we want to inherit bindings of the process that starts our thread, not the one that creates it. --- src/c/alloc_2.d | 11 ++++++++--- src/c/main.d | 16 ++++++++++----- src/c/stacks.d | 26 +++++++++++------------- src/c/threads/thread.d | 45 ++++++++++++++++++++++++++---------------- src/h/external.h | 1 - src/h/object.h | 2 +- 6 files changed, 59 insertions(+), 42 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index acbd71b78..10c2b33a5 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)); @@ -1165,6 +1165,11 @@ ecl_mark_env(struct cl_env_struct *env) GC_set_mark_bit((void *)env->bds_stack.org); } /* When not using threads, "env" is mmaped or statically allocated. */ +#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/main.d b/src/c/main.d index dabf0eb07..46fc0bc70 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -196,11 +196,15 @@ ecl_init_first_env(cl_env_ptr env) init_threads(); #endif #ifdef ECL_THREADS - env->bds_stack.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->bds_stack.bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - env->bds_stack.tl_bindings_size = env->bds_stack.bindings_array->vector.dim; - env->bds_stack.tl_bindings = env->bds_stack.bindings_array->vector.self.t; + { + cl_index idx; + cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*)); + for(idx=0; idx<1024; idx++) { + vector[idx] = ECL_NO_TL_BINDING; + } + env->bds_stack.tl_bindings_size = 1024; + env->bds_stack.tl_bindings = vector; + } #endif init_env_mp(env); init_env_int(env); @@ -225,6 +229,8 @@ _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.*/ #ifdef ECL_THREADS + ecl_free(env->bds_stack.tl_bindings); + env->bds_stack.tl_bindings_size = 0; ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock); #endif #if defined(ECL_USE_MPROTECT) diff --git a/src/c/stacks.d b/src/c/stacks.d index 8f4f36ed4..d86d5acd4 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -435,17 +435,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) { @@ -454,10 +443,17 @@ invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) index = ecl_new_binding_index(env, s); } if (index >= env->bds_stack.tl_bindings_size) { - cl_object vector = env->bds_stack.bindings_array; - env->bds_stack.bindings_array = vector = ecl_extend_bindings_array(vector); - env->bds_stack.tl_bindings_size = vector->vector.dim; - env->bds_stack.tl_bindings = vector->vector.self.t; + 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; } diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index bb2817d79..bbc6c0efd 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -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_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_p != ECL_NIL || env->bds_stack.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()->bds_stack.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->bds_stack.bindings_array = process->process.initial_bindings; - env_aux->bds_stack.tl_bindings_size = env_aux->bds_stack.bindings_array->vector.dim; - env_aux->bds_stack.tl_bindings = env_aux->bds_stack.bindings_array->vector.self.t; + init_tl_bindings(process, env_aux); /* Switch over to the real environment */ memcpy(env, env_aux, sizeof(*env)); @@ -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->bds_stack.bindings_array = process->process.initial_bindings; - process_env->bds_stack.tl_bindings_size = - process_env->bds_stack.bindings_array->vector.dim; - process_env->bds_stack.tl_bindings = - process_env->bds_stack.bindings_array->vector.self.t; + init_tl_bindings(process, process_env); ecl_disable_interrupts_env(the_env); #ifdef ECL_WINDOWS_THREADS diff --git a/src/h/external.h b/src/h/external.h index d77f148f5..f37c68e5b 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -26,7 +26,6 @@ struct ecl_binding_stack { #ifdef ECL_THREADS cl_index tl_bindings_size; cl_object *tl_bindings; - cl_object bindings_array; #endif cl_index size; cl_index limit_size; diff --git a/src/h/object.h b/src/h/object.h index e0ee2fb34..1906181fa 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; -- GitLab From 7db0a89f42d0ad9100cf87f37507f5ce966883e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 2 May 2025 14:43:08 +0200 Subject: [PATCH 10/23] stacks: use a manual allocator for stacks Objects have a well defind extent so there is no need to rely on GC for them. This change allows us to move stack initialization before garbage collector is introduced into the system (or even without any GC). --- src/c/alloc_2.d | 20 ++--- src/c/main.d | 8 +- src/c/stacks.d | 186 ++++++++++++++++++++++++----------------- src/c/threads/thread.d | 3 +- src/h/internal.h | 2 +- 5 files changed, 123 insertions(+), 96 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 10c2b33a5..0bb2b7674 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1152,19 +1152,13 @@ update_bytes_consed () { static void ecl_mark_env(struct cl_env_struct *env) { - if (env->run_stack.org) { - GC_push_conditional((void *)env->run_stack.org, (void *)env->run_stack.top, 1); - GC_set_mark_bit((void *)env->run_stack.org); - } - if (env->frs_stack.top) { - GC_push_conditional((void *)env->frs_stack.org, (void *)(env->frs_stack.top+1), 1); - GC_set_mark_bit((void *)env->frs_stack.org); - } - if (env->bds_stack.top) { - GC_push_conditional((void *)env->bds_stack.org, (void *)(env->bds_stack.top+1), 1); - GC_set_mark_bit((void *)env->bds_stack.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, diff --git a/src/c/main.d b/src/c/main.d index 46fc0bc70..0140087c1 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -226,8 +226,11 @@ 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. */ + ecl_free(env->run_stack.org); + ecl_free(env->frs_stack.org); + ecl_free(env->bds_stack.org); #ifdef ECL_THREADS ecl_free(env->bds_stack.tl_bindings); env->bds_stack.tl_bindings_size = 0; @@ -525,7 +528,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 diff --git a/src/c/stacks.d b/src/c/stacks.d index d86d5acd4..c862f46f2 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -24,6 +24,28 @@ /* ------------------------- C STACK ---------------------------------- */ +static void +cs_set_size(cl_env_ptr env, cl_index new_size); + +void +ecl_cs_init(cl_env_ptr env) +{ +#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 +#endif + { + /* Rough estimate. Not very safe. We assume that cl_boot() + * is invoked from the main() routine of the program. */ + env->c_stack.org = (char*)(&env); + } + env->c_stack.max = env->c_stack.org; + env->c_stack.max_size = 0; + cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); +} + static void cs_set_size(cl_env_ptr env, cl_index new_size) { @@ -113,53 +135,53 @@ ecl_cs_overflow(void) cs_set_size(env, size); } -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->c_stack.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->c_stack.org = (char*)(&env); - } - env->c_stack.max = env->c_stack.org; - env->c_stack.max_size = 0; - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); -} - /* ------------------------- LISP STACK ------------------------------- */ +static void +run_init(cl_env_ptr env) +{ + cl_index size, limit_size, margin; + margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_LISP_STACK_SIZE]; + size = ((size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE; + limit_size = size - 2*margin; + env->run_stack.size = size; + env->run_stack.limit_size = limit_size; + 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]; + /* 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. */ + *(env->run_stack.top++) = ecl_make_fixnum(0); +} + cl_object * ecl_data_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) { cl_index top = env->run_stack.top - env->run_stack.org; 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; + cl_index nsize = tentative_new_size + 2*safety_area; + cl_index osize = env->run_stack.size; /* Round to page size */ - new_size = ((new_size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE; + nsize = ((nsize + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE; - if (ecl_unlikely(top > new_size)) { + if (ecl_unlikely(top > nsize)) { FEerror("Internal error: cannot shrink stack below stack top.",0); } old_stack = env->run_stack.org; - new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); + new_stack = (cl_object *)ecl_realloc(old_stack, + osize * sizeof(cl_object), + nsize * sizeof(cl_object)); ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(new_stack, old_stack, env->run_stack.size * sizeof(cl_object)); - env->run_stack.size = new_size; - env->run_stack.limit_size = new_size - 2*safety_area; + env->run_stack.size = nsize; + env->run_stack.limit_size = nsize - 2*safety_area; env->run_stack.org = new_stack; env->run_stack.top = env->run_stack.org + top; - env->run_stack.limit = env->run_stack.org + (new_size - 2*safety_area); + env->run_stack.limit = env->run_stack.org + (nsize - 2*safety_area); /* 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. @@ -168,8 +190,6 @@ ecl_data_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) *(env->run_stack.top++) = ecl_make_fixnum(0); } ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_stack); return env->run_stack.top; } @@ -283,28 +303,40 @@ ecl_bds_unwind_n(cl_env_ptr env, int n) } static void -ecl_bds_set_size(cl_env_ptr env, cl_index new_size) +bds_init(cl_env_ptr env) +{ + cl_index size, margin; + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; + env->bds_stack.size = size; + 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[size - 2*margin]; +} + +static void +ecl_bds_set_size(cl_env_ptr env, cl_index nsize) { ecl_bds_ptr old_org = env->bds_stack.org; cl_index limit = env->bds_stack.top - old_org; - if (new_size <= limit) { + cl_index osize = env->bds_stack.size; + if (nsize <= 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_stack.limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + org = ecl_realloc(old_org, + osize * sizeof(*org), + nsize * sizeof(*org)); ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); memcpy(org, old_org, (limit + 1) * sizeof(*org)); env->bds_stack.top = org + limit; env->bds_stack.org = org; - env->bds_stack.limit = org + (new_size - 2*margin); - env->bds_stack.size = new_size; + env->bds_stack.limit = org + (nsize - 2*margin); + env->bds_stack.size = nsize; + env->bds_stack.limit_size = nsize - 2*margin; ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_org); } } @@ -571,6 +603,16 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) /* ------------------------- INVOCATION STACK ------------------------- */ +static void +ihs_init(cl_env_ptr env) +{ + 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; +} + static ecl_ihs_ptr get_ihs_ptr(cl_index n) { @@ -628,28 +670,39 @@ si_ihs_env(cl_object arg) /* ------------------------- FRAME STACK ------------------------------ */ static void -frs_set_size(cl_env_ptr env, cl_index new_size) +frs_init(cl_env_ptr env) +{ + cl_index size, margin; + margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; + env->frs_stack.size = size; + 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[size - 2*margin]; +} + +static void +frs_set_size(cl_env_ptr env, cl_index nsize) { ecl_frame_ptr old_org = env->frs_stack.org; cl_index limit = env->frs_stack.top - old_org; - if (new_size <= limit) { + if (nsize <= 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_stack.limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + cl_index osize = env->frs_stack.size; + org = ecl_realloc(old_org, + osize * sizeof(*org), + nsize * sizeof(*org)); ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); env->frs_stack.top = org + limit; env->frs_stack.org = org; - env->frs_stack.limit = org + (new_size - 2*margin); - env->frs_stack.size = new_size; + env->frs_stack.limit = org + (nsize - 2*margin); + env->frs_stack.size = nsize; + env->frs_stack.limit_size = nsize - 2*margin; ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_org); } } @@ -853,31 +906,8 @@ si_reset_margin(cl_object type) 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_stack.size = size; - env->frs_stack.org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_stack.org)); - env->frs_stack.top = env->frs_stack.org-1; - env->frs_stack.limit = &env->frs_stack.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_stack.size = size; - env->bds_stack.org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_stack.org)); - env->bds_stack.top = env->bds_stack.org-1; - env->bds_stack.limit = &env->bds_stack.org[size - 2*margin]; - /* ihs stack */ - env->ihs_stack.top = &ihs_org; - ihs_org.function = ECL_NIL; - ihs_org.lex_env = ECL_NIL; - ihs_org.index = 0; - /* lisp stack */ - env->run_stack.org = NULL; - env->run_stack.top = NULL; - env->run_stack.limit = NULL; - env->run_stack.size = 0; - ecl_data_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); + frs_init(env); + bds_init(env); + ihs_init(env); + run_init(env); } diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index bbc6c0efd..cdb2c3333 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 @@ -761,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/h/internal.h b/src/h/internal.h index a368f7537..5ca1e1004 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -557,7 +557,7 @@ extern cl_object ecl_deserialize(uint8_t *data); #define CL_NEWENV_END \ 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); #ifndef RLIM_SAVED_MAX # define RLIM_SAVED_MAX RLIM_INFINITY -- GitLab From 6463cae89cb63b4a9488cf9bb9dcd1ce0a7ba28e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Apr 2024 14:16:37 +0200 Subject: [PATCH 11/23] stacks: rename bindings and runtime stack pointers stored in frs They are named to follow the same convention hinting that it is an index, not a pointer. --- src/c/compiler.d | 6 +++--- src/c/ffi.d | 2 +- src/c/interpreter.d | 2 +- src/c/stacks.d | 16 ++++++++-------- src/h/external.h | 2 +- src/h/stacks.h | 8 ++++---- 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index f3c054576..cce49e626 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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 @@ -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_stack.top - env->bds_stack.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/ffi.d b/src/c/ffi.d index f6b3ff17b..9939d0c01 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 6685844b6..3b873197f 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1276,7 +1276,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) THREAD_NEXT; } CASE(OP_PROTECT_NORMAL); { - ecl_bds_unwind(the_env, the_env->frs_stack.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)); diff --git a/src/c/stacks.d b/src/c/stacks.d index c862f46f2..859746715 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -290,7 +290,7 @@ 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); } } @@ -364,9 +364,9 @@ ecl_bds_overflow(void) } 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_stack.org; + 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 @@ -744,9 +744,9 @@ _ecl_frs_push(cl_env_ptr env) output->frs_val = ECL_DUMMY_TAG; AO_nop_full(); ++env->frs_stack.top; - output->frs_bds_top_index = env->bds_stack.top - env->bds_stack.org; + 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; - output->frs_sp = ECL_STACK_INDEX(env); return output; } @@ -760,8 +760,8 @@ ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) --top; } env->ihs_stack.top = top->frs_ihs; - ecl_bds_unwind(env, top->frs_bds_top_index); - ECL_STACK_SET_INDEX(env, top->frs_sp); + 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 */ @@ -801,7 +801,7 @@ 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 diff --git a/src/h/external.h b/src/h/external.h index f37c68e5b..2d8978fca 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1648,7 +1648,7 @@ 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/stacks.h b/src/h/stacks.h index 9dd587497..9aa029f36 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -280,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); @@ -408,9 +408,9 @@ ecl_data_stack_set_index(cl_env_ptr env, cl_index ndx) #define ECL_STACK_REF(env,n) ((env)->run_stack.top[n]) #define ECL_STACK_INDEX(env) ecl_data_stack_index(env) -#define ECL_STACK_SET_INDEX(env,ndx) ecl_data_stack_set_index(env,ndx) -#define ECL_STACK_PUSH(env,o) ecl_data_stack_push(env,o) +#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) -- GitLab From 72fb1c583a4af21252880e7e44bc0dca96c71d0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 16 Apr 2024 08:08:31 +0200 Subject: [PATCH 12/23] stacks: remove serror, stack-error-handler and reset-margin All these operations were propagated up to the condition system in order to reset the stack margin in the case of a non-local exit. We can do that easily with open-coded unwind protect within stacks. --- src/c/error.d | 7 ----- src/c/stacks.d | 70 ++++++++++++++++++++--------------------- src/c/symbols_list.h | 3 -- src/clos/conditions.lsp | 5 --- src/clos/fixup.lsp | 5 --- src/h/external.h | 1 - src/h/internal.h | 3 -- 7 files changed, 34 insertions(+), 60 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index 7e4c1b62b..612dd3a05 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -601,13 +601,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/stacks.d b/src/c/stacks.d index 859746715..13f3170f8 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -118,17 +118,21 @@ ecl_cs_overflow(void) #endif else ecl_unrecoverable_error(env, stack_overflow_msg); - - if (env->c_stack.max_size == (cl_index)0 || env->c_stack.size < env->c_stack.max_size) - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', - @':size', ecl_make_fixnum(size), - @':type', @'ext::c-stack'); - else - si_serror(6, ECL_NIL, - @'ext::stack-overflow', - @':size', ECL_NIL, - @':type', @'ext::c-stack'); + ECL_UNWIND_PROTECT_BEGIN(env) { + if (env->c_stack.max_size == (cl_index)0 || env->c_stack.size < env->c_stack.max_size) + cl_cerror(6, @"Extend stack size", + @'ext::stack-overflow', + @':size', ecl_make_fixnum(size), + @':type', @'ext::c-stack'); + else + cl_error(5, + @'ext::stack-overflow', + @':size', ECL_NIL, + @':type', @'ext::c-stack'); + } ECL_UNWIND_PROTECT_EXIT { + /* reset margin */ + cs_set_size(env, size); + } ECL_UNWIND_PROTECT_END; size += size/2; if (size > env->c_stack.max_size) size = env->c_stack.max_size; @@ -315,7 +319,7 @@ bds_init(cl_env_ptr env) } static void -ecl_bds_set_size(cl_env_ptr env, cl_index nsize) +bds_set_size(cl_env_ptr env, cl_index nsize) { ecl_bds_ptr old_org = env->bds_stack.org; cl_index limit = env->bds_stack.top - old_org; @@ -356,10 +360,15 @@ ecl_bds_overflow(void) ecl_unrecoverable_error(env, stack_overflow_msg); } env->bds_stack.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)); + ECL_UNWIND_PROTECT_BEGIN(env) { + cl_cerror(6, @"Extend stack size", + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::binding-stack'); + } ECL_UNWIND_PROTECT_EXIT { + /* reset margin */ + bds_set_size(env, size); + } ECL_UNWIND_PROTECT_END; + bds_set_size(env, size + (size / 2)); return env->bds_stack.top; } @@ -722,9 +731,14 @@ frs_overflow(void) /* used as condition in list.d */ ecl_unrecoverable_error(env, stack_overflow_msg); } env->frs_stack.limit += margin; - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::frame-stack'); + ECL_UNWIND_PROTECT_BEGIN(env) { + cl_cerror(6, @"Extend stack size", + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::frame-stack'); + } ECL_UNWIND_PROTECT_EXIT { + /* reset margin */ + frs_set_size(env, size); + } ECL_UNWIND_PROTECT_END; frs_set_size(env, size + size / 2); } @@ -846,7 +860,7 @@ si_set_limit(cl_object type, cl_object limit) } 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); + bds_set_size(env, the_size + 2*margin); } else if (type == @'ext::c-stack') { cl_index the_size = ecl_to_size(limit); margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; @@ -887,22 +901,6 @@ 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_stack.size); - else if (type == @'ext::binding-stack') - ecl_bds_set_size(env, env->bds_stack.size); - else if (type == @'ext::c-stack') - cs_set_size(env, env->c_stack.size); - else - ecl_return1(env, ECL_NIL); - - ecl_return1(env, ECL_T); -} - void init_stacks(cl_env_ptr env) { diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index f5da4b072..7a0d12046 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/clos/conditions.lsp b/src/clos/conditions.lsp index fbc3686f7..87c82a4a7 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 9ab0f07ce..4993a8ed4 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/h/external.h b/src/h/external.h index 2d8978fca..e2c24b7dc 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1643,7 +1643,6 @@ 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); diff --git a/src/h/internal.h b/src/h/internal.h index 5ca1e1004..88ae995db 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -298,9 +298,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 */ -- GitLab From 21c23973ae72e3487a414acb5c956c4680c46d16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 27 Mar 2025 20:25:19 +0100 Subject: [PATCH 13/23] stacks: refactor the code in stacks.d - {run,bds,frs}_set_size functions were very similar; I've updated them to follow the same naming convention and execution order to indicate that. - these functions are now renamed to xxx_set_limit -that simplifies some code - there were inconsistencies in how we've treated boot sizes (limit vs size) --- src/c/error.d | 3 +- src/c/stacks.d | 214 +++++++++++++++++++++++------------------------ src/h/external.h | 1 - 3 files changed, 104 insertions(+), 114 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index 612dd3a05..2885792a5 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -506,8 +506,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); diff --git a/src/c/stacks.d b/src/c/stacks.d index 13f3170f8..bb3bc82a9 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 @@ -19,6 +19,7 @@ # include # include #endif +#include #include #include @@ -146,67 +147,47 @@ run_init(cl_env_ptr env) { cl_index size, limit_size, margin; margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_LISP_STACK_SIZE]; - size = ((size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE; - limit_size = size - 2*margin; - env->run_stack.size = size; - env->run_stack.limit_size = limit_size; + 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. */ *(env->run_stack.top++) = ecl_make_fixnum(0); } -cl_object * -ecl_data_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) +void +data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size) { - cl_index top = env->run_stack.top - env->run_stack.org; - cl_object *new_stack, *old_stack; - cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; - cl_index nsize = tentative_new_size + 2*safety_area; + 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; - - /* Round to page size */ - nsize = ((nsize + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE; - - if (ecl_unlikely(top > nsize)) { - FEerror("Internal error: cannot shrink stack below stack top.",0); - } - - old_stack = env->run_stack.org; - new_stack = (cl_object *)ecl_realloc(old_stack, - osize * sizeof(cl_object), - nsize * sizeof(cl_object)); - + 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"); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + 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 = nsize - 2*safety_area; - env->run_stack.org = new_stack; - env->run_stack.top = env->run_stack.org + top; - env->run_stack.limit = env->run_stack.org + (nsize - 2*safety_area); - - /* 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->run_stack.top++) = ecl_make_fixnum(0); - } + env->run_stack.limit_size = new_lim_size; ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - return env->run_stack.top; -} - -void -FEstack_underflow(void) -{ - FEerror("Internal error: stack underflow.",0); } cl_object * ecl_data_stack_grow(cl_env_ptr env) { - return ecl_data_stack_set_size(env, env->run_stack.size + env->run_stack.size / 2); + data_stack_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); + return env->run_stack.top; } cl_index @@ -219,7 +200,7 @@ ecl_data_stack_push_values(cl_env_ptr env) { p = b + i; } env->run_stack.top = p; - memcpy(b, env->values, i * sizeof(cl_object)); + ecl_copy(b, env->values, i * sizeof(cl_object)); return i; } @@ -227,10 +208,10 @@ void 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)) - FEstack_underflow(); + ecl_internal_error("data stack: stack underflow."); env->nvalues = n; env->run_stack.top = p; - memcpy(env->values, p, n * sizeof(cl_object)); + ecl_copy(env->values, p, n * sizeof(cl_object)); } cl_object @@ -240,7 +221,8 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) cl_index bindex; if (size) { if ((env->run_stack.limit - base) < size) { - base = ecl_data_stack_set_size(env, env->run_stack.size + size); + data_stack_set_limit(env, env->run_stack.limit_size + size); + base = env->run_stack.top; } } bindex = ECL_STACK_INDEX(env); @@ -309,39 +291,39 @@ ecl_bds_unwind_n(cl_env_ptr env, int n) static void bds_init(cl_env_ptr env) { - cl_index size, margin; + cl_index size, margin, limit_size; margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; - env->bds_stack.size = size; + 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[size - 2*margin]; + env->bds_stack.limit = &env->bds_stack.org[limit_size]; + env->bds_stack.size = size; + env->bds_stack.limit_size = limit_size; } static void -bds_set_size(cl_env_ptr env, cl_index nsize) +bds_set_limit(cl_env_ptr env, cl_index new_lim_size) { + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; ecl_bds_ptr old_org = env->bds_stack.org; - cl_index limit = env->bds_stack.top - old_org; + ecl_bds_ptr new_org = NULL; cl_index osize = env->bds_stack.size; - if (nsize <= limit) { - FEerror("Cannot shrink the binding stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - ecl_bds_ptr org; - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - org = ecl_realloc(old_org, - osize * sizeof(*org), - nsize * sizeof(*org)); - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->bds_stack.top = org + limit; - env->bds_stack.org = org; - env->bds_stack.limit = org + (nsize - 2*margin); - env->bds_stack.size = nsize; - env->bds_stack.limit_size = nsize - 2*margin; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - } + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->bds_stack.top - old_org; + if (current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + env->bds_stack.org = new_org; + env->bds_stack.top = new_org + current_size; + env->bds_stack.limit = new_org + new_lim_size; + /* Update indexes */ + env->bds_stack.size = nsize; + env->bds_stack.limit_size = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); } ecl_bds_ptr @@ -354,6 +336,7 @@ ecl_bds_overflow(void) cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; 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_stack.limit >= last) { @@ -366,9 +349,9 @@ ecl_bds_overflow(void) @':type', @'ext::binding-stack'); } ECL_UNWIND_PROTECT_EXIT { /* reset margin */ - bds_set_size(env, size); + bds_set_limit(env, limit_size); } ECL_UNWIND_PROTECT_END; - bds_set_size(env, size + (size / 2)); + bds_set_limit(env, limit_size + (limit_size / 2)); return env->bds_stack.top; } @@ -681,38 +664,39 @@ si_ihs_env(cl_object arg) static void frs_init(cl_env_ptr env) { - cl_index size, margin; + cl_index size, margin, limit_size; margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; - env->frs_stack.size = size; + 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[size - 2*margin]; + env->frs_stack.limit = &env->frs_stack.org[limit_size]; + env->frs_stack.size = size; + env->frs_stack.limit_size = limit_size; } static void -frs_set_size(cl_env_ptr env, cl_index nsize) +frs_set_limit(cl_env_ptr env, cl_index new_lim_size) { + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; ecl_frame_ptr old_org = env->frs_stack.org; - cl_index limit = env->frs_stack.top - old_org; - if (nsize <= limit) { - FEerror("Cannot shrink frame stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - ecl_frame_ptr org; - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - cl_index osize = env->frs_stack.size; - org = ecl_realloc(old_org, - osize * sizeof(*org), - nsize * sizeof(*org)); - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - env->frs_stack.top = org + limit; - env->frs_stack.org = org; - env->frs_stack.limit = org + (nsize - 2*margin); - env->frs_stack.size = nsize; - env->frs_stack.limit_size = nsize - 2*margin; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - } + ecl_frame_ptr new_org = NULL; + cl_index osize = env->frs_stack.size; + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->frs_stack.top - old_org; + if(current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + env->frs_stack.org = new_org; + env->frs_stack.top = new_org + current_size; + env->frs_stack.limit = new_org + new_lim_size; + /* Update indexes. */ + env->frs_stack.size = nsize; + env->frs_stack.limit_size = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); } static void @@ -725,6 +709,7 @@ frs_overflow(void) /* used as condition in list.d */ cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; cl_index size = env->frs_stack.size; + cl_index limit_size = env->frs_stack.limit_size; ecl_frame_ptr org = env->frs_stack.org; ecl_frame_ptr last = org + size; if (env->frs_stack.limit >= last) { @@ -737,9 +722,9 @@ frs_overflow(void) /* used as condition in list.d */ @':type', @'ext::frame-stack'); } ECL_UNWIND_PROTECT_EXIT { /* reset margin */ - frs_set_size(env, size); + frs_set_limit(env, limit_size); } ECL_UNWIND_PROTECT_END; - frs_set_size(env, size + size / 2); + frs_set_limit(env, limit_size + limit_size / 2); } ecl_frame_ptr @@ -854,20 +839,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); + 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]; - 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); + bds_set_limit(env, request_size); + } else if (type == @'ext::lisp-stack') { + cl_index current_size = env->run_stack.top - env->run_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink lisp stack below ~D.", 1, limit); + data_stack_set_limit(env, request_size); } 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_data_stack_set_size(env, the_size); } else if (type == @'ext::heap-size') { /* * size_t can be larger than cl_index, and ecl_to_size() @@ -889,10 +881,10 @@ si_get_limit(cl_object type) output = env->frs_stack.limit_size; else if (type == @'ext::binding-stack') output = env->bds_stack.limit_size; - else if (type == @'ext::c-stack') - output = env->c_stack.limit_size; else if (type == @'ext::lisp-stack') 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)); diff --git a/src/h/external.h b/src/h/external.h index e2c24b7dc..95efd55e8 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -541,7 +541,6 @@ 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 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); -- GitLab From fd2fae1a393201bf296cce8305706832539cce43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 28 Mar 2025 20:26:51 +0100 Subject: [PATCH 14/23] stacks: merge stack overflow errors into a single handler Replace calls to cl_error and cl_cerror with CEstack_overflow. --- src/c/error.d | 18 ++++++++++++++++ src/c/stacks.d | 53 +++++++++++------------------------------------- src/h/external.h | 1 + 3 files changed, 31 insertions(+), 41 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index 2885792a5..b420e47af 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -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, ...) { diff --git a/src/c/stacks.d b/src/c/stacks.d index bb3bc82a9..44cfe5241 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -52,6 +52,8 @@ cs_set_size(cl_env_ptr env, cl_index new_size) { volatile char foo = 0; cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + if (new_size > env->c_stack.max_size) + new_size = env->c_stack.max_size; #if defined(ECL_CAN_SET_STACK_SIZE) { struct rlimit rl; @@ -118,26 +120,11 @@ ecl_cs_overflow(void) env->c_stack.limit += margin; #endif else - ecl_unrecoverable_error(env, stack_overflow_msg); - ECL_UNWIND_PROTECT_BEGIN(env) { - if (env->c_stack.max_size == (cl_index)0 || env->c_stack.size < env->c_stack.max_size) - cl_cerror(6, @"Extend stack size", - @'ext::stack-overflow', - @':size', ecl_make_fixnum(size), - @':type', @'ext::c-stack'); - else - cl_error(5, - @'ext::stack-overflow', - @':size', ECL_NIL, - @':type', @'ext::c-stack'); - } ECL_UNWIND_PROTECT_EXIT { - /* reset margin */ - cs_set_size(env, size); - } ECL_UNWIND_PROTECT_END; - size += size/2; - if (size > env->c_stack.max_size) - size = env->c_stack.max_size; - cs_set_size(env, size); + 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 + CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_NIL); } /* ------------------------- LISP STACK ------------------------------- */ @@ -340,18 +327,10 @@ ecl_bds_overflow(void) ecl_bds_ptr org = env->bds_stack.org; ecl_bds_ptr last = org + size; if (env->bds_stack.limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); + ecl_internal_error(stack_overflow_msg); } env->bds_stack.limit += margin; - ECL_UNWIND_PROTECT_BEGIN(env) { - cl_cerror(6, @"Extend stack size", - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::binding-stack'); - } ECL_UNWIND_PROTECT_EXIT { - /* reset margin */ - bds_set_limit(env, limit_size); - } ECL_UNWIND_PROTECT_END; - bds_set_limit(env, limit_size + (limit_size / 2)); + CEstack_overflow(@'ext::binding-stack', ecl_make_fixnum(size), ECL_T); return env->bds_stack.top; } @@ -700,7 +679,7 @@ frs_set_limit(cl_env_ptr env, cl_index new_lim_size) } 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" @@ -713,18 +692,10 @@ frs_overflow(void) /* used as condition in list.d */ ecl_frame_ptr org = env->frs_stack.org; ecl_frame_ptr last = org + size; if (env->frs_stack.limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); + ecl_internal_error(stack_overflow_msg); } env->frs_stack.limit += margin; - ECL_UNWIND_PROTECT_BEGIN(env) { - cl_cerror(6, @"Extend stack size", - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::frame-stack'); - } ECL_UNWIND_PROTECT_EXIT { - /* reset margin */ - frs_set_limit(env, limit_size); - } ECL_UNWIND_PROTECT_END; - frs_set_limit(env, limit_size + limit_size / 2); + CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(size), ECL_T); } ecl_frame_ptr diff --git a/src/h/external.h b/src/h/external.h index 95efd55e8..99dd66a95 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -596,6 +596,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; -- GitLab From 03e9f9296c57835c8db03a98497bd3ddd4f424e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 28 Mar 2025 22:14:11 +0100 Subject: [PATCH 15/23] stacks: refactor file to separate low level and high level operators With this it will possible to move low level primitives earlier in the bootstrap process. --- src/c/main.d | 17 +- src/c/stacks.d | 486 +++++++++++++++++++++++++++-------------------- src/h/internal.h | 9 +- 3 files changed, 291 insertions(+), 221 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 0140087c1..399d3e30b 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -194,17 +194,6 @@ ecl_init_first_env(cl_env_ptr env) { #ifdef ECL_THREADS init_threads(); -#endif -#ifdef ECL_THREADS - { - cl_index idx; - cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*)); - for(idx=0; idx<1024; idx++) { - vector[idx] = ECL_NO_TL_BINDING; - } - env->bds_stack.tl_bindings_size = 1024; - env->bds_stack.tl_bindings = vector; - } #endif init_env_mp(env); init_env_int(env); @@ -228,12 +217,8 @@ _ecl_dealloc_env(cl_env_ptr env) { /* Environment cleanup. This is required because the environment is allocated * using mmap or some other method. */ - ecl_free(env->run_stack.org); - ecl_free(env->frs_stack.org); - ecl_free(env->bds_stack.org); + free_stacks(env); #ifdef ECL_THREADS - ecl_free(env->bds_stack.tl_bindings); - env->bds_stack.tl_bindings_size = 0; ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock); #endif #if defined(ECL_USE_MPROTECT) diff --git a/src/c/stacks.d b/src/c/stacks.d index 44cfe5241..999831b74 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -13,6 +13,7 @@ */ #include +#include #include #include #ifdef HAVE_SYS_RESOURCE_H @@ -23,43 +24,84 @@ #include #include -/* ------------------------- C STACK ---------------------------------- */ - -static void -cs_set_size(cl_env_ptr env, cl_index new_size); - +/* -- C Stack ---------------------------------------------------------------- */ void ecl_cs_init(cl_env_ptr env) { + volatile char foo = 0; + cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + cl_index new_size = ecl_option_values[ECL_OPT_C_STACK_SIZE]; + cl_index max_size = new_size; #ifdef GBC_BOEHM struct GC_stack_base base; if (GC_get_stack_base(&base) == GC_SUCCESS) env->c_stack.org = (char*)base.mem_base; else + env->c_stack.org = (char*)(&env); +#else + /* Rough estimate. Not very safe. We assume that cl_boot() is invoked from the + * main() routine of the program. */ + env->c_stack.org = (char*)(&env); #endif - { - /* Rough estimate. Not very safe. We assume that cl_boot() - * is invoked from the main() routine of the program. */ - env->c_stack.org = (char*)(&env); +#ifdef ECL_CAN_SET_STACK_SIZE + { + struct rlimit rl; + if (!getrlimit(RLIMIT_STACK, &rl)) { + if (new_size > rl.rlim_cur) { + rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size; + if (setrlimit(RLIMIT_STACK, &rl)) + ecl_internal_error("Can't set the size of the C stack"); + } + } else { + rl.rlim_cur = new_size; + rl.rlim_max = max_size; } - env->c_stack.max = env->c_stack.org; - env->c_stack.max_size = 0; - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); + if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) { + /* Either getrlimit failed or returned nonsense, either way we don't + * know the stack size. Use a default of 1 MB and hope for the best. */ + new_size = 1048576; + max_size = 1048576; + } else { + new_size = rl.rlim_cur; + max_size = rl.rlim_max; + } + } +#endif + env->c_stack.limit_size = new_size - 2*margin; + env->c_stack.size = new_size; + env->c_stack.max_size = max_size; +#ifdef ECL_DOWN_STACK + env->c_stack.max = env->c_stack.org - new_size; + if (&foo > (env->c_stack.org - new_size) + 16) { + env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin); + if (env->c_stack.limit < env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); + } +#else + env->c_stack.max = env->c_stack.org + new_size; + if (&foo < (env->c_stack.org + new_size) - 16) { + env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin); + if (env->c_stack.limit > env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); + } +#endif } -static void -cs_set_size(cl_env_ptr env, cl_index new_size) +void +ecl_cs_set_size(cl_env_ptr env, cl_index new_size) { volatile char foo = 0; cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; if (new_size > env->c_stack.max_size) new_size = env->c_stack.max_size; -#if defined(ECL_CAN_SET_STACK_SIZE) +#ifdef ECL_CAN_SET_STACK_SIZE { struct rlimit rl; - if (!getrlimit(RLIMIT_STACK, &rl)) { - env->c_stack.max_size = rl.rlim_max; if (new_size > rl.rlim_cur) { rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size; if (setrlimit(RLIMIT_STACK, &rl)) @@ -69,37 +111,35 @@ cs_set_size(cl_env_ptr env, cl_index new_size) rl.rlim_cur = new_size; } if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) { - /* Either getrlimit failed or returned nonsense, either way we - * don't know the stack size. Use a default of 1 MB and hope for - * the best. */ + /* Either getrlimit failed or returned nonsense, either way we don't know + * the stack size. Use a default of 1 MB and hope for the best. */ new_size = 1048576; } else { new_size = rl.rlim_cur; } -#ifdef ECL_DOWN_STACK - env->c_stack.max = env->c_stack.org - new_size; -#else - env->c_stack.max = env->c_stack.org + new_size; -#endif } #endif - env->c_stack.limit_size = new_size - (2*margin); + env->c_stack.limit_size = new_size - 2*margin; + env->c_stack.size = new_size; #ifdef ECL_DOWN_STACK + env->c_stack.max = env->c_stack.org - new_size; if (&foo > (env->c_stack.org - new_size) + 16) { env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin); if (env->c_stack.limit < env->c_stack.max) env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); } #else + env->c_stack.max = env->c_stack.org + new_size; if (&foo < (env->c_stack.org + new_size) - 16) { env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin); if (env->c_stack.limit > env->c_stack.max) env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); } #endif - else - ecl_internal_error("Can't set the size of the C stack: sanity check failed"); - env->c_stack.size = new_size; } void @@ -127,7 +167,7 @@ ecl_cs_overflow(void) CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_NIL); } -/* ------------------------- LISP STACK ------------------------------- */ +/* -- Data stack ------------------------------------------------------------ */ static void run_init(cl_env_ptr env) @@ -147,7 +187,7 @@ run_init(cl_env_ptr env) } void -data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size) +ecl_data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size) { cl_index margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; cl_object *old_org = env->run_stack.org; @@ -173,7 +213,7 @@ data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size) cl_object * ecl_data_stack_grow(cl_env_ptr env) { - data_stack_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); + ecl_data_stack_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); return env->run_stack.top; } @@ -208,7 +248,7 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) cl_index bindex; if (size) { if ((env->run_stack.limit - base) < size) { - data_stack_set_limit(env, env->run_stack.limit_size + size); + ecl_data_stack_set_limit(env, env->run_stack.limit_size + size); base = env->run_stack.top; } } @@ -267,13 +307,7 @@ ecl_stack_frame_close(cl_object f) } } -/* ------------------------- BINDING STACK ---------------------------- */ - -void -ecl_bds_unwind_n(cl_env_ptr env, int n) -{ - while (n--) ecl_bds_unwind1(env); -} +/* -- Binding stack ---------------------------------------------------------- */ static void bds_init(cl_env_ptr env) @@ -289,31 +323,7 @@ bds_init(cl_env_ptr env) env->bds_stack.limit_size = limit_size; } -static void -bds_set_limit(cl_env_ptr env, cl_index new_lim_size) -{ - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_ptr old_org = env->bds_stack.org; - ecl_bds_ptr new_org = NULL; - cl_index osize = env->bds_stack.size; - cl_index nsize = new_lim_size + 2*margin; - cl_index current_size = env->bds_stack.top - old_org; - if (current_size > new_lim_size) - ecl_internal_error("Cannot shrink frame stack below its minimal element"); - new_org = ecl_realloc(old_org, - osize * sizeof(*old_org), - nsize * sizeof(*old_org)); - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - env->bds_stack.org = new_org; - env->bds_stack.top = new_org + current_size; - env->bds_stack.limit = new_org + new_lim_size; - /* Update indexes */ - env->bds_stack.size = nsize; - env->bds_stack.limit_size = new_lim_size; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); -} - -ecl_bds_ptr +ecl_bds_ptr ecl_bds_overflow(void) { static const char *stack_overflow_msg = @@ -348,65 +358,10 @@ ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx) env->bds_stack.top = new_bds_top; } -cl_index -ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) -{ - cl_object vars = vars0, values = values0; - cl_index n = env->bds_stack.top - env->bds_stack.org; - for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { - if (Null(vars)) { - return n; - } else { - cl_object var = ECL_CONS_CAR(vars); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - if (ecl_symbol_type(var) & ecl_stp_constant) - FEbinding_a_constant(var); - if (Null(values)) { - ecl_bds_bind(env, var, OBJNULL); - } else { - ecl_bds_bind(env, var, ECL_CONS_CAR(values)); - values = ECL_CONS_CDR(values); - } - } - } - FEerror("Wrong arguments to special form PROGV. Either~%" - "~A~%or~%~A~%are not proper lists", - 2, vars0, values0); -} - -static ecl_bds_ptr -get_bds_ptr(cl_object x) -{ - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x); - if (env->bds_stack.org <= p && p <= env->bds_stack.top) - return(p); - } - FEerror("~S is an illegal bds index.", 1, x); -} - -cl_object -si_bds_top() -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org)); -} - -cl_object -si_bds_var(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_bds_ptr(arg)->symbol); -} - -cl_object -si_bds_val(cl_object arg) +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 @@ -572,8 +527,31 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) } #endif /* ECL_THREADS */ -/* ------------------------- INVOCATION STACK ------------------------- */ +void +ecl_bds_set_limit(cl_env_ptr env, cl_index new_lim_size) +{ + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + ecl_bds_ptr old_org = env->bds_stack.org; + ecl_bds_ptr new_org = NULL; + cl_index osize = env->bds_stack.size; + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->bds_stack.top - old_org; + if (current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + env->bds_stack.org = new_org; + env->bds_stack.top = new_org + current_size; + env->bds_stack.limit = new_org + new_lim_size; + /* Update indexes */ + env->bds_stack.size = nsize; + env->bds_stack.limit_size = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); +} +/* -- Invocation stack ------------------------------------------------------- */ static void ihs_init(cl_env_ptr env) { @@ -584,61 +562,7 @@ ihs_init(cl_env_ptr env) ihs_org.index = 0; } -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); -} - -/* ------------------------- FRAME STACK ------------------------------ */ +/* -- Frame stack ------------------------------------------------------------ */ static void frs_init(cl_env_ptr env) @@ -654,8 +578,8 @@ frs_init(cl_env_ptr env) env->frs_stack.limit_size = limit_size; } -static void -frs_set_limit(cl_env_ptr env, cl_index new_lim_size) +void +ecl_frs_set_limit(cl_env_ptr env, cl_index new_lim_size) { cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; ecl_frame_ptr old_org = env->frs_stack.org; @@ -695,7 +619,7 @@ frs_overflow(void) ecl_internal_error(stack_overflow_msg); } env->frs_stack.limit += margin; - CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(size), ECL_T); + CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(limit_size), ECL_T); } ecl_frame_ptr @@ -720,6 +644,59 @@ _ecl_frs_push(cl_env_ptr env) 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) { @@ -737,17 +714,71 @@ ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) /* 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_stack.top; top >= env->frs_stack.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) { @@ -794,7 +825,7 @@ 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); + for (x = get_frame_ptr(fr); x <= env->frs_stack.top && x->frs_ihs->index < y; x++); ecl_return1(env, ((x > env->frs_stack.top) @@ -802,7 +833,63 @@ si_sch_frs_base(cl_object fr, cl_object ihs) : ecl_make_fixnum(x - env->frs_stack.org))); } -/* ------------------------- INITIALIZATION --------------------------- */ +/* -- 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); +} + +/* -- Lisp ops on stacks ---------------------------------------------------- */ cl_object si_set_limit(cl_object type, cl_object limit) @@ -814,23 +901,23 @@ si_set_limit(cl_object type, cl_object limit) cl_index request_size = ecl_to_size(limit); if(current_size > request_size) FEerror("Cannot shrink frame stack below ~D.", 1, limit); - frs_set_limit(env, request_size); + ecl_frs_set_limit(env, request_size); } else if (type == @'ext::binding-stack') { cl_index current_size = env->bds_stack.top - env->bds_stack.org; cl_index request_size = ecl_to_size(limit); if(current_size > request_size) FEerror("Cannot shrink binding stack below ~D.", 1, limit); - bds_set_limit(env, request_size); + ecl_bds_set_limit(env, request_size); } else if (type == @'ext::lisp-stack') { cl_index current_size = env->run_stack.top - env->run_stack.org; cl_index request_size = ecl_to_size(limit); if(current_size > request_size) FEerror("Cannot shrink lisp stack below ~D.", 1, limit); - data_stack_set_limit(env, request_size); + ecl_data_stack_set_limit(env, request_size); } else if (type == @'ext::c-stack') { cl_index the_size = ecl_to_size(limit); margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cs_set_size(env, the_size + 2*margin); + ecl_cs_set_size(env, the_size + 2*margin); } else if (type == @'ext::heap-size') { /* * size_t can be larger than cl_index, and ecl_to_size() @@ -863,12 +950,3 @@ si_get_limit(cl_object type) ecl_return1(env, ecl_make_unsigned_integer(output)); } - -void -init_stacks(cl_env_ptr env) -{ - frs_init(env); - bds_init(env); - ihs_init(env); - run_init(env); -} diff --git a/src/h/internal.h b/src/h/internal.h index 88ae995db..ac05fa98a 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -36,7 +36,10 @@ extern void init_GC(void); #endif extern void init_macros(void); extern void init_read(void); -extern void init_stacks(cl_env_ptr); + +extern cl_object init_stacks(cl_env_ptr); +extern cl_object free_stacks(cl_env_ptr); + extern void init_unixint(int pass); extern void init_unixtime(void); extern void init_compiler(void); @@ -555,6 +558,10 @@ extern cl_object ecl_deserialize(uint8_t *data); ecl_data_stack_pop_values(the_env,__i); } extern void ecl_cs_init(cl_env_ptr env); +extern void ecl_frs_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_bds_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_data_stack_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_cs_set_size(cl_env_ptr env, cl_index n); #ifndef RLIM_SAVED_MAX # define RLIM_SAVED_MAX RLIM_INFINITY -- GitLab From 7dfc7ac5e9015d36c9a8fe9f5b352a812682c2d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 28 Mar 2025 14:16:32 +0100 Subject: [PATCH 16/23] stacks: add a general purpose stack implementation based on vector --- src/c/stacks.d | 84 ++++++++++++++++++++++++++++++++++++++++++++++++ src/h/ecl-inl.h | 20 ++++++++++++ src/h/external.h | 5 +++ 3 files changed, 109 insertions(+) diff --git a/src/c/stacks.d b/src/c/stacks.d index 999831b74..783f33f9c 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -889,6 +889,90 @@ si_ihs_env(cl_object arg) 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); + } +} + +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 diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index 16101fc93..9376c9e34 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -82,6 +82,26 @@ } 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() }} + /* * Static constant definition. */ diff --git a/src/h/external.h b/src/h/external.h index 99dd66a95..b907bba80 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -320,6 +320,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 */ -- GitLab From ecaa73155b1ec01d31a522f42011e023da58dbc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 24 Apr 2024 13:21:11 +0200 Subject: [PATCH 17/23] cleanup: reorganize cl_env_struct --- src/c/unixint.d | 3 +- src/h/external.h | 104 +++++++++++++++++++++++------------------------ 2 files changed, 52 insertions(+), 55 deletions(-) diff --git a/src/c/unixint.d b/src/c/unixint.d index 43a7e4b92..7d6ad09ad 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -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 diff --git a/src/h/external.h b/src/h/external.h index b907bba80..fa888a91c 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -23,49 +23,40 @@ struct ecl_runtime_stack { /* The BinDing Stack stores the bindings of special variables. */ struct ecl_binding_stack { -#ifdef ECL_THREADS - cl_index tl_bindings_size; - cl_object *tl_bindings; -#endif 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 }; -/* 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 { - struct ecl_frame *nlj_fr; - cl_index frame_id; - 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; }; -/* The Invocation History Stack (IHS) keeps a list of the names of the functions - * that are invoked, together with their lexical environments. */ struct ecl_history_stack { struct ecl_ihs_frame *top; }; -/* 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 { - cl_index max_size; /* maximum possible size */ - 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 */ }; @@ -78,52 +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]; - /* -- 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. */ + /* 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 */ - /* Private variables used by different parts of ECL: */ + /* -- Invocation of closures, generic function, etc ------------------ */ + cl_object function; + cl_object stepper; /* Hook invoked by ByteVM */ + cl_object stack_frame; /* Current stack frame */ + + /* -- System Processes (native threads) ------------------------------ */ +#ifdef ECL_THREADS + cl_object own_process; /* Backpointer to the host process. */ + int cleanup; +#endif + + /* -- 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; @@ -131,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 { -- GitLab From 5233c2104afa0de3049cdc5001a18cea74a65705 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 19 May 2025 08:28:50 +0200 Subject: [PATCH 18/23] stacks: move ECL_STACK_RESIZE_DISABLE_INTERRUPTS before realloc --- src/c/stacks.d | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/c/stacks.d b/src/c/stacks.d index 783f33f9c..018797423 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -197,10 +197,10 @@ ecl_data_stack_set_limit(cl_env_ptr env, cl_index new_lim_size) 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)); - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); env->run_stack.org = new_org; env->run_stack.top = new_org + current_size; env->run_stack.limit = new_org + new_lim_size; @@ -538,10 +538,10 @@ ecl_bds_set_limit(cl_env_ptr env, cl_index new_lim_size) 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)); - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); env->bds_stack.org = new_org; env->bds_stack.top = new_org + current_size; env->bds_stack.limit = new_org + new_lim_size; @@ -587,12 +587,12 @@ ecl_frs_set_limit(cl_env_ptr env, cl_index new_lim_size) 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) + 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)); - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); env->frs_stack.org = new_org; env->frs_stack.top = new_org + current_size; env->frs_stack.limit = new_org + new_lim_size; -- GitLab From b1605eaeae39f819aeec84280dafb0dafe8eb16b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 19 May 2025 08:34:24 +0200 Subject: [PATCH 19/23] update the changelog --- CHANGELOG | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index d25ead654..36293166b 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. -- GitLab From 71763174eff2266076be43fae632dae7b1385765 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 26 May 2025 07:49:36 +0200 Subject: [PATCH 20/23] doc: clarify wording for :INITIAL-BINDINGS in MAKE-PROCESS --- src/doc/manual/extensions/mp_ref_process.txi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/doc/manual/extensions/mp_ref_process.txi b/src/doc/manual/extensions/mp_ref_process.txi index 3857d1a99..d25cd6976 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 -- GitLab From 8fcac4bd9fec037f96cf0a35404b1078b6f76707 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 28 May 2025 11:08:27 +0200 Subject: [PATCH 21/23] ecl-inl: add looping over stack frames --- src/h/ecl-inl.h | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index 9376c9e34..c12bf0821 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -102,6 +102,24 @@ #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. */ -- GitLab From e9e97815bc258ff6eb8d4c43e5a70e6fe46eabc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 29 May 2025 11:36:48 +0200 Subject: [PATCH 22/23] stacks: make stack frame state consistent based on its operators Previously we did not perform necessary checks for whether we should update the frame size and stack pointer or whether we should resize the stack. This commit fixes these functions and adds a missing function to API ecl_stack_frame_pop. --- src/c/eval.d | 2 +- src/c/stacks.d | 58 +++++++++++++++++++++++++++++++++++++++--------- src/h/external.h | 1 + 3 files changed, 49 insertions(+), 12 deletions(-) diff --git a/src/c/eval.d b/src/c/eval.d index 237f54660..97fb81668 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/stacks.d b/src/c/stacks.d index 018797423..adab860cc 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -222,7 +222,7 @@ ecl_data_stack_push_values(cl_env_ptr env) { cl_index i = env->nvalues; cl_object *b = env->run_stack.top; cl_object *p = b + i; - if (p >= env->run_stack.limit) { + while (p >= env->run_stack.limit) { b = ecl_data_stack_grow(env); p = b + i; } @@ -266,35 +266,71 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) void ecl_stack_frame_push(cl_object f, cl_object o) { - cl_env_ptr env = f->frame.env; - cl_object *top = env->run_stack.top; - if (top >= env->run_stack.limit) { - top = ecl_data_stack_grow(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 { + /* XXX we allow here for a frame overflow. -- jd 2025-05-29 */ + /* assert(frame_top == env->run_stack.top, "frame overflow"); */ + cl_env_ptr env = f->frame.env; + ECL_STACK_PUSH(env, o); + f->frame.sp++; + f->frame.size++; + } +} + +cl_object +ecl_stack_frame_pop(cl_object f) +{ + if (f->frame.sp <= f->frame.base) { + ecl_internal_error("ecl_stack_frame_pop: frame underflow."); } - env->run_stack.top = ++top; - *(top-1) = o; - f->frame.size++; + f->frame.sp--; + return *ECL_STACK_FRAME_TOP(f); } void ecl_stack_frame_push_values(cl_object f) { cl_env_ptr env = f->frame.env; - ecl_data_stack_push_values(env); - f->frame.size += env->nvalues; + cl_index limit_index = f->frame.base + f->frame.size; + cl_index vals_length = env->nvalues; + cl_index value_index = f->frame.sp + vals_length; + cl_object *top = ECL_STACK_FRAME_TOP(f); + if (value_index < limit_index) { + ecl_copy(top, env->values, vals_length * sizeof(cl_object)); + f->frame.sp = value_index; + } else { + /* XXX we allow here for a frame overflow. -- jd 2025-05-29 */ + /* assert(frame_top == env->run_stack.top, "frame overflow"); */ + cl_object *ptr = top + vals_length; + while (ptr >= env->run_stack.limit) { + ecl_data_stack_grow(env); + top = ECL_STACK_FRAME_TOP(f); + ptr = top + vals_length; + env->run_stack.top = ptr; + } + ecl_copy(top, env->values, vals_length * sizeof(cl_object)); + f->frame.sp = value_index; + f->frame.size = value_index - f->frame.base; + } } 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_index top_size = f->frame.sp - f->frame.base; + cl_index n = top_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); } + f->frame.sp -= n; return o; } diff --git a/src/h/external.h b/src/h/external.h index fa888a91c..e1af3207b 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -539,6 +539,7 @@ 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); -- GitLab From c00b13f47de89de83b90e7532924df0658df542d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 29 May 2025 14:55:46 +0200 Subject: [PATCH 23/23] stacks: when the stack frame is aligned with the stack, update both This is to ensure that the topmost frame manipulations update also a data stack. --- src/c/stacks.d | 85 ++++++++++++++++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 31 deletions(-) diff --git a/src/c/stacks.d b/src/c/stacks.d index adab860cc..2f09462c5 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -241,6 +241,22 @@ ecl_data_stack_pop_values(cl_env_ptr env, cl_index n) { 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) { @@ -266,72 +282,79 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) void ecl_stack_frame_push(cl_object f, cl_object o) { + 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 { - /* XXX we allow here for a frame overflow. -- jd 2025-05-29 */ - /* assert(frame_top == env->run_stack.top, "frame overflow"); */ - cl_env_ptr env = f->frame.env; - ECL_STACK_PUSH(env, o); + } 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); } - f->frame.sp--; - return *ECL_STACK_FRAME_TOP(f); } void ecl_stack_frame_push_values(cl_object f) { - cl_env_ptr env = f->frame.env; + cl_env_ptr the_env = f->frame.env; cl_index limit_index = f->frame.base + f->frame.size; - cl_index vals_length = env->nvalues; + cl_index vals_length = the_env->nvalues; cl_index value_index = f->frame.sp + vals_length; - cl_object *top = ECL_STACK_FRAME_TOP(f); - if (value_index < limit_index) { - ecl_copy(top, env->values, vals_length * sizeof(cl_object)); + 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 { - /* XXX we allow here for a frame overflow. -- jd 2025-05-29 */ - /* assert(frame_top == env->run_stack.top, "frame overflow"); */ - cl_object *ptr = top + vals_length; - while (ptr >= env->run_stack.limit) { - ecl_data_stack_grow(env); - top = ECL_STACK_FRAME_TOP(f); - ptr = top + vals_length; - env->run_stack.top = ptr; - } - ecl_copy(top, env->values, vals_length * sizeof(cl_object)); + } 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_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 o; - env->nvalues = n; - env->values[0] = o = ECL_NIL; - while (n--) { - env->values[n] = o = ECL_STACK_FRAME_REF(f, n); + 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; } - f->frame.sp -= n; - return o; } void -- GitLab