From da3dc342412f47bb9a473dc3b31af74034430666 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/58] 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 3c75a98b24d7082f246767f3528ebc473ce9c00b 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/58] 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 a624a946b814c23f6217ea701e2febef6ddeacbd 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/58] 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 b42b1532c003d2a5dfbaba302dc9aa02b9881aa2 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/58] 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 5260cbc7de44daabb0fa26cb0f043ea8f22213d8 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/58] 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 3c86211051ace2a3ddbae84730bb81751e86b012 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/58] 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 ad81ee8f421d1db4b5b241d5d40948f12aeb4472 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/58] 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 815e0daa056473e0451861019af14e82d533aa7e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 4 Apr 2024 17:01:07 +0200 Subject: [PATCH 08/58] stacks: make runtime stack accessors inline functions Also remove an unused operator FEstack_advance. --- src/c/compiler.d | 10 ++--- src/c/ffi.d | 6 +-- src/c/interpreter.d | 96 ++++++++++++++++++++++----------------------- src/c/read.d | 6 +-- src/c/stacks.d | 12 ++---- src/c/string.d | 4 +- src/h/external.h | 1 - src/h/stacks.h | 92 ++++++++++++++++++++++++------------------- 8 files changed, 115 insertions(+), 112 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index f3c054576..0c2f7b3eb 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -53,7 +53,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 current_pc(env) ecl_stack_index(env) #define set_pc(env,n) asm_clear(env,n) #define asm_ref(env,n) (cl_fixnum)((env)->run_stack.org[n]) static void asm_clear(cl_env_ptr env, cl_index h); @@ -206,12 +206,12 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { static void asm_op(cl_env_ptr env, cl_fixnum code) { cl_object v = (cl_object)code; - ECL_STACK_PUSH(env,v); + ecl_stack_push(env,v); } static void asm_clear(cl_env_ptr env, cl_index h) { - ECL_STACK_SET_INDEX(env, h); + ecl_stack_set_index_unsafe(env, h); } static void @@ -2813,7 +2813,7 @@ save_bytecodes(cl_env_ptr env, cl_index start, cl_index end) cl_object bytecodes = ecl_alloc_simple_vector(l, ecl_aet_index); cl_index *p; for (p = bytecodes->vector.self.index; end > start; end--, p++) { - *p = (cl_index)ECL_STACK_POP_UNSAFE(env); + *p = (cl_index)ecl_stack_pop_unsafe(env); } return bytecodes; } @@ -2824,7 +2824,7 @@ restore_bytecodes(cl_env_ptr env, cl_object bytecodes) cl_index *p = bytecodes->vector.self.index; cl_index l; for (l = bytecodes->vector.dim; l; l--) { - ECL_STACK_PUSH(env, (cl_object)p[l-1]); + ecl_stack_push(env, (cl_object)p[l-1]); } ecl_dealloc(bytecodes); } diff --git a/src/c/ffi.d b/src/c/ffi.d index f6b3ff17b..34faf54de 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -904,7 +904,7 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, /* Push the newly allocated object onto the stack so that it * is reachable by the garbage collector */ if (ECL_CONS_CAR(args) != object) { - ECL_STACK_PUSH(the_env, object); + ecl_stack_push(the_env, object); } } args = ECL_CONS_CDR(args); @@ -937,12 +937,12 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, volatile cl_index sp; ffi_cif cif; @ { - sp = ECL_STACK_INDEX(the_env); + sp = ecl_stack_index(the_env); prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); 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_set_index_unsafe(the_env, sp); if (object != ECL_NIL) { @(return object); } else { diff --git a/src/c/interpreter.d b/src/c/interpreter.d index b3a8d7413..b187cf14f 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -421,7 +421,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Inlined forms for some functions which act on reg0 and stack. */ CASE(OP_CONS); { - cl_object car = ECL_STACK_POP_UNSAFE(the_env); + cl_object car = ecl_stack_pop_unsafe(the_env); reg0 = CONS(car, reg0); THREAD_NEXT; } @@ -447,7 +447,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_index n; GET_OPARG(n, vector); while (--n) { - reg0 = CONS(ECL_STACK_POP_UNSAFE(the_env), reg0); + reg0 = CONS(ecl_stack_pop_unsafe(the_env), reg0); } THREAD_NEXT; } @@ -475,7 +475,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PINT); { cl_fixnum n; GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + ecl_stack_push(the_env, ecl_make_fixnum(n)); THREAD_NEXT; } @@ -483,7 +483,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Pushes the object in REG0. */ CASE(OP_PUSH); { - ECL_STACK_PUSH(the_env, reg0); + ecl_stack_push(the_env, reg0); THREAD_NEXT; } /* OP_PUSHV n{lcl} @@ -494,13 +494,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHV); { int ndx; GET_OPARG(ndx, vector); - ECL_STACK_PUSH(the_env, ecl_lcl_env_get_var(lcl_env, ndx)); + ecl_stack_push(the_env, ecl_lcl_env_get_var(lcl_env, ndx)); THREAD_NEXT; } CASE(OP_PUSHVC); { int ndx; GET_OPARG(ndx, vector); - ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, ndx)); + ecl_stack_push(the_env, ecl_lex_env_get_var(lex_env, ndx)); THREAD_NEXT; } CASE(OP_PUSHVS); { @@ -509,7 +509,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) value = ECL_SYM_VAL(the_env, var_name); if (ecl_unlikely(value == OBJNULL)) VEunbound_variable(var_name); - ECL_STACK_PUSH(the_env, value); + ecl_stack_push(the_env, value); THREAD_NEXT; } /* OP_PUSHQ n{arg} @@ -518,7 +518,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHQ); { cl_object aux; GET_DATA(aux, vector, data); - ECL_STACK_PUSH(the_env, aux); + ecl_stack_push(the_env, aux); THREAD_NEXT; } @@ -540,7 +540,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the_env->function = ECL_SYM_FUN(s); f = ECL_SYM_FUN(s)->cfun.entry; SETUP_ENV(the_env); - reg0 = f(2, ECL_STACK_POP_UNSAFE(the_env), reg0); + reg0 = f(2, ecl_stack_pop_unsafe(the_env), reg0); THREAD_NEXT; } @@ -584,7 +584,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the stack (They all have been deposited by OP_PUSHVALUES) */ CASE(OP_MCALL); { - narg = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + narg = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); reg0 = ECL_STACK_REF(the_env,-narg-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); THREAD_NEXT; @@ -594,14 +594,14 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Pops a single value pushed by a OP_PUSH* operator. */ CASE(OP_POP); { - reg0 = ECL_STACK_POP_UNSAFE(the_env); + reg0 = ecl_stack_pop_unsafe(the_env); THREAD_NEXT; } /* OP_POP1 Pops a single value pushed by a OP_PUSH* operator, ignoring it. */ CASE(OP_POP1); { - (void)ECL_STACK_POP_UNSAFE(the_env); + (void)ecl_stack_pop_unsafe(the_env); THREAD_NEXT; } /* OP_POPREQ @@ -624,7 +624,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) if (frame_index >= frame->frame.size) { reg0 = ECL_NIL; } else { - ECL_STACK_PUSH(the_env, ECL_STACK_FRAME_REF(frame, frame_index++)); + ecl_stack_push(the_env, ECL_STACK_FRAME_REF(frame, frame_index++)); reg0 = ECL_T; } THREAD_NEXT; @@ -676,8 +676,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) } } } - if (flag != ECL_NIL) ECL_STACK_PUSH(the_env, value); - ECL_STACK_PUSH(the_env, flag); + if (flag != ECL_NIL) ecl_stack_push(the_env, value); + ecl_stack_push(the_env, flag); } if (count && Null(aok)) { cl_object *p = first; @@ -859,7 +859,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) output values are left in VALUES(...). */ CASE(OP_THROW); { - cl_object tag_name = ECL_STACK_POP_UNSAFE(the_env); + cl_object tag_name = ecl_stack_pop_unsafe(the_env); the_env->values[0] = reg0; cl_throw(tag_name); THREAD_NEXT; @@ -954,7 +954,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBIND); { cl_object var_name; GET_DATA(var_name, vector, data); - bind_var(lcl_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + bind_var(lcl_env, var_name, ecl_stack_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_VBIND); { @@ -975,7 +975,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBINDS); { cl_object var_name; GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + ecl_bds_bind(the_env, var_name, ecl_stack_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_VBINDS); { @@ -1027,20 +1027,20 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PSETQ); { int ndx; GET_OPARG(ndx, vector); - ecl_lcl_env_set_var(lcl_env, ndx, ECL_STACK_POP_UNSAFE(the_env)); + ecl_lcl_env_set_var(lcl_env, ndx, ecl_stack_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_PSETQC); { int ndx; GET_OPARG(ndx, vector); - ecl_lex_env_set_var(lex_env, ndx, ECL_STACK_POP_UNSAFE(the_env)); + ecl_lex_env_set_var(lex_env, ndx, ecl_stack_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_PSETQS); { cl_object var; GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(the_env, var, ECL_STACK_POP_UNSAFE(the_env)); + ECL_SETQ(the_env, var, ecl_stack_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_VSETQ); { @@ -1107,8 +1107,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_FRAME); { cl_opcode *exit; GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, tangle_lcl(lcl_env)); - ECL_STACK_PUSH(the_env, (cl_object)exit); + ecl_stack_push(the_env, tangle_lcl(lcl_env)); + ecl_stack_push(the_env, (cl_object)exit); ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result != 0) { reg0 = the_env->values[0]; @@ -1136,8 +1136,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_TAGBODY); { int n; GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, tangle_lcl(lcl_env)); - ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ + ecl_stack_push(the_env, tangle_lcl(lcl_env)); + ecl_stack_push(the_env, (cl_object)vector); /* FIXME! */ vector += n * OPARG_SIZE; ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result != 0) { @@ -1158,7 +1158,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_EXIT_FRAME); { DO_EXIT_FRAME: ecl_frs_pop(the_env); - ECL_STACK_POP_N_UNSAFE(the_env, 2); + ecl_stack_pop_n_unsafe(the_env, 2); THREAD_NEXT; } CASE(OP_NIL); { @@ -1166,7 +1166,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) THREAD_NEXT; } CASE(OP_PUSHNIL); { - ECL_STACK_PUSH(the_env, ECL_NIL); + ecl_stack_push(the_env, ECL_NIL); THREAD_NEXT; } CASE(OP_VALUEREG0); { @@ -1181,7 +1181,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) PUSH_VALUES: CASE(OP_PUSHVALUES); { cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i+1); + ecl_stack_push_n(the_env, i+1); the_env->values[0] = reg0; memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); @@ -1193,7 +1193,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHMOREVALUES); { cl_index n = ecl_fixnum(ECL_STACK_REF(the_env,-1)); cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i); + ecl_stack_push_n(the_env, i); the_env->values[0] = reg0; memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(n + i); @@ -1204,15 +1204,15 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_POPVALUES); { cl_object *dest = the_env->values; - int n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + int n = the_env->nvalues = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); if (n == 0) { *dest = reg0 = ECL_NIL; THREAD_NEXT; } else if (n == 1) { - *dest = reg0 = ECL_STACK_POP_UNSAFE(the_env); + *dest = reg0 = ecl_stack_pop_unsafe(the_env); THREAD_NEXT; } else { - ECL_STACK_POP_N_UNSAFE(the_env,n); + ecl_stack_pop_n_unsafe(the_env,n); memcpy(dest, &ECL_STACK_REF(the_env,0), n * sizeof(cl_object)); reg0 = *dest; THREAD_NEXT; @@ -1226,7 +1226,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_fixnum n; GET_OPARG(n, vector); the_env->nvalues = n; - ECL_STACK_POP_N_UNSAFE(the_env, n); + ecl_stack_pop_n_unsafe(the_env, n); memcpy(the_env->values, &ECL_STACK_REF(the_env, 0), n * sizeof(cl_object)); reg0 = the_env->values[0]; THREAD_NEXT; @@ -1236,7 +1236,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) The index N-th is extracted from the top of the stack. */ CASE(OP_NTHVAL); { - cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + cl_fixnum n = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); if (ecl_unlikely(n < 0)) { VEwrong_arg_type_nth_val(n); } else if ((cl_index)n >= the_env->nvalues) { @@ -1262,15 +1262,15 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, tangle_lcl(lcl_env)); - ECL_STACK_PUSH(the_env, (cl_object)exit); + ecl_stack_push(the_env, tangle_lcl(lcl_env)); + ecl_stack_push(the_env, (cl_object)exit); ecl_frs_push(the_env,ECL_PROTECT_TAG); if (__ecl_frs_push_result != 0) { ecl_frs_pop(the_env); - vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); - unwind_lcl(lcl_env, ECL_STACK_POP_UNSAFE(the_env)); + 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->frs_stack.nlj_fr - the_env->frs_stack.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; @@ -1278,17 +1278,17 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PROTECT_NORMAL); { 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)); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(1)); + (void)ecl_stack_pop_unsafe(the_env); + unwind_lcl(lcl_env, ecl_stack_pop_unsafe(the_env)); + ecl_stack_push(the_env, ecl_make_fixnum(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); while (n--) - the_env->values[n] = ECL_STACK_POP_UNSAFE(the_env); + the_env->values[n] = ecl_stack_pop_unsafe(the_env); reg0 = the_env->values[0]; - n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + n = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); if (n <= 0) ecl_unwind(the_env, the_env->frs_stack.top + n); THREAD_NEXT; @@ -1302,13 +1302,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_PROGV); { cl_object values = reg0; - cl_object vars = ECL_STACK_POP_UNSAFE(the_env); + cl_object vars = ecl_stack_pop_unsafe(the_env); cl_index n = ecl_progv(the_env, vars, values); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + ecl_stack_push(the_env, ecl_make_fixnum(n)); THREAD_NEXT; } CASE(OP_EXIT_PROGV); { - cl_index n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + cl_index n = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); ecl_bds_unwind(the_env, n); THREAD_NEXT; } diff --git a/src/c/read.d b/src/c/read.d index dcb124730..1f2c41d9d 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -910,7 +910,7 @@ static cl_object sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) { cl_env_ptr env = ecl_process_env(); - cl_index sp = ECL_STACK_INDEX(env); + cl_index sp = ecl_stack_index(env); cl_object last, elt, x; cl_fixnum dim, dimcount, i; cl_object rtbl = ecl_current_readtable(); @@ -935,7 +935,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) FEreader_error("Character ~:C is not allowed after #*", in, 1, ECL_CODE_CHAR(x)); } - ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); + ecl_stack_push(env, ecl_make_fixnum(x == '1')); } if (Null(d)) { dim = dimcount; @@ -960,7 +960,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) else x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; } - ECL_STACK_POP_N_UNSAFE(env, dimcount); + ecl_stack_pop_n_unsafe(env, dimcount); @(return x); } diff --git a/src/c/stacks.d b/src/c/stacks.d index a078d04bc..7a1e1da8b 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -179,12 +179,6 @@ 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) { @@ -276,7 +270,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_set_index_unsafe(f->frame.env, f->frame.base); } } @@ -703,7 +697,7 @@ _ecl_frs_push(cl_env_ptr env) ++env->frs_stack.top; output->frs_bds_top_index = env->bds_stack.top - env->bds_stack.org; output->frs_ihs = env->ihs_stack.top; - output->frs_sp = ECL_STACK_INDEX(env); + output->frs_sp = ecl_stack_index(env); return output; } @@ -718,7 +712,7 @@ ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) } 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_stack_set_index_unsafe(env, top->frs_sp); env->frs_stack.top = top; ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); /* never reached */ diff --git a/src/c/string.d b/src/c/string.d index 32093f8b8..6fa76858d 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -881,14 +881,14 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) for (i = 0, l = 0; i < narg; i++) { cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); if (s->base_string.fillp) { - ECL_STACK_PUSH(the_env, s); + ecl_stack_push(the_env, s); l += s->base_string.fillp; } } /* Do actual copying by recovering those strings */ output = ecl_alloc_simple_base_string(l); while (l) { - cl_object s = ECL_STACK_POP_UNSAFE(the_env); + cl_object s = ecl_stack_pop_unsafe(the_env); size_t bytes = s->base_string.fillp; l -= bytes; memcpy(output->base_string.self + l, s->base_string.self, bytes); diff --git a/src/h/external.h b/src/h/external.h index ca4816f8e..f45137c53 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -543,7 +543,6 @@ 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); diff --git a/src/h/stacks.h b/src/h/stacks.h index 27f5cc57a..48558933c 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -364,51 +364,61 @@ 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_REF(env,n) ((env)->run_stack.top[n]) + +static inline void +ecl_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_stack_grow(env); + } + env->run_stack.top = new_top+1; + *new_top = (o); +} -#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) +static inline void +ecl_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_stack_grow(env); + } + env->run_stack.top = new_top + n; +} -#define ECL_STACK_POP_UNSAFE(env) *(--((env)->run_stack.top)) +static inline cl_object +ecl_stack_pop_unsafe(cl_env_ptr env) +{ + return *(--((env)->run_stack.top)); +} -#define ECL_STACK_REF(env,n) ((env)->run_stack.top[n]) +static inline void +ecl_stack_pop_n_unsafe(cl_env_ptr env, cl_index n) +{ + env->run_stack.top -= n; +} + +static inline cl_index +ecl_stack_index(cl_env_ptr env) { + return (env)->run_stack.top - (env)->run_stack.org; +} + +static inline void +ecl_stack_set_index_unsafe(cl_env_ptr env, cl_index ndx) +{ + env->run_stack.top = env->run_stack.org + (ndx); +} + +#define ECL_STACK_INDEX(env) ((env)->run_stack.top - (env)->run_stack.org) + +#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_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) +#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); \ -- GitLab From 52ce2e8f5bf12d1eff0ca1e6feb118c657c89728 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/58] 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 | 5 +++++ 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, 56 insertions(+), 39 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index acbd71b78..aeb0c95f1 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -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 7a1e1da8b..783e75524 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 f45137c53..4c8d96674 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 f2cc791c1b0c356aca8eba5d2b1fbfcc4f0a7e48 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/58] 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 aeb0c95f1..62e8d59a8 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 783e75524..24b092417 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_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_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_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 296f7520b..b374e80bc 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_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 6dcff2267b973b643c075d770e2ba5aed461b5ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 9 Apr 2024 08:25:04 +0200 Subject: [PATCH 11/58] stacks: rename env runtime stack operators ecl_vms_* ecl_stack_* was not specific enough. --- src/c/compiler.d | 10 ++-- src/c/ffi.d | 6 +- src/c/interpreter.d | 130 ++++++++++++++++++++++---------------------- src/c/read.d | 8 +-- src/c/stacks.d | 26 ++++----- src/c/string.d | 4 +- src/h/external.h | 8 +-- src/h/internal.h | 4 +- src/h/stacks.h | 26 ++++----- 9 files changed, 111 insertions(+), 111 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 0c2f7b3eb..64333f73d 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -53,7 +53,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 current_pc(env) ecl_vms_index(env) #define set_pc(env,n) asm_clear(env,n) #define asm_ref(env,n) (cl_fixnum)((env)->run_stack.org[n]) static void asm_clear(cl_env_ptr env, cl_index h); @@ -206,12 +206,12 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { static void asm_op(cl_env_ptr env, cl_fixnum code) { cl_object v = (cl_object)code; - ecl_stack_push(env,v); + ecl_vms_push(env,v); } static void asm_clear(cl_env_ptr env, cl_index h) { - ecl_stack_set_index_unsafe(env, h); + ecl_vms_unwind(env, h); } static void @@ -2813,7 +2813,7 @@ save_bytecodes(cl_env_ptr env, cl_index start, cl_index end) cl_object bytecodes = ecl_alloc_simple_vector(l, ecl_aet_index); cl_index *p; for (p = bytecodes->vector.self.index; end > start; end--, p++) { - *p = (cl_index)ecl_stack_pop_unsafe(env); + *p = (cl_index)ecl_vms_pop_unsafe(env); } return bytecodes; } @@ -2824,7 +2824,7 @@ restore_bytecodes(cl_env_ptr env, cl_object bytecodes) cl_index *p = bytecodes->vector.self.index; cl_index l; for (l = bytecodes->vector.dim; l; l--) { - ecl_stack_push(env, (cl_object)p[l-1]); + ecl_vms_push(env, (cl_object)p[l-1]); } ecl_dealloc(bytecodes); } diff --git a/src/c/ffi.d b/src/c/ffi.d index 34faf54de..acf6fd459 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -904,7 +904,7 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, /* Push the newly allocated object onto the stack so that it * is reachable by the garbage collector */ if (ECL_CONS_CAR(args) != object) { - ecl_stack_push(the_env, object); + ecl_vms_push(the_env, object); } } args = ECL_CONS_CDR(args); @@ -937,12 +937,12 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, volatile cl_index sp; ffi_cif cif; @ { - sp = ecl_stack_index(the_env); + sp = ecl_vms_index(the_env); prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); 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_unsafe(the_env, sp); + ecl_vms_unwind(the_env, sp); if (object != ECL_NIL) { @(return object); } else { diff --git a/src/c/interpreter.d b/src/c/interpreter.d index b187cf14f..c2c2cafa7 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -421,7 +421,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Inlined forms for some functions which act on reg0 and stack. */ CASE(OP_CONS); { - cl_object car = ecl_stack_pop_unsafe(the_env); + cl_object car = ecl_vms_pop_unsafe(the_env); reg0 = CONS(car, reg0); THREAD_NEXT; } @@ -447,7 +447,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_index n; GET_OPARG(n, vector); while (--n) { - reg0 = CONS(ecl_stack_pop_unsafe(the_env), reg0); + reg0 = CONS(ecl_vms_pop_unsafe(the_env), reg0); } THREAD_NEXT; } @@ -475,7 +475,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PINT); { cl_fixnum n; GET_OPARG(n, vector); - ecl_stack_push(the_env, ecl_make_fixnum(n)); + ecl_vms_push(the_env, ecl_make_fixnum(n)); THREAD_NEXT; } @@ -483,7 +483,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Pushes the object in REG0. */ CASE(OP_PUSH); { - ecl_stack_push(the_env, reg0); + ecl_vms_push(the_env, reg0); THREAD_NEXT; } /* OP_PUSHV n{lcl} @@ -494,13 +494,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHV); { int ndx; GET_OPARG(ndx, vector); - ecl_stack_push(the_env, ecl_lcl_env_get_var(lcl_env, ndx)); + ecl_vms_push(the_env, ecl_lcl_env_get_var(lcl_env, ndx)); THREAD_NEXT; } CASE(OP_PUSHVC); { int ndx; GET_OPARG(ndx, vector); - ecl_stack_push(the_env, ecl_lex_env_get_var(lex_env, ndx)); + ecl_vms_push(the_env, ecl_lex_env_get_var(lex_env, ndx)); THREAD_NEXT; } CASE(OP_PUSHVS); { @@ -509,7 +509,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) value = ECL_SYM_VAL(the_env, var_name); if (ecl_unlikely(value == OBJNULL)) VEunbound_variable(var_name); - ecl_stack_push(the_env, value); + ecl_vms_push(the_env, value); THREAD_NEXT; } /* OP_PUSHQ n{arg} @@ -518,7 +518,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHQ); { cl_object aux; GET_DATA(aux, vector, data); - ecl_stack_push(the_env, aux); + ecl_vms_push(the_env, aux); THREAD_NEXT; } @@ -540,7 +540,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the_env->function = ECL_SYM_FUN(s); f = ECL_SYM_FUN(s)->cfun.entry; SETUP_ENV(the_env); - reg0 = f(2, ecl_stack_pop_unsafe(the_env), reg0); + reg0 = f(2, ecl_vms_pop_unsafe(the_env), reg0); THREAD_NEXT; } @@ -574,7 +574,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_FCALL); { GET_OPARG(narg, vector); - reg0 = ECL_STACK_REF(the_env,-narg-1); + reg0 = ECL_VMS_REF(the_env,-narg-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); THREAD_NEXT; } @@ -584,8 +584,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the stack (They all have been deposited by OP_PUSHVALUES) */ CASE(OP_MCALL); { - narg = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); - reg0 = ECL_STACK_REF(the_env,-narg-1); + narg = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); + reg0 = ECL_VMS_REF(the_env,-narg-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); THREAD_NEXT; } @@ -594,14 +594,14 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Pops a single value pushed by a OP_PUSH* operator. */ CASE(OP_POP); { - reg0 = ecl_stack_pop_unsafe(the_env); + reg0 = ecl_vms_pop_unsafe(the_env); THREAD_NEXT; } /* OP_POP1 Pops a single value pushed by a OP_PUSH* operator, ignoring it. */ CASE(OP_POP1); { - (void)ecl_stack_pop_unsafe(the_env); + (void)ecl_vms_pop_unsafe(the_env); THREAD_NEXT; } /* OP_POPREQ @@ -624,7 +624,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) if (frame_index >= frame->frame.size) { reg0 = ECL_NIL; } else { - ecl_stack_push(the_env, ECL_STACK_FRAME_REF(frame, frame_index++)); + ecl_vms_push(the_env, ECL_STACK_FRAME_REF(frame, frame_index++)); reg0 = ECL_T; } THREAD_NEXT; @@ -676,8 +676,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) } } } - if (flag != ECL_NIL) ecl_stack_push(the_env, value); - ecl_stack_push(the_env, flag); + if (flag != ECL_NIL) ecl_vms_push(the_env, value); + ecl_vms_push(the_env, flag); } if (count && Null(aok)) { cl_object *p = first; @@ -859,7 +859,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) output values are left in VALUES(...). */ CASE(OP_THROW); { - cl_object tag_name = ecl_stack_pop_unsafe(the_env); + cl_object tag_name = ecl_vms_pop_unsafe(the_env); the_env->values[0] = reg0; cl_throw(tag_name); THREAD_NEXT; @@ -954,7 +954,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBIND); { cl_object var_name; GET_DATA(var_name, vector, data); - bind_var(lcl_env, var_name, ecl_stack_pop_unsafe(the_env)); + bind_var(lcl_env, var_name, ecl_vms_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_VBIND); { @@ -975,7 +975,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBINDS); { cl_object var_name; GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, ecl_stack_pop_unsafe(the_env)); + ecl_bds_bind(the_env, var_name, ecl_vms_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_VBINDS); { @@ -1027,20 +1027,20 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PSETQ); { int ndx; GET_OPARG(ndx, vector); - ecl_lcl_env_set_var(lcl_env, ndx, ecl_stack_pop_unsafe(the_env)); + ecl_lcl_env_set_var(lcl_env, ndx, ecl_vms_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_PSETQC); { int ndx; GET_OPARG(ndx, vector); - ecl_lex_env_set_var(lex_env, ndx, ecl_stack_pop_unsafe(the_env)); + ecl_lex_env_set_var(lex_env, ndx, ecl_vms_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_PSETQS); { cl_object var; GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(the_env, var, ecl_stack_pop_unsafe(the_env)); + ECL_SETQ(the_env, var, ecl_vms_pop_unsafe(the_env)); THREAD_NEXT; } CASE(OP_VSETQ); { @@ -1107,14 +1107,14 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_FRAME); { cl_opcode *exit; GET_LABEL(exit, vector); - ecl_stack_push(the_env, tangle_lcl(lcl_env)); - ecl_stack_push(the_env, (cl_object)exit); + ecl_vms_push(the_env, tangle_lcl(lcl_env)); + ecl_vms_push(the_env, (cl_object)exit); ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result != 0) { reg0 = the_env->values[0]; - vector = (cl_opcode *)ECL_STACK_REF(the_env,-1); /* FIXME! */ + vector = (cl_opcode *)ECL_VMS_REF(the_env,-1); /* FIXME! */ /* Unbind locals including the frame, we are leaving the frame. */ - unwind_lcl(lcl_env, ECL_STACK_REF(the_env, -2)); + unwind_lcl(lcl_env, ECL_VMS_REF(the_env,-2)); unbind_lcl(lcl_env, 1); /* unbind the frame */ goto DO_EXIT_FRAME; } @@ -1136,17 +1136,17 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_TAGBODY); { int n; GET_OPARG(n, vector); - ecl_stack_push(the_env, tangle_lcl(lcl_env)); - ecl_stack_push(the_env, (cl_object)vector); /* FIXME! */ + ecl_vms_push(the_env, tangle_lcl(lcl_env)); + ecl_vms_push(the_env, (cl_object)vector); /* FIXME! */ vector += n * OPARG_SIZE; ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result != 0) { /* Wait here for gotos. Each goto sets VALUES(0) to an integer which ranges from 0 to ntags-1, depending on the tag. These numbers are indices into the jump table and are computed at compile time. */ - cl_opcode *table = (cl_opcode *)ECL_STACK_REF(the_env,-1); + cl_opcode *table = (cl_opcode *)ECL_VMS_REF(the_env,-1); /* Unbind locals but leave the frame, we are still inside the frame. */ - unwind_lcl(lcl_env, ECL_STACK_REF(the_env,-2)); + unwind_lcl(lcl_env, ECL_VMS_REF(the_env,-2)); table = table + ecl_fixnum(the_env->values[0]) * OPARG_SIZE; vector = table + *(cl_oparg *)table; } @@ -1158,7 +1158,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_EXIT_FRAME); { DO_EXIT_FRAME: ecl_frs_pop(the_env); - ecl_stack_pop_n_unsafe(the_env, 2); + ecl_vms_pop_n_unsafe(the_env, 2); THREAD_NEXT; } CASE(OP_NIL); { @@ -1166,7 +1166,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) THREAD_NEXT; } CASE(OP_PUSHNIL); { - ecl_stack_push(the_env, ECL_NIL); + ecl_vms_push(the_env, ECL_NIL); THREAD_NEXT; } CASE(OP_VALUEREG0); { @@ -1181,22 +1181,22 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) PUSH_VALUES: CASE(OP_PUSHVALUES); { cl_index i = the_env->nvalues; - ecl_stack_push_n(the_env, i+1); + ecl_vms_push_n(the_env, i+1); the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); + memcpy(&ECL_VMS_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_VMS_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); THREAD_NEXT; } /* OP_PUSHMOREVALUES Adds more values to the ones pushed by OP_PUSHVALUES. */ CASE(OP_PUSHMOREVALUES); { - cl_index n = ecl_fixnum(ECL_STACK_REF(the_env,-1)); + cl_index n = ecl_fixnum(ECL_VMS_REF(the_env,-1)); cl_index i = the_env->nvalues; - ecl_stack_push_n(the_env, i); + ecl_vms_push_n(the_env, i); the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(n + i); + memcpy(&ECL_VMS_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_VMS_REF(the_env, -1) = ecl_make_fixnum(n + i); THREAD_NEXT; } /* OP_POPVALUES @@ -1204,16 +1204,16 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_POPVALUES); { cl_object *dest = the_env->values; - int n = the_env->nvalues = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); + int n = the_env->nvalues = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); if (n == 0) { *dest = reg0 = ECL_NIL; THREAD_NEXT; } else if (n == 1) { - *dest = reg0 = ecl_stack_pop_unsafe(the_env); + *dest = reg0 = ecl_vms_pop_unsafe(the_env); THREAD_NEXT; } else { - ecl_stack_pop_n_unsafe(the_env,n); - memcpy(dest, &ECL_STACK_REF(the_env,0), n * sizeof(cl_object)); + ecl_vms_pop_n_unsafe(the_env,n); + memcpy(dest, &ECL_VMS_REF(the_env,0), n * sizeof(cl_object)); reg0 = *dest; THREAD_NEXT; } @@ -1226,8 +1226,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_fixnum n; GET_OPARG(n, vector); the_env->nvalues = n; - ecl_stack_pop_n_unsafe(the_env, n); - memcpy(the_env->values, &ECL_STACK_REF(the_env, 0), n * sizeof(cl_object)); + ecl_vms_pop_n_unsafe(the_env, n); + memcpy(the_env->values, &ECL_VMS_REF(the_env, 0), n * sizeof(cl_object)); reg0 = the_env->values[0]; THREAD_NEXT; } @@ -1236,7 +1236,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) The index N-th is extracted from the top of the stack. */ CASE(OP_NTHVAL); { - cl_fixnum n = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); + cl_fixnum n = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); if (ecl_unlikely(n < 0)) { VEwrong_arg_type_nth_val(n); } else if ((cl_index)n >= the_env->nvalues) { @@ -1262,15 +1262,15 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); - ecl_stack_push(the_env, tangle_lcl(lcl_env)); - ecl_stack_push(the_env, (cl_object)exit); + ecl_vms_push(the_env, tangle_lcl(lcl_env)); + ecl_vms_push(the_env, (cl_object)exit); ecl_frs_push(the_env,ECL_PROTECT_TAG); if (__ecl_frs_push_result != 0) { ecl_frs_pop(the_env); - vector = (cl_opcode *)ecl_stack_pop_unsafe(the_env); - unwind_lcl(lcl_env, ecl_stack_pop_unsafe(the_env)); + vector = (cl_opcode *)ecl_vms_pop_unsafe(the_env); + unwind_lcl(lcl_env, ecl_vms_pop_unsafe(the_env)); reg0 = the_env->values[0]; - ecl_stack_push(the_env, ecl_make_fixnum(the_env->frs_stack.nlj_fr - the_env->frs_stack.top)); + ecl_vms_push(the_env, ecl_make_fixnum(the_env->frs_stack.nlj_fr - the_env->frs_stack.top)); goto PUSH_VALUES; } THREAD_NEXT; @@ -1278,17 +1278,17 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PROTECT_NORMAL); { 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)); - ecl_stack_push(the_env, ecl_make_fixnum(1)); + (void)ecl_vms_pop_unsafe(the_env); + unwind_lcl(lcl_env, ecl_vms_pop_unsafe(the_env)); + ecl_vms_push(the_env, ecl_make_fixnum(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); + volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); while (n--) - the_env->values[n] = ecl_stack_pop_unsafe(the_env); + the_env->values[n] = ecl_vms_pop_unsafe(the_env); reg0 = the_env->values[0]; - n = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); + n = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); if (n <= 0) ecl_unwind(the_env, the_env->frs_stack.top + n); THREAD_NEXT; @@ -1302,13 +1302,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_PROGV); { cl_object values = reg0; - cl_object vars = ecl_stack_pop_unsafe(the_env); + cl_object vars = ecl_vms_pop_unsafe(the_env); cl_index n = ecl_progv(the_env, vars, values); - ecl_stack_push(the_env, ecl_make_fixnum(n)); + ecl_vms_push(the_env, ecl_make_fixnum(n)); THREAD_NEXT; } CASE(OP_EXIT_PROGV); { - cl_index n = ecl_fixnum(ecl_stack_pop_unsafe(the_env)); + cl_index n = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); ecl_bds_unwind(the_env, n); THREAD_NEXT; } @@ -1325,9 +1325,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) GET_DATA(form, vector, data); SETUP_ENV(the_env); the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); + n = ecl_vms_push_values(the_env); call_stepper(the_env, form, ecl_make_fixnum(1)); - ecl_stack_pop_values(the_env, n); + ecl_vms_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_vms_push_values(the_env); call_stepper(the_env, ECL_NIL, ecl_make_fixnum(-1)); - ecl_stack_pop_values(the_env, n); + ecl_vms_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; } diff --git a/src/c/read.d b/src/c/read.d index 1f2c41d9d..13d066d3f 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -910,7 +910,7 @@ static cl_object sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) { cl_env_ptr env = ecl_process_env(); - cl_index sp = ecl_stack_index(env); + cl_index sp = ecl_vms_index(env); cl_object last, elt, x; cl_fixnum dim, dimcount, i; cl_object rtbl = ecl_current_readtable(); @@ -935,7 +935,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) FEreader_error("Character ~:C is not allowed after #*", in, 1, ECL_CODE_CHAR(x)); } - ecl_stack_push(env, ecl_make_fixnum(x == '1')); + ecl_vms_push(env, ecl_make_fixnum(x == '1')); } if (Null(d)) { dim = dimcount; @@ -951,7 +951,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) unlikely_if (dim && (dimcount == 0)) FEreader_error("Cannot fill the bit-vector #*.", in, 0); } - last = ECL_STACK_REF(env,-1); + last = ECL_VMS_REF(env,-1); x = ecl_alloc_simple_vector(dim, ecl_aet_bit); for (i = 0; i < dim; i++) { elt = (i < dimcount) ? env->run_stack.org[sp+i] : last; @@ -960,7 +960,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) else x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; } - ecl_stack_pop_n_unsafe(env, dimcount); + ecl_vms_pop_n_unsafe(env, dimcount); @(return x); } diff --git a/src/c/stacks.d b/src/c/stacks.d index 24b092417..efe16edd0 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -156,7 +156,7 @@ run_init(cl_env_ptr env) } cl_object * -ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) +ecl_vms_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; @@ -200,18 +200,18 @@ FEstack_underflow(void) } cl_object * -ecl_stack_grow(cl_env_ptr env) +ecl_vms_grow(cl_env_ptr env) { - return ecl_stack_set_size(env, env->run_stack.size + env->run_stack.size / 2); + return ecl_vms_set_size(env, env->run_stack.size + env->run_stack.size / 2); } cl_index -ecl_stack_push_values(cl_env_ptr env) { +ecl_vms_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_vms_grow(env); p = b + i; } env->run_stack.top = p; @@ -220,7 +220,7 @@ ecl_stack_push_values(cl_env_ptr env) { } void -ecl_stack_pop_values(cl_env_ptr env, cl_index n) { +ecl_vms_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(); @@ -236,7 +236,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_vms_set_size(env, env->run_stack.size + size); } } bindex = ECL_STACK_INDEX(env); @@ -256,7 +256,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_vms_grow(env); } env->run_stack.top = ++top; *(top-1) = o; @@ -267,7 +267,7 @@ void ecl_stack_frame_push_values(cl_object f) { cl_env_ptr env = f->frame.env; - ecl_stack_push_values(env); + ecl_vms_push_values(env); f->frame.size += env->nvalues; } @@ -290,7 +290,7 @@ ecl_stack_frame_close(cl_object f) { if (f->frame.opened) { f->frame.opened = 0; - ecl_stack_set_index_unsafe(f->frame.env, f->frame.base); + ecl_vms_unwind(f->frame.env, f->frame.base); } } @@ -746,7 +746,7 @@ _ecl_frs_push(cl_env_ptr env) ++env->frs_stack.top; output->frs_bds_top_index = env->bds_stack.top - env->bds_stack.org; output->frs_ihs = env->ihs_stack.top; - output->frs_sp = ecl_stack_index(env); + output->frs_sp = ecl_vms_index(env); return output; } @@ -761,7 +761,7 @@ ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) } env->ihs_stack.top = top->frs_ihs; ecl_bds_unwind(env, top->frs_bds_top_index); - ecl_stack_set_index_unsafe(env, top->frs_sp); + ecl_vms_unwind(env, top->frs_sp); env->frs_stack.top = top; ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); /* never reached */ @@ -853,7 +853,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_vms_set_size(env, the_size); } else if (type == @'ext::heap-size') { /* * size_t can be larger than cl_index, and ecl_to_size() diff --git a/src/c/string.d b/src/c/string.d index 6fa76858d..b90ef6e58 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -881,14 +881,14 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) for (i = 0, l = 0; i < narg; i++) { cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); if (s->base_string.fillp) { - ecl_stack_push(the_env, s); + ecl_vms_push(the_env, s); l += s->base_string.fillp; } } /* Do actual copying by recovering those strings */ output = ecl_alloc_simple_base_string(l); while (l) { - cl_object s = ecl_stack_pop_unsafe(the_env); + cl_object s = ecl_vms_pop_unsafe(the_env); size_t bytes = s->base_string.fillp; l -= bytes; memcpy(output->base_string.self + l, s->base_string.self, bytes); diff --git a/src/h/external.h b/src/h/external.h index 4c8d96674..28c818389 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -542,10 +542,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 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_vms_grow(cl_env_ptr env); +extern ECL_API cl_object *ecl_vms_set_size(cl_env_ptr env, cl_index new_size); +extern ECL_API cl_index ecl_vms_push_values(cl_env_ptr env); +extern ECL_API void ecl_vms_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 b374e80bc..cc62fe77c 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_vms_push_values(the_env); \ #define CL_NEWENV_END \ - ecl_stack_pop_values(the_env,__i); } + ecl_vms_pop_values(the_env,__i); } extern void ecl_cs_init(cl_env_ptr env); diff --git a/src/h/stacks.h b/src/h/stacks.h index 48558933c..85cffc1dc 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -364,46 +364,46 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); * LISP STACK *************/ -#define ECL_STACK_REF(env,n) ((env)->run_stack.top[n]) +#define ECL_VMS_REF(env,n) ((env)->run_stack.top[n]) static inline void -ecl_stack_push(cl_env_ptr env, cl_object o) { +ecl_vms_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_stack_grow(env); + new_top = ecl_vms_grow(env); } env->run_stack.top = new_top+1; *new_top = (o); } static inline void -ecl_stack_push_n(cl_env_ptr env, cl_index n) { +ecl_vms_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_stack_grow(env); + new_top = ecl_vms_grow(env); } env->run_stack.top = new_top + n; } static inline cl_object -ecl_stack_pop_unsafe(cl_env_ptr env) +ecl_vms_pop_unsafe(cl_env_ptr env) { return *(--((env)->run_stack.top)); } static inline void -ecl_stack_pop_n_unsafe(cl_env_ptr env, cl_index n) +ecl_vms_pop_n_unsafe(cl_env_ptr env, cl_index n) { env->run_stack.top -= n; } static inline cl_index -ecl_stack_index(cl_env_ptr env) { +ecl_vms_index(cl_env_ptr env) { return (env)->run_stack.top - (env)->run_stack.org; } static inline void -ecl_stack_set_index_unsafe(cl_env_ptr env, cl_index ndx) +ecl_vms_unwind(cl_env_ptr env, cl_index ndx) { env->run_stack.top = env->run_stack.org + (ndx); } @@ -446,10 +446,10 @@ ecl_stack_set_index_unsafe(cl_env_ptr env, cl_index ndx) #define ECL_UNWIND_PROTECT_EXIT \ __unwinding=0; } \ ecl_frs_pop(__the_env); \ - __nr = ecl_stack_push_values(__the_env); + __nr = ecl_vms_push_values(__the_env); #define ECL_UNWIND_PROTECT_END \ - ecl_stack_pop_values(__the_env,__nr); \ + ecl_vms_pop_values(__the_env,__nr); \ if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) /* unwind-protect variant which disables interrupts during cleanup */ @@ -457,10 +457,10 @@ ecl_stack_set_index_unsafe(cl_env_ptr env, cl_index ndx) __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_vms_push_values(__the_env); #define ECL_UNWIND_PROTECT_THREAD_SAFE_END \ - ecl_stack_pop_values(__the_env,__nr); \ + ecl_vms_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 33b363915eddb15c42c8b28225b033bd5b2a592c 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 12/58] stacks: rename bds and vms 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 | 4 ++-- src/c/interpreter.d | 2 +- src/c/stacks.d | 14 +++++++------- src/h/external.h | 2 +- src/h/stacks.h | 4 ++-- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 64333f73d..8b8634439 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_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/interpreter.d b/src/c/interpreter.d index c2c2cafa7..b0d646eb6 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_vms_pop_unsafe(the_env); unwind_lcl(lcl_env, ecl_vms_pop_unsafe(the_env)); diff --git a/src/c/stacks.d b/src/c/stacks.d index efe16edd0..572fa7519 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -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_vms_ndx = ecl_vms_index(env); output->frs_ihs = env->ihs_stack.top; - output->frs_sp = ecl_vms_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_vms_unwind(env, top->frs_sp); + ecl_bds_unwind(env, top->frs_bds_ndx); + ecl_vms_unwind(env, top->frs_vms_ndx); env->frs_stack.top = top; ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); /* never reached */ @@ -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 28c818389..db56a801d 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 85cffc1dc..3c894e43e 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_vms_ndx; } *ecl_frame_ptr; extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); -- GitLab From 2d8331fca4798a7ea3dfa403962bc70ad794190a 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 13/58] 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 572fa7519..a726b4b51 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 db56a801d..8a36a0f51 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 cc62fe77c..b284881f8 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 2f982650624a0bf9bf2c45e4cff401cd17aab0cf 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 14/58] 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) - rename some more ecl_stack_* functions to ecl_vms_* for clarity --- src/c/compiler.d | 2 +- src/c/error.d | 3 +- src/c/interpreter.d | 58 ++++++------ src/c/read.d | 2 +- src/c/stacks.d | 220 +++++++++++++++++++++----------------------- src/c/string.d | 2 +- src/h/external.h | 3 +- src/h/stacks.h | 10 +- 8 files changed, 145 insertions(+), 155 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 8b8634439..bca9b9fe6 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2813,7 +2813,7 @@ save_bytecodes(cl_env_ptr env, cl_index start, cl_index end) cl_object bytecodes = ecl_alloc_simple_vector(l, ecl_aet_index); cl_index *p; for (p = bytecodes->vector.self.index; end > start; end--, p++) { - *p = (cl_index)ecl_vms_pop_unsafe(env); + *p = (cl_index)ecl_vms_popu(env); } return bytecodes; } 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/interpreter.d b/src/c/interpreter.d index b0d646eb6..9d38f0a11 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -421,7 +421,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Inlined forms for some functions which act on reg0 and stack. */ CASE(OP_CONS); { - cl_object car = ecl_vms_pop_unsafe(the_env); + cl_object car = ecl_vms_popu(the_env); reg0 = CONS(car, reg0); THREAD_NEXT; } @@ -447,7 +447,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_index n; GET_OPARG(n, vector); while (--n) { - reg0 = CONS(ecl_vms_pop_unsafe(the_env), reg0); + reg0 = CONS(ecl_vms_popu(the_env), reg0); } THREAD_NEXT; } @@ -540,7 +540,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the_env->function = ECL_SYM_FUN(s); f = ECL_SYM_FUN(s)->cfun.entry; SETUP_ENV(the_env); - reg0 = f(2, ecl_vms_pop_unsafe(the_env), reg0); + reg0 = f(2, ecl_vms_popu(the_env), reg0); THREAD_NEXT; } @@ -584,7 +584,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the stack (They all have been deposited by OP_PUSHVALUES) */ CASE(OP_MCALL); { - narg = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); + narg = ecl_fixnum(ecl_vms_popu(the_env)); reg0 = ECL_VMS_REF(the_env,-narg-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); THREAD_NEXT; @@ -594,14 +594,14 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Pops a single value pushed by a OP_PUSH* operator. */ CASE(OP_POP); { - reg0 = ecl_vms_pop_unsafe(the_env); + reg0 = ecl_vms_popu(the_env); THREAD_NEXT; } /* OP_POP1 Pops a single value pushed by a OP_PUSH* operator, ignoring it. */ CASE(OP_POP1); { - (void)ecl_vms_pop_unsafe(the_env); + (void)ecl_vms_popu(the_env); THREAD_NEXT; } /* OP_POPREQ @@ -859,7 +859,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) output values are left in VALUES(...). */ CASE(OP_THROW); { - cl_object tag_name = ecl_vms_pop_unsafe(the_env); + cl_object tag_name = ecl_vms_popu(the_env); the_env->values[0] = reg0; cl_throw(tag_name); THREAD_NEXT; @@ -954,7 +954,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBIND); { cl_object var_name; GET_DATA(var_name, vector, data); - bind_var(lcl_env, var_name, ecl_vms_pop_unsafe(the_env)); + bind_var(lcl_env, var_name, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_VBIND); { @@ -975,7 +975,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBINDS); { cl_object var_name; GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, ecl_vms_pop_unsafe(the_env)); + ecl_bds_bind(the_env, var_name, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_VBINDS); { @@ -1027,20 +1027,20 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PSETQ); { int ndx; GET_OPARG(ndx, vector); - ecl_lcl_env_set_var(lcl_env, ndx, ecl_vms_pop_unsafe(the_env)); + ecl_lcl_env_set_var(lcl_env, ndx, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_PSETQC); { int ndx; GET_OPARG(ndx, vector); - ecl_lex_env_set_var(lex_env, ndx, ecl_vms_pop_unsafe(the_env)); + ecl_lex_env_set_var(lex_env, ndx, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_PSETQS); { cl_object var; GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(the_env, var, ecl_vms_pop_unsafe(the_env)); + ECL_SETQ(the_env, var, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_VSETQ); { @@ -1158,7 +1158,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_EXIT_FRAME); { DO_EXIT_FRAME: ecl_frs_pop(the_env); - ecl_vms_pop_n_unsafe(the_env, 2); + ecl_vms_drop(the_env, 2); THREAD_NEXT; } CASE(OP_NIL); { @@ -1181,7 +1181,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) PUSH_VALUES: CASE(OP_PUSHVALUES); { cl_index i = the_env->nvalues; - ecl_vms_push_n(the_env, i+1); + ecl_vms_grow(the_env, i+1); the_env->values[0] = reg0; memcpy(&ECL_VMS_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); ECL_VMS_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); @@ -1193,7 +1193,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHMOREVALUES); { cl_index n = ecl_fixnum(ECL_VMS_REF(the_env,-1)); cl_index i = the_env->nvalues; - ecl_vms_push_n(the_env, i); + ecl_vms_grow(the_env, i); the_env->values[0] = reg0; memcpy(&ECL_VMS_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); ECL_VMS_REF(the_env, -1) = ecl_make_fixnum(n + i); @@ -1204,15 +1204,15 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_POPVALUES); { cl_object *dest = the_env->values; - int n = the_env->nvalues = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); + int n = the_env->nvalues = ecl_fixnum(ecl_vms_popu(the_env)); if (n == 0) { *dest = reg0 = ECL_NIL; THREAD_NEXT; } else if (n == 1) { - *dest = reg0 = ecl_vms_pop_unsafe(the_env); + *dest = reg0 = ecl_vms_popu(the_env); THREAD_NEXT; } else { - ecl_vms_pop_n_unsafe(the_env,n); + ecl_vms_drop(the_env,n); memcpy(dest, &ECL_VMS_REF(the_env,0), n * sizeof(cl_object)); reg0 = *dest; THREAD_NEXT; @@ -1226,7 +1226,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_fixnum n; GET_OPARG(n, vector); the_env->nvalues = n; - ecl_vms_pop_n_unsafe(the_env, n); + ecl_vms_drop(the_env, n); memcpy(the_env->values, &ECL_VMS_REF(the_env, 0), n * sizeof(cl_object)); reg0 = the_env->values[0]; THREAD_NEXT; @@ -1236,7 +1236,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) The index N-th is extracted from the top of the stack. */ CASE(OP_NTHVAL); { - cl_fixnum n = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); + cl_fixnum n = ecl_fixnum(ecl_vms_popu(the_env)); if (ecl_unlikely(n < 0)) { VEwrong_arg_type_nth_val(n); } else if ((cl_index)n >= the_env->nvalues) { @@ -1267,8 +1267,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) ecl_frs_push(the_env,ECL_PROTECT_TAG); if (__ecl_frs_push_result != 0) { ecl_frs_pop(the_env); - vector = (cl_opcode *)ecl_vms_pop_unsafe(the_env); - unwind_lcl(lcl_env, ecl_vms_pop_unsafe(the_env)); + vector = (cl_opcode *)ecl_vms_popu(the_env); + unwind_lcl(lcl_env, ecl_vms_popu(the_env)); reg0 = the_env->values[0]; ecl_vms_push(the_env, ecl_make_fixnum(the_env->frs_stack.nlj_fr - the_env->frs_stack.top)); goto PUSH_VALUES; @@ -1278,17 +1278,17 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PROTECT_NORMAL); { ecl_bds_unwind(the_env, the_env->frs_stack.top->frs_bds_ndx); ecl_frs_pop(the_env); - (void)ecl_vms_pop_unsafe(the_env); - unwind_lcl(lcl_env, ecl_vms_pop_unsafe(the_env)); + (void)ecl_vms_popu(the_env); + unwind_lcl(lcl_env, ecl_vms_popu(the_env)); ecl_vms_push(the_env, ecl_make_fixnum(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); + volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ecl_vms_popu(the_env)); while (n--) - the_env->values[n] = ecl_vms_pop_unsafe(the_env); + the_env->values[n] = ecl_vms_popu(the_env); reg0 = the_env->values[0]; - n = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); + n = ecl_fixnum(ecl_vms_popu(the_env)); if (n <= 0) ecl_unwind(the_env, the_env->frs_stack.top + n); THREAD_NEXT; @@ -1302,13 +1302,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_PROGV); { cl_object values = reg0; - cl_object vars = ecl_vms_pop_unsafe(the_env); + cl_object vars = ecl_vms_popu(the_env); cl_index n = ecl_progv(the_env, vars, values); ecl_vms_push(the_env, ecl_make_fixnum(n)); THREAD_NEXT; } CASE(OP_EXIT_PROGV); { - cl_index n = ecl_fixnum(ecl_vms_pop_unsafe(the_env)); + cl_index n = ecl_fixnum(ecl_vms_popu(the_env)); ecl_bds_unwind(the_env, n); THREAD_NEXT; } diff --git a/src/c/read.d b/src/c/read.d index 13d066d3f..e36a8ca83 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -960,7 +960,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) else x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; } - ecl_vms_pop_n_unsafe(env, dimcount); + ecl_vms_drop(env, dimcount); @(return x); } diff --git a/src/c/stacks.d b/src/c/stacks.d index a726b4b51..46826b046 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_vms_set_size(cl_env_ptr env, cl_index tentative_new_size) +void +vms_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_vms_grow(cl_env_ptr env) +ecl_vms_extend(cl_env_ptr env) { - return ecl_vms_set_size(env, env->run_stack.size + env->run_stack.size / 2); + vms_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); + return env->run_stack.top; } cl_index @@ -215,11 +196,11 @@ ecl_vms_push_values(cl_env_ptr env) { cl_object *b = env->run_stack.top; cl_object *p = b + i; if (p >= env->run_stack.limit) { - b = ecl_vms_grow(env); + b = ecl_vms_extend(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_vms_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("vms: 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_vms_set_size(env, env->run_stack.size + size); + vms_set_limit(env, env->run_stack.limit_size + size); + base = env->run_stack.top; } } bindex = ECL_STACK_INDEX(env); @@ -260,7 +242,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_vms_grow(env); + top = ecl_vms_extend(env); } env->run_stack.top = ++top; *(top-1) = o; @@ -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 FRS 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 BDS 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 VMS stack below ~D.", 1, limit); + vms_set_limit(env, request_size); } else if (type == @'ext::c-stack') { cl_index the_size = ecl_to_size(limit); margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; cs_set_size(env, the_size + 2*margin); - } else if (type == @'ext::lisp-stack') { - cl_index the_size = ecl_to_size(limit); - ecl_vms_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/c/string.d b/src/c/string.d index b90ef6e58..7058dbfa4 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -888,7 +888,7 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) /* Do actual copying by recovering those strings */ output = ecl_alloc_simple_base_string(l); while (l) { - cl_object s = ecl_vms_pop_unsafe(the_env); + cl_object s = ecl_vms_popu(the_env); size_t bytes = s->base_string.fillp; l -= bytes; memcpy(output->base_string.self + l, s->base_string.self, bytes); diff --git a/src/h/external.h b/src/h/external.h index 8a36a0f51..f85f0a0ac 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -541,8 +541,7 @@ 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_vms_grow(cl_env_ptr env); +extern ECL_API cl_object *ecl_vms_extend(cl_env_ptr env); extern ECL_API cl_object *ecl_vms_set_size(cl_env_ptr env, cl_index new_size); extern ECL_API cl_index ecl_vms_push_values(cl_env_ptr env); extern ECL_API void ecl_vms_pop_values(cl_env_ptr env, cl_index n); diff --git a/src/h/stacks.h b/src/h/stacks.h index 3c894e43e..0ec24dc2a 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -370,29 +370,29 @@ static inline void ecl_vms_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_vms_grow(env); + new_top = ecl_vms_extend(env); } env->run_stack.top = new_top+1; *new_top = (o); } static inline void -ecl_vms_push_n(cl_env_ptr env, cl_index n) { +ecl_vms_grow(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_vms_grow(env); + new_top = ecl_vms_extend(env); } env->run_stack.top = new_top + n; } static inline cl_object -ecl_vms_pop_unsafe(cl_env_ptr env) +ecl_vms_popu(cl_env_ptr env) { return *(--((env)->run_stack.top)); } static inline void -ecl_vms_pop_n_unsafe(cl_env_ptr env, cl_index n) +ecl_vms_drop(cl_env_ptr env, cl_index n) { env->run_stack.top -= n; } -- GitLab From a14508cee42df45f938fee643cd4f13ac8774f28 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 15/58] 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 46826b046..b50984461 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 f85f0a0ac..93389e143 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 f7633962d91f5c9748201f34484ba32fdba2ae65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 28 Mar 2025 22:14:11 +0100 Subject: [PATCH 16/58] 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 b50984461..daf3f2726 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -13,6 +13,7 @@ */ #include +#include #include #include #ifdef HAVE_SYS_RESOURCE_H @@ -23,43 +24,84 @@ #include #include -/* ------------------------- C STACK ---------------------------------- */ - -static void -cs_set_size(cl_env_ptr env, cl_index new_size); - +/* -- C Stack ---------------------------------------------------------------- */ void ecl_cs_init(cl_env_ptr env) { + volatile char foo = 0; + cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + cl_index new_size = ecl_option_values[ECL_OPT_C_STACK_SIZE]; + cl_index max_size = new_size; #ifdef GBC_BOEHM struct GC_stack_base base; if (GC_get_stack_base(&base) == GC_SUCCESS) env->c_stack.org = (char*)base.mem_base; else + env->c_stack.org = (char*)(&env); +#else + /* Rough estimate. Not very safe. We assume that cl_boot() is invoked from the + * main() routine of the program. */ + env->c_stack.org = (char*)(&env); #endif - { - /* Rough estimate. Not very safe. We assume that cl_boot() - * is invoked from the main() routine of the program. */ - env->c_stack.org = (char*)(&env); +#ifdef ECL_CAN_SET_STACK_SIZE + { + struct rlimit rl; + if (!getrlimit(RLIMIT_STACK, &rl)) { + if (new_size > rl.rlim_cur) { + rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size; + if (setrlimit(RLIMIT_STACK, &rl)) + ecl_internal_error("Can't set the size of the C stack"); + } + } else { + rl.rlim_cur = new_size; + rl.rlim_max = max_size; } - env->c_stack.max = env->c_stack.org; - env->c_stack.max_size = 0; - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); + if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) { + /* Either getrlimit failed or returned nonsense, either way we don't + * know the stack size. Use a default of 1 MB and hope for the best. */ + new_size = 1048576; + max_size = 1048576; + } else { + new_size = rl.rlim_cur; + max_size = rl.rlim_max; + } + } +#endif + env->c_stack.limit_size = new_size - 2*margin; + env->c_stack.size = new_size; + env->c_stack.max_size = max_size; +#ifdef ECL_DOWN_STACK + env->c_stack.max = env->c_stack.org - new_size; + if (&foo > (env->c_stack.org - new_size) + 16) { + env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin); + if (env->c_stack.limit < env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); + } +#else + env->c_stack.max = env->c_stack.org + new_size; + if (&foo < (env->c_stack.org + new_size) - 16) { + env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin); + if (env->c_stack.limit > env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); + } +#endif } -static void -cs_set_size(cl_env_ptr env, cl_index new_size) +void +ecl_cs_set_size(cl_env_ptr env, cl_index new_size) { volatile char foo = 0; cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; if (new_size > env->c_stack.max_size) new_size = env->c_stack.max_size; -#if defined(ECL_CAN_SET_STACK_SIZE) +#ifdef ECL_CAN_SET_STACK_SIZE { struct rlimit rl; - if (!getrlimit(RLIMIT_STACK, &rl)) { - env->c_stack.max_size = rl.rlim_max; if (new_size > rl.rlim_cur) { rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size; if (setrlimit(RLIMIT_STACK, &rl)) @@ -69,37 +111,35 @@ cs_set_size(cl_env_ptr env, cl_index new_size) rl.rlim_cur = new_size; } if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) { - /* Either getrlimit failed or returned nonsense, either way we - * don't know the stack size. Use a default of 1 MB and hope for - * the best. */ + /* Either getrlimit failed or returned nonsense, either way we don't know + * the stack size. Use a default of 1 MB and hope for the best. */ new_size = 1048576; } else { new_size = rl.rlim_cur; } -#ifdef ECL_DOWN_STACK - env->c_stack.max = env->c_stack.org - new_size; -#else - env->c_stack.max = env->c_stack.org + new_size; -#endif } #endif - env->c_stack.limit_size = new_size - (2*margin); + env->c_stack.limit_size = new_size - 2*margin; + env->c_stack.size = new_size; #ifdef ECL_DOWN_STACK + env->c_stack.max = env->c_stack.org - new_size; if (&foo > (env->c_stack.org - new_size) + 16) { env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin); if (env->c_stack.limit < env->c_stack.max) env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); } #else + env->c_stack.max = env->c_stack.org + new_size; if (&foo < (env->c_stack.org + new_size) - 16) { env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin); if (env->c_stack.limit > env->c_stack.max) env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); } #endif - else - ecl_internal_error("Can't set the size of the C stack: sanity check failed"); - env->c_stack.size = new_size; } void @@ -127,7 +167,7 @@ ecl_cs_overflow(void) CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_NIL); } -/* ------------------------- LISP STACK ------------------------------- */ +/* -- ByteVM stack ----------------------------------------------------------- */ static void run_init(cl_env_ptr env) @@ -147,7 +187,7 @@ run_init(cl_env_ptr env) } void -vms_set_limit(cl_env_ptr env, cl_index new_lim_size) +ecl_vms_set_limit(cl_env_ptr env, cl_index new_lim_size) { cl_index margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; cl_object *old_org = env->run_stack.org; @@ -173,7 +213,7 @@ vms_set_limit(cl_env_ptr env, cl_index new_lim_size) cl_object * ecl_vms_extend(cl_env_ptr env) { - vms_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); + ecl_vms_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); return env->run_stack.top; } @@ -208,7 +248,7 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) cl_index bindex; if (size) { if ((env->run_stack.limit - base) < size) { - vms_set_limit(env, env->run_stack.limit_size + size); + ecl_vms_set_limit(env, env->run_stack.limit_size + size); base = env->run_stack.top; } } @@ -267,13 +307,7 @@ ecl_stack_frame_close(cl_object f) } } -/* ------------------------- BINDING STACK ---------------------------- */ - -void -ecl_bds_unwind_n(cl_env_ptr env, int n) -{ - while (n--) ecl_bds_unwind1(env); -} +/* -- Binding stack ---------------------------------------------------------- */ static void bds_init(cl_env_ptr env) @@ -289,31 +323,7 @@ bds_init(cl_env_ptr env) env->bds_stack.limit_size = limit_size; } -static void -bds_set_limit(cl_env_ptr env, cl_index new_lim_size) -{ - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_ptr old_org = env->bds_stack.org; - ecl_bds_ptr new_org = NULL; - cl_index osize = env->bds_stack.size; - cl_index nsize = new_lim_size + 2*margin; - cl_index current_size = env->bds_stack.top - old_org; - if (current_size > new_lim_size) - ecl_internal_error("Cannot shrink frame stack below its minimal element"); - new_org = ecl_realloc(old_org, - osize * sizeof(*old_org), - nsize * sizeof(*old_org)); - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - env->bds_stack.org = new_org; - env->bds_stack.top = new_org + current_size; - env->bds_stack.limit = new_org + new_lim_size; - /* Update indexes */ - env->bds_stack.size = nsize; - env->bds_stack.limit_size = new_lim_size; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); -} - -ecl_bds_ptr +ecl_bds_ptr ecl_bds_overflow(void) { static const char *stack_overflow_msg = @@ -348,65 +358,10 @@ ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx) env->bds_stack.top = new_bds_top; } -cl_index -ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) -{ - 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 FRS stack below ~D.", 1, limit); - frs_set_limit(env, request_size); + ecl_frs_set_limit(env, request_size); } else if (type == @'ext::binding-stack') { cl_index current_size = env->bds_stack.top - env->bds_stack.org; cl_index request_size = ecl_to_size(limit); if(current_size > request_size) FEerror("Cannot shrink BDS stack below ~D.", 1, limit); - bds_set_limit(env, request_size); + ecl_bds_set_limit(env, request_size); } else if (type == @'ext::lisp-stack') { cl_index current_size = env->run_stack.top - env->run_stack.org; cl_index request_size = ecl_to_size(limit); if(current_size > request_size) FEerror("Cannot shrink VMS stack below ~D.", 1, limit); - vms_set_limit(env, request_size); + ecl_vms_set_limit(env, request_size); } else if (type == @'ext::c-stack') { cl_index the_size = ecl_to_size(limit); margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cs_set_size(env, the_size + 2*margin); + ecl_cs_set_size(env, the_size + 2*margin); } else if (type == @'ext::heap-size') { /* * size_t can be larger than cl_index, and ecl_to_size() @@ -863,12 +950,3 @@ si_get_limit(cl_object type) ecl_return1(env, ecl_make_unsigned_integer(output)); } - -void -init_stacks(cl_env_ptr env) -{ - frs_init(env); - bds_init(env); - ihs_init(env); - run_init(env); -} diff --git a/src/h/internal.h b/src/h/internal.h index b284881f8..d716a0a13 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -36,7 +36,10 @@ extern void init_GC(void); #endif extern void init_macros(void); extern void init_read(void); -extern void init_stacks(cl_env_ptr); + +extern cl_object init_stacks(cl_env_ptr); +extern cl_object free_stacks(cl_env_ptr); + extern void init_unixint(int pass); extern void init_unixtime(void); extern void init_compiler(void); @@ -555,6 +558,10 @@ extern cl_object ecl_deserialize(uint8_t *data); ecl_vms_pop_values(the_env,__i); } extern void ecl_cs_init(cl_env_ptr env); +extern void ecl_frs_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_bds_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_vms_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_cs_set_size(cl_env_ptr env, cl_index n); #ifndef RLIM_SAVED_MAX # define RLIM_SAVED_MAX RLIM_INFINITY -- GitLab From 1551762a7b051625b4f0b1c2b53ca1b00a5a05fa 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 17/58] 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 daf3f2726..a9b8f1781 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 93389e143..31d13e004 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 13755d0bba3f700144d8ea4f3ef9b2cbe1fb8892 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 18/58] cleanup: reorganize cl_env_struct --- src/c/unixint.d | 3 +- src/h/external.h | 109 +++++++++++++++++++++++------------------------ 2 files changed, 54 insertions(+), 58 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 31d13e004..85232f6d3 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 */ }; @@ -75,55 +66,72 @@ struct ecl_c_stack { typedef struct cl_env_struct *cl_env_ptr; 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 ---------------------------------------------- */ + /* Flag for disabling interrupts while we call C library functions. */ + volatile int disable_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 +139,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 2cc9a4d4ee73bd34451b0b9e02ebc38620a99293 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 24 Nov 2022 21:58:50 +0100 Subject: [PATCH 19/58] c/makefile: group files in rough categories We also introduce an empty form for NUCL_OBJS and nucleus.h header for a minimized runtime. This runtime will be developed over next commits so that we can separate runtime essentials from other dependencies. --- src/c/Makefile.in | 77 ++++++++++++++++++++++++++--------------------- src/h/nucleus.h | 9 ++++++ 2 files changed, 51 insertions(+), 35 deletions(-) create mode 100644 src/h/nucleus.h diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 355348014..0b3688502 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -40,42 +40,49 @@ includedir=@includedir@ # Files HDIR = ../ecl -HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h \ - $(HDIR)/object.h $(HDIR)/cs.h $(HDIR)/stacks.h \ - $(HDIR)/external.h $(HDIR)/cons.h $(HDIR)/legacy.h \ - $(HDIR)/number.h $(HDIR)/page.h $(HDIR)/bytecodes.h \ - $(HDIR)/cache.h $(HDIR)/config-internal.h $(HDIR)/ecl_atomics.h \ - $(HDIR)/ecl-inl.h $(HDIR)/internal.h $(HDIR)/stack-resize.h \ - $(HDIR)/threads.h $(HDIR)/impl/math_dispatch2.h \ - $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ - $(HDIR)/impl/math_fenv_msvc.h + +HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h \ + $(HDIR)/cs.h $(HDIR)/stacks.h $(HDIR)/external.h $(HDIR)/cons.h \ + $(HDIR)/legacy.h $(HDIR)/number.h $(HDIR)/page.h $(HDIR)/bytecodes.h \ + $(HDIR)/cache.h $(HDIR)/config-internal.h $(HDIR)/ecl_atomics.h \ + $(HDIR)/ecl-inl.h $(HDIR)/internal.h $(HDIR)/stack-resize.h \ + $(HDIR)/threads.h $(HDIR)/impl/math_dispatch2.h \ + $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ + $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h + +NUCL_OBJS = + CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o -OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o \ - interpreter.o compiler.o disassembler.o $(CLOS_OBJS) \ - reference.o character.o file.o read.o print.o error.o \ - string.o cfun.o reader/parse_integer.o reader/parse_number.o \ - printer/float_to_digits.o printer/float_to_string.o \ - printer/integer_to_string.o printer/write_ugly.o \ - printer/write_object.o printer/write_symbol.o \ - printer/write_array.o printer/write_list.o \ - printer/write_code.o printer/write_sse.o \ - printer/print_unreadable.o ffi/libraries.o ffi/backtrace.o \ - ffi/mmap.o ffi/cdata.o numbers/cos.o numbers/sin.o \ - numbers/tan.o numbers/atan.o numbers/cosh.o numbers/sinh.o \ - numbers/tanh.o numbers/exp.o numbers/expt.o numbers/log.o \ - numbers/sqrt.o numbers/abs.o numbers/zerop.o numbers/plusp.o \ - numbers/minusp.o numbers/negate.o numbers/conjugate.o \ - numbers/one_plus.o numbers/one_minus.o numbers/plus.o \ - numbers/minus.o numbers/times.o numbers/divide.o \ - numbers/number_compare.o numbers/number_equalp.o \ - numbers/minmax.o numbers/floor.o numbers/ceiling.o \ - numbers/round.o numbers/truncate.o typespec.o assignment.o \ - memory.o predicate.o number.o num_pred.o num_arith.o num_co.o \ - num_log.o num_rand.o array.o vector_push.o sequence.o \ - cmpaux.o macros.o backq.o stacks.o time.o unixint.o mapfun.o \ - multival.o hash.o format.o pathname.o structure.o load.o \ - unixfsys.o unixsys.o serialize.o ffi.o sse2.o @EXTRA_OBJS@ \ - threads/atomic.o process.o + +NUM_OBJS = number.o num_pred.o num_arith.o num_co.o num_log.o num_rand.o \ + numbers/cos.o numbers/sin.o numbers/tan.o numbers/atan.o \ + numbers/cosh.o numbers/sinh.o numbers/tanh.o numbers/exp.o \ + numbers/expt.o numbers/log.o numbers/sqrt.o numbers/abs.o \ + numbers/zerop.o numbers/plusp.o numbers/minusp.o numbers/negate.o \ + numbers/conjugate.o numbers/one_plus.o numbers/one_minus.o \ + numbers/plus.o numbers/minus.o numbers/times.o numbers/divide.o \ + numbers/number_compare.o numbers/number_equalp.o numbers/minmax.o \ + numbers/floor.o numbers/ceiling.o numbers/round.o numbers/truncate.o + +WRITER_OBJS = print.o printer/float_to_digits.o printer/float_to_string.o \ + printer/integer_to_string.o printer/write_ugly.o \ + printer/write_object.o printer/write_symbol.o printer/write_array.o \ + printer/write_list.o printer/write_code.o printer/write_sse.o \ + printer/print_unreadable.o + +READER_OBJS = read.o reader/parse_integer.o reader/parse_number.o + +FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o + +OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o \ + compiler.o disassembler.o reference.o character.o file.o error.o \ + string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o \ + vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ + unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ + load.o unixfsys.o unixsys.o serialize.o sse2.o threads/atomic.o \ + process.o \ + $(CLOS_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(FFI_OBJS) \ + $(NUCL_OBJS) @EXTRA_OBJS@ .PHONY: all diff --git a/src/h/nucleus.h b/src/h/nucleus.h new file mode 100644 index 000000000..54c9fc92d --- /dev/null +++ b/src/h/nucleus.h @@ -0,0 +1,9 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +#ifndef ECL_NUCLEUS_H +#define ECL_NUCLEUS_H + +#include "external.h" + +#endif /* ECL_NUCLEUS_H */ -- GitLab From 0b473f57efbb5c70bee06a559f78df0ac782fb02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 10:10:13 +0200 Subject: [PATCH 20/58] core: move defacto constants from cl_core structure to global space --- src/c/compiler.d | 13 ++-- src/c/hash.d | 4 +- src/c/main.d | 84 ++++++++++---------------- src/c/num_co.d | 12 ++-- src/c/number.d | 12 ++-- src/c/numbers/atan.d | 16 +++-- src/c/numbers/round.d | 4 +- src/c/numbers/sqrt.d | 2 +- src/c/package.d | 4 +- src/c/pathname.d | 6 +- src/c/printer/write_object.d | 4 +- src/c/read.d | 12 ++-- src/c/serialize.d | 4 +- src/c/threads/thread.d | 3 +- src/c/time.d | 8 +-- src/c/unixint.d | 4 +- src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp | 12 ++-- src/h/external.h | 36 +++++------ src/h/internal.h | 2 +- 19 files changed, 115 insertions(+), 127 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index bca9b9fe6..72c2eba40 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -3096,10 +3096,11 @@ c_cons_cdr(cl_env_ptr env, cl_object args, int flags) cl_object si_need_to_make_load_form_p(cl_object object) { - cl_object load_form_cache = cl__make_hash_table(@'eq', - ecl_make_fixnum(16), - cl_core.rehash_size, - cl_core.rehash_threshold); + cl_object load_form_cache = + cl__make_hash_table(@'eq', + ecl_make_fixnum(16), + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); cl_object waiting_objects = ecl_list1(object); cl_type type = t_start; @@ -3811,8 +3812,8 @@ init_compiler() cl_object dispatch_table = cl_core.compiler_dispatch = cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); int i; for (i = 0; database[i].symbol; i++) { ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i)); diff --git a/src/c/hash.d b/src/c/hash.d index d9c3320b4..580f16894 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -943,8 +943,8 @@ ecl_extend_hashtable(cl_object hashtable) (weakness ECL_NIL) (synchronized ECL_NIL) (size ecl_make_fixnum(1024)) - (rehash_size cl_core.rehash_size) - (rehash_threshold cl_core.rehash_threshold)) + (rehash_size ecl_ct_default_rehash_size) + (rehash_threshold ecl_ct_default_rehash_threshold)) @ { cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold); if (hash->hash.test == ecl_htt_generic) { diff --git a/src/c/main.d b/src/c/main.d index 399d3e30b..7a0c0998a 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -51,6 +51,26 @@ const char *ecl_self; static struct cl_env_struct first_env; +/* -- constants ----------------------------------------------------- */ + +const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800); + +ecl_def_ct_base_string(ecl_ct_null_string,"",0,,const); + +ecl_def_ct_single_float(ecl_ct_default_rehash_size,1.5f,,const); +ecl_def_ct_single_float(ecl_ct_default_rehash_threshold,0.75f,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_zero,0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_zero,0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_zero,0,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_minus_zero,-0.0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_minus_zero,-0.0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const); + +ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); +ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); + /************************ GLOBAL INITIALIZATION ***********************/ @@ -310,8 +330,6 @@ cl_shutdown(void) ecl_set_option(ECL_OPT_BOOTED, -1); } -ecl_def_ct_single_float(default_rehash_size,1.5f,static,const); -ecl_def_ct_single_float(default_rehash_threshold,0.75f,static,const); ecl_def_ct_base_string(str_common_lisp,"COMMON-LISP",11,static,const); ecl_def_ct_base_string(str_common_lisp_user,"COMMON-LISP-USER",16,static,const); ecl_def_ct_base_string(str_cl,"CL",2,static,const); @@ -334,7 +352,6 @@ ecl_def_ct_base_string(str_gray,"GRAY",4,static,const); #endif ecl_def_ct_base_string(str_star_dot_star,"*.*",3,static,const); ecl_def_ct_base_string(str_rel_star_dot_star,"./*.*",5,static,const); -ecl_def_ct_base_string(str_empty,"",0,static,const); ecl_def_ct_base_string(str_G,"G",1,static,const); ecl_def_ct_base_string(str_T,"T",1,static,const); #ifdef ENABLE_DLOPEN @@ -349,22 +366,6 @@ ecl_def_ct_base_string(str_lsp,"lsp",3,static,const); ecl_def_ct_base_string(str_LSP,"LSP",3,static,const); ecl_def_ct_base_string(str_lisp,"lisp",4,static,const); ecl_def_ct_base_string(str_NIL,"NIL",3,static,const); -ecl_def_ct_base_string(str_slash,"/",1,static,const); - -ecl_def_ct_single_float(flt_zero,0,static,const); -ecl_def_ct_single_float(flt_zero_neg,-0.0,static,const); -ecl_def_ct_double_float(dbl_zero,0,static,const); -ecl_def_ct_double_float(dbl_zero_neg,-0.0,static,const); -ecl_def_ct_long_float(ldbl_zero,0,static,const); -ecl_def_ct_long_float(ldbl_zero_neg,-0.0l,static,const); -ecl_def_ct_ratio(plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),static,const); -ecl_def_ct_ratio(minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),static,const); -ecl_def_ct_single_float(flt_one,1,static,const); -ecl_def_ct_single_float(flt_one_neg,-1,static,const); -ecl_def_ct_single_float(flt_two,2,static,const); -ecl_def_ct_complex(flt_imag_unit,&flt_zero_data,&flt_one_data,static,const); -ecl_def_ct_complex(flt_imag_unit_neg,&flt_zero_data,&flt_one_neg_data,static,const); -ecl_def_ct_complex(flt_imag_two,&flt_zero_data,&flt_two_data,static,const); struct cl_core_struct cl_core = { .packages = ECL_NIL, @@ -393,25 +394,10 @@ struct cl_core_struct cl_core = { .dispatch_reader = ECL_NIL, .char_names = ECL_NIL, - .null_string = (cl_object)&str_empty_data, - - .plus_half = (cl_object)&plus_half_data, - .minus_half = (cl_object)&minus_half_data, - .imag_unit = (cl_object)&flt_imag_unit_data, - .minus_imag_unit = (cl_object)&flt_imag_unit_neg_data, - .imag_two = (cl_object)&flt_imag_two_data, - .singlefloat_zero = (cl_object)&flt_zero_data, - .doublefloat_zero = (cl_object)&dbl_zero_data, - .singlefloat_minus_zero = (cl_object)&flt_zero_neg_data, - .doublefloat_minus_zero = (cl_object)&dbl_zero_neg_data, - .longfloat_zero = (cl_object)&ldbl_zero_data, - .longfloat_minus_zero = (cl_object)&ldbl_zero_neg_data, - - .gensym_prefix = (cl_object)&str_G_data, - .gentemp_prefix = (cl_object)&str_T_data, - .gentemp_counter = ecl_make_fixnum(0), - .Jan1st1970UT = ECL_NIL, + .gensym_prefix = ECL_NIL, + .gentemp_prefix = ECL_NIL, + .gentemp_counter = ecl_make_fixnum(0), .system_properties = ECL_NIL, @@ -419,9 +405,8 @@ struct cl_core_struct cl_core = { #ifdef ECL_THREADS .processes = ECL_NIL, #endif - /* LIBRARIES is an adjustable vector of objects. It behaves as - a vector of weak pointers thanks to the magic in - gbc.d/alloc_2.d */ + /* LIBRARIES is an adjustable vector of objects. It behaves as a vector of + weak pointers thanks to the magic in the garbage collector. */ .libraries = ECL_NIL, .max_heap_size = 0, @@ -440,13 +425,8 @@ struct cl_core_struct cl_core = { .last_var_index = 0, .reused_indices = ECL_NIL, #endif - .slash = (cl_object)&str_slash_data, - .compiler_dispatch = ECL_NIL, - .rehash_size = (cl_object)&default_rehash_size_data, - .rehash_threshold = (cl_object)&default_rehash_threshold_data, - .known_signals = ECL_NIL }; @@ -555,6 +535,8 @@ cl_boot(int argc, char **argv) #else cl_core.path_max = MAXPATHLEN; #endif + cl_core.gensym_prefix = (cl_object)&str_G_data; + cl_core.gentemp_prefix = (cl_object)&str_T_data; cl_core.lisp_package = ecl_make_package(str_common_lisp, @@ -645,8 +627,8 @@ cl_boot(int argc, char **argv) */ cl_core.char_names = aux = cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); for (i = 0; char_names[i].elt.self; i++) { cl_object name = (cl_object)(char_names + i); cl_object code = ecl_make_fixnum(i); @@ -672,8 +654,8 @@ cl_boot(int argc, char **argv) */ cl_core.system_properties = cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); @@ -738,8 +720,8 @@ cl_boot(int argc, char **argv) */ ECL_SET(@'si::*class-name-hash-table*', cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold)); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold)); /* * Features. diff --git a/src/c/num_co.d b/src/c/num_co.d index 1a88fc970..d347b3552 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -431,21 +431,21 @@ cl_imagpart(cl_object x) break; case t_singlefloat: if (signbit(ecl_single_float(x))) - x = cl_core.singlefloat_minus_zero; + x = ecl_ct_singlefloat_minus_zero; else - x = cl_core.singlefloat_zero; + x = ecl_ct_singlefloat_zero; break; case t_doublefloat: if (signbit(ecl_double_float(x))) - x = cl_core.doublefloat_minus_zero; + x = ecl_ct_doublefloat_minus_zero; else - x = cl_core.doublefloat_zero; + x = ecl_ct_doublefloat_zero; break; case t_longfloat: if (signbit(ecl_long_float(x))) - x = cl_core.longfloat_minus_zero; + x = ecl_ct_longfloat_minus_zero; else - x = cl_core.longfloat_zero; + x = ecl_ct_longfloat_zero; break; case t_complex: x = x->gencomplex.imag; diff --git a/src/c/number.d b/src/c/number.d index ad2810107..8de5d5d9d 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -501,9 +501,9 @@ ecl_make_single_float(float f) if (f == (float)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.singlefloat_minus_zero; + return ecl_ct_singlefloat_minus_zero; #endif - return cl_core.singlefloat_zero; + return ecl_ct_singlefloat_zero; } x = ecl_alloc_object(t_singlefloat); ecl_single_float(x) = f; @@ -519,9 +519,9 @@ ecl_make_double_float(double f) if (f == (double)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.doublefloat_minus_zero; + return ecl_ct_doublefloat_minus_zero; #endif - return cl_core.doublefloat_zero; + return ecl_ct_doublefloat_zero; } x = ecl_alloc_object(t_doublefloat); ecl_double_float(x) = f; @@ -537,9 +537,9 @@ ecl_make_long_float(long double f) if (f == (long double)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.longfloat_minus_zero; + return ecl_ct_longfloat_minus_zero; #endif - return cl_core.longfloat_zero; + return ecl_ct_longfloat_zero; } x = ecl_alloc_object(t_longfloat); x->longfloat.value = f; diff --git a/src/c/numbers/atan.d b/src/c/numbers/atan.d index e63bc8a5e..af55f7c9c 100644 --- a/src/c/numbers/atan.d +++ b/src/c/numbers/atan.d @@ -15,11 +15,19 @@ #define ECL_INCLUDE_MATH_H #include +#include #include #include #pragma STDC FENV_ACCESS ON +ecl_def_ct_single_float(ecl_ct_flt_zero,0,static,const); +ecl_def_ct_single_float(ecl_ct_flt_one,1,static,const); +ecl_def_ct_single_float(ecl_ct_flt_one_neg,-1,static,const); + +ecl_def_ct_complex(ecl_ct_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one,static,const); +ecl_def_ct_complex(ecl_ct_minus_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one_neg,static,const); + cl_object ecl_atan2(cl_object y, cl_object x) { @@ -53,20 +61,20 @@ ecl_atan1(cl_object y) { if (ECL_COMPLEXP(y)) { #if 0 /* ANSI states it should be this first part */ - cl_object z = ecl_times(cl_core.imag_unit, y); + cl_object z = ecl_times(ecl_ct_imag_unit, y); z = ecl_plus(ecl_log1(ecl_one_plus(z)), ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), - cl_core.imag_unit)); + ecl_ct_imag_unit)); #else - cl_object z1, z = ecl_times(cl_core.imag_unit, y); + cl_object z1, z = ecl_times(ecl_ct_imag_unit, y); z = ecl_one_plus(z); z1 = ecl_times(y, y); z1 = ecl_one_plus(z1); z1 = ecl_sqrt(z1); z = ecl_divide(z, z1); z = ecl_log1(z); - z = ecl_times(cl_core.minus_imag_unit, z); + z = ecl_times(ecl_ct_minus_imag_unit, z); #endif /* ANSI */ return z; } else { diff --git a/src/c/numbers/round.d b/src/c/numbers/round.d index b1b97060f..4d5ffaa39 100644 --- a/src/c/numbers/round.d +++ b/src/c/numbers/round.d @@ -87,12 +87,12 @@ ecl_round2_integer(const cl_env_ptr the_env, cl_object x, cl_object y, cl_object cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); cl_object r = ecl_minus(q, q1); if (ecl_minusp(r)) { - int c = ecl_number_compare(cl_core.minus_half, r); + int c = ecl_number_compare(ecl_ct_minus_half, r); if (c > 0 || (c == 0 && ecl_oddp(q1))) { q1 = ecl_one_minus(q1); } } else { - int c = ecl_number_compare(r, cl_core.plus_half); + int c = ecl_number_compare(r, ecl_ct_plus_half); if (c > 0 || (c == 0 && ecl_oddp(q1))) { q1 = ecl_one_plus(q1); } diff --git a/src/c/numbers/sqrt.d b/src/c/numbers/sqrt.d index a8af7cae3..a35ac725c 100644 --- a/src/c/numbers/sqrt.d +++ b/src/c/numbers/sqrt.d @@ -76,7 +76,7 @@ ecl_sqrt_long_float(cl_object x) static cl_object ecl_sqrt_complex(cl_object x) { - return ecl_expt(x, cl_core.plus_half); + return ecl_expt(x, ecl_ct_plus_half); } #ifdef ECL_COMPLEX_FLOAT diff --git a/src/c/package.d b/src/c/package.d index e6d6e3238..9494fcb93 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -114,8 +114,8 @@ make_package_hashtable() { return cl__make_hash_table(@'package', /* package hash table */ ecl_make_fixnum(128), /* initial size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); } static cl_object diff --git a/src/c/pathname.d b/src/c/pathname.d index 32ebb5206..03c3d18bf 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -461,7 +461,7 @@ parse_word(cl_object s, delim_fn delim, int flags, cl_index start, case 0: if (flags & WORD_EMPTY_IS_NIL) return ECL_NIL; - return cl_core.null_string; + return ecl_ct_null_string; case 1: if (ecl_char(s,j) == '*') return @':wild'; @@ -505,7 +505,7 @@ parse_directories(cl_object s, int flags, cl_index start, cl_index end, cl_object part = parse_word(s, delim, flags, j, end, &i); if (part == @':error' || part == ECL_NIL) break; - if (part == cl_core.null_string) { /* "/", ";" */ + if (part == ecl_ct_null_string) { /* "/", ";" */ if (j != start) { if (flags & WORD_LOGICAL) return @':error'; @@ -1318,7 +1318,7 @@ cl_host_namestring(cl_object pname) pname = cl_pathname(pname); pname = pname->pathname.host; if (Null(pname) || pname == @':wild') - pname = cl_core.null_string; + pname = ecl_ct_null_string; @(return pname); } diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d index 1a8a0d614..e75a3814d 100644 --- a/src/c/printer/write_object.d +++ b/src/c/printer/write_object.d @@ -96,8 +96,8 @@ si_write_object_with_circle(cl_object x, cl_object stream, cl_object print_funct cl_object hash = cl__make_hash_table(@'eq', ecl_make_fixnum(1024), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); ecl_bds_bind(env, @'si::*circle-stack*', hash); si_write_object_with_circle(x, cl_core.null_stream, print_function); diff --git a/src/c/read.d b/src/c/read.d index e36a8ca83..de0727ec9 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1277,8 +1277,8 @@ patch_sharp(const cl_env_ptr the_env, cl_object x) } else { cl_object table = cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); do { cl_object pair = ECL_CONS_CAR(pairs); _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); @@ -1859,8 +1859,8 @@ ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, cl_object hash = readtable->readtable.hash; if (Null(hash)) { hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); readtable->readtable.hash = hash; } _ecl_sethash(ECL_CODE_CHAR(c), hash, @@ -1937,8 +1937,8 @@ ecl_invalid_character_p(int c) c = ecl_char_code(chr); cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_readtable_set(readtable, c, cat, table); @(return ECL_T); @) diff --git a/src/c/serialize.d b/src/c/serialize.d index c77ce56e9..d497e955e 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -349,8 +349,8 @@ init_pool(pool_t pool, cl_object root) ECL_NIL, ecl_make_fixnum(0)); pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_sethash(root, pool->hash, ecl_make_fixnum(0)); pool->queue = ecl_list1(root); pool->last = pool->queue; diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index cdb2c3333..4dc6280c7 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -628,8 +628,9 @@ mp_process_active_p(cl_object process) cl_object mp_process_whostate(cl_object process) { + const cl_env_ptr the_env = ecl_process_env(); assert_type_process(process); - @(return (cl_core.null_string)); + ecl_return1(the_env, ecl_ct_null_string); } cl_object diff --git a/src/c/time.d b/src/c/time.d index 166a2a7c3..82ac93ae8 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -221,18 +221,14 @@ cl_get_internal_real_time() cl_object cl_get_universal_time() { + cl_env_ptr env = ecl_process_env(); cl_object utc = ecl_make_integer(time(0)); - @(return ecl_plus(utc, cl_core.Jan1st1970UT)); + ecl_return1(env, ecl_plus(utc, ecl_ct_Jan1st1970UT)); } void init_unixtime(void) { ecl_get_internal_real_time(&beginning); - ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000000)); - - cl_core.Jan1st1970UT = - ecl_times(ecl_make_fixnum(24 * 60 * 60), - ecl_make_fixnum(17 + 365 * 70)); } diff --git a/src/c/unixint.d b/src/c/unixint.d index 7d6ad09ad..8c1209c2b 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -1474,8 +1474,8 @@ create_signal_code_constants() cl_object hash = cl_core.known_signals = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); int i; for (i = 0; known_signals[i].code >= 0; i++) { add_one_signal(hash, known_signals[i].code, diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp index 6516c7c40..107a1dc8d 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp @@ -42,12 +42,12 @@ '( ;; Order is important: on platforms where 0.0 and -0.0 are the same ;; the last one is prioritized. - (#.(coerce 0 'cl:single-float) "cl_core.singlefloat_zero") - (#.(coerce 0 'cl:double-float) "cl_core.doublefloat_zero") - (#.(coerce -0.0 'cl:single-float) "cl_core.singlefloat_minus_zero") - (#.(coerce -0.0 'cl:double-float) "cl_core.doublefloat_minus_zero") - (#.(coerce 0 'cl:long-float) "cl_core.longfloat_zero") - (#.(coerce -0.0 'cl:long-float) "cl_core.longfloat_minus_zero") + (#.(coerce 0 'cl:single-float) "ecl_ct_singlefloat_zero") + (#.(coerce 0 'cl:double-float) "ecl_ct_doublefloat_zero") + (#.(coerce -0.0 'cl:single-float) "ecl_ct_singlefloat_minus_zero") + (#.(coerce -0.0 'cl:double-float) "ecl_ct_doublefloat_minus_zero") + (#.(coerce 0 'cl:long-float) "ecl_ct_longfloat_zero") + (#.(coerce -0.0 'cl:long-float) "ecl_ct_longfloat_minus_zero") ;; We temporarily remove this constant, because the bytecodes compiler ;; does not know how to externalize it. diff --git a/src/h/external.h b/src/h/external.h index 85232f6d3..6595f76b3 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -200,26 +200,11 @@ struct cl_core_struct { cl_object dispatch_reader; cl_object char_names; - cl_object null_string; - - cl_object plus_half; - cl_object minus_half; - cl_object imag_unit; - cl_object minus_imag_unit; - cl_object imag_two; - cl_object singlefloat_zero; - cl_object doublefloat_zero; - cl_object singlefloat_minus_zero; - cl_object doublefloat_minus_zero; - cl_object longfloat_zero; - cl_object longfloat_minus_zero; cl_object gensym_prefix; cl_object gentemp_prefix; cl_object gentemp_counter; - cl_object Jan1st1970UT; - cl_object system_properties; cl_env_ptr first_env; @@ -251,9 +236,6 @@ struct cl_core_struct { cl_object compiler_dispatch; - cl_object rehash_size; - cl_object rehash_threshold; - cl_object known_signals; }; @@ -266,6 +248,24 @@ extern ECL_API void ecl_free(void *ptr); extern ECL_API void ecl_copy(void *dst, void *src, cl_index ndx); #define ecl_free_unsafe(x) ecl_free(x); +/* cold_boot.c */ +extern ECL_API const cl_object ecl_ct_Jan1st1970UT; +extern ECL_API const cl_object ecl_ct_null_string; + +extern ECL_API const cl_object ecl_ct_default_rehash_size; +extern ECL_API const cl_object ecl_ct_default_rehash_threshold; + +extern ECL_API const cl_object ecl_ct_singlefloat_zero; +extern ECL_API const cl_object ecl_ct_doublefloat_zero; +extern ECL_API const cl_object ecl_ct_longfloat_zero; + +extern ECL_API const cl_object ecl_ct_singlefloat_minus_zero; +extern ECL_API const cl_object ecl_ct_doublefloat_minus_zero; +extern ECL_API const cl_object ecl_ct_longfloat_minus_zero; + +extern ECL_API const cl_object ecl_ct_plus_half; +extern ECL_API const cl_object ecl_ct_minus_half; + /* alloc.c / alloc_2.c */ extern ECL_API cl_object ecl_alloc_object(cl_type t); diff --git a/src/h/internal.h b/src/h/internal.h index d716a0a13..dc7113bc5 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -596,7 +596,7 @@ extern void ecl_get_internal_real_time(struct ecl_timeval *time); extern void ecl_get_internal_run_time(struct ecl_timeval *time); extern void ecl_musleep(double time); -#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),cl_core.Jan1st1970UT) +#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),ecl_ct_Jan1st1970UT) extern cl_fixnum ecl_runtime(void); /* unixfsys.d */ -- GitLab From b0d52e622d200200fc3c4b2e388cd9479337dab5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 10:18:40 +0200 Subject: [PATCH 21/58] core: define protect and dummy tags as constants Both tags have a special meaning to the low-level runtime (most notably the frame stack). Extracting them from "all symbols" is a step towards multiple runtimes. --- src/c/main.d | 8 ++++++++ src/c/symbols_list.h | 2 -- src/h/ecl-inl.h | 49 +++++++++++++++++++++++++++++--------------- src/h/external.h | 3 +++ src/h/object.h | 11 +++++----- 5 files changed, 50 insertions(+), 23 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 7a0c0998a..5a270eeb6 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -71,6 +71,14 @@ ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const); ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); +/* These two tags have a special meaning for the frame stack. */ + +ecl_def_ct_base_string(ecl_ct_ptag_string,"PROTECT-TAG",11,static,const); +ecl_def_ct_base_string(ecl_ct_dtag_string,"DUMMY-TAG",9,static,const); + +ecl_def_ct_token(ecl_ct_protect_tag,ecl_stp_constant,ecl_ct_ptag_string,ECL_NIL,,const); +ecl_def_ct_token(ecl_ct_dummy_tag ,ecl_stp_constant,ecl_ct_dtag_string,ECL_NIL,,const); + /************************ GLOBAL INITIALIZATION ***********************/ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 7a0d12046..5f2f461f0 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -104,8 +104,6 @@ cl_symbols[] = { {"NIL" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)}, -{SYS_ "PROTECT-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "DUMMY-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, {SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, {EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)}, diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index 9376c9e34..5a1f06434 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -111,35 +111,52 @@ #define ecl_cast_ptr(type,n) ((type)(n)) #endif +#ifdef ECL_THREADS +#define ecl_def_ct_token(name,stype,sname,value,static,const) \ + static const struct ecl_symbol name ## _data = { \ + (int8_t)t_symbol, 0, stype, 0, \ + value, ECL_NIL, NULL /*ecl_undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL, \ + ECL_MISSING_SPECIAL_BINDING }; \ + static const cl_object name = (cl_object)(& name ## _data) +#else +#define ecl_def_ct_token(name,stype,sname,value,static,const) \ + static const struct ecl_symbol name ## _data = { \ + (int8_t)t_symbol, 0, stype, 0, \ + value, ECL_NIL, NULL /*ecl_undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL }; \ + static const cl_object name = (cl_object)(& name ## _data) +#endif + #define ecl_def_string_array(name,static,const) \ static const union { \ struct ecl_base_string elt; \ cl_fixnum padding[(sizeof(struct ecl_base_string)+3)/4*4]; \ } name[] -#define ecl_def_string_array_elt(chars) { { \ - (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ - ECL_NIL, (cl_index)(sizeof(chars))-1, \ - (cl_index)(sizeof(chars))-1, \ +#define ecl_def_string_array_elt(chars) { { \ + (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ + ECL_NIL, (cl_index)(sizeof(chars))-1, \ + (cl_index)(sizeof(chars))-1, \ (ecl_base_char*)(chars) } } -#define ecl_def_ct_base_string(name,chars,len,static,const) \ - static const struct ecl_base_string name ## _data = { \ +#define ecl_def_ct_base_string(name,chars,len,static,const) \ + static const struct ecl_base_string name ## _data = { \ (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ - ECL_NIL, (cl_index)(len), (cl_index)(len), \ - (ecl_base_char*)(chars) }; \ + ECL_NIL, (cl_index)(len), (cl_index)(len), \ + (ecl_base_char*)(chars) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_single_float(name,f,static,const) \ - static const struct ecl_singlefloat name ## _data = { \ - (int8_t)t_singlefloat, 0, 0, 0, \ - (float)(f) }; \ +#define ecl_def_ct_single_float(name,f,static,const) \ + static const struct ecl_singlefloat name ## _data = { \ + (int8_t)t_singlefloat, 0, 0, 0, \ + (float)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_double_float(name,f,static,const) \ - static const struct ecl_doublefloat name ## _data = { \ - (int8_t)t_doublefloat, 0, 0, 0, \ - (double)(f) }; \ +#define ecl_def_ct_double_float(name,f,static,const) \ + static const struct ecl_doublefloat name ## _data = { \ + (int8_t)t_doublefloat, 0, 0, 0, \ + (double)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) #define ecl_def_ct_long_float(name,f,static,const) \ diff --git a/src/h/external.h b/src/h/external.h index 6595f76b3..2f3d4db6f 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -266,6 +266,9 @@ extern ECL_API const cl_object ecl_ct_longfloat_minus_zero; extern ECL_API const cl_object ecl_ct_plus_half; extern ECL_API const cl_object ecl_ct_minus_half; +extern ECL_API const cl_object ecl_ct_protect_tag; +extern ECL_API const cl_object ecl_ct_dummy_tag; + /* alloc.c / alloc_2.c */ extern ECL_API cl_object ecl_alloc_object(cl_type t); diff --git a/src/h/object.h b/src/h/object.h index 1906181fa..58951893c 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -258,14 +258,15 @@ enum ecl_stype { /* symbol type */ }; #define ECL_NIL ((cl_object)t_list) +#define ECL_PROTECT_TAG ecl_ct_protect_tag +#define ECL_DUMMY_TAG ecl_ct_dummy_tag + #define ECL_NIL_SYMBOL ((cl_object)cl_symbols) #define ECL_T ((cl_object)(cl_symbols+1)) #define ECL_UNBOUND ((cl_object)(cl_symbols+2)) -#define ECL_PROTECT_TAG ((cl_object)(cl_symbols+3)) -#define ECL_DUMMY_TAG ((cl_object)(cl_symbols+4)) -#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+5)) -#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+6)) -#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+7)) +#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+3)) +#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+4)) +#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+5)) #define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) struct ecl_symbol { -- GitLab From 4a760a06ddc7c598bef0e16efcedf11d5db247c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 11:03:49 +0200 Subject: [PATCH 22/58] core: split cl_core_struct in two structure cl_core and ecl_core ecl_core contains early global environment that is meant to be shared by all runtimes, while cl_core contains an environment relevant to common lisp. --- src/c/alloc_2.d | 99 ++++++++++++------------ src/c/ffi/libraries.d | 14 ++-- src/c/main.d | 116 +++++++++++++++------------- src/c/package.d | 6 +- src/c/pathname.d | 10 +-- src/c/process.d | 10 +-- src/c/stacks.d | 10 +-- src/c/threads/thread.d | 28 +++---- src/c/unixfsys.d | 10 +-- src/c/unixint.d | 20 ++--- src/h/external.h | 69 ++++++++--------- src/h/internal.h | 24 +++--- src/tests/normal-tests/compiler.lsp | 2 +- 13 files changed, 211 insertions(+), 207 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 62e8d59a8..fa8d4ebbf 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -54,13 +54,13 @@ _ecl_set_max_heap_size(size_t new_size) { const cl_env_ptr the_env = ecl_process_env(); ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size = new_size); + GC_set_max_heap_size(ecl_core.max_heap_size = new_size); if (new_size == 0) { cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - GC_FREE(cl_core.safety_region); - cl_core.safety_region = 0; + ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (ecl_core.safety_region) { + GC_FREE(ecl_core.safety_region); + ecl_core.safety_region = 0; } ecl_enable_interrupts_env(the_env); } @@ -96,7 +96,7 @@ out_of_memory(size_t requested_bytes) /* The out of memory condition may happen in more than one thread */ /* But then we have to ensure the error has not been solved */ #ifdef ECL_THREADS - ecl_mutex_lock(&cl_core.error_lock); + ecl_mutex_lock(&ecl_core.error_lock); ECL_UNWIND_PROTECT_BEGIN(the_env) #endif { @@ -111,23 +111,23 @@ out_of_memory(size_t requested_bytes) goto OUTPUT; } } - if (cl_core.max_heap_size == 0) { + if (ecl_core.max_heap_size == 0) { /* We did not set any limit in the amount of memory, * yet we failed, or we had some limits but we have * not reached them. */ - if (cl_core.safety_region) { + if (ecl_core.safety_region) { /* We can free some memory and try handling the error */ - GC_FREE(cl_core.safety_region); + GC_FREE(ecl_core.safety_region); the_env->string_pool = ECL_NIL; - cl_core.safety_region = 0; + ecl_core.safety_region = 0; method = 0; } else { /* No possibility of continuing */ method = 2; } } else { - cl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - GC_set_max_heap_size(cl_core.max_heap_size); + ecl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + GC_set_max_heap_size(ecl_core.max_heap_size); method = 1; } OUTPUT: @@ -135,7 +135,7 @@ out_of_memory(size_t requested_bytes) } #ifdef ECL_THREADS ECL_UNWIND_PROTECT_EXIT { - ecl_mutex_unlock(&cl_core.error_lock); + ecl_mutex_unlock(&ecl_core.error_lock); } ECL_UNWIND_PROTECT_END; #endif ecl_bds_unwind1(the_env); @@ -154,8 +154,8 @@ out_of_memory(size_t requested_bytes) } if (!interrupts) ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size += - cl_core.max_heap_size / 2); + ecl_core.max_heap_size += (ecl_core.max_heap_size / 2); + GC_set_max_heap_size(ecl_core.max_heap_size); /* Default allocation. Note that we do not allocate atomic. */ return GC_MALLOC(requested_bytes); } @@ -792,14 +792,14 @@ init_alloc(int pass) FALSE, TRUE); # endif #endif /* !GBC_BOEHM_PRECISE */ - - GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]); + ecl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]; + GC_set_max_heap_size(ecl_core.max_heap_size); /* Save some memory for the case we get tight. */ - if (cl_core.max_heap_size == 0) { + if (ecl_core.max_heap_size == 0) { cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - cl_core.safety_region = 0; + ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (ecl_core.safety_region) { + ecl_core.safety_region = 0; } init_type_info(); @@ -889,7 +889,7 @@ standard_finalizer(cl_object o) } case t_symbol: { if (o->symbol.binding != ECL_MISSING_SPECIAL_BINDING) { - ecl_atomic_push(&cl_core.reused_indices, ecl_make_fixnum(o->symbol.binding)); + ecl_atomic_push(&ecl_core.reused_indices, ecl_make_fixnum(o->symbol.binding)); o->symbol.binding = ECL_MISSING_SPECIAL_BINDING; } } @@ -1066,33 +1066,33 @@ si_gc_stats(cl_object enable) cl_object old_status; cl_object size1; cl_object size2; - if (cl_core.gc_stats == 0) { + if (ecl_core.gc_stats == 0) { old_status = ECL_NIL; } else if (GC_print_stats) { old_status = @':full'; } else { old_status = ECL_T; } - if (cl_core.bytes_consed == ECL_NIL) { - cl_core.bytes_consed = ecl_alloc_object(t_bignum); - mpz_init2(ecl_bignum(cl_core.bytes_consed), 128); - cl_core.gc_counter = ecl_alloc_object(t_bignum); - mpz_init2(ecl_bignum(cl_core.gc_counter), 128); + if (ecl_core.bytes_consed == ECL_NIL) { + ecl_core.bytes_consed = ecl_alloc_object(t_bignum); + mpz_init2(ecl_bignum(ecl_core.bytes_consed), 128); + ecl_core.gc_counter = ecl_alloc_object(t_bignum); + mpz_init2(ecl_bignum(ecl_core.gc_counter), 128); } update_bytes_consed(); /* We need fresh copies of the bignums */ - size1 = _ecl_big_register_copy(cl_core.bytes_consed); - size2 = _ecl_big_register_copy(cl_core.gc_counter); + size1 = _ecl_big_register_copy(ecl_core.bytes_consed); + size2 = _ecl_big_register_copy(ecl_core.gc_counter); if (enable == ECL_NIL) { GC_print_stats = 0; - cl_core.gc_stats = 0; + ecl_core.gc_stats = 0; } else if (enable == ecl_make_fixnum(0)) { - mpz_set_ui(ecl_bignum(cl_core.bytes_consed), 0); - mpz_set_ui(ecl_bignum(cl_core.gc_counter), 0); + mpz_set_ui(ecl_bignum(ecl_core.bytes_consed), 0); + mpz_set_ui(ecl_bignum(ecl_core.gc_counter), 0); } else { - cl_core.gc_stats = 1; + ecl_core.gc_stats = 1; GC_print_stats = (enable == @':full'); } @(return size1 size2 old_status); @@ -1105,10 +1105,10 @@ static void gather_statistics() { /* GC stats rely on bignums */ - if (cl_core.gc_stats) { + if (ecl_core.gc_stats) { update_bytes_consed(); - mpz_add_ui(ecl_bignum(cl_core.gc_counter), - ecl_bignum(cl_core.gc_counter), + mpz_add_ui(ecl_bignum(ecl_core.gc_counter), + ecl_bignum(ecl_core.gc_counter), 1); } if (GC_old_start_callback) @@ -1118,8 +1118,8 @@ gather_statistics() static void update_bytes_consed () { #if GBC_BOEHM == 0 - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), GC_get_bytes_since_gc()); #else /* This is not accurate and may wrap around. We try to detect this @@ -1130,15 +1130,15 @@ update_bytes_consed () { if (bytes > new_bytes) { cl_index wrapped; wrapped = ~((cl_index)0) - bytes; - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), wrapped); - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), new_bytes); } else { - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), new_bytes - bytes); } bytes = new_bytes; @@ -1170,7 +1170,7 @@ ecl_mark_env(struct cl_env_struct *env) static void stacks_scanner() { - cl_object l = cl_core.libraries; + cl_object l = ecl_core.libraries; loop_for_on_unsafe(l) { cl_object dll = ECL_CONS_CAR(l); if (dll->cblock.locked) { @@ -1178,18 +1178,19 @@ stacks_scanner() GC_set_mark_bit((void *)dll); } } end_loop_for_on_unsafe(l); + GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1)); GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); - ecl_mark_env(cl_core.first_env); + ecl_mark_env(ecl_core.first_env); #ifdef ECL_THREADS - l = cl_core.processes; + l = ecl_core.processes; if (l != OBJNULL) { cl_index i, size; for (i = 0, size = l->vector.dim; i < size; i++) { cl_object process = l->vector.self.t[i]; if (!Null(process)) { cl_env_ptr env = process->process.env; - if (env && (env != cl_core.first_env)) ecl_mark_env(env); + if (env && (env != ecl_core.first_env)) ecl_mark_env(env); } } } diff --git a/src/c/ffi/libraries.d b/src/c/ffi/libraries.d index 098cd483d..21441dfc0 100644 --- a/src/c/ffi/libraries.d +++ b/src/c/ffi/libraries.d @@ -221,7 +221,7 @@ static cl_object ecl_library_find_by_name(cl_object filename) { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object other = ECL_CONS_CAR(l); cl_object name = other->cblock.name; if (!Null(name) && ecl_string_eq(name, filename)) { @@ -235,7 +235,7 @@ static cl_object ecl_library_find_by_handle(void *handle) { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object other = ECL_CONS_CAR(l); if (handle == other->cblock.handle) { return other; @@ -268,7 +268,7 @@ ecl_library_open_inner(cl_object filename, bool self_destruct) block->cblock.refs = ecl_one_plus(block->cblock.refs); } else { si_set_finalizer(block, ECL_T); - cl_core.libraries = CONS(block, cl_core.libraries); + ecl_core.libraries = CONS(block, ecl_core.libraries); } } ecl_enable_interrupts(); @@ -341,7 +341,7 @@ ecl_library_symbol(cl_object block, const char *symbol, bool lock) { void *p; if (block == @':default') { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object block = ECL_CONS_CAR(l); p = ecl_library_symbol(block, symbol, lock); if (p) return p; @@ -426,7 +426,7 @@ ecl_library_close(cl_object block) { block = ECL_NIL; } else if (block->cblock.handle != NULL) { success = GC_call_with_alloc_lock(dlclose_wrapper, block); - cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); + ecl_core.libraries = ecl_remove_eq(block, ecl_core.libraries); } else { /* block not loaded */ success = FALSE; } @@ -443,8 +443,8 @@ ecl_library_close(cl_object block) { void ecl_library_close_all(void) { - while (cl_core.libraries != ECL_NIL) { - ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); + while (ecl_core.libraries != ECL_NIL) { + ecl_library_close(ECL_CONS_CAR(ecl_core.libraries)); } } diff --git a/src/c/main.d b/src/c/main.d index 5a270eeb6..e8b77fd2d 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -35,6 +35,7 @@ # define MAP_FAILED -1 # endif #endif +#include #include #include #include @@ -49,8 +50,62 @@ /******************************* EXPORTS ******************************/ const char *ecl_self; + +/* -- core runtime ---------------------------------------------------------- */ + +/* The root environment is a default execution context. */ static struct cl_env_struct first_env; +struct ecl_core_struct ecl_core = { + .first_env = &first_env, + /* processes */ +#ifdef ECL_THREADS + .processes = ECL_NIL, + .last_var_index = 0, + .reused_indices = ECL_NIL, +#endif + /* signals */ + .default_sigmask_bytes = 0, + .known_signals = ECL_NIL, + /* allocation */ + .max_heap_size = 0, + .bytes_consed = ECL_NIL, + .gc_counter = ECL_NIL, + .gc_stats = 0, + .safety_region = NULL, + /* pathnames */ + .path_max = 0, + .pathname_translations = ECL_NIL, + /* LIBRARIES is a list of objects. It behaves as a sequence of weak pointers + thanks to the magic in the garbage collector. */ + .libraries = ECL_NIL, + .library_pathname = ECL_NIL +}; + +/* note that this function does not create any environment */ +int +ecl_boot(void) +{ + int i; + + i = ecl_option_values[ECL_OPT_BOOTED]; + if (i) { + if (i < 0) { + /* We have called cl_shutdown and want to use ECL again. */ + ecl_set_option(ECL_OPT_BOOTED, 1); + } + return 1; + } + + init_process(); + /* init_unixint(); */ + /* init_garbage(); */ + + ecl_core.path_max = MAXPATHLEN; + + return 0; +} + /* -- constants ----------------------------------------------------- */ const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800); @@ -271,7 +326,7 @@ _ecl_alloc_env(cl_env_ptr parent) * Note that at this point we are not allocating any other memory * which is stored via a pointer in the environment. If we would do * that, an unlucky interrupt by the gc before the allocated - * environment is registered in cl_core.processes could lead to + * environment is registered in ecl_core.processes could lead to * memory being freed because the gc is not aware of the pointer to * the allocated memory in the environment. */ @@ -293,14 +348,14 @@ _ecl_alloc_env(cl_env_ptr parent) # endif #endif { - size_t bytes = cl_core.default_sigmask_bytes; + size_t bytes = ecl_core.default_sigmask_bytes; if (bytes == 0) { output->default_sigmask = 0; } else if (parent) { output->default_sigmask = ecl_alloc_atomic(bytes); memcpy(output->default_sigmask, parent->default_sigmask, bytes); } else { - output->default_sigmask = cl_core.default_sigmask; + output->default_sigmask = ecl_core.first_env->default_sigmask; } } for (cl_index i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { @@ -390,9 +445,6 @@ struct cl_core_struct cl_core = { .c_package = ECL_NIL, .ffi_package = ECL_NIL, - .pathname_translations = ECL_NIL, - .library_pathname = ECL_NIL, - .terminal_io = ECL_NIL, .null_stream = ECL_NIL, .standard_input = ECL_NIL, @@ -408,34 +460,7 @@ struct cl_core_struct cl_core = { .gentemp_counter = ecl_make_fixnum(0), .system_properties = ECL_NIL, - - .first_env = &first_env, -#ifdef ECL_THREADS - .processes = ECL_NIL, -#endif - /* LIBRARIES is an adjustable vector of objects. It behaves as a vector of - weak pointers thanks to the magic in the garbage collector. */ - .libraries = ECL_NIL, - - .max_heap_size = 0, - .bytes_consed = ECL_NIL, - .gc_counter = ECL_NIL, - .gc_stats = 0, - .path_max = 0, -#ifdef GBC_BOEHM - .safety_region = NULL, -#endif - - .default_sigmask = NULL, - .default_sigmask_bytes = 0, - -#ifdef ECL_THREADS - .last_var_index = 0, - .reused_indices = ECL_NIL, -#endif .compiler_dispatch = ECL_NIL, - - .known_signals = ECL_NIL }; #if !defined(ECL_MS_WINDOWS_HOST) @@ -468,22 +493,8 @@ cl_boot(int argc, char **argv) int i; cl_env_ptr env; - i = ecl_option_values[ECL_OPT_BOOTED]; - if (i) { - if (i < 0) { - /* We have called cl_shutdown and want to use ECL again. */ - ecl_set_option(ECL_OPT_BOOTED, 1); - } - return 1; - } - - /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/ - -#if !defined(GBC_BOEHM) - setbuf(stdin, stdin_buf); - setbuf(stdout, stdout_buf); -#endif - init_process(); + i = ecl_boot(); + if (i==1) return 1; ARGC = argc; ARGV = argv; @@ -499,7 +510,7 @@ cl_boot(int argc, char **argv) * ext::*interrupts-enabled* while creating packages. */ - env = cl_core.first_env; + env = ecl_core.first_env; ecl_init_first_env(env); /* @@ -538,11 +549,6 @@ cl_boot(int argc, char **argv) #endif cl_num_symbols_in_core=2; -#ifdef NO_PATH_MAX - cl_core.path_max = sysconf(_PC_PATH_MAX); -#else - cl_core.path_max = MAXPATHLEN; -#endif cl_core.gensym_prefix = (cl_object)&str_G_data; cl_core.gentemp_prefix = (cl_object)&str_T_data; diff --git a/src/c/package.d b/src/c/package.d index 9494fcb93..2fc45f63e 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -23,8 +23,8 @@ * NOTE 1: we only need to use the package locks when reading/writing the hash * tables, or changing the fields of a package. We do not need the locks to * read lists from the packages (i.e. list of shadowing symbols, used - * packages, etc), or from the global environment (cl_core.packages_list) if - * we do not destructively modify them (For instance, use ecl_remove_eq + * packages, etc), or from the global environment (cl_core.packages_list) + * if we do not destructively modify them (For instance, use ecl_remove_eq * instead of ecl_delete_eq). */ /* @@ -270,7 +270,7 @@ ecl_make_package(cl_object name, cl_object nicknames, nicknamed->pack.nicknamedby = CONS(x, nicknamed->pack.nicknamedby); } end_loop_for_in; /* Finally, add it to the list of packages */ - cl_core.packages = CONS(x, cl_core.packages); + cl_core.packages = ecl_cons(x, cl_core.packages); OUTPUT: (void)0; } ECL_WITH_GLOBAL_ENV_WRLOCK_END; diff --git a/src/c/pathname.d b/src/c/pathname.d index 03c3d18bf..ca674a28f 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -525,7 +525,7 @@ ecl_logical_hostname_p(cl_object host) { if (!ecl_stringp(host)) return FALSE; - return !Null(ecl_assqlp(host, cl_core.pathname_translations)); + return !Null(ecl_assqlp(host, ecl_core.pathname_translations)); } /* @@ -900,8 +900,8 @@ si_coerce_to_filename(cl_object pathname_orig) pathname_orig->pathname.type, pathname_orig->pathname.version); } - if (cl_core.path_max != -1 && - ecl_length(namestring) >= cl_core.path_max - 16) + if (ecl_core.path_max != -1 && + ecl_length(namestring) >= ecl_core.path_max - 16) FEerror("Too long filename: ~S.", 1, namestring); return namestring; } @@ -1542,7 +1542,7 @@ coerce_to_from_pathname(cl_object x, cl_object host) FEerror("Wrong host syntax ~S", 1, host); } /* Find its translation list */ - pair = ecl_assqlp(host, cl_core.pathname_translations); + pair = ecl_assqlp(host, ecl_core.pathname_translations); if (set == OBJNULL) { @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); } @@ -1552,7 +1552,7 @@ coerce_to_from_pathname(cl_object x, cl_object host) } if (pair == ECL_NIL) { pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); - cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); + ecl_core.pathname_translations = CONS(pair, ecl_core.pathname_translations); } for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { cl_object item = CAR(l); diff --git a/src/c/process.d b/src/c/process.d index 9f9fffda4..e74b2c6ce 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -84,13 +84,13 @@ cl_env_ptr cl_env_p = NULL; void init_process(void) { - cl_env_ptr env = cl_core.first_env; + cl_env_ptr env = ecl_core.first_env; #ifdef ECL_THREADS ecl_process_key_create(cl_env_key); - ecl_mutex_init(&cl_core.processes_lock, 1); - ecl_mutex_init(&cl_core.global_lock, 1); - ecl_mutex_init(&cl_core.error_lock, 1); - ecl_rwlock_init(&cl_core.global_env_lock); + ecl_mutex_init(&ecl_core.processes_lock, 1); + ecl_mutex_init(&ecl_core.global_lock, 1); + ecl_mutex_init(&ecl_core.error_lock, 1); + ecl_rwlock_init(&ecl_core.global_env_lock); #endif ecl_set_process_env(env); env->default_sigmask = NULL; diff --git a/src/c/stacks.d b/src/c/stacks.d index a9b8f1781..0c22031e4 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -382,11 +382,11 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol) cl_object pool; cl_index new_index = symbol->symbol.binding; if (new_index == ECL_MISSING_SPECIAL_BINDING) { - pool = ecl_atomic_pop(&cl_core.reused_indices); + pool = ecl_atomic_pop(&ecl_core.reused_indices); if (!Null(pool)) { new_index = ecl_fixnum(ECL_CONS_CAR(pool)); } else { - new_index = ecl_atomic_index_incf(&cl_core.last_var_index); + new_index = ecl_atomic_index_incf(&ecl_core.last_var_index); } symbol->symbol.binding = new_index; } @@ -402,7 +402,7 @@ invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) } if (index >= env->bds_stack.tl_bindings_size) { cl_index osize = env->bds_stack.tl_bindings_size; - cl_index nsize = cl_core.last_var_index * 1.25; + cl_index nsize = ecl_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*), @@ -660,7 +660,7 @@ cl_object init_stacks(cl_env_ptr the_env) { #ifdef ECL_THREADS - if (the_env == cl_core.first_env) { + if (the_env == ecl_core.first_env) { cl_index idx; cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*)); for(idx=0; idx<1024; idx++) { @@ -1029,7 +1029,7 @@ si_get_limit(cl_object type) 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)); + ecl_return1(env, ecl_make_unsigned_integer(ecl_core.max_heap_size)); } ecl_return1(env, ecl_make_unsigned_integer(output)); diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 4dc6280c7..fc5817b85 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -31,7 +31,7 @@ # include #endif -/* -- Macros -------------------------------------------------------- */ +/* -- Macros ---------------------------------------------------------------- */ #ifdef ECL_WINDOWS_THREADS # define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2)) @@ -56,18 +56,18 @@ static void extend_process_vector() { - cl_object v = cl_core.processes; + cl_object v = ecl_core.processes; cl_index new_size = v->vector.dim + v->vector.dim/2; cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object other = cl_core.processes; + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { + cl_object other = ecl_core.processes; if (new_size > other->vector.dim) { cl_object new = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ecl_make_fixnum(other->vector.fillp), ECL_NIL, ECL_NIL, ECL_NIL); ecl_copy_subarray(new, 0, other, 0, other->vector.dim); - cl_core.processes = new; + ecl_core.processes = new; } } ECL_WITH_NATIVE_LOCK_END; } @@ -78,8 +78,8 @@ ecl_list_process(cl_object process) cl_env_ptr the_env = ecl_process_env(); bool ok = 0; do { - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object vector = cl_core.processes; + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { + cl_object vector = ecl_core.processes; cl_index size = vector->vector.dim; cl_index ndx = vector->vector.fillp; if (ndx < size) { @@ -98,8 +98,8 @@ ecl_list_process(cl_object process) static void ecl_unlist_process(cl_object process) { - ecl_mutex_lock(&cl_core.processes_lock); - cl_object vector = cl_core.processes; + ecl_mutex_lock(&ecl_core.processes_lock); + cl_object vector = ecl_core.processes; cl_index i; for (i = 0; i < vector->vector.fillp; i++) { if (vector->vector.self.t[i] == process) { @@ -111,7 +111,7 @@ ecl_unlist_process(cl_object process) break; } } - ecl_mutex_unlock(&cl_core.processes_lock); + ecl_mutex_unlock(&ecl_core.processes_lock); } static cl_object @@ -119,8 +119,8 @@ ecl_process_list() { cl_env_ptr the_env = ecl_process_env(); cl_object output = ECL_NIL; - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object vector = cl_core.processes; + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { + cl_object vector = ecl_core.processes; cl_object *data = vector->vector.self.t; cl_index i; for (i = 0; i < vector->vector.fillp; i++) { @@ -344,7 +344,7 @@ ecl_import_current_thread(cl_object name, cl_object bindings) } #endif { - cl_object processes = cl_core.processes; + cl_object processes = ecl_core.processes; cl_index i, size; for (i = 0, size = processes->vector.fillp; i < size; i++) { cl_object p = processes->vector.self.t[i]; @@ -783,6 +783,6 @@ init_threads() ECL_NIL, ECL_NIL, ECL_NIL); v->vector.self.t[0] = process; v->vector.fillp = 1; - cl_core.processes = v; + ecl_core.processes = v; } } diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index 56a6e48ea..a25b04868 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -1085,7 +1085,7 @@ dir_recursive(cl_object base_dir, cl_object directory, cl_object filemask, int f cl_object si_get_library_pathname(void) { - cl_object s = cl_core.library_pathname; + cl_object s = ecl_core.library_pathname; if (!Null(s)) { goto OUTPUT_UNCHANGED; } else { @@ -1100,11 +1100,11 @@ si_get_library_pathname(void) ecl_filename_char *buffer; HMODULE hnd; cl_index len, ep; - s = ecl_alloc_adjustable_filename(cl_core.path_max); + s = ecl_alloc_adjustable_filename(ecl_core.path_max); buffer = ecl_filename_self(s); ecl_disable_interrupts(); hnd = GetModuleHandle("ecl.dll"); - len = ecl_GetModuleFileName(hnd, buffer, cl_core.path_max-1); + len = ecl_GetModuleFileName(hnd, buffer, ecl_core.path_max-1); ecl_enable_interrupts(); if (len == 0) { FEerror("GetModuleFileName failed (last error = ~S)", @@ -1125,9 +1125,9 @@ si_get_library_pathname(void) s = current_dir(); } } - cl_core.library_pathname = ecl_decode_filename(s, ECL_NIL); + ecl_core.library_pathname = ecl_decode_filename(s, ECL_NIL); OUTPUT_UNCHANGED: - @(return cl_core.library_pathname); + @(return ecl_core.library_pathname); } @(defun ext::chdir (directory &optional (change_d_p_d ECL_T)) diff --git a/src/c/unixint.d b/src/c/unixint.d index 8c1209c2b..f4c6e90d8 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -534,7 +534,7 @@ handler_fn_prototype(non_evil_signal_handler, int sig, siginfo_t *siginfo, void unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); handle_or_queue(the_env, signal_object, sig); errno = old_errno; @@ -552,7 +552,7 @@ handler_fn_prototype(evil_signal_handler, int sig, siginfo_t *siginfo, void *dat unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); handle_signal_now(signal_object); errno = old_errno; @@ -647,7 +647,7 @@ asynchronous_signal_servicing_thread() break; } signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); if (!Null(signal_code)) { mp_process_run_function(3, @'si::handle-signal', @@ -959,7 +959,7 @@ cl_object si_get_signal_handler(cl_object code) { const cl_env_ptr the_env = ecl_process_env(); - cl_object handler = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + cl_object handler = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL); unlikely_if (handler == OBJNULL) { illegal_signal_code(code); } @@ -970,11 +970,11 @@ cl_object si_set_signal_handler(cl_object code, cl_object handler) { const cl_env_ptr the_env = ecl_process_env(); - cl_object action = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + cl_object action = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL); unlikely_if (action == OBJNULL) { illegal_signal_code(code); } - ecl_sethash(code, cl_core.known_signals, handler); + ecl_sethash(code, ecl_core.known_signals, handler); si_catch_signal(2, code, ECL_T); ecl_return0(the_env); } @@ -984,7 +984,7 @@ si_set_signal_handler(cl_object code, cl_object handler) { const cl_env_ptr the_env = ecl_process_env(); int code_int; - unlikely_if (ecl_gethash_safe(code, cl_core.known_signals, OBJNULL) == OBJNULL) { + unlikely_if (ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL) == OBJNULL) { illegal_signal_code(code); } code_int = ecl_fixnum(code); @@ -1312,8 +1312,8 @@ install_asynchronous_signal_handlers() # endif #endif #ifdef HAVE_SIGPROCMASK - sigset_t *sigmask = cl_core.default_sigmask = &main_thread_sigmask; - cl_core.default_sigmask_bytes = sizeof(sigset_t); + sigset_t *sigmask = ecl_core.first_env->default_sigmask = &main_thread_sigmask; + ecl_core.default_sigmask_bytes = sizeof(sigset_t); # ifdef ECL_THREADS pthread_sigmask(SIG_SETMASK, NULL, sigmask); # else @@ -1472,7 +1472,7 @@ static void create_signal_code_constants() { cl_object hash = - cl_core.known_signals = + ecl_core.known_signals = cl__make_hash_table(@'eql', ecl_make_fixnum(128), ecl_ct_default_rehash_size, ecl_ct_default_rehash_threshold); diff --git a/src/h/external.h b/src/h/external.h index 2f3d4db6f..d6d794d36 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -169,9 +169,36 @@ struct ecl_interrupt_struct { extern ECL_API cl_env_ptr cl_env_p; #endif -/* - * Per-process data. Modify main.d accordingly. - */ +/* Core environment. */ + +struct ecl_core_struct { + cl_env_ptr first_env; +#ifdef ECL_THREADS + cl_object processes; + ecl_mutex_t processes_lock; + ecl_mutex_t global_lock; + ecl_mutex_t error_lock; + ecl_rwlock_t global_env_lock; + cl_index last_var_index; + cl_object reused_indices; +#endif + size_t max_heap_size; + cl_object bytes_consed; + cl_object gc_counter; + bool gc_stats; + char *safety_region; + + cl_index default_sigmask_bytes; + cl_object known_signals; + + int path_max; + cl_object pathname_translations; + + cl_object libraries; + cl_object library_pathname; +}; + +/* Per-process data. Modify main.d accordingly. */ struct cl_core_struct { cl_object packages; @@ -188,9 +215,6 @@ struct cl_core_struct { cl_object c_package; cl_object ffi_package; - cl_object pathname_translations; - cl_object library_pathname; - cl_object terminal_io; cl_object null_stream; cl_object standard_input; @@ -206,39 +230,10 @@ struct cl_core_struct { cl_object gentemp_counter; cl_object system_properties; - - cl_env_ptr first_env; -#ifdef ECL_THREADS - cl_object processes; - ecl_mutex_t processes_lock; - ecl_mutex_t global_lock; - ecl_mutex_t error_lock; - ecl_rwlock_t global_env_lock; -#endif - cl_object libraries; - - size_t max_heap_size; - cl_object bytes_consed; - cl_object gc_counter; - bool gc_stats; - int path_max; -#ifdef GBC_BOEHM - char *safety_region; -#endif - void *default_sigmask; - cl_index default_sigmask_bytes; - -#ifdef ECL_THREADS - cl_index last_var_index; - cl_object reused_indices; -#endif - cl_object slash; - cl_object compiler_dispatch; - - cl_object known_signals; }; +extern ECL_API struct ecl_core_struct ecl_core; extern ECL_API struct cl_core_struct cl_core; /* memory.c */ @@ -249,6 +244,8 @@ extern ECL_API void ecl_copy(void *dst, void *src, cl_index ndx); #define ecl_free_unsafe(x) ecl_free(x); /* cold_boot.c */ +extern ECL_API int ecl_boot(void); + extern ECL_API const cl_object ecl_ct_Jan1st1970UT; extern ECL_API const cl_object ecl_ct_null_string; diff --git a/src/h/internal.h b/src/h/internal.h index dc7113bc5..4deb8a0bf 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -753,8 +753,8 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); #include #ifdef ECL_THREADS -# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) \ - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.global_lock) +# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) \ + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.global_lock) # define ECL_WITH_GLOBAL_LOCK_END \ ECL_WITH_NATIVE_LOCK_END # define ECL_WITH_LOCK_BEGIN(the_env,lock) { \ @@ -779,21 +779,21 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT { \ ecl_mutex_unlock(__ecl_the_lock); \ } ECL_UNWIND_PROTECT_THREAD_SAFE_END; } -# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { \ - const cl_env_ptr __ecl_pack_env = the_env; \ +# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { \ + const cl_env_ptr __ecl_pack_env = the_env; \ ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \ - ecl_rwlock_lock_read(&cl_core.global_env_lock); -# define ECL_WITH_GLOBAL_ENV_RDLOCK_END \ - ecl_rwlock_unlock_read(&cl_core.global_env_lock); \ - ecl_bds_unwind1(__ecl_pack_env); \ + ecl_rwlock_lock_read(&ecl_core.global_env_lock); +# define ECL_WITH_GLOBAL_ENV_RDLOCK_END \ + ecl_rwlock_unlock_read(&ecl_core.global_env_lock); \ + ecl_bds_unwind1(__ecl_pack_env); \ ecl_check_pending_interrupts(__ecl_pack_env); } # define ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { \ const cl_env_ptr __ecl_pack_env = the_env; \ ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \ - ecl_rwlock_lock_write(&cl_core.global_env_lock); -# define ECL_WITH_GLOBAL_ENV_WRLOCK_END \ - ecl_rwlock_unlock_write(&cl_core.global_env_lock); \ - ecl_bds_unwind1(__ecl_pack_env); \ + ecl_rwlock_lock_write(&ecl_core.global_env_lock); +# define ECL_WITH_GLOBAL_ENV_WRLOCK_END \ + ecl_rwlock_unlock_write(&ecl_core.global_env_lock); \ + ecl_bds_unwind1(__ecl_pack_env); \ ecl_check_pending_interrupts(__ecl_pack_env); } #else # define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 32d7d3b5c..6c23eb505 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -192,7 +192,7 @@ ;;; Fixed: 10/10/2006 ;;; Description: ;;; -;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized +;;; Nested calls to queue_finalizer trashed the value of ecl_core.to_be_finalized ;;; The following code tests that at least three objects are finalized. ;;; ;;; Note: this test fails in multithreaded mode. GC takes too long! -- GitLab From 09876a167242ecdaf9fcdb0b9a85ba50e27ee275 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 12:57:34 +0200 Subject: [PATCH 23/58] nucleus: move function calling from apply.d and eval.d to call.d The file apply.d is effectively removed. --- src/c/Makefile.in | 4 +- src/c/{apply.d => call.d} | 92 ++++++++++++++++++++++++++--- src/c/eval.d | 121 -------------------------------------- 3 files changed, 86 insertions(+), 131 deletions(-) rename src/c/{apply.d => call.d} (95%) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 0b3688502..555b85e11 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = +NUCL_OBJS = call.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o @@ -74,7 +74,7 @@ READER_OBJS = read.o reader/parse_integer.o reader/parse_number.o FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o -OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o \ +OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o \ compiler.o disassembler.o reference.o character.o file.o error.o \ string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o \ vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ diff --git a/src/c/apply.d b/src/c/call.d similarity index 95% rename from src/c/apply.d rename to src/c/call.d index 12a27e74e..de0f5c545 100644 --- a/src/c/apply.d +++ b/src/c/call.d @@ -1,18 +1,93 @@ /* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ -/* - * apply.c - interface to C call mechanism - * - * Copyright (c) 1993 Giuseppe Attardi - * Copyright (c) 2001 Juan Jose Garcia Ripoll +/* dispatch.c - function application */ + +#include +#include +#include +#include +#include + +cl_objectfn +ecl_function_dispatch(cl_env_ptr env, cl_object x) +{ + cl_object fun = x; + if (ecl_unlikely(fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + env->function = fun; + return fun->cfunfixed.entry; + case t_cfun: + env->function = fun; + return fun->cfun.entry; + case t_cclosure: + env->function = fun; + return fun->cclosure.entry; + case t_instance: + env->function = fun; + return fun->instance.entry; + case t_symbol: + fun = ECL_SYM_FUN(fun); + env->function = fun; + return fun->cfun.entry; + case t_bytecodes: + env->function = fun; + return fun->bytecodes.entry; + case t_bclosure: + env->function = fun; + return fun->bclosure.entry; + default: + FEinvalid_function(x); + } + _ecl_unexpected_return(); +} + +/* Calling conventions: + * Compiled C code calls lisp function supplying #args, and args. * - * See file 'LICENSE' for the copyright details. + * Linking function performs check_args, gets jmp_buf with _setjmp, then * + * if cfun then stores C code address into function link location and transfers + * to jmp_buf at cf_self + + * if cclosure then replaces #args with cc_env and calls cc_self otherwise, it + * emulates funcall. */ -#include -#include +cl_object +ecl_apply_from_stack_frame(cl_object frame, cl_object x) +{ + cl_object *sp = ECL_STACK_FRAME_PTR(frame); + cl_index narg = frame->frame.size; + cl_env_ptr env = frame->frame.env; + cl_objectfn entry = ecl_function_dispatch(env, x); + cl_object ret; + env->stack_frame = frame; + ret = APPLY(narg, entry, sp); + env->stack_frame = NULL; + return ret; +} + +cl_object +cl_funcall(cl_narg narg, cl_object function, ...) +{ + cl_object output; + --narg; + { + ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); + output = ecl_apply_from_stack_frame(frame, function); + ECL_STACK_FRAME_VARARGS_END(frame); + } + return output; +} + +cl_object * +_ecl_va_sp(cl_narg narg) +{ + return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; +} #if !(ECL_C_ARGUMENTS_LIMIT == 63) #error "Please adjust code to the constant!" @@ -658,4 +733,5 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) default: FEprogram_error("Too many arguments", 0); } + _ecl_unexpected_return(); } diff --git a/src/c/eval.d b/src/c/eval.d index 237f54660..b7d34a6a1 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -16,127 +16,6 @@ #include #include -cl_object * -_ecl_va_sp(cl_narg narg) -{ - return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; -} - -/* Calling conventions: - * Compiled C code calls lisp function supplying #args, and args. - * Linking function performs check_args, gets jmp_buf with _setjmp, then - * if cfun then stores C code address into function link location - * and transfers to jmp_buf at cf_self - * if cclosure then replaces #args with cc_env and calls cc_self - * otherwise, it emulates funcall. - */ - -cl_object -ecl_apply_from_stack_frame(cl_object frame, cl_object x) -{ - cl_object *sp = ECL_STACK_FRAME_PTR(frame); - cl_index narg = frame->frame.size; - cl_object fun = x; - cl_object ret; - frame->frame.env->stack_frame = frame; - AGAIN: - frame->frame.env->function = fun; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) - FEwrong_num_arguments(fun); - ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); - break; - case t_cfun: - ret = APPLY(narg, fun->cfun.entry, sp); - break; - case t_cclosure: - ret = APPLY(narg, fun->cclosure.entry, sp); - break; - case t_instance: - switch (fun->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - ret = _ecl_standard_dispatch(frame, fun); - break; - case ECL_USER_DISPATCH: - fun = fun->instance.slots[fun->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - ret = APPLY(narg, fun->instance.entry, sp); - break; - default: - FEinvalid_function(fun); - } - break; - case t_symbol: - if (ecl_unlikely(!ECL_FBOUNDP(fun))) - FEundefined_function(fun); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - ret = ecl_interpret(frame, ECL_NIL, fun); - break; - case t_bclosure: - ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - break; - default: - FEinvalid_function(x); - } - frame->frame.env->stack_frame = NULL; /* for gc's sake */ - return ret; -} - -cl_objectfn -ecl_function_dispatch(cl_env_ptr env, cl_object x) -{ - cl_object fun = x; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - env->function = fun; - return fun->cfunfixed.entry; - case t_cfun: - env->function = fun; - return fun->cfun.entry; - case t_cclosure: - env->function = fun; - return fun->cclosure.entry; - case t_instance: - env->function = fun; - return fun->instance.entry; - case t_symbol: - fun = ECL_SYM_FUN(fun); - env->function = fun; - return fun->cfun.entry; - case t_bytecodes: - env->function = fun; - return fun->bytecodes.entry; - case t_bclosure: - env->function = fun; - return fun->bclosure.entry; - default: - FEinvalid_function(x); - } -} - -cl_object -cl_funcall(cl_narg narg, cl_object function, ...) -{ - cl_object output; - --narg; - { - ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); - output = ecl_apply_from_stack_frame(frame, function); - ECL_STACK_FRAME_VARARGS_END(frame); - } - return output; -} - @(defun apply (fun lastarg &rest args) @ { if (narg == 2 && ecl_t_of(lastarg) == t_frame) { -- GitLab From 86d64b358ac5e76d45c81d422ab7f4b0f8266a90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 23 Apr 2024 08:52:59 +0200 Subject: [PATCH 24/58] nucleus: move atomics from threads directory to core Atomics are needed by stacks. Replace ecl_atomic_push -> ecl_atomic_psh that takes as an argument a preallocated cons. ecl_atomic_push is replaced by a macro. --- src/c/Makefile.in | 5 ++--- src/c/{threads => }/atomic.d | 15 ++++++++------- src/h/external.h | 5 +++-- 3 files changed, 13 insertions(+), 12 deletions(-) rename src/c/{threads => }/atomic.d (81%) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 555b85e11..694f66358 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = call.o +NUCL_OBJS = call.o atomic.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o @@ -79,8 +79,7 @@ OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o \ vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ - load.o unixfsys.o unixsys.o serialize.o sse2.o threads/atomic.o \ - process.o \ + load.o unixfsys.o unixsys.o serialize.o sse2.o process.o \ $(CLOS_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(FFI_OBJS) \ $(NUCL_OBJS) @EXTRA_OBJS@ diff --git a/src/c/threads/atomic.d b/src/c/atomic.d similarity index 81% rename from src/c/threads/atomic.d rename to src/c/atomic.d index b6d3e6109..91d17c7e3 100644 --- a/src/c/threads/atomic.d +++ b/src/c/atomic.d @@ -2,7 +2,7 @@ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - * atomic.d - atomic operations + * atomic.c - atomic operations * * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya * Copyright (c) 1990 Giuseppe Attardi @@ -27,14 +27,15 @@ ecl_atomic_get(cl_object *slot) return old; } -void -ecl_atomic_push(cl_object *slot, cl_object c) +cl_object +ecl_atomic_psh(cl_object *slot, cl_object cons) { - cl_object cons = ecl_list1(c), car; + cl_object cdr; do { - car = (cl_object)AO_load((AO_t*)slot); - ECL_RPLACD(cons, car); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)car, (AO_t)cons)); + cdr = (cl_object)AO_load((AO_t*)slot); + ECL_RPLACD(cons, cdr); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)cdr, (AO_t)cons)); + return cdr; } cl_object diff --git a/src/h/external.h b/src/h/external.h index d6d794d36..4256d0f1d 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1839,12 +1839,13 @@ extern ECL_API cl_object mp_mailbox_try_read(cl_object mailbox); extern ECL_API cl_object mp_mailbox_send(cl_object mailbox, cl_object msg); extern ECL_API cl_object mp_mailbox_try_send(cl_object mailbox, cl_object msg); -/* threads/atomic.c */ +/* nucleus/atomic.c */ extern ECL_API cl_object ecl_atomic_get(cl_object *slot); -extern ECL_API void ecl_atomic_push(cl_object *slot, cl_object o); +extern ECL_API cl_object ecl_atomic_psh(cl_object *slot, cl_object cons); extern ECL_API cl_object ecl_atomic_pop(cl_object *slot); extern ECL_API cl_index ecl_atomic_index_incf(cl_index *slot); +#define ecl_atomic_push(slot, obj) ecl_atomic_psh(slot, ecl_list1(obj)); /* threads/mutex.c */ -- GitLab From e1d9726d4f934ba7e1b1f4e0279f1d16c3ba1da1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 10:01:30 +0200 Subject: [PATCH 25/58] nucleus: add a module for program control transfer Currently it contains early errors and backtrace. --- src/c/Makefile.in | 2 +- src/c/error.d | 82 ++++--------------------- src/c/ffi/backtrace.d | 47 -------------- src/c/jump.d | 140 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 152 insertions(+), 119 deletions(-) create mode 100644 src/c/jump.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 694f66358..705791efb 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = call.o atomic.o +NUCL_OBJS = call.o jump.o atomic.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o diff --git a/src/c/error.d b/src/c/error.d index b420e47af..6622b99b3 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -24,69 +24,12 @@ #include #include -static cl_object -cl_symbol_or_object(cl_object x) -{ - if (ECL_FIXNUMP(x)) - return (cl_object)(cl_symbols + ecl_fixnum(x)); - return x; -} - -void -_ecl_unexpected_return() -{ - ecl_internal_error( - "*** \n" - "*** A call to ERROR returned without handling the error.\n" - "*** This should have never happened and is usually a signal\n" - "*** that the debugger or the universal error handler were\n" - "*** improperly coded or altered. Please contact the maintainers\n" - "***\n"); -} - -void -ecl_internal_error(const char *s) -{ - int saved_errno = errno; - fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); - if (saved_errno) { - fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); - } - fflush(stderr); - _ecl_dump_c_backtrace(); -#ifdef SIGIOT - signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ -#endif - abort(); -} - -#ifdef ECL_THREADS -void -ecl_thread_internal_error(const char *s) -{ - int saved_errno = errno; - fprintf(stderr, "\nInternal thread error in:\n%s\n", s); - if (saved_errno) { - fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); - } - _ecl_dump_c_backtrace(); - fprintf(stderr, - "\nDid you forget to call `ecl_import_current_thread'?\n" - "Exitting thread.\n"); - fflush(stderr); - ecl_thread_exit(); -} -#endif - void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) { - /* - * Right now we have no means of specifying a jump point - * for really bad events. We just jump to the outermost - * frame, which is equivalent to quitting, and wait for - * someone to intercept this jump. - */ + /* Right now we have no means of specifying a jump point for really bad + * events. We just jump to the outermost frame, which is equivalent to + * quitting, and wait for someone to intercept this jump. */ ecl_frame_ptr destination; cl_object tag; @@ -112,21 +55,18 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) } } -void -ecl_miscompilation_error() -{ - ecl_internal_error( - "***\n" - "*** Encountered a code path that should have never been taken.\n" - "*** This likely indicates a bug in the ECL compiler. Please contact\n" - "*** the maintainers.\n" - "***\n"); -} - /*****************************************************************************/ /* Support for Lisp Error Handler */ /*****************************************************************************/ +static cl_object +cl_symbol_or_object(cl_object x) +{ + if (ECL_FIXNUMP(x)) + return (cl_object)(cl_symbols + ecl_fixnum(x)); + return x; +} + void FEerror(const char *s, int narg, ...) { diff --git a/src/c/ffi/backtrace.d b/src/c/ffi/backtrace.d index d1b72a310..0384babae 100644 --- a/src/c/ffi/backtrace.d +++ b/src/c/ffi/backtrace.d @@ -24,56 +24,9 @@ # include #endif -/* Max number of frames dumped by _ecl_dump_c_backtrace */ -#define MAX_BACKTRACE_SIZE 128 /* Max length of symbols printed */ #define MAX_SYMBOL_LENGTH 256 -void -_ecl_dump_c_backtrace() -{ -#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) - { - void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE); -# if defined(ECL_UNIX_BACKTRACE) - int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE); - char **names = backtrace_symbols(pointers, nframes); -# elif defined(ECL_WINDOWS_BACKTRACE) - HANDLE process = GetCurrentProcess(); - if (!SymInitialize(process, NULL, TRUE)) { - return; - } - int nframes = CaptureStackBackTrace(0, MAX_BACKTRACE_SIZE, pointers, NULL); - char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)]; - PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer; - pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO); - pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH; -# endif - int i; - fprintf(stderr, "\n;;; ECL C Backtrace\n"); - for (i = 0; i < nframes; i++) { -# if defined(ECL_UNIX_BACKTRACE) - fprintf(stderr, ";;; %s\n", names[i]); -# elif defined(ECL_WINDOWS_BACKTRACE) - DWORD64 displacement; - if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) { - fprintf(stderr, ";;; (%s+0x%llx) [0x%p]\n", pSymbol->Name, displacement, pointers[i]); - } else { - fprintf(stderr, ";;; (unknown) [0x%p]\n", pointers[i]); - } -# endif - } - fflush(stderr); - free(pointers); -# if defined(ECL_UNIX_BACKTRACE) - free(names); -# elif defined(ECL_WINDOWS_BACKTRACE) - SymCleanup(process); -# endif - } -#endif /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */ -} - cl_object si_dump_c_backtrace(cl_object size) { diff --git a/src/c/jump.d b/src/c/jump.d new file mode 100644 index 000000000..0d8fa836d --- /dev/null +++ b/src/c/jump.d @@ -0,0 +1,140 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* control.c - signaling conditions and transfering program control */ + +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) +# include +#endif + +#if defined(HAVE_BACKTRACE) && defined(HAVE_BACKTRACE_SYMBOLS) +# include +# define ECL_UNIX_BACKTRACE +#endif + +#if defined(ECL_WINDOWS_BACKTRACE) +# include +# include +#endif + +/* -- Fatal errors ---------------------------------------------------------- ** + +Fatal errors that can't be recovered from and result in the program abortion. + +** ---------------------------------------------------------------------------*/ + +void +ecl_internal_error(const char *s) +{ + int saved_errno = errno; + fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); + if (saved_errno) { + fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); + } + fflush(stderr); + _ecl_dump_c_backtrace(); +#ifdef SIGIOT + signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ +#endif + abort(); +} + +#ifdef ECL_THREADS +void +ecl_thread_internal_error(const char *s) +{ + int saved_errno = errno; + fprintf(stderr, "\nInternal thread error in:\n%s\n", s); + if (saved_errno) { + fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); + } + _ecl_dump_c_backtrace(); + fprintf(stderr, "\nDid you forget to call `ecl_import_current_thread'?\n" + "Exitting thread.\n"); + fflush(stderr); + ecl_thread_exit(); +} +#endif + +void +_ecl_unexpected_return() +{ + ecl_internal_error("*** \n" + "*** A call to ERROR returned without handling the error.\n" + "*** This should have never happened and is usually a signal\n" + "*** that the debugger or the universal error handler were\n" + "*** improperly coded or altered. Please contact the maintainers\n" + "*** \n"); +} + +void +ecl_miscompilation_error() +{ + ecl_internal_error("*** \n" + "*** Encountered a code path that should have never been taken.\n" + "*** This likely indicates a bug in the ECL compiler. Please contact\n" + "*** the maintainers.\n" + "*** \n"); +} + + +/* Max number of frames dumped by _ecl_dump_c_backtrace */ +#define MAX_BACKTRACE_SIZE 128 +/* Max length of symbols printed */ +#define MAX_SYMBOL_LENGTH 256 + +void +_ecl_dump_c_backtrace() +{ +#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) + { + void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE); +# if defined(ECL_UNIX_BACKTRACE) + int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE); + char **names = backtrace_symbols(pointers, nframes); +# elif defined(ECL_WINDOWS_BACKTRACE) + HANDLE process = GetCurrentProcess(); + if (!SymInitialize(process, NULL, TRUE)) { + return; + } + int nframes = CaptureStackBackTrace(0, MAX_BACKTRACE_SIZE, pointers, NULL); + char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)]; + PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer; + pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO); + pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH; +# endif + int i; + fprintf(stderr, "\n;;; ECL C Backtrace\n"); + for (i = 0; i < nframes; i++) { +# if defined(ECL_UNIX_BACKTRACE) + fprintf(stderr, ";;; %s\n", names[i]); +# elif defined(ECL_WINDOWS_BACKTRACE) + DWORD64 displacement; + if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) { + fprintf(stderr, ";;; (%s+0x%llx) [0x%p]\n", pSymbol->Name, displacement, pointers[i]); + } else { + fprintf(stderr, ";;; (unknown) [0x%p]\n", pointers[i]); + } +# endif + } + fflush(stderr); + free(pointers); +# if defined(ECL_UNIX_BACKTRACE) + free(names); +# elif defined(ECL_WINDOWS_BACKTRACE) + SymCleanup(process); +# endif + } +#endif /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */ +} -- GitLab From f1bcd3fa469b0df702f9eef52d4d8aff40bbe3f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 24 Nov 2022 22:50:31 +0100 Subject: [PATCH 26/58] nucleus: add a module boot for booting the core Currently it contains only option setters. --- src/c/Makefile.in | 2 +- src/c/boot.d | 87 +++++++++++++++++++++++++++++++++++++++++++++++ src/c/main.d | 76 ----------------------------------------- src/h/external.h | 2 +- 4 files changed, 89 insertions(+), 78 deletions(-) create mode 100644 src/c/boot.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 705791efb..f0e58b646 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = call.o jump.o atomic.o +NUCL_OBJS = boot.o call.o jump.o atomic.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o diff --git a/src/c/boot.d b/src/c/boot.d new file mode 100644 index 000000000..15684066e --- /dev/null +++ b/src/c/boot.d @@ -0,0 +1,87 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* boot.c - initializing ecl internal data */ + +/* -- imports ------------------------------------------------------- */ + +#include +#include + +/* -- implementation------------------------------------------------- */ + +#if ECL_FIXNUM_BITS <= 32 +/* 1GB */ +#define ECL_DEFAULT_HEAP_SIZE 1073741824L +#else +/* 4GB */ +#define ECL_DEFAULT_HEAP_SIZE 4294967296L +#endif + +#ifndef ECL_DEFAULT_C_STACK_SIZE +#define ECL_DEFAULT_C_STACK_SIZE 0 +#endif + +#ifdef GBC_BOEHM_GENGC +#define ECL_INCREMENTAL_GC 1 +#else +#define ECL_INCREMENTAL_GC 0 +#endif + +#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) +#define ECL_SIGNAL_HANDLING_THREAD 1 +#else +#define ECL_SIGNAL_HANDLING_THREAD 0 +#endif + +/* INV: see ecl_option enum in external.h */ +cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { + /* ---------------------------------------------------------------- */ + ECL_INCREMENTAL_GC, /* ECL_OPT_INCREMENTAL_GC */ + 1, /* ECL_OPT_TRAP_SIGSEGV */ + 1, /* ECL_OPT_TRAP_SIGFPE */ + 1, /* ECL_OPT_TRAP_SIGINT */ + 1, /* ECL_OPT_TRAP_SIGILL */ + 1, /* ECL_OPT_TRAP_SIGBUS */ + 1, /* ECL_OPT_TRAP_SIGPIPE */ + 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ + ECL_SIGNAL_HANDLING_THREAD, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ + 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ + 0, /* ECL_OPT_BOOTED */ + /* ---------------------------------------------------------------- */ + 8192, /* ECL_OPT_BIND_STACK_SIZE */ + 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ + 2048, /* ECL_OPT_FRAME_STACK_SIZE */ + 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ + 32768, /* ECL_OPT_LISP_STACK_SIZE */ + 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ + ECL_DEFAULT_C_STACK_SIZE, /* ECL_OPT_C_STACK_SIZE */ + 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ + ECL_DEFAULT_HEAP_SIZE, /* ECL_OPT_HEAP_SIZE */ + 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ + 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ + 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ + 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ + /* ---------------------------------------------------------------- */ + 0}; + +cl_fixnum +ecl_get_option(int option) +{ + if (option >= ECL_OPT_LIMIT || option < 0) { + return -1; + } + return ecl_option_values[option]; +} + +cl_fixnum +ecl_set_option(int option, cl_fixnum value) +{ + if (option > ECL_OPT_LIMIT || option < 0) { + return -1; + } + if (option >= ECL_OPT_BOOTED || !ecl_option_values[ECL_OPT_BOOTED]) { + ecl_option_values[option] = value; + } + return ecl_option_values[option]; +} diff --git a/src/c/main.d b/src/c/main.d index e8b77fd2d..78ea4e565 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -136,84 +136,8 @@ ecl_def_ct_token(ecl_ct_dummy_tag ,ecl_stp_constant,ecl_ct_dtag_string,ECL_NIL, /************************ GLOBAL INITIALIZATION ***********************/ - -/* HEAP */ - -#if ECL_FIXNUM_BITS <= 32 -/* 1GB */ -#define HEAP_SIZE_DEFAULT 1073741824L -#else -/* 4GB */ -#define HEAP_SIZE_DEFAULT 4294967296L -#endif - - static int ARGC; static char **ARGV; -/* INV: see ecl_option enum in external.h */ -cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { -#ifdef GBC_BOEHM_GENGC - 1, /* ECL_OPT_INCREMENTAL_GC */ -#else - 0, /* ECL_OPT_INCREMENTAL_GC */ -#endif - 1, /* ECL_OPT_TRAP_SIGSEGV */ - 1, /* ECL_OPT_TRAP_SIGFPE */ - 1, /* ECL_OPT_TRAP_SIGINT */ - 1, /* ECL_OPT_TRAP_SIGILL */ - 1, /* ECL_OPT_TRAP_SIGBUS */ - 1, /* ECL_OPT_TRAP_SIGPIPE */ - 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ -#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) - 1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ -#else - 0, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ -#endif - 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ - 0, /* ECL_OPT_BOOTED */ - 8192, /* ECL_OPT_BIND_STACK_SIZE */ - 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ - 2048, /* ECL_OPT_FRAME_STACK_SIZE */ - 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ - 32768, /* ECL_OPT_LISP_STACK_SIZE */ - 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ - ECL_DEFAULT_C_STACK_SIZE, /* ECL_OPT_C_STACK_SIZE */ - 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ - HEAP_SIZE_DEFAULT, /* ECL_OPT_HEAP_SIZE */ - 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ - 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ - 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ - 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ - 0}; - -#if !defined(GBC_BOEHM) -static char stdin_buf[BUFSIZ]; -static char stdout_buf[BUFSIZ]; -#endif - -cl_fixnum -ecl_get_option(int option) -{ - if (option >= ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } - return ecl_option_values[option]; -} - -void -ecl_set_option(int option, cl_fixnum value) -{ - if (option > ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } else { - if (option < ECL_OPT_BOOTED && - ecl_option_values[ECL_OPT_BOOTED]) { - FEerror("Cannot change option ~D while ECL is running", - 1, ecl_make_fixnum(option)); - } - ecl_option_values[option] = value; - } -} static void init_env_mp(cl_env_ptr env) diff --git a/src/h/external.h b/src/h/external.h index 4256d0f1d..3b8587af5 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -994,7 +994,7 @@ typedef enum { } ecl_option; extern ECL_API const char *ecl_self; -extern ECL_API void ecl_set_option(int option, cl_fixnum value); +extern ECL_API cl_fixnum ecl_set_option(int option, cl_fixnum value); extern ECL_API cl_fixnum ecl_get_option(int option); extern ECL_API int cl_boot(int argc, char **argv); extern ECL_API void cl_shutdown(void); -- GitLab From 3f892075376e03f80e7429c246617be1b8e0b876 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 14:43:49 +0200 Subject: [PATCH 27/58] nucleus: move files process.o and process.d from OBJS to NUCL_OBJS --- src/c/Makefile.in | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index f0e58b646..93f91ae8e 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = boot.o call.o jump.o atomic.o +NUCL_OBJS = boot.o call.o jump.o atomic.o process.o memory.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o @@ -76,10 +76,10 @@ FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o \ compiler.o disassembler.o reference.o character.o file.o error.o \ - string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o \ + string.o cfun.o typespec.o assignment.o predicate.o array.o \ vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ - load.o unixfsys.o unixsys.o serialize.o sse2.o process.o \ + load.o unixfsys.o unixsys.o serialize.o sse2.o \ $(CLOS_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(FFI_OBJS) \ $(NUCL_OBJS) @EXTRA_OBJS@ -- GitLab From ebdde0b631ae5522e7ad8cce0d40866d225d6e31 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 10:11:00 +0200 Subject: [PATCH 28/58] nucleus: move early constants from main.d to boot.d --- src/c/boot.d | 23 ++++++++++++++++++++++- src/c/main.d | 20 -------------------- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/c/boot.d b/src/c/boot.d index 15684066e..0eb97fed4 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -6,9 +6,30 @@ /* -- imports ------------------------------------------------------- */ #include +#include #include -/* -- implementation------------------------------------------------- */ +/* -- constants ----------------------------------------------------- */ + +const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800); + +ecl_def_ct_base_string(ecl_ct_null_string,"",0,,const); + +ecl_def_ct_single_float(ecl_ct_default_rehash_size,1.5f,,const); +ecl_def_ct_single_float(ecl_ct_default_rehash_threshold,0.75f,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_zero,0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_zero,0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_zero,0,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_minus_zero,-0.0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_minus_zero,-0.0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const); + +ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); +ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); + +/* -- implementation ------------------------------------------------ */ #if ECL_FIXNUM_BITS <= 32 /* 1GB */ diff --git a/src/c/main.d b/src/c/main.d index 78ea4e565..a8784a516 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -106,26 +106,6 @@ ecl_boot(void) return 0; } -/* -- constants ----------------------------------------------------- */ - -const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800); - -ecl_def_ct_base_string(ecl_ct_null_string,"",0,,const); - -ecl_def_ct_single_float(ecl_ct_default_rehash_size,1.5f,,const); -ecl_def_ct_single_float(ecl_ct_default_rehash_threshold,0.75f,,const); - -ecl_def_ct_single_float(ecl_ct_singlefloat_zero,0,,const); -ecl_def_ct_double_float(ecl_ct_doublefloat_zero,0,,const); -ecl_def_ct_long_float(ecl_ct_longfloat_zero,0,,const); - -ecl_def_ct_single_float(ecl_ct_singlefloat_minus_zero,-0.0,,const); -ecl_def_ct_double_float(ecl_ct_doublefloat_minus_zero,-0.0,,const); -ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const); - -ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); -ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); - /* These two tags have a special meaning for the frame stack. */ ecl_def_ct_base_string(ecl_ct_ptag_string,"PROTECT-TAG",11,static,const); -- GitLab From 8d936ab24823bbc372b23c32cb31c31ba98c254f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 10:19:59 +0200 Subject: [PATCH 29/58] nucleus: move protect and dummy tags to boot.d --- src/c/boot.d | 9 +++++++++ src/c/main.d | 8 -------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/c/boot.d b/src/c/boot.d index 0eb97fed4..e7df5b213 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -29,6 +29,15 @@ ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const); ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); +/* These two tags have a special meaning for the frame stack. */ + +ecl_def_ct_base_string(ecl_ct_ptag_string,"PROTECT-TAG",11,static,const); +ecl_def_ct_base_string(ecl_ct_dtag_string,"DUMMY-TAG",9,static,const); + +ecl_def_ct_token(ecl_ct_protect_tag,ecl_stp_constant,ecl_ct_ptag_string,ECL_NIL,,const); +ecl_def_ct_token(ecl_ct_dummy_tag ,ecl_stp_constant,ecl_ct_dtag_string,ECL_NIL,,const); + + /* -- implementation ------------------------------------------------ */ #if ECL_FIXNUM_BITS <= 32 diff --git a/src/c/main.d b/src/c/main.d index a8784a516..98e5ea7cd 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -106,14 +106,6 @@ ecl_boot(void) return 0; } -/* These two tags have a special meaning for the frame stack. */ - -ecl_def_ct_base_string(ecl_ct_ptag_string,"PROTECT-TAG",11,static,const); -ecl_def_ct_base_string(ecl_ct_dtag_string,"DUMMY-TAG",9,static,const); - -ecl_def_ct_token(ecl_ct_protect_tag,ecl_stp_constant,ecl_ct_ptag_string,ECL_NIL,,const); -ecl_def_ct_token(ecl_ct_dummy_tag ,ecl_stp_constant,ecl_ct_dtag_string,ECL_NIL,,const); - /************************ GLOBAL INITIALIZATION ***********************/ static int ARGC; -- GitLab From d840f10892b6c44e18c394370e6b5070f2724e28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 11:05:02 +0200 Subject: [PATCH 30/58] nucleus: move ecl_core_struct to nucleus --- src/c/boot.d | 80 +++++++++++++++++++++++++++++++++++++++++++++++- src/c/main.d | 71 +----------------------------------------- src/h/ecl.h | 1 + src/h/external.h | 32 ++----------------- src/h/nucleus.h | 27 ++++++++++++++++ 5 files changed, 110 insertions(+), 101 deletions(-) diff --git a/src/c/boot.d b/src/c/boot.d index e7df5b213..878533331 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -3,11 +3,27 @@ /* boot.c - initializing ecl internal data */ -/* -- imports ------------------------------------------------------- */ +/* -- imports --------------------------------------------------------------- */ + +#include +#if defined(ECL_MS_WINDOWS_HOST) +# include +# include +# define MAXPATHLEN 512 +#endif +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN sysconf(_PC_PATH_MAX) +# include +# endif +#endif #include #include #include +#include /* -- constants ----------------------------------------------------- */ @@ -115,3 +131,65 @@ ecl_set_option(int option, cl_fixnum value) } return ecl_option_values[option]; } + +/* -- core runtime ---------------------------------------------------------- */ + +/* The root environment is a default execution context. */ +static struct cl_env_struct first_env; + +struct ecl_core_struct ecl_core = { + .first_env = &first_env, + /* processes */ +#ifdef ECL_THREADS + .processes = ECL_NIL, + .last_var_index = 0, + .reused_indices = ECL_NIL, +#endif + /* signals */ + .default_sigmask_bytes = 0, + .known_signals = ECL_NIL, + /* allocation */ + .max_heap_size = 0, + .bytes_consed = ECL_NIL, + .gc_counter = ECL_NIL, + .gc_stats = 0, + .safety_region = NULL, + /* pathnames */ + .path_max = 0, + .pathname_translations = ECL_NIL, + /* LIBRARIES is a list of objects. It behaves as a sequence of weak pointers + thanks to the magic in the garbage collector. */ + .libraries = ECL_NIL, + .library_pathname = ECL_NIL +}; + +/* note that this function does not create any environment */ +int +ecl_boot(void) +{ + int i; + + i = ecl_option_values[ECL_OPT_BOOTED]; + if (i) { + if (i < 0) { + /* We have called cl_shutdown and want to use ECL again. */ + ecl_set_option(ECL_OPT_BOOTED, 1); + } + return 1; + } + + init_process(); + /* init_unixint(); */ + /* init_garbage(); */ + + ecl_core.path_max = MAXPATHLEN; + + return 0; +} + +int +ecl_halt(void) +{ + ecl_set_option(ECL_OPT_BOOTED, -1); + return 0; +} diff --git a/src/c/main.d b/src/c/main.d index 98e5ea7cd..58122e35b 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -15,20 +15,6 @@ /******************************** IMPORTS *****************************/ #include -#include -#if defined(ECL_MS_WINDOWS_HOST) -# include -# include -# define MAXPATHLEN 512 -#endif -#ifndef MAXPATHLEN -# ifdef PATH_MAX -# define MAXPATHLEN PATH_MAX -# else -# define NO_PATH_MAX -# include -# endif -#endif #ifdef ECL_USE_MPROTECT # include # ifndef MAP_FAILED @@ -51,61 +37,6 @@ const char *ecl_self; -/* -- core runtime ---------------------------------------------------------- */ - -/* The root environment is a default execution context. */ -static struct cl_env_struct first_env; - -struct ecl_core_struct ecl_core = { - .first_env = &first_env, - /* processes */ -#ifdef ECL_THREADS - .processes = ECL_NIL, - .last_var_index = 0, - .reused_indices = ECL_NIL, -#endif - /* signals */ - .default_sigmask_bytes = 0, - .known_signals = ECL_NIL, - /* allocation */ - .max_heap_size = 0, - .bytes_consed = ECL_NIL, - .gc_counter = ECL_NIL, - .gc_stats = 0, - .safety_region = NULL, - /* pathnames */ - .path_max = 0, - .pathname_translations = ECL_NIL, - /* LIBRARIES is a list of objects. It behaves as a sequence of weak pointers - thanks to the magic in the garbage collector. */ - .libraries = ECL_NIL, - .library_pathname = ECL_NIL -}; - -/* note that this function does not create any environment */ -int -ecl_boot(void) -{ - int i; - - i = ecl_option_values[ECL_OPT_BOOTED]; - if (i) { - if (i < 0) { - /* We have called cl_shutdown and want to use ECL again. */ - ecl_set_option(ECL_OPT_BOOTED, 1); - } - return 1; - } - - init_process(); - /* init_unixint(); */ - /* init_garbage(); */ - - ecl_core.path_max = MAXPATHLEN; - - return 0; -} - /************************ GLOBAL INITIALIZATION ***********************/ static int ARGC; @@ -286,7 +217,7 @@ cl_shutdown(void) ecl_tcp_close_all(); #endif } - ecl_set_option(ECL_OPT_BOOTED, -1); + ecl_halt(); } ecl_def_ct_base_string(str_common_lisp,"COMMON-LISP",11,static,const); diff --git a/src/h/ecl.h b/src/h/ecl.h index ee1fca141..a95e27e70 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -80,6 +80,7 @@ #endif #include +#include #include #include #include diff --git a/src/h/external.h b/src/h/external.h index 3b8587af5..1a3032689 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -169,35 +169,6 @@ struct ecl_interrupt_struct { extern ECL_API cl_env_ptr cl_env_p; #endif -/* Core environment. */ - -struct ecl_core_struct { - cl_env_ptr first_env; -#ifdef ECL_THREADS - cl_object processes; - ecl_mutex_t processes_lock; - ecl_mutex_t global_lock; - ecl_mutex_t error_lock; - ecl_rwlock_t global_env_lock; - cl_index last_var_index; - cl_object reused_indices; -#endif - size_t max_heap_size; - cl_object bytes_consed; - cl_object gc_counter; - bool gc_stats; - char *safety_region; - - cl_index default_sigmask_bytes; - cl_object known_signals; - - int path_max; - cl_object pathname_translations; - - cl_object libraries; - cl_object library_pathname; -}; - /* Per-process data. Modify main.d accordingly. */ struct cl_core_struct { @@ -243,8 +214,9 @@ extern ECL_API void ecl_free(void *ptr); extern ECL_API void ecl_copy(void *dst, void *src, cl_index ndx); #define ecl_free_unsafe(x) ecl_free(x); -/* cold_boot.c */ +/* boot.c */ extern ECL_API int ecl_boot(void); +extern ECL_API int ecl_halt(void); extern ECL_API const cl_object ecl_ct_Jan1st1970UT; extern ECL_API const cl_object ecl_ct_null_string; diff --git a/src/h/nucleus.h b/src/h/nucleus.h index 54c9fc92d..70d7617d9 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -6,4 +6,31 @@ #include "external.h" +struct ecl_core_struct { + cl_env_ptr first_env; +#ifdef ECL_THREADS + cl_object processes; + ecl_mutex_t processes_lock; + ecl_mutex_t global_lock; + ecl_mutex_t error_lock; + ecl_rwlock_t global_env_lock; + cl_index last_var_index; + cl_object reused_indices; +#endif + size_t max_heap_size; + cl_object bytes_consed; + cl_object gc_counter; + bool gc_stats; + char *safety_region; + + cl_index default_sigmask_bytes; + cl_object known_signals; + + int path_max; + cl_object pathname_translations; + + cl_object libraries; + cl_object library_pathname; +}; + #endif /* ECL_NUCLEUS_H */ -- GitLab From bde0bf209068ad57609ea3f4ce04379b254ae8c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 11 Apr 2024 12:20:41 +0200 Subject: [PATCH 31/58] exceptions: rewrite signal handling to use functions and not lists Instead of storing lists in *HANDLER-CLUSTERS*, we define functions that are called unconditionally on the handler. HANDLER-BIND defines that function to be a typecase that is dispatched based on the conditiont type, as specified by CL. This change will aid further refactor. --- src/clos/conditions.lsp | 44 ++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 87c82a4a7..009099b38 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -88,15 +88,6 @@ :function f))) *restart-clusters*))) -(defun bind-simple-handlers (tag names) - (flet ((simple-handler-function (tag code) - #'(lambda (c) (throw tag (values code c))))) - (cons (loop for i from 1 - for n in (if (atom names) (list names) names) - for f = (simple-handler-function tag i) - collect (cons n f)) - *handler-clusters*))) - (defmacro restart-bind (bindings &body forms) `(let ((*restart-clusters* (cons (list ,@(mapcar #'(lambda (binding) @@ -382,16 +373,27 @@ |# -(defparameter *handler-clusters* nil) +(defvar *handler-clusters* nil) -(defmacro handler-bind (bindings &body forms) - (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) - (error "Ill-formed handler bindings.")) - `(let ((*handler-clusters* - (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) - ,@forms)) +(defmacro handler-bind (bindings &body body) + (with-gensyms (handler condition) + `(flet ((,handler (,condition) + (typecase ,condition + ,@(loop for (type func . rest) in bindings + when rest do + (error "Ill-formed handler bindings.") + collect `(,type (funcall ,func ,condition)))))) + (declare (dynamic-extent (function ,handler))) + (let ((*handler-clusters* (cons (function ,handler) *handler-clusters*))) + ,@body)))) + +(defun bind-simple-handlers (tag names) + (flet ((simple-handler (condition) + (loop for code from 1 + for type in (if (atom names) (list names) names) + when (typep condition type) do + (throw tag (values code condition))))) + (cons #'simple-handler *handler-clusters*))) (defun signal (datum &rest arguments) (let* ((condition @@ -400,10 +402,8 @@ (when (typep condition *break-on-signals*) (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition)) (loop (unless *handler-clusters* (return)) - (let ((cluster (pop *handler-clusters*))) - (dolist (handler cluster) - (when (typep condition (car handler)) - (funcall (cdr handler) condition))))) + (let ((handler (pop *handler-clusters*))) + (funcall handler condition))) nil)) -- GitLab From e83abf68c5fac843cda0fa43e417371782ab4872 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 15 Apr 2024 08:37:20 +0200 Subject: [PATCH 32/58] exceptions: introduce signals to the early environment --- src/c/jump.d | 69 +++++++++++++++++++++++++++++++++++++++++ src/c/symbols_list.h | 3 ++ src/clos/conditions.lsp | 8 ++--- src/h/nucleus.h | 24 ++++++++++++++ 4 files changed, 98 insertions(+), 6 deletions(-) diff --git a/src/c/jump.d b/src/c/jump.d index 0d8fa836d..fa358ec82 100644 --- a/src/c/jump.d +++ b/src/c/jump.d @@ -28,6 +28,75 @@ # include #endif +/* -- Escapes --------------------------------------------------------------- ** + +Non-local transfer of control. Practically this is like THROW, where +continuation is the exit point estabilished by an equivalent of CATCH. + +** -------------------------------------------------------------------------- */ + +cl_object +ecl_escape(cl_object continuation) +{ + ecl_frame_ptr fr = frs_sch(continuation); + if (!fr) ecl_internal_error("si_fear_handler: continuation not found!"); + ecl_unwind(ecl_process_env(), fr); + _ecl_unexpected_return(); +} + +/* -- Signaling conditions -------------------------------------------------- ** + +Low level signals work slightly different from Common Lisp. There are no handler +clusters nor restarts. %signal is called with three arguments: + +- condition :: the signaled object (may be any cl_object) +- returns :: the flag stating whether whether the function returns +- destination :: the thread the condition is delivered to (implementme!) + +The signal invokes all handlers bound with with-handler in LIFO order and call +them with the condition. The handler may take do one of the following: + +- decline :: return, then signal proceeds to the next handler +- escape :: perform non-local transfer of control +- defer :: signal a condition, invoke a debugger, ... + +The called handler is not bound as an active signal handler during its execution +to avoid an infinite recursion while resignaling. When all handlers decline and +the CONTINUABLE is ECL_NIL, then we abort the program by invoking the function +_ecl_unexpected_return(). + +** -------------------------------------------------------------------------- */ + +cl_object +ecl_signal(cl_object condition, cl_object returns, cl_object thread) { + const cl_env_ptr the_env = ecl_process_env(); + cl_object symbol, cluster, handler; + symbol = ECL_HANDLER_CLUSTERS; + cluster = ECL_SYM_VAL(the_env, symbol); + ecl_bds_bind(the_env, symbol, cluster); + while(!Null(cluster)) { + handler = ECL_CONS_CAR(cluster); + cluster = ECL_CONS_CDR(cluster); + ECL_SETQ(the_env, symbol, cluster); + _ecl_funcall2(handler, condition); + } + if (returns == ECL_NIL) + _ecl_unexpected_return(); + ecl_bds_unwind1(the_env); + return ECL_NIL; +} + +cl_object +ecl_call_with_handler(cl_object handler, cl_object continuation) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_object result; + ECL_WITH_HANDLER_BEGIN(the_env, handler) { + result = _ecl_funcall1(continuation); + } ECL_WITH_HANDLER_END; + return result; +} + /* -- Fatal errors ---------------------------------------------------------- ** Fatal errors that can't be recovered from and result in the program abortion. diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 5f2f461f0..9aef56d34 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -108,6 +108,9 @@ cl_symbols[] = { {SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, {EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)}, +{SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "%SIGNAL" ECL_FUN("ecl_signal", ecl_signal, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, + /* LISP PACKAGE */ {"&ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {"&AUX" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 009099b38..1e43abc87 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -396,14 +396,10 @@ (cons #'simple-handler *handler-clusters*))) (defun signal (datum &rest arguments) - (let* ((condition - (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)) - (*handler-clusters* *handler-clusters*)) + (let ((condition (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL))) (when (typep condition *break-on-signals*) (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition)) - (loop (unless *handler-clusters* (return)) - (let ((handler (pop *handler-clusters*))) - (funcall handler condition))) + (%signal condition t nil) nil)) diff --git a/src/h/nucleus.h b/src/h/nucleus.h index 70d7617d9..a27210fd7 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -33,4 +33,28 @@ struct ecl_core_struct { cl_object library_pathname; }; +/* control.c */ +cl_object ecl_escape(cl_object continuation) ecl_attr_noreturn; +cl_object ecl_signal(cl_object condition, cl_object returns, cl_object thread); +cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); + +/* Binding a handler conses a new list, but at this stage we don't assume the + the garbage collector to work! Luckily the extent of the binding is dynamic + and we can allocate cons on the stack. */ +#define ECL_WITH_HANDLER_BEGIN(the_env, handler) do { \ + const cl_env_ptr __the_env = the_env; \ + cl_object __ecl_sym = ECL_HANDLER_CLUSTERS; \ + cl_object __ecl_hnd = ECL_SYM_VAL(__the_env, __ecl_sym); \ + cl_object __ecl_hnds = ecl_cons_stack(handler, __ecl_hnd); \ + ecl_bds_bind(__the_env, __ecl_sym, __ecl_hnds); + +#define ECL_WITH_HANDLER_END ecl_bds_unwind1(__the_env); } while(0) + +cl_object ecl_raise(ecl_ex_type type, cl_object returns, + cl_object arg1, cl_object arg2, cl_object arg3); + +cl_object ecl_ferror(cl_object type, cl_object args); +cl_object ecl_cerror(cl_object type, cl_object args, cl_object cmsg); +cl_object ecl_serror(cl_object type, cl_object size, cl_object resz); + #endif /* ECL_NUCLEUS_H */ -- GitLab From e422b1eedcec21ff9c84a78c843241f1e68978b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 15:05:35 +0200 Subject: [PATCH 33/58] exceptions: introduce the concept of an exception The exception in CL is resignaled as a condition. --- src/c/alloc_2.d | 5 +++ src/c/clos/instance.d | 3 ++ src/c/error.d | 92 +++++++++++++++++++++++++++++++++++++- src/c/jump.d | 56 +++++++++++++++++++++++ src/c/main.d | 9 ++-- src/c/printer/write_ugly.d | 7 +++ src/c/serialize.d | 1 + src/c/symbols_list.h | 3 ++ src/c/threads/thread.d | 1 + src/c/typespec.d | 2 + src/clos/hierarchy.lsp | 1 + src/h/external.h | 4 ++ src/h/nucleus.h | 9 ++-- src/h/object.h | 38 ++++++++++++++++ 14 files changed, 219 insertions(+), 12 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index fa8d4ebbf..551fb8bc6 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -552,6 +552,7 @@ void init_type_info (void) init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1); init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 0); + init_tm(t_exception, "EXCEPTION", sizeof(struct ecl_exception), 3); init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); #ifdef ECL_SSE2 init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); @@ -710,6 +711,10 @@ void init_type_info (void) to_bitmap(&o, &(o.foreign.tag)); type_info[t_frame].descriptor = to_bitmap(&o, &(o.frame.env)); + type_info[t_exception].descriptor = + to_bitmap(&o, &(o.exception.arg1)) | + to_bitmap(&o, &(o.exception.arg2)) | + to_bitmap(&o, &(o.exception.arg3)); type_info[t_weak_pointer].descriptor = 0; #ifdef ECL_SSE2 type_info[t_sse_pack].descriptor = 0; diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index e589692b0..6fc1d8303 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -383,6 +383,7 @@ enum ecl_built_in_classes { ECL_BUILTIN_CODE_BLOCK, ECL_BUILTIN_FOREIGN_DATA, ECL_BUILTIN_FRAME, + ECL_BUILTIN_EXCEPTION, ECL_BUILTIN_WEAK_POINTER #ifdef ECL_THREADS , @@ -505,6 +506,8 @@ cl_class_of(cl_object x) index = ECL_BUILTIN_FOREIGN_DATA; break; case t_frame: index = ECL_BUILTIN_FRAME; break; + case t_exception: + index = ECL_BUILTIN_EXCEPTION; break; case t_weak_pointer: index = ECL_BUILTIN_WEAK_POINTER; break; #ifdef ECL_SSE2 diff --git a/src/c/error.d b/src/c/error.d index 6622b99b3..b71665d57 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -55,6 +55,95 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) } } +/* -- Integration with low-level exceptions */ +cl_object +ecl_exception_handler(cl_object o) +{ + if (ECL_EXCEPTIONP(o)) { + cl_object arg1 = o->exception.arg1; + cl_object arg2 = o->exception.arg2; + cl_object hand = @'si::universal-error-handler'; + switch (o->exception.ex_type) { + /* General conditions */ + case ECL_EX_FERROR: + ecl_enable_interrupts(); + return _ecl_funcall4(hand, ECL_NIL, arg1, arg2); + case ECL_EX_CERROR: + ecl_enable_interrupts(); + return _ecl_funcall4(hand, ECL_T, arg1, arg2); + /* Stack conditions */ + case ECL_EX_CS_OVR: + CEstack_overflow(@'ext::c-stack', arg1, arg2); + break; + case ECL_EX_FRS_OVR: + CEstack_overflow(@'ext::frame-stack', arg1, arg2); + break; + case ECL_EX_BDS_OVR: + CEstack_overflow(@'ext::binding-stack', arg1, arg2); + break; + /* KLUDGE ByteVM-specific conditions */ + case ECL_EX_VM_BADARG_EXCD: + FEprogram_error("Too many arguments passed to function ~A~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_UNKK: + FEprogram_error("Unknown keyword argument passed to function ~A.~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_ODDK: + FEprogram_error("Odd number of keyword arguments passed to function ~A.~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_NTH_VAL: + FEerror("Wrong index passed to NTH-VAL", 0); + break; + case ECL_EX_VM_BADARG_ENDP: + FEwrong_type_only_arg(@[endp], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_CAR: + FEwrong_type_only_arg(@[car], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_CDR: + FEwrong_type_only_arg(@[cdr], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_PROGV: + FEerror("Wrong arguments to special form PROGV. Either~%" + "~A~%or~%~A~%are not proper lists", + 2, arg1, arg2); + break; + /* Variable conditions */ + case ECL_EX_V_CSETQ: + FEassignment_to_constant(arg1); + break; + case ECL_EX_V_CBIND: + FEbinding_a_constant(arg1); + break; + case ECL_EX_V_UNBND: + FEunbound_variable(arg1); + break; + case ECL_EX_V_BNAME: + FEunbound_variable(arg1); + break; + /* Function conditions */ + case ECL_EX_F_NARGS: + FEwrong_num_arguments(arg1); + break; + case ECL_EX_F_UNDEF: + FEundefined_function(arg1); + break; + case ECL_EX_F_INVAL: + FEinvalid_function(arg1); + break; + default: + ecl_internal_error("Unknown exception type."); + } + } + return ECL_NIL; +} + /*****************************************************************************/ /* Support for Lisp Error Handler */ /*****************************************************************************/ @@ -562,6 +651,5 @@ void init_error(void) { ecl_def_c_function(@'si::universal-error-handler', - (cl_objectfn_fixed)universal_error_handler, - 3); + (cl_objectfn_fixed)universal_error_handler, 3); } diff --git a/src/c/jump.d b/src/c/jump.d index fa358ec82..67e68d90e 100644 --- a/src/c/jump.d +++ b/src/c/jump.d @@ -97,6 +97,62 @@ ecl_call_with_handler(cl_object handler, cl_object continuation) return result; } +/* -- Exceptions ------------------------------------------------------------ ** + +Conditions in Common Lisp are instances of STANDARD-CLASS. While eventually I'd +like to include classes to the early environment, that would be too much work at +one go. This is also the reason why ecl_signal accepts all kinds of objects. + +In order to signal conditions in the early environment we use a trick: we pass +to ecl_signal objects of type ecl_exception that are recognized by a Common Lisp +handler, and that handler resignals proper conditions. Exceptions are allocated +on the stack and capturing them is prohibited. + +ecl_raise is very similar to ecl_signal with an exception that it does not pop +the current handler from the stack. This is to ensure, that the condition +handler is invoked despite being "above" the exception handler on the stack. To +avoid infinite recursion it is prohibited to resignal the exception itself. + +** ---------------------------------------------------------------------------*/ + +cl_object +ecl_raise(ecl_ex_type type, bool returns, + cl_object arg1, cl_object arg2, cl_object arg3, void *arg4) +{ + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_exception ex = + { .t = t_exception, .ex_type = type, + .arg1 = arg1, .arg2 = arg2, .arg3 = arg3, .arg4 = arg4 }; + cl_object symbol, cluster, handler; + cl_object exception = ecl_cast_ptr(cl_object,&ex); + symbol = ECL_HANDLER_CLUSTERS; + cluster = ECL_SYM_VAL(the_env, symbol); + ecl_bds_bind(the_env, symbol, cluster); + while(!Null(cluster)) { + handler = ECL_CONS_CAR(cluster); + cluster = ECL_CONS_CDR(cluster); + _ecl_funcall2(handler, exception); + } + if (!returns) + _ecl_unexpected_return(); + ecl_bds_unwind1(the_env); + return ECL_NIL; +} + +cl_object +ecl_ferror(ecl_ex_type extype, cl_object type, cl_object args) +{ + ecl_raise(extype, 0, type, args, ECL_NIL, NULL); + _ecl_unexpected_return(); +} + +cl_object +ecl_cerror(ecl_ex_type extype, cl_object type, cl_object args) +{ + ecl_raise(extype, 1, type, args, ECL_NIL, NULL); + return ECL_NIL; +} + /* -- Fatal errors ---------------------------------------------------------- ** Fatal errors that can't be recovered from and result in the program abortion. diff --git a/src/c/main.d b/src/c/main.d index 58122e35b..02b1451cf 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -105,11 +105,7 @@ ecl_init_first_env(cl_env_ptr env) #ifdef ECL_THREADS init_threads(); #endif - init_env_mp(env); - init_env_int(env); - init_env_aux(env); - init_env_ffi(env); - init_stacks(env); + ecl_init_env(env); } void @@ -448,6 +444,9 @@ cl_boot(int argc, char **argv) /* We need to enable GC because a lot of stuff is to be created */ init_alloc(1); + /* Initialize the handler stack with the exception handler. */ + ECL_SET(ECL_HANDLER_CLUSTERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); + /* * Set *default-pathname-defaults* to a temporary fake value. We * will fix this when we have access to the condition system to diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index d99672ee1..522365d31 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -370,6 +370,12 @@ write_frame(cl_object x, cl_object stream) _ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), stream); } +static void +write_exception(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "exception", ECL_NIL, stream); +} + static void write_weak_pointer(cl_object x, cl_object stream) { @@ -480,6 +486,7 @@ static printer dispatch[FREE+1] = { write_codeblock, /* t_codeblock */ write_foreign, /* t_foreign */ write_frame, /* t_frame */ + write_exception, /* t_exception */ write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 _ecl_write_sse, /* t_sse_pack */ diff --git a/src/c/serialize.d b/src/c/serialize.d index d497e955e..216ee5df0 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -76,6 +76,7 @@ static cl_index object_size[] = { ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ ROUNDED_SIZE(ecl_foreign), /* t_foreign */ ROUNDED_SIZE(ecl_stack_frame), /* t_frame */ + ROUNDED_SIZE(ecl_exception), /* t_exception */ ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ #ifdef ECL_SSE2 , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 9aef56d34..ba3246b13 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -111,6 +111,8 @@ cl_symbols[] = { {SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "%SIGNAL" ECL_FUN("ecl_signal", ecl_signal, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "EXCEPTION-HANDLER" ECL_FUN("ecl_exception_handler", ecl_exception_handler, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, + /* LISP PACKAGE */ {"&ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {"&AUX" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, @@ -1844,6 +1846,7 @@ cl_symbols[] = { {SYS_ "CODE-BLOCK" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "EXCEPTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "FRAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "APPLY-FROM-STACK-FRAME" ECL_FUN("si_apply_from_stack_frame", si_apply_from_stack_frame, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index fc5817b85..907f09ff6 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -365,6 +365,7 @@ ecl_import_current_thread(cl_object name, cl_object bindings) env_aux->interrupt_struct->signal_queue = ECL_NIL; ecl_set_process_env(env_aux); ecl_init_env(env_aux); + ECL_SET(ECL_HANDLER_CLUSTERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); /* Allocate real environment, link it together with process */ env = _ecl_alloc_env(0); diff --git a/src/c/typespec.d b/src/c/typespec.d index 19e89538d..7e4ae800a 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -181,6 +181,8 @@ ecl_type_to_symbol(cl_type t) return @'si::foreign-data'; case t_frame: return @'si::frame'; + case t_exception: + return @'si::exception'; case t_weak_pointer: return @'ext::weak-pointer'; #ifdef ECL_SSE2 diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index 0e2690d58..af25872e1 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -229,6 +229,7 @@ (si::code-block) (si::foreign-data) (si::frame) + (si::exception) (si::weak-pointer) #+threads (mp::process) #+threads (mp::lock) diff --git a/src/h/external.h b/src/h/external.h index 1a3032689..1c1984c55 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -534,6 +534,8 @@ extern ECL_API cl_object si_bc_join(cl_object lex, cl_object code, cl_object dat extern ECL_API cl_object cl_error _ECL_ARGS((cl_narg narg, cl_object eformat, ...)) ecl_attr_noreturn; extern ECL_API cl_object cl_cerror _ECL_ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...)); +extern ECL_API cl_object ecl_exception_handler(cl_object exception); + extern ECL_API void ecl_internal_error(const char *s) ecl_attr_noreturn; #ifdef ECL_THREADS extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn; @@ -541,6 +543,8 @@ extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn; extern ECL_API void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_attr_noreturn; extern ECL_API void ecl_miscompilation_error(void) ecl_attr_noreturn; extern ECL_API void ecl_cs_overflow(void) /*ecl_attr_noreturn*/; + +extern ECL_API void CEstack_overflow(cl_object resume, cl_object type, cl_object size); extern ECL_API void FEprogram_error(const char *s, int narg, ...) ecl_attr_noreturn; extern ECL_API void FEcontrol_error(const char *s, int narg, ...) ecl_attr_noreturn; extern ECL_API void FEreader_error(const char *s, cl_object stream, int narg, ...) ecl_attr_noreturn; diff --git a/src/h/nucleus.h b/src/h/nucleus.h index a27210fd7..eb992e007 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -50,11 +50,10 @@ cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); #define ECL_WITH_HANDLER_END ecl_bds_unwind1(__the_env); } while(0) -cl_object ecl_raise(ecl_ex_type type, cl_object returns, - cl_object arg1, cl_object arg2, cl_object arg3); +cl_object ecl_raise(ecl_ex_type t, bool ret, + cl_object a1, cl_object a2, cl_object a3, void *a4); -cl_object ecl_ferror(cl_object type, cl_object args); -cl_object ecl_cerror(cl_object type, cl_object args, cl_object cmsg); -cl_object ecl_serror(cl_object type, cl_object size, cl_object resz); +cl_object ecl_ferror(ecl_ex_type extype, cl_object type, cl_object args); +cl_object ecl_cerror(ecl_ex_type extype, cl_object type, cl_object args); #endif /* ECL_NUCLEUS_H */ diff --git a/src/h/object.h b/src/h/object.h index 58951893c..462955885 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -84,6 +84,7 @@ typedef enum { t_codeblock, t_foreign, t_frame, + t_exception, t_weak_pointer, #ifdef ECL_SSE2 t_sse_pack, @@ -933,6 +934,42 @@ struct ecl_stack_frame { struct cl_env_struct *env; }; +typedef enum { + ECL_EX_FERROR, /* general purpose fatal error */ + ECL_EX_CERROR, /* general purpose continuable error */ + ECL_EX_CS_OVR, /* stack overflow */ + ECL_EX_FRS_OVR, /* stack overflow */ + ECL_EX_BDS_OVR, /* stack overflow */ + /* Kludges for the bytecodes VM */ + ECL_EX_VM_BADARG_EXCD, + ECL_EX_VM_BADARG_UNKK, + ECL_EX_VM_BADARG_ODDK, + ECL_EX_VM_BADARG_NTH_VAL, + ECL_EX_VM_BADARG_ENDP, + ECL_EX_VM_BADARG_CAR, + ECL_EX_VM_BADARG_CDR, + ECL_EX_VM_BADARG_PROGV, + /* Specific normal conditions */ + ECL_EX_V_CSETQ, /* assigning a constant */ + ECL_EX_V_CBIND, /* binding a constant */ + ECL_EX_V_UNBND, /* unbound variable */ + ECL_EX_V_BNAME, /* illegal variable name */ + ECL_EX_F_NARGS, /* wrong number of arguments */ + ECL_EX_F_UNDEF, /* undefined function */ + ECL_EX_F_INVAL /* non-function passed as function */ +} ecl_ex_type; + +#define ECL_EXCEPTIONP(x) ((ECL_IMMEDIATE(x)==0) && ((x)->d.t==t_exception)) + +struct ecl_exception { + _ECL_HDR1(ex_type); + /* Slots for storing contextual data. Depends on the exception type. */ + cl_object arg1; /* usually the offending object or the type. */ + cl_object arg2; /* usually additional arguments or the flag. */ + cl_object arg3; /* arbitrary lisp extra argument (i.e ECL_NIL). */ + void * arg4; /* arbitrary last ditch argument (usually NULL). */ +}; + struct ecl_weak_pointer { /* weak pointer to value */ _ECL_HDR; cl_object value; @@ -1161,6 +1198,7 @@ union cl_lispunion { struct ecl_cclosure cclosure; /* compiled closure */ struct ecl_dummy d; /* dummy */ struct ecl_instance instance; /* clos instance */ + struct ecl_exception exception; /* exception */ #ifdef ECL_THREADS struct ecl_process process; /* process */ struct ecl_lock lock; /* lock */ -- GitLab From 3e500d93a4b911409e8550aee0bb5af45421f2d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 15:02:28 +0200 Subject: [PATCH 34/58] exceptions: interpreter signals exceptions (not conditions) --- src/c/interpreter.d | 48 +++++++++++++++++---------------------------- 1 file changed, 18 insertions(+), 30 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 9d38f0a11..4fb1c591d 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -24,85 +24,73 @@ static void VEbad_lambda_too_many_args(cl_object bytecodes, cl_object frame) { - FEprogram_error("Too many arguments passed to " - "function ~A~&Argument list: ~S", - 2, bytecodes, cl_apply(2, @'list', frame)); + ecl_ferror(ECL_EX_VM_BADARG_EXCD, bytecodes, frame); } static void VEbad_lambda_unknown_keyword(cl_object bytecodes, cl_object frame) { - FEprogram_error("Unknown keyword argument passed to function ~S.~&" - "Argument list: ~S", 2, bytecodes, - cl_apply(2, @'list', frame)); + ecl_ferror(ECL_EX_VM_BADARG_UNKK, bytecodes, frame); } static void VEbad_lambda_odd_keys(cl_object bytecodes, cl_object frame) { - FEprogram_error("Function ~A called with odd number " - "of keyword arguments.", - 1, bytecodes); + ecl_ferror(ECL_EX_VM_BADARG_ODDK, bytecodes, frame); } static void VEwrong_arg_type_endp(cl_object reg0) { - FEwrong_type_only_arg(@[endp], reg0, @[list]); + ecl_ferror(ECL_EX_VM_BADARG_ENDP, ECL_NIL, reg0); } static void VEwrong_arg_type_car(cl_object reg0) { - FEwrong_type_only_arg(@[car], reg0, @[cons]); + ecl_ferror(ECL_EX_VM_BADARG_CAR, ECL_NIL, reg0); } static void VEwrong_arg_type_cdr(cl_object reg0) { - FEwrong_type_only_arg(@[cdr], reg0, @[cons]); + ecl_ferror(ECL_EX_VM_BADARG_CDR, ECL_NIL, reg0); } static void -VEwrong_arg_type_nth_val(cl_fixnum n) +VEwrong_arg_type_nth_val() { - FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); + ecl_ferror(ECL_EX_VM_BADARG_NTH_VAL, ECL_NIL, ECL_NIL); } static void VEassignment_to_constant(cl_object var) { - FEassignment_to_constant(var); + ecl_ferror(ECL_EX_V_CSETQ, var, ECL_NIL); } static void VEunbound_variable(cl_object var) { - FEunbound_variable(var); + ecl_ferror(ECL_EX_V_UNBND, var, ECL_NIL); } static void -VEwrong_num_arguments(cl_object fname) +VEwrong_num_arguments(cl_object fun) { - FEwrong_num_arguments(fname); + ecl_ferror(ECL_EX_F_NARGS, fun, ECL_NIL); } static void VEundefined_function(cl_object fun) { - FEundefined_function(fun); + ecl_ferror(ECL_EX_F_UNDEF, fun, ECL_NIL); } static void VEinvalid_function(cl_object fun) { - FEinvalid_function(fun); -} - -static void -VEclose_around_arg_type() -{ - FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0); + ecl_ferror(ECL_EX_F_INVAL, fun, ECL_NIL); } /* ------------------------------ LEXICAL ENV. ------------------------------ */ @@ -248,7 +236,7 @@ static cl_object close_around_self(cl_object fun) { cl_object v, template; if(ecl_t_of(fun) != t_bytecodes) - VEclose_around_arg_type(); + VEinvalid_function(fun); template = fun->bytecodes.flex; if(Null(template)) return fun; /* Make a closure */ @@ -286,7 +274,7 @@ close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object lex_env) { fun->bclosure.lex = new_lex; break; default: - VEclose_around_arg_type(); + VEinvalid_function(fun); } } @@ -296,7 +284,7 @@ ecl_close_around(cl_object fun, cl_object lcl_env, cl_object lex_env) { cl_object v, new_lex, template, entry; cl_fixnum nlex, idx, ndx; if(ecl_t_of(fun) != t_bytecodes) - VEclose_around_arg_type(); + VEinvalid_function(fun); template = fun->bytecodes.flex; if(Null(template)) return fun; /* Close around */ @@ -1238,7 +1226,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_NTHVAL); { cl_fixnum n = ecl_fixnum(ecl_vms_popu(the_env)); if (ecl_unlikely(n < 0)) { - VEwrong_arg_type_nth_val(n); + VEwrong_arg_type_nth_val(); } else if ((cl_index)n >= the_env->nvalues) { reg0 = ECL_NIL; } else if (n) { -- GitLab From ffbdf6f203fd23ff8a7e697193b82fc03a496581 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 16 Apr 2024 14:23:37 +0200 Subject: [PATCH 35/58] exceptions: runtime stack error signals exceptions (not conditions) Replace calls to CEstack_overflow with exceptions - this is a necessary step before moving stacks into nucleus. --- src/c/stacks.d | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/c/stacks.d b/src/c/stacks.d index 0c22031e4..d3a2c94eb 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -20,6 +20,7 @@ # include # include #endif +#include #include #include #include @@ -162,9 +163,9 @@ ecl_cs_overflow(void) else 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); + ecl_cerror(ECL_EX_CS_OVR, ecl_make_fixnum(size), ECL_T); else - CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_NIL); + ecl_ferror(ECL_EX_CS_OVR, ecl_make_fixnum(size), ECL_NIL); } /* -- ByteVM stack ----------------------------------------------------------- */ @@ -340,7 +341,7 @@ ecl_bds_overflow(void) ecl_internal_error(stack_overflow_msg); } env->bds_stack.limit += margin; - CEstack_overflow(@'ext::binding-stack', ecl_make_fixnum(size), ECL_T); + ecl_cerror(ECL_EX_BDS_OVR, ecl_make_fixnum(limit_size), ECL_T); return env->bds_stack.top; } @@ -619,7 +620,7 @@ frs_overflow(void) ecl_internal_error(stack_overflow_msg); } env->frs_stack.limit += margin; - CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(limit_size), ECL_T); + ecl_cerror(ECL_EX_FRS_OVR, ecl_make_fixnum(limit_size), ECL_T); } ecl_frame_ptr -- GitLab From 0fe1887cb928d8d8ad32d78e07940f76ba9425fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 12:45:42 +0200 Subject: [PATCH 36/58] exceptions: dispatch signals exceptions (not conditions) --- src/c/call.d | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/c/call.d b/src/c/call.d index de0f5c545..aac0c1cb7 100644 --- a/src/c/call.d +++ b/src/c/call.d @@ -14,7 +14,7 @@ ecl_function_dispatch(cl_env_ptr env, cl_object x) { cl_object fun = x; if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); + ecl_ferror(ECL_EX_F_UNDEF, fun, ECL_NIL); switch (ecl_t_of(fun)) { case t_cfunfixed: env->function = fun; @@ -39,7 +39,7 @@ ecl_function_dispatch(cl_env_ptr env, cl_object x) env->function = fun; return fun->bclosure.entry; default: - FEinvalid_function(x); + ecl_ferror(ECL_EX_F_INVAL, fun, ECL_NIL); } _ecl_unexpected_return(); } @@ -731,7 +731,7 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) x[50],x[51],x[52],x[53],x[54],x[55],x[56], x[57],x[58],x[59],x[60],x[61],x[62]); default: - FEprogram_error("Too many arguments", 0); + ecl_ferror(ECL_EX_F_NARGS, ecl_make_fixnum(n), ECL_NIL); } _ecl_unexpected_return(); } -- GitLab From 4f6296869784baba448a56528bb1dfce42141cc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 23 Apr 2024 08:04:21 +0200 Subject: [PATCH 37/58] exceptions: define *SIGNAL-HANDLERS* in cold_boot I've also renamed *HANDLER-CLUSTERS* to a more appropriate *SIGNAL-HANDLERS*. Currently this symbol is imported to the SYSTEM package, although this may be revised in the future to cater to multiple global environments. Alternatively the SYSTEM package may be common to all runtimes. --- src/c/alloc_2.d | 3 +++ src/c/boot.d | 11 +++++------ src/c/cinit.d | 2 +- src/c/jump.d | 4 ++-- src/c/main.d | 4 +++- src/c/symbols_list.h | 1 - src/c/threads/thread.d | 1 - src/clos/conditions.lsp | 6 +++--- src/h/ecl-inl.h | 8 ++++++++ src/h/external.h | 3 +++ src/h/nucleus.h | 2 +- src/h/object.h | 4 ++-- src/h/stacks.h | 2 +- 13 files changed, 32 insertions(+), 19 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 551fb8bc6..60e8d9e08 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1183,7 +1183,10 @@ stacks_scanner() GC_set_mark_bit((void *)dll); } } end_loop_for_on_unsafe(l); + /* ECL runtime */ GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1)); + GC_push_all((void *)ecl_vr_shandlers, (void *)(ecl_vr_shandlers + 1)); + /* Common Lisp */ GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); ecl_mark_env(ecl_core.first_env); diff --git a/src/c/boot.d b/src/c/boot.d index 878533331..9a24e6724 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -46,13 +46,12 @@ ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); /* These two tags have a special meaning for the frame stack. */ +ecl_def_constant(ecl_ct_protect_tag, ECL_NIL, "PROTECT-TAG", 11); +ecl_def_constant(ecl_ct_dummy_tag, ECL_NIL, "DUMMY-TAG", 9); -ecl_def_ct_base_string(ecl_ct_ptag_string,"PROTECT-TAG",11,static,const); -ecl_def_ct_base_string(ecl_ct_dtag_string,"DUMMY-TAG",9,static,const); - -ecl_def_ct_token(ecl_ct_protect_tag,ecl_stp_constant,ecl_ct_ptag_string,ECL_NIL,,const); -ecl_def_ct_token(ecl_ct_dummy_tag ,ecl_stp_constant,ecl_ct_dtag_string,ECL_NIL,,const); - +/* This variable is a stack with functions that are called for raised exceptions + and signaled conditions. */ +ecl_def_variable(ecl_vr_shandlers, ECL_NIL, "*SIGNAL-HANDLERS*", 17); /* -- implementation ------------------------------------------------ */ diff --git a/src/c/cinit.d b/src/c/cinit.d index 8f81d28d4..852d663b9 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -77,7 +77,7 @@ si_bind_simple_handlers(cl_object tag, cl_object names) if (ECL_FBOUNDP(@'si::bind-simple-handlers')) return _ecl_funcall3(@'si::bind-simple-handlers', tag, names); else - return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*'); + return ECL_SYM_VAL(ecl_process_env(), ECL_SIGNAL_HANDLERS); } extern cl_object diff --git a/src/c/jump.d b/src/c/jump.d index 67e68d90e..683f0084b 100644 --- a/src/c/jump.d +++ b/src/c/jump.d @@ -71,7 +71,7 @@ cl_object ecl_signal(cl_object condition, cl_object returns, cl_object thread) { const cl_env_ptr the_env = ecl_process_env(); cl_object symbol, cluster, handler; - symbol = ECL_HANDLER_CLUSTERS; + symbol = ECL_SIGNAL_HANDLERS; cluster = ECL_SYM_VAL(the_env, symbol); ecl_bds_bind(the_env, symbol, cluster); while(!Null(cluster)) { @@ -125,7 +125,7 @@ ecl_raise(ecl_ex_type type, bool returns, .arg1 = arg1, .arg2 = arg2, .arg3 = arg3, .arg4 = arg4 }; cl_object symbol, cluster, handler; cl_object exception = ecl_cast_ptr(cl_object,&ex); - symbol = ECL_HANDLER_CLUSTERS; + symbol = ECL_SIGNAL_HANDLERS; cluster = ECL_SYM_VAL(the_env, symbol); ecl_bds_bind(the_env, symbol, cluster); while(!Null(cluster)) { diff --git a/src/c/main.d b/src/c/main.d index 02b1451cf..bdaf5c7a6 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -445,7 +445,9 @@ cl_boot(int argc, char **argv) init_alloc(1); /* Initialize the handler stack with the exception handler. */ - ECL_SET(ECL_HANDLER_CLUSTERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); + cl_import2(ECL_SIGNAL_HANDLERS, cl_core.system_package); + cl_export2(ECL_SIGNAL_HANDLERS, cl_core.system_package); + ECL_SET(ECL_SIGNAL_HANDLERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); /* * Set *default-pathname-defaults* to a temporary fake value. We diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index ba3246b13..8736cddac 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -105,7 +105,6 @@ cl_symbols[] = { {"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)}, {SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, -{SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, {EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)}, {SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 907f09ff6..fc5817b85 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -365,7 +365,6 @@ ecl_import_current_thread(cl_object name, cl_object bindings) env_aux->interrupt_struct->signal_queue = ECL_NIL; ecl_set_process_env(env_aux); ecl_init_env(env_aux); - ECL_SET(ECL_HANDLER_CLUSTERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); /* Allocate real environment, link it together with process */ env = _ecl_alloc_env(0); diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 1e43abc87..45f93cf98 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -373,7 +373,7 @@ |# -(defvar *handler-clusters* nil) +(defvar *signal-handlers* nil) (defmacro handler-bind (bindings &body body) (with-gensyms (handler condition) @@ -384,7 +384,7 @@ (error "Ill-formed handler bindings.") collect `(,type (funcall ,func ,condition)))))) (declare (dynamic-extent (function ,handler))) - (let ((*handler-clusters* (cons (function ,handler) *handler-clusters*))) + (let ((*signal-handlers* (cons (function ,handler) *signal-handlers*))) ,@body)))) (defun bind-simple-handlers (tag names) @@ -393,7 +393,7 @@ for type in (if (atom names) (list names) names) when (typep condition type) do (throw tag (values code condition))))) - (cons #'simple-handler *handler-clusters*))) + (cons #'simple-handler *signal-handlers*))) (defun signal (datum &rest arguments) (let ((condition (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL))) diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index 5a1f06434..c1e1a34f9 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -111,6 +111,14 @@ #define ecl_cast_ptr(type,n) ((type)(n)) #endif +#define ecl_def_variable(name, value, chars, len) \ + ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \ + ecl_def_ct_token(name, ecl_stp_special, name ## _var_name, value,,) + +#define ecl_def_constant(name, value, chars, len) \ + ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \ + ecl_def_ct_token(name, ecl_stp_constant, name ## _var_name, value,,const) + #ifdef ECL_THREADS #define ecl_def_ct_token(name,stype,sname,value,static,const) \ static const struct ecl_symbol name ## _data = { \ diff --git a/src/h/external.h b/src/h/external.h index 1c1984c55..ef4460670 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -207,6 +207,9 @@ struct cl_core_struct { extern ECL_API struct ecl_core_struct ecl_core; extern ECL_API struct cl_core_struct cl_core; +/* variables */ +extern ECL_API cl_object ecl_vr_shandlers; + /* memory.c */ extern ECL_API void *ecl_malloc(cl_index n); extern ECL_API void *ecl_realloc(void *ptr, cl_index o, cl_index n); diff --git a/src/h/nucleus.h b/src/h/nucleus.h index eb992e007..9dc00a03f 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -43,7 +43,7 @@ cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); and we can allocate cons on the stack. */ #define ECL_WITH_HANDLER_BEGIN(the_env, handler) do { \ const cl_env_ptr __the_env = the_env; \ - cl_object __ecl_sym = ECL_HANDLER_CLUSTERS; \ + cl_object __ecl_sym = ECL_SIGNAL_HANDLERS; \ cl_object __ecl_hnd = ECL_SYM_VAL(__the_env, __ecl_sym); \ cl_object __ecl_hnds = ecl_cons_stack(handler, __ecl_hnd); \ ecl_bds_bind(__the_env, __ecl_sym, __ecl_hnds); diff --git a/src/h/object.h b/src/h/object.h index 462955885..04f6dd4c3 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -261,13 +261,13 @@ enum ecl_stype { /* symbol type */ #define ECL_NIL ((cl_object)t_list) #define ECL_PROTECT_TAG ecl_ct_protect_tag #define ECL_DUMMY_TAG ecl_ct_dummy_tag +#define ECL_SIGNAL_HANDLERS ecl_vr_shandlers #define ECL_NIL_SYMBOL ((cl_object)cl_symbols) #define ECL_T ((cl_object)(cl_symbols+1)) #define ECL_UNBOUND ((cl_object)(cl_symbols+2)) #define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+3)) -#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+4)) -#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+5)) +#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+4)) #define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) struct ecl_symbol { diff --git a/src/h/stacks.h b/src/h/stacks.h index 0ec24dc2a..8d76623a2 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -504,7 +504,7 @@ ecl_vms_unwind(cl_env_ptr env, cl_index ndx) #define ECL_HANDLER_CASE_BEGIN(the_env, names) do { \ const cl_env_ptr __the_env = (the_env); \ const cl_object __ecl_tag = ecl_list1(names); \ - ecl_bds_bind(__the_env, ECL_HANDLER_CLUSTERS, \ + ecl_bds_bind(__the_env, ECL_SIGNAL_HANDLERS, \ si_bind_simple_handlers(__ecl_tag, names)); \ ecl_frs_push(__the_env,__ecl_tag); \ if (__ecl_frs_push_result == 0) { -- GitLab From 91f4fa8ec1fa45dbf47c48f812def6b8f505bd7e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 20:53:56 +0200 Subject: [PATCH 38/58] nucleus: [1/n] move processing unit managament to nucleus --- src/c/alloc_2.d | 16 +-- src/c/boot.d | 2 +- src/c/main.d | 21 ++-- src/c/process.d | 114 +++++++++++++++++++++ src/c/threads/thread.d | 220 +++++++++-------------------------------- src/c/unixint.d | 81 ++++++--------- src/h/external.h | 6 +- src/h/nucleus.h | 9 +- src/h/object.h | 9 +- 9 files changed, 225 insertions(+), 253 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 60e8d9e08..06b65ad09 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1191,17 +1191,11 @@ stacks_scanner() GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); ecl_mark_env(ecl_core.first_env); #ifdef ECL_THREADS - l = ecl_core.processes; - if (l != OBJNULL) { - cl_index i, size; - for (i = 0, size = l->vector.dim; i < size; i++) { - cl_object process = l->vector.self.t[i]; - if (!Null(process)) { - cl_env_ptr env = process->process.env; - if (env && (env != ecl_core.first_env)) ecl_mark_env(env); - } - } - } + loop_across_stack_fifo(_env, ecl_core.threads) { + cl_env_ptr env = ecl_cast_ptr(cl_env_ptr, _env); + if(env != ecl_core.first_env) + ecl_mark_env(env); + } end_loop_across_stack(); #endif if (old_GC_push_other_roots) (*old_GC_push_other_roots)(); diff --git a/src/c/boot.d b/src/c/boot.d index 9a24e6724..b6de35437 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -140,7 +140,7 @@ struct ecl_core_struct ecl_core = { .first_env = &first_env, /* processes */ #ifdef ECL_THREADS - .processes = ECL_NIL, + .threads = ECL_NIL, .last_var_index = 0, .reused_indices = ECL_NIL, #endif diff --git a/src/c/main.d b/src/c/main.d index bdaf5c7a6..cd176248a 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -42,16 +42,6 @@ const char *ecl_self; static int ARGC; static char **ARGV; -static void -init_env_mp(cl_env_ptr env) -{ -#if defined(ECL_THREADS) - env->cleanup = 0; -#else - env->own_process = ECL_NIL; -#endif -} - static void init_env_int(cl_env_ptr env) { @@ -59,6 +49,9 @@ init_env_int(cl_env_ptr env) env->interrupt_struct->pending_interrupt = ECL_NIL; #ifdef ECL_THREADS ecl_mutex_init(&env->interrupt_struct->signal_queue_lock, FALSE); +#endif +#ifdef ECL_WINDOWS_THREADS + env->interrupt_struct->inside_interrupt = false; #endif { int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; @@ -111,7 +104,6 @@ ecl_init_first_env(cl_env_ptr env) void ecl_init_env(cl_env_ptr env) { - init_env_mp(env); init_env_int(env); init_env_aux(env); init_env_ffi(env); @@ -170,6 +162,13 @@ _ecl_alloc_env(cl_env_ptr parent) ecl_internal_error("Unable to allocate environment structure."); # endif #endif + /* Initialize the structure with NULL data. */ +#if defined(ECL_THREADS) + output->bds_stack.tl_bindings_size = 0; + output->bds_stack.tl_bindings = NULL; + output->cleanup = 0; +#endif + output->own_process = ECL_NIL; { size_t bytes = ecl_core.default_sigmask_bytes; if (bytes == 0) { diff --git a/src/c/process.d b/src/c/process.d index e74b2c6ce..5736a3451 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -36,11 +36,25 @@ #ifdef ECL_THREADS # ifdef ECL_WINDOWS_THREADS +# define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2)) +# define ecl_set_process_self(var) \ + { \ + HANDLE aux = GetCurrentThread(); \ + DuplicateHandle(GetCurrentProcess(), \ + aux, \ + GetCurrentProcess(), \ + &var, \ + 0, \ + FALSE, \ + DUPLICATE_SAME_ACCESS); \ + } # define ecl_process_key_t DWORD # define ecl_process_key_create(key) key = TlsAlloc() # define ecl_process_get_tls(key) TlsGetValue(key) # define ecl_process_set_tls(key,val) (TlsSetValue(key,val)!=0) # else +# define ecl_process_eq(t1, t2) (t1 == t2) +# define ecl_set_process_self(var) (var = pthread_self()) # define ecl_process_key_t static pthread_key_t # define ecl_process_key_create(key) pthread_key_create(&key, NULL) # define ecl_process_get_tls(key) pthread_getspecific(key) @@ -79,6 +93,105 @@ ecl_set_process_env(cl_env_ptr env) cl_env_ptr cl_env_p = NULL; #endif /* ECL_THREADS */ +/* -- Managing the collection of processes ---------------------------------- */ + +#ifdef ECL_THREADS + +static void +add_env(cl_env_ptr the_env) +{ + cl_object _env; + ecl_mutex_lock(&ecl_core.processes_lock); + _env = ecl_cast_ptr(cl_object,the_env); + ecl_stack_push(ecl_core.threads, _env); + ecl_mutex_unlock(&ecl_core.processes_lock); +} + +static void +del_env(cl_env_ptr the_env) +{ + cl_object _env; + ecl_mutex_lock(&ecl_core.processes_lock); + _env = ecl_cast_ptr(cl_object,the_env); + ecl_stack_del(ecl_core.threads, _env); + ecl_mutex_unlock(&ecl_core.processes_lock); +} + +/* Run a process in the current system thread. */ +cl_env_ptr +ecl_adopt_cpu() +{ + struct cl_env_struct env_aux[1]; + cl_env_ptr the_env = ecl_process_env_unsafe(); + ecl_thread_t current; + int registered; + if (the_env != NULL) + return the_env; + /* 1. Ensure that the thread is known to the GC. */ + /* FIXME this should be executed with hooks. */ +#ifdef GBC_BOEHM + { + struct GC_stack_base stack; + GC_get_stack_base(&stack); + switch (GC_register_my_thread(&stack)) { + case GC_SUCCESS: + registered = 1; + break; + case GC_DUPLICATE: + /* Thread was probably created using the GC hooks for thread creation. */ + registered = 0; + break; + default: + ecl_internal_error("gc returned an impossible answer."); + } + } +#endif + ecl_set_process_self(current); + /* We need a fake env to allow for interrupts blocking and to set up frame + * stacks or other stuff that is needed by ecl_init_env. Since the fake env is + * allocated on the stack, we can safely store pointers to memory allocated by + * the gc there. */ + memset(env_aux, 0, sizeof(*env_aux)); + env_aux->disable_interrupts = 1; + env_aux->interrupt_struct = ecl_alloc_unprotected(sizeof(*env_aux->interrupt_struct)); + env_aux->interrupt_struct->pending_interrupt = ECL_NIL; + ecl_mutex_init(&env_aux->interrupt_struct->signal_queue_lock, FALSE); + env_aux->interrupt_struct->signal_queue = ECL_NIL; + ecl_set_process_env(env_aux); + env_aux->thread = current; + env_aux->cleanup = registered; + ecl_init_env(env_aux); + + /* Allocate, initialize and switch to the real environment. */ + the_env = _ecl_alloc_env(0); + memcpy(the_env, env_aux, sizeof(*the_env)); + ecl_set_process_env(the_env); + add_env(the_env); + + return the_env; +} + +/* Run a process in a new system thread. */ +cl_env_ptr +ecl_spawn_cpu() +{ + return NULL; +} + + +void +ecl_add_process(cl_object process) +{ + add_env(process->process.env); +} + +void +ecl_del_process(cl_object process) +{ + del_env(process->process.env); +} +#endif + /* -- Initialiation --------------------------------------------------------- */ void @@ -91,6 +204,7 @@ init_process(void) ecl_mutex_init(&ecl_core.global_lock, 1); ecl_mutex_init(&ecl_core.error_lock, 1); ecl_rwlock_init(&ecl_core.global_env_lock); + ecl_core.threads = ecl_make_stack(16); #endif ecl_set_process_env(env); env->default_sigmask = NULL; diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index fc5817b85..2f6609246 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -53,81 +53,17 @@ /* -- Core ---------------------------------------------------------- */ -static void -extend_process_vector() -{ - cl_object v = ecl_core.processes; - cl_index new_size = v->vector.dim + v->vector.dim/2; - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { - cl_object other = ecl_core.processes; - if (new_size > other->vector.dim) { - cl_object new = si_make_vector(ECL_T, - ecl_make_fixnum(new_size), - ecl_make_fixnum(other->vector.fillp), - ECL_NIL, ECL_NIL, ECL_NIL); - ecl_copy_subarray(new, 0, other, 0, other->vector.dim); - ecl_core.processes = new; - } - } ECL_WITH_NATIVE_LOCK_END; -} - -static void -ecl_list_process(cl_object process) -{ - cl_env_ptr the_env = ecl_process_env(); - bool ok = 0; - do { - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { - cl_object vector = ecl_core.processes; - cl_index size = vector->vector.dim; - cl_index ndx = vector->vector.fillp; - if (ndx < size) { - vector->vector.self.t[ndx++] = process; - vector->vector.fillp = ndx; - ok = 1; - } - } ECL_WITH_NATIVE_LOCK_END; - if (ok) break; - extend_process_vector(); - } while (1); -} - -/* Must be called with disabled interrupts to prevent race conditions - * in thread_cleanup */ -static void -ecl_unlist_process(cl_object process) -{ - ecl_mutex_lock(&ecl_core.processes_lock); - cl_object vector = ecl_core.processes; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - if (vector->vector.self.t[i] == process) { - vector->vector.fillp--; - do { - vector->vector.self.t[i] = - vector->vector.self.t[i+1]; - } while (++i < vector->vector.fillp); - break; - } - } - ecl_mutex_unlock(&ecl_core.processes_lock); -} - static cl_object ecl_process_list() { cl_env_ptr the_env = ecl_process_env(); cl_object output = ECL_NIL; ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { - cl_object vector = ecl_core.processes; - cl_object *data = vector->vector.self.t; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - cl_object p = data[i]; - if (p != ECL_NIL) - output = ecl_cons(p, output); - } + loop_across_stack_fifo(_env, ecl_core.threads) { + cl_env_ptr env = ecl_cast_ptr(cl_env_ptr, _env); + cl_object p = env->own_process; + output = ecl_cons(p, output); + } end_loop_across_stack(); } ECL_WITH_NATIVE_LOCK_END; return output; } @@ -183,10 +119,10 @@ thread_cleanup(void *aux) pthread_sigmask(SIG_BLOCK, new, NULL); } #endif + ecl_del_process(process); process->process.env = NULL; - ecl_unlist_process(process); #ifdef ECL_WINDOWS_THREADS - CloseHandle(process->process.thread); + CloseHandle(env->thread); #endif ecl_set_process_env(NULL); if (env) _ecl_dealloc_env(env); @@ -238,21 +174,12 @@ thread_entry_point(void *arg) #endif process->process.phase = ECL_PROCESS_ACTIVE; ecl_mutex_unlock(&process->process.start_stop_lock); - ecl_enable_interrupts_env(env); si_trap_fpe(@'last', ECL_T); + ecl_enable_interrupts_env(env); ecl_bds_bind(env, @'mp::*current-process*', process); ECL_RESTART_CASE_BEGIN(env, @'abort') { - env->values[0] = cl_apply(2, process->process.function, - process->process.args); - { - cl_object output = ECL_NIL; - int i = env->nvalues; - while (i--) { - output = CONS(env->values[i], output); - } - process->process.exit_values = output; - } + process->process.entry(0); } ECL_RESTART_CASE(1,args) { /* ABORT restart. */ process->process.exit_values = args; @@ -295,22 +222,36 @@ init_tl_bindings(cl_object process, cl_env_ptr env) env->bds_stack.tl_bindings = bindings; } +static cl_object +run_process(cl_narg narg, ...) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_object process = the_env->own_process; + cl_object fun = process->process.function; + cl_object args = process->process.args; + cl_object output = ECL_NIL; + the_env->values[0] = cl_apply(2, fun, args); + int i = the_env->nvalues; + while (i--) { + output = CONS(the_env->values[i], output); + } + process->process.exit_values = output; + return the_env->values[0]; +} + 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; + cl_object process = ecl_alloc_object(t_process); process->process.phase = ECL_PROCESS_INACTIVE; + process->process.exit_values = ECL_NIL; + process->process.entry = run_process; 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; process->process.woken_up = ECL_NIL; + process->process.inherit_bindings_p = Null(initial_bindings_p)? ECL_T : ECL_NIL; ecl_disable_interrupts_env(env); ecl_mutex_init(&process->process.start_stop_lock, TRUE); ecl_cond_var_init(&process->process.exit_barrier); @@ -322,71 +263,23 @@ alloc_process(cl_object name, cl_object initial_bindings_p) bool ecl_import_current_thread(cl_object name, cl_object bindings) { - struct cl_env_struct env_aux[1]; cl_object process; - ecl_thread_t current; - cl_env_ptr env; - int registered; - struct GC_stack_base stack; - ecl_set_process_self(current); -#ifdef GBC_BOEHM - GC_get_stack_base(&stack); - switch (GC_register_my_thread(&stack)) { - case GC_SUCCESS: - registered = 1; - break; - case GC_DUPLICATE: - /* Thread was probably created using the GC hooks for thread creation. */ - registered = 0; - break; - default: + cl_env_ptr the_env; + if (ecl_process_env_unsafe() != NULL) return 0; - } -#endif - { - cl_object processes = ecl_core.processes; - cl_index i, size; - for (i = 0, size = processes->vector.fillp; i < size; i++) { - cl_object p = processes->vector.self.t[i]; - if (!Null(p) && ecl_process_eq(p->process.thread, current)) { - return 0; - } - } - } - /* We need a fake env to allow for interrupts blocking and to set up - * frame stacks or other stuff which may be needed by alloc_process - * and ecl_list_process. Since the fake env is allocated on the stack, - * we can safely store pointers to memory allocated by the gc there. */ - memset(env_aux, 0, sizeof(*env_aux)); - env_aux->disable_interrupts = 1; - env_aux->interrupt_struct = ecl_alloc_unprotected(sizeof(*env_aux->interrupt_struct)); - env_aux->interrupt_struct->pending_interrupt = ECL_NIL; - ecl_mutex_init(&env_aux->interrupt_struct->signal_queue_lock, FALSE); - env_aux->interrupt_struct->signal_queue = ECL_NIL; - ecl_set_process_env(env_aux); - ecl_init_env(env_aux); - - /* Allocate real environment, link it together with process */ - env = _ecl_alloc_env(0); + the_env = ecl_adopt_cpu(); + ecl_enable_interrupts_env(the_env); + process = alloc_process(name, ECL_NIL); - process->process.env = env; + process->process.env = the_env; process->process.phase = ECL_PROCESS_BOOTING; - process->process.thread = current; - /* Copy initial bindings from process to the fake environment */ - env_aux->cleanup = registered; - init_tl_bindings(process, env_aux); - - /* Switch over to the real environment */ - memcpy(env, env_aux, sizeof(*env)); - env->own_process = process; - ecl_set_process_env(env); - ecl_list_process(process); - ecl_enable_interrupts_env(env); + init_tl_bindings(process, the_env); + the_env->own_process = process; process->process.phase = ECL_PROCESS_ACTIVE; - ecl_bds_bind(env, @'mp::*current-process*', process); + ecl_bds_bind(the_env, @'mp::*current-process*', process); return 1; } @@ -512,10 +405,6 @@ mp_process_enable(cl_object process) ok = 0; process->process.phase = ECL_PROCESS_BOOTING; - process->process.parent = mp_current_process(); - process->process.trap_fpe_bits = - process->process.parent->process.env->trap_fpe_bits; - /* Link environment and process together */ process_env = _ecl_alloc_env(the_env); process_env->own_process = process; @@ -523,13 +412,13 @@ mp_process_enable(cl_object process) /* Immediately list the process such that its environment is * marked by the gc when its contents are allocated */ - ecl_list_process(process); + ecl_add_process(process); /* Now we can safely allocate memory for the environment contents * and store pointers to it in the environment */ ecl_init_env(process_env); - process_env->trap_fpe_bits = process->process.trap_fpe_bits; + process_env->trap_fpe_bits = the_env->trap_fpe_bits; init_tl_bindings(process, process_env); ecl_disable_interrupts_env(the_env); @@ -539,7 +428,7 @@ mp_process_enable(cl_object process) DWORD threadId; code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); - ok = (process->process.thread = code) != NULL; + ok = (process_env->thread = code) != NULL; } #else { @@ -560,12 +449,12 @@ mp_process_enable(cl_object process) sigdelset(&new, SIGSEGV); sigdelset(&new, SIGBUS); pthread_sigmask(SIG_BLOCK, &new, &previous); - code = pthread_create(&process->process.thread, &pthreadattr, + code = pthread_create(&process_env->thread, &pthreadattr, thread_entry_point, process); pthread_sigmask(SIG_SETMASK, &previous, NULL); } #else - code = pthread_create(&process->process.thread, &pthreadattr, + code = pthread_create(&process_env->thread, &pthreadattr, thread_entry_point, process); #endif ok = (code == 0); @@ -576,7 +465,7 @@ mp_process_enable(cl_object process) if (!ok) { /* INV: interrupts are already disabled through thread safe * unwind-protect */ - ecl_unlist_process(process); + ecl_del_process(process); process->process.phase = ECL_PROCESS_INACTIVE; /* Alert possible waiting processes. */ ecl_cond_var_broadcast(&process->process.exit_barrier); @@ -668,8 +557,7 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) ecl_va_start(args, function, narg, 2); rest = cl_grab_rest_args(args); ecl_va_end(args); - cl_apply(4, @'mp::process-preset', process, function, - rest); + cl_apply(4, @'mp::process-preset', process, function, rest); return mp_process_enable(process); } @@ -758,7 +646,7 @@ void init_threads() { cl_env_ptr the_env = ecl_process_env(); - cl_object process; + cl_object process, _env = ecl_cast_ptr(cl_object,the_env); ecl_thread_t main_thread; /* We have to set the environment before any allocation takes place, * so that the interrupt handling code works. */ @@ -769,20 +657,10 @@ init_threads() process->process.name = @'si::top-level'; process->process.function = ECL_NIL; process->process.args = ECL_NIL; - process->process.thread = main_thread; process->process.env = the_env; - process->process.woken_up = ECL_NIL; ecl_mutex_init(&process->process.start_stop_lock, TRUE); ecl_cond_var_init(&process->process.exit_barrier); - + the_env->thread = main_thread; the_env->own_process = process; - { - cl_object v = si_make_vector(ECL_T, /* Element type */ - ecl_make_fixnum(256), /* Size */ - ecl_make_fixnum(0), /* fill pointer */ - ECL_NIL, ECL_NIL, ECL_NIL); - v->vector.self.t[0] = process; - v->vector.fillp = 1; - ecl_core.processes = v; - } + ecl_stack_push(ecl_core.threads, _env); } diff --git a/src/c/unixint.d b/src/c/unixint.d index f4c6e90d8..dc385e30b 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -265,8 +265,8 @@ static void early_signal_error() ecl_attr_noreturn; static void early_signal_error() { - ecl_internal_error("Got signal before environment was installed" - " on our thread"); + ecl_internal_error + ("Got signal before environment was installed on our thread"); } static void illegal_signal_code(cl_object code) ecl_attr_noreturn; @@ -869,7 +869,7 @@ cl_object si_check_pending_interrupts(void) { const cl_env_ptr the_env = ecl_process_env(); - handle_all_queued(ecl_process_env()); + handle_all_queued(the_env); ecl_return0(the_env); } @@ -950,8 +950,7 @@ do_catch_signal(int code, cl_object action, cl_object process) } return ECL_T; } else { - FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1, - action); + FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1, action); } } @@ -992,19 +991,16 @@ si_set_signal_handler(cl_object code, cl_object handler) # ifdef SIGSEGV unlikely_if ((code == ecl_make_fixnum(SIGSEGV)) && ecl_option_values[ECL_OPT_INCREMENTAL_GC]) - FEerror("It is not allowed to change the behavior of SIGSEGV.", - 0); + FEerror("It is not allowed to change the behavior of SIGSEGV.", 0); # endif # ifdef SIGBUS unlikely_if (code_int == SIGBUS) - FEerror("It is not allowed to change the behavior of SIGBUS.", - 0); + FEerror("It is not allowed to change the behavior of SIGBUS.", 0); # endif #endif #if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST) unlikely_if (code_int == ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]) { - FEerror("It is not allowed to change the behavior of signal ~D", 1, - code); + FEerror("It is not allowed to change the behavior of signal ~D", 1, code); } #endif #ifdef SIGFPE @@ -1036,40 +1032,34 @@ wakeup_noop(ULONG_PTR foo) static bool do_interrupt_thread(cl_object process) { + cl_env_ptr process_env = process->process.env; # ifdef ECL_WINDOWS_THREADS # ifndef ECL_USE_GUARD_PAGE # error "Cannot implement ecl_interrupt_process without guard pages" # endif - HANDLE thread = process->process.thread; + HANDLE thread = process_env->thread; CONTEXT context; - void *trap_address = process->process.env; + void *trap_address = ecl_cast_ptr(void*, process_env);; DWORD guard = PAGE_GUARD | PAGE_READWRITE; int ok = 1; if (SuspendThread(thread) == (DWORD)-1) { - FEwin32_error("Unable to suspend thread ~A", 1, - process); + FEwin32_error("Unable to suspend thread ~A", 1, process); ok = 0; goto EXIT; } - process->process.interrupt = ECL_T; - if (!VirtualProtect(process->process.env, - sizeof(struct cl_env_struct), - guard, - &guard)) + process_env->interrupt_struct->inside_interrupt = true; + if (!VirtualProtect(process_env, sizeof(struct cl_env_struct), guard, &guard)) { - FEwin32_error("Unable to protect memory from thread ~A", - 1, process); + FEwin32_error("Unable to protect memory from thread ~A", 1, process); ok = 0; } RESUME: if (!QueueUserAPC(wakeup_function, thread, 0)) { - FEwin32_error("Unable to queue APC call to thread ~A", - 1, process); + FEwin32_error("Unable to queue APC call to thread ~A", 1, process); ok = 0; } if (ResumeThread(thread) == (DWORD)-1) { - FEwin32_error("Unable to resume thread ~A", 1, - process); + FEwin32_error("Unable to resume thread ~A", 1, process); ok = 0; goto EXIT; } @@ -1077,9 +1067,8 @@ do_interrupt_thread(cl_object process) return ok; # else int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - if (pthread_kill(process->process.thread, signal)) { - FElibc_error("Unable to interrupt process ~A", 1, - process); + if (pthread_kill(process_env->thread, signal)) { + FElibc_error("Unable to interrupt process ~A", 1, process); } return 1; # endif @@ -1120,10 +1109,10 @@ void ecl_wakeup_process(cl_object process) { # ifdef ECL_WINDOWS_THREADS - HANDLE thread = process->process.thread; + cl_env_ptr process_env = process->process.env; + HANDLE thread = process_env->thread; if (!QueueUserAPC(wakeup_noop, thread, 0)) { - FEwin32_error("Unable to queue APC call to thread ~A", - 1, process); + FEwin32_error("Unable to queue APC call to thread ~A", 1, process); } # else do_interrupt_thread(process); @@ -1145,9 +1134,8 @@ _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep) { /* Access to guard page */ case STATUS_GUARD_PAGE_VIOLATION: { - cl_object process = the_env->own_process; - if (!Null(process->process.interrupt)) { - process->process.interrupt = ECL_NIL; + if(the_env->interrupt_struct->inside_interrupt) { + the_env->interrupt_struct->inside_interrupt = false; handle_all_queued_interrupt_safe(the_env); } return EXCEPTION_CONTINUE_EXECUTION; @@ -1207,8 +1195,7 @@ static cl_object W32_handle_in_new_thread(cl_object signal_code) { int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL); - mp_process_run_function(3, @'si::handle-signal', - @'si::handle-signal', + mp_process_run_function(3, @'si::handle-signal', @'si::handle-signal', signal_code); if (outside_ecl) ecl_release_current_thread(); } @@ -1356,19 +1343,13 @@ install_signal_handling_thread() ecl_process_env()->default_sigmask = &main_thread_sigmask; if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) { cl_object fun = - ecl_make_cfun((cl_objectfn_fixed) - asynchronous_signal_servicing_thread, - @'si::signal-servicing', - ECL_NIL, - 0); + ecl_make_cfun((cl_objectfn_fixed) asynchronous_signal_servicing_thread, + @'si::signal-servicing', ECL_NIL, 0); cl_object process = signal_thread_process = - mp_process_run_function_wait(2, - @'si::signal-servicing', - fun); + mp_process_run_function_wait(2, @'si::signal-servicing', fun); if (Null(process)) { - ecl_internal_error("Unable to create signal " - "servicing thread"); + ecl_internal_error("Unable to create signal servicing thread."); } } #endif @@ -1416,8 +1397,7 @@ install_synchronous_signal_handlers() int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; if (signal == 0) { signal = DEFAULT_THREAD_INTERRUPT_SIGNAL; - ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, - signal); + ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, signal); } mysignal(signal, process_interrupt_handler); #ifdef HAVE_SIGPROCMASK @@ -1479,8 +1459,7 @@ create_signal_code_constants() int i; for (i = 0; known_signals[i].code >= 0; i++) { add_one_signal(hash, known_signals[i].code, - _ecl_intern(known_signals[i].name, - cl_core.ext_package), + _ecl_intern(known_signals[i].name, cl_core.ext_package), known_signals[i].handler); } #ifdef SIGRTMIN diff --git a/src/h/external.h b/src/h/external.h index ef4460670..c62ddbd34 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -99,7 +99,8 @@ struct cl_env_struct { /* -- System Processes (native threads) ------------------------------ */ #ifdef ECL_THREADS - cl_object own_process; /* Backpointer to the host process. */ + cl_object own_process; /* Backpointer to the running process. */ + ecl_thread_t thread; int cleanup; #endif @@ -151,6 +152,9 @@ struct ecl_interrupt_struct { #ifdef ECL_THREADS ecl_mutex_t signal_queue_lock; #endif +#ifdef ECL_WINDOWS_THREADS + bool inside_interrupt; +#endif }; #ifndef __GNUC__ diff --git a/src/h/nucleus.h b/src/h/nucleus.h index 9dc00a03f..08f553651 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -9,7 +9,7 @@ struct ecl_core_struct { cl_env_ptr first_env; #ifdef ECL_THREADS - cl_object processes; + cl_object threads; ecl_mutex_t processes_lock; ecl_mutex_t global_lock; ecl_mutex_t error_lock; @@ -33,6 +33,13 @@ struct ecl_core_struct { cl_object library_pathname; }; +/* process.c */ +cl_env_ptr ecl_adopt_cpu(); +cl_env_ptr ecl_spawn_cpu(); + +void ecl_add_process(cl_object process); +void ecl_del_process(cl_object process); + /* control.c */ cl_object ecl_escape(cl_object continuation) ecl_attr_noreturn; cl_object ecl_signal(cl_object condition, cl_object returns, cl_object thread); diff --git a/src/h/object.h b/src/h/object.h index 04f6dd4c3..6ba83a8b9 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -1023,19 +1023,16 @@ enum { struct ecl_process { _ECL_HDR; cl_object name; + cl_object exit_values; + cl_objectfn entry; /* entry address (matches ecl_cfun offset) */ cl_object function; cl_object args; - struct cl_env_struct *env; - cl_object interrupt; cl_object inherit_bindings_p; - cl_object parent; - cl_object exit_values; cl_object woken_up; ecl_mutex_t start_stop_lock; /* phase is updated only when we hold this lock */ ecl_cond_var_t exit_barrier; /* process-join waits on this barrier */ cl_index phase; - ecl_thread_t thread; - int trap_fpe_bits; + struct cl_env_struct *env; }; enum { -- GitLab From 4ea1528b34592fc1971fa970722f92e12f30ce05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 2 May 2024 15:25:26 +0200 Subject: [PATCH 39/58] nucleus: [2/n] move processing unit managament to nucleus --- src/c/process.d | 186 ++++++++++++++++++++--- src/c/threads/thread.d | 336 +++++++++++------------------------------ src/h/nucleus.h | 4 +- 3 files changed, 251 insertions(+), 275 deletions(-) diff --git a/src/c/process.d b/src/c/process.d index 5736a3451..fc26b971b 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -93,6 +93,32 @@ ecl_set_process_env(cl_env_ptr env) cl_env_ptr cl_env_p = NULL; #endif /* ECL_THREADS */ +/* -- Thread local bindings */ +static void +init_tl_bindings(cl_object process, cl_env_ptr env) +{ +#ifdef ECL_THREADS + cl_index bindings_size; + cl_object *bindings; + if (Null(process) || 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; +#endif +} + + /* -- Managing the collection of processes ---------------------------------- */ #ifdef ECL_THREADS @@ -122,12 +148,13 @@ cl_env_ptr ecl_adopt_cpu() { struct cl_env_struct env_aux[1]; + struct ecl_interrupt_struct int_aux[1]; cl_env_ptr the_env = ecl_process_env_unsafe(); ecl_thread_t current; int registered; if (the_env != NULL) return the_env; - /* 1. Ensure that the thread is known to the GC. */ + /* Ensure that the thread is known to the GC. */ /* FIXME this should be executed with hooks. */ #ifdef GBC_BOEHM { @@ -153,7 +180,7 @@ ecl_adopt_cpu() * the gc there. */ memset(env_aux, 0, sizeof(*env_aux)); env_aux->disable_interrupts = 1; - env_aux->interrupt_struct = ecl_alloc_unprotected(sizeof(*env_aux->interrupt_struct)); + env_aux->interrupt_struct = int_aux; env_aux->interrupt_struct->pending_interrupt = ECL_NIL; ecl_mutex_init(&env_aux->interrupt_struct->signal_queue_lock, FALSE); env_aux->interrupt_struct->signal_queue = ECL_NIL; @@ -167,28 +194,144 @@ ecl_adopt_cpu() memcpy(the_env, env_aux, sizeof(*the_env)); ecl_set_process_env(the_env); add_env(the_env); + init_tl_bindings(ECL_NIL, the_env); return the_env; } -/* Run a process in a new system thread. */ -cl_env_ptr -ecl_spawn_cpu() +void +ecl_disown_cpu() { - return NULL; + int registered; + cl_env_ptr the_env = ecl_process_env_unsafe(); + if (the_env == NULL) + return; + registered = the_env->cleanup; + ecl_disable_interrupts_env(the_env); + /* FIXME this should be part of dealloc. */ + ecl_clear_bignum_registers(the_env); +#ifdef ECL_WINDOWS_THREADS + CloseHandle(the_env->thread); +#endif + ecl_set_process_env(NULL); + del_env(the_env); + _ecl_dealloc_env(the_env); + /* FIXME thsi should be executed with hooks. */ + if (registered) { + GC_unregister_my_thread(); + } } - -void -ecl_add_process(cl_object process) +#ifdef ECL_WINDOWS_THREADS +static DWORD WINAPI +#else +static void * +#endif +thread_entry_point(void *ptr) { - add_env(process->process.env); + cl_env_ptr the_env = ecl_cast_ptr(cl_env_ptr, ptr); + cl_object process = the_env->own_process; + /* Setup the environment for the execution of the thread. */ + ecl_set_process_env(the_env); + ecl_cs_init(the_env); + + process->process.entry(0); + + /* This routine performs some cleanup before a thread is completely + * killed. For instance, it has to remove the associated process object from + * the list, an it has to dealloc some memory. + * + * NOTE: this cleanup does not provide enough "protection". In order to ensure + * that all UNWIND-PROTECT forms are properly executed, never use the function + * pthread_cancel() to kill a process, but rather use the lisp functions + * mp_interrupt_process() and mp_process_kill(). */ + + ecl_set_process_env(NULL); + the_env->own_process = ECL_NIL; + del_env(the_env); +#ifdef ECL_WINDOWS_THREADS + CloseHandle(the_env->thread); +#endif + _ecl_dealloc_env(the_env); + +#ifdef ECL_WINDOWS_THREADS + return 1; +#else + return NULL; +#endif } -void -ecl_del_process(cl_object process) +/* Run a process in a new system thread. */ +cl_env_ptr +ecl_spawn_cpu(cl_object process) { - del_env(process->process.env); + cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr new_env = NULL; + int ok = 1; + /* Allocate and initialize the new cpu env. */ + { + new_env = _ecl_alloc_env(the_env); + /* List the process such that its environment is marked by the GC when its + contents are allocated. */ + add_env(new_env); + /* Now we can safely allocate memory for the environment ocntents and store + pointers to it in the environment. */ + ecl_init_env(new_env); + /* Copy the parent env defaults. */ + new_env->trap_fpe_bits = the_env->trap_fpe_bits; + new_env->own_process = process; + init_tl_bindings(process, new_env); + process->process.env = new_env; + } + /* Spawn the thread */ + ecl_disable_interrupts_env(the_env); +#ifdef ECL_WINDOWS_THREADS + { + HANDLE code; + DWORD threadId; + + code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, new_env, 0, &threadId); + new_env->thread = code; + ok = code != NULL; + } +#else /* ECL_WINDOWS_THREADS */ + { + int code; + pthread_attr_t pthreadattr; + + pthread_attr_init(&pthreadattr); + pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); + /* + * Block all asynchronous signals until the thread is completely + * set up. The synchronous signals SIGSEGV and SIGBUS are needed + * by the gc and thus can't be blocked. + */ +# ifdef HAVE_SIGPROCMASK + { + sigset_t new, previous; + sigfillset(&new); + sigdelset(&new, SIGSEGV); + sigdelset(&new, SIGBUS); + pthread_sigmask(SIG_BLOCK, &new, &previous); + code = pthread_create(&new_env->thread, &pthreadattr, + thread_entry_point, new_env); + pthread_sigmask(SIG_SETMASK, &previous, NULL); + } +# else + code = pthread_create(&new_env->thread, &pthreadattr, + thread_entry_point, new_env); +# endif + ok = (code == 0); + } +#endif /* ECL_WINDOWS_THREADS */ + /* Deal with the fallout of the thread creation. */ + if (!ok) { + del_env(new_env); + process->process.env = NULL; + _ecl_dealloc_env(new_env); + } + ecl_enable_interrupts_env(the_env); + return ok ? new_env : NULL; } #endif @@ -197,8 +340,11 @@ ecl_del_process(cl_object process) void init_process(void) { - cl_env_ptr env = ecl_core.first_env; + cl_env_ptr the_env = ecl_core.first_env; #ifdef ECL_THREADS + ecl_thread_t main_thread; + ecl_set_process_self(main_thread); + the_env->thread = main_thread; ecl_process_key_create(cl_env_key); ecl_mutex_init(&ecl_core.processes_lock, 1); ecl_mutex_init(&ecl_core.global_lock, 1); @@ -206,10 +352,10 @@ init_process(void) ecl_rwlock_init(&ecl_core.global_env_lock); ecl_core.threads = ecl_make_stack(16); #endif - ecl_set_process_env(env); - env->default_sigmask = NULL; - env->method_cache = NULL; - env->slot_cache = NULL; - env->interrupt_struct = NULL; - env->disable_interrupts = 1; + ecl_set_process_env(the_env); + the_env->default_sigmask = NULL; + the_env->method_cache = NULL; + the_env->slot_cache = NULL; + the_env->interrupt_struct = NULL; + the_env->disable_interrupts = 1; } diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 2f6609246..40942832a 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -31,26 +31,6 @@ # include #endif -/* -- Macros ---------------------------------------------------------------- */ - -#ifdef ECL_WINDOWS_THREADS -# define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2)) -# define ecl_set_process_self(var) \ - { \ - HANDLE aux = GetCurrentThread(); \ - DuplicateHandle(GetCurrentProcess(), \ - aux, \ - GetCurrentProcess(), \ - &var, \ - 0, \ - FALSE, \ - DUPLICATE_SAME_ACCESS); \ - } -#else -# define ecl_process_eq(t1, t2) (t1 == t2) -# define ecl_set_process_self(var) (var = pthread_self()) -#endif /* ECL_WINDOWS_THREADS */ - /* -- Core ---------------------------------------------------------- */ static cl_object @@ -87,155 +67,74 @@ assert_type_process(cl_object o) FEwrong_type_argument(@[mp::process], o); } -static void -thread_cleanup(void *aux) -{ - /* This routine performs some cleanup before a thread is completely - * killed. For instance, it has to remove the associated process - * object from the list, an it has to dealloc some memory. - * - * NOTE: thread_cleanup() does not provide enough "protection". In - * order to ensure that all UNWIND-PROTECT forms are properly - * executed, never use pthread_cancel() to kill a process, but - * rather use the lisp functions mp_interrupt_process() and - * mp_process_kill(). - */ - cl_object process = (cl_object)aux; - cl_env_ptr env = process->process.env; - - /* The following flags will disable all interrupts. */ - if (env) { - ecl_disable_interrupts_env(env); - ecl_clear_bignum_registers(env); - } - ecl_mutex_lock(&process->process.start_stop_lock); - process->process.phase = ECL_PROCESS_EXITING; -#ifdef HAVE_SIGPROCMASK - /* ...but we might get stray signals. */ - { - sigset_t new[1]; - sigemptyset(new); - sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); - pthread_sigmask(SIG_BLOCK, new, NULL); - } -#endif - ecl_del_process(process); - process->process.env = NULL; -#ifdef ECL_WINDOWS_THREADS - CloseHandle(env->thread); -#endif - ecl_set_process_env(NULL); - if (env) _ecl_dealloc_env(env); - - process->process.phase = ECL_PROCESS_INACTIVE; - ecl_cond_var_broadcast(&process->process.exit_barrier); - ecl_mutex_unlock(&process->process.start_stop_lock); -} - -#ifdef ECL_WINDOWS_THREADS -static DWORD WINAPI -#else -static void * -#endif -thread_entry_point(void *arg) +static cl_object +run_process(cl_narg narg, ...) { - cl_object process = (cl_object)arg; - cl_env_ptr env = process->process.env; - - /* - * Upon entering this routine - * process.env = our environment for lisp - * process.phase = ECL_PROCESS_BOOTING - * signals are disabled in the environment - * the communication interrupt is disabled (sigmasked) + /* Upon entering this routine the process environment is set up, the process + * phase is ECL_PROCESS_BOOTING, signals are disabled in the environment and + * the communication interrupt is disabled (sigmasked). * - * This process will not receive signals that originate from - * other processes. Furthermore, we expect not to get any - * other interrupts (SIGSEGV, SIGFPE) if we do things right. + * This process will not receive signals that originate from other processes. + * Furthermore, we expect not to get any other interrupts (SIGSEGV, SIGFPE) if + * we do things right. */ - /* 1) Setup the environment for the execution of the thread */ - ecl_set_process_env(env = process->process.env); -#ifndef ECL_WINDOWS_THREADS - pthread_cleanup_push(thread_cleanup, (void *)process); -#endif - ecl_cs_init(env); + cl_env_ptr the_env = ecl_process_env(); + cl_object process = the_env->own_process; + cl_object fun = process->process.function; + cl_object args = process->process.args; + cl_object output = ECL_NIL; + /* Entry barrier. enable_process releases this lock before exit. */ ecl_mutex_lock(&process->process.start_stop_lock); - /* 2) Execute the code. The CATCH_ALL point is the destination - * provides us with an elegant way to exit the thread: we just - * do an unwind up to frs_top. - */ - ECL_CATCH_ALL_BEGIN(env) { + /* Execute the code. The CATCH_ALL point is the destination provides us with + * an elegant way to exit the thread: we just do an unwind up to frs_top. */ + ECL_CATCH_ALL_BEGIN(the_env) { #ifdef HAVE_SIGPROCMASK { - sigset_t *new = (sigset_t*)env->default_sigmask; + sigset_t *new = (sigset_t*)the_env->default_sigmask; pthread_sigmask(SIG_SETMASK, new, NULL); } #endif process->process.phase = ECL_PROCESS_ACTIVE; ecl_mutex_unlock(&process->process.start_stop_lock); si_trap_fpe(@'last', ECL_T); - ecl_enable_interrupts_env(env); - ecl_bds_bind(env, @'mp::*current-process*', process); - ECL_RESTART_CASE_BEGIN(env, @'abort') { - process->process.entry(0); + ecl_enable_interrupts_env(the_env); + ecl_bds_bind(the_env, @'mp::*current-process*', process); + + ECL_RESTART_CASE_BEGIN(the_env, @'abort') { + the_env->values[0] = cl_apply(2, fun, args); + int i = the_env->nvalues; + while (i--) { + output = CONS(the_env->values[i], output); + } + process->process.exit_values = output; } ECL_RESTART_CASE(1,args) { /* ABORT restart. */ process->process.exit_values = args; } ECL_RESTART_CASE_END; - ecl_bds_unwind1(env); + ecl_bds_unwind1(the_env); } ECL_CATCH_ALL_END; - /* 4) If everything went right, we should be exiting the thread - * through this point. thread_cleanup is automatically invoked - * marking the process as inactive. - */ -#ifdef ECL_WINDOWS_THREADS - thread_cleanup(process); - return 1; -#else - pthread_cleanup_pop(1); - return NULL; -#endif -} + ecl_disable_interrupts_env(the_env); + ecl_clear_bignum_registers(the_env); -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*)); + ecl_mutex_lock(&process->process.start_stop_lock); + process->process.phase = ECL_PROCESS_EXITING; +#ifdef HAVE_SIGPROCMASK + /* ...but we might get stray signals. */ + { + sigset_t new[1]; + sigemptyset(new); + sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + pthread_sigmask(SIG_BLOCK, new, NULL); } - env->bds_stack.tl_bindings_size = bindings_size; - env->bds_stack.tl_bindings = bindings; -} +#endif + process->process.env = NULL; + process->process.phase = ECL_PROCESS_INACTIVE; + ecl_cond_var_broadcast(&process->process.exit_barrier); + ecl_mutex_unlock(&process->process.start_stop_lock); -static cl_object -run_process(cl_narg narg, ...) -{ - cl_env_ptr the_env = ecl_process_env(); - cl_object process = the_env->own_process; - cl_object fun = process->process.function; - cl_object args = process->process.args; - cl_object output = ECL_NIL; - the_env->values[0] = cl_apply(2, fun, args); - int i = the_env->nvalues; - while (i--) { - output = CONS(the_env->values[i], output); - } - process->process.exit_values = output; return the_env->values[0]; } @@ -273,10 +172,7 @@ ecl_import_current_thread(cl_object name, cl_object bindings) process = alloc_process(name, ECL_NIL); process->process.env = the_env; process->process.phase = ECL_PROCESS_BOOTING; - - init_tl_bindings(process, the_env); the_env->own_process = process; - process->process.phase = ECL_PROCESS_ACTIVE; ecl_bds_bind(the_env, @'mp::*current-process*', process); @@ -286,16 +182,27 @@ ecl_import_current_thread(cl_object name, cl_object bindings) void ecl_release_current_thread(void) { - cl_env_ptr env = ecl_process_env(); - - int cleanup = env->cleanup; - cl_object own_process = env->own_process; - thread_cleanup(own_process); -#ifdef GBC_BOEHM - if (cleanup) { - GC_unregister_my_thread(); + cl_object process; + cl_env_ptr the_env = ecl_process_env_unsafe(); + if (the_env == NULL) + return; + process = the_env->own_process; + ecl_mutex_lock(&process->process.start_stop_lock); + process->process.env = NULL; + process->process.phase = ECL_PROCESS_EXITING; + ecl_disown_cpu(); +#ifdef HAVE_SIGPROCMASK + /* ...but we might get stray signals. */ + { + sigset_t new[1]; + sigemptyset(new); + sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + pthread_sigmask(SIG_BLOCK, new, NULL); } #endif + process->process.phase = ECL_PROCESS_INACTIVE; + ecl_cond_var_broadcast(&process->process.exit_barrier); + ecl_mutex_unlock(&process->process.start_stop_lock); } @(defun mp::make-process (&key name ((:initial-bindings initial_bindings_p) ECL_T)) @@ -388,105 +295,33 @@ mp_process_yield(void) cl_object mp_process_enable(cl_object process) { - /* process_env and ok are changed after the setjmp call in - * ECL_UNWIND_PROTECT_BEGIN, so they need to be declared volatile */ - volatile cl_env_ptr process_env = NULL; cl_env_ptr the_env = ecl_process_env(); - volatile int ok = 1; - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* Try to gain exclusive access to the process. This prevents two - * concurrent calls to process-enable from different threads on - * the same process */ - ecl_mutex_lock(&process->process.start_stop_lock); - /* Ensure that the process is inactive. */ - if (process->process.phase != ECL_PROCESS_INACTIVE) { - FEerror("Cannot enable the running process ~A.", 1, process); - } - ok = 0; - process->process.phase = ECL_PROCESS_BOOTING; - - /* Link environment and process together */ - process_env = _ecl_alloc_env(the_env); - process_env->own_process = process; - process->process.env = process_env; - - /* Immediately list the process such that its environment is - * marked by the gc when its contents are allocated */ - ecl_add_process(process); - - /* Now we can safely allocate memory for the environment contents - * and store pointers to it in the environment */ - ecl_init_env(process_env); - - process_env->trap_fpe_bits = the_env->trap_fpe_bits; - init_tl_bindings(process, process_env); - - ecl_disable_interrupts_env(the_env); -#ifdef ECL_WINDOWS_THREADS - { - HANDLE code; - DWORD threadId; - - code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); - ok = (process_env->thread = code) != NULL; - } -#else - { - int code; - pthread_attr_t pthreadattr; - - pthread_attr_init(&pthreadattr); - pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); - /* - * Block all asynchronous signals until the thread is completely - * set up. The synchronous signals SIGSEGV and SIGBUS are needed - * by the gc and thus can't be blocked. - */ -#ifdef HAVE_SIGPROCMASK - { - sigset_t new, previous; - sigfillset(&new); - sigdelset(&new, SIGSEGV); - sigdelset(&new, SIGBUS); - pthread_sigmask(SIG_BLOCK, &new, &previous); - code = pthread_create(&process_env->thread, &pthreadattr, - thread_entry_point, process); - pthread_sigmask(SIG_SETMASK, &previous, NULL); - } -#else - code = pthread_create(&process_env->thread, &pthreadattr, - thread_entry_point, process); -#endif - ok = (code == 0); - } -#endif - ecl_enable_interrupts_env(the_env); - } ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT { - if (!ok) { - /* INV: interrupts are already disabled through thread safe - * unwind-protect */ - ecl_del_process(process); - process->process.phase = ECL_PROCESS_INACTIVE; - /* Alert possible waiting processes. */ - ecl_cond_var_broadcast(&process->process.exit_barrier); - process->process.env = NULL; - if (process_env != NULL) - _ecl_dealloc_env(process_env); - } - /* Unleash the thread */ + cl_env_ptr process_env = NULL; + /* Try to gain exclusive access to the process. This prevents two concurrent + * calls to process-enable from different threads on the same process */ + ecl_mutex_lock(&process->process.start_stop_lock); + /* Ensure that the process is inactive. */ + if (process->process.phase != ECL_PROCESS_INACTIVE) { ecl_mutex_unlock(&process->process.start_stop_lock); - } ECL_UNWIND_PROTECT_THREAD_SAFE_END; - - @(return (ok? process : ECL_NIL)); + FEerror("Cannot enable the running process ~A.", 1, process); + } + process->process.phase = ECL_PROCESS_BOOTING; + /* Spawn the thread (allocates the environment)*/ + process_env = ecl_spawn_cpu(process); + if (process_env == NULL) { + process->process.phase = ECL_PROCESS_INACTIVE; + ecl_cond_var_broadcast(&process->process.exit_barrier); + } + /* Unleash the thread */ + ecl_mutex_unlock(&process->process.start_stop_lock); + ecl_return1(the_env, (process_env ? process : ECL_NIL)); } cl_object mp_exit_process(void) { - /* We simply undo the whole of the frame stack. This brings up - back to the thread entry point, going through all possible - UNWIND-PROTECT. - */ + /* We simply undo the whole of the frame stack. This brings up back to the + thread entry point, going through all possible UNWIND-PROTECT. */ const cl_env_ptr the_env = ecl_process_env(); ecl_unwind(the_env, the_env->frs_stack.org); /* Never reached */ @@ -647,11 +482,9 @@ init_threads() { cl_env_ptr the_env = ecl_process_env(); cl_object process, _env = ecl_cast_ptr(cl_object,the_env); - 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; process->process.name = @'si::top-level'; @@ -660,7 +493,6 @@ init_threads() process->process.env = the_env; ecl_mutex_init(&process->process.start_stop_lock, TRUE); ecl_cond_var_init(&process->process.exit_barrier); - the_env->thread = main_thread; the_env->own_process = process; ecl_stack_push(ecl_core.threads, _env); } diff --git a/src/h/nucleus.h b/src/h/nucleus.h index 08f553651..039fb5dd9 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -36,9 +36,7 @@ struct ecl_core_struct { /* process.c */ cl_env_ptr ecl_adopt_cpu(); cl_env_ptr ecl_spawn_cpu(); - -void ecl_add_process(cl_object process); -void ecl_del_process(cl_object process); +void ecl_disown_cpu(); /* control.c */ cl_object ecl_escape(cl_object continuation) ecl_attr_noreturn; -- GitLab From 0375f9747c5e4f13c9afb3784f3cd0e823ccee8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 3 May 2024 08:40:50 +0200 Subject: [PATCH 40/58] process: use GC_thread_is_registered() instead of the_env->cleanup This allows us to remove unnecessary bookkeeping. --- src/c/main.d | 1 - src/c/process.d | 50 +++++++++++++++++++++++------------------------- src/h/external.h | 1 - 3 files changed, 24 insertions(+), 28 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index cd176248a..328355155 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -166,7 +166,6 @@ _ecl_alloc_env(cl_env_ptr parent) #if defined(ECL_THREADS) output->bds_stack.tl_bindings_size = 0; output->bds_stack.tl_bindings = NULL; - output->cleanup = 0; #endif output->own_process = ECL_NIL; { diff --git a/src/c/process.d b/src/c/process.d index fc26b971b..aec804237 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -143,6 +143,28 @@ del_env(cl_env_ptr the_env) ecl_mutex_unlock(&ecl_core.processes_lock); } +static void +register_gc_thread() +{ +#ifdef GBC_BOEHM + if (GC_thread_is_registered() == 0) { + struct GC_stack_base stack; + GC_get_stack_base(&stack); + GC_register_my_thread(&stack); + } +#endif +} + +static void +unregister_gc_thread() +{ +#ifdef GBC_BOEHM + if (GC_thread_is_registered() == 1) { + GC_unregister_my_thread(); + } +#endif +} + /* Run a process in the current system thread. */ cl_env_ptr ecl_adopt_cpu() @@ -151,28 +173,10 @@ ecl_adopt_cpu() struct ecl_interrupt_struct int_aux[1]; cl_env_ptr the_env = ecl_process_env_unsafe(); ecl_thread_t current; - int registered; if (the_env != NULL) return the_env; /* Ensure that the thread is known to the GC. */ - /* FIXME this should be executed with hooks. */ -#ifdef GBC_BOEHM - { - struct GC_stack_base stack; - GC_get_stack_base(&stack); - switch (GC_register_my_thread(&stack)) { - case GC_SUCCESS: - registered = 1; - break; - case GC_DUPLICATE: - /* Thread was probably created using the GC hooks for thread creation. */ - registered = 0; - break; - default: - ecl_internal_error("gc returned an impossible answer."); - } - } -#endif + register_gc_thread(); ecl_set_process_self(current); /* We need a fake env to allow for interrupts blocking and to set up frame * stacks or other stuff that is needed by ecl_init_env. Since the fake env is @@ -186,7 +190,6 @@ ecl_adopt_cpu() env_aux->interrupt_struct->signal_queue = ECL_NIL; ecl_set_process_env(env_aux); env_aux->thread = current; - env_aux->cleanup = registered; ecl_init_env(env_aux); /* Allocate, initialize and switch to the real environment. */ @@ -202,11 +205,9 @@ ecl_adopt_cpu() void ecl_disown_cpu() { - int registered; cl_env_ptr the_env = ecl_process_env_unsafe(); if (the_env == NULL) return; - registered = the_env->cleanup; ecl_disable_interrupts_env(the_env); /* FIXME this should be part of dealloc. */ ecl_clear_bignum_registers(the_env); @@ -216,10 +217,7 @@ ecl_disown_cpu() ecl_set_process_env(NULL); del_env(the_env); _ecl_dealloc_env(the_env); - /* FIXME thsi should be executed with hooks. */ - if (registered) { - GC_unregister_my_thread(); - } + unregister_gc_thread(); } #ifdef ECL_WINDOWS_THREADS diff --git a/src/h/external.h b/src/h/external.h index c62ddbd34..ef857439f 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -101,7 +101,6 @@ struct cl_env_struct { #ifdef ECL_THREADS cl_object own_process; /* Backpointer to the running process. */ ecl_thread_t thread; - int cleanup; #endif /* -- System Interrupts ---------------------------------------------- */ -- GitLab From 9ce19f55c23a51f05f5a62dc7eed6c40dee90667 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 29 Nov 2024 23:38:56 +0100 Subject: [PATCH 41/58] process: move ecl_clear_bignum_registers to _dealloc_env This resolves a fixme. --- src/c/main.d | 1 + src/c/process.d | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 328355155..c360bc48b 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -126,6 +126,7 @@ _ecl_dealloc_env(cl_env_ptr env) if (!VirtualFree(env, 0, MEM_RELEASE)) ecl_internal_error("Unable to deallocate environment structure."); #else + ecl_clear_bignum_registers(env); ecl_free_unsafe(env); #endif } diff --git a/src/c/process.d b/src/c/process.d index aec804237..5ff7b4afd 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -209,8 +209,6 @@ ecl_disown_cpu() if (the_env == NULL) return; ecl_disable_interrupts_env(the_env); - /* FIXME this should be part of dealloc. */ - ecl_clear_bignum_registers(the_env); #ifdef ECL_WINDOWS_THREADS CloseHandle(the_env->thread); #endif -- GitLab From 7af29da33cf6710c1fa026e7839dc4d04be36823 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 7 May 2024 07:09:31 +0200 Subject: [PATCH 42/58] modules: [0/n] introduce a new structure ecl_module in the system This will allow us to decouple forward system initialization from the early process code. --- src/c/Makefile.in | 2 +- src/c/alloc_2.d | 2 + src/c/boot.d | 4 +- src/c/clos/instance.d | 3 + src/c/main.d | 14 ++- src/c/module.d | 178 +++++++++++++++++++++++++++++++++++++ src/c/printer/write_ugly.d | 7 ++ src/c/process.d | 7 +- src/c/serialize.d | 1 + src/c/symbols_list.h | 1 + src/c/threads/thread.d | 2 - src/c/typespec.d | 2 + src/clos/hierarchy.lsp | 1 + src/h/external.h | 14 ++- src/h/internal.h | 1 + src/h/nucleus.h | 1 + src/h/object.h | 17 ++++ 17 files changed, 247 insertions(+), 10 deletions(-) create mode 100644 src/c/module.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 93f91ae8e..17553b4a4 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = boot.o call.o jump.o atomic.o process.o memory.o +NUCL_OBJS = boot.o call.o jump.o atomic.o process.o memory.o module.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 06b65ad09..f85efd052 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -553,6 +553,7 @@ void init_type_info (void) init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 0); init_tm(t_exception, "EXCEPTION", sizeof(struct ecl_exception), 3); + init_tm(t_module, "MODULE", sizeof(struct ecl_module), 2); init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); #ifdef ECL_SSE2 init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); @@ -715,6 +716,7 @@ void init_type_info (void) to_bitmap(&o, &(o.exception.arg1)) | to_bitmap(&o, &(o.exception.arg2)) | to_bitmap(&o, &(o.exception.arg3)); + type_info[t_module].descriptor = 0; type_info[t_weak_pointer].descriptor = 0; #ifdef ECL_SSE2 type_info[t_sse_pack].descriptor = 0; diff --git a/src/c/boot.d b/src/c/boot.d index b6de35437..0f9cbcd5d 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -156,6 +156,8 @@ struct ecl_core_struct ecl_core = { /* pathnames */ .path_max = 0, .pathname_translations = ECL_NIL, + /* MODULES is a stack of plugins that may be loaded at boot time. */ + .modules = ECL_NIL, /* LIBRARIES is a list of objects. It behaves as a sequence of weak pointers thanks to the magic in the garbage collector. */ .libraries = ECL_NIL, @@ -176,8 +178,8 @@ ecl_boot(void) } return 1; } - init_process(); + init_modules(); /* init_unixint(); */ /* init_garbage(); */ diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index 6fc1d8303..8d1fd5bbd 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -384,6 +384,7 @@ enum ecl_built_in_classes { ECL_BUILTIN_FOREIGN_DATA, ECL_BUILTIN_FRAME, ECL_BUILTIN_EXCEPTION, + ECL_BUILTIN_MODULE, ECL_BUILTIN_WEAK_POINTER #ifdef ECL_THREADS , @@ -508,6 +509,8 @@ cl_class_of(cl_object x) index = ECL_BUILTIN_FRAME; break; case t_exception: index = ECL_BUILTIN_EXCEPTION; break; + case t_module: + index = ECL_BUILTIN_MODULE; break; case t_weak_pointer: index = ECL_BUILTIN_WEAK_POINTER; break; #ifdef ECL_SSE2 diff --git a/src/c/main.d b/src/c/main.d index c360bc48b..f0dd2195e 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -93,17 +93,22 @@ init_env_aux(cl_env_ptr env) } void -ecl_init_first_env(cl_env_ptr env) +ecl_init_first_env(cl_env_ptr the_env) { #ifdef ECL_THREADS init_threads(); #endif - ecl_init_env(env); + ecl_cs_init(the_env); + init_env_int(the_env); + init_env_aux(the_env); + init_env_ffi(the_env); + init_stacks(the_env); } void ecl_init_env(cl_env_ptr env) { + ecl_modules_init_env(env); init_env_int(env); init_env_aux(env); init_env_ffi(env); @@ -113,8 +118,8 @@ ecl_init_env(cl_env_ptr env) void _ecl_dealloc_env(cl_env_ptr env) { - /* Environment cleanup. This is required because the environment is allocated - * using mmap or some other method. */ + env->own_process = ECL_NIL; + ecl_modules_free_env(env); free_stacks(env); #ifdef ECL_THREADS ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock); @@ -324,6 +329,7 @@ cl_boot(int argc, char **argv) init_unixint(0); init_alloc(0); + init_big(); /* diff --git a/src/c/module.d b/src/c/module.d new file mode 100644 index 000000000..dd745640c --- /dev/null +++ b/src/c/module.d @@ -0,0 +1,178 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* module.c - managing runtime modules */ + +/* -- imports ---------------------------------------------------------------- */ +#include +#include +#include +#include + +/* -- test module ------------------------------------------------------------ */ + +static cl_object create() { + printf("DUMMY: Creating the module!\n"); + return ECL_NIL; +} + +static cl_object enable() { + printf("DUMMY: Enabling the module!\n"); + return ECL_NIL; +} + +static cl_object init_env(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: init_env [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: init_env [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object init_cpu(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: init_cpu [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: init_cpu [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object free_cpu(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: free_cpu [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: free_cpu [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object free_env(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: free_env [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: free_env [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object disable() { + printf("DUMMY: Disabling the module!\n"); + return ECL_NIL; +} + +static cl_object destroy() { + printf("DUMMY: Destroying the module!\n"); + return ECL_NIL; +} + +ecl_def_ct_base_string(str_dummy, "DUMMY", 5, static, const); + +static struct ecl_module module_dummy = { + .name = str_dummy, + .create = create, + .enable = enable, + .init_env = init_env, + .init_cpu = init_cpu, + .free_cpu = free_cpu, + .free_env = free_env, + .disable = disable, + .destroy = destroy +}; + +cl_object ecl_module_dummy = (cl_object)&module_dummy; + +/* -- implementation --------------------------------------------------------- */ + +cl_object +ecl_module_no_op() +{ + return ECL_NIL; +} + +cl_object +ecl_module_no_op_env(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +cl_object +ecl_module_no_op_cpu(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +cl_object +ecl_add_module(cl_object self) +{ + self->module.create(); + self->module.init_cpu(ecl_core.first_env); + self->module.init_env(ecl_core.first_env); + ecl_stack_push(ecl_core.modules, self); + return ECL_NIL; +} + +cl_object +ecl_del_module(cl_object self) +{ + ecl_stack_del(ecl_core.modules, self); + self->module.disable(); + self->module.free_env(ecl_core.first_env); + self->module.free_cpu(ecl_core.first_env); + self->module.destroy(); + return ECL_NIL; +} + +cl_object +ecl_modules_init_env(cl_env_ptr the_env) { + loop_across_stack_fifo(var, ecl_core.modules) { + /* printf("> init_env: %s\n", (var->module.name)->base_string.self); */ + var->module.init_env(the_env); + /* printf("< init_env: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +cl_object +ecl_modules_init_cpu(cl_env_ptr the_env) { + loop_across_stack_fifo(var, ecl_core.modules) { + /* printf("> init_cpu: %s\n", (var->module.name)->base_string.self); */ + var->module.init_cpu(the_env); + /* printf("< init_cpu: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +cl_object +ecl_modules_free_cpu(cl_env_ptr the_env) { + loop_across_stack_filo(var, ecl_core.modules) { + /* printf("> free_cpu: %s\n", (var->module.name)->base_string.self); */ + var->module.free_cpu(the_env); + /* printf("< free_cpu: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +cl_object +ecl_modules_free_env(cl_env_ptr the_env) { + loop_across_stack_filo(var, ecl_core.modules) { + /* printf("> free_env: %s\n", (var->module.name)->base_string.self); */ + var->module.free_env(the_env); + /* printf("< free_env: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +/* INV all modules must be loaded before we make new threads. */ +/* FIXME enforce this invariant. */ +void +init_modules() +{ + cl_object self = ecl_make_stack(16); + ecl_core.modules = self; +} diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index 522365d31..fcdb42bb0 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -376,6 +376,12 @@ write_exception(cl_object x, cl_object stream) _ecl_write_unreadable(x, "exception", ECL_NIL, stream); } +static void +write_module(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "module", x->module.name, stream); +} + static void write_weak_pointer(cl_object x, cl_object stream) { @@ -487,6 +493,7 @@ static printer dispatch[FREE+1] = { write_foreign, /* t_foreign */ write_frame, /* t_frame */ write_exception, /* t_exception */ + write_module, /* t_module */ write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 _ecl_write_sse, /* t_sse_pack */ diff --git a/src/c/process.d b/src/c/process.d index 5ff7b4afd..094b567fe 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -195,9 +195,10 @@ ecl_adopt_cpu() /* Allocate, initialize and switch to the real environment. */ the_env = _ecl_alloc_env(0); memcpy(the_env, env_aux, sizeof(*the_env)); - ecl_set_process_env(the_env); add_env(the_env); init_tl_bindings(ECL_NIL, the_env); + ecl_set_process_env(the_env); + ecl_modules_init_cpu(the_env); return the_env; } @@ -209,6 +210,7 @@ ecl_disown_cpu() if (the_env == NULL) return; ecl_disable_interrupts_env(the_env); + ecl_modules_free_cpu(the_env); #ifdef ECL_WINDOWS_THREADS CloseHandle(the_env->thread); #endif @@ -229,6 +231,7 @@ thread_entry_point(void *ptr) cl_object process = the_env->own_process; /* Setup the environment for the execution of the thread. */ ecl_set_process_env(the_env); + ecl_modules_init_cpu(the_env); ecl_cs_init(the_env); process->process.entry(0); @@ -242,8 +245,10 @@ thread_entry_point(void *ptr) * pthread_cancel() to kill a process, but rather use the lisp functions * mp_interrupt_process() and mp_process_kill(). */ + ecl_disable_interrupts_env(the_env); ecl_set_process_env(NULL); the_env->own_process = ECL_NIL; + ecl_modules_free_cpu(the_env); del_env(the_env); #ifdef ECL_WINDOWS_THREADS CloseHandle(the_env->thread); diff --git a/src/c/serialize.d b/src/c/serialize.d index 216ee5df0..ac829031b 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -77,6 +77,7 @@ static cl_index object_size[] = { ROUNDED_SIZE(ecl_foreign), /* t_foreign */ ROUNDED_SIZE(ecl_stack_frame), /* t_frame */ ROUNDED_SIZE(ecl_exception), /* t_exception */ + ROUNDED_SIZE(ecl_module), /* t_module */ ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ #ifdef ECL_SSE2 , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 8736cddac..86196072e 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1846,6 +1846,7 @@ cl_symbols[] = { {SYS_ "CODE-BLOCK" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "EXCEPTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "MODULE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "FRAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "APPLY-FROM-STACK-FRAME" ECL_FUN("si_apply_from_stack_frame", si_apply_from_stack_frame, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 40942832a..4028059d3 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -50,8 +50,6 @@ ecl_process_list() /* -- Environment --------------------------------------------------- */ -extern void ecl_init_env(struct cl_env_struct *env); - cl_object mp_current_process(void) { diff --git a/src/c/typespec.d b/src/c/typespec.d index 7e4ae800a..5b53e230e 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -183,6 +183,8 @@ ecl_type_to_symbol(cl_type t) return @'si::frame'; case t_exception: return @'si::exception'; + case t_module: + return @'si::module'; case t_weak_pointer: return @'ext::weak-pointer'; #ifdef ECL_SSE2 diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index af25872e1..18e887aac 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -230,6 +230,7 @@ (si::foreign-data) (si::frame) (si::exception) + (si::module) (si::weak-pointer) #+threads (mp::process) #+threads (mp::lock) diff --git a/src/h/external.h b/src/h/external.h index ef857439f..f6423024a 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -64,7 +64,6 @@ struct ecl_c_stack { * Per-thread data. */ -typedef struct cl_env_struct *cl_env_ptr; struct cl_env_struct { /* -- ECL runtime ---------------------------------------------------- */ /* Array where values are returned. */ @@ -1856,6 +1855,19 @@ extern ECL_API cl_object ecl_make_rwlock(cl_object lock); #endif /* ECL_THREADS */ +/* nucleus/module.c */ + +extern ECL_API cl_object ecl_add_module(cl_object self); +extern ECL_API cl_object ecl_del_module(cl_object self); +extern ECL_API cl_object ecl_modules_init_env(cl_env_ptr the_env); +extern ECL_API cl_object ecl_modules_free_env(cl_env_ptr the_env); +extern ECL_API cl_object ecl_modules_init_cpu(cl_env_ptr the_env); +extern ECL_API cl_object ecl_modules_free_cpu(cl_env_ptr the_env); + +extern ECL_API cl_object ecl_module_no_op_env(cl_env_ptr the_env); +extern ECL_API cl_object ecl_module_no_op_cpu(cl_env_ptr the_env); +extern ECL_API cl_object ecl_module_no_op(); + /* time.c */ extern ECL_API cl_object cl_sleep(cl_object z); diff --git a/src/h/internal.h b/src/h/internal.h index 4deb8a0bf..d8a64c0b3 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -44,6 +44,7 @@ extern void init_unixint(int pass); extern void init_unixtime(void); extern void init_compiler(void); extern void init_process(void); +extern void init_modules(void); #ifdef ECL_THREADS extern void init_threads(void); #endif diff --git a/src/h/nucleus.h b/src/h/nucleus.h index 039fb5dd9..6d6c752f4 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -29,6 +29,7 @@ struct ecl_core_struct { int path_max; cl_object pathname_translations; + cl_object modules; cl_object libraries; cl_object library_pathname; }; diff --git a/src/h/object.h b/src/h/object.h index 6ba83a8b9..3e2218ee5 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -85,6 +85,7 @@ typedef enum { t_foreign, t_frame, t_exception, + t_module, t_weak_pointer, #ifdef ECL_SSE2 t_sse_pack, @@ -100,10 +101,12 @@ typedef enum { Definition of the type of LISP objects. */ typedef union cl_lispunion *cl_object; +typedef struct cl_env_struct *cl_env_ptr; typedef cl_object cl_return; typedef cl_fixnum cl_narg; typedef cl_object (*cl_objectfn)(cl_narg narg, ...); typedef cl_object (*cl_objectfn_fixed)(); +typedef cl_object (*cl_objectfn_envfn)(cl_env_ptr); /* OBJect NULL value. @@ -970,6 +973,19 @@ struct ecl_exception { void * arg4; /* arbitrary last ditch argument (usually NULL). */ }; +struct ecl_module { + _ECL_HDR; + cl_object name; + cl_objectfn_fixed create; + cl_objectfn_fixed enable; + cl_objectfn_envfn init_env; + cl_objectfn_envfn init_cpu; + cl_objectfn_envfn free_cpu; + cl_objectfn_envfn free_env; + cl_objectfn_fixed disable; + cl_objectfn_fixed destroy; +}; + struct ecl_weak_pointer { /* weak pointer to value */ _ECL_HDR; cl_object value; @@ -1196,6 +1212,7 @@ union cl_lispunion { struct ecl_dummy d; /* dummy */ struct ecl_instance instance; /* clos instance */ struct ecl_exception exception; /* exception */ + struct ecl_module module; /* core module */ #ifdef ECL_THREADS struct ecl_process process; /* process */ struct ecl_lock lock; /* lock */ -- GitLab From d94f976587ad7a83a830ad10cd9209bcbc36277c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 29 Nov 2024 21:49:47 +0100 Subject: [PATCH 43/58] modules: [1/n] introduce ecl_module_gc We also remove conditionalization for garbage collector inclusion in autotools. When we propose an alternative gc, then we may decide to put them back, or to add necessary ifdef statements directly in files. Moreover untangle c-stack from the gc code and assign the stack base with a rough guess only when it is not initialized yet (GC will always fill it). Finally remove a kludge from ecl_adopt_cpu and disable colleciton until the cpu is fully initialized. --- src/aclocal.m4 | 3 - src/c/Makefile.in | 4 +- src/c/main.d | 11 +- src/c/{alloc_2.d => mem_gc.d} | 299 +++++++++++++++++++--------------- src/c/process.d | 25 +-- src/c/stacks.d | 14 +- src/c/threads/thread.d | 3 +- src/configure | 5 - src/configure.ac | 2 - src/h/internal.h | 11 +- 10 files changed, 191 insertions(+), 186 deletions(-) rename src/c/{alloc_2.d => mem_gc.d} (95%) diff --git a/src/aclocal.m4 b/src/aclocal.m4 index b24eb4df2..571a70eff 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -1130,7 +1130,6 @@ if test "${enable_boehm}" = auto -o "${enable_boehm}" = system; then fi else FASL_LIBS="${FASL_LIBS} -lgc" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" AC_DEFINE(GBC_BOEHM, [1], [Use Boehm's garbage collector]) fi fi @@ -1162,7 +1161,6 @@ if test "${enable_boehm}" = "included"; then ECL_BOEHM_GC_HEADER='ecl/gc/gc.h' SUBDIRS="${SUBDIRS} gc" CORE_LIBS="-leclgc ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}" fi @@ -1237,7 +1235,6 @@ if test "${enable_libffi}" = "included"; then ECL_LIBFFI_HEADER='ecl/ffi.h' SUBDIRS="${SUBDIRS} libffi" CORE_LIBS="-leclffi ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}" fi diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 17553b4a4..1985ff731 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -74,12 +74,14 @@ READER_OBJS = read.o reader/parse_integer.o reader/parse_number.o FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o +GC_OBJS = alloc.o gbc.o + OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o \ compiler.o disassembler.o reference.o character.o file.o error.o \ string.o cfun.o typespec.o assignment.o predicate.o array.o \ vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ - load.o unixfsys.o unixsys.o serialize.o sse2.o \ + load.o unixfsys.o unixsys.o serialize.o sse2.o mem_gc.o \ $(CLOS_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(FFI_OBJS) \ $(NUCL_OBJS) @EXTRA_OBJS@ diff --git a/src/c/main.d b/src/c/main.d index f0dd2195e..42ee78ea7 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -174,6 +174,7 @@ _ecl_alloc_env(cl_env_ptr parent) output->bds_stack.tl_bindings = NULL; #endif output->own_process = ECL_NIL; + output->c_stack.org = NULL; { size_t bytes = ecl_core.default_sigmask_bytes; if (bytes == 0) { @@ -327,9 +328,9 @@ cl_boot(int argc, char **argv) ARGV = argv; ecl_self = argv[0]; - init_unixint(0); - init_alloc(0); + ecl_add_module(ecl_module_gc); + init_unixint(0); init_big(); /* @@ -341,6 +342,9 @@ cl_boot(int argc, char **argv) env = ecl_core.first_env; ecl_init_first_env(env); + /* We need to enable GC because a lot of stuff is to be created */ + ecl_module_gc->module.enable(); + /* * 1) Initialize symbols and packages */ @@ -446,9 +450,6 @@ cl_boot(int argc, char **argv) /* These must come _after_ the packages and NIL/T have been created */ init_all_symbols(); - /* We need to enable GC because a lot of stuff is to be created */ - init_alloc(1); - /* Initialize the handler stack with the exception handler. */ cl_import2(ECL_SIGNAL_HANDLERS, cl_core.system_package); cl_export2(ECL_SIGNAL_HANDLERS, cl_core.system_package); diff --git a/src/c/alloc_2.d b/src/c/mem_gc.d similarity index 95% rename from src/c/alloc_2.d rename to src/c/mem_gc.d index f85efd052..64fec22a4 100644 --- a/src/c/alloc_2.d +++ b/src/c/mem_gc.d @@ -1,17 +1,16 @@ /* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ -/* - * alloc_2.c - memory allocation based on the Boehm GC - * - * Copyright (c) 2001 Juan Jose Garcia Ripoll - * - * See file 'LICENSE' for the copyright details. - * - */ +/* mem_gc.d - automatic memory allocator and garbage collector based on bdwgc */ -#include +/* -- imports ---------------------------------------------------------------- */ #include +#include +#include +#include + +#include + #ifdef ECL_THREADS # ifdef ECL_WINDOWS_THREADS # include @@ -19,21 +18,24 @@ # include # endif #endif + #include #include #include + #ifdef ECL_WSOCK -#include +# include #endif #ifdef GBC_BOEHM -#include +# include +#endif static void (*GC_old_start_callback)(void) = NULL; static void gather_statistics(void); static void update_bytes_consed(void); static void ecl_mark_env(struct cl_env_struct *env); - + #ifdef GBC_BOEHM_PRECISE # if GBC_BOEHM # undef GBC_BOEHM_PRECISE @@ -45,9 +47,7 @@ static void **cl_object_free_list; # endif #endif -/********************************************************** - * OBJECT ALLOCATION * - **********************************************************/ +/* -- object allocation ------------------------------------------------------ */ void _ecl_set_max_heap_size(size_t new_size) @@ -143,8 +143,7 @@ out_of_memory(size_t requested_bytes) switch (method) { case 0: cl_error(1, @'ext::storage-exhausted'); break; - case 1: cl_cerror(2, @"Extend heap size", - @'ext::storage-exhausted'); + case 1: cl_cerror(2, @"Extend heap size", @'ext::storage-exhausted'); break; case 2: return output; @@ -470,6 +469,56 @@ ecl_dealloc(void *ptr) ecl_enable_interrupts_env(the_env); } +/* -- weak pointers ---------------------------------------------------------- */ + +cl_object +ecl_alloc_weak_pointer(cl_object o) +{ + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_weak_pointer *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); + ecl_enable_interrupts_env(the_env); + obj->t = t_weak_pointer; + obj->value = o; + if (!ECL_IMMEDIATE(o)) { + GC_GENERAL_REGISTER_DISAPPEARING_LINK((void**)&(obj->value), (void*)o); + si_set_finalizer((cl_object)obj, ECL_T); + } + return (cl_object)obj; +} + +static cl_object +ecl_weak_pointer_value(cl_object o) +{ + return ecl_weak_pointer(o); +} + +cl_object +si_make_weak_pointer(cl_object o) +{ + cl_object pointer = ecl_alloc_weak_pointer(o); + @(return pointer); +} + +cl_object +si_weak_pointer_value(cl_object o) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object value; + if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) + FEwrong_type_only_arg(@[ext::weak-pointer-value], o, + @[ext::weak-pointer]); + value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); + if (value) { + ecl_return2(the_env, value, ECL_T); + } else { + ecl_return2(the_env, ECL_NIL, ECL_NIL); + } +} + +/* -- graph traversal -------------------------------------------------------- */ + #ifdef GBC_BOEHM_PRECISE static cl_index to_bitmap(void *x, void *y) @@ -751,78 +800,7 @@ extern void (*GC_push_other_roots)(); static void (*old_GC_push_other_roots)(); static void stacks_scanner(); -void -init_alloc(int pass) -{ - if (pass == 1) { - GC_enable(); - return; - } - /* - * Garbage collector restrictions: we set up the garbage collector - * library to work as follows - * - * 1) The garbage collector shall not scan shared libraries - * explicitely. - * 2) We only detect objects that are referenced by a pointer to - * the begining or to the first byte. - * 3) Out of the incremental garbage collector, we only use the - * generational component. - * 4) GC should handle fork() which is used to run subprocess on - * some platforms. - */ - GC_set_no_dls(1); - GC_set_all_interior_pointers(0); - GC_set_time_limit(GC_TIME_UNLIMITED); -#ifndef ECL_MS_WINDOWS_HOST - GC_set_handle_fork(1); -#endif - GC_init(); -#ifdef ECL_THREADS -# if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1 - GC_allow_register_threads(); -# endif -#endif - if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { - GC_enable_incremental(); - } - GC_register_displacement(1); - GC_clear_roots(); - GC_disable(); - -#ifdef GBC_BOEHM_PRECISE -# ifdef GBC_BOEHM_OWN_MARKER - cl_object_free_list = (void **)GC_new_free_list_inner(); - cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); - cl_object_kind = GC_new_kind_inner(cl_object_free_list, - GC_MAKE_PROC(cl_object_mark_proc_index, 0), - FALSE, TRUE); -# endif -#endif /* !GBC_BOEHM_PRECISE */ - ecl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]; - GC_set_max_heap_size(ecl_core.max_heap_size); - /* Save some memory for the case we get tight. */ - if (ecl_core.max_heap_size == 0) { - cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (ecl_core.safety_region) { - ecl_core.safety_region = 0; - } - - init_type_info(); - - old_GC_push_other_roots = GC_push_other_roots; - GC_push_other_roots = stacks_scanner; - GC_old_start_callback = GC_get_start_callback(); - GC_set_start_callback(gather_statistics); - GC_set_java_finalization(1); - GC_set_oom_fn(out_of_memory); - GC_set_warn_proc(no_warnings); -} - -/********************************************************** - * FINALIZATION * - **********************************************************/ +/* -- finalization ----------------------------------------------------------- */ static void standard_finalizer(cl_object o) @@ -1059,6 +1037,8 @@ si_set_finalizer(cl_object o, cl_object finalizer) @(return); } +/* -- GC stats --------------------------------------------------------------- */ + /* If we do not build our own version of the library, we do not have * control over the existence of this variable. */ #if GBC_BOEHM == 0 @@ -1152,9 +1132,7 @@ update_bytes_consed () { #endif } -/********************************************************** - * GARBAGE COLLECTOR * - **********************************************************/ +/* -- garbage collection ----------------------------------------------------- */ static void ecl_mark_env(struct cl_env_struct *env) @@ -1169,7 +1147,8 @@ ecl_mark_env(struct cl_env_struct *env) #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)); + (void *)(env->bds_stack.tl_bindings + + env->bds_stack.tl_bindings_size)); #endif GC_push_all((void *)env, (void *)(env + 1)); } @@ -1203,10 +1182,6 @@ stacks_scanner() (*old_GC_push_other_roots)(); } -/********************************************************** - * GARBAGE COLLECTION * - **********************************************************/ - void ecl_register_root(cl_object *p) { @@ -1236,54 +1211,112 @@ si_gc_dump() @(return); } -/********************************************************************** - * WEAK POINTERS - */ +/* -- module definition ------------------------------------------------------ */ -cl_object -ecl_alloc_weak_pointer(cl_object o) +static cl_object +create_gc() { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_weak_pointer *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); - ecl_enable_interrupts_env(the_env); - obj->t = t_weak_pointer; - obj->value = o; - if (!ECL_IMMEDIATE(o)) { - GC_GENERAL_REGISTER_DISAPPEARING_LINK((void**)&(obj->value), (void*)o); - si_set_finalizer((cl_object)obj, ECL_T); + /* + * Garbage collector restrictions: we set up the garbage collector + * library to work as follows + * + * 1) The garbage collector shall not scan shared libraries + * explicitely. + * 2) We only detect objects that are referenced by a pointer to + * the begining or to the first byte. + * 3) Out of the incremental garbage collector, we only use the + * generational component. + * 4) GC should handle fork() which is used to run subprocess on + * some platforms. + */ + GC_set_no_dls(1); + GC_set_all_interior_pointers(0); + GC_set_time_limit(GC_TIME_UNLIMITED); +#ifndef ECL_MS_WINDOWS_HOST + GC_set_handle_fork(1); +#endif + GC_init(); +#ifdef ECL_THREADS +# if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1 + GC_allow_register_threads(); +# endif +#endif + if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { + GC_enable_incremental(); } - return (cl_object)obj; + GC_register_displacement(1); + GC_clear_roots(); + GC_disable(); + +#ifdef GBC_BOEHM_PRECISE +# ifdef GBC_BOEHM_OWN_MARKER + cl_object_free_list = (void **)GC_new_free_list_inner(); + cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); + cl_object_kind = GC_new_kind_inner(cl_object_free_list, + GC_MAKE_PROC(cl_object_mark_proc_index, 0), + FALSE, TRUE); +# endif +#endif /* !GBC_BOEHM_PRECISE */ + ecl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]; + GC_set_max_heap_size(ecl_core.max_heap_size); + /* Save some memory for the case we get tight. */ + if (ecl_core.max_heap_size == 0) { + cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (ecl_core.safety_region) { + ecl_core.safety_region = 0; + } + + init_type_info(); + + old_GC_push_other_roots = GC_push_other_roots; + GC_push_other_roots = stacks_scanner; + GC_old_start_callback = GC_get_start_callback(); + GC_set_start_callback(gather_statistics); + GC_set_java_finalization(1); + GC_set_oom_fn(out_of_memory); + GC_set_warn_proc(no_warnings); + + return ECL_NIL; } static cl_object -ecl_weak_pointer_value(cl_object o) +enable_gc () { - return ecl_weak_pointer(o); + GC_enable(); + return ECL_NIL; } -cl_object -si_make_weak_pointer(cl_object o) +static cl_object +disable_gc () { - cl_object pointer = ecl_alloc_weak_pointer(o); - @(return pointer); + GC_disable(); + return ECL_NIL; } -cl_object -si_weak_pointer_value(cl_object o) +static cl_object +init_cpu(cl_env_ptr the_env) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object value; - if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) - FEwrong_type_only_arg(@[ext::weak-pointer-value], o, - @[ext::weak-pointer]); - value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); - if (value) { - ecl_return2(the_env, value, ECL_T); - } else { - ecl_return2(the_env, ECL_NIL, ECL_NIL); - } +#ifdef GBC_BOEHM + struct GC_stack_base stack; + GC_get_stack_base(&stack); + the_env->c_stack.org = (char*)stack.mem_base; +#endif + return ECL_NIL; } -#endif /* GBC_BOEHM */ +ecl_def_ct_base_string(str_gc, "GC", 2, static, const); + +static struct ecl_module module_gc = { + .name = str_gc, + .create = create_gc, + .enable = enable_gc, + .init_env = ecl_module_no_op_env, + .init_cpu = init_cpu, + .free_cpu = ecl_module_no_op_cpu, + .free_env = ecl_module_no_op_env, + .disable = disable_gc, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_gc = (cl_object)&module_gc; diff --git a/src/c/process.d b/src/c/process.d index 094b567fe..89827f590 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -169,35 +169,18 @@ unregister_gc_thread() cl_env_ptr ecl_adopt_cpu() { - struct cl_env_struct env_aux[1]; - struct ecl_interrupt_struct int_aux[1]; cl_env_ptr the_env = ecl_process_env_unsafe(); ecl_thread_t current; if (the_env != NULL) return the_env; - /* Ensure that the thread is known to the GC. */ register_gc_thread(); ecl_set_process_self(current); - /* We need a fake env to allow for interrupts blocking and to set up frame - * stacks or other stuff that is needed by ecl_init_env. Since the fake env is - * allocated on the stack, we can safely store pointers to memory allocated by - * the gc there. */ - memset(env_aux, 0, sizeof(*env_aux)); - env_aux->disable_interrupts = 1; - env_aux->interrupt_struct = int_aux; - env_aux->interrupt_struct->pending_interrupt = ECL_NIL; - ecl_mutex_init(&env_aux->interrupt_struct->signal_queue_lock, FALSE); - env_aux->interrupt_struct->signal_queue = ECL_NIL; - ecl_set_process_env(env_aux); - env_aux->thread = current; - ecl_init_env(env_aux); - - /* Allocate, initialize and switch to the real environment. */ the_env = _ecl_alloc_env(0); - memcpy(the_env, env_aux, sizeof(*the_env)); + the_env->thread = current; + ecl_set_process_env(the_env); + ecl_init_env(the_env); add_env(the_env); init_tl_bindings(ECL_NIL, the_env); - ecl_set_process_env(the_env); ecl_modules_init_cpu(the_env); return the_env; @@ -254,7 +237,6 @@ thread_entry_point(void *ptr) CloseHandle(the_env->thread); #endif _ecl_dealloc_env(the_env); - #ifdef ECL_WINDOWS_THREADS return 1; #else @@ -354,6 +336,7 @@ init_process(void) ecl_core.threads = ecl_make_stack(16); #endif ecl_set_process_env(the_env); + the_env->c_stack.org = NULL; the_env->default_sigmask = NULL; the_env->method_cache = NULL; the_env->slot_cache = NULL; diff --git a/src/c/stacks.d b/src/c/stacks.d index d3a2c94eb..e2cf9a169 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -33,17 +33,11 @@ ecl_cs_init(cl_env_ptr env) 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 + if (env->c_stack.org == NULL) { + /* 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); -#else - /* Rough estimate. Not very safe. We assume that cl_boot() is invoked from the - * main() routine of the program. */ - env->c_stack.org = (char*)(&env); -#endif + } #ifdef ECL_CAN_SET_STACK_SIZE { struct rlimit rl; diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 4028059d3..7b266fa29 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -164,7 +164,9 @@ ecl_import_current_thread(cl_object name, cl_object bindings) cl_env_ptr the_env; if (ecl_process_env_unsafe() != NULL) return 0; + ecl_module_gc->module.disable(); the_env = ecl_adopt_cpu(); + ecl_module_gc->module.enable(); ecl_enable_interrupts_env(the_env); process = alloc_process(name, ECL_NIL); @@ -482,7 +484,6 @@ init_threads() cl_object process, _env = ecl_cast_ptr(cl_object,the_env); /* We have to set the environment before any allocation takes place, * so that the interrupt handling code works. */ - ecl_cs_init(the_env); process = ecl_alloc_object(t_process); process->process.phase = ECL_PROCESS_ACTIVE; process->process.name = @'si::top-level'; diff --git a/src/configure b/src/configure index f1ace37a3..174f9f2c8 100755 --- a/src/configure +++ b/src/configure @@ -7060,8 +7060,6 @@ fi if test ${enable_boehm} = "no" ; then as_fn_error $? "Boehm GC library is currently needed to build ECL" "$LINENO" 5; - EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}" - enable_smallcons="no" else @@ -7314,7 +7312,6 @@ printf "%s\n" "${system_boehm} " >&6; } fi else FASL_LIBS="${FASL_LIBS} -lgc" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" printf "%s\n" "#define GBC_BOEHM 1" >>confdefs.h @@ -7344,7 +7341,6 @@ printf "%s\n" "$as_me: Configuring included Boehm GC library:" >&6;} ECL_BOEHM_GC_HEADER='ecl/gc/gc.h' SUBDIRS="${SUBDIRS} gc" CORE_LIBS="-leclgc ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}" fi @@ -7492,7 +7488,6 @@ printf "%s\n" "$as_me: Configuring included libffi library:" >&6;} ECL_LIBFFI_HEADER='ecl/ffi.h' SUBDIRS="${SUBDIRS} libffi" CORE_LIBS="-leclffi ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}" fi diff --git a/src/configure.ac b/src/configure.ac index 309c03ea0..b72773b79 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -600,8 +600,6 @@ dnl ---------------------------------------------------------------------- dnl Boehm-Weiser garbage collector if test ${enable_boehm} = "no" ; then AC_MSG_ERROR([Boehm GC library is currently needed to build ECL]); - EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}" - enable_smallcons="no" else ECL_BOEHM_GC fi diff --git a/src/h/internal.h b/src/h/internal.h index d8a64c0b3..15b71b282 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -24,16 +24,13 @@ extern "C" { /* booting */ extern void init_all_symbols(void); -extern void init_alloc(int pass); extern void init_backq(void); extern void init_big(); extern void init_clos(void); extern void init_error(void); extern void init_eval(void); extern void init_file(void); -#ifndef GBC_BOEHM -extern void init_GC(void); -#endif +extern void init_gc(void); extern void init_macros(void); extern void init_read(void); @@ -54,7 +51,7 @@ extern void init_lib_LSP(cl_object); extern cl_env_ptr _ecl_alloc_env(cl_env_ptr parent); extern void _ecl_dealloc_env(cl_env_ptr); -/* alloc.d/alloc_2.d */ +/* mem_gc.d */ #ifdef GBC_BOEHM #define ECL_COMPACT_OBJECT_EXTRA(x) ((void*)((x)->array.displaced)) @@ -64,6 +61,10 @@ extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); extern cl_index ecl_object_byte_size(cl_type t); extern cl_index ecl_next_stamp(); +/* modules.c */ +extern ECL_API cl_object ecl_module_dummy; +extern ECL_API cl_object ecl_module_gc; + /* array.d */ #ifdef ECL_DEFINE_AET_SIZE -- GitLab From 4351ba6371037e1fd55ca4f8b27cd5839ac3957f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 3 Dec 2024 14:12:58 +0100 Subject: [PATCH 44/58] modules: [2/n] introduce ecl_module_unixint --- src/c/main.d | 45 +------------------ src/c/process.d | 4 -- src/c/unixint.d | 111 ++++++++++++++++++++++++++++++++++++++++++----- src/h/internal.h | 9 ++-- 4 files changed, 107 insertions(+), 62 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 42ee78ea7..dce567023 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -42,25 +42,6 @@ const char *ecl_self; static int ARGC; static char **ARGV; -static void -init_env_int(cl_env_ptr env) -{ - env->interrupt_struct = ecl_alloc(sizeof(*env->interrupt_struct)); - env->interrupt_struct->pending_interrupt = ECL_NIL; -#ifdef ECL_THREADS - ecl_mutex_init(&env->interrupt_struct->signal_queue_lock, FALSE); -#endif -#ifdef ECL_WINDOWS_THREADS - env->interrupt_struct->inside_interrupt = false; -#endif - { - int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; - env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); - } - env->fault_address = env; - env->trap_fpe_bits = 0; -} - static void init_env_ffi(cl_env_ptr env) { @@ -99,7 +80,6 @@ ecl_init_first_env(cl_env_ptr the_env) init_threads(); #endif ecl_cs_init(the_env); - init_env_int(the_env); init_env_aux(the_env); init_env_ffi(the_env); init_stacks(the_env); @@ -109,7 +89,6 @@ void ecl_init_env(cl_env_ptr env) { ecl_modules_init_env(env); - init_env_int(env); init_env_aux(env); init_env_ffi(env); init_stacks(env); @@ -121,9 +100,6 @@ _ecl_dealloc_env(cl_env_ptr env) env->own_process = ECL_NIL; ecl_modules_free_env(env); free_stacks(env); -#ifdef ECL_THREADS - ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock); -#endif #if defined(ECL_USE_MPROTECT) if (munmap(env, sizeof(*env))) ecl_internal_error("Unable to deallocate environment structure."); @@ -175,27 +151,10 @@ _ecl_alloc_env(cl_env_ptr parent) #endif output->own_process = ECL_NIL; output->c_stack.org = NULL; - { - size_t bytes = ecl_core.default_sigmask_bytes; - if (bytes == 0) { - output->default_sigmask = 0; - } else if (parent) { - output->default_sigmask = ecl_alloc_atomic(bytes); - memcpy(output->default_sigmask, parent->default_sigmask, bytes); - } else { - output->default_sigmask = ecl_core.first_env->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; - /* - * An uninitialized environment _always_ disables interrupts. They - * are activated later on by the thread entry point or init_unixint(). - */ - output->disable_interrupts = 1; return output; } @@ -329,8 +288,8 @@ cl_boot(int argc, char **argv) ecl_self = argv[0]; ecl_add_module(ecl_module_gc); + ecl_add_module(ecl_module_unixint); - init_unixint(0); init_big(); /* @@ -610,7 +569,7 @@ cl_boot(int argc, char **argv) /* Jump to top level */ ECL_SET(@'*package*', cl_core.user_package); - init_unixint(1); + ecl_module_unixint->module.enable(); return 1; } diff --git a/src/c/process.d b/src/c/process.d index 89827f590..496598dda 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -192,7 +192,6 @@ ecl_disown_cpu() cl_env_ptr the_env = ecl_process_env_unsafe(); if (the_env == NULL) return; - ecl_disable_interrupts_env(the_env); ecl_modules_free_cpu(the_env); #ifdef ECL_WINDOWS_THREADS CloseHandle(the_env->thread); @@ -337,9 +336,6 @@ init_process(void) #endif ecl_set_process_env(the_env); the_env->c_stack.org = NULL; - the_env->default_sigmask = NULL; the_env->method_cache = NULL; the_env->slot_cache = NULL; - the_env->interrupt_struct = NULL; - the_env->disable_interrupts = 1; } diff --git a/src/c/unixint.d b/src/c/unixint.d index dc385e30b..4f75f73c1 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -1482,17 +1482,108 @@ create_signal_code_constants() #endif } -void -init_unixint(int pass) +/* -- module definition ------------------------------------------------------ */ + +static cl_object +create_unixint() { - if (pass == 0) { - install_asynchronous_signal_handlers(); - install_synchronous_signal_handlers(); + cl_env_ptr the_env = ecl_core.first_env; + the_env->default_sigmask = NULL; + the_env->interrupt_struct = NULL; + ecl_disable_interrupts_env(the_env); + /* Install handlers */ + install_asynchronous_signal_handlers(); + install_synchronous_signal_handlers(); + return ECL_NIL; +} + +static cl_object +enable_unixint() +{ + create_signal_code_constants(); + install_fpe_signal_handlers(); + install_signal_handling_thread(); + ECL_SET(@'ext::*interrupts-enabled*', ECL_T); + ecl_process_env()->disable_interrupts = 0; + return ECL_NIL; +} + +static cl_object +init_env_unixint(cl_env_ptr the_env) +{ + cl_env_ptr parent_env = ecl_process_env_unsafe(); + size_t bytes = ecl_core.default_sigmask_bytes; + if (bytes == 0) { + the_env->default_sigmask = 0; + } else if (parent_env) { + the_env->default_sigmask = ecl_alloc_atomic(bytes); + memcpy(the_env->default_sigmask, parent_env->default_sigmask, bytes); } else { - create_signal_code_constants(); - install_fpe_signal_handlers(); - install_signal_handling_thread(); - ECL_SET(@'ext::*interrupts-enabled*', ECL_T); - ecl_process_env()->disable_interrupts = 0; + the_env->default_sigmask = ecl_core.first_env->default_sigmask; + } + the_env->interrupt_struct = ecl_alloc(sizeof(*the_env->interrupt_struct)); + the_env->interrupt_struct->pending_interrupt = ECL_NIL; +#ifdef ECL_THREADS + ecl_mutex_init(&the_env->interrupt_struct->signal_queue_lock, FALSE); +#endif +#ifdef ECL_WINDOWS_THREADS + the_env->interrupt_struct->inside_interrupt = false; +#endif + { + int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; + the_env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); } + the_env->fault_address = the_env; + the_env->trap_fpe_bits = 0; + /* An fresh environment _always_ disables interrupts. They are activated later + * on by the thread entry point or ecl_module_unixint. */ + ecl_disable_interrupts_env(the_env); + return ECL_NIL; } + +static cl_object +init_cpu_unixint(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +free_cpu_unixint(cl_env_ptr the_env) +{ + ecl_disable_interrupts_env(the_env); + return ECL_NIL; +} + +static cl_object +free_env_unixint(cl_env_ptr the_env) +{ +#ifdef ECL_THREADS + ecl_mutex_destroy(&the_env->interrupt_struct->signal_queue_lock); +#endif + return ECL_NIL; +} + +/* KLUDGE UNIXINT and MEM_GC are interwened - GC expects stop_world to work and + unixint relies on the GC to allocate its internal structures. + + When we start add MEM_GC module before UNIXINT and enable GC after both are + created. That is enough to get GC going. Finally we enable UNIXINT. + + When we adopt a new cpu we first disable MEM_GC, then initialize UNIXINT + (allocator works fine despite GC collector being disabled), then initialize + GC to register the current thread and enable the GC. -- jd 2024-12-05 */ + +ecl_def_ct_base_string(str_unixint, "UNIXINT", 7, static, const); +static struct ecl_module module_unixint = { + .name = str_unixint, + .create = create_unixint, + .enable = enable_unixint, + .init_env = init_env_unixint, + .init_cpu = init_cpu_unixint, + .free_cpu = free_cpu_unixint, + .free_env = free_env_unixint, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_unixint = (cl_object)&module_unixint; diff --git a/src/h/internal.h b/src/h/internal.h index 15b71b282..5ead66672 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -23,6 +23,10 @@ extern "C" { #define unlikely_if(x) if (ecl_unlikely(x)) /* booting */ +extern ECL_API cl_object ecl_module_dummy; +extern ECL_API cl_object ecl_module_gc; +extern ECL_API cl_object ecl_module_unixint; + extern void init_all_symbols(void); extern void init_backq(void); extern void init_big(); @@ -37,7 +41,6 @@ extern void init_read(void); 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); extern void init_process(void); @@ -61,10 +64,6 @@ extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); extern cl_index ecl_object_byte_size(cl_type t); extern cl_index ecl_next_stamp(); -/* modules.c */ -extern ECL_API cl_object ecl_module_dummy; -extern ECL_API cl_object ecl_module_gc; - /* array.d */ #ifdef ECL_DEFINE_AET_SIZE -- GitLab From f008aa1a4e16d426461b6d3679eed5f174264cbb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 3 Dec 2024 14:57:39 +0100 Subject: [PATCH 45/58] modules: [3/n] introduce ecl_module_process --- src/c/boot.d | 4 --- src/c/main.d | 3 +-- src/c/process.d | 66 +++++++++++++++++++++++++++++++++++++----------- src/h/internal.h | 1 + 4 files changed, 53 insertions(+), 21 deletions(-) diff --git a/src/c/boot.d b/src/c/boot.d index 0f9cbcd5d..f99014219 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -178,11 +178,7 @@ ecl_boot(void) } return 1; } - init_process(); init_modules(); - /* init_unixint(); */ - /* init_garbage(); */ - ecl_core.path_max = MAXPATHLEN; return 0; diff --git a/src/c/main.d b/src/c/main.d index dce567023..99180bd5d 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -97,7 +97,6 @@ ecl_init_env(cl_env_ptr env) void _ecl_dealloc_env(cl_env_ptr env) { - env->own_process = ECL_NIL; ecl_modules_free_env(env); free_stacks(env); #if defined(ECL_USE_MPROTECT) @@ -149,7 +148,6 @@ _ecl_alloc_env(cl_env_ptr parent) output->bds_stack.tl_bindings_size = 0; output->bds_stack.tl_bindings = NULL; #endif - output->own_process = ECL_NIL; output->c_stack.org = NULL; for (cl_index i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { output->big_register[i] = ECL_NIL; @@ -287,6 +285,7 @@ cl_boot(int argc, char **argv) ARGV = argv; ecl_self = argv[0]; + ecl_add_module(ecl_module_process); ecl_add_module(ecl_module_gc); ecl_add_module(ecl_module_unixint); diff --git a/src/c/process.d b/src/c/process.d index 496598dda..0cc7f2822 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -196,7 +196,6 @@ ecl_disown_cpu() #ifdef ECL_WINDOWS_THREADS CloseHandle(the_env->thread); #endif - ecl_set_process_env(NULL); del_env(the_env); _ecl_dealloc_env(the_env); unregister_gc_thread(); @@ -212,7 +211,6 @@ thread_entry_point(void *ptr) cl_env_ptr the_env = ecl_cast_ptr(cl_env_ptr, ptr); cl_object process = the_env->own_process; /* Setup the environment for the execution of the thread. */ - ecl_set_process_env(the_env); ecl_modules_init_cpu(the_env); ecl_cs_init(the_env); @@ -228,8 +226,6 @@ thread_entry_point(void *ptr) * mp_interrupt_process() and mp_process_kill(). */ ecl_disable_interrupts_env(the_env); - ecl_set_process_env(NULL); - the_env->own_process = ECL_NIL; ecl_modules_free_cpu(the_env); del_env(the_env); #ifdef ECL_WINDOWS_THREADS @@ -317,16 +313,11 @@ ecl_spawn_cpu(cl_object process) } #endif -/* -- Initialiation --------------------------------------------------------- */ - -void -init_process(void) +/* -- Module definition (so meta!) ------------------------------------------ */ +static cl_object +create_process() { - cl_env_ptr the_env = ecl_core.first_env; #ifdef ECL_THREADS - ecl_thread_t main_thread; - ecl_set_process_self(main_thread); - the_env->thread = main_thread; ecl_process_key_create(cl_env_key); ecl_mutex_init(&ecl_core.processes_lock, 1); ecl_mutex_init(&ecl_core.global_lock, 1); @@ -334,8 +325,53 @@ init_process(void) ecl_rwlock_init(&ecl_core.global_env_lock); ecl_core.threads = ecl_make_stack(16); #endif + return ECL_NIL; +} + +static cl_object +init_env_process(cl_env_ptr the_env) +{ +#ifdef ECL_THREAD + the_env->own_process = ECL_NIL; +#endif + return ECL_NIL; +} + +static cl_object +init_cpu_process(cl_env_ptr the_env) +{ ecl_set_process_env(the_env); - the_env->c_stack.org = NULL; - the_env->method_cache = NULL; - the_env->slot_cache = NULL; + return ECL_NIL; } + +static cl_object +free_cpu_process(cl_env_ptr the_env) +{ + ecl_set_process_env(NULL); + return ECL_NIL; +} + +static cl_object +free_env_process(cl_env_ptr the_env) +{ +#ifdef ECL_THREAD + the_env->own_process = ECL_NIL; +#endif + return ECL_NIL; +} + +ecl_def_ct_base_string(str_process, "PROCESS", 7, static, const); + +static struct ecl_module module_process = { + .name = str_process, + .create = create_process, + .enable = ecl_module_no_op, + .init_env = init_env_process, + .init_cpu = init_cpu_process, + .free_cpu = free_cpu_process, + .free_env = free_env_process, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_process = (cl_object)&module_process; diff --git a/src/h/internal.h b/src/h/internal.h index 5ead66672..85469d3b7 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -23,6 +23,7 @@ extern "C" { #define unlikely_if(x) if (ecl_unlikely(x)) /* booting */ +extern ECL_API cl_object ecl_module_process; extern ECL_API cl_object ecl_module_dummy; extern ECL_API cl_object ecl_module_gc; extern ECL_API cl_object ecl_module_unixint; -- GitLab From dfd99e0e16a681a7e03acaebb7bf7d93fed4fb56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 4 Dec 2024 22:49:57 +0100 Subject: [PATCH 46/58] modules: [4/n] introduce ecl_module_bignum --- src/c/big.d | 58 +++++++++++++++++++++++++++++------------- src/c/main.d | 9 +------ src/c/threads/thread.d | 1 - src/c/unixint.d | 24 ++++++++--------- src/h/internal.h | 5 ++-- 5 files changed, 57 insertions(+), 40 deletions(-) diff --git a/src/c/big.d b/src/c/big.d index 5ea01ea22..9a69931cd 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -14,10 +14,13 @@ */ #define ECL_INCLUDE_MATH_H -#include -#include #include +#include #include +#include + +#include +#include /************************************************************* * MEMORY MANAGEMENT WITH GMP @@ -326,22 +329,20 @@ _ecl_fix_divided_by_big(cl_fixnum x, cl_object y) static void * mp_alloc(size_t size) { - return ecl_alloc_uncollectable(size); + return ecl_malloc(size); } static void mp_free(void *ptr, size_t size) { - ecl_free_uncollectable(ptr); + ecl_free(ptr); } static void * mp_realloc(void *ptr, size_t osize, size_t nsize) { - mp_limb_t *p = mp_alloc(nsize); - memcpy(p, ptr, (osize < nsize)? osize : nsize); - mp_free(ptr, osize); - return p; + ptr = ecl_realloc(ptr, osize, nsize); + return ptr; } #ifdef ECL_GMP_FIXNUM_TO_LIMBS @@ -607,29 +608,52 @@ _ecl_big_boole_operator(int op) return bignum_operations[op]; } -void +/* -- module definition ------------------------------------------------------ */ + +static cl_object +create_bignum () +{ + if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS]) + mp_set_memory_functions(mp_alloc, mp_realloc, mp_free); + return ECL_NIL; +} + +cl_object ecl_init_bignum_registers(cl_env_ptr env) { int i; for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { + /* INV this implies the standard allocator already initialized. */ cl_object x = ecl_alloc_object(t_bignum); _ecl_big_init2(x, ECL_BIG_REGISTER_SIZE); env->big_register[i] = x; } + return ECL_NIL; } -void -ecl_clear_bignum_registers(cl_env_ptr env) +cl_object +ecl_free_bignum_registers(cl_env_ptr env) { int i; for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { _ecl_big_clear(env->big_register[i]); + env->big_register[i] = ECL_NIL; } + return ECL_NIL; } -void -init_big() -{ - if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS]) - mp_set_memory_functions(mp_alloc, mp_realloc, mp_free); -} +ecl_def_ct_base_string(str_bignum, "BIGNUM", 6, static, const); + +static struct ecl_module module_bignum = { + .name = str_bignum, + .create = create_bignum, + .enable = ecl_module_no_op, + .init_env = ecl_init_bignum_registers, + .init_cpu = ecl_module_no_op_cpu, + .free_cpu = ecl_module_no_op_cpu, + .free_env = ecl_free_bignum_registers, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_bignum = (cl_object)&module_bignum; diff --git a/src/c/main.d b/src/c/main.d index 99180bd5d..1344add0e 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -64,8 +64,6 @@ init_env_aux(cl_env_ptr env) #if !defined(ECL_CMU_FORMAT) env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); #endif - /* Bignum arithmetic */ - ecl_init_bignum_registers(env); /* Bytecodes compiler environment */ env->c_env = NULL; /* CLOS caches */ @@ -106,7 +104,6 @@ _ecl_dealloc_env(cl_env_ptr env) if (!VirtualFree(env, 0, MEM_RELEASE)) ecl_internal_error("Unable to deallocate environment structure."); #else - ecl_clear_bignum_registers(env); ecl_free_unsafe(env); #endif } @@ -149,9 +146,6 @@ _ecl_alloc_env(cl_env_ptr parent) output->bds_stack.tl_bindings = NULL; #endif output->c_stack.org = NULL; - for (cl_index i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { - output->big_register[i] = ECL_NIL; - } output->method_cache = output->slot_cache = NULL; return output; } @@ -288,8 +282,7 @@ cl_boot(int argc, char **argv) ecl_add_module(ecl_module_process); ecl_add_module(ecl_module_gc); ecl_add_module(ecl_module_unixint); - - init_big(); + ecl_add_module(ecl_module_bignum); /* * Initialize the per-thread data. diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 7b266fa29..d770b2533 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -115,7 +115,6 @@ run_process(cl_narg narg, ...) } ECL_CATCH_ALL_END; ecl_disable_interrupts_env(the_env); - ecl_clear_bignum_registers(the_env); ecl_mutex_lock(&process->process.start_stop_lock); process->process.phase = ECL_PROCESS_EXITING; diff --git a/src/c/unixint.d b/src/c/unixint.d index 4f75f73c1..b8e50a525 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -366,15 +366,14 @@ handle_all_queued(cl_env_ptr env) static void handle_all_queued_interrupt_safe(cl_env_ptr env) { - /* We have to save and later restore thread-local variables to - * ensure that they don't get overwritten by the interrupting - * code */ - /* INV: - IHS stack manipulations are interrupt safe - * - The rest of the thread local variables are - * guaranteed to be used in an interrupt safe way. This - * is not true for the compiler environment and ffi - * data, but it is unclear whether the DFFI or compiler - * are thread safe anyway. */ + /* We have to save and later restore thread-local variables to ensure that + * they don't get overwritten by the interrupting code. */ + /* FIXME introduce save/load procedure in modules. */ + /* INV IHS stack manipulations are interrupt safe; the rest of the thread + * local variables are guaranteed to be used in an interrupt safe way[1]. + * + * [1] This is not true for the compiler environment and ffi data, but it is + * unclear whether the DFFI or the compiler are thread safe anyway. */ cl_object fun = env->function; cl_index nvalues = env->nvalues; cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; @@ -387,7 +386,8 @@ handle_all_queued_interrupt_safe(cl_env_ptr env) * not init and clear them before calling the interrupting * code we would risk memory leaks. */ cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER]; - memcpy(big_register, env->big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object)); + cl_index big_register_size = ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object); + ecl_copy(big_register, env->big_register, big_register_size); ecl_init_bignum_registers(env); /* 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 @@ -407,8 +407,8 @@ handle_all_queued_interrupt_safe(cl_env_ptr env) memcpy(env->bds_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame)); memcpy(env->frs_stack.top+1, &top_frame, sizeof(struct ecl_frame)); env->run_stack.top--; - ecl_clear_bignum_registers(env); - memcpy(env->big_register, big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object)); + ecl_free_bignum_registers(env); + ecl_copy(env->big_register, big_register, big_register_size); env->packages_to_be_created_p = packages_to_be_created_p; env->packages_to_be_created = packages_to_be_created; env->stack_frame = stack_frame; diff --git a/src/h/internal.h b/src/h/internal.h index 85469d3b7..5511a644e 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -27,6 +27,7 @@ extern ECL_API cl_object ecl_module_process; extern ECL_API cl_object ecl_module_dummy; extern ECL_API cl_object ecl_module_gc; extern ECL_API cl_object ecl_module_unixint; +extern ECL_API cl_object ecl_module_bignum; extern void init_all_symbols(void); extern void init_backq(void); @@ -484,8 +485,8 @@ extern cl_object _ecl_long_double_to_integer(long double d); extern cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1]; -extern void ecl_init_bignum_registers(cl_env_ptr env); -extern void ecl_clear_bignum_registers(cl_env_ptr env); +extern cl_object ecl_init_bignum_registers(cl_env_ptr env); +extern cl_object ecl_free_bignum_registers(cl_env_ptr env); /* threads/mutex.d */ -- GitLab From 2a5c8a4598db6d3e6210f9d86ffa1f1aaf06f25e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 3 Dec 2024 09:53:28 +0100 Subject: [PATCH 47/58] modules: [5/n] introduce ecl_module_ffi --- src/c/ffi.d | 30 ++++++++++++++++++++++++++++++ src/c/main.d | 14 +------------- src/h/internal.h | 1 + 3 files changed, 32 insertions(+), 13 deletions(-) diff --git a/src/c/ffi.d b/src/c/ffi.d index acf6fd459..44e4bd0a0 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -13,6 +13,7 @@ #include #define ECL_INCLUDE_FFI_H #include +#include #include static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = { @@ -1019,3 +1020,32 @@ si_free_ffi_closure(cl_object closure) @(return closure_object); } @) #endif /* HAVE_LIBFFI */ + +/* -- Module definition ------------------------------------------------------ */ +static cl_object +init_env_ffi(cl_env_ptr the_env) +{ +#ifdef HAVE_LIBFFI + the_env->ffi_args_limit = 0; + the_env->ffi_types = 0; + the_env->ffi_values = 0; + the_env->ffi_values_ptrs = 0; +#endif + return ECL_NIL; +} + +ecl_def_ct_base_string(str_ffi, "FFI", 3, static, const); + +static struct ecl_module module_ffi = { + .name = str_ffi, + .create = ecl_module_no_op, + .enable = ecl_module_no_op, + .init_env = init_env_ffi, + .init_cpu = ecl_module_no_op_cpu, + .free_cpu = ecl_module_no_op_cpu, + .free_env = ecl_module_no_op_env, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_ffi = (cl_object)&module_ffi; diff --git a/src/c/main.d b/src/c/main.d index 1344add0e..67552e8f8 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -42,17 +42,6 @@ const char *ecl_self; static int ARGC; static char **ARGV; -static void -init_env_ffi(cl_env_ptr env) -{ -#ifdef HAVE_LIBFFI - env->ffi_args_limit = 0; - env->ffi_types = 0; - env->ffi_values = 0; - env->ffi_values_ptrs = 0; -#endif -} - static void init_env_aux(cl_env_ptr env) { @@ -79,7 +68,6 @@ ecl_init_first_env(cl_env_ptr the_env) #endif ecl_cs_init(the_env); init_env_aux(the_env); - init_env_ffi(the_env); init_stacks(the_env); } @@ -88,7 +76,6 @@ ecl_init_env(cl_env_ptr env) { ecl_modules_init_env(env); init_env_aux(env); - init_env_ffi(env); init_stacks(env); } @@ -283,6 +270,7 @@ cl_boot(int argc, char **argv) ecl_add_module(ecl_module_gc); ecl_add_module(ecl_module_unixint); ecl_add_module(ecl_module_bignum); + ecl_add_module(ecl_module_ffi); /* * Initialize the per-thread data. diff --git a/src/h/internal.h b/src/h/internal.h index 5511a644e..c8e21a2a3 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -28,6 +28,7 @@ extern ECL_API cl_object ecl_module_dummy; extern ECL_API cl_object ecl_module_gc; extern ECL_API cl_object ecl_module_unixint; extern ECL_API cl_object ecl_module_bignum; +extern ECL_API cl_object ecl_module_ffi; extern void init_all_symbols(void); extern void init_backq(void); -- GitLab From ccd062f88933629ba58b0d73652dfa79017b120d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 3 Dec 2024 10:00:55 +0100 Subject: [PATCH 48/58] modules: [6/n] introduce ecl_module_aux --- src/c/main.d | 66 +++++++++++++++++++++++++++++++++--------------- src/h/internal.h | 1 + 2 files changed, 46 insertions(+), 21 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 67552e8f8..5ab81a9f8 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -42,24 +42,6 @@ const char *ecl_self; static int ARGC; static char **ARGV; -static void -init_env_aux(cl_env_ptr env) -{ - /* Reader */ - env->string_pool = ECL_NIL; - env->packages_to_be_created = ECL_NIL; - env->packages_to_be_created_p = ECL_NIL; - /* Format (written in C) */ -#if !defined(ECL_CMU_FORMAT) - env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); -#endif - /* Bytecodes compiler environment */ - env->c_env = NULL; - /* CLOS caches */ - env->method_cache = ecl_make_cache(64, 4096); - env->slot_cache = ecl_make_cache(3, 4096); -} - void ecl_init_first_env(cl_env_ptr the_env) { @@ -67,7 +49,6 @@ ecl_init_first_env(cl_env_ptr the_env) init_threads(); #endif ecl_cs_init(the_env); - init_env_aux(the_env); init_stacks(the_env); } @@ -75,7 +56,6 @@ void ecl_init_env(cl_env_ptr env) { ecl_modules_init_env(env); - init_env_aux(env); init_stacks(env); } @@ -133,7 +113,6 @@ _ecl_alloc_env(cl_env_ptr parent) output->bds_stack.tl_bindings = NULL; #endif output->c_stack.org = NULL; - output->method_cache = output->slot_cache = NULL; return output; } @@ -271,6 +250,7 @@ cl_boot(int argc, char **argv) ecl_add_module(ecl_module_unixint); ecl_add_module(ecl_module_bignum); ecl_add_module(ecl_module_ffi); + ecl_add_module(ecl_module_aux); /* * Initialize the per-thread data. @@ -553,6 +533,50 @@ cl_boot(int argc, char **argv) return 1; } +/* -- Module definition (auxiliary structures) ------------------------------- */ +static cl_object +create_aux() +{ + cl_env_ptr the_env = ecl_core.first_env; + the_env->method_cache = NULL; + the_env->slot_cache = NULL; + return ECL_NIL; +} + +static cl_object +init_env_aux(cl_env_ptr the_env) +{ + /* Reader */ + the_env->string_pool = ECL_NIL; + the_env->packages_to_be_created = ECL_NIL; + the_env->packages_to_be_created_p = ECL_NIL; + /* Format (written in C) */ +#if !defined(ECL_CMU_FORMAT) + the_env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); +#endif + /* Bytecodes compiler environment */ + the_env->c_env = NULL; + /* CLOS caches */ + the_env->method_cache = ecl_make_cache(64, 4096); + the_env->slot_cache = ecl_make_cache(3, 4096); + return ECL_NIL; +} + +ecl_def_ct_base_string(str_aux, "AUX", 3, static, const); + +static struct ecl_module module_aux = { + .name = str_aux, + .create = create_aux, + .enable = ecl_module_no_op, + .init_env = init_env_aux, + .init_cpu = ecl_module_no_op_env, + .free_cpu = ecl_module_no_op_cpu, + .free_env = ecl_module_no_op_env, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; +cl_object ecl_module_aux = (cl_object)&module_aux; + /************************* ENVIRONMENT ROUTINES ***********************/ @(defun ext::quit (&optional (code ecl_make_fixnum(0)) (kill_all_threads ECL_T)) diff --git a/src/h/internal.h b/src/h/internal.h index c8e21a2a3..c68e6d906 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -29,6 +29,7 @@ extern ECL_API cl_object ecl_module_gc; extern ECL_API cl_object ecl_module_unixint; extern ECL_API cl_object ecl_module_bignum; extern ECL_API cl_object ecl_module_ffi; +extern ECL_API cl_object ecl_module_aux; extern void init_all_symbols(void); extern void init_backq(void); -- GitLab From f0c0e2f9535a9a02da475938806be07e626b6c2d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 15 May 2025 11:06:58 +0200 Subject: [PATCH 49/58] modules: [7/n] introduce ecl_module_stacks --- src/c/main.d | 11 ++----- src/c/process.d | 5 +--- src/c/stacks.d | 75 ++++++++++++++++++++++++++++++++++++------------ src/h/internal.h | 5 +--- 4 files changed, 61 insertions(+), 35 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 5ab81a9f8..6aba07d36 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -48,22 +48,18 @@ ecl_init_first_env(cl_env_ptr the_env) #ifdef ECL_THREADS init_threads(); #endif - ecl_cs_init(the_env); - init_stacks(the_env); } void ecl_init_env(cl_env_ptr env) { ecl_modules_init_env(env); - init_stacks(env); } void _ecl_dealloc_env(cl_env_ptr env) { ecl_modules_free_env(env); - free_stacks(env); #if defined(ECL_USE_MPROTECT) if (munmap(env, sizeof(*env))) ecl_internal_error("Unable to deallocate environment structure."); @@ -108,11 +104,7 @@ _ecl_alloc_env(cl_env_ptr parent) # endif #endif /* Initialize the structure with NULL data. */ -#if defined(ECL_THREADS) - output->bds_stack.tl_bindings_size = 0; - output->bds_stack.tl_bindings = NULL; -#endif - output->c_stack.org = NULL; + memset(output, 0, sizeof(*output)); return output; } @@ -246,6 +238,7 @@ cl_boot(int argc, char **argv) ecl_self = argv[0]; ecl_add_module(ecl_module_process); + ecl_add_module(ecl_module_stacks); ecl_add_module(ecl_module_gc); ecl_add_module(ecl_module_unixint); ecl_add_module(ecl_module_bignum); diff --git a/src/c/process.d b/src/c/process.d index 0cc7f2822..6d220a07b 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -212,10 +212,8 @@ thread_entry_point(void *ptr) cl_object process = the_env->own_process; /* Setup the environment for the execution of the thread. */ ecl_modules_init_cpu(the_env); - ecl_cs_init(the_env); - + /* Start the user routine */ process->process.entry(0); - /* This routine performs some cleanup before a thread is completely * killed. For instance, it has to remove the associated process object from * the list, an it has to dealloc some memory. @@ -224,7 +222,6 @@ thread_entry_point(void *ptr) * that all UNWIND-PROTECT forms are properly executed, never use the function * pthread_cancel() to kill a process, but rather use the lisp functions * mp_interrupt_process() and mp_process_kill(). */ - ecl_disable_interrupts_env(the_env); ecl_modules_free_cpu(the_env); del_env(the_env); diff --git a/src/c/stacks.d b/src/c/stacks.d index e2cf9a169..77951a96f 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -650,35 +650,57 @@ frs_sch (cl_object frame_id) return(NULL); } -/* -- Initialization -------------------------------------------------------- */ -cl_object -init_stacks(cl_env_ptr the_env) +/* -- Module definition ------------------------------------------------------ */ + +static cl_object +create_stacks() { + cl_env_ptr the_env = ecl_core.first_env; #ifdef ECL_THREADS - if (the_env == ecl_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; + 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 + the_env->c_stack.org = NULL; + return ECL_NIL; +} + +static cl_object +enable_stacks() +{ + return ECL_NIL; +} + +static cl_object +init_env_stacks(cl_env_ptr the_env) +{ 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 + the_env->c_stack.org = NULL; return ECL_NIL; } -cl_object -free_stacks(cl_env_ptr the_env) +static cl_object +init_cpu_stacks(cl_env_ptr the_env) +{ + ecl_cs_init(the_env); + return ECL_NIL; +} + +static cl_object +free_cpu_stacks(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +free_env_stacks(cl_env_ptr the_env) { #ifdef ECL_THREADS ecl_free(the_env->bds_stack.tl_bindings); @@ -690,6 +712,22 @@ free_stacks(cl_env_ptr the_env) return ECL_NIL; } +ecl_def_ct_base_string(str_stacks, "STACKS", 6, static, const); + +static struct ecl_module module_stacks = { + .name = str_stacks, + .create = create_stacks, + .enable = enable_stacks, + .init_env = init_env_stacks, + .init_cpu = init_cpu_stacks, + .free_cpu = free_cpu_stacks, + .free_env = free_env_stacks, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_stacks = (cl_object)&module_stacks; + /* -- High level interface -------------------------------------------------- */ void @@ -1029,3 +1067,4 @@ si_get_limit(cl_object type) ecl_return1(env, ecl_make_unsigned_integer(output)); } + diff --git a/src/h/internal.h b/src/h/internal.h index c68e6d906..5046d3a73 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -24,6 +24,7 @@ extern "C" { /* booting */ extern ECL_API cl_object ecl_module_process; +extern ECL_API cl_object ecl_module_stacks; extern ECL_API cl_object ecl_module_dummy; extern ECL_API cl_object ecl_module_gc; extern ECL_API cl_object ecl_module_unixint; @@ -41,10 +42,6 @@ extern void init_file(void); extern void init_gc(void); extern void init_macros(void); extern void init_read(void); - -extern cl_object init_stacks(cl_env_ptr); -extern cl_object free_stacks(cl_env_ptr); - extern void init_unixtime(void); extern void init_compiler(void); extern void init_process(void); -- GitLab From 802a1c152b28f719694d34e1fd657ba28f08e3f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 3 Dec 2024 11:20:19 +0100 Subject: [PATCH 50/58] modules: [9/n] introduce ecl_module_thread --- src/c/main.d | 12 +++------ src/c/threads/thread.d | 56 ++++++++++++++++++++++++++++++++++++++++-- src/h/internal.h | 6 ++--- 3 files changed, 60 insertions(+), 14 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 6aba07d36..7cee491b2 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -42,14 +42,6 @@ const char *ecl_self; static int ARGC; static char **ARGV; -void -ecl_init_first_env(cl_env_ptr the_env) -{ -#ifdef ECL_THREADS - init_threads(); -#endif -} - void ecl_init_env(cl_env_ptr env) { @@ -241,6 +233,9 @@ cl_boot(int argc, char **argv) ecl_add_module(ecl_module_stacks); ecl_add_module(ecl_module_gc); ecl_add_module(ecl_module_unixint); +#ifdef ECL_THREADS + ecl_add_module(ecl_module_thread); +#endif ecl_add_module(ecl_module_bignum); ecl_add_module(ecl_module_ffi); ecl_add_module(ecl_module_aux); @@ -252,7 +247,6 @@ cl_boot(int argc, char **argv) */ env = ecl_core.first_env; - ecl_init_first_env(env); /* We need to enable GC because a lot of stuff is to be created */ ecl_module_gc->module.enable(); diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index d770b2533..6f82d7ceb 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -474,12 +474,17 @@ mp_restore_signals(cl_object sigmask) #endif } -/* -- Initialization ------------------------------------------------ */ +/* -- Module definition --------------------------------------------- */ void init_threads() { - cl_env_ptr the_env = ecl_process_env(); +} + +static cl_object +create_thread() +{ + cl_env_ptr the_env = ecl_core.first_env; cl_object process, _env = ecl_cast_ptr(cl_object,the_env); /* We have to set the environment before any allocation takes place, * so that the interrupt handling code works. */ @@ -493,4 +498,51 @@ init_threads() ecl_cond_var_init(&process->process.exit_barrier); the_env->own_process = process; ecl_stack_push(ecl_core.threads, _env); + return ECL_NIL; +} + +static cl_object +enable_thread() +{ + return ECL_NIL; +} + +static cl_object +init_env_thread(cl_env_ptr the_env) +{ + return ECL_NIL; } + +static cl_object +init_cpu_thread(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +free_cpu_thread(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +free_env_thread(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +ecl_def_ct_base_string(str_thread, "THREAD", 6, static, const); + +static struct ecl_module module_thread = { + .name = str_thread, + .create = create_thread, + .enable = enable_thread, + .init_env = init_env_thread, + .init_cpu = init_cpu_thread, + .free_cpu = free_cpu_thread, + .free_env = free_env_thread, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_thread = (cl_object)&module_thread; diff --git a/src/h/internal.h b/src/h/internal.h index 5046d3a73..efce62e83 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -28,6 +28,9 @@ extern ECL_API cl_object ecl_module_stacks; extern ECL_API cl_object ecl_module_dummy; extern ECL_API cl_object ecl_module_gc; extern ECL_API cl_object ecl_module_unixint; +#ifdef ECL_THREADS +extern ECL_API cl_object ecl_module_thread; +#endif extern ECL_API cl_object ecl_module_bignum; extern ECL_API cl_object ecl_module_ffi; extern ECL_API cl_object ecl_module_aux; @@ -46,9 +49,6 @@ extern void init_unixtime(void); extern void init_compiler(void); extern void init_process(void); extern void init_modules(void); -#ifdef ECL_THREADS -extern void init_threads(void); -#endif extern void ecl_init_env(cl_env_ptr); extern void init_lib_LSP(cl_object); -- GitLab From 608a361344093c8f78948379bbb25ed7e9e27613 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 15 May 2025 11:08:05 +0200 Subject: [PATCH 51/58] modules: [A/n] move the environment allocators to nucleus Also clean up initialization code across different paths to have the same order. --- src/c/boot.d | 97 ++++++++++++++++++++++++++++++++++++++++++++++--- src/c/main.d | 77 +++------------------------------------ src/c/process.d | 42 ++++----------------- 3 files changed, 105 insertions(+), 111 deletions(-) diff --git a/src/c/boot.d b/src/c/boot.d index f99014219..e27ffe046 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -5,7 +5,21 @@ /* -- imports --------------------------------------------------------------- */ +#include +#include +#include +#include + +#ifdef ECL_USE_MPROTECT +# include +# ifndef MAP_FAILED +# define MAP_FAILED -1 +# endif +#endif #include +#include +#include +#include #if defined(ECL_MS_WINDOWS_HOST) # include # include @@ -20,11 +34,6 @@ # endif #endif -#include -#include -#include -#include - /* -- constants ----------------------------------------------------- */ const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800); @@ -131,6 +140,84 @@ ecl_set_option(int option, cl_fixnum value) return ecl_option_values[option]; } +/* -- environments ---------------------------------------------------------- */ + +#ifdef ECL_THREADS +static void +add_env(cl_env_ptr the_env) +{ + cl_object _env; + ecl_mutex_lock(&ecl_core.processes_lock); + _env = ecl_cast_ptr(cl_object,the_env); + ecl_stack_push(ecl_core.threads, _env); + ecl_mutex_unlock(&ecl_core.processes_lock); +} + +static void +del_env(cl_env_ptr the_env) +{ + cl_object _env; + ecl_mutex_lock(&ecl_core.processes_lock); + _env = ecl_cast_ptr(cl_object,the_env); + ecl_stack_del(ecl_core.threads, _env); + ecl_mutex_unlock(&ecl_core.processes_lock); +} +#endif + +cl_env_ptr +_ecl_alloc_env(cl_env_ptr parent) +{ + /* Allocates the lisp environment for a thread. Depending on which mechanism + * we use for detecting delayed signals, we may allocate the environment using + * mmap or with malloc. + * + * Note that at this point we are not allocating any other memory which is + * stored via a pointer in the environment. If we would do that, an unlucky + * interrupt by the gc before the allocated environment is registered in + * ecl_core.processes could lead to memory being freed because the gc is not + * aware of the pointer to the allocated memory in the environment. */ + cl_env_ptr output; +#if defined(ECL_USE_MPROTECT) + output = (cl_env_ptr) mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, + MAP_ANON | MAP_PRIVATE, -1, 0); + if (output == MAP_FAILED) + ecl_internal_error("Unable to allocate environment structure."); +#else +# if defined(ECL_USE_GUARD_PAGE) + output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, PAGE_READWRITE); + if (output == NULL) + ecl_internal_error("Unable to allocate environment structure."); +# else + output = ecl_malloc(sizeof(*output)); + if (output == NULL) + ecl_internal_error("Unable to allocate environment structure."); +# endif +#endif + /* Initialize the structure with NULL data. */ + memset(output, 0, sizeof(*output)); +#ifdef ECL_THREADS + add_env(output); +#endif + return output; +} + +void +_ecl_dealloc_env(cl_env_ptr env) +{ +#ifdef ECL_THREADS + del_env(env); +#endif +#if defined(ECL_USE_MPROTECT) + if (munmap(env, sizeof(*env))) + ecl_internal_error("Unable to deallocate environment structure."); +#elif defined(ECL_USE_GUARD_PAGE) + if (!VirtualFree(env, 0, MEM_RELEASE)) + ecl_internal_error("Unable to deallocate environment structure."); +#else + ecl_free_unsafe(env); +#endif +} + /* -- core runtime ---------------------------------------------------------- */ /* The root environment is a default execution context. */ diff --git a/src/c/main.d b/src/c/main.d index 7cee491b2..5b5eceec2 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -12,15 +12,9 @@ * */ -/******************************** IMPORTS *****************************/ +/* -- Imports ------------------------------------------------------- */ #include -#ifdef ECL_USE_MPROTECT -# include -# ifndef MAP_FAILED -# define MAP_FAILED -1 -# endif -#endif #include #include #include @@ -29,77 +23,15 @@ #include #include - #include "ecl_features.h" #include "iso_latin_names.h" -/******************************* EXPORTS ******************************/ +/* -- Global Initialization ----------------------------------------- */ const char *ecl_self; - -/************************ GLOBAL INITIALIZATION ***********************/ - static int ARGC; static char **ARGV; -void -ecl_init_env(cl_env_ptr env) -{ - ecl_modules_init_env(env); -} - -void -_ecl_dealloc_env(cl_env_ptr env) -{ - ecl_modules_free_env(env); -#if defined(ECL_USE_MPROTECT) - if (munmap(env, sizeof(*env))) - ecl_internal_error("Unable to deallocate environment structure."); -#elif defined(ECL_USE_GUARD_PAGE) - if (!VirtualFree(env, 0, MEM_RELEASE)) - ecl_internal_error("Unable to deallocate environment structure."); -#else - ecl_free_unsafe(env); -#endif -} - -cl_env_ptr -_ecl_alloc_env(cl_env_ptr parent) -{ - /* - * Allocates the lisp environment for a thread. Depending on which - * mechanism we use for detecting delayed signals, we may allocate - * the environment using mmap or the garbage collector. - * - * Note that at this point we are not allocating any other memory - * which is stored via a pointer in the environment. If we would do - * that, an unlucky interrupt by the gc before the allocated - * environment is registered in ecl_core.processes could lead to - * memory being freed because the gc is not aware of the pointer to - * the allocated memory in the environment. - */ - cl_env_ptr output; -#if defined(ECL_USE_MPROTECT) - output = (cl_env_ptr) mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, - MAP_ANON | MAP_PRIVATE, -1, 0); - if (output == MAP_FAILED) - ecl_internal_error("Unable to allocate environment structure."); -#else -# if defined(ECL_USE_GUARD_PAGE) - output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, PAGE_READWRITE); - if (output == NULL) - ecl_internal_error("Unable to allocate environment structure."); -# else - output = ecl_malloc(sizeof(*output)); - if (output == NULL) - ecl_internal_error("Unable to allocate environment structure."); -# endif -#endif - /* Initialize the structure with NULL data. */ - memset(output, 0, sizeof(*output)); - return output; -} - void cl_shutdown(void) { @@ -520,7 +452,8 @@ cl_boot(int argc, char **argv) return 1; } -/* -- Module definition (auxiliary structures) ------------------------------- */ +/* -- Module definition (auxiliary structures) ---------------------- */ + static cl_object create_aux() { @@ -564,7 +497,7 @@ static struct ecl_module module_aux = { }; cl_object ecl_module_aux = (cl_object)&module_aux; -/************************* ENVIRONMENT ROUTINES ***********************/ +/* -- Operating system environment routines ------------------------- */ @(defun ext::quit (&optional (code ecl_make_fixnum(0)) (kill_all_threads ECL_T)) @ { diff --git a/src/c/process.d b/src/c/process.d index 6d220a07b..46bd6f088 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -123,26 +123,6 @@ init_tl_bindings(cl_object process, cl_env_ptr env) #ifdef ECL_THREADS -static void -add_env(cl_env_ptr the_env) -{ - cl_object _env; - ecl_mutex_lock(&ecl_core.processes_lock); - _env = ecl_cast_ptr(cl_object,the_env); - ecl_stack_push(ecl_core.threads, _env); - ecl_mutex_unlock(&ecl_core.processes_lock); -} - -static void -del_env(cl_env_ptr the_env) -{ - cl_object _env; - ecl_mutex_lock(&ecl_core.processes_lock); - _env = ecl_cast_ptr(cl_object,the_env); - ecl_stack_del(ecl_core.threads, _env); - ecl_mutex_unlock(&ecl_core.processes_lock); -} - static void register_gc_thread() { @@ -178,9 +158,8 @@ ecl_adopt_cpu() the_env = _ecl_alloc_env(0); the_env->thread = current; ecl_set_process_env(the_env); - ecl_init_env(the_env); - add_env(the_env); init_tl_bindings(ECL_NIL, the_env); + ecl_modules_init_env(the_env); ecl_modules_init_cpu(the_env); return the_env; @@ -196,7 +175,7 @@ ecl_disown_cpu() #ifdef ECL_WINDOWS_THREADS CloseHandle(the_env->thread); #endif - del_env(the_env); + ecl_modules_free_env(the_env); _ecl_dealloc_env(the_env); unregister_gc_thread(); } @@ -214,9 +193,9 @@ thread_entry_point(void *ptr) ecl_modules_init_cpu(the_env); /* Start the user routine */ process->process.entry(0); - /* This routine performs some cleanup before a thread is completely - * killed. For instance, it has to remove the associated process object from - * the list, an it has to dealloc some memory. + /* This routine performs some cleanup before a thread is completely killed. + * For instance, it has to remove the associated process object from * the + * list, an it has to dealloc some memory. * * NOTE: this cleanup does not provide enough "protection". In order to ensure * that all UNWIND-PROTECT forms are properly executed, never use the function @@ -224,10 +203,10 @@ thread_entry_point(void *ptr) * mp_interrupt_process() and mp_process_kill(). */ ecl_disable_interrupts_env(the_env); ecl_modules_free_cpu(the_env); - del_env(the_env); #ifdef ECL_WINDOWS_THREADS CloseHandle(the_env->thread); #endif + ecl_modules_free_env(the_env); _ecl_dealloc_env(the_env); #ifdef ECL_WINDOWS_THREADS return 1; @@ -246,12 +225,7 @@ ecl_spawn_cpu(cl_object process) /* Allocate and initialize the new cpu env. */ { new_env = _ecl_alloc_env(the_env); - /* List the process such that its environment is marked by the GC when its - contents are allocated. */ - add_env(new_env); - /* Now we can safely allocate memory for the environment ocntents and store - pointers to it in the environment. */ - ecl_init_env(new_env); + ecl_modules_init_env(new_env); /* Copy the parent env defaults. */ new_env->trap_fpe_bits = the_env->trap_fpe_bits; new_env->own_process = process; @@ -301,8 +275,8 @@ ecl_spawn_cpu(cl_object process) #endif /* ECL_WINDOWS_THREADS */ /* Deal with the fallout of the thread creation. */ if (!ok) { - del_env(new_env); process->process.env = NULL; + ecl_modules_free_env(new_env); _ecl_dealloc_env(new_env); } ecl_enable_interrupts_env(the_env); -- GitLab From fb80c726833f15b168d4912b6137f7bef7a86a21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 6 Dec 2024 18:13:38 +0100 Subject: [PATCH 52/58] process: abstract away create thread, exit thread and sigmask Previously we've opencoded calls to these functions, although they may be nicely abstracted with static inline functions. This change improves code readibility and portability. --- src/c/jump.d | 1 + src/c/process.d | 57 +++++++++++++----------------------------- src/c/threads/thread.d | 18 ++++++------- src/c/unixint.d | 32 ++++++++---------------- src/h/ecl.h | 3 --- src/h/internal.h | 28 +++++++++++++++------ src/h/stack-resize.h | 9 +++---- src/h/threads.h | 45 ++++++++++++++++++++++++++++++--- 8 files changed, 104 insertions(+), 89 deletions(-) diff --git a/src/c/jump.d b/src/c/jump.d index 683f0084b..6fadb39e2 100644 --- a/src/c/jump.d +++ b/src/c/jump.d @@ -189,6 +189,7 @@ ecl_thread_internal_error(const char *s) "Exitting thread.\n"); fflush(stderr); ecl_thread_exit(); + _ecl_unexpected_return(); } #endif diff --git a/src/c/process.d b/src/c/process.d index 46bd6f088..f3dcba6c8 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -221,7 +221,7 @@ ecl_spawn_cpu(cl_object process) { cl_env_ptr the_env = ecl_process_env(); cl_env_ptr new_env = NULL; - int ok = 1; + int code = 0; /* Allocate and initialize the new cpu env. */ { new_env = _ecl_alloc_env(the_env); @@ -234,53 +234,30 @@ ecl_spawn_cpu(cl_object process) } /* Spawn the thread */ ecl_disable_interrupts_env(the_env); -#ifdef ECL_WINDOWS_THREADS +#if !defined(ECL_WINDOWS_THREADS) && defined(HAVE_SIGPROCMASK) { - HANDLE code; - DWORD threadId; - - code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, new_env, 0, &threadId); - new_env->thread = code; - ok = code != NULL; + /* Block all asynchronous signals until the thread is completely set up. The + * synchronous signals SIGSEGV and SIGBUS are needed by the gc and and can't + * be blocked. */ + sigset_t new, previous; + sigfillset(&new); + sigdelset(&new, SIGSEGV); + sigdelset(&new, SIGBUS); + ecl_sigmask(SIG_BLOCK, &new, &previous); + code = ecl_thread_create(new_env, thread_entry_point); + ecl_sigmask(SIG_SETMASK, &previous, NULL); } -#else /* ECL_WINDOWS_THREADS */ - { - int code; - pthread_attr_t pthreadattr; - - pthread_attr_init(&pthreadattr); - pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); - /* - * Block all asynchronous signals until the thread is completely - * set up. The synchronous signals SIGSEGV and SIGBUS are needed - * by the gc and thus can't be blocked. - */ -# ifdef HAVE_SIGPROCMASK - { - sigset_t new, previous; - sigfillset(&new); - sigdelset(&new, SIGSEGV); - sigdelset(&new, SIGBUS); - pthread_sigmask(SIG_BLOCK, &new, &previous); - code = pthread_create(&new_env->thread, &pthreadattr, - thread_entry_point, new_env); - pthread_sigmask(SIG_SETMASK, &previous, NULL); - } -# else - code = pthread_create(&new_env->thread, &pthreadattr, - thread_entry_point, new_env); -# endif - ok = (code == 0); - } -#endif /* ECL_WINDOWS_THREADS */ +#else + code = ecl_thread_create(new_env, thread_entry_point); +#endif /* Deal with the fallout of the thread creation. */ - if (!ok) { + if (code != 0) { process->process.env = NULL; ecl_modules_free_env(new_env); _ecl_dealloc_env(new_env); } ecl_enable_interrupts_env(the_env); - return ok ? new_env : NULL; + return code ? NULL : new_env; } #endif diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 6f82d7ceb..3485ddfb0 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -90,7 +90,7 @@ run_process(cl_narg narg, ...) #ifdef HAVE_SIGPROCMASK { sigset_t *new = (sigset_t*)the_env->default_sigmask; - pthread_sigmask(SIG_SETMASK, new, NULL); + ecl_sigmask(SIG_SETMASK, new, NULL); } #endif process->process.phase = ECL_PROCESS_ACTIVE; @@ -124,7 +124,7 @@ run_process(cl_narg narg, ...) sigset_t new[1]; sigemptyset(new); sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); - pthread_sigmask(SIG_BLOCK, new, NULL); + ecl_sigmask(SIG_BLOCK, new, NULL); } #endif process->process.env = NULL; @@ -196,7 +196,7 @@ ecl_release_current_thread(void) sigset_t new[1]; sigemptyset(new); sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); - pthread_sigmask(SIG_BLOCK, new, NULL); + ecl_sigmask(SIG_BLOCK, new, NULL); } #endif process->process.phase = ECL_PROCESS_INACTIVE; @@ -424,8 +424,8 @@ mp_get_sigmask(void) sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; sigset_t no_signals; sigemptyset(&no_signals); - if (pthread_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) - FElibc_error("MP:GET-SIGMASK failed in a call to pthread_sigmask", 0); + if (ecl_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) + FElibc_error("MP:GET-SIGMASK failed in a call to ecl_sigmask", 0); @(return data); } @@ -433,8 +433,8 @@ static cl_object mp_set_sigmask(cl_object data) { sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; - if (pthread_sigmask(SIG_SETMASK, mask_ptr, NULL)) - FElibc_error("MP:SET-SIGMASK failed in a call to pthread_sigmask", 0); + if (ecl_sigmask(SIG_SETMASK, mask_ptr, NULL)) + FElibc_error("MP:SET-SIGMASK failed in a call to ecl_sigmask", 0); @(return data); } #endif @@ -455,8 +455,8 @@ mp_block_signals(void) * can thus never be blocked */ sigdelset(&all_signals, SIGSEGV); sigdelset(&all_signals, SIGBUS); - if (pthread_sigmask(SIG_SETMASK, &all_signals, NULL)) - FElibc_error("MP:BLOCK-SIGNALS failed in a call to pthread_sigmask",0); + if (ecl_sigmask(SIG_SETMASK, &all_signals, NULL)) + FElibc_error("MP:BLOCK-SIGNALS failed in a call to ecl_sigmask",0); @(return previous); #endif } diff --git a/src/c/unixint.d b/src/c/unixint.d index b8e50a525..8cb2d1af1 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -41,7 +41,7 @@ * sections of code which are interruptible, and in which it is safe * for the handler to run arbitrary code, protect anything else. In * principle this "marking" can be done using POSIX functions such as - * pthread_sigmask() or sigprocmask(). + * pthread_sigmask() or sigprocmask() abstracted with ecl_sigmask(). * * However in practice this is slow, as it involves at least a * function call, resolving thread-local variables, etc, etc, and it @@ -307,11 +307,7 @@ unblock_signal(cl_env_ptr the_env, int signal) * We do not really "unblock" the signal, but rather restore * ECL's default sigmask. */ -# ifdef ECL_THREADS - pthread_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL); -# else - sigprocmask(SIG_SETMASK, the_env->default_sigmask, NULL); -# endif + ecl_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL); } #endif @@ -619,7 +615,7 @@ asynchronous_signal_servicing_thread() sigdelset(&handled_set, SIGSEGV); sigdelset(&handled_set, SIGBUS); } - pthread_sigmask(SIG_BLOCK, &handled_set, NULL); + ecl_sigmask(SIG_BLOCK, &handled_set, NULL); } /* * We create the object for communication. We need a lock to prevent other @@ -906,25 +902,25 @@ do_catch_signal(int code, cl_object action, cl_object process) return ECL_T; } else { sigset_t handled_set; - pthread_sigmask(SIG_SETMASK, NULL, &handled_set); + ecl_sigmask(SIG_SETMASK, NULL, &handled_set); if (action == @':mask') { sigaddset(&handled_set, code); } else { sigdelset(&handled_set, code); } - pthread_sigmask(SIG_SETMASK, &handled_set, NULL); + ecl_sigmask(SIG_SETMASK, &handled_set, NULL); return ECL_T; } # else { sigset_t handled_set; - sigprocmask(SIG_SETMASK, NULL, &handled_set); + ecl_sigmask(SIG_SETMASK, NULL, &handled_set); if (action == @':mask') { sigaddset(&handled_set, code); } else { sigdelset(&handled_set, code); } - sigprocmask(SIG_SETMASK, &handled_set, NULL); + ecl_sigmask(SIG_SETMASK, &handled_set, NULL); return ECL_T; } # endif /* !ECL_THREADS */ @@ -1301,11 +1297,7 @@ install_asynchronous_signal_handlers() #ifdef HAVE_SIGPROCMASK sigset_t *sigmask = ecl_core.first_env->default_sigmask = &main_thread_sigmask; ecl_core.default_sigmask_bytes = sizeof(sigset_t); -# ifdef ECL_THREADS - pthread_sigmask(SIG_SETMASK, NULL, sigmask); -# else - sigprocmask(SIG_SETMASK, NULL, sigmask); -# endif + ecl_sigmask(SIG_SETMASK, NULL, sigmask); #endif #if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) ecl_mutex_init(&signal_thread_lock, TRUE); @@ -1316,11 +1308,7 @@ install_asynchronous_signal_handlers() } #endif #ifdef HAVE_SIGPROCMASK -# if defined(ECL_THREADS) - pthread_sigmask(SIG_SETMASK, sigmask, NULL); -# else - sigprocmask(SIG_SETMASK, sigmask, NULL); -# endif + ecl_sigmask(SIG_SETMASK, sigmask, NULL); #endif #ifdef ECL_WINDOWS_THREADS old_W32_exception_filter = @@ -1402,7 +1390,7 @@ install_synchronous_signal_handlers() mysignal(signal, process_interrupt_handler); #ifdef HAVE_SIGPROCMASK sigdelset(&main_thread_sigmask, signal); - pthread_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL); + ecl_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL); #endif } #endif diff --git a/src/h/ecl.h b/src/h/ecl.h index a95e27e70..80214bf5a 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -62,9 +62,6 @@ # include # endif # ifdef ECL_THREADS - typedef HANDLE pthread_t; - typedef HANDLE pthread_mutex_t; - typedef HANDLE pthread_cond_t; /*Dummy, not really used*/ # undef ERROR # ifdef GBC_BOEHM # define CreateThread GC_CreateThread diff --git a/src/h/internal.h b/src/h/internal.h index efce62e83..bcd027640 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -578,13 +578,6 @@ extern void ecl_cs_set_size(cl_env_ptr env, cl_index n); #ifdef ECL_THREADS extern ECL_API cl_object mp_suspend_loop(); extern ECL_API cl_object mp_break_suspend_loop(); - -# ifdef ECL_WINDOWS_THREADS -# define ecl_thread_exit() ExitThread(0); -# else -# define ecl_thread_exit() pthread_exit(NULL); -# endif /* ECL_WINDOWS_THREADS */ - #endif /* time.d */ @@ -754,6 +747,27 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); #include +/* sigmask */ + +#ifdef HAVE_SIGPROCMASK +# include +# ifdef ECL_THREADS +static inline int +ecl_sigmask(int how, const sigset_t *set, sigset_t *oldset) +{ + return pthread_sigmask(how, set, oldset); +} +# else +static inline int +ecl_sigmask(int how, const sigset_t *set, sigset_t *oldset) +{ + return sigprocmask(how, set, oldset); +} +# endif +#endif + +/* global locks */ + #ifdef ECL_THREADS # define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) \ ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.global_lock) diff --git a/src/h/stack-resize.h b/src/h/stack-resize.h index 93e9ee6bb..09e67df35 100644 --- a/src/h/stack-resize.h +++ b/src/h/stack-resize.h @@ -14,11 +14,10 @@ #ifndef ECL_STACK_RESIZE_H #define ECL_STACK_RESIZE_H -/* We can't block interrupts with ecl_disable_interrupts() and write - * in the thread local environment if we use fast interrupt dispatch - * via mprotect(), so we have to use sigprocmask instead. No - * performance problems, since this is only used for stack - * resizing. */ +/* We can't block interrupts with ecl_disable_interrupts() and write in the + * thread local environment if we use fast interrupt dispatch via mprotect(), so + * we have to use sigprocmask instead. No performance problems, since this is + * only used for stack resizing. */ #if defined(ECL_THREADS) && defined(ECL_USE_MPROTECT) # ifdef HAVE_SIGPROCMASK # include diff --git a/src/h/threads.h b/src/h/threads.h index 5571b228a..eb4ff6755 100644 --- a/src/h/threads.h +++ b/src/h/threads.h @@ -22,8 +22,8 @@ # endif #endif -#ifndef ECL_MUTEX_H -#define ECL_MUTEX_H +#ifndef ECL_THREADS_H +#define ECL_THREADS_H #include #ifdef ECL_WINDOWS_THREADS @@ -38,6 +38,45 @@ #endif #include +#ifdef ECL_WINDOWS_THREADS +/* Windows can't into typedefs in parameter lists. */ +/* typedef DWORD WINAPI (*ecl_thread_entry)(void *ptr); */ +static inline int +ecl_thread_create(cl_env_ptr the_env, /* ecl_thread_entry */ void* fun) +{ + HANDLE code; + DWORD threadId; + code = (HANDLE)CreateThread(NULL, 0, fun, the_env, 0, &threadId); + the_env->thread = code; + /* NULL handle is a failure. */ + return (code != NULL) ? 0 : 1; +} + +static inline void +ecl_thread_exit() +{ + ExitThread(0); +} +#else /* ECL_WINDOWS_THREADS */ +typedef void* (*ecl_thread_entry)(void *ptr); + +static inline int +ecl_thread_create(cl_env_ptr the_env, ecl_thread_entry fun) +{ + pthread_attr_t pthreadattr; + pthread_attr_init(&pthreadattr); + pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); + return pthread_create(&the_env->thread, &pthreadattr, fun, the_env); +} + +static inline void +ecl_thread_exit() +{ + pthread_exit(NULL); +} +#endif /* ECL_WINDOWS_THREADS */ + + #if !defined(ECL_WINDOWS_THREADS) #define ECL_MUTEX_SUCCESS 0 @@ -734,6 +773,6 @@ ecl_rwlock_lock_write(ecl_rwlock_t *rwlock) #endif /* ECL_WINDOWS_THREADS */ -#endif /* ECL_MUTEX_H */ +#endif /* ECL_THREADS_H */ #endif /* ECL_THREADS */ -- GitLab From 43b92e332152d655373cfc79c0091b2f3affa880 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 9 Dec 2024 11:26:07 +0100 Subject: [PATCH 53/58] garbage: register and unregister GC threads manually from a module This decouples thread primitives from the garbage collector and allows us to build nucl once more. --- src/aclocal.m4 | 26 ++++++++++++-------------- src/c/mem_gc.d | 20 +++++++++++++++++++- src/c/process.d | 24 ------------------------ src/configure | 28 +++++++++++++--------------- src/h/ecl.h | 3 --- 5 files changed, 44 insertions(+), 57 deletions(-) diff --git a/src/aclocal.m4 b/src/aclocal.m4 index 571a70eff..d441f6467 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -263,9 +263,10 @@ SHAREDPREFIX='lib' LIBPREFIX='lib' LIBEXT='a' PICFLAG='-fPIC' -THREAD_CFLAGS='' +THREAD_CFLAGS='-DGC_NO_THREAD_REDIRECTS' THREAD_LIBS='' THREAD_GC_FLAGS='--enable-threads=posix' +CFLAGS='' INSTALL_TARGET='install' THREAD_OBJ="$THREAD_OBJ threads/thread threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox threads/rwlock" clibs='-lm' @@ -274,7 +275,7 @@ SONAME_LDFLAGS='' case "${host_os}" in linux-android*) thehost='android' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" # THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -290,7 +291,7 @@ case "${host_os}" in # libdir may have a dollar expression inside linux*) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -303,7 +304,7 @@ case "${host_os}" in ;; gnu*) thehost='gnu' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -315,7 +316,7 @@ case "${host_os}" in ;; kfreebsd*-gnu) thehost='kfreebsd' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -357,8 +358,6 @@ case "${host_os}" in ;; openbsd*) thehost='openbsd' - THREAD_CFLAGS='' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -386,7 +385,7 @@ case "${host_os}" in thehost='cygwin' #enable_threads='no' shared='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -406,7 +405,7 @@ case "${host_os}" in clibs='' shared='yes' enable_threads='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_GC_FLAGS='--enable-threads=win32' SHARED_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" BUNDLE_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" @@ -424,7 +423,7 @@ case "${host_os}" in SHARED_LDFLAGS="-dynamiclib ${LDFLAGS}" BUNDLE_LDFLAGS="-bundle ${LDFLAGS}" ECL_LDRPATH='-Wl,-rpath,~A' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' # The GMP library has not yet been ported to Intel or Arm-OSX case "`uname -m`" in @@ -457,7 +456,7 @@ case "${host_os}" in thehost='nonstop' shared='yes' PICFLAG='-call_shared' - THREAD_CFLAGS='-spthread' + THREAD_CFLAGS="-spthread ${THREAD_CFLAGS}" SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wld=\"-rld_l ~A\"' @@ -465,7 +464,6 @@ case "${host_os}" in ;; haiku*) thehost='haiku' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -492,7 +490,7 @@ esac case "${host}" in *-nacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -504,7 +502,7 @@ case "${host}" in ;; *-pnacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' dnl SHARED_LDFLAGS="-shared ${LDFLAGS}" dnl BUNDLE_LDFLAGS="-shared ${LDFLAGS}" diff --git a/src/c/mem_gc.d b/src/c/mem_gc.d index 64fec22a4..4de0978a4 100644 --- a/src/c/mem_gc.d +++ b/src/c/mem_gc.d @@ -1301,6 +1301,24 @@ init_cpu(cl_env_ptr the_env) struct GC_stack_base stack; GC_get_stack_base(&stack); the_env->c_stack.org = (char*)stack.mem_base; +# ifdef ECL_THREADS + if (GC_thread_is_registered() == 0) { + GC_register_my_thread(&stack); + } +# endif +#endif + return ECL_NIL; +} + +static cl_object +free_cpu() +{ +#ifdef GBC_BOEHM +# ifdef ECL_THREADS + if (GC_thread_is_registered() == 1) { + GC_unregister_my_thread(); + } +# endif #endif return ECL_NIL; } @@ -1313,7 +1331,7 @@ static struct ecl_module module_gc = { .enable = enable_gc, .init_env = ecl_module_no_op_env, .init_cpu = init_cpu, - .free_cpu = ecl_module_no_op_cpu, + .free_cpu = free_cpu, .free_env = ecl_module_no_op_env, .disable = disable_gc, .destroy = ecl_module_no_op diff --git a/src/c/process.d b/src/c/process.d index f3dcba6c8..02b661627 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -123,28 +123,6 @@ init_tl_bindings(cl_object process, cl_env_ptr env) #ifdef ECL_THREADS -static void -register_gc_thread() -{ -#ifdef GBC_BOEHM - if (GC_thread_is_registered() == 0) { - struct GC_stack_base stack; - GC_get_stack_base(&stack); - GC_register_my_thread(&stack); - } -#endif -} - -static void -unregister_gc_thread() -{ -#ifdef GBC_BOEHM - if (GC_thread_is_registered() == 1) { - GC_unregister_my_thread(); - } -#endif -} - /* Run a process in the current system thread. */ cl_env_ptr ecl_adopt_cpu() @@ -153,7 +131,6 @@ ecl_adopt_cpu() ecl_thread_t current; if (the_env != NULL) return the_env; - register_gc_thread(); ecl_set_process_self(current); the_env = _ecl_alloc_env(0); the_env->thread = current; @@ -177,7 +154,6 @@ ecl_disown_cpu() #endif ecl_modules_free_env(the_env); _ecl_dealloc_env(the_env); - unregister_gc_thread(); } #ifdef ECL_WINDOWS_THREADS diff --git a/src/configure b/src/configure index 174f9f2c8..b1c1d954a 100755 --- a/src/configure +++ b/src/configure @@ -6092,9 +6092,10 @@ SHAREDPREFIX='lib' LIBPREFIX='lib' LIBEXT='a' PICFLAG='-fPIC' -THREAD_CFLAGS='' +THREAD_CFLAGS='-DGC_NO_THREAD_REDIRECTS' THREAD_LIBS='' THREAD_GC_FLAGS='--enable-threads=posix' +CFLAGS='' INSTALL_TARGET='install' THREAD_OBJ="$THREAD_OBJ threads/thread threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox threads/rwlock" clibs='-lm' @@ -6103,7 +6104,7 @@ SONAME_LDFLAGS='' case "${host_os}" in linux-android*) thehost='android' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" # THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6121,7 +6122,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" # libdir may have a dollar expression inside linux*) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6134,7 +6135,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; gnu*) thehost='gnu' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6146,7 +6147,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; kfreebsd*-gnu) thehost='kfreebsd' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6188,8 +6189,6 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; openbsd*) thehost='openbsd' - THREAD_CFLAGS='' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -6217,7 +6216,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" thehost='cygwin' #enable_threads='no' shared='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6236,7 +6235,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" clibs='' shared='yes' enable_threads='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_GC_FLAGS='--enable-threads=win32' SHARED_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" BUNDLE_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" @@ -6254,7 +6253,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" SHARED_LDFLAGS="-dynamiclib ${LDFLAGS}" BUNDLE_LDFLAGS="-bundle ${LDFLAGS}" ECL_LDRPATH='-Wl,-rpath,~A' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' # The GMP library has not yet been ported to Intel or Arm-OSX case "`uname -m`" in @@ -6287,7 +6286,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" thehost='nonstop' shared='yes' PICFLAG='-call_shared' - THREAD_CFLAGS='-spthread' + THREAD_CFLAGS="-spthread ${THREAD_CFLAGS}" SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wld=\"-rld_l ~A\"' @@ -6295,7 +6294,6 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; haiku*) thehost='haiku' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -6322,7 +6320,7 @@ esac case "${host}" in *-nacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6336,7 +6334,7 @@ LSP_FEATURES="(cons :nacl ${LSP_FEATURES})" ;; *-pnacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 ${CFLAGS}" @@ -7008,7 +7006,7 @@ if test "${enable_threads}" = "yes" ; then as_fn_error $? "Threads aren't supported on this system." "$LINENO" 5 else LIBS="${THREAD_LIBS} ${LIBS}" - CFLAGS="${CFLAGS} ${THREAD_CFLAGS}" + CFLAGS="${CFLAGS} ${THREAD_CFLAGS} -DGC_NO_THREAD_REDIRECTS" ac_fn_c_check_func "$LINENO" "pthread_rwlock_init" "ac_cv_func_pthread_rwlock_init" if test "x$ac_cv_func_pthread_rwlock_init" = xyes diff --git a/src/h/ecl.h b/src/h/ecl.h index 80214bf5a..1fa4363df 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -63,9 +63,6 @@ # endif # ifdef ECL_THREADS # undef ERROR -# ifdef GBC_BOEHM -# define CreateThread GC_CreateThread -# endif # else # error "The Windows ports cannot be built without threads." # endif /* ECL_THREADS */ -- GitLab From 74b898f72a855d2e52115efb97e859dd466245ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 9 Dec 2024 11:48:39 +0100 Subject: [PATCH 54/58] process: move process initialization to the process module hooks --- src/c/process.d | 44 +++++++++++++++--------------------------- src/c/threads/thread.d | 5 +++++ 2 files changed, 21 insertions(+), 28 deletions(-) diff --git a/src/c/process.d b/src/c/process.d index 02b661627..4c5522145 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -93,11 +93,12 @@ ecl_set_process_env(cl_env_ptr env) cl_env_ptr cl_env_p = NULL; #endif /* ECL_THREADS */ +#ifdef ECL_THREADS /* -- Thread local bindings */ static void init_tl_bindings(cl_object process, cl_env_ptr env) { -#ifdef ECL_THREADS + cl_index bindings_size; cl_object *bindings; if (Null(process) || Null(process->process.inherit_bindings_p)) { @@ -115,9 +116,9 @@ init_tl_bindings(cl_object process, cl_env_ptr env) } env->bds_stack.tl_bindings_size = bindings_size; env->bds_stack.tl_bindings = bindings; -#endif -} +} +#endif /* -- Managing the collection of processes ---------------------------------- */ @@ -128,14 +129,11 @@ cl_env_ptr ecl_adopt_cpu() { cl_env_ptr the_env = ecl_process_env_unsafe(); - ecl_thread_t current; if (the_env != NULL) return the_env; - ecl_set_process_self(current); the_env = _ecl_alloc_env(0); - the_env->thread = current; ecl_set_process_env(the_env); - init_tl_bindings(ECL_NIL, the_env); + the_env->own_process = ECL_NIL; ecl_modules_init_env(the_env); ecl_modules_init_cpu(the_env); @@ -149,9 +147,6 @@ ecl_disown_cpu() if (the_env == NULL) return; ecl_modules_free_cpu(the_env); -#ifdef ECL_WINDOWS_THREADS - CloseHandle(the_env->thread); -#endif ecl_modules_free_env(the_env); _ecl_dealloc_env(the_env); } @@ -169,21 +164,8 @@ thread_entry_point(void *ptr) ecl_modules_init_cpu(the_env); /* Start the user routine */ process->process.entry(0); - /* This routine performs some cleanup before a thread is completely killed. - * For instance, it has to remove the associated process object from * the - * list, an it has to dealloc some memory. - * - * NOTE: this cleanup does not provide enough "protection". In order to ensure - * that all UNWIND-PROTECT forms are properly executed, never use the function - * pthread_cancel() to kill a process, but rather use the lisp functions - * mp_interrupt_process() and mp_process_kill(). */ ecl_disable_interrupts_env(the_env); - ecl_modules_free_cpu(the_env); -#ifdef ECL_WINDOWS_THREADS - CloseHandle(the_env->thread); -#endif - ecl_modules_free_env(the_env); - _ecl_dealloc_env(the_env); + ecl_disown_cpu(); #ifdef ECL_WINDOWS_THREADS return 1; #else @@ -201,12 +183,10 @@ ecl_spawn_cpu(cl_object process) /* Allocate and initialize the new cpu env. */ { new_env = _ecl_alloc_env(the_env); - ecl_modules_init_env(new_env); - /* Copy the parent env defaults. */ new_env->trap_fpe_bits = the_env->trap_fpe_bits; new_env->own_process = process; - init_tl_bindings(process, new_env); process->process.env = new_env; + ecl_modules_init_env(new_env); } /* Spawn the thread */ ecl_disable_interrupts_env(the_env); @@ -256,7 +236,7 @@ static cl_object init_env_process(cl_env_ptr the_env) { #ifdef ECL_THREAD - the_env->own_process = ECL_NIL; + init_tl_bindings(the_env->own_process, the_env); #endif return ECL_NIL; } @@ -264,6 +244,11 @@ init_env_process(cl_env_ptr the_env) static cl_object init_cpu_process(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t main_thread; + ecl_set_process_self(main_thread); + the_env->thread = main_thread; +#endif ecl_set_process_env(the_env); return ECL_NIL; } @@ -271,6 +256,9 @@ init_cpu_process(cl_env_ptr the_env) static cl_object free_cpu_process(cl_env_ptr the_env) { +#ifdef ECL_WINDOWS_THREADS + CloseHandle(the_env->thread); +#endif ecl_set_process_env(NULL); return ECL_NIL; } diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 3485ddfb0..314bf50a7 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -111,6 +111,11 @@ run_process(cl_narg narg, ...) /* ABORT restart. */ process->process.exit_values = args; } ECL_RESTART_CASE_END; + /* This routine performs some cleanup before a thread is finished. Note that + it does not provide enough protection -- in order to ensure that all + UNWIND-PROTECT forms are properly executed, enver use the function + pthread_cancel() to kill a process, but rather use the lisp functions + mp_interrupt_process() and mp_process_kill(). */ ecl_bds_unwind1(the_env); } ECL_CATCH_ALL_END; -- GitLab From b622ea12341737e23a5795c5ac4a3308ba449c67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 11 Dec 2024 23:15:31 +0100 Subject: [PATCH 55/58] nucleus: move aux throw/go/tagbody implementations to jump.d --- src/c/cmpaux.d | 31 ------------------------------- src/c/error.d | 3 +++ src/c/jump.d | 28 ++++++++++++++++++++++++++-- src/h/nucleus.h | 2 +- src/h/object.h | 3 ++- 5 files changed, 32 insertions(+), 35 deletions(-) diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index 331d5cfd5..eaced3d20 100644 --- a/src/c/cmpaux.d +++ b/src/c/cmpaux.d @@ -129,37 +129,6 @@ ecl_aset_bv(cl_object x, cl_index index, int value) return value; } -void -cl_throw(cl_object tag) -{ - ecl_frame_ptr fr = frs_sch(tag); - if (fr == NULL) - FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); - ecl_unwind(ecl_process_env(), fr); -} - -void -cl_return_from(cl_object block_id, cl_object block_name) -{ - ecl_frame_ptr fr = frs_sch(block_id); - if (fr == NULL) - FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", - 2, block_name, block_id); - ecl_unwind(ecl_process_env(), fr); -} - -void -cl_go(cl_object tag_id, cl_object label) -{ - const cl_env_ptr the_env = ecl_process_env(); - ecl_frame_ptr fr = frs_sch(tag_id); - if (fr == NULL) - FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); - the_env->values[0] = label; - the_env->nvalues = 1; - ecl_unwind(the_env, fr); -} - cl_object cl_grab_rest_args(ecl_va_list args) { diff --git a/src/c/error.d b/src/c/error.d index b71665d57..ce707a87b 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -137,6 +137,9 @@ ecl_exception_handler(cl_object o) case ECL_EX_F_INVAL: FEinvalid_function(arg1); break; + case ECL_EX_S_FMISS: + FEcontrol_error("UNWIND: frame ~s not found.", 1, arg1); + break; default: ecl_internal_error("Unknown exception type."); } diff --git a/src/c/jump.d b/src/c/jump.d index 6fadb39e2..1b535aa36 100644 --- a/src/c/jump.d +++ b/src/c/jump.d @@ -35,15 +35,39 @@ continuation is the exit point estabilished by an equivalent of CATCH. ** -------------------------------------------------------------------------- */ -cl_object +void ecl_escape(cl_object continuation) { ecl_frame_ptr fr = frs_sch(continuation); - if (!fr) ecl_internal_error("si_fear_handler: continuation not found!"); + if (!fr) { + ecl_ferror(ECL_EX_S_FMISS, continuation, ECL_NIL); + } ecl_unwind(ecl_process_env(), fr); _ecl_unexpected_return(); } +void +cl_throw(cl_object tag) +{ + ecl_escape(tag); +} + +void +cl_return_from(cl_object block_id, cl_object block_name) +{ + ecl_escape(block_id); +} + +void +cl_go(cl_object tag_id, cl_object label) +{ + + const cl_env_ptr the_env = ecl_process_env(); + the_env->values[0] = label; + the_env->nvalues = 1; + ecl_escape(tag_id); +} + /* -- Signaling conditions -------------------------------------------------- ** Low level signals work slightly different from Common Lisp. There are no handler diff --git a/src/h/nucleus.h b/src/h/nucleus.h index 6d6c752f4..1072e4be6 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -40,7 +40,7 @@ cl_env_ptr ecl_spawn_cpu(); void ecl_disown_cpu(); /* control.c */ -cl_object ecl_escape(cl_object continuation) ecl_attr_noreturn; +void ecl_escape(cl_object continuation) ecl_attr_noreturn; cl_object ecl_signal(cl_object condition, cl_object returns, cl_object thread); cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); diff --git a/src/h/object.h b/src/h/object.h index 3e2218ee5..85b5d4a28 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -959,7 +959,8 @@ typedef enum { ECL_EX_V_BNAME, /* illegal variable name */ ECL_EX_F_NARGS, /* wrong number of arguments */ ECL_EX_F_UNDEF, /* undefined function */ - ECL_EX_F_INVAL /* non-function passed as function */ + ECL_EX_F_INVAL, /* non-function passed as function */ + ECL_EX_S_FMISS /* missing unwind frame (ecl_escape) */ } ecl_ex_type; #define ECL_EXCEPTIONP(x) ((ECL_IMMEDIATE(x)==0) && ((x)->d.t==t_exception)) -- GitLab From 4c0e5614dbb32910eeff4a14b837e82f6f7ed512 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 15 May 2025 11:39:37 +0200 Subject: [PATCH 56/58] nucleus: move early stacks to a separate file This is necessary if we want to link them into nucleus without CL env baggage. --- src/c/Makefile.in | 4 +- src/c/interpreter.d | 44 ++++++++ src/c/jump.d | 17 +++ src/c/stack2.d | 236 ++++++++++++++++++++++++++++++++++++++++ src/c/stacks.d | 257 -------------------------------------------- 5 files changed, 299 insertions(+), 259 deletions(-) create mode 100644 src/c/stack2.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 1985ff731..3bb706edf 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = boot.o call.o jump.o atomic.o process.o memory.o module.o +NUCL_OBJS = boot.o call.o jump.o atomic.o process.o memory.o module.o stacks.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o @@ -79,7 +79,7 @@ GC_OBJS = alloc.o gbc.o OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o \ compiler.o disassembler.o reference.o character.o file.o error.o \ string.o cfun.o typespec.o assignment.o predicate.o array.o \ - vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ + vector_push.o sequence.o cmpaux.o macros.o backq.o stack2.o time.o \ unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ load.o unixfsys.o unixsys.o serialize.o sse2.o mem_gc.o \ $(CLOS_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(FFI_OBJS) \ diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 4fb1c591d..29eb71c49 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -63,18 +63,36 @@ VEwrong_arg_type_nth_val() ecl_ferror(ECL_EX_VM_BADARG_NTH_VAL, ECL_NIL, ECL_NIL); } +static void +VEwrong_args_progv(cl_object vars, cl_object vals) +{ + ecl_ferror(ECL_EX_VM_BADARG_PROGV, vars, vals); +} + static void VEassignment_to_constant(cl_object var) { ecl_ferror(ECL_EX_V_CSETQ, var, ECL_NIL); } +static void +VEbinding_a_constant(cl_object var) +{ + ecl_ferror(ECL_EX_V_CBIND, var, ECL_NIL); +} + static void VEunbound_variable(cl_object var) { ecl_ferror(ECL_EX_V_UNBND, var, ECL_NIL); } +static void +VEillegal_variable_name(cl_object name) +{ + ecl_ferror(ECL_EX_V_BNAME, name, ECL_NIL); +} + static void VEwrong_num_arguments(cl_object fun) { @@ -310,6 +328,32 @@ ecl_close_around(cl_object fun, cl_object lcl_env, cl_object lex_env) { return v; } +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) || Null(var)) + VEillegal_variable_name(var); + if (var->symbol.stype & ecl_stp_constant) + VEbinding_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); + } + } + } + VEwrong_args_progv(vars0, values0); + _ecl_unexpected_return(); +} + static inline cl_object call_stepper(cl_env_ptr the_env, cl_object form, cl_object delta) { diff --git a/src/c/jump.d b/src/c/jump.d index 1b535aa36..bfd5a7058 100644 --- a/src/c/jump.d +++ b/src/c/jump.d @@ -46,6 +46,23 @@ ecl_escape(cl_object continuation) _ecl_unexpected_return(); } +void +ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) +{ + env->frs_stack.nlj_fr = fr; + ecl_frame_ptr top = env->frs_stack.top; + while (top != fr && top->frs_val != ECL_PROTECT_TAG){ + top->frs_val = ECL_DUMMY_TAG; + --top; + } + env->ihs_stack.top = top->frs_ihs; + ecl_bds_unwind(env, top->frs_bds_ndx); + ecl_vms_unwind(env, top->frs_vms_ndx); + env->frs_stack.top = top; + ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); + _ecl_unexpected_return(); +} + void cl_throw(cl_object tag) { diff --git a/src/c/stack2.d b/src/c/stack2.d new file mode 100644 index 000000000..c3d003d67 --- /dev/null +++ b/src/c/stack2.d @@ -0,0 +1,236 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* + * stacks.d - runtime, binding, history and frame stacks + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ + +#include +#include +#include +#include +#ifdef HAVE_SYS_RESOURCE_H +# include +# include +#endif +#include +#include +#include +#include + +/* -- Bindings stack -------------------------------------------------------- */ + +static ecl_bds_ptr +get_bds_ptr(cl_object x) +{ + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x); + if (env->bds_stack.org <= p && p <= env->bds_stack.top) + return(p); + } + FEerror("~S is an illegal bds index.", 1, x); +} + +cl_object +si_bds_top() +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org)); +} + +cl_object +si_bds_var(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_bds_ptr(arg)->symbol); +} + +cl_object +si_bds_val(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + cl_object v = get_bds_ptr(arg)->value; + ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v)); +} + +/* -- Frame stack ----------------------------------------------------------- */ + +static ecl_frame_ptr +get_frame_ptr(cl_object x) +{ + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x); + if (env->frs_stack.org <= p && p <= env->frs_stack.top) + return p; + } + FEerror("~S is an illegal frs index.", 1, x); +} + +cl_object +si_frs_top() +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org)); +} + +cl_object +si_frs_bds(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx)); +} + +cl_object +si_frs_tag(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_frame_ptr(arg)->frs_val); +} + +cl_object +si_frs_ihs(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)); +} + +cl_object +si_sch_frs_base(cl_object fr, cl_object ihs) +{ + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr x; + cl_index y = ecl_to_size(ihs); + for (x = get_frame_ptr(fr); + x <= env->frs_stack.top && x->frs_ihs->index < y; + x++); + ecl_return1(env, ((x > env->frs_stack.top) + ? ECL_NIL + : ecl_make_fixnum(x - env->frs_stack.org))); +} + +/* -- Invocation stack ------------------------------------------------------ */ + +static ecl_ihs_ptr +get_ihs_ptr(cl_index n) +{ + 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) +{ + cl_env_ptr env = ecl_process_env(); + cl_index margin; + if (type == @'ext::frame-stack') { + 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 FRS stack below ~D.", 1, limit); + ecl_frs_set_limit(env, request_size); + } else if (type == @'ext::binding-stack') { + cl_index current_size = env->bds_stack.top - env->bds_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink BDS stack below ~D.", 1, limit); + ecl_bds_set_limit(env, request_size); + } else if (type == @'ext::lisp-stack') { + cl_index current_size = env->run_stack.top - env->run_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink VMS stack below ~D.", 1, limit); + ecl_vms_set_limit(env, request_size); + } else if (type == @'ext::c-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + 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() + * creates a fixnum which is too small for size_t on 32-bit. + */ + size_t the_size = (size_t)ecl_to_ulong(limit); + _ecl_set_max_heap_size(the_size); + } + + ecl_return1(env, si_get_limit(type)); +} + +cl_object +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_stack.limit_size; + else if (type == @'ext::binding-stack') + output = env->bds_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(ecl_core.max_heap_size)); + } + + ecl_return1(env, ecl_make_unsigned_integer(output)); +} diff --git a/src/c/stacks.d b/src/c/stacks.d index 77951a96f..ea12de46c 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -728,200 +728,6 @@ static struct ecl_module module_stacks = { cl_object ecl_module_stacks = (cl_object)&module_stacks; -/* -- High level interface -------------------------------------------------- */ - -void -ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) -{ - env->frs_stack.nlj_fr = fr; - ecl_frame_ptr top = env->frs_stack.top; - while (top != fr && top->frs_val != ECL_PROTECT_TAG){ - top->frs_val = ECL_DUMMY_TAG; - --top; - } - env->ihs_stack.top = top->frs_ihs; - ecl_bds_unwind(env, top->frs_bds_ndx); - ecl_vms_unwind(env, top->frs_vms_ndx); - env->frs_stack.top = top; - ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); - /* never reached */ -} - -cl_index -ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) -{ - cl_object vars = vars0, values = values0; - cl_index n = env->bds_stack.top - env->bds_stack.org; - for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { - if (Null(vars)) { - return n; - } else { - cl_object var = ECL_CONS_CAR(vars); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - if (ecl_symbol_type(var) & ecl_stp_constant) - FEbinding_a_constant(var); - if (Null(values)) { - ecl_bds_bind(env, var, OBJNULL); - } else { - ecl_bds_bind(env, var, ECL_CONS_CAR(values)); - values = ECL_CONS_CDR(values); - } - } - } - FEerror("Wrong arguments to special form PROGV. Either~%" - "~A~%or~%~A~%are not proper lists", - 2, vars0, values0); -} - -/* -- Bindings stack -------------------------------------------------------- */ - -static ecl_bds_ptr -get_bds_ptr(cl_object x) -{ - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x); - if (env->bds_stack.org <= p && p <= env->bds_stack.top) - return(p); - } - FEerror("~S is an illegal bds index.", 1, x); -} - -cl_object -si_bds_top() -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org)); -} - -cl_object -si_bds_var(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_bds_ptr(arg)->symbol); -} - -cl_object -si_bds_val(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - cl_object v = get_bds_ptr(arg)->value; - ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v)); -} - -/* -- Frame stack ----------------------------------------------------------- */ - -static ecl_frame_ptr -get_frame_ptr(cl_object x) -{ - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x); - if (env->frs_stack.org <= p && p <= env->frs_stack.top) - return p; - } - FEerror("~S is an illegal frs index.", 1, x); -} - -cl_object -si_frs_top() -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org)); -} - -cl_object -si_frs_bds(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx)); -} - -cl_object -si_frs_tag(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_frame_ptr(arg)->frs_val); -} - -cl_object -si_frs_ihs(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)); -} - -cl_object -si_sch_frs_base(cl_object fr, cl_object ihs) -{ - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr x; - cl_index y = ecl_to_size(ihs); - for (x = get_frame_ptr(fr); - x <= env->frs_stack.top && x->frs_ihs->index < y; - x++); - ecl_return1(env, ((x > env->frs_stack.top) - ? ECL_NIL - : ecl_make_fixnum(x - env->frs_stack.org))); -} - -/* -- Invocation stack ------------------------------------------------------ */ - -static ecl_ihs_ptr -get_ihs_ptr(cl_index n) -{ - cl_env_ptr env = ecl_process_env(); - ecl_ihs_ptr p = env->ihs_stack.top; - if (n > p->index) - FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); - while (n < p->index) - p = p->next; - return p; -} - -cl_object -si_ihs_top(void) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->ihs_stack.top->index)); -} - -cl_object -si_ihs_prev(cl_object x) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, cl_1M(x)); -} - -cl_object -si_ihs_next(cl_object x) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, cl_1P(x)); -} - -cl_object -si_ihs_bds(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)); -} - -cl_object -si_ihs_fun(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function); -} - -cl_object -si_ihs_env(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env); -} - /* -- General purpose stack implementation ----------------------------------- */ /* Stacks are based on actually adjustable simple vectors. */ @@ -1005,66 +811,3 @@ ecl_stack_popu(cl_object self) self->vector.self.t[self->vector.fillp] = ECL_NIL; return result; } - -/* -- Lisp ops on stacks ---------------------------------------------------- */ - -cl_object -si_set_limit(cl_object type, cl_object limit) -{ - cl_env_ptr env = ecl_process_env(); - cl_index margin; - if (type == @'ext::frame-stack') { - 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 FRS stack below ~D.", 1, limit); - ecl_frs_set_limit(env, request_size); - } else if (type == @'ext::binding-stack') { - cl_index current_size = env->bds_stack.top - env->bds_stack.org; - cl_index request_size = ecl_to_size(limit); - if(current_size > request_size) - FEerror("Cannot shrink BDS stack below ~D.", 1, limit); - ecl_bds_set_limit(env, request_size); - } else if (type == @'ext::lisp-stack') { - cl_index current_size = env->run_stack.top - env->run_stack.org; - cl_index request_size = ecl_to_size(limit); - if(current_size > request_size) - FEerror("Cannot shrink VMS stack below ~D.", 1, limit); - ecl_vms_set_limit(env, request_size); - } else if (type == @'ext::c-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - 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() - * creates a fixnum which is too small for size_t on 32-bit. - */ - size_t the_size = (size_t)ecl_to_ulong(limit); - _ecl_set_max_heap_size(the_size); - } - - ecl_return1(env, si_get_limit(type)); -} - -cl_object -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_stack.limit_size; - else if (type == @'ext::binding-stack') - output = env->bds_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(ecl_core.max_heap_size)); - } - - ecl_return1(env, ecl_make_unsigned_integer(output)); -} - -- GitLab From 2e4b5184aa3852d530abc2d4689239f318c8b85a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 10 Dec 2024 13:24:21 +0100 Subject: [PATCH 57/58] nucleus: introduce a table with early symbols ecl_symbols This table contains symbols that are essential to the core runtime: ECL_T, ECL_UNBOUND, ECL_SIGNAL_HANDLERS, ECL_RESTART_CLUSTERs, ECL_INTERRUPTS_ENABLED, ECL_ALLOW_OTHER_KEYS and ECL_UNBOUND. The table is initialized with constexpr, so it is possible to use its elements in static elements. We also add ecl_def_function to ecl-inl to allow appropriating C functions into Lisp world at top level. --- src/c/all_symbols.d | 4 +-- src/c/boot.d | 18 ++++++++++-- src/c/cinit.d | 2 +- src/c/cmpaux.d | 5 ++-- src/c/file.d | 2 +- src/c/interpreter.d | 4 +-- src/c/main.d | 66 ++++++++++++++++++++++++++---------------- src/c/mem_gc.d | 9 +++--- src/c/pathname.d | 2 +- src/c/read.d | 2 +- src/c/symbol.d | 2 +- src/c/symbols_list.h | 5 ---- src/c/threads/thread.d | 6 ++-- src/c/unixint.d | 4 +-- src/h/ecl-inl.h | 31 ++++++++++++++++++++ src/h/external.h | 2 ++ src/h/object.h | 17 ++++++----- 17 files changed, 121 insertions(+), 60 deletions(-) diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index aba1f51ef..47a0601c8 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -290,8 +290,8 @@ init_all_symbols(void) cl_object s, value; cl_objectfn fun; - /* We skip NIL and T */ - for (i = 2; cl_symbols[i].init.name != NULL; i++) { + /* We skip ECL_NIL_SYMBOL */ + for (i = 1; cl_symbols[i].init.name != NULL; i++) { s = (cl_object)(cl_symbols + i); code = cl_symbols[i].init.type; name = cl_symbols[i].init.name; diff --git a/src/c/boot.d b/src/c/boot.d index e27ffe046..1a53b386f 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -58,9 +58,21 @@ ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const ecl_def_constant(ecl_ct_protect_tag, ECL_NIL, "PROTECT-TAG", 11); ecl_def_constant(ecl_ct_dummy_tag, ECL_NIL, "DUMMY-TAG", 9); -/* This variable is a stack with functions that are called for raised exceptions - and signaled conditions. */ -ecl_def_variable(ecl_vr_shandlers, ECL_NIL, "*SIGNAL-HANDLERS*", 17); +struct ecl_symbol +ecl_symbols[] = { + /* This variable contains handlers for signals and exceptions. */ + ecl_constexpr_symbol(ecl_stp_special, "*SIGNAL-HANDLERS*", ECL_NIL), + /* Restart clusters allow us to estabilish selectable correction actions. */ + ecl_constexpr_symbol(ecl_stp_special, "*RESTART-CLUSTERS*", ECL_NIL), + /* This variable allows for interrupting sygnals from Lisp.. */ + ecl_constexpr_symbol(ecl_stp_special, "*INTERRUPTS-ENABLED*", ECL_T), + /* OP_PUSHKEYS handles specially :ALLOW-OTHER-KEYS (per CL semantics). */ + ecl_constexpr_symbol(ecl_stp_constant, "ALLOW-OTHER-KEYS", ECL_ALLOW_OTHER_KEYS), + /* The universal truth, the supertype of all, the class above classes. */ + ecl_constexpr_symbol(ecl_stp_constant, "T", ECL_T), + /* The marker for unbound slots. This is more a tag than a symbol. */ + ecl_constexpr_symbol(ecl_stp_constant, "UNBOUND", ECL_UNBOUND), +}; /* -- implementation ------------------------------------------------ */ diff --git a/src/c/cinit.d b/src/c/cinit.d index 852d663b9..286391b3a 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -68,7 +68,7 @@ si_bind_simple_restarts(cl_object tag, cl_object names) if (ECL_FBOUNDP(@'si::bind-simple-restarts')) return _ecl_funcall3(@'si::bind-simple-restarts', tag, names); else - return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*'); + return ECL_SYM_VAL(ecl_process_env(), ECL_RESTART_CLUSTERS); } extern cl_object diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index eaced3d20..66d03c09d 100644 --- a/src/c/cmpaux.d +++ b/src/c/cmpaux.d @@ -180,7 +180,7 @@ cl_parse_key( } } /* the key is a new one */ - if (keyword == @':allow-other-keys') { + if (keyword == ECL_ALLOW_OTHER_KEYS) { if (supplied_allow_other_keys == OBJNULL) supplied_allow_other_keys = value; } else if (unknown_keyword == OBJNULL) @@ -193,7 +193,8 @@ cl_parse_key( (supplied_allow_other_keys == ECL_NIL || supplied_allow_other_keys == OBJNULL))) { for (i = 0; i < nkey; i++) { - if (keys[i] == @':allow-other-keys' && vars[nkey+i] == ECL_T && !Null(vars[i])) { + if (keys[i] == ECL_ALLOW_OTHER_KEYS && vars[nkey+i] == ECL_T + && !Null(vars[i])) { return; } } diff --git a/src/c/file.d b/src/c/file.d index 798b0a37f..03fa88411 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -5807,7 +5807,7 @@ ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, @(return strm); @) -@(defun close (strm &key (abort @'nil')) +@(defun close (strm &key (abort ECL_NIL)) @ @(return stream_dispatch_table(strm)->close(strm)); @) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 29eb71c49..f8719d879 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -714,12 +714,12 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) if (count && Null(aok)) { cl_object *p = first; for (; p != last; ++p) { - if (*(p++) == @':allow-other-keys') { + if (*(p++) == ECL_ALLOW_OTHER_KEYS) { aok = *p; count -= 2; /* only the first :allow-other-keys argument is considered */ for (++p; p != last; ++p) { - if (*(p++) != @':allow-other-keys') + if (*(p++) != ECL_ALLOW_OTHER_KEYS) break; count -= 2; } diff --git a/src/c/main.d b/src/c/main.d index 5b5eceec2..c457bb99f 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -146,6 +146,42 @@ maybe_fix_console_stream(cl_object stream) } #endif +static void +init_early_symbol(cl_object symbol, cl_object package) { + symbol->symbol.undef_entry = ecl_undefined_function_entry; + ECL_FMAKUNBOUND(symbol); + cl_import2(symbol, package); + cl_export2(symbol, package); +} + +static void +init_ecl_symbols() +{ + init_early_symbol(ECL_SIGNAL_HANDLERS, cl_core.system_package); + init_early_symbol(ECL_RESTART_CLUSTERS, cl_core.system_package); + init_early_symbol(ECL_INTERRUPTS_ENABLED, cl_core.system_package); + init_early_symbol(ECL_T, cl_core.lisp_package); + init_early_symbol(ECL_UNBOUND, cl_core.system_package); + + /* SYSTEM:UNBOUND has an associated function si_unbound that returns it. */ + ECL_SYM_FUN(ECL_UNBOUND) + = ecl_make_cfun((cl_objectfn_fixed)si_unbound, ECL_UNBOUND, NULL, 0); + + /* Initialize the :ALLOW-OTHER-KEYS symbol (it is not part of cl_symbols). */ + { + cl_object p = cl_core.keyword_package; + cl_object s = ECL_ALLOW_OTHER_KEYS; + cl_object n = s->symbol.name; + ECL_SET(s, OBJNULL); + ECL_FMAKUNBOUND(s); + s->symbol.hpack = p; + s->symbol.undef_entry = ecl_undefined_function_entry; + ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant); + ECL_SET(s, s); + p->pack.external = _ecl_sethash(n, p->pack.external, s); + } +} + int cl_boot(int argc, char **argv) { @@ -175,7 +211,7 @@ cl_boot(int argc, char **argv) /* * Initialize the per-thread data. * This cannot come later, because we need to be able to bind - * ext::*interrupts-enabled* while creating packages. + * ECL_INTERRUPTS_ENABLED while creating packages. */ env = ecl_core.first_env; @@ -203,22 +239,6 @@ cl_boot(int argc, char **argv) #endif cl_num_symbols_in_core=1; - ECL_T->symbol.t = (short)t_symbol; - ECL_T->symbol.value = ECL_T; - ECL_T->symbol.name = str_T; - ECL_T->symbol.cname = ECL_NIL; - ECL_FMAKUNBOUND(ECL_T); - ECL_T->symbol.sfdef = ECL_NIL; - ECL_T->symbol.macfun = ECL_NIL; - ECL_T->symbol.plist = ECL_NIL; - ECL_T->symbol.hpack = ECL_NIL; - ECL_T->symbol.stype = ecl_stp_constant; - ECL_T->symbol.undef_entry = ecl_undefined_function_entry; -#ifdef ECL_THREADS - ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING; -#endif - cl_num_symbols_in_core=2; - cl_core.gensym_prefix = (cl_object)&str_G_data; cl_core.gentemp_prefix = (cl_object)&str_T_data; @@ -278,19 +298,15 @@ cl_boot(int argc, char **argv) cl_import2(ECL_NIL, cl_core.lisp_package); cl_export2(ECL_NIL, cl_core.lisp_package); - ECL_T->symbol.hpack = cl_core.lisp_package; - cl_import2(ECL_T, cl_core.lisp_package); - cl_export2(ECL_T, cl_core.lisp_package); - /* At exit, clean up */ atexit(cl_shutdown); - /* These must come _after_ the packages and NIL/T have been created */ + /* These must come _after_ the packages have been created */ + init_ecl_symbols(); init_all_symbols(); - /* Initialize the handler stack with the exception handler. */ - cl_import2(ECL_SIGNAL_HANDLERS, cl_core.system_package); - cl_export2(ECL_SIGNAL_HANDLERS, cl_core.system_package); + /* Set the default exception handler that coerces exceptions to conditions + that are understood by the condition system. */ ECL_SET(ECL_SIGNAL_HANDLERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); /* diff --git a/src/c/mem_gc.d b/src/c/mem_gc.d index 4de0978a4..56f8afb50 100644 --- a/src/c/mem_gc.d +++ b/src/c/mem_gc.d @@ -85,11 +85,11 @@ out_of_memory(size_t requested_bytes) int interrupts = the_env->disable_interrupts; int method = 0; void *output; - /* Disable interrupts only with the ext::*interrupts-enabled* - * mechanism to allow for writes in the thread local environment */ + /* Disable interrupts only with the ECL_INTERRUPTS_ENABLED mechanism to allow + * for writes in the thread local environment */ if (interrupts) ecl_enable_interrupts_env(the_env); - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + ecl_bds_bind(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); /* Free the input / output buffers */ the_env->string_pool = ECL_NIL; @@ -1166,7 +1166,8 @@ stacks_scanner() } end_loop_for_on_unsafe(l); /* ECL runtime */ GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1)); - GC_push_all((void *)ecl_vr_shandlers, (void *)(ecl_vr_shandlers + 1)); + GC_push_all((void *)(ECL_SIGNAL_HANDLERS), + (void *)(ECL_SIGNAL_HANDLERS + 1)); /* Common Lisp */ GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); diff --git a/src/c/pathname.d b/src/c/pathname.d index ca674a28f..b470d0222 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -562,7 +562,7 @@ ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep, bool logical; if (start == end) { - host = device = path = name = type = aux = version = @'nil'; + host = device = path = name = type = aux = version = ECL_NIL; logical = 0; *ep = end; goto make_it; diff --git a/src/c/read.d b/src/c/read.d index de0727ec9..69a2efa65 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1718,7 +1718,7 @@ do_read_delimited_list(int d, cl_object in, bool proper_list) @(return ECL_CODE_CHAR(c)); } } else if (f == ECL_LISTEN_NO_CHAR) { - @(return @'nil'); + @(return ECL_NIL); } /* We reach here if there was an EOF */ END_OF_FILE: diff --git a/src/c/symbol.d b/src/c/symbol.d index a89faaea9..fe4945da1 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -159,7 +159,7 @@ ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s) #ifndef ECL_FINAL /* Symbols are not initialized yet. This test is issued only during ECL compilation to ensure, that we have no early references in the core. */ - if(cl_num_symbols_in_core < 3) { + if(cl_num_symbols_in_core < 2) { ecl_internal_error("SYMBOL-VALUE: symbols are not initialized yet."); } #endif diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 86196072e..0d4d063e7 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -102,10 +102,6 @@ cl_symbol_initializer cl_symbols[] = { {"NIL" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, -{"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, -{SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)}, -{SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, -{EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)}, {SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "%SIGNAL" ECL_FUN("ecl_signal", ecl_signal, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, @@ -1355,7 +1351,6 @@ cl_symbols[] = { {KEY_ "ADJUSTABLE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "ABORT" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "ABSOLUTE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, -{KEY_ "ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "APPEND" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "ARRAY" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "BACK" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index 314bf50a7..ecf7dc72b 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -449,8 +449,8 @@ mp_block_signals(void) { #ifdef ECL_WINDOWS_THREADS cl_env_ptr the_env = ecl_process_env(); - cl_object previous = ecl_cmp_symbol_value(the_env, @'ext::*interrupts-enabled*'); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + cl_object previous = ecl_cmp_symbol_value(the_env, ECL_INTERRUPTS_ENABLED); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); @(return previous); #else cl_object previous = mp_get_sigmask(); @@ -471,7 +471,7 @@ mp_restore_signals(cl_object sigmask) { #ifdef ECL_WINDOWS_THREADS cl_env_ptr the_env = ecl_process_env(); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, sigmask); ecl_check_pending_interrupts(the_env); @(return sigmask); #else diff --git a/src/c/unixint.d b/src/c/unixint.d index 8cb2d1af1..f53014ba2 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -257,7 +257,7 @@ static ECL_INLINE bool interrupts_disabled_by_lisp(cl_env_ptr the_env) { return !ecl_option_values[ECL_OPT_BOOTED] || - Null(ECL_SYM_VAL(the_env, @'ext::*interrupts-enabled*')); + Null(ECL_SYM_VAL(the_env, ECL_INTERRUPTS_ENABLED)); } static void early_signal_error() ecl_attr_noreturn; @@ -1491,7 +1491,7 @@ enable_unixint() create_signal_code_constants(); install_fpe_signal_handlers(); install_signal_handling_thread(); - ECL_SET(@'ext::*interrupts-enabled*', ECL_T); + ECL_SET(ECL_INTERRUPTS_ENABLED, ECL_T); ecl_process_env()->disable_interrupts = 0; return ECL_NIL; } diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index c1e1a34f9..e4f687a40 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -111,6 +111,28 @@ #define ecl_cast_ptr(type,n) ((type)(n)) #endif +#define ecl_constexpr_string(name) \ + ((struct ecl_base_string) \ + { (int8_t)t_base_string, 0, ecl_aet_bc, 0, ECL_NIL, \ + (cl_index)((sizeof(name)-1)), (cl_index)((sizeof(name)-1)), \ + (ecl_base_char*)(name) }) + +#ifdef ECL_THREADS +#define ecl_constexpr_symbol(type, name, value) \ + ((struct ecl_symbol) \ + { (int8_t)t_symbol, 0, type, 0, \ + value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \ + ECL_NIL, ECL_NIL, ECL_MISSING_SPECIAL_BINDING } ) +#else +#define ecl_constexpr_symbol(type, name, value) \ + ((struct ecl_symbol) \ + { (int8_t)t_symbol, 0, type, 0, \ + value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \ + ECL_NIL, ECL_NIL } ) +#endif + #define ecl_def_variable(name, value, chars, len) \ ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \ ecl_def_ct_token(name, ecl_stp_special, name ## _var_name, value,,) @@ -136,6 +158,15 @@ static const cl_object name = (cl_object)(& name ## _data) #endif +#define ecl_def_function(name, cname, static, const) \ + static const struct ecl_cfunfixed name ##_data = { \ + (int8_t)t_cfunfixed, 0, 0, 0, \ + /*name*/ECL_NIL, /*block*/ECL_NIL, \ + /*entry*/(cl_objectfn)cname, \ + /*funfixed_entry*/(cl_objectfn_fixed)NULL, \ + ECL_NIL, ECL_NIL }; \ + static const cl_object name = (cl_object)(& name ## _data) + #define ecl_def_string_array(name,static,const) \ static const union { \ struct ecl_base_string elt; \ diff --git a/src/h/external.h b/src/h/external.h index f6423024a..37cf6e5da 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -211,6 +211,7 @@ extern ECL_API struct cl_core_struct cl_core; /* variables */ extern ECL_API cl_object ecl_vr_shandlers; +extern ECL_API cl_object ecl_vr_allow_other_keys; /* memory.c */ extern ECL_API void *ecl_malloc(cl_index n); @@ -286,6 +287,7 @@ typedef union { } cl_symbol_initializer; extern ECL_API cl_symbol_initializer cl_symbols[]; extern ECL_API cl_index cl_num_symbols_in_core; +extern ECL_API struct ecl_symbol ecl_symbols[]; #define ECL_SYM(name,code) ((cl_object)(cl_symbols+(code))) diff --git a/src/h/object.h b/src/h/object.h index 85b5d4a28..f29fe449f 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -262,16 +262,19 @@ enum ecl_stype { /* symbol type */ }; #define ECL_NIL ((cl_object)t_list) +#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) + #define ECL_PROTECT_TAG ecl_ct_protect_tag #define ECL_DUMMY_TAG ecl_ct_dummy_tag -#define ECL_SIGNAL_HANDLERS ecl_vr_shandlers -#define ECL_NIL_SYMBOL ((cl_object)cl_symbols) -#define ECL_T ((cl_object)(cl_symbols+1)) -#define ECL_UNBOUND ((cl_object)(cl_symbols+2)) -#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+3)) -#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+4)) -#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) +#define ECL_SIGNAL_HANDLERS ((cl_object)(ecl_symbols+0)) +#define ECL_RESTART_CLUSTERS ((cl_object)(ecl_symbols+1)) +#define ECL_INTERRUPTS_ENABLED ((cl_object)(ecl_symbols+2)) +#define ECL_ALLOW_OTHER_KEYS ((cl_object)(ecl_symbols+3)) +#define ECL_T ((cl_object)(ecl_symbols+4)) +#define ECL_UNBOUND ((cl_object)(ecl_symbols+5)) + +#define ECL_NIL_SYMBOL ((cl_object)(cl_symbols+0)) struct ecl_symbol { _ECL_HDR1(stype); /* symbol type */ -- GitLab From 0e1267f579d9eaaecca3872d6dba8aadd5f3dcf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 15 May 2025 12:09:59 +0200 Subject: [PATCH 58/58] msvc: update the makefile and specify /std:c11 minimal standard MSVC does not allow for specifying /std:c99 so we need c11. We don't rely on the default standard because it does not allow for static struct initializers. --- msvc/Makefile | 2 +- msvc/c/Makefile | 61 ++++++++++++++++++++++++++++--------------------- 2 files changed, 36 insertions(+), 27 deletions(-) diff --git a/msvc/Makefile b/msvc/Makefile index 7b2f540ba..e1dc4df56 100755 --- a/msvc/Makefile +++ b/msvc/Makefile @@ -134,7 +134,7 @@ GCFLAGS = nodebug=1 CLIBS = $(CLIBS) DbgHelp.lib !endif -CFLAGS = /EHsc /DGC_DLL /DGC_BUILD /nologo /wd4068 /wd4715 /wd4716 /D_CRT_SECURE_NO_DEPRECATE $(CFLAGS_CONFIG) +CFLAGS = /EHsc /DGC_DLL /DGC_BUILD /nologo /wd4068 /wd4715 /wd4716 /D_CRT_SECURE_NO_DEPRECATE /std:c11 $(CFLAGS_CONFIG) LDFLAGS = /link /incremental:no /nologo $(LDFLAGS_CONFIG) /STACK:$(ECL_DEFAULT_C_STACK_SIZE) diff --git a/msvc/c/Makefile b/msvc/c/Makefile index c9d02ab66..c141a8d6b 100755 --- a/msvc/c/Makefile +++ b/msvc/c/Makefile @@ -13,7 +13,7 @@ ECL_FPE_CODE=fpe_x86.c !if "$(ECL_THREADS)" != "" ECL_THREADS_FLAG=1 THREADS_OBJ= thread.obj mutex.obj condition_variable.obj rwlock.obj \ - semaphore.obj barrier.obj mailbox.obj atomic.obj + semaphore.obj barrier.obj mailbox.obj !else ECL_THREADS_FLAG=0 THREADS_OBJ= @@ -47,7 +47,7 @@ ECL_USE_DBGHELP_FLAG=0 # Programs used by "make": # CC = cl -CFLAGS = -c $(ECL_CFLAGS) -DECL_BUILD -DECL_API="__declspec(dllexport)" -I./ -I../ -I../ecl -I$(srcdir) -I$(srcdir)/unicode +CFLAGS = -c $(ECL_CFLAGS) /std:c11 -DECL_BUILD -DECL_API="__declspec(dllexport)" -I./ -I../ -I../ecl -I$(srcdir) -I$(srcdir)/unicode SHELL = /bin/sh RM = del @@ -79,20 +79,13 @@ HFILES = ..\ecl\config.h ..\ecl\config-internal.h ..\ecl\atomic_ops.h \ $(HDIR)\cache.h $(HDIR)\stack-resize.h \ $(HDIR)\ecl_atomics.h -OBJS = main.obj symbol.obj package.obj cons.obj list.obj\ - apply.obj eval.obj \ - interpreter.obj compiler.obj disassembler.obj \ - instance.obj gfun.obj cache.obj accessor.obj \ - reference.obj character.obj\ - file.obj read.obj print.obj error.obj string.obj cfun.obj\ - parse_integer.obj parse_number.obj \ - float_to_digits.obj float_to_string.obj \ - integer_to_string.obj write_ugly.obj \ - write_object.obj write_symbol.obj \ - write_array.obj write_list.obj write_code.obj \ - write_sse.obj print_unreadable.obj \ - libraries.obj backtrace.obj mmap.obj cdata.obj \ - cos.obj sin.obj tan.obj atan.obj \ +NUCL_OBJS = boot.obj call.obj jump.obj atomic.obj process.obj memory.obj \ + module.obj stacks.obj + +CLOS_OBJS = instance.obj gfun.obj cache.obj accessor.obj + +NUM_OBJS = number.obj num_pred.obj num_arith.obj num_co.obj \ + num_log.obj num_rand.obj cos.obj sin.obj tan.obj atan.obj \ cosh.obj sinh.obj tanh.obj \ exp.obj expt.obj log.obj \ sqrt.obj abs.obj \ @@ -101,18 +94,34 @@ OBJS = main.obj symbol.obj package.obj cons.obj list.obj\ one_plus.obj one_minus.obj \ plus.obj minus.obj times.obj divide.obj \ number_compare.obj number_equalp.obj minmax.obj \ - floor.obj ceiling.obj round.obj truncate.obj \ - typespec.obj assignment.obj \ - predicate.obj big.obj number.obj\ - num_pred.obj num_arith.obj num_co.obj\ - num_log.obj num_rand.obj array.obj vector_push.obj \ + floor.obj ceiling.obj round.obj truncate.obj + +WRITER_OBJS = print.obj float_to_digits.obj float_to_string.obj \ + integer_to_string.obj write_ugly.obj \ + write_object.obj write_symbol.obj \ + write_array.obj write_list.obj write_code.obj \ + write_sse.obj print_unreadable.obj + +READER_OBJS = read.obj parse_integer.obj parse_number.obj + +FFI_OBJS = ffi.obj libraries.obj backtrace.obj mmap.obj cdata.obj + +GC_OBJS = alloc.obj gbc.obj + +OBJS = main.obj symbol.obj package.obj cons.obj list.obj\ + eval.obj interpreter.obj compiler.obj disassembler.obj \ + reference.obj character.obj file.obj error.obj \ + string.obj cfun.obj typespec.obj assignment.obj \ + predicate.obj big.obj array.obj vector_push.obj \ sequence.obj cmpaux.obj\ - macros.obj backq.obj stacks.obj \ - time.obj unixint.obj memory.obj \ + macros.obj backq.obj stack2.obj \ + time.obj unixint.obj \ mapfun.obj multival.obj hash.obj format.obj pathname.obj\ - structure.obj load.obj unixfsys.obj unixsys.obj \ - ffi.obj alloc_2.obj tcp.obj $(THREADS_OBJ) process.obj serialize.obj \ - $(ECL_UCD_OBJ) $(ECL_SSE_OBJ) + structure.obj load.obj unixfsys.obj unixsys.obj serialize.obj \ + mem_gc.obj tcp.obj \ + $(NUCL_OBJS) $(CLOS_OBJS) $(NUM_OBJS) $(FFI_OBJS) \ + $(WRITER_OBJS) $(READER_OBJS) $(THREADS_OBJ) \ + $(ECL_UCD_OBJ) $(ECL_SSE_OBJ) $(NUCL_OBJS) all: $(DPP) ..\eclmin.lib ..\cinit.obj -- GitLab