From 844296da75821445f89b0c93f2a4949ac2544d2a 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] 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/escape.d | 17 +++ src/c/interpreter.d | 44 +++++++ src/c/stack2.d | 251 ++++++++++++++++++++++++++++++++++++++++ src/c/stacks.d | 272 -------------------------------------------- 5 files changed, 314 insertions(+), 274 deletions(-) create mode 100644 src/c/stack2.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 49d9a1e07..47d94d731 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 -BOOT_OBJS = boot.o escape.o eql.o module.o +BOOT_OBJS = boot.o escape.o eql.o module.o stacks.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o @@ -82,7 +82,7 @@ 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 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 \ + 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 atomic.o process.o \ $(BOOT_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(STREAM_OBJS) \ diff --git a/src/c/escape.d b/src/c/escape.d index e0475872f..fc7a028cb 100644 --- a/src/c/escape.d +++ b/src/c/escape.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_STACK_UNWIND(env, top->frs_run_ndx); + env->frs_stack.top = top; + ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); + /* never reached */ +} + void cl_throw(cl_object tag) { diff --git a/src/c/interpreter.d b/src/c/interpreter.d index be3214c71..bfed39176 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/stack2.d b/src/c/stack2.d new file mode 100644 index 000000000..a9e2ce689 --- /dev/null +++ b/src/c/stack2.d @@ -0,0 +1,251 @@ +/* -*- 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_lex(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env); +} + +cl_object +si_ihs_lcl(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lcl_env); +} + +/* DEPRECATED backward compatibility with SWANK/SLYNK. --jd 2025-11-17 */ +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))->lcl_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 frame 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 binding stack below ~D.", 1, limit); + ecl_bds_set_limit(env, request_size); + } else if (type == @'ext::lisp-stack') { + cl_index current_size = env->run_stack.top - env->run_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink lisp stack below ~D.", 1, limit); + ecl_data_stack_set_limit(env, request_size); + } else if (type == @'ext::c-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + 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 9d4c8a16d..e71803372 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -805,215 +805,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_STACK_UNWIND(env, top->frs_run_ndx); - env->frs_stack.top = top; - ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); - /* never reached */ -} - -cl_index -ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) -{ - cl_object vars = vars0, values = values0; - cl_index n = env->bds_stack.top - env->bds_stack.org; - for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { - if (Null(vars)) { - return n; - } else { - cl_object var = ECL_CONS_CAR(vars); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - if (ecl_symbol_type(var) & ecl_stp_constant) - FEbinding_a_constant(var); - if (Null(values)) { - ecl_bds_bind(env, var, OBJNULL); - } else { - ecl_bds_bind(env, var, ECL_CONS_CAR(values)); - values = ECL_CONS_CDR(values); - } - } - } - FEerror("Wrong arguments to special form PROGV. Either~%" - "~A~%or~%~A~%are not proper lists", - 2, vars0, values0); -} - -/* -- Bindings stack -------------------------------------------------------- */ - -static ecl_bds_ptr -get_bds_ptr(cl_object x) -{ - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x); - if (env->bds_stack.org <= p && p <= env->bds_stack.top) - return(p); - } - FEerror("~S is an illegal bds index.", 1, x); -} - -cl_object -si_bds_top() -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org)); -} - -cl_object -si_bds_var(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_bds_ptr(arg)->symbol); -} - -cl_object -si_bds_val(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - cl_object v = get_bds_ptr(arg)->value; - ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v)); -} - -/* -- Frame stack ----------------------------------------------------------- */ - -static ecl_frame_ptr -get_frame_ptr(cl_object x) -{ - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x); - if (env->frs_stack.org <= p && p <= env->frs_stack.top) - return p; - } - FEerror("~S is an illegal frs index.", 1, x); -} - -cl_object -si_frs_top() -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org)); -} - -cl_object -si_frs_bds(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx)); -} - -cl_object -si_frs_tag(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_frame_ptr(arg)->frs_val); -} - -cl_object -si_frs_ihs(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)); -} - -cl_object -si_sch_frs_base(cl_object fr, cl_object ihs) -{ - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr x; - cl_index y = ecl_to_size(ihs); - for (x = get_frame_ptr(fr); - x <= env->frs_stack.top && x->frs_ihs->index < y; - x++); - ecl_return1(env, ((x > env->frs_stack.top) - ? ECL_NIL - : ecl_make_fixnum(x - env->frs_stack.org))); -} - -/* -- Invocation stack ------------------------------------------------------ */ - -static ecl_ihs_ptr -get_ihs_ptr(cl_index n) -{ - 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_lex(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env); -} - -cl_object -si_ihs_lcl(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lcl_env); -} - -/* DEPRECATED backward compatibility with SWANK/SLYNK. --jd 2025-11-17 */ -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))->lcl_env); -} - /* -- General purpose stack implementation ----------------------------------- */ /* Stacks are based on actually adjustable simple vectors. */ @@ -1107,66 +898,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 frame 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 binding stack below ~D.", 1, limit); - ecl_bds_set_limit(env, request_size); - } else if (type == @'ext::lisp-stack') { - cl_index current_size = env->run_stack.top - env->run_stack.org; - cl_index request_size = ecl_to_size(limit); - if(current_size > request_size) - FEerror("Cannot shrink lisp stack below ~D.", 1, limit); - ecl_data_stack_set_limit(env, request_size); - } else if (type == @'ext::c-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - 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)); -} -