diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 4a6fcab4f56943c4eee20e17664c108fed4d8bbc..aba1f51ef54b5375741c4d7c1646102bac0f75a5 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -236,6 +236,7 @@ make_this_symbol(int i, volatile cl_object s, int code, ECL_FMAKUNBOUND(s); s->symbol.undef_entry = ecl_undefined_function_entry; s->symbol.macfun = ECL_NIL; + s->symbol.sfdef = ECL_NIL; s->symbol.plist = ECL_NIL; s->symbol.hpack = ECL_NIL; s->symbol.stype = stp; diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index e3c6497abc9ccabfcc1122bd290db2f783d95d6f..c52f8f20988406c6e6e4ba0647b5f35efb992a2f 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -580,6 +580,7 @@ void init_type_info (void) to_bitmap(&o, &(o.symbol.value)) | to_bitmap(&o, &(o.symbol.gfdef)) | to_bitmap(&o, &(o.symbol.macfun)) | + to_bitmap(&o, &(o.symbol.sfdef)) | to_bitmap(&o, &(o.symbol.plist)) | to_bitmap(&o, &(o.symbol.name)) | to_bitmap(&o, &(o.symbol.hpack)); @@ -645,6 +646,7 @@ void init_type_info (void) to_bitmap(&o, &(o.bytecodes.definition)) | to_bitmap(&o, &(o.bytecodes.code)) | to_bitmap(&o, &(o.bytecodes.data)) | + to_bitmap(&o, &(o.bytecodes.flex)) | to_bitmap(&o, &(o.bytecodes.file)) | to_bitmap(&o, &(o.bytecodes.file_position)); type_info[t_bclosure].descriptor = diff --git a/src/c/array.d b/src/c/array.d index 89d7d022a1a1023e2d8d12979544135238dae02c..2b1e586ab0158a61e3a035b9db2e0c8c5f8d870c 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -482,6 +482,21 @@ si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, @(return x); } +/* Internal internal function for making simple actually adjustable vectors. */ +cl_object +ecl_make_stack(cl_index dim) +{ + cl_object x = ecl_alloc_object(t_vector); + x->vector.elttype = ecl_aet_object; + x->vector.self.t = NULL; + x->vector.displaced = ECL_NIL; + x->vector.dim = dim; + x->vector.fillp = 0; + x->vector.flags = ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER; + ecl_array_allocself(x); + return x; +} + /* Internal function for making vectors: diff --git a/src/c/assignment.d b/src/c/assignment.d index a19f8a38919afb6a3e254546f82ec869018966bf..1003fcffa7f1211937c7878a16e35f731d62e990 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -112,15 +112,12 @@ cl_object ecl_setf_definition(cl_object sym, cl_object createp) { cl_env_ptr the_env = ecl_process_env(); - cl_object pair; - ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { - pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); - if (Null(pair) && !Null(createp)) { - createp = make_setf_function_error(sym); - pair = ecl_cons(createp, ECL_NIL); - ecl_sethash(sym, cl_core.setf_definitions, pair); - } - } ECL_WITH_GLOBAL_ENV_RDLOCK_END; + cl_object pair = sym->symbol.sfdef; + if (Null(pair) && !Null(createp)) { + createp = make_setf_function_error(sym); + pair = ecl_cons(createp, ECL_NIL); + sym->symbol.sfdef = pair; + } return pair; } @@ -134,19 +131,11 @@ static void ecl_rem_setf_definition(cl_object sym) { cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { - cl_object pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); - if (!Null(pair)) { - ECL_RPLACA(pair, make_setf_function_error(sym)); - ECL_RPLACD(pair, ECL_NIL); - /* - FIXME: This leaks resources - We actually cannot remove it, because some compiled - code might be using it! - ecl_remhash(sym, cl_core.setf_definitions); - */ - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + cl_object pair = sym->symbol.sfdef; + if (!Null(pair)) { + ECL_RPLACA(pair, make_setf_function_error(sym)); + ECL_RPLACD(pair, ECL_NIL); + } } @(defun si::fset (fname def &optional macro pprint) diff --git a/src/c/compiler.d b/src/c/compiler.d index 42321534914d2ac35b3f7f6c176dddcf338c6206..a30ca3e8230baa08b9d9e746831a795221781dcb 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -48,9 +48,6 @@ #define FLAG_LOAD 32 #define FLAG_COMPILE 64 -#define ECL_SPECIAL_VAR_REF -2 -#define ECL_UNDEFINED_VAR_REF -1 - /********************* PRIVATE ********************/ typedef struct cl_compiler_env *cl_compiler_ptr; @@ -66,7 +63,11 @@ static cl_object asm_end(cl_env_ptr env, cl_index handle, cl_object definition); static cl_index asm_jmp(cl_env_ptr env, int op); static void asm_complete(cl_env_ptr env, int op, cl_index original); -static cl_fixnum c_var_ref(cl_env_ptr env, cl_object var, int allow_symbol_macro, bool ensure_defined); +static struct cl_compiler_ref +c_var_ref(cl_env_ptr env, cl_object var, bool allow_sym_mac, bool ensure_def); + +void c_sym_ref(cl_env_ptr env, cl_object name); +void c_mac_ref(cl_env_ptr env, cl_object name); static int c_block(cl_env_ptr env, cl_object args, int flags); static int c_case(cl_env_ptr env, cl_object args, int flags); @@ -122,11 +123,15 @@ static int c_car(cl_env_ptr env, cl_object args, int push); static int c_cdr(cl_env_ptr env, cl_object args, int push); static int c_list(cl_env_ptr env, cl_object args, int push); static int c_listA(cl_env_ptr env, cl_object args, int push); +static int c_cons_car(cl_env_ptr env, cl_object args, int push); +static int c_cons_cdr(cl_env_ptr env, cl_object args, int push); static cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda); static void FEill_formed_input(void) ecl_attr_noreturn; +static int asm_function(cl_env_ptr env, cl_object args, int flags); + /* -------------------- SAFE LIST HANDLING -------------------- */ static cl_object pop(cl_object *l) { @@ -184,6 +189,7 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { bytecodes->bytecodes.code_size = code_size; bytecodes->bytecodes.code = ecl_alloc_atomic(code_size * sizeof(cl_opcode)); bytecodes->bytecodes.data = c_env->constants; + bytecodes->bytecodes.flex = ECL_NIL; for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); } @@ -224,6 +230,15 @@ asm_constant(cl_env_ptr env, cl_object c) return constants->vector.fillp-1; } +static cl_index +asm_captured(cl_env_ptr env, cl_object c) +{ + const cl_compiler_ptr c_env = env->c_env; + cl_object captured = c_env->captured; + cl_vector_push_extend(2, c, captured); + return captured->vector.fillp-1; +} + static cl_index asm_jmp(cl_env_ptr env, int op) { cl_index output; @@ -296,9 +311,7 @@ static compiler_record database[] = { {@'si::while', c_while, 0}, {@'ext::with-backend', c_with_backend, 0}, {@'si::until', c_until, 0}, - - /* Extras */ - + /* Inlined functions */ {@'cons', c_cons, 1}, {@'car', c_car, 1}, {@'cdr', c_cdr, 1}, @@ -307,8 +320,10 @@ static compiler_record database[] = { {@'list', c_list, 1}, {@'list*', c_listA, 1}, {@'endp', c_endp, 1}, - {@'si::cons-car', c_car, 1}, - {@'si::cons-cdr', c_cdr, 1}, + /* Primops */ + {@'si::cons-car', c_cons_car, 1}, + {@'si::cons-cdr', c_cons_cdr, 1}, + {NULL, NULL, 1} }; @@ -349,7 +364,7 @@ c_register_constant(cl_env_ptr env, cl_object c) } static void -asm_c(cl_env_ptr env, cl_object o) { +asm_arg_data(cl_env_ptr env, cl_object o) { asm_arg(env, c_register_constant(env, o)); } @@ -358,6 +373,31 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { asm_op2(env, code, c_register_constant(env, o)); } +/* Captured variables */ +static int +c_search_captured(cl_env_ptr env, cl_object c) +{ + const cl_compiler_ptr c_env = env->c_env; + cl_object p = c_env->captured; + int n; + if(Null(p)) { + ecl_miscompilation_error(); + } + for (n = 0; n < p->vector.fillp; n++) { + if (ecl_eql(p->vector.self.t[n], c)) { + return n; + } + } + return -1; +} + +static int +c_register_captured(cl_env_ptr env, cl_object c) +{ + int n = c_search_captured(env, c); + return (n < 0) ? asm_captured(env, c) : n; +} + /* * Note: the following should match the definitions in cmp/cmpenv.lsp, as * well as CMP-ENV-REGISTER-MACROLET (lsp/defmacro.lsp) @@ -365,28 +405,30 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * The compiler environment consists of two lists, one stored in * env->variables, the other one stored in env->macros. * - * variable-record = (:block block-name [used-p | block-object] location) | - * (:tag ({tag-name}*) [NIL | tag-object] location) | - * (:function function-name used-p [location]) | - * (var-name {:special | nil} bound-p [location]) | - * (symbol si::symbol-macro macro-function) | - * (:declare type arguments) | - * SI:FUNCTION-BOUNDARY | - * SI:UNWIND-PROTECT-BOUNDARY - * (:declare declaration-arguments*) - * macro-record = (function-name FUNCTION [| function-object]) | - * (macro-name si::macro macro-function) | - * (:declare name declaration) | - * (compiler-macro-name si::compiler-macro macro-function) | - * SI:FUNCTION-BOUNDARY | - * SI:UNWIND-PROTECT-BOUNDARY + * variable-record = + * (:block block-name [used-p | block-object] location) | + * (:tag ({tag-name [. tag-id]}*) [used-p | tag-object] location) | + * (:function function-name used-p [location]) | + * (var-name {:special | nil} bound-p [location]) | + * (symbol si::symbol-macro macro-function) | + * (:declare type arguments) | + * SI:FUNCTION-BOUNDARY | + * SI:UNWIND-PROTECT-BOUNDARY + * (:declare declaration-arguments*) + * macro-record = + * (function-name FUNCTION [| function-object]) | + * (macro-name si::macro macro-function) | + * (:declare name declaration) | + * (compiler-macro-name si::compiler-macro macro-function) | + * SI:FUNCTION-BOUNDARY | + * SI:UNWIND-PROTECT-BOUNDARY * - * A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A - * MACRO-FUNCTION is a function that provides us with the expansion for that - * local macro or symbol macro. BOUND-P is true when the variable has been bound - * by an enclosing form, while it is NIL if the variable-record corresponds just - * to a special declaration. SI:FUNCTION-BOUNDARY and SI:UNWIND-PROTECT-BOUNDARY - * denote function and unwind-protect boundaries. + * A *-NAME is a symbol. A TAG-ID is a number. A MACRO-FUNCTION is a function + * that provides us with the expansion for that local macro or symbol + * macro. BOUND-P is true when the variable has been bound by an enclosing form, + * while it is NIL if the variable-record corresponds just to a special + * declaration. SI:FUNCTION-BOUNDARY and SI:UNWIND-PROTECT-BOUNDARY denote + * function and unwind-protect boundaries. * * The brackets [] denote differences between the bytecodes and C compiler * environments, with the first option belonging to the interpreter and the @@ -406,59 +448,57 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * declaration forms, as they do not completely match those of Common-Lisp. */ -#if 0 -#define new_location(env,x) ecl_make_fixnum(0) -#else static cl_object -new_location(const cl_compiler_ptr c_env) +c_push_record(const cl_compiler_ptr c_env, cl_object type, + cl_object arg1, cl_object arg2) { - return CONS(ecl_make_fixnum(c_env->env_depth), - ecl_make_fixnum(c_env->env_size++)); + cl_object depth = ecl_make_fixnum(c_env->env_depth); + cl_object index = ecl_make_fixnum(c_env->env_size++); + cl_object loc = CONS(depth, index); + return cl_list(4, type, arg1, arg2, loc); } -#endif -static cl_index +static void c_register_block(cl_env_ptr env, cl_object name) { const cl_compiler_ptr c_env = env->c_env; - cl_object loc = new_location(c_env); - c_env->variables = CONS(cl_list(4, @':block', name, ECL_NIL, loc), - c_env->variables); - return ecl_fixnum(ECL_CONS_CDR(loc)); + cl_object entry = c_push_record(c_env, @':block', name, ECL_NIL); + c_env->variables = CONS(entry, c_env->variables); } -static cl_index +static void c_register_tags(cl_env_ptr env, cl_object all_tags) { const cl_compiler_ptr c_env = env->c_env; - cl_object loc = new_location(c_env); - c_env->variables = CONS(cl_list(4, @':tag', all_tags, ECL_NIL, loc), - c_env->variables); - return ecl_fixnum(ECL_CONS_CDR(loc)); + cl_object entry = c_push_record(c_env, @':tag', all_tags, ECL_NIL); + c_env->variables = CONS(entry, c_env->variables); } static void -c_register_function(cl_env_ptr env, cl_object name) +c_register_var(cl_env_ptr env, cl_object var, bool special, bool bound) { const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(4, @':function', name, ECL_NIL, - new_location(c_env)), - c_env->variables); - c_env->macros = CONS(cl_list(2, name, @'function'), c_env->macros); + cl_object boundp = bound? ECL_T : ECL_NIL; + cl_object specialp = special? ECL_T : ECL_NIL; + cl_object entry = c_push_record(c_env, var, specialp, boundp); + c_env->variables = CONS(entry, c_env->variables); } -static cl_object -c_macro_expand1(cl_env_ptr env, cl_object stmt) +static void +c_register_function(cl_env_ptr env, cl_object name) { const cl_compiler_ptr c_env = env->c_env; - return cl_macroexpand_1(2, stmt, CONS(c_env->variables, c_env->macros)); + cl_object entry = c_push_record(c_env, @':function', name, ECL_NIL); + c_env->variables = CONS(entry, c_env->variables); + c_env->macros = CONS(cl_list(2, name, @'function'), c_env->macros); } static void c_register_symbol_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) { const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), c_env->variables); + cl_object entry = c_push_record(c_env, name, @'si::symbol-macro', exp_fun); + c_env->variables = CONS(entry, c_env->variables); } static void @@ -469,62 +509,71 @@ c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) } static void -c_register_var(cl_env_ptr env, cl_object var, bool special, bool bound) +c_register_boundary(cl_env_ptr env, cl_object type) { const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(4, var, - special? @'special' : ECL_NIL, - bound? ECL_T : ECL_NIL, - new_location(c_env)), - c_env->variables); + c_env->variables = CONS(type, c_env->variables); + c_env->macros = CONS(type, c_env->macros); } -static void -c_register_boundary(cl_env_ptr env, cl_object type) +static cl_object +c_macro_expand1(cl_env_ptr env, cl_object stmt) { const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(type, c_env->variables); - c_env->macros = CONS(type, c_env->macros); + if(ECL_ATOM(stmt)) { + if(!ECL_SYMBOLP(stmt)) return stmt; + c_sym_ref(env, stmt); + } else { + cl_object name = ECL_CONS_CAR(stmt); + if(!ECL_SYMBOLP(name)) return stmt; + c_mac_ref(env, name); + } + return cl_macroexpand_1(2, stmt, CONS(c_env->variables, c_env->macros)); } static void guess_compiler_environment(cl_env_ptr env, cl_object interpreter_env) { - if (!LISTP(interpreter_env)) + if (!ECL_VECTORP(interpreter_env)) return; /* * Given the environment of an interpreted function, we guess a * suitable compiler enviroment to compile forms that access the * variables and local functions of this interpreted code. */ - for (interpreter_env = @revappend(interpreter_env, ECL_NIL); - !Null(interpreter_env); - interpreter_env = ECL_CONS_CDR(interpreter_env)) - { - cl_object record = ECL_CONS_CAR(interpreter_env); - if (!LISTP(record)) { - if (ecl_t_of(record) == t_bclosure) - record = record->bclosure.code; - c_register_function(env, record->bytecodes.name); + cl_object record; + cl_object *lex = interpreter_env->vector.self.t; + cl_index index = interpreter_env->vector.dim; + while(index>0) { + index--; + record = lex[index]; + if (!LISTP(record)) { + if (ecl_t_of(record) == t_bclosure) + record = record->bclosure.code; + c_register_function(env, record->bytecodes.name); + } else { + cl_object record0 = ECL_CONS_CAR(record); + cl_object record1 = ECL_CONS_CDR(record); + if (ECL_SYMBOLP(record0)) { + if (record0 == @'si::macro') + c_register_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1)); + else if (record0 == @'si::symbol-macro') + c_register_symbol_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1)); + else + c_register_var(env, record0, FALSE, TRUE); + } else if (record1 == ecl_make_fixnum(0)) { + /* We have lost the information, which tag corresponds to + the lex-env record. If we are compiling a closure over a + tag, we will get an error later on. */ } else { - cl_object record0 = ECL_CONS_CAR(record); - cl_object record1 = ECL_CONS_CDR(record); - if (ECL_SYMBOLP(record0)) { - if (record0 == @'si::macro') - c_register_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1)); - else if (record0 == @'si::symbol-macro') - c_register_symbol_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1)); - else - c_register_var(env, record0, FALSE, TRUE); - } else if (record1 == ecl_make_fixnum(0)) { - /* We have lost the information, which tag corresponds to - the lex-env record. If we are compiling a closure over a - tag, we will get an error later on. */ - } else { - c_register_block(env, record1); - } + c_register_block(env, record1); } } + } + /* INV we register a function boundary so that objets are not looked for in + the parent locals. Top environment must have env->captured bound because + ecl_make_lambda will call c_any_ref on the parent env. -- jd 2025-01-13*/ + c_register_boundary(env, @'si::function-boundary'); } static void @@ -534,6 +583,7 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env, the_env->c_env = new; if (old) { *new = *old; + new->parent_env = old; new->env_depth = old->env_depth + 1; } else { new->code_walker = ECL_SYM_VAL(the_env, @'si::*code-walker*'); @@ -549,6 +599,8 @@ c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env, new->ltf_being_created = ECL_NIL; new->ltf_defer_init_until = ECL_T; new->ltf_locations = ECL_NIL; + new->captured = ECL_NIL; + new->parent_env = NULL; new->env_depth = 0; new->macros = CDR(env); new->variables = CAR(env); @@ -582,50 +634,265 @@ c_restore_env(cl_env_ptr the_env, cl_compiler_env_ptr new_c_env, cl_compiler_env the_env->c_env = old_c_env; } -static cl_object -c_tag_ref(cl_env_ptr env, cl_object the_tag, cl_object the_type) +/* c_sym_ref and c_mac_ref ensure that symbol macros and macros that are + referenced across the function boundary are captured. We capture the entry + verbatim and we don't bind any objects at runtime -- these objects are + supplied to enable recompilation by CCMP and BCMP. */ + +static void +close_around_macros(cl_env_ptr env, cl_object mfun) +{ + cl_object lex = mfun->bclosure.lex, record; + cl_object *lex_vec = lex->vector.self.t; + for (cl_index i = 0; i < lex->vector.dim; i++) { + cl_object reg = lex_vec[i]; /* INV see interpreter.d for lexenv structure */ + cl_object type = CAR(reg); /* lexenv tag */ + cl_object name = CDDR(reg); /* macro name */ + if (type == @'si::macro') { + c_mac_ref(env, name); + } else if (type == @'si::symbol_macro') { + c_sym_ref(env, name); + } + } +} + +void +c_sym_ref(cl_env_ptr env, cl_object name) +{ + const cl_compiler_ptr c_env = env->c_env; + int function_boundary_crossed = 0; + cl_object l = c_env->variables; + loop_for_on_unsafe(l) { + cl_object record = ECL_CONS_CAR(l), reg, type, other; + if (record == @'si::function-boundary') + function_boundary_crossed++; + if(ECL_ATOM(record)) + continue; + reg = record; + type = pop(®); + other = pop(®); + if (type == name) { + if (other == @'si::symbol-macro') { + if (function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + c_register_captured(env, record); + } else { + cl_object mfun = ECL_CONS_CAR(reg); + if (ecl_t_of(mfun) == t_bclosure) { + c_env->function_boundary_crossed = 1; + close_around_macros(env, mfun); + } + } + } + return; + } + } end_loop_for_on_unsafe(l); +} + +/* This looks in c_env->macros so it is unlike other c_*_ref functions. */ +void +c_mac_ref(cl_env_ptr env, cl_object name) +{ + const cl_compiler_ptr c_env = env->c_env; + int function_boundary_crossed = 0; + cl_object l = c_env->macros; + loop_for_on_unsafe(l) { + cl_object record = ECL_CONS_CAR(l), reg, type, other; + if (record == @'si::function-boundary') + function_boundary_crossed++; + if(ECL_ATOM(record)) + continue; + reg = record; + type = pop(®); + other = pop(®); + if (type == name) { + if(other == @':function') + return; + if(other == @'si::macro') { + if (function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + c_register_captured(env, record); + } else { + cl_object mfun = ECL_CONS_CAR(reg); + if (ecl_t_of(mfun) == t_bclosure) { + c_env->function_boundary_crossed = 1; + close_around_macros(env, mfun); + } + } + return; + } + } + } end_loop_for_on_unsafe(l); +} + +/* This function is called after we compile lambda in the parent's + environment. Its responsibility is to propagate closures. */ +static struct cl_compiler_ref +c_any_ref(cl_env_ptr env, cl_object entry) +{ + cl_fixnum n = 0; + int function_boundary_crossed = 0; + struct cl_compiler_ref output = { ECL_CMPREF_UNDEFINED }; + const cl_compiler_ptr c_env = env->c_env; + cl_object l = c_env->variables; + loop_for_on_unsafe(l) { + cl_object record = ECL_CONS_CAR(l), reg, type, other; + if (record == @'si::function-boundary') + function_boundary_crossed++; + if(ECL_ATOM(record)) + continue; + reg = record; + type = pop(®); + other = pop(®); + if(record == entry) { + if (function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + output.place = ECL_CMPREF_CLOSE; + output.index = c_register_captured(env, record); + } else { + output.place = ECL_CMPREF_LOCAL; + output.index = n; + } + output.entry = record; + return output; + } + if (type == @':block' || type == @':function'|| type == @':tag' + || Null(other)) { + n++; + } + } end_loop_for_on_unsafe(l); + return output; +} + +static struct cl_compiler_ref +c_tag_ref(cl_env_ptr env, cl_object the_tag) { cl_fixnum n = 0; - cl_object l, output = ECL_NIL; - bool function_boundary_crossed = 0; + cl_object l, reg; + int function_boundary_crossed = 0; + struct cl_compiler_ref output = { ECL_CMPREF_UNDEFINED }; const cl_compiler_ptr c_env = env->c_env; for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { - cl_object type, name, record = ECL_CONS_CAR(l); + cl_object type, all_tags, record = ECL_CONS_CAR(l); if (record == @'si::function-boundary') - function_boundary_crossed = 1; + function_boundary_crossed++; if (ECL_ATOM(record)) continue; - type = ECL_CONS_CAR(record); - record = ECL_CONS_CDR(record); - name = ECL_CONS_CAR(record); + reg = record; + type = pop(®); + all_tags = pop(®); if (type == @':tag') { - if (type == the_type) { - cl_object label = ecl_assql(the_tag, name); - if (!Null(label)) { - output = CONS(ecl_make_fixnum(n), ECL_CONS_CDR(label)); - break; + cl_object label = ecl_assql(the_tag, all_tags); + if (!Null(label)) { + /* Mark as used */ + ECL_RPLACA(reg, ECL_T); + if (function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + output.place = ECL_CMPREF_CLOSE; + output.index = c_register_captured(env, record); + } else { + output.place = ECL_CMPREF_LOCAL; + output.index = n; + } + output.entry = record; + output.label = ecl_fixnum(ECL_CONS_CDR(label)); + return output; + } + n++; + } else if (type == @':block' || type == @':function' || Null(all_tags)) { + /* INV Null(all_tags) implies lexical variable -- Null(specialp). */ + n++; + } else { + /* We are counting only locals and ignore specials, declarations, etc. */ + } + } + return output; +} + +static struct cl_compiler_ref +c_blk_ref(cl_env_ptr env, cl_object the_tag) +{ + cl_fixnum n = 0; + cl_object l, reg; + int function_boundary_crossed = 0; + struct cl_compiler_ref output = { ECL_CMPREF_UNDEFINED }; + const cl_compiler_ptr c_env = env->c_env; + for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { + cl_object type, name, record = ECL_CONS_CAR(l); + if (record == @'si::function-boundary') + function_boundary_crossed++; + if (ECL_ATOM(record)) + continue; + reg = record; + type = pop(®); + name = pop(®); + if (type == @':block') { + if(ecl_eql(name, the_tag)) { + /* Mark as used */ + ECL_RPLACA(reg, ECL_T); + if (function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + output.place = ECL_CMPREF_CLOSE; + output.index = c_register_captured(env, record); + } else { + output.place = ECL_CMPREF_LOCAL; + output.index = n; } + output.entry = record; + return output; } n++; - } else if (type == @':block' || type == @':function') { + } else if (type == @':tag' || type == @':function' || Null(name)) { + /* INV Null(name) implies lexical variable -- Null(specialp). */ + n++; + } else { + /* We are counting only locals and ignore specials, declarations, etc. */ + } + } + return output; +} + +static struct cl_compiler_ref +c_fun_ref(cl_env_ptr env, cl_object the_tag) +{ + cl_fixnum n = 0; + cl_object l, reg; + int function_boundary_crossed = 0; + struct cl_compiler_ref output = { ECL_CMPREF_UNDEFINED }; + const cl_compiler_ptr c_env = env->c_env; + for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { + cl_object type, name, record = ECL_CONS_CAR(l); + if (record == @'si::function-boundary') + function_boundary_crossed++; + if (ECL_ATOM(record)) + continue; + reg = record; + type = pop(®); + name = pop(®); + if (type == @':function') { /* We compare with EQUAL, because of (SETF fname) */ - if (type == the_type && ecl_equal(name, the_tag)) { + if(ecl_equal(name, the_tag)) { /* Mark as used */ - record = ECL_CONS_CDR(record); - ECL_RPLACA(record, ECL_T); - output = ecl_make_fixnum(n); - break; + ECL_RPLACA(reg, ECL_T); + if (function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + output.place = ECL_CMPREF_CLOSE; + output.index = c_register_captured(env, record); + } else { + output.place = ECL_CMPREF_LOCAL; + output.index = n; + } + output.entry = record; + return output; } n++; - } else if (Null(name)) { + } else if (type == @':tag' || type == @':block' || Null(name)) { + /* INV Null(name) implies lexical variable -- Null(specialp). */ n++; } else { - /* We are counting only locals and ignore specials - * and other declarations */ + /* We are counting only locals and ignore specials, declarations, etc. */ } } - if (function_boundary_crossed && !Null(output)) - c_env->function_boundary_crossed = 1; return output; } @@ -633,57 +900,96 @@ ecl_def_ct_base_string(undefined_variable, "Undefined variable referenced in interpreted code" ".~%Name: ~A", 60, static, const); -static cl_fixnum -c_var_ref(cl_env_ptr env, cl_object var, int allow_symbol_macro, bool ensure_defined) +static struct cl_compiler_ref +c_var_ref(cl_env_ptr env, cl_object var, bool allow_sym_mac, bool ensure_def) { - cl_fixnum n = 0, output = ECL_UNDEFINED_VAR_REF; - cl_object l, record, special, name; - bool function_boundary_crossed = 0; + cl_fixnum n = 0; + cl_object l, reg; + int function_boundary_crossed = 0; + struct cl_compiler_ref output; + output.place = ECL_CMPREF_UNDEFINED; + output.label = ECL_CMPVAR_UNDEFINED; const cl_compiler_ptr c_env = env->c_env; for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { - record = ECL_CONS_CAR(l); + cl_object type, special, record = ECL_CONS_CAR(l); if (record == @'si::function-boundary') - function_boundary_crossed = 1; + function_boundary_crossed++; if (ECL_ATOM(record)) continue; - name = ECL_CONS_CAR(record); - record = ECL_CONS_CDR(record); - special = ECL_CONS_CAR(record); - if (name == @':block' || name == @':tag' || name == @':function') { + reg = record; + type = pop(®); + special = pop(®); + if (type == @':block' || type == @':tag' || type == @':function') { n++; - } else if (name == @':declare') { + } else if (type == @':declare') { /* Ignored */ - } else if (name != var) { + } else if (type != var) { /* Symbol not yet found. Only count locals. */ if (Null(special)) n++; - } else if (special == @'si::symbol-macro') { - /* We can only get here when we try to redefine a - symbol macro */ - if (allow_symbol_macro) { - output = -1; - break; - } - FEprogram_error("Internal error: symbol macro ~S used as variable", - 1, var); } else if (Null(special)) { - output = n; - break; + if (function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + output.place = ECL_CMPREF_CLOSE; + output.index = c_register_captured(env, record); + } else { + output.place = ECL_CMPREF_LOCAL; + output.index = n; + } + output.entry = record; + output.label = ECL_CMPVAR_LEXICAL; + return output; + } else if (special == @'si::symbol-macro') { + if(!allow_sym_mac) + FEprogram_error("Internal error: symbol macro ~S used as variable", 1, var); + /* We can only get here when we try to redefine a symbol macro. */ + /* We don't close over symbol macros (but we will). */ + output.place = function_boundary_crossed + ? ECL_CMPREF_CLOSE + : ECL_CMPREF_LOCAL; + output.entry = record; + output.label = ECL_CMPVAR_SYM_MACRO; + return output; } else { - output = ECL_SPECIAL_VAR_REF; - break; + /* We don't close over special variables. */ + output.place = function_boundary_crossed + ? ECL_CMPREF_CLOSE + : ECL_CMPREF_LOCAL; + output.index = -1; + output.entry = record; + output.label = ECL_CMPVAR_SPECIAL; + return output; } } - if (ensure_defined) { + if (ensure_def) { l = ecl_cmp_symbol_value(env, @'ext::*action-on-undefined-variable*'); if (l != ECL_NIL) { - funcall(3, l, undefined_variable, var); + cl_funcall(3, l, undefined_variable, var); } } - if (function_boundary_crossed && output >= 0) - c_env->function_boundary_crossed = 1; return output; } +/* Depending on whether the variable is special, local or closed over, we emit + different opcodes since they are handled differently. -- jd 2025-01-07*/ +static int +c_var_ref_fix_op(struct cl_compiler_ref ref, int op) { + bool special = (ref.label == ECL_CMPVAR_SPECIAL + || ref.label == ECL_CMPVAR_UNDEFINED); + bool closure = (!special && ref.place == ECL_CMPREF_CLOSE); + if(!special && !closure) return op; + switch(op) { + /* setters */ + case OP_SETQ: return (special ? OP_SETQS : OP_SETQC); + case OP_PSETQ: return (special ? OP_PSETQS : OP_PSETQC); + case OP_VSETQ: return (special ? OP_VSETQS : OP_VSETQC); + /* getters */ + case OP_VAR: return (special ? OP_VARS : OP_VARC); + case OP_PUSHV: return (special ? OP_PUSHVS : OP_PUSHVC); + default: + ecl_miscompilation_error(); + } +} + static bool c_declared_special(cl_object var, cl_object specials) { @@ -694,11 +1000,17 @@ static void c_declare_specials(cl_env_ptr env, cl_object specials) { while (!Null(specials)) { - int ndx; cl_object var = pop(&specials); - ndx = c_var_ref(env, var, 1, FALSE); - if (ndx >= 0 || ndx == ECL_UNDEFINED_VAR_REF) + struct cl_compiler_ref ref = c_var_ref(env, var, TRUE, FALSE); + switch(ref.label) { + case ECL_CMPVAR_UNDEFINED: + case ECL_CMPVAR_SYM_MACRO: + case ECL_CMPVAR_LEXICAL: c_register_var(env, var, TRUE, FALSE); + break; + default: + break; + } } } @@ -783,22 +1095,23 @@ c_undo_bindings(cl_env_ptr the_env, cl_object old_vars, int only_specials) static void compile_setq(cl_env_ptr env, int op, cl_object var) { - cl_fixnum ndx; - + cl_index ndx; + struct cl_compiler_ref ref; if (!ECL_SYMBOLP(var)) FEillegal_variable_name(var); - ndx = c_var_ref(env, var,0,TRUE); - if (ndx < 0) { /* Not a lexical variable */ + ref = c_var_ref(env, var,FALSE,TRUE); + ndx = ref.index; + switch(ref.label) { + case ECL_CMPVAR_SPECIAL: + case ECL_CMPVAR_UNDEFINED: if (ecl_symbol_type(var) & ecl_stp_constant) { FEassignment_to_constant(var); } ndx = c_register_constant(env, var); - if (op == OP_SETQ) - op = OP_SETQS; - else if (op == OP_PSETQ) - op = OP_PSETQS; - else if (op == OP_VSETQ) - op = OP_VSETQS; + /* fall through */ + default: + op = c_var_ref_fix_op(ref, op); + break; } asm_op2(env, op, ndx); } @@ -939,8 +1252,6 @@ c_arguments(cl_env_ptr env, cl_object args) { return nargs; } -static int asm_function(cl_env_ptr env, cl_object args, int flags); - static int c_call(cl_env_ptr env, cl_object args, int flags) { cl_object name; @@ -975,10 +1286,11 @@ c_call(cl_env_ptr env, cl_object args, int flags) { asm_op2(env, OP_STEPCALL, nargs); flags = FLAG_VALUES; } else if (ECL_SYMBOLP(name) && - ((flags & FLAG_GLOBAL) || Null(c_tag_ref(env, name, @':function')))) + ((flags & FLAG_GLOBAL) || + c_fun_ref(env, name).place == ECL_CMPREF_UNDEFINED)) { asm_op2(env, OP_CALLG, nargs); - asm_c(env, name); + asm_arg_data(env, name); flags = FLAG_VALUES; } else { /* Fixme!! We can optimize the case of global functions! */ @@ -1048,7 +1360,7 @@ perform_c_case(cl_env_ptr env, cl_object args, int flags) { cl_object v = pop(&test); asm_op(env, OP_JEQL); maybe_make_load_forms(env, v); - asm_c(env, v); + asm_arg_data(env, v); asm_arg(env, n * (OPCODE_SIZE + OPARG_SIZE * 2) + OPARG_SIZE); } @@ -1056,7 +1368,7 @@ perform_c_case(cl_env_ptr env, cl_object args, int flags) { } asm_op(env, OP_JNEQL); maybe_make_load_forms(env, test); - asm_c(env, test); + asm_arg_data(env, test); labeln = current_pc(env); asm_arg(env, 0); compile_body(env, clause, flags); @@ -1352,12 +1664,13 @@ c_register_functions(cl_env_ptr env, cl_object l) static int c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) { #define push_back(v,l) { cl_object c = *l = CONS(v, *l); l = &ECL_CONS_CDR(c); } + const cl_compiler_ptr c_env = env->c_env; cl_object l, def_list = pop(&args); - cl_object old_vars = env->c_env->variables; - cl_object old_funs = env->c_env->macros; + cl_object old_vars = c_env->variables; + cl_object old_funs = c_env->macros; cl_object fnames = ECL_NIL; cl_object v, *f = &fnames; - cl_index nfun; + cl_index nfun, lex_idx; if (def_list == ECL_NIL) { return c_locally(env, args, flags); @@ -1388,8 +1701,8 @@ c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) { cl_object definition = pop(&l); cl_object name = pop(&definition); cl_object lambda = ecl_make_lambda(env, name, definition); - cl_index c = c_register_constant(env, lambda); - asm_arg(env, c); + lex_idx = c_register_constant(env, lambda); + asm_arg(env, lex_idx); } /* If compiling a FLET form, add the function names to the lexical @@ -1431,42 +1744,25 @@ c_function(cl_env_ptr env, cl_object args, int flags) { return asm_function(env, function, flags); } -static cl_object -create_macro_lexenv(cl_compiler_ptr c_env) -{ - /* Creates a new lexenv out of the macros in the current compiler - * environment */ - cl_object lexenv = ECL_NIL; - cl_object records; - for (records = c_env->macros; !Null(records); records = ECL_CONS_CDR(records)) { - cl_object record = ECL_CONS_CAR(records); - if (ECL_ATOM(record)) - continue; - if (CADR(record) == @'si::macro') - lexenv = CONS(CONS(@'si::macro', CONS(CADDR(record), CAR(record))), lexenv); - } - for (records = c_env->variables; !Null(records); records = ECL_CONS_CDR(records)) { - cl_object record = ECL_CONS_CAR(records); - if (ECL_ATOM(record)) - continue; - if (CADR(record) == @'si::symbol-macro') - lexenv = CONS(CONS(@'si::symbol-macro', CONS(CADDR(record), CAR(record))), lexenv); - } - return lexenv; -} - static int /* XXX: here we look for function in cmpenv */ asm_function(cl_env_ptr env, cl_object function, int flags) { if (!Null(si_valid_function_name_p(function))) { - cl_object ndx = c_tag_ref(env, function, @':function'); - if (Null(ndx)) { + struct cl_compiler_ref ref = c_fun_ref(env, function); + switch(ref.place) { + case ECL_CMPREF_UNDEFINED: /* Globally defined function */ asm_op2c(env, OP_FUNCTION, function); return FLAG_REG0; - } else { + case ECL_CMPREF_LOCAL: /* Function from a FLET/LABELS form */ - asm_op2(env, OP_LFUNCTION, ecl_fixnum(ndx)); + asm_op2(env, OP_LFUNCTION, ref.index); return FLAG_REG0; + case ECL_CMPREF_CLOSE: + /* Function from a FLET/LABELS form (cfb) */ + asm_op2(env, OP_CFUNCTION, ref.index); + return FLAG_REG0; + default: + ecl_miscompilation_error(); } } if (CONSP(function)) { @@ -1482,47 +1778,50 @@ asm_function(cl_env_ptr env, cl_object function, int flags) { goto ERROR; } - const cl_compiler_ptr c_env = env->c_env; cl_object lambda = ecl_make_lambda(env, name, body); cl_object cfb = ecl_nth_value(env, 1); - cl_object macro_lexenv = create_macro_lexenv(c_env); - if (!Null(macro_lexenv)) { - /* Close around macros to allow calling compile on the function - * in the future */ - lambda = ecl_close_around(lambda, macro_lexenv); - } if (Null(cfb)) { /* No closure */ asm_op2c(env, OP_QUOTE, lambda); } else { - /* Close around functions and variables */ + /* Close around referenced objects */ asm_op2c(env, OP_CLOSE, lambda); } return FLAG_REG0; } ERROR: FEprogram_error("FUNCTION: Not a valid argument ~S.", 1, function); - return FLAG_REG0; } - static int c_go(cl_env_ptr env, cl_object args, int flags) { cl_object tag = pop(&args); + if (!Null(args)) { + FEprogram_error("GO: Too many arguments.",0); + } if (Null(tag)) { tag = ECL_NIL_SYMBOL; } - cl_object info = c_tag_ref(env, tag, @':tag'); - if (Null(info)) + struct cl_compiler_ref ref = c_tag_ref(env, tag); + switch(ref.place) { + case ECL_CMPREF_UNDEFINED: FEprogram_error("GO: Unknown tag ~S.", 1, tag); - if (!Null(args)) - FEprogram_error("GO: Too many arguments.",0); - asm_op2(env, OP_GO, ecl_fixnum(CAR(info))); - asm_arg(env, ecl_fixnum(CDR(info))); + case ECL_CMPREF_LOCAL: + asm_op(env, OP_GO); + asm_arg(env, ref.index); + asm_arg(env, ref.label); + break; + case ECL_CMPREF_CLOSE: + asm_op(env, OP_GO_CFB); + asm_arg(env, ref.index); + asm_arg(env, ref.label); + break; + default: + ecl_miscompilation_error(); + } return flags; } - /* (if a b) -> (cond (a b)) (if a b c) -> (cond (a b) (t c)) @@ -1687,9 +1986,8 @@ c_locally(cl_env_ptr env, cl_object args, int flags) { /* MACROLET - The current lexical environment is saved. A new one is prepared with - the definitions of these macros, and this environment is used to - compile the body. + The current lexical environment is saved. A new one is prepared with the + definitions of these macros, and this environment is used to compile the body. */ static int c_macrolet(cl_env_ptr the_env, cl_object args, int flags) @@ -1722,7 +2020,7 @@ c_vbind(cl_env_ptr env, cl_object var, int n, cl_object specials) asm_op(env, OP_BIND); } } - asm_c(env, var); + asm_arg_data(env, var); } static int @@ -1995,25 +2293,33 @@ c_psetq(cl_env_ptr env, cl_object old_args, int flags) { /* - The OP_RETFROM operator returns from a block using the objects - in VALUES() as output values. + The OP_RETURN operator returns from a block putting result in VALUES(). ... ; output form - OP_RETFROM - tag ; object which names the block + OP_RETURN | OP_RETURN_CFB + idx ; index of the output block */ static int -c_return_aux(cl_env_ptr env, cl_object name, cl_object stmt, int flags) +c_return_aux(cl_env_ptr env, cl_object name, cl_object args, int flags) { - cl_object ndx = c_tag_ref(env, name, @':block'); - cl_object output = pop_maybe_nil(&stmt); - - if (!ECL_SYMBOLP(name) || Null(ndx)) - FEprogram_error("RETURN-FROM: Unknown block name ~S.", 1, name); - if (stmt != ECL_NIL) + struct cl_compiler_ref ref = c_blk_ref(env, name); + cl_object output = pop_maybe_nil(&args); + if (!Null(args)) FEprogram_error("RETURN-FROM: Too many arguments.", 0); - compile_form(env, output, FLAG_VALUES); - asm_op2(env, OP_RETURN, ecl_fixnum(ndx)); + switch(ref.place) { + case ECL_CMPREF_UNDEFINED: + FEprogram_error("RETURN-FROM: Unknown block name ~S.", 1, name); + case ECL_CMPREF_LOCAL: + compile_form(env, output, FLAG_VALUES); + asm_op2(env, OP_RETURN, ref.index); + break; + case ECL_CMPREF_CLOSE: + compile_form(env, output, FLAG_VALUES); + asm_op2(env, OP_RETURN_CFB, ref.index); + break; + default: + ecl_miscompilation_error(); + } return FLAG_VALUES; } @@ -2299,12 +2605,19 @@ compile_symbol(cl_env_ptr env, cl_object stmt, int flags) if (stmt1 != stmt) { return compile_form(env, stmt1, flags); } else { - cl_fixnum index = c_var_ref(env, stmt,0,FALSE); + struct cl_compiler_ref ref = c_var_ref(env, stmt, FALSE, FALSE); bool push = flags & FLAG_PUSH; - if (index >= 0) { - asm_op2(env, push? OP_PUSHV : OP_VAR, index); - } else { - asm_op2c(env, push? OP_PUSHVS : OP_VARS, stmt); + int op = c_var_ref_fix_op(ref, push ? OP_PUSHV : OP_VAR); + switch (ref.label) { + case ECL_CMPVAR_LEXICAL: + asm_op2(env, op, ref.index); + break; + case ECL_CMPVAR_SPECIAL: + case ECL_CMPVAR_UNDEFINED: + asm_op2c(env, op, stmt); + break; + default: + ecl_miscompilation_error(); } if (flags & FLAG_VALUES) return (flags & ~FLAG_VALUES) | FLAG_REG0; @@ -2349,12 +2662,10 @@ compile_form(cl_env_ptr env, cl_object stmt, int flags) { if (index != OBJNULL) { compiler_record *l = database + ecl_fixnum(index); c_env->lexical_level += l->lexical_increment; - if (c_env->stepping && function != @'function' && - c_env->lexical_level) + if (c_env->stepping && function != @'function' && c_env->lexical_level) asm_op2c(env, OP_STEPIN, stmt); new_flags = (*(l->compiler))(env, ECL_CONS_CDR(stmt), flags); - if (c_env->stepping && function != @'function' && - c_env->lexical_level) + if (c_env->stepping && function != @'function' && c_env->lexical_level) asm_op(env, OP_STEPOUT); c_env->lexical_level -= l->lexical_increment; goto OUTPUT; @@ -2428,6 +2739,14 @@ eval_nontrivial_form(cl_env_ptr env, cl_object form) { new_c_env.ltf_being_created = ECL_NIL; new_c_env.ltf_defer_init_until = ECL_T; new_c_env.ltf_locations = ECL_NIL; + /* INV ecl_make_lambda calls c_any_ref with this environment, so we need to + have the vector for captured variables bound. -- jd 2025-01-13 */ + new_c_env.captured = si_make_vector(ECL_T, ecl_make_fixnum(16), + ECL_T, /* Adjustable */ + ecl_make_fixnum(0), /* Fillp */ + ECL_NIL, /* displacement */ + ECL_NIL); + new_c_env.parent_env = NULL; new_c_env.env_depth = 0; new_c_env.env_size = 0; env->c_env = &new_c_env; @@ -2705,6 +3024,31 @@ c_listA(cl_env_ptr env, cl_object args, int flags) return c_list_listA(env, args, flags, OP_LISTA); } +/* -- Primops --------------------------------------------------------------- */ + +static int +c_cons_car(cl_env_ptr env, cl_object args, int flags) +{ + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error("CAR: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_CONS_CAR); + return FLAG_REG0; +} + +static int +c_cons_cdr(cl_env_ptr env, cl_object args, int flags) +{ + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error("CDR: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_CONS_CDR); + return FLAG_REG0; +} /* ----------------------------- PUBLIC INTERFACE ---------------------------- */ @@ -2805,11 +3149,13 @@ si_need_to_make_load_form_p(cl_object object) cl_object bc = object->bclosure.code; push(object->bclosure.lex, &waiting_objects); push(bc->bytecodes.data, &waiting_objects); + push(bc->bytecodes.flex, &waiting_objects); push(bc->bytecodes.name, &waiting_objects); goto loop; } case t_bytecodes: push(object->bytecodes.data, &waiting_objects); + push(object->bytecodes.flex, &waiting_objects); push(object->bytecodes.name, &waiting_objects); goto loop; default: @@ -3134,22 +3480,42 @@ c_default(cl_env_ptr env, cl_object var, cl_object stmt, cl_object flag, cl_obje c_pbind(env, var, specials); } +static cl_object +fix_macro_to_lexenv(cl_env_ptr env, cl_object record) { + cl_object arg1 = pop(&record); + cl_object arg2 = pop(&record); + cl_object arg3 = pop(&record); + if (arg2 == @'si::macro') { + c_mac_ref(env, arg1); + return CONS(arg2, CONS(arg3, arg1)); + } else if (arg2 == @'si::symbol-macro') { + c_sym_ref(env, arg1); + return CONS(arg2, CONS(arg3, arg1)); + } else { + return ECL_NIL; + } +} + cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys; cl_object specials, decl, body, output; cl_object cfb = ECL_NIL; cl_index handle; - struct cl_compiler_env *old_c_env, new_c_env; + struct cl_compiler_env *old_c_env, new_c_env[1]; ecl_bds_bind(env, @'si::*current-form*', @list*(3, @'ext::lambda-block', name, lambda)); old_c_env = env->c_env; - c_new_env(env, &new_c_env, ECL_NIL, old_c_env); - new_c_env.lexical_level++; - new_c_env.function_boundary_crossed = 0; - + c_new_env(env, new_c_env, ECL_NIL, old_c_env); + new_c_env->lexical_level++; + new_c_env->function_boundary_crossed = 0; + new_c_env->captured = si_make_vector(ECL_T, ecl_make_fixnum(16), + ECL_T, /* Adjustable */ + ecl_make_fixnum(0), /* Fillp */ + ECL_NIL, /* displacement */ + ECL_NIL); reqs = si_process_lambda(lambda); opts = env->values[1]; rest = env->values[2]; @@ -3241,15 +3607,46 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { lambda = ECL_NIL; output = asm_end(env, handle, lambda); output->bytecodes.name = name; + output->bytecodes.flex = ECL_NIL; + + old_c_env->load_time_forms = new_c_env->load_time_forms; + + c_restore_env(env, new_c_env, old_c_env); + ecl_bds_unwind1(env); /* @'si::*current-form*', */ + + /* Process closed over entries. */ + if (new_c_env->function_boundary_crossed) { + cl_object p = new_c_env->captured, flex, entry, macro_entry; + struct cl_compiler_ref ref; + int i, n, index; + n = p->vector.fillp; + flex = si_make_vector(ECL_T, ecl_make_fixnum(n), + ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); + output->bytecodes.flex = flex; + for (i = 0; i < n; i++) { + entry = p->vector.self.t[i]; + p->vector.self.t[i] = ECL_NIL; + macro_entry = fix_macro_to_lexenv(env, entry); + if(!Null(macro_entry)) { + flex->vector.self.t[i] = macro_entry; + continue; + } + ref = c_any_ref(env, entry); + switch(ref.place) { + case ECL_CMPREF_LOCAL: + flex->vector.self.t[i] = ecl_make_fixnum(-ref.index-1); + break; + case ECL_CMPREF_CLOSE: + flex->vector.self.t[i] = ecl_make_fixnum(ref.index); + break; + default: + ecl_miscompilation_error(); + } + } - old_c_env->load_time_forms = env->c_env->load_time_forms; - if (env->c_env->function_boundary_crossed) { old_c_env->function_boundary_crossed = 1; cfb = ECL_T; } - c_restore_env(env, &new_c_env, old_c_env); - - ecl_bds_unwind1(env); ecl_return2(env, output, cfb); } @@ -3374,6 +3771,7 @@ si_bc_compile_from_stream(cl_object input) new_c_env.lex_env = ECL_NIL; } new_c_env.stepping = stepping != ECL_NIL; + the_env->stepper = @'si::stepper-hook'; ECL_UNWIND_PROTECT_BEGIN(the_env) { if (mode == @':execute') { eval_form(the_env, form); diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 0f4655076fe969e47eed2843fae18c0edbc5c57a..e996b6b8c53d0ffc0508a51e2e99946055bd710e 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -218,14 +218,21 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { goto OPARG; /* OP_VAR n{arg} - Sets NVALUES=1 and VALUES(0) to the value of the n-th local. + Sets reg0 to the value of the n-th local. */ case OP_VAR: string = "VAR\t"; GET_OPARG(n, vector); goto OPARG; + /* OP_VARC n{arg} + Sets reg0 to the value of the n-th lexical. + */ + case OP_VARC: string = "VARC\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_VARS var{symbol} - Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR. + Sets reg0 to the value of the symbol VAR. VAR should be either a special variable or a constant. */ case OP_VARS: string = "VARS\t"; @@ -248,6 +255,13 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { GET_OPARG(n, vector); goto OPARG; + /* OP_PUSHV n{arg} + Pushes the value of the n-th lexical onto the stack. + */ + case OP_PUSHVC: string = "PUSHVC\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_PUSHVS var{symbol} Pushes the value of the symbol VAR onto the stack. VAR should be either a special variable or a constant. @@ -384,19 +398,23 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_LABELS: vector = disassemble_labels(bytecodes, vector); break; - /* OP_LFUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. + /* OP_LFUNCTION index{fixnum} + Extracts nth function defined in the local environment. */ case OP_LFUNCTION: string = "LOCFUNC\t"; GET_OPARG(n, vector); goto OPARG; + /* OP_CFUNCTION index{fixnum} + Extracts nth function defined in the lexical environment. + */ + case OP_CFUNCTION: string = "LEXFUNC\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_FUNCTION name{symbol} Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. + is defined in the global environment. */ case OP_FUNCTION: string = "SYMFUNC\t"; GET_DATA(o, vector, data); @@ -412,10 +430,11 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { goto ARG; /* OP_GO n{arg}, tag-ndx{arg} - OP_QUOTE tag-name{symbol} - Jumps to the tag which is defined at the n-th position in - the lexical environment. TAG-NAME is kept for debugging - purposes. + OP_GO_CFB n{lex}, tag-ndx{arg} + + Jumps to the tag which is defined for the tagbody + frame registered at the n-th position in the lexical + environment. TAG-NDX is the number of tag in the list. */ case OP_GO: string = "GO\t"; GET_OPARG(n, vector); @@ -423,14 +442,26 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { o = ecl_make_fixnum(m); goto OPARG_ARG; - /* OP_RETURN n{arg} + case OP_GO_CFB: string = "GO_CFB\t"; + GET_OPARG(n, vector); + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + goto OPARG_ARG; + + /* OP_RETURN n{arg} + OP_RETURN_CFB n{lex} + Returns from the block whose record in the lexical environment occuppies the n-th position. - */ + */ case OP_RETURN: string = "RETFROM\t"; GET_OPARG(n, vector); goto OPARG; + case OP_RETURN_CFB: string = "RETFROM_CFB\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_THROW Jumps to an enclosing CATCH form whose tag matches the one of the THROW. The tag is taken from the stack, while the @@ -508,30 +539,51 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { GET_DATA(o, vector, data); goto OPARG_ARG; /* OP_SETQ n{arg} + OP_SETQC n{arg} + OP_SETQS n{arg} + OP_PSETQ n{arg} - OP_SETQS var-name{symbol} - OP_PSETQS var-name{symbol} - Sets either the n-th local or a special variable VAR-NAME, - to either the value in VALUES(0) (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]). + OP_PSETQC n{arg} + OP_PSETQS n{arg} + + OP_VSETQ n{arg}, nvalue{arg} + OP_VSETQC n{arg}, nvalue{arg} + OP_VSETQS n{arg}, nvalue{arg} + + Sets either the n-th variable to either the value in REG0 (OP_SETQ[CS]) + or to the first value on the stack (OP_PSETQ[CS]), or to a given value + from the multiple values array (OP_VSETQ[CS]). Note NVALUE > 0 strictly. */ case OP_SETQ: string = "SETQ\t"; GET_OPARG(n, vector); goto OPARG; - case OP_PSETQ: string = "PSETQ\t"; + case OP_SETQC: string = "SETQC\t"; GET_OPARG(n, vector); goto OPARG; - case OP_VSETQ: string = "VSETQ\t"; - GET_OPARG(m, vector); - o = ecl_make_fixnum(m); - GET_OPARG(n, vector); - goto OPARG_ARG; case OP_SETQS: string = "SETQS\t"; GET_DATA(o, vector, data); goto ARG; + + case OP_PSETQ: string = "PSETQ\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_PSETQC: string = "PSETQC\t"; + GET_DATA(o, vector, data); + goto ARG; case OP_PSETQS: string = "PSETQS\t"; GET_DATA(o, vector, data); goto ARG; + + case OP_VSETQ: string = "VSETQ\t"; + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + GET_OPARG(n, vector); + goto OPARG_ARG; + case OP_VSETQC: string = "VSETQC\t"; + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + GET_OPARG(n, vector); + goto OPARG_ARG; case OP_VSETQS: string = "VSETQS\t"; GET_DATA(o, vector, data); GET_OPARG(n, vector); @@ -582,6 +634,9 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_LISTA: string = "LIST*\t"; GET_OPARG(n, vector); goto OPARG; + case OP_CONS_CAR: string = "CONS-CAR\tREG0"; goto NOARG; + case OP_CONS_CDR: string = "CONS-CDR\tREG0"; goto NOARG; + case OP_CALLG1: string = "CALLG1\t"; GET_DATA(o, vector, data); goto ARG; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2010d377036619f129fdb7eb76c7980191f3b835..bf435a268b4ee5f130043732bd2aaca6e02f02a8 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -19,28 +19,114 @@ #include #include +/* -- Errors signaled by the interpreter. ----------------------------------- */ + +static void +VEbad_lambda_too_many_args(cl_object bytecodes, cl_object frame) +{ + FEprogram_error("Too many arguments passed to " + "function ~A~&Argument list: ~S", + 2, bytecodes, cl_apply(2, @'list', frame)); +} + +static void +VEbad_lambda_unknown_keyword(cl_object bytecodes, cl_object frame) +{ + FEprogram_error("Unknown keyword argument passed to function ~S.~&" + "Argument list: ~S", 2, bytecodes, + cl_apply(2, @'list', frame)); +} + +static void +VEbad_lambda_odd_keys(cl_object bytecodes, cl_object frame) +{ + FEprogram_error("Function ~A called with odd number " + "of keyword arguments.", + 1, bytecodes); +} + +static void +VEwrong_arg_type_endp(cl_object reg0) +{ + FEwrong_type_only_arg(@[endp], reg0, @[list]); +} + +static void +VEwrong_arg_type_car(cl_object reg0) +{ + FEwrong_type_only_arg(@[car], reg0, @[cons]); +} + +static void +VEwrong_arg_type_cdr(cl_object reg0) +{ + FEwrong_type_only_arg(@[cdr], reg0, @[cons]); +} + +static void +VEwrong_arg_type_nth_val(cl_fixnum n) +{ + FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); +} + +static void +VEassignment_to_constant(cl_object var) +{ + FEassignment_to_constant(var); +} + +static void +VEunbound_variable(cl_object var) +{ + FEunbound_variable(var); +} + +static void +VEwrong_num_arguments(cl_object fname) +{ + FEwrong_num_arguments(fname); +} + +static void +VEundefined_function(cl_object fun) +{ + FEundefined_function(fun); +} + +static void +VEinvalid_function(cl_object fun) +{ + FEinvalid_function(fun); +} + +static void +VEclose_around_arg_type() +{ + FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0); +} + /* ------------------------------ LEXICAL ENV. ------------------------------ */ /* - * A lexical environment is a list of pairs, each one containing - * either a variable definition, a tagbody or block tag, or a local - * function or macro definition. + * A lexical environment is a list of entries, each containing either a variable + * definition, a tagbody or block tag, or a local function or macro definition. * * lex_env ---> ( { record }* ) - * record = variable | function | block_tag | tagbody_tag | macro + * record = variable | function | block | tagbody | macro | sym_macro * - * variable = ( var_name[symbol] . value ) - * function = function[bytecodes] - * block_tag = ( tag[fixnum] . block_name[symbol] ) - * tagbody_tag = ( tag[fixnum] . 0 ) - * macro = ( { si::macro | si::symbol-macro } macro_function[bytecodes] . macro_name ) + * variable = ( var_name[symbol] . value ) + * function = function[bytecodes] + * block = ( tag[fixnum] . block_name[symbol] ) + * tagbody = ( tag[fixnum] . 0 ) + * macro = ( si::macro macro_function[bytecodes] . macro_name ) + * sym_macro = ( si::symbol-macro macro_function[bytecodes] . macro_name ) */ -#define bind_var(env, var, val) CONS(CONS(var, val), (env)) -#define bind_function(env, name, fun) CONS(fun, (env)) -#define bind_frame(env, id, name) CONS(CONS(id, name), (env)) +#define bind_var(env, var, val) CONS(CONS(var, val), (env)) +#define bind_function(env, fun) CONS(fun, (env)) +#define bind_frame(env, id, name) CONS(CONS(id, name), (env)) static cl_object -ecl_lex_env_get_record(cl_object env, int s) +ecl_lcl_env_get_record(cl_object env, int s) { do { if (s-- == 0) return ECL_CONS_CAR(env); @@ -48,10 +134,38 @@ ecl_lex_env_get_record(cl_object env, int s) } while(1); } +static cl_object +ecl_lex_env_get_record(cl_object env, int s) +{ + return env->vector.self.t[s]; +} + +#define ecl_lcl_env_get_fun(env,x) ecl_lcl_env_get_record(env,x) +#define ecl_lcl_env_get_blk(env,x) ecl_lcl_env_get_record(env,x) +#define ecl_lcl_env_get_tag(env,x) ecl_lcl_env_get_record(env,x) +#define ecl_lcl_env_get_var(env,x) ECL_CONS_CDR(ecl_lcl_env_get_record(env,x)) +#define ecl_lcl_env_set_var(env,x,v) ECL_RPLACD(ecl_lcl_env_get_record(env,x),(v)) + +#define ecl_lex_env_get_fun(env,x) ecl_lex_env_get_record(env,x) +#define ecl_lex_env_get_blk(env,x) ecl_lex_env_get_record(env,x) +#define ecl_lex_env_get_tag(env,x) ecl_lex_env_get_record(env,x) #define ecl_lex_env_get_var(env,x) ECL_CONS_CDR(ecl_lex_env_get_record(env,x)) #define ecl_lex_env_set_var(env,x,v) ECL_RPLACD(ecl_lex_env_get_record(env,x),(v)) -#define ecl_lex_env_get_fun(env,x) ecl_lex_env_get_record(env,x) -#define ecl_lex_env_get_tag(env,x) ECL_CONS_CAR(ecl_lex_env_get_record(env,x)) + +/* -- Lexical and local env operators ------------------------------------------ */ + +static cl_object +make_lex(cl_index n) +{ + return si_make_vector(ECL_T, ecl_make_fixnum(n), ECL_NIL, + ecl_make_fixnum(0), ECL_NIL, ECL_NIL); +} + +static void +push_lex(cl_object stack, cl_object new) +{ + cl_vector_push(new, stack); +} /* -------------------- AIDS TO THE INTERPRETER -------------------- */ @@ -76,32 +190,125 @@ _ecl_bclosure_dispatch_vararg(cl_narg narg, ...) return output; } -cl_object -ecl_close_around(cl_object fun, cl_object lex) { - cl_object v; - if (Null(lex)) return fun; - switch (ecl_t_of(fun)) { +/* Find the global function definition associated with a name. This function is + similar to ecl_fdefinition except thta it does not check for lambdas and + assumes that the name is either SYMBOL or (SETF SYMBOL). -- jd 2024-12-12 */ +static cl_object +_ecl_global_function_definition(cl_object name) +{ + cl_object fun = ECL_NIL, sym, pair; + switch (ecl_t_of(name)) { + case t_symbol: + unlikely_if (!ECL_FBOUNDP(name) + || name->symbol.stype & (ecl_stp_macro | ecl_stp_special_form)) + VEundefined_function(name); + fun = ECL_SYM_FUN(name); + break; + case t_list: + unlikely_if (Null(name)) + VEundefined_function(name); + /* (setf fname) */ + sym = ECL_CONS_CAR(ECL_CONS_CDR(name)); + pair = sym->symbol.sfdef; + unlikely_if (Null(pair) || Null(ECL_CONS_CDR(pair))) { + VEundefined_function(name); + } + fun = ECL_CONS_CAR(pair); + break; + default: + VEinvalid_function(name); + } + return fun; +} + +/* Functions close_around_self and close_around_self_fixup are defined to first + create a closure (so that it can be bound in locals) and then they modify + these closures in place to enable self references. -- jd 2025-01-07 */ +static cl_object +close_around_self(cl_object fun) { + cl_object v, template; + if(ecl_t_of(fun) != t_bytecodes) + VEclose_around_arg_type(); + template = fun->bytecodes.flex; + if(Null(template)) return fun; + /* Make a closure */ + v = ecl_alloc_object(t_bclosure); + v->bclosure.entry = _ecl_bclosure_dispatch_vararg; + v->bclosure.code = fun; + v->bclosure.lex = ECL_NIL; + return v; +} + +static void +close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object lex_env) { + cl_object new_lex, template, entry; + cl_fixnum nlex, idx, ndx; + switch(ecl_t_of(fun)) { case t_bytecodes: - v = ecl_alloc_object(t_bclosure); - v->bclosure.code = fun; - v->bclosure.lex = lex; - v->bclosure.entry = _ecl_bclosure_dispatch_vararg; break; case t_bclosure: - v = ecl_alloc_object(t_bclosure); - v->bclosure.code = fun->bclosure.code; - /* Put the predefined macros in fun->bclosure.lex at the end of - the lexenv so that lexenv indices are still valid */ - v->bclosure.lex = ecl_append(lex, fun->bclosure.lex); - v->bclosure.entry = fun->bclosure.entry; + template = fun->bclosure.code->bytecodes.flex; + /* Close around */ + nlex = template->vector.dim; + new_lex = make_lex(nlex); + for (idx = 0; idxvector.self.t[idx]; + if(!ECL_FIXNUMP(entry)) { + push_lex(new_lex, entry); + continue; + } + ndx = ecl_fixnum(template->vector.self.t[idx]); + ndx < 0 + ? push_lex(new_lex, ecl_lcl_env_get_record(lcl_env, -ndx-1)) + : push_lex(new_lex, ecl_lex_env_get_record(lex_env, ndx)); + } + /* Fixup the closure */ + fun->bclosure.lex = new_lex; break; default: - FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0); + VEclose_around_arg_type(); + } +} + + +cl_object +ecl_close_around(cl_object fun, cl_object lcl_env, cl_object lex_env) { + cl_object v, new_lex, template, entry; + cl_fixnum nlex, idx, ndx; + if(ecl_t_of(fun) != t_bytecodes) + VEclose_around_arg_type(); + template = fun->bytecodes.flex; + if(Null(template)) return fun; + /* Close around */ + nlex = template->vector.dim; + new_lex = make_lex(nlex); + for (idx = 0; idxvector.self.t[idx]; + if(!ECL_FIXNUMP(entry)) { + push_lex(new_lex, entry); + continue; + } + ndx = ecl_fixnum(template->vector.self.t[idx]); + ndx < 0 + ? push_lex(new_lex, ecl_lcl_env_get_record(lcl_env, -ndx-1)) + : push_lex(new_lex, ecl_lex_env_get_record(lex_env, ndx)); } + /* Make a closure */ + v = ecl_alloc_object(t_bclosure); + v->bclosure.entry = _ecl_bclosure_dispatch_vararg; + v->bclosure.code = fun; + v->bclosure.lex = new_lex; + /* Profit */ return v; } -#define SETUP_ENV(the_env) { ihs.lex_env = lex_env; } +static inline cl_object +call_stepper(cl_env_ptr the_env, cl_object form, cl_object delta) +{ + return _ecl_funcall3(the_env->stepper, form, delta); +} + +#define SETUP_ENV(the_env) { ihs.lex_env = closure; } /* * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted @@ -111,53 +318,26 @@ ecl_close_around(cl_object fun, cl_object lex) { * lexical environment needs to be saved. */ -#define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \ - cl_index __n = narg; \ - SETUP_ENV(the_env); \ - frame.stack = the_env->stack; \ - frame.base = the_env->stack_top - (frame.size = __n); \ - reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \ +#define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \ + cl_index __n = narg; \ + SETUP_ENV(the_env); \ + frame.stack = the_env->stack; \ + frame.base = the_env->stack_top - (frame.size = __n); \ + reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \ the_env->stack_top -= __n; } -static void too_many_arguments(cl_object bytecodes, cl_object frame) ecl_attr_noreturn; -static void odd_number_of_keywords(cl_object bytecodes) ecl_attr_noreturn; -static void unknown_keyword(cl_object bytecodes, cl_object frame) ecl_attr_noreturn; - -static void -too_many_arguments(cl_object bytecodes, cl_object frame) -{ - FEprogram_error("Too many arguments passed to " - "function ~A~&Argument list: ~S", - 2, bytecodes, cl_apply(2, @'list', frame)); -} - -static void -odd_number_of_keywords(cl_object bytecodes) -{ - FEprogram_error("Function ~A called with odd number " - "of keyword arguments.", - 1, bytecodes); -} - -static void -unknown_keyword(cl_object bytecodes, cl_object frame) -{ - FEprogram_error("Unknown keyword argument passed to function ~S.~&" - "Argument list: ~S", 2, bytecodes, - cl_apply(2, @'list', frame)); -} - /* -------------------- THE INTERPRETER -------------------- */ cl_object -ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) +ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) { ECL_OFFSET_TABLE const cl_env_ptr the_env = frame->frame.env; volatile cl_index frame_index = 0; cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code; cl_object *data = bytecodes->bytecodes.data->vector.self.t; - cl_object reg0 = ECL_NIL, reg1 = ECL_NIL, lex_env = env; + cl_object lex_env = closure; + cl_object reg0 = ECL_NIL, reg1 = ECL_NIL, lcl_env = NULL; cl_index narg; struct ecl_stack_frame frame_aux; volatile struct ecl_ihs_frame ihs; @@ -165,7 +345,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) /* INV: bytecodes is of type t_bytecodes */ ecl_cs_check(the_env, ihs); - ecl_ihs_push(the_env, &ihs, bytecodes, lex_env); + ecl_ihs_push(the_env, &ihs, bytecodes, closure); frame_aux.t = t_frame; frame_aux.stack = frame_aux.base = 0; frame_aux.size = 0; @@ -183,34 +363,35 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) GET_DATA(reg0, vector, data); THREAD_NEXT; } - /* OP_VAR n{arg}, var{symbol} - Sets REG0 to the value of the n-th local. - VAR is the name of the variable for readability purposes. + /* OP_VAR n{lcl} + OP_VARC n{lex} + OP_VARS n{dat} + Sets REG0 to the value of the n-th variable's value. */ CASE(OP_VAR); { - cl_fixnum lex_env_index; - GET_OPARG(lex_env_index, vector); - reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); + cl_fixnum ndx; + GET_OPARG(ndx, vector); + reg0 = ecl_lcl_env_get_var(lcl_env, ndx); + THREAD_NEXT; + } + CASE(OP_VARC); { + cl_fixnum ndx; + GET_OPARG(ndx, vector); + reg0 = ecl_lex_env_get_var(lex_env, ndx); THREAD_NEXT; } - - /* OP_VARS var{symbol} - Sets REG0 to the value of the symbol VAR. - VAR should be either a special variable or a constant. - */ CASE(OP_VARS); { cl_object var_name; GET_DATA(var_name, vector, data); reg0 = ECL_SYM_VAL(the_env, var_name); if (ecl_unlikely(reg0 == OBJNULL)) - FEunbound_variable(var_name); + VEunbound_variable(var_name); THREAD_NEXT; } /* OP_CONS, OP_CAR, OP_CDR, etc Inlined forms for some functions which act on reg0 and stack. */ - CASE(OP_CONS); { cl_object car = ECL_STACK_POP_UNSAFE(the_env); reg0 = CONS(car, reg0); @@ -219,14 +400,14 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_CAR); { if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[car], reg0, @[cons]); + VEwrong_arg_type_car(reg0); reg0 = CAR(reg0); THREAD_NEXT; } CASE(OP_CDR); { if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[cdr], reg0, @[cons]); + VEwrong_arg_type_cdr(reg0); reg0 = CDR(reg0); THREAD_NEXT; } @@ -243,6 +424,19 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) THREAD_NEXT; } + /* OP_CONS_CAR and OP_CONS_CDR + (Unsafe) primops that act on reg0 and stack. + */ + CASE(OP_CONS_CAR); { + reg0 = ECL_CONS_CAR(reg0); + THREAD_NEXT; + } + + CASE(OP_CONS_CDR); { + reg0 = ECL_CONS_CDR(reg0); + THREAD_NEXT; + } + CASE(OP_INT); { cl_fixnum n; GET_OPARG(n, vector); @@ -264,32 +458,34 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) ECL_STACK_PUSH(the_env, reg0); THREAD_NEXT; } - /* OP_PUSHV n{arg} - Pushes the value of the n-th local onto the stack. + /* OP_PUSHV n{lcl} + OP_PUSHVC n{lex} + OP_PUSHVS n{dat} + Pushes the value of the n-th variable onto the stack. */ CASE(OP_PUSHV); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); + int ndx; + GET_OPARG(ndx, vector); + ECL_STACK_PUSH(the_env, ecl_lcl_env_get_var(lcl_env, ndx)); + THREAD_NEXT; + } + CASE(OP_PUSHVC); { + int ndx; + GET_OPARG(ndx, vector); + ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, ndx)); THREAD_NEXT; } - - /* OP_PUSHVS var{symbol} - Pushes the value of the symbol VAR onto the stack. - VAR should be either a special variable or a constant. - */ CASE(OP_PUSHVS); { cl_object var_name, value; GET_DATA(var_name, vector, data); value = ECL_SYM_VAL(the_env, var_name); if (ecl_unlikely(value == OBJNULL)) - FEunbound_variable(var_name); + VEunbound_variable(var_name); ECL_STACK_PUSH(the_env, value); THREAD_NEXT; } - - /* OP_PUSHQ value{object} - Pushes "value" onto the stack. + /* OP_PUSHQ n{arg} + Pushes n-th constant onto the stack. */ CASE(OP_PUSHQ); { cl_object aux; @@ -327,7 +523,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) */ CASE(OP_CALL); { GET_OPARG(narg, vector); - goto DO_CALL; + INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); + THREAD_NEXT; } /* OP_CALLG n{arg}, name{arg} @@ -338,7 +535,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_CALLG); { GET_OPARG(narg, vector); GET_DATA(reg0, vector, data); - goto DO_CALL; + INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); + THREAD_NEXT; } /* OP_FCALL n{arg} @@ -349,7 +547,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_FCALL); { GET_OPARG(narg, vector); reg0 = ECL_STACK_REF(the_env,-narg-1); - goto DO_CALL; + INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); + THREAD_NEXT; } /* OP_MCALL @@ -359,70 +558,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_MCALL); { narg = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); reg0 = ECL_STACK_REF(the_env,-narg-1); - goto DO_CALL; - } - - DO_CALL: { - cl_object x = reg0; - cl_object frame = (cl_object)&frame_aux; - frame_aux.size = narg; - frame_aux.base = the_env->stack_top - narg; - the_env->stack_frame = frame; - SETUP_ENV(the_env); - AGAIN: - if (ecl_unlikely(reg0 == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(reg0)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)reg0->cfunfixed.narg)) - FEwrong_num_arguments(reg0); - reg0 = APPLY_fixed(narg, reg0->cfunfixed.entry_fixed, - frame_aux.base); - break; - case t_cfun: -#ifdef ECL_C_COMPATIBLE_VARIADIC_DISPATCH - the_env->function = reg0; -#endif - reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.base); - break; - case t_cclosure: - the_env->function = reg0; - reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.base); - break; - case t_instance: - switch (reg0->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - reg0 = _ecl_standard_dispatch(frame, reg0); - break; - case ECL_USER_DISPATCH: - reg0 = reg0->instance.slots[reg0->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - the_env->function = reg0; - reg0 = APPLY(narg, reg0->instance.entry, frame_aux.base); - break; - default: - FEinvalid_function(reg0); - } - break; - case t_symbol: - if (ecl_unlikely(!ECL_FBOUNDP(x))) - FEundefined_function(x); - reg0 = ECL_SYM_FUN(reg0); - goto AGAIN; - case t_bytecodes: - reg0 = ecl_interpret(frame, ECL_NIL, reg0); - break; - case t_bclosure: - reg0 = ecl_interpret(frame, reg0->bclosure.lex, reg0->bclosure.code); - break; - default: - FEinvalid_function(reg0); - } - ECL_STACK_POP_N_UNSAFE(the_env, narg); - the_env->stack_frame = NULL; /* for gc's sake */ + INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); THREAD_NEXT; } @@ -434,7 +570,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) THREAD_NEXT; } /* OP_POP1 - Pops a singe value pushed by a OP_PUSH* operator, ignoring it. + Pops a single value pushed by a OP_PUSH* operator, ignoring it. */ CASE(OP_POP1); { (void)ECL_STACK_POP_UNSAFE(the_env); @@ -446,7 +582,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) */ CASE(OP_POPREQ); { if (ecl_unlikely(frame_index >= frame->frame.size)) { - FEwrong_num_arguments(bytecodes->bytecodes.name); + VEwrong_num_arguments(frame->bytecodes.name); } reg0 = frame->frame.base[frame_index++]; THREAD_NEXT; @@ -470,7 +606,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) */ CASE(OP_NOMORE); { if (ecl_unlikely(frame_index < frame->frame.size)) - too_many_arguments(bytecodes, frame); + VEbad_lambda_too_many_args(bytecodes, frame); THREAD_NEXT; } /* OP_POPREST @@ -495,7 +631,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) count = frame->frame.size - frame_index; last = first + count; if (ecl_unlikely(count & 1)) { - odd_number_of_keywords(bytecodes); + VEbad_lambda_odd_keys(bytecodes, frame); } aok = ECL_CONS_CAR(keys_list); for (; (keys_list = ECL_CONS_CDR(keys_list), !Null(keys_list)); ) { @@ -531,7 +667,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } } if (ecl_likely(count && Null(aok))) { - unknown_keyword(bytecodes, frame); + VEbad_lambda_unknown_keyword(bytecodes, frame); } } THREAD_NEXT; @@ -554,18 +690,17 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) Note that nfun > 0. */ CASE(OP_FLET); { - int nfun; - cl_object old_lex; + int idx, nfun; + cl_object fun_env=ECL_NIL, fun; GET_OPARG(nfun, vector); - /* Copy the environment so that functions get it without references - to themselves, and then add new closures to the environment. */ - old_lex = lex_env; - do { - cl_object f; - GET_DATA(f, vector, data); - f = ecl_close_around(f, old_lex); - lex_env = bind_function(lex_env, f->bytecodes.name, f); - } while (--nfun); + /* Create closures. */ + for(idx = 0; idxbytecodes.name, f); + f = close_around_self(f); + lcl_env = bind_function(lcl_env, f); } while (--i); } /* Update the closures so that all functions can call each other */ { - cl_object l = lex_env; + cl_object l = lcl_env; do { - ECL_RPLACA(l, ecl_close_around(ECL_CONS_CAR(l), lex_env)); + close_around_self_fixup(ECL_CONS_CAR(l), lcl_env, lex_env); l = ECL_CONS_CDR(l); } while (--nfun); } THREAD_NEXT; } - /* OP_LFUNCTION n{arg}, function-name{symbol} - Calls the local or global function with N arguments - which have been deposited in the stack. + /* OP_LFUNCTION index{fixnum} ; local + OP_CFUNCTION index{fixnum} ; cfb + + Extracts a local function denoted by the index from the environment. */ - CASE(OP_LFUNCTION); { /* XXX: local function (fix comment) */ - int lex_env_index; - GET_OPARG(lex_env_index, vector); - reg0 = ecl_lex_env_get_fun(lex_env, lex_env_index); + CASE(OP_LFUNCTION); { + int ndx; + GET_OPARG(ndx, vector); + reg0 = ecl_lcl_env_get_fun(lcl_env, ndx); THREAD_NEXT; } + CASE(OP_CFUNCTION); { + int ndx; + GET_OPARG(ndx, vector); + reg0 = ecl_lex_env_get_fun(lex_env, ndx); + THREAD_NEXT; + } + + /* OP_FUNCTION name{function-name} - /* OP_FUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. + Extracts a function associated with the name. The function is defined in + the global environment. Local function are handled by OP_LFUNCTION and + lambdas are handled by OP_QUOTE and OP_CLOSE. */ - CASE(OP_FUNCTION); { /* XXX: global function (fix comment) */ + CASE(OP_FUNCTION); { GET_DATA(reg0, vector, data); - reg0 = ecl_fdefinition(reg0); + reg0 = _ecl_global_function_definition(reg0); THREAD_NEXT; } - /* OP_CLOSE name{symbol} - Creates a closure around the current lexical environment for - the function associated to the given symbol. + /* OP_CLOSE fun{object} + + Creates a closure around objects referenced in the current lexical + environment. Objects may be part of parent locals or its closure. */ CASE(OP_CLOSE); { - GET_DATA(reg0, vector, data); - reg0 = ecl_close_around(reg0, lex_env); + cl_object fun; + GET_DATA(fun, vector, data); + reg0 = ecl_close_around(fun, lcl_env, lex_env); THREAD_NEXT; } + /* OP_GO n{arg}, tag-ndx{arg} + OP_GO_CFB n{lex}, tag-ndx{arg} + Jumps to the tag which is defined for the tagbody frame registered at the n-th position in the lexical environment. TAG-NDX is the number of tag in the list. */ CASE(OP_GO); { - cl_index lex_env_index; + cl_index ndx; cl_fixnum tag_ndx; - GET_OPARG(lex_env_index, vector); + cl_object record; + GET_OPARG(ndx, vector); + GET_OPARG(tag_ndx, vector); + record = ecl_lcl_env_get_tag(lcl_env, ndx); + /* record = (id . ???) */ + cl_go(ECL_CONS_CAR(record), ecl_make_fixnum(tag_ndx)); + THREAD_NEXT; + } + CASE(OP_GO_CFB); { + cl_fixnum ndx, tag_ndx; + cl_object record; + GET_OPARG(ndx, vector); GET_OPARG(tag_ndx, vector); - cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), - ecl_make_fixnum(tag_ndx)); + record = ecl_lex_env_get_tag(lex_env, ndx); + /* record = (id . ???) */ + cl_go(ECL_CONS_CAR(record), ecl_make_fixnum(tag_ndx)); THREAD_NEXT; } - /* OP_RETURN n{arg} - Returns from the block whose record in the lexical environment - occuppies the n-th position. + /* OP_RETURN n{arg} + OP_RETURN_CFB n{lex} + + Returns from the block whose record in the environment occuppies the n-th + position. */ CASE(OP_RETURN); { - int lex_env_index; - cl_object block_record; - GET_OPARG(lex_env_index, vector); + int ndx; + cl_object record; + GET_OPARG(ndx, vector); + /* record = (id . name) */ + record = ecl_lcl_env_get_blk(lcl_env, ndx); + the_env->values[0] = reg0; + cl_return_from(ECL_CONS_CAR(record), ECL_CONS_CDR(record)); + THREAD_NEXT; + } + CASE(OP_RETURN_CFB); { + int ndx; + cl_object record; + GET_OPARG(ndx, vector); /* record = (id . name) */ - block_record = ecl_lex_env_get_record(lex_env, lex_env_index); + record = ecl_lex_env_get_blk(lex_env, ndx); the_env->values[0] = reg0; - cl_return_from(ECL_CONS_CAR(block_record), - ECL_CONS_CDR(block_record)); + cl_return_from(ECL_CONS_CAR(record), ECL_CONS_CDR(record)); THREAD_NEXT; } /* OP_THROW @@ -718,7 +890,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_ENDP); if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[endp], reg0, @[list]); + VEwrong_arg_type_endp(reg0); CASE(OP_NOT); { reg0 = (reg0 == ECL_NIL)? ECL_T : ECL_NIL; THREAD_NEXT; @@ -731,7 +903,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) cl_oparg n; GET_OPARG(n, vector); while (n--) - lex_env = ECL_CONS_CDR(lex_env); + lcl_env = ECL_CONS_CDR(lcl_env); THREAD_NEXT; } /* OP_UNBINDS n{arg} @@ -756,13 +928,13 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_BIND); { cl_object var_name; GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, reg0); + lcl_env = bind_var(lcl_env, var_name, reg0); THREAD_NEXT; } CASE(OP_PBIND); { cl_object var_name; GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + lcl_env = bind_var(lcl_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); THREAD_NEXT; } CASE(OP_VBIND); { @@ -770,7 +942,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) cl_object var_name; GET_OPARG(n, vector); GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, + lcl_env = bind_var(lcl_env, var_name, (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); THREAD_NEXT; } @@ -795,22 +967,32 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); THREAD_NEXT; } - /* OP_SETQ n{arg} - OP_PSETQ n{arg} - OP_SETQS var-name{symbol} - OP_PSETQS var-name{symbol} - OP_VSETQ n{arg}, nvalue{arg} - OP_VSETQS var-name{symbol}, nvalue{arg} - Sets either the n-th local or a special variable VAR-NAME, - to either the value in REG0 (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]), or to a given - value from the multiple values array (OP_VSETQ[S]). Note - that NVALUE > 0 strictly. + /* OP_SETQ n{lcl} + OP_SETQC n{lex} + OP_SETQS n{dat} + + OP_PSETQ n{lcl} + OP_PSETQC n{lex} + OP_PSETQS n{dat} + + OP_VSETQ n{lcl}, nvalue{arg} + OP_VSETQC n{lex}, nvalue{arg} + OP_VSETQS n{dat}, nvalue{arg} + + Sets either the n-th variable to either the value in REG0 (OP_SETQ[CS]) + or to the first value on the stack (OP_PSETQ[CS]), or to a given value + from the multiple values array (OP_VSETQ[CS]). Note NVALUE > 0 strictly. */ CASE(OP_SETQ); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, reg0); + int ndx; + GET_OPARG(ndx, vector); + ecl_lcl_env_set_var(lcl_env, ndx, reg0); + THREAD_NEXT; + } + CASE(OP_SETQC); { + int ndx; + GET_OPARG(ndx, vector); + ecl_lex_env_set_var(lex_env, ndx, reg0); THREAD_NEXT; } CASE(OP_SETQS); { @@ -818,15 +1000,20 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ if (ecl_unlikely(var->symbol.stype & ecl_stp_constant)) - FEassignment_to_constant(var); + VEassignment_to_constant(var); ECL_SETQ(the_env, var, reg0); THREAD_NEXT; } CASE(OP_PSETQ); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, - ECL_STACK_POP_UNSAFE(the_env)); + int ndx; + GET_OPARG(ndx, vector); + ecl_lcl_env_set_var(lcl_env, ndx, ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_PSETQC); { + int ndx; + GET_OPARG(ndx, vector); + ecl_lex_env_set_var(lex_env, ndx, ECL_STACK_POP_UNSAFE(the_env)); THREAD_NEXT; } CASE(OP_PSETQS); { @@ -837,12 +1024,27 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) THREAD_NEXT; } CASE(OP_VSETQ); { - cl_index lex_env_index; + cl_index ndx; + cl_oparg index; + cl_object value; + GET_OPARG(ndx, vector); + GET_OPARG(index, vector); + value = (index >= the_env->nvalues) + ? ECL_NIL + : the_env->values[index]; + ecl_lcl_env_set_var(lcl_env, ndx, value); + THREAD_NEXT; + } + CASE(OP_VSETQC); { + cl_index ndx; cl_oparg index; - GET_OPARG(lex_env_index, vector); + cl_object value; + GET_OPARG(ndx, vector); GET_OPARG(index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, - (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]); + value = (index >= the_env->nvalues) + ? ECL_NIL + : the_env->values[index]; + ecl_lex_env_set_var(lex_env, ndx, value); THREAD_NEXT; } CASE(OP_VSETQS); { @@ -868,24 +1070,24 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_BLOCK); { GET_DATA(reg0, vector, data); reg1 = ecl_make_fixnum(the_env->frame_id++); - lex_env = bind_frame(lex_env, reg1, reg0); + lcl_env = bind_frame(lcl_env, reg1, reg0); THREAD_NEXT; } CASE(OP_DO); { reg0 = ECL_NIL; reg1 = ecl_make_fixnum(the_env->frame_id++); - lex_env = bind_frame(lex_env, reg1, reg0); + lcl_env = bind_frame(lcl_env, reg1, reg0); THREAD_NEXT; } CASE(OP_CATCH); { reg1 = reg0; - lex_env = bind_frame(lex_env, reg1, reg0); + lcl_env = bind_frame(lcl_env, reg1, reg0); THREAD_NEXT; } CASE(OP_FRAME); { cl_opcode *exit; GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, lcl_env); ECL_STACK_PUSH(the_env, (cl_object)exit); ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result == 0) { @@ -893,7 +1095,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } else { reg0 = the_env->values[0]; vector = (cl_opcode *)ECL_STACK_REF(the_env,-1); /* FIXME! */ - lex_env = ECL_STACK_REF(the_env,-2); + lcl_env = ECL_STACK_REF(the_env,-2); goto DO_EXIT_FRAME; } } @@ -913,18 +1115,16 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_TAGBODY); { int n; GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, lcl_env); ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ vector += n * OPARG_SIZE; ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result != 0) { - /* Wait here for gotos. Each goto sets - VALUES(0) to an integer which ranges from 0 - to ntags-1, depending on the tag. These - numbers are indices into the jump table and - are computed at compile time. */ + /* Wait here for gotos. Each goto sets VALUES(0) to an integer which + ranges from 0 to ntags-1, depending on the tag. These numbers are + indices into the jump table and are computed at compile time. */ cl_opcode *table = (cl_opcode *)ECL_STACK_REF(the_env,-1); - lex_env = ECL_STACK_REF(the_env,-2); + lcl_env = ECL_STACK_REF(the_env,-2); table = table + ecl_fixnum(the_env->values[0]) * OPARG_SIZE; vector = table + *(cl_oparg *)table; } @@ -937,7 +1137,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) DO_EXIT_FRAME: ecl_frs_pop(the_env); ECL_STACK_POP_N_UNSAFE(the_env, 2); - lex_env = ECL_CONS_CDR(lex_env); + lcl_env = ECL_CONS_CDR(lcl_env); THREAD_NEXT; } CASE(OP_NIL); { @@ -1017,7 +1217,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_NTHVAL); { cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); if (ecl_unlikely(n < 0)) { - FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); + VEwrong_arg_type_nth_val(n); } else if ((cl_index)n >= the_env->nvalues) { reg0 = ECL_NIL; } else if (n) { @@ -1041,13 +1241,13 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, lcl_env); ECL_STACK_PUSH(the_env, (cl_object)exit); ecl_frs_push(the_env,ECL_PROTECT_TAG); if (__ecl_frs_push_result != 0) { ecl_frs_pop(the_env); vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); - lex_env = ECL_STACK_POP_UNSAFE(the_env); + 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)); goto PUSH_VALUES; @@ -1058,7 +1258,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); ecl_frs_pop(the_env); (void)ECL_STACK_POP_UNSAFE(the_env); - lex_env = ECL_STACK_POP_UNSAFE(the_env); + lcl_env = ECL_STACK_POP_UNSAFE(the_env); ECL_STACK_PUSH(the_env, ecl_make_fixnum(1)); goto PUSH_VALUES; } @@ -1100,28 +1300,12 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) CASE(OP_STEPIN); { cl_object form; - cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); cl_index n; GET_DATA(form, vector, data); SETUP_ENV(the_env); the_env->values[0] = reg0; n = ecl_stack_push_values(the_env); - if (a == ECL_T) { - /* We are stepping in, but must first ask the user - * what to do. */ - ECL_SETQ(the_env, @'si::*step-level*', - cl_1P(ECL_SYM_VAL(the_env, @'si::*step-level*'))); - ECL_STACK_PUSH(the_env, form); - INTERPRET_FUNCALL(form, the_env, frame_aux, 1, @'si::stepper'); - } else if (a != ECL_NIL) { - /* The user told us to step over. *step-level* contains - * an integer number that, when it becomes 0, means - * that we have finished stepping over. */ - ECL_SETQ(the_env, @'si::*step-action*', cl_1P(a)); - } else { - /* We are not inside a STEP form. This should - * actually never happen. */ - } + call_stepper(the_env, form, ecl_make_fixnum(1)); ecl_stack_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; @@ -1133,31 +1317,15 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) cl_fixnum n; GET_OPARG(n, vector); SETUP_ENV(the_env); - if (ECL_SYM_VAL(the_env, @'si::*step-action*') == ECL_T) { - ECL_STACK_PUSH(the_env, reg0); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); - } + reg0 = call_stepper(the_env, reg0, ecl_make_fixnum(0)); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); } CASE(OP_STEPOUT); { - cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); cl_index n; SETUP_ENV(the_env); the_env->values[0] = reg0; n = ecl_stack_push_values(the_env); - if (a == ECL_T) { - /* We exit one stepping level */ - ECL_SETQ(the_env, @'si::*step-level*', - cl_1M(ECL_SYM_VAL(the_env, @'si::*step-level*'))); - } else if (a == ecl_make_fixnum(0)) { - /* We are back to the level in which the user - * selected to step over. */ - ECL_SETQ(the_env, @'si::*step-action*', ECL_T); - } else if (a != ECL_NIL) { - ECL_SETQ(the_env, @'si::*step-action*', cl_1M(a)); - } else { - /* Not stepping, nothing to be done. */ - } + call_stepper(the_env, ECL_NIL, ecl_make_fixnum(-1)); ecl_stack_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; diff --git a/src/c/main.d b/src/c/main.d index e46c2ec07d3fe83b93fa39347a0aa2541dbb7c81..e7b48ec531310ae168c3928ca9c45d8870e391a9 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -413,7 +413,6 @@ struct cl_core_struct cl_core = { .Jan1st1970UT = ECL_NIL, .system_properties = ECL_NIL, - .setf_definitions = ECL_NIL, #ifdef ECL_THREADS .processes = ECL_NIL, @@ -514,6 +513,8 @@ cl_boot(int argc, char **argv) ECL_NIL_SYMBOL->symbol.name = str_NIL; ECL_NIL_SYMBOL->symbol.cname = ECL_NIL; ECL_FMAKUNBOUND(ECL_NIL_SYMBOL); + ECL_NIL_SYMBOL->symbol.sfdef = ECL_NIL; + ECL_NIL_SYMBOL->symbol.macfun = ECL_NIL; ECL_NIL_SYMBOL->symbol.plist = ECL_NIL; ECL_NIL_SYMBOL->symbol.hpack = ECL_NIL; ECL_NIL_SYMBOL->symbol.stype = ecl_stp_constant; @@ -528,6 +529,8 @@ cl_boot(int argc, char **argv) ECL_T->symbol.name = str_T; ECL_T->symbol.cname = ECL_NIL; ECL_FMAKUNBOUND(ECL_T); + ECL_T->symbol.sfdef = ECL_NIL; + ECL_T->symbol.macfun = ECL_NIL; ECL_T->symbol.plist = ECL_NIL; ECL_T->symbol.hpack = ECL_NIL; ECL_T->symbol.stype = ecl_stp_constant; @@ -678,10 +681,6 @@ cl_boot(int argc, char **argv) cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ cl_core.rehash_size, cl_core.rehash_threshold); - cl_core.setf_definitions = - cl__make_hash_table(@'eq', ecl_make_fixnum(256), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); diff --git a/src/c/printer/write_code.d b/src/c/printer/write_code.d index 5abf46ec1b242d2fef7040daeffcb423a00b0e4d..160a377d9048b0e95705a2060f54e26508450826 100644 --- a/src/c/printer/write_code.d +++ b/src/c/printer/write_code.d @@ -21,20 +21,15 @@ _ecl_write_bytecodes_readably(cl_object x, cl_object stream, cl_object lex) { cl_index i; cl_object code_l = ECL_NIL; - /* INV: We don't write the definition of the closure, hence we don't - * need to write the macros it closes over either */ - for (; !Null(lex); lex = ECL_CONS_CDR(lex)) { - cl_object record = ECL_CONS_CAR(lex); - if (!ECL_CONSP(record) || (ECL_CONS_CAR(record) != @'si::macro' && - ECL_CONS_CAR(record) != @'si::symbol-macro')) - break; - } for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) code_l = ecl_cons(ecl_make_fixnum(((cl_opcode*)(x->bytecodes.code))[i]), code_l); writestr_stream("#Y", stream); + /* We don't write the definition because is not guaranteed to be readable. */ si_write_ugly_object(cl_list(7, x->bytecodes.name, lex, ECL_NIL /* x->bytecodes.definition */, - code_l, x->bytecodes.data, + code_l, + x->bytecodes.data, + x->bytecodes.flex, x->bytecodes.file, x->bytecodes.file_position), stream); diff --git a/src/c/read.d b/src/c/read.d index 31dace2bc4b05d181948c8d9e7281f44f54af20f..4fba0b93bde1a1434dffd2e5b421404774641401 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -765,6 +765,10 @@ sharp_Y_reader(cl_object in, cl_object c, cl_object d) x = ECL_CONS_CDR(x); rv->bytecodes.data = nth; + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.flex = nth; + if (ECL_ATOM(x)) { nth = ECL_NIL; } else { @@ -1252,6 +1256,7 @@ do_patch_sharp(cl_object x, cl_object table) x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); + x->bytecodes.flex = do_patch_sharp(x->bytecodes.flex, table); break; } default:; diff --git a/src/c/serialize.d b/src/c/serialize.d index 650fb268c856dc5641164bcc5687c4eb13e9c7e6..44ecfe1f4ce1af80cc2dede7dc78ae78c21c6d5d 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -327,6 +327,7 @@ serialize_one(pool_t pool, cl_object what) buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name); buffer->bytecodes.definition = enqueue(pool, buffer->bytecodes.definition); buffer->bytecodes.data = enqueue(pool, buffer->bytecodes.data); + buffer->bytecodes.flex = enqueue(pool, buffer->bytecodes.flex); buffer->bytecodes.file = enqueue(pool, buffer->bytecodes.file); buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position); buffer->bytecodes.code_size = serialize_bits(pool, buffer->bytecodes.code, @@ -614,6 +615,7 @@ fixup(cl_object o, cl_object *o_list) o->bytecodes.name = get_object(o->bytecodes.name, o_list); o->bytecodes.definition = get_object(o->bytecodes.definition, o_list); o->bytecodes.data = get_object(o->bytecodes.data, o_list); + o->bytecodes.flex = get_object(o->bytecodes.flex, o_list); o->bytecodes.file = get_object(o->bytecodes.file, o_list); o->bytecodes.file_position = get_object(o->bytecodes.file_position, o_list); o->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; diff --git a/src/c/symbol.d b/src/c/symbol.d index 0cc4e6a2177236f443615627e34e3b7698406ab1..151a15562eeae039ccd7bdd0fd6322d3f9adefe0 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -109,6 +109,7 @@ cl_make_symbol(cl_object str) ECL_SET(x,OBJNULL); ECL_FMAKUNBOUND(x); x->symbol.undef_entry = ecl_undefined_function_entry; + x->symbol.sfdef = ECL_NIL; x->symbol.plist = ECL_NIL; x->symbol.hpack = ECL_NIL; x->symbol.stype = ecl_stp_ordinary; @@ -332,6 +333,7 @@ cl_symbol_name(cl_object x) x->symbol.value = sym->symbol.value; x->symbol.plist = cl_copy_list(sym->symbol.plist); x->symbol.undef_entry = sym->symbol.undef_entry; + x->symbol.sfdef = sym->symbol.sfdef; x->symbol.macfun = sym->symbol.macfun; if (ECL_FBOUNDP(sym)) { x->symbol.gfdef = sym->symbol.gfdef; diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index dcf51ec94d624a85f95341142900f9ba6de1897b..921ca57152c0d95126dcd23a67bde14fefe9a513 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1288,7 +1288,7 @@ cl_symbols[] = { {SYS_ "SPECIALP" ECL_FUN("si_specialp", si_specialp, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "CONSTP" ECL_FUN("si_constp", si_constp, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "STANDARD-READTABLE" ECL_FUN("si_standard_readtable", si_standard_readtable, 0) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "STEPPER" ECL_FUN("OBJNULL", OBJNULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "STEPPER-HOOK" ECL_FUN("OBJNULL", OBJNULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "BASE-STRING-CONCATENATE" ECL_FUN("si_base_string_concatenate", si_base_string_concatenate, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "STRING-TO-OBJECT" ECL_FUN("si_string_to_object", ECL_NAME(si_string_to_object), -2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "STRUCTURE-NAME" ECL_FUN("si_structure_name", si_structure_name, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index b43be843f1159faaced8578c269c380db56a0c1d..3fb421e497edf5cab131ce8a285e9422d7270869 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -174,46 +174,57 @@ "Set up an environment for compilation of closures: Register closed over macros in the compiler environment and enclose the definition of the closure in let/flet forms for variables/functions it closes over." - (loop for record in lexenv - do (cond ((not (listp record)) - (multiple-value-bind (record-def record-lexenv) - (function-lambda-expression record) - (cond ((eql (car record-def) 'LAMBDA) - (setf record-def (cdr record-def))) - ((eql (car record-def) 'EXT:LAMBDA-BLOCK) - (setf record-def (cddr record-def))) - (t - (error "~&;;; Error: Not a valid lambda expression: ~s." record-def))) - ;; allow for closures which close over closures. - ;; (first record-def) is the lambda list, (rest - ;; record-def) the definition of the local function - ;; in record - (setf (rest record-def) - (list (set-closure-env (if (= (length record-def) 2) - (second record-def) - `(progn ,@(rest record-def))) - record-lexenv env))) - (setf definition - `(flet ((,(ext:compiled-function-name record) - ,@record-def)) - ,definition)))) - ((and (listp record) (symbolp (car record))) - (cond ((eq (car record) 'si:macro) - (cmp-env-register-macro (cddr record) (cadr record) env)) - ((eq (car record) 'si:symbol-macro) - (cmp-env-register-symbol-macro-function (cddr record) (cadr record) env)) - (t - (setf definition - `(let ((,(car record) ',(cdr record))) - ,definition))) - )) - ;; ((and (integerp (cdr record)) (= (cdr record) 0)) - ;; Tags: We have lost the information, which tag - ;; corresponds to the lex-env record. If we are - ;; compiling a closure over a tag, we will get an - ;; error later on. - ;; ) - ;; (t - ;; Blocks: Not yet implemented - ) - finally (return definition))) + (flet ((handle-record (record) + (cond + ((not (listp record)) + (multiple-value-bind (record-def record-lexenv) + (function-lambda-expression record) + (let* ((self-ref (position record record-lexenv)) + (flet-env (remove record record-lexenv))) + (case (car record-def) + (CL:LAMBDA + (setf record-def (cdr record-def))) + (EXT:LAMBDA-BLOCK + (setf record-def (cddr record-def))) + (otherwise + (error "~&;;; Error: Not a valid lambda expression: ~s." + record-def))) + ;; Allow for closures that close over other closures. + ;; (first record-def) is the lambda list, (rest record-def) + ;; the definition of the local function in the record. + (setf (rest record-def) + (list (set-closure-env (if (= (length record-def) 2) + (second record-def) + `(progn ,@(rest record-def))) + flet-env env))) + (setf definition + (if self-ref + `(labels ((,(ext:compiled-function-name record) + ,@record-def)) + ,definition) + `(flet ((,(ext:compiled-function-name record) + ,@record-def)) + ,definition)))))) + ((and (listp record) (symbolp (car record))) + (cond ((eq (car record) 'si:macro) + (cmp-env-register-macro (cddr record) (cadr record) env)) + ((eq (car record) 'si:symbol-macro) + (cmp-env-register-symbol-macro-function (cddr record) + (cadr record) + env)) + (t + (setf definition + `(let ((,(car record) ',(cdr record))) + ,definition))) + )) + ;; ((and (integerp (cdr record)) (= (cdr record) 0)) + ;; Tags: We have lost the information, which tag + ;; corresponds to the lex-env record. If we are + ;; compiling a closure over a tag, we will get an + ;; error later on. + ;; ) + ;; (t + ;; Blocks: Not yet implemented + ))) + (map nil #'handle-record lexenv) + definition)) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index a52157cfcdcf8d551a20fee70409e59719eae028..06565e8c6731734bff2b7f9820529e10251d769f 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -11,7 +11,8 @@ (defun not-a-closure-p (fname) (declare (si::c-local)) - (not (and (fboundp fname) (nth-value 1 (function-lambda-expression (fdefinition fname)))))) + (not (and (fboundp fname) + (nth-value 1 (function-lambda-expression (fdefinition fname)))))) (defun function-form-p (form) (declare (si::c-local)) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index d9ec2820ebece89e67ded1b6b30990d3ec146344..9831e10855e4ab9f5a5d7db90ae278b2a3c8d423 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -6,6 +6,8 @@ *** IN THE INTERPRETER AND COMPILER IN PARTICULAR, IT MAY HURT THE THREADED *** INTERPRETER CODE. ----------------------------------------------------------------------------- */ +#ifndef ECL_BYTECODES_H +#define ECL_BYTECODES_H /* See ecl/src/c/interpreter.d for a detailed explanation of all opcodes. */ enum { @@ -17,12 +19,16 @@ enum { OP_CDR, OP_LIST, OP_LISTA, + OP_CONS_CAR, + OP_CONS_CDR, OP_INT, OP_PINT, OP_VAR, + OP_VARC, OP_VARS, OP_PUSH, OP_PUSHV, + OP_PUSHVC, OP_PUSHVS, OP_PUSHQ, OP_CALLG1, @@ -42,10 +48,13 @@ enum { OP_FLET, OP_LABELS, OP_LFUNCTION, + OP_CFUNCTION, OP_FUNCTION, OP_CLOSE, OP_GO, + OP_GO_CFB, OP_RETURN, + OP_RETURN_CFB, OP_THROW, OP_JMP, OP_JNIL, @@ -61,10 +70,13 @@ enum { OP_PBINDS, OP_VBINDS, OP_SETQ, + OP_SETQC, OP_SETQS, OP_PSETQ, + OP_PSETQC, OP_PSETQS, OP_VSETQ, + OP_VSETQC, OP_VSETQS, OP_BLOCK, OP_DO, @@ -170,12 +182,16 @@ typedef int16_t cl_opcode; &&LBL_OP_CDR - &&LBL_OP_NOP,\ &&LBL_OP_LIST - &&LBL_OP_NOP,\ &&LBL_OP_LISTA - &&LBL_OP_NOP,\ + &&LBL_OP_CONS_CAR - &&LBL_OP_NOP,\ + &&LBL_OP_CONS_CDR - &&LBL_OP_NOP,\ &&LBL_OP_INT - &&LBL_OP_NOP,\ &&LBL_OP_PINT - &&LBL_OP_NOP,\ &&LBL_OP_VAR - &&LBL_OP_NOP,\ + &&LBL_OP_VARC - &&LBL_OP_NOP,\ &&LBL_OP_VARS - &&LBL_OP_NOP,\ &&LBL_OP_PUSH - &&LBL_OP_NOP,\ &&LBL_OP_PUSHV - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHVC - &&LBL_OP_NOP,\ &&LBL_OP_PUSHVS - &&LBL_OP_NOP,\ &&LBL_OP_PUSHQ - &&LBL_OP_NOP,\ &&LBL_OP_CALLG1 - &&LBL_OP_NOP,\ @@ -195,10 +211,13 @@ typedef int16_t cl_opcode; &&LBL_OP_FLET - &&LBL_OP_NOP,\ &&LBL_OP_LABELS - &&LBL_OP_NOP,\ &&LBL_OP_LFUNCTION - &&LBL_OP_NOP,\ + &&LBL_OP_CFUNCTION - &&LBL_OP_NOP,\ &&LBL_OP_FUNCTION - &&LBL_OP_NOP,\ &&LBL_OP_CLOSE - &&LBL_OP_NOP,\ &&LBL_OP_GO - &&LBL_OP_NOP,\ + &&LBL_OP_GO_CFB - &&LBL_OP_NOP,\ &&LBL_OP_RETURN - &&LBL_OP_NOP,\ + &&LBL_OP_RETURN_CFB - &&LBL_OP_NOP,\ &&LBL_OP_THROW - &&LBL_OP_NOP,\ &&LBL_OP_JMP - &&LBL_OP_NOP,\ &&LBL_OP_JNIL - &&LBL_OP_NOP,\ @@ -214,10 +233,13 @@ typedef int16_t cl_opcode; &&LBL_OP_PBINDS - &&LBL_OP_NOP,\ &&LBL_OP_VBINDS - &&LBL_OP_NOP,\ &&LBL_OP_SETQ - &&LBL_OP_NOP,\ + &&LBL_OP_SETQC - &&LBL_OP_NOP,\ &&LBL_OP_SETQS - &&LBL_OP_NOP,\ &&LBL_OP_PSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_PSETQC - &&LBL_OP_NOP,\ &&LBL_OP_PSETQS - &&LBL_OP_NOP,\ &&LBL_OP_VSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_VSETQC - &&LBL_OP_NOP,\ &&LBL_OP_VSETQS - &&LBL_OP_NOP,\ &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ &&LBL_OP_DO - &&LBL_OP_NOP,\ @@ -245,3 +267,5 @@ typedef int16_t cl_opcode; &&LBL_OP_STEPCALL - &&LBL_OP_NOP,\ &&LBL_OP_STEPOUT - &&LBL_OP_NOP }; #endif + +#endif /* ECL_BYTECODES_H */ diff --git a/src/h/external.h b/src/h/external.h index c4af3076fdbe84d94e4758166ed64d5f421c08de..83a4d490302ca6ca93a3821225c8245381f1f107 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -23,11 +23,10 @@ struct cl_env_struct { cl_index nvalues; cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; - /* Environment for calling closures, CLOS generic functions, etc */ + /* -- Invocation of closures, generic function, etc ------------------ */ cl_object function; - - /* Current stack frame */ - cl_object stack_frame; + cl_object stepper; /* Hook invoked by ByteVM */ + cl_object stack_frame; /* Current stack frame */ /* The four stacks in ECL. */ @@ -221,7 +220,6 @@ struct cl_core_struct { cl_object Jan1st1970UT; cl_object system_properties; - cl_object setf_definitions; #ifdef ECL_THREADS cl_object processes; @@ -313,6 +311,7 @@ extern ECL_API cl_object APPLY(cl_narg n, cl_objectfn, cl_object *x); /* array.c */ +extern ECL_API cl_object ecl_make_stack(cl_index dim); extern ECL_API cl_object cl_row_major_aref(cl_object x, cl_object i); extern ECL_API cl_object si_row_major_aset(cl_object x, cl_object i, cl_object v); extern ECL_API cl_object si_make_vector(cl_object etype, cl_object dim, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff); diff --git a/src/h/internal.h b/src/h/internal.h index fe3fb5a1b5576813e2e3c75ed6c42913be1671fe..830e451fceea8017d63814538f751b4d1cc6f298 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -234,10 +234,13 @@ typedef cl_object (*cl_objectfn63)(cl_narg narg, cl_object, cl_object, cl_object /* compiler.d */ +typedef struct cl_compiler_env *cl_compiler_env_ptr; + struct cl_compiler_env { - cl_object variables; /* Variables, tags, functions, etc: the env. */ + cl_object variables; /* the env: vars, tags, funs, etc */ cl_object macros; /* Macros and function bindings */ cl_fixnum lexical_level; /* =0 if toplevel form */ + cl_object captured; /* Captured objects from the parent */ cl_object constants; /* Constants for this form */ cl_object load_time_forms; /* Constants that have to be rebuilt */ cl_object ltf_being_created; /* Load time objects being compiled */ @@ -253,9 +256,29 @@ struct cl_compiler_env { int mode; bool stepping; bool function_boundary_crossed; + cl_compiler_env_ptr parent_env; }; -typedef struct cl_compiler_env *cl_compiler_env_ptr; +enum ecl_cmpref_tag { + ECL_CMPREF_LOCAL, + ECL_CMPREF_CLOSE, + ECL_CMPREF_UNDEFINED, +}; + +enum ecl_cmpvar_tag { + ECL_CMPVAR_UNDEFINED, + ECL_CMPVAR_SYM_MACRO, + ECL_CMPVAR_SPECIAL, + ECL_CMPVAR_LEXICAL, +}; + +struct cl_compiler_ref { + enum ecl_cmpref_tag place; + cl_object entry; /* entry in c_env->variables (if any) */ + cl_fixnum index; /* index in the corresponding location */ + cl_fixnum label; /* index of a label (tagbody specific) */ + cl_object location; /* (cons env-depth env-size) */ +}; /* character.d */ @@ -338,7 +361,7 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form, extern cl_object _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...); extern cl_object _ecl_bclosure_dispatch_vararg(cl_narg narg, ...); -extern cl_object ecl_close_around(cl_object fun, cl_object env); +extern cl_object ecl_close_around(cl_object fun, cl_object env, cl_object flex); /* ffi/backtrace.d */ diff --git a/src/h/object.h b/src/h/object.h index 996f3c5e041b4885be0a64df1ef637f2058350c5..1f9b581a22fbec2eab9bf8d24b9507714618f92a 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -280,6 +280,7 @@ struct ecl_symbol { * of cfun.entry); see below for * more explanation */ cl_object macfun; /* macro expansion function */ + cl_object sfdef; /* global (setf f) definition */ cl_object plist; /* property list */ cl_object name; /* print name */ cl_object cname; /* associated C name for function @@ -771,6 +772,7 @@ struct ecl_bytecodes { cl_index code_size; /* number of bytecodes */ char *code; /* the intermediate language */ cl_object data; /* non-inmediate constants used in the code */ + cl_object flex; /* indexes of captured objects (vector) */ cl_object file; /* file where it was defined... */ cl_object file_position;/* and where it was created */ }; @@ -778,7 +780,7 @@ struct ecl_bytecodes { struct ecl_bclosure { _ECL_HDR; cl_object code; - cl_object lex; + cl_object lex; /* captured objects (flat vector) */ cl_objectfn entry; /* entry address */ }; diff --git a/src/lsp/trace.lsp b/src/lsp/trace.lsp index 0eb3384948463da57bf921ef0de5dc79d7bbcff0..bce22e100d92357ed5ed57ba82c2837d0cd8b73b 100644 --- a/src/lsp/trace.lsp +++ b/src/lsp/trace.lsp @@ -269,6 +269,37 @@ all functions." Finish evaluation without stepping.~%") )) +(defun stepper-enter (form) + (etypecase *step-action* + ((eql t) + (incf *step-level*) + (stepper form)) + ((integer 0) + (incf *step-action*)))) + +(defun stepper-leave (form) + (declare (ignore form)) + (typecase *step-action* + ((eql t) + (decf *step-level*)) + ((integer 1) + (decf *step-action*)) + ((integer 0 0) + (setf *step-action* t)))) + +(defun stepper-call (form) + (if (eq *step-action* t) + (stepper form) + form)) + +(defun stepper-hook (form delta) + (cond + ((= delta +1) + (stepper-enter form)) + ((= delta -1) + (stepper-leave form)) + ((stepper-call form)))) + (defmacro step (form) "Syntax: (step form) Evaluates FORM in the Stepper mode and returns all its values. See ECL Report diff --git a/src/tests/2am.lisp b/src/tests/2am.lisp index 865828f1134fd3c66ab3bc55b670dbcf8fcefc76..28a3449b281cb519c85daeb7dc263d8545bac55a 100644 --- a/src/tests/2am.lisp +++ b/src/tests/2am.lisp @@ -24,7 +24,7 @@ #| to avoid conflict with the library name package 2am-ecl |# (defpackage #:2am-ecl (:use #:cl) - (:export #:test #:test-with-timeout #:is #:signals #:finishes + (:export #:deftest #:test #:test-with-timeout #:is #:signals #:finishes #:run #:suite)) (in-package #:2am-ecl) @@ -152,13 +152,16 @@ (%run fn)) (values))) -(defmacro test (name &body body) +(defmacro deftest (name () &body body) `(progn (defun ,name () (call-test ',name (lambda () ,@body))) (pushnew ',name (gethash *tests* *suites*)) ',name)) +(defmacro test (name &body body) + `(deftest ,name () ,@body)) + (defun kill-processes (process-list &optional original) "Kills a list of processes, which may be the difference between two lists." (let ((process-list (set-difference process-list original))) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 0ee963a99279ea6239db8a9f6b7ea077f6adc9f8..93ae0085ef92de4918b7987d8a13d99bbb95d00f 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -2394,3 +2394,146 @@ (signals type-error (funcall 'foo.0098b :y :bad-arg)) (signals type-error (funcall 'foo.0098b :x nil :y :bad-arg)) (signals type-error (funcall 'foo.0098b :x "" :y :bad-arg))) + +;;; Date 2024-12-17 +;;; Description +;;; +;;; The bytecodes compiler does not enclose FLET/LABELS functions with their +;;; macroexpansion environment, leading to miscompilation in the C later. +;;; +(test cmp.0099.bytecodes-flet-labels-enclose-macrolet + (dolist (op '( flet labels)) + (let* ((form `(lambda () + (macrolet ((plops () 42)) + (,op ((a () (plops))) #'a)))) + (f1 (funcall (ext::bc-compile nil form))) + (f2 (compile nil f1))) + (is (nth-value 1 (function-lambda-expression f1))) + (is (eql (funcall f1) 42)) + (finishes (is (eql (funcall f2) 42)))) + (let* ((form `(lambda () + (symbol-macrolet ((klops 96)) + (,op ((a () klops)) #'a)))) + (f1 (funcall (ext::bc-compile nil form))) + (f2 (compile nil f1))) + (is (nth-value 1 (function-lambda-expression f1))) + (is (eql (funcall f1) 96)) + (finishes (is (eql (funcall f2) 96)))))) + +;;; Date 2024-12-17 +;;; Description +;;; +;;; While writing cmp.0099 and adding LABELS variant I've hit a stack +;;; overflow. This test encodes that particular failure. SET-CLOSURE-ENV +;;; recursively adds the reference to the function leading to the error. In +;;; this test we check whether this pitfall is avoided and whether compiled +;;; LABELS can still reference itself. +;;; +(test cmp.0100.bytecodes-labels-stack-overflow + (let ((fun (labels ((a (n) + (if (zerop n) + 'banzai + (a (1- n))))) + #'a))) + (multiple-value-bind (fun wrn err) + (compile nil fun) + (finishes (is (eql (funcall fun 4) 'banzai))) + (is (null wrn)) + (is (null err))))) + +;;; Date 2024-12-18 +;;; Description +;;; +;;; Test for an uncommited regression in the bytecodes compiler that was +;;; introduced while fixing cmp.0100 where we've made the single label share +;;; bindings among all function closures, or we've restored invalid lexenv, +;;; or that we've miscompiled closure by C compiler. +;;; +(deftest cmp.0101.bytecodes-labels-false-sharing () + (flet ((make (start) + (macrolet ((start-result () 'start)) + (labels ((fun (n) + (if (zerop n) + (start-result) + (1+ (fun (1- n)))))) + #'fun)))) + (let ((f1 (make 3)) + (f2 (make 2))) + (print (= (funcall f1 3) 6)) + (print (= (funcall f2 3) 5)) + (finishes (is (null (nth-value 2 (compile nil f1))))) + (finishes (is (null (nth-value 2 (compile nil f2))))) + (print (= (funcall f1 3) 6)) + (print (= (funcall f2 3) 5))))) + +;;; Date 2024-12-19 +;;; Description +;;; +;;; Make sure that FLET and LABELS do not create a closure when the lexenv +;;; contains only objects that are not referenced. Similar to cmp.0066. +;;; +(test cmp.0102.bytecodes-flat-closure + (let ((fun (let ((b 3)) (flet ((a () 1)) #'a)))) + (is (null (nth-value 1 (function-lambda-expression fun))))) + (let ((fun (let ((b 3)) (labels ((a () 1)) #'a)))) + (is (null (nth-value 1 (function-lambda-expression fun)))))) + +;;; Date 2025-01-16 +;;; Description +;;; +;;; Make sure that MACROLET closes around MACROLET (see #0099). +;;; +(deftest cmp.0103.macrolet-over-macrolet () + (let* ((f0 (macrolet ((foo () `(list 1 2 3))) + (lambda () + (macrolet ((bar () (let ((x (foo))) + `(cons ',x 42)))) + (lambda () (bar)))))) + (f1 (compile nil f0)) + (f2 (ext::bc-compile nil f0))) + (is (equal (funcall (funcall f0)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f1)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f2)) '((1 2 3) . 42))))) + +(deftest cmp.0104.macrolet-over-symbol-macrolet () + (let* ((f0 (macrolet ((foo () `(list 1 2 3))) + (lambda () + (symbol-macrolet ((bar (cons (foo) 42))) + (lambda () bar))))) + (f1 (compile nil f0)) + (f2 (ext::bc-compile nil f0))) + (is (equal (funcall (funcall f0)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f1)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f2)) '((1 2 3) . 42))))) + +(deftest cmp.0105.symbol-macrolet-over-macrolet () + (let* ((f0 (symbol-macrolet ((foo (list 1 2 3))) + (lambda () + (macrolet ((bar () (let ((x foo)) + `(cons ',x 42)))) + (lambda () (bar)))))) + (f1 (compile nil f0)) + (f2 (ext::bc-compile nil f0))) + (is (equal (funcall (funcall f0)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f1)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f2)) '((1 2 3) . 42))))) + +(deftest cmp.0106.symbol-macrolet-over-symbol-macrolet () + (let* ((f0 (symbol-macrolet ((foo (list 1 2 3))) + (lambda () + (symbol-macrolet ((bar (cons foo 42))) + (lambda () bar))))) + (f1 (compile nil f0)) + (f2 (ext::bc-compile nil f0))) + (is (equal (funcall (funcall f0)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f1)) '((1 2 3) . 42))) + (is (equal (funcall (funcall f2)) '((1 2 3) . 42))))) + +;;; When we compile a file it is sometimes not possible to store all definitions +;;; readably. Make sure that the compiler does not error in such cases. +(deftest cmp.0107.unreadable-definition () + (finishes + (with-compiler ("unreadable-definition.lsp") + '(macrolet ((def-it (name) + `(defun test () ,(find-package name)))) + (def-it "COMMON-LISP")))))