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] 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 | 226 +++++++++++++++++++++----------------------- src/c/string.d | 2 +- src/h/external.h | 3 +- src/h/stacks.h | 10 +- 8 files changed, 148 insertions(+), 158 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) -{ - 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 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)); - - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - 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); - } - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - return env->run_stack.top; -} - void -FEstack_underflow(void) +vms_set_limit(cl_env_ptr env, cl_index new_lim_size) { - FEerror("Internal error: stack underflow.",0); + cl_index margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + cl_object *old_org = env->run_stack.org; + cl_object *new_org = NULL; + cl_index osize = env->run_stack.size; + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->run_stack.top - old_org; + if (current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + 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 = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); } 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; }