mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-16 01:40:33 -07:00
Merge branch 'refactor-stacks' into 'develop'
refactor stacks to reduce dependencies See merge request embeddable-common-lisp/ecl!348
This commit is contained in:
Marius Gerbershagen
commit
cb9b63a9a7
22 changed files with 1109 additions and 848 deletions
|
|
@ -29,7 +29,14 @@
|
|||
|
||||
* Pending changes since 24.5.10
|
||||
|
||||
- Many internal improvements and bug fixes for the native compiler.
|
||||
- Process initial bindings, when specified, are inherited when the process
|
||||
is enabled (previously they were copied when the process was created)
|
||||
|
||||
- Bytecodes VM stores locals on the stack (performance improvement)
|
||||
|
||||
- Bytecodes closures capture now only closed over variables (not whole env)
|
||||
|
||||
- MANY internal improvements and bug fixes for the native compiler.
|
||||
|
||||
- Reduced function call overhead.
|
||||
|
||||
|
|
|
|||
|
|
@ -676,12 +676,12 @@ void init_type_info (void)
|
|||
to_bitmap(&o, &(o.process.name)) |
|
||||
to_bitmap(&o, &(o.process.function)) |
|
||||
to_bitmap(&o, &(o.process.args)) |
|
||||
to_bitmap(&o, &(o.process.env)) |
|
||||
to_bitmap(&o, &(o.process.interrupt)) |
|
||||
to_bitmap(&o, &(o.process.initial_bindings)) |
|
||||
to_bitmap(&o, &(o.process.inherit_bindings_p)) |
|
||||
to_bitmap(&o, &(o.process.parent)) |
|
||||
to_bitmap(&o, &(o.process.exit_values)) |
|
||||
to_bitmap(&o, &(o.process.woken_up));
|
||||
to_bitmap(&o, &(o.process.woken_up)) |
|
||||
to_bitmap(&o, &(o.process.env));
|
||||
type_info[t_lock].descriptor =
|
||||
to_bitmap(&o, &(o.lock.name)) |
|
||||
to_bitmap(&o, &(o.lock.owner));
|
||||
|
|
@ -1152,19 +1152,18 @@ update_bytes_consed () {
|
|||
static void
|
||||
ecl_mark_env(struct cl_env_struct *env)
|
||||
{
|
||||
if (env->stack) {
|
||||
GC_push_conditional((void *)env->stack, (void *)env->stack_top, 1);
|
||||
GC_set_mark_bit((void *)env->stack);
|
||||
}
|
||||
if (env->frs_top) {
|
||||
GC_push_conditional((void *)env->frs_org, (void *)(env->frs_top+1), 1);
|
||||
GC_set_mark_bit((void *)env->frs_org);
|
||||
}
|
||||
if (env->bds_top) {
|
||||
GC_push_conditional((void *)env->bds_org, (void *)(env->bds_top+1), 1);
|
||||
GC_set_mark_bit((void *)env->bds_org);
|
||||
}
|
||||
/* When not using threads, "env" is mmaped or statically allocated. */
|
||||
/* Environments and stacks are allocated without GC */
|
||||
if (env->run_stack.org)
|
||||
GC_push_all((void *)env->run_stack.org, (void *)env->run_stack.top);
|
||||
if (env->frs_stack.org)
|
||||
GC_push_all((void *)env->frs_stack.org, (void *)(env->frs_stack.top+1));
|
||||
if (env->bds_stack.org)
|
||||
GC_push_all((void *)env->bds_stack.org, (void *)(env->bds_stack.top+1));
|
||||
#ifdef ECL_THREADS
|
||||
if (env->bds_stack.tl_bindings)
|
||||
GC_push_all((void *)env->bds_stack.tl_bindings,
|
||||
(void *)(env->bds_stack.tl_bindings + env->bds_stack.tl_bindings_size));
|
||||
#endif
|
||||
GC_push_all((void *)env, (void *)(env + 1));
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ typedef struct cl_compiler_env *cl_compiler_ptr;
|
|||
#define asm_begin(env) current_pc(env)
|
||||
#define current_pc(env) ECL_STACK_INDEX(env)
|
||||
#define set_pc(env,n) asm_clear(env,n)
|
||||
#define asm_ref(env,n) (cl_fixnum)((env)->stack[n])
|
||||
#define asm_ref(env,n) (cl_fixnum)((env)->run_stack.org[n])
|
||||
static void asm_clear(cl_env_ptr env, cl_index h);
|
||||
static void asm_op(cl_env_ptr env, cl_fixnum op);
|
||||
static void asm_op2(cl_env_ptr env, int op, int arg);
|
||||
|
|
@ -192,7 +192,7 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) {
|
|||
output->bytecodes.flex = ECL_NIL;
|
||||
output->bytecodes.nlcl = ecl_make_fixnum(c_env->env_width);
|
||||
for (i = 0, code = (cl_opcode *)output->bytecodes.code; i < code_size; i++) {
|
||||
code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]);
|
||||
code[i] = (cl_opcode)(cl_fixnum)(env->run_stack.org[beginning+i]);
|
||||
}
|
||||
output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg;
|
||||
ecl_set_function_source_file_info(output, (file == OBJNULL)? ECL_NIL : file,
|
||||
|
|
@ -211,7 +211,7 @@ asm_op(cl_env_ptr env, cl_fixnum code) {
|
|||
|
||||
static void
|
||||
asm_clear(cl_env_ptr env, cl_index h) {
|
||||
ECL_STACK_SET_INDEX(env, h);
|
||||
ECL_STACK_UNWIND(env, h);
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -257,7 +257,7 @@ asm_complete(cl_env_ptr env, int op, cl_index pc) {
|
|||
else if (ecl_unlikely(delta < -MAX_OPARG || delta > MAX_OPARG))
|
||||
FEprogram_error("Too large jump", 0);
|
||||
else {
|
||||
env->stack[pc] = (cl_object)(cl_fixnum)delta;
|
||||
env->run_stack.org[pc] = (cl_object)(cl_fixnum)delta;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -1446,7 +1446,7 @@ c_catch(cl_env_ptr env, cl_object args, int flags) {
|
|||
static int
|
||||
c_compiler_let(cl_env_ptr env, cl_object args, int flags) {
|
||||
cl_object bindings;
|
||||
cl_index old_bds_top_index = env->bds_top - env->bds_org;
|
||||
cl_index old_bds_ndx = env->bds_stack.top - env->bds_stack.org;
|
||||
|
||||
for (bindings = pop(&args); !Null(bindings); ) {
|
||||
cl_object form = pop(&bindings);
|
||||
|
|
@ -1455,7 +1455,7 @@ c_compiler_let(cl_env_ptr env, cl_object args, int flags) {
|
|||
ecl_bds_bind(env, var, value);
|
||||
}
|
||||
flags = compile_toplevel_body(env, args, flags);
|
||||
ecl_bds_unwind(env, old_bds_top_index);
|
||||
ecl_bds_unwind(env, old_bds_ndx);
|
||||
return flags;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -104,8 +104,8 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message)
|
|||
ecl_unwind(the_env, destination);
|
||||
}
|
||||
}
|
||||
if (the_env->frs_org <= the_env->frs_top) {
|
||||
destination = ecl_process_env()->frs_org;
|
||||
if (the_env->frs_stack.org <= the_env->frs_stack.top) {
|
||||
destination = ecl_process_env()->frs_stack.org;
|
||||
ecl_unwind(the_env, destination);
|
||||
} else {
|
||||
ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;");
|
||||
|
|
@ -162,6 +162,24 @@ CEerror(cl_object c, const char *err, int narg, ...)
|
|||
* Conditions signaler *
|
||||
***********************/
|
||||
|
||||
void
|
||||
CEstack_overflow(cl_object type, cl_object limit, cl_object resume)
|
||||
{
|
||||
cl_env_ptr the_env = ecl_process_env();
|
||||
cl_index the_size;
|
||||
if (!Null(resume)) resume = @"Extend stack size";
|
||||
ECL_UNWIND_PROTECT_BEGIN(the_env) {
|
||||
cl_cerror(6, resume, @'ext::stack-overflow', @':type', type, @':size', limit);
|
||||
} ECL_UNWIND_PROTECT_EXIT {
|
||||
/* reset the margin */
|
||||
si_set_limit(type, limit);
|
||||
} ECL_UNWIND_PROTECT_END;
|
||||
/* resize the stack */
|
||||
the_size = ecl_to_size(limit);
|
||||
the_size = the_size + the_size/2;
|
||||
si_set_limit(type, ecl_make_fixnum(the_size));
|
||||
}
|
||||
|
||||
void
|
||||
FEprogram_error(const char *s, int narg, ...)
|
||||
{
|
||||
|
|
@ -287,7 +305,7 @@ FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type)
|
|||
struct ecl_ihs_frame tmp_ihs;
|
||||
function = cl_symbol_or_object(function);
|
||||
type = cl_symbol_or_object(type);
|
||||
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
|
||||
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
|
||||
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
|
||||
}
|
||||
si_signal_simple_error(8,
|
||||
|
|
@ -311,7 +329,7 @@ FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_objec
|
|||
struct ecl_ihs_frame tmp_ihs;
|
||||
function = cl_symbol_or_object(function);
|
||||
type = cl_symbol_or_object(type);
|
||||
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
|
||||
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
|
||||
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
|
||||
}
|
||||
si_signal_simple_error(8,
|
||||
|
|
@ -337,7 +355,7 @@ FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_obje
|
|||
function = cl_symbol_or_object(function);
|
||||
type = cl_symbol_or_object(type);
|
||||
key = cl_symbol_or_object(key);
|
||||
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
|
||||
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
|
||||
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
|
||||
}
|
||||
si_signal_simple_error(8,
|
||||
|
|
@ -368,7 +386,7 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx,
|
|||
cl_env_ptr env = ecl_process_env();
|
||||
struct ecl_ihs_frame tmp_ihs;
|
||||
function = cl_symbol_or_object(function);
|
||||
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
|
||||
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
|
||||
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
|
||||
}
|
||||
cl_error(9,
|
||||
|
|
@ -506,8 +524,7 @@ universal_error_handler(cl_object continue_string, cl_object datum,
|
|||
ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(8));
|
||||
ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL);
|
||||
ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10));
|
||||
writestr_stream("\n;;; Unhandled lisp initialization error",
|
||||
stream);
|
||||
writestr_stream("\n;;; Unhandled lisp initialization error", stream);
|
||||
writestr_stream("\n;;; Message:\n", stream);
|
||||
si_write_ugly_object(datum, stream);
|
||||
writestr_stream("\n;;; Arguments:\n", stream);
|
||||
|
|
@ -601,13 +618,6 @@ FEwin32_error(const char *msg, int narg, ...)
|
|||
cl_grab_rest_args(args)));
|
||||
} @)
|
||||
|
||||
@(defun si::serror (cformat eformat &rest args)
|
||||
@ {
|
||||
ecl_enable_interrupts();
|
||||
@(return funcall(4, @'si::stack-error-handler', cformat, eformat,
|
||||
cl_grab_rest_args(args)));
|
||||
} @)
|
||||
|
||||
void
|
||||
init_error(void)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -149,7 +149,7 @@ cl_funcall(cl_narg narg, cl_object function, ...)
|
|||
(cl_object)&frame_aux,
|
||||
narg -= 2);
|
||||
for (i = 0; i < narg; i++) {
|
||||
ECL_STACK_FRAME_SET(frame, i, lastarg);
|
||||
ecl_stack_frame_push(frame, lastarg);
|
||||
lastarg = ecl_va_arg(args);
|
||||
}
|
||||
if (ecl_t_of(lastarg) == t_frame) {
|
||||
|
|
|
|||
|
|
@ -942,7 +942,7 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type,
|
|||
ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs);
|
||||
object = ecl_foreign_data_ref_elt(the_env->ffi_values,
|
||||
ecl_foreign_type_code(return_type));
|
||||
ECL_STACK_SET_INDEX(the_env, sp);
|
||||
ECL_STACK_UNWIND(the_env, sp);
|
||||
if (object != ECL_NIL) {
|
||||
@(return object);
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -1089,13 +1089,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
|
|||
|
||||
CASE(OP_BLOCK); {
|
||||
GET_DATA(reg0, vector, data);
|
||||
reg1 = ecl_make_fixnum(the_env->frame_id++);
|
||||
reg1 = ecl_make_fixnum(the_env->frs_stack.frame_id++);
|
||||
bind_frame(lcl_env, reg1, reg0);
|
||||
THREAD_NEXT;
|
||||
}
|
||||
CASE(OP_DO); {
|
||||
reg0 = ECL_NIL;
|
||||
reg1 = ecl_make_fixnum(the_env->frame_id++);
|
||||
reg1 = ecl_make_fixnum(the_env->frs_stack.frame_id++);
|
||||
bind_frame(lcl_env, reg1, reg0);
|
||||
THREAD_NEXT;
|
||||
}
|
||||
|
|
@ -1270,13 +1270,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
|
|||
vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env);
|
||||
unwind_lcl(lcl_env, ECL_STACK_POP_UNSAFE(the_env));
|
||||
reg0 = the_env->values[0];
|
||||
ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->nlj_fr - the_env->frs_top));
|
||||
ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->frs_stack.nlj_fr - the_env->frs_stack.top));
|
||||
goto PUSH_VALUES;
|
||||
}
|
||||
THREAD_NEXT;
|
||||
}
|
||||
CASE(OP_PROTECT_NORMAL); {
|
||||
ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index);
|
||||
ecl_bds_unwind(the_env, the_env->frs_stack.top->frs_bds_ndx);
|
||||
ecl_frs_pop(the_env);
|
||||
(void)ECL_STACK_POP_UNSAFE(the_env);
|
||||
unwind_lcl(lcl_env, ECL_STACK_POP_UNSAFE(the_env));
|
||||
|
|
@ -1290,7 +1290,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
|
|||
reg0 = the_env->values[0];
|
||||
n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env));
|
||||
if (n <= 0)
|
||||
ecl_unwind(the_env, the_env->frs_top + n);
|
||||
ecl_unwind(the_env, the_env->frs_stack.top + n);
|
||||
THREAD_NEXT;
|
||||
}
|
||||
|
||||
|
|
@ -1325,9 +1325,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
|
|||
GET_DATA(form, vector, data);
|
||||
SETUP_ENV(the_env);
|
||||
the_env->values[0] = reg0;
|
||||
n = ecl_stack_push_values(the_env);
|
||||
n = ecl_data_stack_push_values(the_env);
|
||||
call_stepper(the_env, form, ecl_make_fixnum(1));
|
||||
ecl_stack_pop_values(the_env, n);
|
||||
ecl_data_stack_pop_values(the_env, n);
|
||||
reg0 = the_env->values[0];
|
||||
THREAD_NEXT;
|
||||
}
|
||||
|
|
@ -1345,9 +1345,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
|
|||
cl_index n;
|
||||
SETUP_ENV(the_env);
|
||||
the_env->values[0] = reg0;
|
||||
n = ecl_stack_push_values(the_env);
|
||||
n = ecl_data_stack_push_values(the_env);
|
||||
call_stepper(the_env, ECL_NIL, ecl_make_fixnum(-1));
|
||||
ecl_stack_pop_values(the_env, n);
|
||||
ecl_data_stack_pop_values(the_env, n);
|
||||
reg0 = the_env->values[0];
|
||||
THREAD_NEXT;
|
||||
}
|
||||
|
|
|
|||
20
src/c/main.d
20
src/c/main.d
|
|
@ -194,13 +194,6 @@ ecl_init_first_env(cl_env_ptr env)
|
|||
{
|
||||
#ifdef ECL_THREADS
|
||||
init_threads();
|
||||
#endif
|
||||
#ifdef ECL_THREADS
|
||||
env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024),
|
||||
ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL);
|
||||
si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
|
||||
env->thread_local_bindings_size = env->bindings_array->vector.dim;
|
||||
env->thread_local_bindings = env->bindings_array->vector.self.t;
|
||||
#endif
|
||||
init_env_mp(env);
|
||||
init_env_int(env);
|
||||
|
|
@ -222,8 +215,9 @@ ecl_init_env(cl_env_ptr env)
|
|||
void
|
||||
_ecl_dealloc_env(cl_env_ptr env)
|
||||
{
|
||||
/* Environment cleanup. This is required becauyse the environment is allocated
|
||||
* using mmap or some other method. We could do more cleaning here.*/
|
||||
/* Environment cleanup. This is required because the environment is allocated
|
||||
* using mmap or some other method. */
|
||||
free_stacks(env);
|
||||
#ifdef ECL_THREADS
|
||||
ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock);
|
||||
#endif
|
||||
|
|
@ -281,6 +275,9 @@ _ecl_alloc_env(cl_env_ptr parent)
|
|||
output->default_sigmask = cl_core.default_sigmask;
|
||||
}
|
||||
}
|
||||
for (cl_index i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
|
||||
output->big_register[i] = ECL_NIL;
|
||||
}
|
||||
output->method_cache = output->slot_cache = NULL;
|
||||
output->interrupt_struct = NULL;
|
||||
/*
|
||||
|
|
@ -516,7 +513,6 @@ cl_boot(int argc, char **argv)
|
|||
|
||||
env = cl_core.first_env;
|
||||
ecl_init_first_env(env);
|
||||
ecl_cs_set_org(env);
|
||||
|
||||
/*
|
||||
* 1) Initialize symbols and packages
|
||||
|
|
@ -814,8 +810,8 @@ cl_boot(int argc, char **argv)
|
|||
}
|
||||
#endif
|
||||
ECL_SET(@'ext::*program-exit-code*', code);
|
||||
if (the_env->frs_org <= the_env->frs_top)
|
||||
ecl_unwind(the_env, the_env->frs_org);
|
||||
if (the_env->frs_stack.org <= the_env->frs_stack.top)
|
||||
ecl_unwind(the_env, the_env->frs_stack.org);
|
||||
si_exit(1, code);
|
||||
}
|
||||
@)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
1174
src/c/stacks.d
1174
src/c/stacks.d
File diff suppressed because it is too large
Load diff
|
|
@ -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)},
|
||||
|
|
|
|||
|
|
@ -222,7 +222,7 @@ thread_entry_point(void *arg)
|
|||
#ifndef ECL_WINDOWS_THREADS
|
||||
pthread_cleanup_push(thread_cleanup, (void *)process);
|
||||
#endif
|
||||
ecl_cs_set_org(env);
|
||||
ecl_cs_init(env);
|
||||
ecl_mutex_lock(&process->process.start_stop_lock);
|
||||
|
||||
/* 2) Execute the code. The CATCH_ALL point is the destination
|
||||
|
|
@ -273,26 +273,43 @@ thread_entry_point(void *arg)
|
|||
#endif
|
||||
}
|
||||
|
||||
static void
|
||||
init_tl_bindings(cl_object process, cl_env_ptr env)
|
||||
{
|
||||
cl_index bindings_size;
|
||||
cl_object *bindings;
|
||||
if (Null(process->process.inherit_bindings_p)) {
|
||||
cl_index idx = 0, size = 256;
|
||||
bindings_size = size;
|
||||
bindings = (cl_object *)ecl_malloc(size*sizeof(cl_object*));
|
||||
for(idx=0; idx<256; idx++) {
|
||||
bindings[idx] = ECL_NO_TL_BINDING;
|
||||
}
|
||||
} else {
|
||||
cl_env_ptr parent_env = ecl_process_env();
|
||||
bindings_size = parent_env->bds_stack.tl_bindings_size;
|
||||
bindings = (cl_object *)ecl_malloc(bindings_size*sizeof(cl_object*));
|
||||
ecl_copy(bindings, parent_env->bds_stack.tl_bindings, bindings_size*sizeof(cl_object*));
|
||||
}
|
||||
env->bds_stack.tl_bindings_size = bindings_size;
|
||||
env->bds_stack.tl_bindings = bindings;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
alloc_process(cl_object name, cl_object initial_bindings)
|
||||
alloc_process(cl_object name, cl_object initial_bindings_p)
|
||||
{
|
||||
cl_env_ptr env = ecl_process_env();
|
||||
cl_object process = ecl_alloc_object(t_process), array;
|
||||
cl_index bindings_size;
|
||||
cl_object* bindings;
|
||||
process->process.phase = ECL_PROCESS_INACTIVE;
|
||||
process->process.name = name;
|
||||
process->process.function = ECL_NIL;
|
||||
process->process.args = ECL_NIL;
|
||||
process->process.interrupt = ECL_NIL;
|
||||
process->process.inherit_bindings_p = Null(initial_bindings_p)? ECL_T : ECL_NIL;
|
||||
process->process.exit_values = ECL_NIL;
|
||||
process->process.env = NULL;
|
||||
if (initial_bindings != ECL_NIL || env->bindings_array == OBJNULL) {
|
||||
array = si_make_vector(ECL_T, ecl_make_fixnum(256),
|
||||
ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL);
|
||||
si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
|
||||
} else {
|
||||
array = cl_copy_seq(ecl_process_env()->bindings_array);
|
||||
}
|
||||
process->process.initial_bindings = array;
|
||||
process->process.woken_up = ECL_NIL;
|
||||
ecl_disable_interrupts_env(env);
|
||||
ecl_mutex_init(&process->process.start_stop_lock, TRUE);
|
||||
|
|
@ -351,16 +368,14 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
|
|||
|
||||
/* Allocate real environment, link it together with process */
|
||||
env = _ecl_alloc_env(0);
|
||||
process = alloc_process(name, bindings);
|
||||
process = alloc_process(name, ECL_NIL);
|
||||
process->process.env = env;
|
||||
process->process.phase = ECL_PROCESS_BOOTING;
|
||||
process->process.thread = current;
|
||||
|
||||
/* Copy initial bindings from process to the fake environment */
|
||||
env_aux->cleanup = registered;
|
||||
env_aux->bindings_array = process->process.initial_bindings;
|
||||
env_aux->thread_local_bindings_size = env_aux->bindings_array->vector.dim;
|
||||
env_aux->thread_local_bindings = env_aux->bindings_array->vector.self.t;
|
||||
init_tl_bindings(process, env_aux);
|
||||
|
||||
/* Switch over to the real environment */
|
||||
memcpy(env, env_aux, sizeof(*env));
|
||||
|
|
@ -390,10 +405,10 @@ ecl_release_current_thread(void)
|
|||
#endif
|
||||
}
|
||||
|
||||
@(defun mp::make-process (&key name ((:initial-bindings initial_bindings) ECL_T))
|
||||
@(defun mp::make-process (&key name ((:initial-bindings initial_bindings_p) ECL_T))
|
||||
cl_object process;
|
||||
@
|
||||
process = alloc_process(name, initial_bindings);
|
||||
process = alloc_process(name, initial_bindings_p);
|
||||
@(return process);
|
||||
@)
|
||||
|
||||
|
|
@ -515,11 +530,7 @@ mp_process_enable(cl_object process)
|
|||
ecl_init_env(process_env);
|
||||
|
||||
process_env->trap_fpe_bits = process->process.trap_fpe_bits;
|
||||
process_env->bindings_array = process->process.initial_bindings;
|
||||
process_env->thread_local_bindings_size =
|
||||
process_env->bindings_array->vector.dim;
|
||||
process_env->thread_local_bindings =
|
||||
process_env->bindings_array->vector.self.t;
|
||||
init_tl_bindings(process, process_env);
|
||||
|
||||
ecl_disable_interrupts_env(the_env);
|
||||
#ifdef ECL_WINDOWS_THREADS
|
||||
|
|
@ -588,7 +599,7 @@ mp_exit_process(void)
|
|||
UNWIND-PROTECT.
|
||||
*/
|
||||
const cl_env_ptr the_env = ecl_process_env();
|
||||
ecl_unwind(the_env, the_env->frs_org);
|
||||
ecl_unwind(the_env, the_env->frs_stack.org);
|
||||
/* Never reached */
|
||||
}
|
||||
|
||||
|
|
@ -750,6 +761,7 @@ init_threads()
|
|||
ecl_thread_t main_thread;
|
||||
/* We have to set the environment before any allocation takes place,
|
||||
* so that the interrupt handling code works. */
|
||||
ecl_cs_init(the_env);
|
||||
ecl_set_process_self(main_thread);
|
||||
process = ecl_alloc_object(t_process);
|
||||
process->process.phase = ECL_PROCESS_ACTIVE;
|
||||
|
|
|
|||
|
|
@ -389,24 +389,24 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
|
|||
cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER];
|
||||
memcpy(big_register, env->big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object));
|
||||
ecl_init_bignum_registers(env);
|
||||
/* We might have been interrupted while we push/pop in the
|
||||
* stack. Increasing env->stack_top ensures that we don't
|
||||
* overwrite the topmost stack value. */
|
||||
env->stack_top++;
|
||||
/* We might have been interrupted while we push/pop in the stack. Increasing
|
||||
* env->run_stack.top ensures that we don't overwrite the topmost stack
|
||||
* value. */
|
||||
env->run_stack.top++;
|
||||
/* We also need to save and restore the (top+1)'th frame and
|
||||
* binding stack value to prevent overwriting it.
|
||||
* INV: Due to the stack safety areas we don't need to check
|
||||
* for env->frs/bds_limit */
|
||||
struct ecl_frame top_frame;
|
||||
memcpy(&top_frame, env->frs_top+1, sizeof(struct ecl_frame));
|
||||
memcpy(&top_frame, env->frs_stack.top+1, sizeof(struct ecl_frame));
|
||||
struct ecl_bds_frame top_binding;
|
||||
memcpy(&top_binding, env->bds_top+1, sizeof(struct ecl_bds_frame));
|
||||
memcpy(&top_binding, env->bds_stack.top+1, sizeof(struct ecl_bds_frame));
|
||||
/* Finally we can handle the queued signals ... */
|
||||
handle_all_queued(env);
|
||||
/* ... and restore everything again */
|
||||
memcpy(env->bds_top+1, &top_binding, sizeof(struct ecl_bds_frame));
|
||||
memcpy(env->frs_top+1, &top_frame, sizeof(struct ecl_frame));
|
||||
env->stack_top--;
|
||||
memcpy(env->bds_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame));
|
||||
memcpy(env->frs_stack.top+1, &top_frame, sizeof(struct ecl_frame));
|
||||
env->run_stack.top--;
|
||||
ecl_clear_bignum_registers(env);
|
||||
memcpy(env->big_register, big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object));
|
||||
env->packages_to_be_created_p = packages_to_be_created_p;
|
||||
|
|
@ -445,8 +445,7 @@ queue_signal(cl_env_ptr env, cl_object code, int allocate)
|
|||
ECL_RPLACA(record, code);
|
||||
ECL_RPLACD(record, ECL_NIL);
|
||||
env->interrupt_struct->pending_interrupt =
|
||||
ecl_nconc(env->interrupt_struct->pending_interrupt,
|
||||
record);
|
||||
ecl_nconc(env->interrupt_struct->pending_interrupt, record);
|
||||
}
|
||||
|
||||
#ifdef ECL_THREADS
|
||||
|
|
@ -829,16 +828,16 @@ handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux)
|
|||
# endif /* ECL_USE_MPROTECT */
|
||||
# ifdef ECL_DOWN_STACK
|
||||
if (sig == SIGSEGV &&
|
||||
(char*)info->si_addr > the_env->cs_barrier &&
|
||||
(char*)info->si_addr <= the_env->cs_org) {
|
||||
(char*)info->si_addr > the_env->c_stack.max &&
|
||||
(char*)info->si_addr <= the_env->c_stack.org) {
|
||||
unblock_signal(the_env, sig);
|
||||
ecl_unrecoverable_error(the_env, stack_overflow_msg);
|
||||
return;
|
||||
}
|
||||
# else
|
||||
if (sig == SIGSEGV &&
|
||||
(char*)info->si_addr < the_env->cs_barrier &&
|
||||
(char*)info->si_addr >= the_env->cs_org) {
|
||||
(char*)info->si_addr < the_env->c_stack.max &&
|
||||
(char*)info->si_addr >= the_env->c_stack.org) {
|
||||
unblock_signal(the_env, sig);
|
||||
ecl_unrecoverable_error(the_env, stack_overflow_msg);
|
||||
return;
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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+)
|
||||
|
|
|
|||
|
|
@ -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);")
|
||||
|
|
|
|||
|
|
@ -96,8 +96,8 @@ set to @var{name} and no function to run. See also
|
|||
|
||||
If @var{initial-bindings} is false, the new process inherits local
|
||||
bindings to special variables (i.e. binding a special variable with
|
||||
@code{let} or @code{let*}) from the current thread, otherwise the new
|
||||
thread possesses no local bindings.
|
||||
@code{let} or @code{let*}) from the thread that enables it, otherwise
|
||||
the new thread initially possesses no local bindings.
|
||||
@end defun
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -82,6 +82,44 @@
|
|||
} else do {
|
||||
#define end_loop_for_on(list) } while (list = ECL_CONS_CDR(list), ECL_CONSP(list))
|
||||
|
||||
/*
|
||||
* Loops over a vector.
|
||||
*/
|
||||
#define loop_across_stack_fifo(var, obj) { \
|
||||
cl_index __ecl_idx; \
|
||||
cl_index __ecl_ndx = obj->vector.fillp; \
|
||||
cl_object *__ecl_v = obj->vector.self.t; \
|
||||
for(__ecl_idx = 0; __ecl_idx < __ecl_ndx; __ecl_idx++) { \
|
||||
cl_object var = __ecl_v[__ecl_idx];
|
||||
|
||||
|
||||
#define loop_across_stack_filo(var, obj) { \
|
||||
cl_index __ecl_idx; \
|
||||
cl_index __ecl_ndx = obj->vector.fillp; \
|
||||
cl_object *__ecl_v = obj->vector.self.t; \
|
||||
for(__ecl_idx = __ecl_ndx; __ecl_idx > 0; __ecl_idx--) { \
|
||||
cl_object var = __ecl_v[__ecl_idx-1];
|
||||
|
||||
#define end_loop_across_stack() }}
|
||||
|
||||
/*
|
||||
* Loops over a stack frame.
|
||||
*/
|
||||
|
||||
#define loop_across_frame_fifo(var, obj) { \
|
||||
cl_object *__ecl_ptr = ECL_STACK_FRAME_PTR(obj); \
|
||||
cl_object *__ecl_top = ECL_STACK_FRAME_TOP(obj); \
|
||||
while(__ecl_ptr++ < __ecl_top) { \
|
||||
cl_object var = *(__ecl_ptr-1); \
|
||||
|
||||
#define loop_across_frame_filo(var, obj) { \
|
||||
cl_object *__ecl_ptr = ECL_STACK_FRAME_PTR(obj); \
|
||||
cl_object *__ecl_top = ECL_STACK_FRAME_TOP(obj); \
|
||||
while(__ecl_ptr < __ecl_top--) { \
|
||||
cl_object var = *__ecl_top;
|
||||
|
||||
#define end_loop_across_frame() }}
|
||||
|
||||
/*
|
||||
* Static constant definition.
|
||||
*/
|
||||
|
|
|
|||
200
src/h/external.h
200
src/h/external.h
|
|
@ -10,6 +10,56 @@ extern "C" {
|
|||
|
||||
#define _ECL_ARGS(x) x
|
||||
|
||||
/* The runtime stack, which is used mainly for keeping the arguments of a
|
||||
* function before it is invoked, and also by the compiler and by the reader
|
||||
* when they are building some data structure. */
|
||||
struct ecl_runtime_stack {
|
||||
cl_index size;
|
||||
cl_index limit_size;
|
||||
cl_object *org;
|
||||
cl_object *top;
|
||||
cl_object *limit;
|
||||
};
|
||||
|
||||
/* The BinDing Stack stores the bindings of special variables. */
|
||||
struct ecl_binding_stack {
|
||||
cl_index size;
|
||||
cl_index limit_size;
|
||||
struct ecl_bds_frame *org;
|
||||
struct ecl_bds_frame *top;
|
||||
struct ecl_bds_frame *limit;
|
||||
#ifdef ECL_THREADS
|
||||
cl_index tl_bindings_size;
|
||||
cl_object *tl_bindings;
|
||||
#endif
|
||||
};
|
||||
|
||||
struct ecl_frames_stack {
|
||||
cl_index size;
|
||||
cl_index limit_size;
|
||||
struct ecl_frame *org;
|
||||
struct ecl_frame *top;
|
||||
struct ecl_frame *limit;
|
||||
/* extra */
|
||||
struct ecl_frame *nlj_fr;
|
||||
cl_index frame_id;
|
||||
};
|
||||
|
||||
struct ecl_history_stack {
|
||||
struct ecl_ihs_frame *top;
|
||||
};
|
||||
|
||||
struct ecl_c_stack {
|
||||
cl_index size; /* current size */
|
||||
cl_index limit_size; /* maximum size minus safety area */
|
||||
char *org; /* origin address */
|
||||
char *max; /* overflow address (real maximum address) */
|
||||
char *limit; /* overflow address (spares recovery area) */
|
||||
/* extra */
|
||||
cl_index max_size; /* maximum possible size */
|
||||
};
|
||||
|
||||
|
||||
/*
|
||||
* Per-thread data.
|
||||
*/
|
||||
|
|
@ -19,109 +69,70 @@ struct cl_env_struct {
|
|||
/* Flag for disabling interrupts while we call C library functions. */
|
||||
volatile int disable_interrupts;
|
||||
|
||||
/* Array where values are returned by functions. */
|
||||
/* -- ECL runtime ---------------------------------------------------- */
|
||||
/* Array where values are returned. */
|
||||
cl_index nvalues;
|
||||
cl_object values[ECL_MULTIPLE_VALUES_LIMIT];
|
||||
|
||||
/* ECL stacks. */
|
||||
|
||||
/* The Runtime Stack is used mainly for keeping the arguments of a
|
||||
* function before it is invoked, and also by the compiler and by the
|
||||
* reader when they are building some data structure. */
|
||||
struct ecl_runtime_stack run_stack;
|
||||
/* The BinDing Stack stores the bindings of special variables. */
|
||||
struct ecl_binding_stack bds_stack;
|
||||
/* The FRames Stack (FRS) is a list of frames or jump points, and it is
|
||||
* used by different high-level constructs (BLOCK, TAGBODY, CATCH...)
|
||||
* to set return points. */
|
||||
struct ecl_frames_stack frs_stack;
|
||||
/* The Invocation History Stack (IHS) keeps a list of the names of the
|
||||
* functions that are invoked with their lexical environments. */
|
||||
struct ecl_history_stack ihs_stack;
|
||||
/* The following pointers to the C Stack are used to ensure that a
|
||||
* recursive function does not enter an infinite loop and exhausts all
|
||||
* memory. They will eventually disappear, because most operating
|
||||
* systems already take care of this. */
|
||||
struct ecl_c_stack c_stack; /* shadow stack */
|
||||
|
||||
/* -- Invocation of closures, generic function, etc ------------------ */
|
||||
cl_object function;
|
||||
cl_object stepper; /* Hook invoked by ByteVM */
|
||||
cl_object stack_frame; /* Current stack frame */
|
||||
|
||||
/* The four stacks in ECL. */
|
||||
|
||||
/*
|
||||
* The lisp stack, which is used mainly for keeping the arguments of a
|
||||
* function before it is invoked, and also by the compiler and by the
|
||||
* reader when they are building some data structure.
|
||||
*/
|
||||
cl_index stack_size;
|
||||
cl_index stack_limit_size;
|
||||
cl_object *stack;
|
||||
cl_object *stack_top;
|
||||
cl_object *stack_limit;
|
||||
|
||||
/*
|
||||
* The BinDing Stack stores the bindings of special variables.
|
||||
*/
|
||||
/* -- System Processes (native threads) ------------------------------ */
|
||||
#ifdef ECL_THREADS
|
||||
cl_index thread_local_bindings_size;
|
||||
cl_object *thread_local_bindings;
|
||||
cl_object bindings_array;
|
||||
cl_object own_process; /* Backpointer to the host process. */
|
||||
int cleanup;
|
||||
#endif
|
||||
cl_index bds_size;
|
||||
cl_index bds_limit_size;
|
||||
struct ecl_bds_frame *bds_org;
|
||||
struct ecl_bds_frame *bds_top;
|
||||
struct ecl_bds_frame *bds_limit;
|
||||
|
||||
/*
|
||||
* The Invocation History Stack (IHS) keeps a list of the names of the
|
||||
* functions that are invoked, together with their lexical
|
||||
* environments.
|
||||
*/
|
||||
struct ecl_ihs_frame *ihs_top;
|
||||
/* -- System Interrupts ---------------------------------------------- */
|
||||
/* The objects in this struct need to be writeable from a different
|
||||
thread, if environment is write-protected by mprotect. Hence they
|
||||
have to be allocated seperately. */
|
||||
struct ecl_interrupt_struct *interrupt_struct;
|
||||
void *default_sigmask;
|
||||
/* Floating point interrupts which are trapped */
|
||||
int trap_fpe_bits;
|
||||
/* Segmentation fault address */
|
||||
void *fault_address;
|
||||
|
||||
/*
|
||||
* The FRames Stack (FRS) is a list of frames or jump points, and it
|
||||
* is used by different high-level constructs (BLOCK, TAGBODY, CATCH...)
|
||||
* to set return points.
|
||||
*/
|
||||
cl_index frs_size;
|
||||
cl_index frs_limit_size;
|
||||
struct ecl_frame *frs_org;
|
||||
struct ecl_frame *frs_top;
|
||||
struct ecl_frame *frs_limit;
|
||||
struct ecl_frame *nlj_fr;
|
||||
cl_index frame_id;
|
||||
|
||||
/*
|
||||
* The following pointers to the C Stack are used to ensure that a
|
||||
* recursive function does not enter an infinite loop and exhausts all
|
||||
* memory. They will eventually disappear, because most operating
|
||||
* systems already take care of this.
|
||||
*/
|
||||
cl_index cs_size; /* current size */
|
||||
cl_index cs_limit_size; /* current size minus safety area */
|
||||
cl_index cs_max_size; /* maximum possible size */
|
||||
char *cs_org; /* origin address */
|
||||
char *cs_limit; /* limit address; if the stack pointer
|
||||
goes beyond this value, a stack
|
||||
overflow will be signaled ... */
|
||||
char *cs_barrier; /* ... but the area up to cs_barrier
|
||||
is still available to allow
|
||||
programs to recover from the
|
||||
stack overflow */
|
||||
|
||||
/* Private variables used by different parts of ECL: */
|
||||
/* -- Private variables used by different parts of ECL ---------------- */
|
||||
/* ... the reader and printer ... */
|
||||
cl_object string_pool;
|
||||
|
||||
/* ... the compiler ... */
|
||||
struct cl_compiler_env *c_env;
|
||||
|
||||
/* ... the formatter ... */
|
||||
#if !defined(ECL_CMU_FORMAT)
|
||||
cl_object fmt_aux_stream;
|
||||
#endif
|
||||
|
||||
/* ... arithmetics ... */
|
||||
cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER];
|
||||
|
||||
cl_object own_process;
|
||||
/* The objects in this struct need to be writeable from a
|
||||
different thread, if environment is write-protected by
|
||||
mprotect. Hence they have to be allocated seperately. */
|
||||
struct ecl_interrupt_struct *interrupt_struct;
|
||||
void *default_sigmask;
|
||||
|
||||
/* The following is a hash table for caching invocations of
|
||||
generic functions. In a multithreaded environment we must
|
||||
queue operations in which the hash is cleared from updated
|
||||
generic functions. */
|
||||
/* The following is a hash table for caching invocations of generic
|
||||
functions. In a multithreaded environment we must queue operations in
|
||||
which the hash is cleared from updated generic functions. */
|
||||
struct ecl_cache *method_cache;
|
||||
struct ecl_cache *slot_cache;
|
||||
|
||||
/* foreign function interface */
|
||||
#ifdef HAVE_LIBFFI
|
||||
cl_index ffi_args_limit;
|
||||
|
|
@ -129,21 +140,10 @@ struct cl_env_struct {
|
|||
union ecl_ffi_values *ffi_values;
|
||||
union ecl_ffi_values **ffi_values_ptrs;
|
||||
#endif
|
||||
|
||||
/* Floating point interrupts which are trapped */
|
||||
int trap_fpe_bits;
|
||||
|
||||
/* List of packages interned when loading a FASL but which have
|
||||
* to be explicitely created by the compiled code itself. */
|
||||
cl_object packages_to_be_created;
|
||||
cl_object packages_to_be_created_p;
|
||||
|
||||
/* Segmentation fault address */
|
||||
void *fault_address;
|
||||
|
||||
#ifdef ECL_THREADS
|
||||
int cleanup;
|
||||
#endif
|
||||
};
|
||||
|
||||
struct ecl_interrupt_struct {
|
||||
|
|
@ -318,6 +318,11 @@ extern ECL_API cl_index cl_num_symbols_in_core;
|
|||
extern ECL_API cl_object APPLY_fixed(cl_narg n, cl_object (*f)(), cl_object *x);
|
||||
extern ECL_API cl_object APPLY(cl_narg n, cl_objectfn, cl_object *x);
|
||||
|
||||
/* stack.c */
|
||||
extern ECL_API cl_object ecl_make_stack(cl_index dim);
|
||||
extern ECL_API cl_object ecl_stack_push(cl_object stack, cl_object elt);
|
||||
extern ECL_API cl_object ecl_stack_del(cl_object stack, cl_object elt);
|
||||
extern ECL_API cl_object ecl_stack_popu(cl_object stack);
|
||||
|
||||
/* array.c */
|
||||
|
||||
|
|
@ -534,17 +539,16 @@ extern ECL_API cl_object si_eval_with_env _ECL_ARGS((cl_narg narg, cl_object for
|
|||
extern ECL_API cl_object si_interpreter_stack();
|
||||
extern ECL_API cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size);
|
||||
extern ECL_API void ecl_stack_frame_push(cl_object f, cl_object o);
|
||||
extern ECL_API cl_object ecl_stack_frame_pop(cl_object f);
|
||||
extern ECL_API void ecl_stack_frame_push_values(cl_object f);
|
||||
extern ECL_API cl_object ecl_stack_frame_pop_values(cl_object f);
|
||||
extern ECL_API void ecl_stack_frame_close(cl_object f);
|
||||
#define si_apply_from_stack_frame ecl_apply_from_stack_frame
|
||||
|
||||
extern ECL_API void FEstack_underflow(void) ecl_attr_noreturn;
|
||||
extern ECL_API void FEstack_advance(void) ecl_attr_noreturn;
|
||||
extern ECL_API cl_object *ecl_stack_grow(cl_env_ptr env);
|
||||
extern ECL_API cl_object *ecl_stack_set_size(cl_env_ptr env, cl_index new_size);
|
||||
extern ECL_API cl_index ecl_stack_push_values(cl_env_ptr env);
|
||||
extern ECL_API void ecl_stack_pop_values(cl_env_ptr env, cl_index n);
|
||||
extern ECL_API cl_object *ecl_data_stack_grow(cl_env_ptr env);
|
||||
extern ECL_API cl_object *ecl_data_stack_set_size(cl_env_ptr env, cl_index new_size);
|
||||
extern ECL_API cl_index ecl_data_stack_push_values(cl_env_ptr env);
|
||||
extern ECL_API void ecl_data_stack_pop_values(cl_env_ptr env, cl_index n);
|
||||
extern ECL_API cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes);
|
||||
extern ECL_API cl_object _ecl_bytecodes_dispatch(cl_narg narg, ...);
|
||||
extern ECL_API cl_object _ecl_bclosure_dispatch(cl_narg narg, ...);
|
||||
|
|
@ -596,6 +600,7 @@ extern ECL_API void FEtimeout() ecl_attr_noreturn;
|
|||
extern ECL_API void FEerror_not_owned(cl_object lock) ecl_attr_noreturn;
|
||||
extern ECL_API void FEunknown_lock_error(cl_object lock) ecl_attr_noreturn;
|
||||
extern ECL_API cl_object CEerror(cl_object c, const char *err_str, int narg, ...);
|
||||
extern ECL_API void CEstack_overflow(cl_object type, cl_object limit, cl_object resume);
|
||||
extern ECL_API void FElibc_error(const char *msg, int narg, ...) ecl_attr_noreturn;
|
||||
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
|
||||
extern ECL_API void FEwin32_error(const char *msg, int narg, ...) ecl_attr_noreturn;
|
||||
|
|
@ -1642,12 +1647,11 @@ extern ECL_API cl_object si_bds_var(cl_object arg);
|
|||
extern ECL_API cl_object si_bds_val(cl_object arg);
|
||||
extern ECL_API cl_object si_sch_frs_base(cl_object fr, cl_object ihs);
|
||||
extern ECL_API cl_object si_reset_stack_limits(void);
|
||||
extern ECL_API cl_object si_reset_margin(cl_object type);
|
||||
extern ECL_API cl_object si_set_limit(cl_object type, cl_object size);
|
||||
extern ECL_API cl_object si_get_limit(cl_object type);
|
||||
|
||||
extern ECL_API cl_index ecl_progv(cl_env_ptr env, cl_object vars, cl_object values);
|
||||
extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index);
|
||||
extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx);
|
||||
extern ECL_API void ecl_unwind(cl_env_ptr env, struct ecl_frame *fr) ecl_attr_noreturn;
|
||||
extern ECL_API struct ecl_frame *frs_sch(cl_object frame_id);
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,10 @@ extern void init_GC(void);
|
|||
#endif
|
||||
extern void init_macros(void);
|
||||
extern void init_read(void);
|
||||
extern void init_stacks(cl_env_ptr);
|
||||
|
||||
extern cl_object init_stacks(cl_env_ptr);
|
||||
extern cl_object free_stacks(cl_env_ptr);
|
||||
|
||||
extern void init_unixint(int pass);
|
||||
extern void init_unixtime(void);
|
||||
extern void init_compiler(void);
|
||||
|
|
@ -298,9 +301,6 @@ struct cl_compiler_ref {
|
|||
|
||||
extern void _ecl_unexpected_return() ecl_attr_noreturn;
|
||||
extern cl_object _ecl_strerror(int code);
|
||||
extern ECL_API cl_object si_serror _ECL_ARGS
|
||||
((cl_narg narg, cl_object cformat, cl_object eformat, ...));
|
||||
|
||||
|
||||
/* eval.d */
|
||||
|
||||
|
|
@ -552,12 +552,16 @@ extern cl_object ecl_deserialize(uint8_t *data);
|
|||
/* stacks.d */
|
||||
#define CL_NEWENV_BEGIN {\
|
||||
const cl_env_ptr the_env = ecl_process_env(); \
|
||||
cl_index __i = ecl_stack_push_values(the_env); \
|
||||
cl_index __i = ecl_data_stack_push_values(the_env); \
|
||||
|
||||
#define CL_NEWENV_END \
|
||||
ecl_stack_pop_values(the_env,__i); }
|
||||
ecl_data_stack_pop_values(the_env,__i); }
|
||||
|
||||
extern void ecl_cs_set_org(cl_env_ptr env);
|
||||
extern void ecl_cs_init(cl_env_ptr env);
|
||||
extern void ecl_frs_set_limit(cl_env_ptr env, cl_index n);
|
||||
extern void ecl_bds_set_limit(cl_env_ptr env, cl_index n);
|
||||
extern void ecl_data_stack_set_limit(cl_env_ptr env, cl_index n);
|
||||
extern void ecl_cs_set_size(cl_env_ptr env, cl_index n);
|
||||
|
||||
#ifndef RLIM_SAVED_MAX
|
||||
# define RLIM_SAVED_MAX RLIM_INFINITY
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
285
src/h/stacks.h
285
src/h/stacks.h
|
|
@ -27,10 +27,10 @@ extern "C" {
|
|||
|
||||
#ifdef ECL_DOWN_STACK
|
||||
#define ecl_cs_check(env,var) \
|
||||
if (ecl_unlikely((char*)(&var) <= (env)->cs_limit)) ecl_cs_overflow()
|
||||
if (ecl_unlikely((char*)(&var) <= (env)->c_stack.limit)) ecl_cs_overflow()
|
||||
#else
|
||||
#define ecl_cs_check(env,var) \
|
||||
if (ecl_unlikely((char*)(&var) >= (env)->cs_limit)) ecl_cs_overflow()
|
||||
if (ecl_unlikely((char*)(&var) >= (env)->c_stack.limit)) ecl_cs_overflow()
|
||||
#endif
|
||||
|
||||
/*********************************************************
|
||||
|
|
@ -78,7 +78,7 @@ typedef struct ecl_bds_frame {
|
|||
} *ecl_bds_ptr;
|
||||
|
||||
#define ecl_bds_check(env) \
|
||||
(ecl_unlikely(env->bds_top >= env->bds_limit)? (ecl_bds_overflow(),1) : 0)
|
||||
(ecl_unlikely(env->bds_stack.top >= env->bds_stack.limit)? (ecl_bds_overflow(),1) : 0)
|
||||
|
||||
#define ECL_MISSING_SPECIAL_BINDING (~((cl_index)0))
|
||||
|
||||
|
|
@ -100,25 +100,25 @@ extern ECL_API cl_object ecl_bds_set(cl_env_ptr env, cl_object s, cl_object v);
|
|||
# define ECL_SETQ(env,s,v) ((s)->symbol.value=(v))
|
||||
#endif
|
||||
|
||||
#ifdef __GNUC__
|
||||
static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v)
|
||||
#ifdef ECL_THREADS
|
||||
static inline void
|
||||
ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v)
|
||||
{
|
||||
ecl_bds_ptr slot;
|
||||
# ifdef ECL_THREADS
|
||||
cl_object *location;
|
||||
const cl_index index = s->symbol.binding;
|
||||
if (index >= env->thread_local_bindings_size) {
|
||||
if (index >= env->bds_stack.tl_bindings_size) {
|
||||
ecl_bds_bind(env,s,v);
|
||||
} else {
|
||||
location = env->thread_local_bindings + index;
|
||||
slot = env->bds_top+1;
|
||||
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
|
||||
location = env->bds_stack.tl_bindings + index;
|
||||
slot = env->bds_stack.top+1;
|
||||
if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow();
|
||||
/* First, we push a dummy symbol in the stack to
|
||||
* prevent segfaults when we are interrupted with a
|
||||
* call to ecl_bds_unwind. */
|
||||
slot->symbol = ECL_DUMMY_TAG;
|
||||
AO_nop_full();
|
||||
++env->bds_top;
|
||||
++env->bds_stack.top;
|
||||
/* Then we disable interrupts to ensure that
|
||||
* ecl_bds_unwind doesn't overwrite the symbol with
|
||||
* some random value. */
|
||||
|
|
@ -128,115 +128,102 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v)
|
|||
*location = v;
|
||||
ecl_enable_interrupts_env(env);
|
||||
}
|
||||
# else
|
||||
slot = ++env->bds_top;
|
||||
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
|
||||
ecl_disable_interrupts_env(env);
|
||||
slot->symbol = s;
|
||||
slot->value = s->symbol.value;
|
||||
s->symbol.value = v;
|
||||
ecl_enable_interrupts_env(env);
|
||||
# endif /* !ECL_THREADS */
|
||||
}
|
||||
|
||||
static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s)
|
||||
static inline void
|
||||
ecl_bds_push_inl(cl_env_ptr env, cl_object s)
|
||||
{
|
||||
ecl_bds_ptr slot;
|
||||
# ifdef ECL_THREADS
|
||||
cl_object *location;
|
||||
const cl_index index = s->symbol.binding;
|
||||
if (index >= env->thread_local_bindings_size) {
|
||||
if (index >= env->bds_stack.tl_bindings_size) {
|
||||
ecl_bds_push(env, s);
|
||||
} else {
|
||||
location = env->thread_local_bindings + index;
|
||||
slot = env->bds_top+1;
|
||||
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
|
||||
location = env->bds_stack.tl_bindings + index;
|
||||
slot = env->bds_stack.top+1;
|
||||
if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow();
|
||||
slot->symbol = ECL_DUMMY_TAG;
|
||||
AO_nop_full();
|
||||
++env->bds_top;
|
||||
++env->bds_stack.top;
|
||||
ecl_disable_interrupts_env(env);
|
||||
slot->symbol = s;
|
||||
slot->value = *location;
|
||||
if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value;
|
||||
ecl_enable_interrupts_env(env);
|
||||
}
|
||||
# else
|
||||
slot = ++env->bds_top;
|
||||
if (slot >= env->bds_limit) slot = ecl_bds_overflow();
|
||||
ecl_disable_interrupts_env(env);
|
||||
slot->symbol = s;
|
||||
slot->value = s->symbol.value;
|
||||
ecl_enable_interrupts_env(env);
|
||||
# endif /* !ECL_THREADS */
|
||||
}
|
||||
|
||||
static inline void ecl_bds_unwind1_inl(cl_env_ptr env)
|
||||
static inline void
|
||||
ecl_bds_unwind1_inl(cl_env_ptr env)
|
||||
{
|
||||
cl_object s = env->bds_top->symbol;
|
||||
# ifdef ECL_THREADS
|
||||
cl_object *location = env->thread_local_bindings + s->symbol.binding;
|
||||
*location = env->bds_top->value;
|
||||
# else
|
||||
s->symbol.value = env->bds_top->value;
|
||||
# endif
|
||||
--env->bds_top;
|
||||
cl_object s = env->bds_stack.top->symbol;
|
||||
cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding;
|
||||
*location = env->bds_stack.top->value;
|
||||
--env->bds_stack.top;
|
||||
}
|
||||
|
||||
# ifdef ECL_THREADS
|
||||
static inline cl_object ecl_bds_read_inl(cl_env_ptr env, cl_object s)
|
||||
static inline cl_object
|
||||
ecl_bds_read_inl(cl_env_ptr env, cl_object s)
|
||||
{
|
||||
cl_index index = s->symbol.binding;
|
||||
if (index < env->thread_local_bindings_size) {
|
||||
cl_object x = env->thread_local_bindings[index];
|
||||
if (index < env->bds_stack.tl_bindings_size) {
|
||||
cl_object x = env->bds_stack.tl_bindings[index];
|
||||
if (x != ECL_NO_TL_BINDING) return x;
|
||||
}
|
||||
return s->symbol.value;
|
||||
}
|
||||
static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s)
|
||||
static inline cl_object *
|
||||
ecl_bds_ref_inl(cl_env_ptr env, cl_object s)
|
||||
{
|
||||
cl_index index = s->symbol.binding;
|
||||
if (index < env->thread_local_bindings_size) {
|
||||
cl_object *location = env->thread_local_bindings + index;
|
||||
if (index < env->bds_stack.tl_bindings_size) {
|
||||
cl_object *location = env->bds_stack.tl_bindings + index;
|
||||
if (*location != ECL_NO_TL_BINDING) return location;
|
||||
}
|
||||
return &s->symbol.value;
|
||||
}
|
||||
# define ecl_bds_set(env,s,v) (*ecl_bds_ref_inl(env,s)=(v))
|
||||
# define ecl_bds_read ecl_bds_read_inl
|
||||
# endif
|
||||
# define ecl_bds_bind ecl_bds_bind_inl
|
||||
# define ecl_bds_push ecl_bds_push_inl
|
||||
# define ecl_bds_unwind1 ecl_bds_unwind1_inl
|
||||
#else /* !__GNUC__ */
|
||||
# ifndef ECL_THREADS
|
||||
# define ecl_bds_bind(env,sym,val) do { \
|
||||
const cl_env_ptr env_copy = (env); \
|
||||
const cl_object s = (sym); \
|
||||
const cl_object v = (val); \
|
||||
ecl_bds_check(env_copy); \
|
||||
ecl_bds_ptr slot = ++(env_copy->bds_top); \
|
||||
ecl_disable_interrupts_env(env_copy); \
|
||||
slot->symbol = s; \
|
||||
slot->value = s->symbol.value; \
|
||||
s->symbol.value = v; \
|
||||
ecl_enable_interrupts_env(env_copy); } while (0)
|
||||
# define ecl_bds_push(env,sym) do { \
|
||||
const cl_env_ptr env_copy = (env); \
|
||||
const cl_object s = (sym); \
|
||||
const cl_object v = s->symbol.value; \
|
||||
ecl_bds_check(env_copy); \
|
||||
ecl_bds_ptr slot = ++(env_copy->bds_top); \
|
||||
ecl_disable_interrupts_env(env_copy); \
|
||||
slot->symbol = s; \
|
||||
slot->value = s->symbol.value; \
|
||||
ecl_enable_interrupts_env(env_copy); } while (0);
|
||||
# define ecl_bds_unwind1(env) do { \
|
||||
const cl_env_ptr env_copy = (env); \
|
||||
const cl_object s = env_copy->bds_top->symbol; \
|
||||
s->symbol.value = env_copy->bds_top->value; \
|
||||
--(env_copy->bds_top); } while (0)
|
||||
# endif /* !ECL_THREADS */
|
||||
#endif /* !__GNUC__ */
|
||||
|
||||
# define ecl_bds_set(env,s,v) (*ecl_bds_ref_inl(env,s)=(v))
|
||||
# define ecl_bds_read ecl_bds_read_inl
|
||||
|
||||
#else /* ECL_THREADS */
|
||||
static inline void
|
||||
ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v)
|
||||
{
|
||||
ecl_bds_ptr slot;
|
||||
slot = ++env->bds_stack.top;
|
||||
if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow();
|
||||
ecl_disable_interrupts_env(env);
|
||||
slot->symbol = s;
|
||||
slot->value = s->symbol.value;
|
||||
s->symbol.value = v;
|
||||
ecl_enable_interrupts_env(env);
|
||||
}
|
||||
|
||||
static inline void
|
||||
ecl_bds_push_inl(cl_env_ptr env, cl_object s)
|
||||
{
|
||||
ecl_bds_ptr slot;
|
||||
slot = ++env->bds_stack.top;
|
||||
if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow();
|
||||
ecl_disable_interrupts_env(env);
|
||||
slot->symbol = s;
|
||||
slot->value = s->symbol.value;
|
||||
ecl_enable_interrupts_env(env);
|
||||
}
|
||||
|
||||
static inline void
|
||||
ecl_bds_unwind1_inl(cl_env_ptr env)
|
||||
{
|
||||
cl_object s = env->bds_stack.top->symbol;
|
||||
s->symbol.value = env->bds_stack.top->value;
|
||||
--env->bds_stack.top;
|
||||
}
|
||||
#endif /* ECL_THREADS */
|
||||
|
||||
#define ecl_bds_bind ecl_bds_bind_inl
|
||||
#define ecl_bds_push ecl_bds_push_inl
|
||||
#define ecl_bds_unwind1 ecl_bds_unwind1_inl
|
||||
|
||||
/****************************
|
||||
* INVOCATION HISTORY STACK
|
||||
|
|
@ -253,18 +240,18 @@ typedef struct ecl_ihs_frame {
|
|||
#define ecl_ihs_push(env,rec,fun,lisp_env) do { \
|
||||
const cl_env_ptr __the_env = (env); \
|
||||
ecl_ihs_ptr const r = (ecl_ihs_ptr const)(rec); \
|
||||
r->next=__the_env->ihs_top; \
|
||||
r->function=(fun); \
|
||||
r->lex_env=(lisp_env); \
|
||||
r->index=__the_env->ihs_top->index+1; \
|
||||
r->bds=__the_env->bds_top - __the_env->bds_org; \
|
||||
__the_env->ihs_top = r; \
|
||||
r->next=__the_env->ihs_stack.top; \
|
||||
r->function=(fun); \
|
||||
r->lex_env=(lisp_env); \
|
||||
r->index=__the_env->ihs_stack.top->index+1; \
|
||||
r->bds=__the_env->bds_stack.top - __the_env->bds_stack.org; \
|
||||
__the_env->ihs_stack.top = r; \
|
||||
} while(0)
|
||||
|
||||
#define ecl_ihs_pop(env) do { \
|
||||
const cl_env_ptr __the_env = (env); \
|
||||
ecl_ihs_ptr r = __the_env->ihs_top; \
|
||||
if (r) __the_env->ihs_top = r->next; \
|
||||
ecl_ihs_ptr r = __the_env->ihs_stack.top; \
|
||||
if (r) __the_env->ihs_stack.top = r->next; \
|
||||
} while(0)
|
||||
|
||||
/***************
|
||||
|
|
@ -293,9 +280,9 @@ typedef struct ecl_ihs_frame {
|
|||
typedef struct ecl_frame {
|
||||
jmp_buf frs_jmpbuf;
|
||||
cl_object frs_val;
|
||||
cl_index frs_bds_top_index;
|
||||
ecl_ihs_ptr frs_ihs;
|
||||
cl_index frs_sp;
|
||||
cl_index frs_bds_ndx;
|
||||
cl_index frs_run_ndx;
|
||||
} *ecl_frame_ptr;
|
||||
|
||||
extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr);
|
||||
|
|
@ -306,8 +293,8 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr);
|
|||
int __ecl_frs_push_result = ecl_setjmp(__frame->frs_jmpbuf); \
|
||||
ecl_enable_interrupts_env(env)
|
||||
|
||||
#define ecl_frs_pop(env) ((env)->frs_top--)
|
||||
#define ecl_frs_pop_n(env,n) ((env)->frs_top-=n)
|
||||
#define ecl_frs_pop(env) ((env)->frs_stack.top--)
|
||||
#define ecl_frs_pop_n(env,n) ((env)->frs_stack.top-=n)
|
||||
|
||||
/*******************
|
||||
* ARGUMENTS STACK
|
||||
|
|
@ -377,51 +364,65 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr);
|
|||
* LISP STACK
|
||||
*************/
|
||||
|
||||
#define ECL_STACK_INDEX(env) ((env)->stack_top - (env)->stack)
|
||||
static inline void
|
||||
ecl_data_stack_push(cl_env_ptr env, cl_object o) {
|
||||
cl_object *new_top = env->run_stack.top;
|
||||
if (ecl_unlikely(new_top >= env->run_stack.limit)) {
|
||||
new_top = ecl_data_stack_grow(env);
|
||||
}
|
||||
env->run_stack.top = new_top+1;
|
||||
*new_top = (o);
|
||||
}
|
||||
|
||||
#define ECL_STACK_PUSH(the_env,o) do { \
|
||||
const cl_env_ptr __env = (the_env); \
|
||||
cl_object *__new_top = __env->stack_top; \
|
||||
if (ecl_unlikely(__new_top >= __env->stack_limit)) { \
|
||||
__new_top = ecl_stack_grow(__env); \
|
||||
} \
|
||||
__env->stack_top = __new_top+1; \
|
||||
*__new_top = (o); } while (0)
|
||||
static inline void
|
||||
ecl_data_stack_push_n(cl_env_ptr env, cl_index n) {
|
||||
cl_object *new_top = env->run_stack.top;
|
||||
while (ecl_unlikely((env->run_stack.limit - new_top) <= n)) {
|
||||
new_top = ecl_data_stack_grow(env);
|
||||
}
|
||||
env->run_stack.top = new_top + n;
|
||||
}
|
||||
|
||||
#define ECL_STACK_POP_UNSAFE(env) *(--((env)->stack_top))
|
||||
static inline cl_object
|
||||
ecl_data_stack_pop_unsafe(cl_env_ptr env)
|
||||
{
|
||||
return *(--((env)->run_stack.top));
|
||||
}
|
||||
|
||||
#define ECL_STACK_REF(env,n) ((env)->stack_top[n])
|
||||
static inline void
|
||||
ecl_data_stack_pop_n_unsafe(cl_env_ptr env, cl_index 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)) \
|
||||
FEstack_advance(); \
|
||||
__env->stack_top = __new_top; } while (0)
|
||||
static inline cl_index
|
||||
ecl_data_stack_index(cl_env_ptr env) {
|
||||
return (env)->run_stack.top - (env)->run_stack.org;
|
||||
}
|
||||
|
||||
#define ECL_STACK_POP_N(the_env,n) do { \
|
||||
const cl_env_ptr __env = (the_env); \
|
||||
cl_object *__new_top = __env->stack_top - (n); \
|
||||
if (ecl_unlikely(__new_top < __env->stack)) \
|
||||
FEstack_underflow(); \
|
||||
__env->stack_top = __new_top; } while (0)
|
||||
static inline void
|
||||
ecl_data_stack_set_index(cl_env_ptr env, cl_index ndx)
|
||||
{
|
||||
env->run_stack.top = env->run_stack.org + (ndx);
|
||||
}
|
||||
|
||||
#define ECL_STACK_POP_N_UNSAFE(the_env,n) ((the_env)->stack_top -= (n))
|
||||
#define ECL_STACK_REF(env,n) ((env)->run_stack.top[n])
|
||||
#define ECL_STACK_INDEX(env) ecl_data_stack_index(env)
|
||||
#define ECL_STACK_UNWIND(env,ndx) ecl_data_stack_set_index(env,ndx)
|
||||
#define ECL_STACK_PUSH_N(env,n) ecl_data_stack_push_n(env,n)
|
||||
#define ECL_STACK_PUSH(env,o) ecl_data_stack_push(env,o)
|
||||
#define ECL_STACK_POP_UNSAFE(env) ecl_data_stack_pop_unsafe(env)
|
||||
#define ECL_STACK_POP_N_UNSAFE(env,o) ecl_data_stack_pop_n_unsafe(env,o)
|
||||
|
||||
#define ECL_STACK_PUSH_N(the_env,n) do { \
|
||||
const cl_env_ptr __env = (the_env) ; \
|
||||
cl_index __aux = (n); \
|
||||
cl_object *__new_top = __env->stack_top; \
|
||||
while (ecl_unlikely((__env->stack_limit - __new_top) <= __aux)) { \
|
||||
__new_top = ecl_stack_grow(__env); \
|
||||
} \
|
||||
__env->stack_top = __new_top + __aux; } while (0)
|
||||
#define ECL_STACK_FRAME_REF(f,ndx) \
|
||||
((f)->frame.env->run_stack.org[(f)->frame.base+(ndx)])
|
||||
#define ECL_STACK_FRAME_SET(f,ndx,o) \
|
||||
do { ECL_STACK_FRAME_REF(f,ndx) = (o); } while(0)
|
||||
|
||||
#define ECL_STACK_FRAME_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); \
|
||||
|
|
@ -443,16 +444,16 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr);
|
|||
cl_index __nr; \
|
||||
ecl_frs_push(__the_env,ECL_PROTECT_TAG); \
|
||||
if (__ecl_frs_push_result) { \
|
||||
__unwinding=1; __next_fr=__the_env->nlj_fr; \
|
||||
__unwinding=1; __next_fr=__the_env->frs_stack.nlj_fr; \
|
||||
} else {
|
||||
|
||||
#define ECL_UNWIND_PROTECT_EXIT \
|
||||
__unwinding=0; } \
|
||||
ecl_frs_pop(__the_env); \
|
||||
__nr = ecl_stack_push_values(__the_env);
|
||||
__nr = ecl_data_stack_push_values(__the_env);
|
||||
|
||||
#define ECL_UNWIND_PROTECT_END \
|
||||
ecl_stack_pop_values(__the_env,__nr); \
|
||||
ecl_data_stack_pop_values(__the_env,__nr); \
|
||||
if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0)
|
||||
|
||||
/* unwind-protect variant which disables interrupts during cleanup */
|
||||
|
|
@ -460,15 +461,15 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr);
|
|||
__unwinding=0; } \
|
||||
ecl_bds_bind(__the_env,ECL_INTERRUPTS_ENABLED,ECL_NIL); \
|
||||
ecl_frs_pop(__the_env); \
|
||||
__nr = ecl_stack_push_values(__the_env);
|
||||
__nr = ecl_data_stack_push_values(__the_env);
|
||||
|
||||
#define ECL_UNWIND_PROTECT_THREAD_SAFE_END \
|
||||
ecl_stack_pop_values(__the_env,__nr); \
|
||||
ecl_data_stack_pop_values(__the_env,__nr); \
|
||||
ecl_bds_unwind1(__the_env); \
|
||||
ecl_check_pending_interrupts(__the_env); \
|
||||
if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0)
|
||||
|
||||
#define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frame_id++)
|
||||
#define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frs_stack.frame_id++)
|
||||
|
||||
#define ECL_BLOCK_BEGIN(the_env,id) do { \
|
||||
const cl_object __id = ECL_NEW_FRAME_ID(the_env); \
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue