From b1aa2e47f3256dad1b88696f0c11441a43078649 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Jan 2025 12:40:45 +0100 Subject: [PATCH 01/23] bytevm: provide function wrappers for all signaled conditions --- src/c/interpreter.d | 148 ++++++++++++++++++++++++++++++-------------- 1 file changed, 103 insertions(+), 45 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2010d3770..ee0aaddbd 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -19,6 +19,92 @@ #include #include +/* -- Errors signaled by the interpreter. ----------------------------------- */ + +static void +VEbad_lambda_arg_excd(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_unk_keyw(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 @@ -96,7 +182,7 @@ ecl_close_around(cl_object fun, cl_object lex) { v->bclosure.entry = fun->bclosure.entry; break; default: - FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0); + VEclose_around_arg_type(); } return v; } @@ -119,34 +205,6 @@ ecl_close_around(cl_object fun, cl_object lex) { 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 @@ -203,7 +261,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) 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; } @@ -219,14 +277,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; } @@ -283,7 +341,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) 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; } @@ -371,11 +429,11 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) SETUP_ENV(the_env); AGAIN: if (ecl_unlikely(reg0 == ECL_NIL)) - FEundefined_function(x); + VEundefined_function(x); switch (ecl_t_of(reg0)) { case t_cfunfixed: if (ecl_unlikely(narg != (cl_index)reg0->cfunfixed.narg)) - FEwrong_num_arguments(reg0); + VEwrong_num_arguments(reg0); reg0 = APPLY_fixed(narg, reg0->cfunfixed.entry_fixed, frame_aux.base); break; @@ -404,12 +462,12 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) reg0 = APPLY(narg, reg0->instance.entry, frame_aux.base); break; default: - FEinvalid_function(reg0); + VEinvalid_function(reg0); } break; case t_symbol: if (ecl_unlikely(!ECL_FBOUNDP(x))) - FEundefined_function(x); + VEundefined_function(x); reg0 = ECL_SYM_FUN(reg0); goto AGAIN; case t_bytecodes: @@ -419,7 +477,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) reg0 = ecl_interpret(frame, reg0->bclosure.lex, reg0->bclosure.code); break; default: - FEinvalid_function(reg0); + VEinvalid_function(reg0); } ECL_STACK_POP_N_UNSAFE(the_env, narg); the_env->stack_frame = NULL; /* for gc's sake */ @@ -446,7 +504,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 +528,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_arg_excd(bytecodes, frame); THREAD_NEXT; } /* OP_POPREST @@ -495,7 +553,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 +589,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } } if (ecl_likely(count && Null(aok))) { - unknown_keyword(bytecodes, frame); + VEbad_lambda_unk_keyw(bytecodes, frame); } } THREAD_NEXT; @@ -718,7 +776,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; @@ -818,7 +876,7 @@ 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; } @@ -1017,7 +1075,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) { -- GitLab From 497ece5a77d7866bff78533e646d425258dee4be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 10 Dec 2024 22:40:39 +0100 Subject: [PATCH 02/23] bytevm: move stepping logic out to trace.lsp We use the environment hook to install the stepper. --- src/c/compiler.d | 9 ++++--- src/c/interpreter.d | 56 ++++++++++++-------------------------------- src/c/symbols_list.h | 2 +- src/h/bytecodes.h | 4 ++++ src/h/external.h | 7 +++--- src/lsp/trace.lsp | 31 ++++++++++++++++++++++++ 6 files changed, 58 insertions(+), 51 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 423215349..7bdaf2a2f 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -676,7 +676,7 @@ c_var_ref(cl_env_ptr env, cl_object var, int allow_symbol_macro, bool ensure_def if (ensure_defined) { 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) @@ -2349,12 +2349,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; @@ -3374,6 +3372,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/interpreter.d b/src/c/interpreter.d index ee0aaddbd..e26461aa8 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -187,6 +187,12 @@ ecl_close_around(cl_object fun, cl_object lex) { return v; } +static inline cl_object +call_stepper(cl_env_ptr the_env, cl_object form, cl_object delta) +{ + return cl_funcall(3, the_env->stepper, form, delta); +} + #define SETUP_ENV(the_env) { ihs.lex_env = lex_env; } /* @@ -197,12 +203,12 @@ 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; } /* -------------------- THE INTERPRETER -------------------- */ @@ -1158,28 +1164,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; @@ -1191,31 +1181,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/symbols_list.h b/src/c/symbols_list.h index dcf51ec94..921ca5715 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/h/bytecodes.h b/src/h/bytecodes.h index d9ec2820e..5a412e48d 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 { @@ -245,3 +247,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 c4af3076f..36799478d 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. */ diff --git a/src/lsp/trace.lsp b/src/lsp/trace.lsp index 0eb338494..bce22e100 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 -- GitLab From 32dfca42e53eacea3af0926494ee10753d231603 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Jan 2025 12:50:50 +0100 Subject: [PATCH 03/23] bytevm: introduce unsafe primops SI:CONS-CAR and SI:CONS-CDR --- src/c/compiler.d | 37 ++++++++++++++++++++++++++++++++----- src/c/disassembler.d | 3 +++ src/c/interpreter.d | 14 +++++++++++++- src/h/bytecodes.h | 4 ++++ 4 files changed, 52 insertions(+), 6 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 7bdaf2a2f..b8247a6a1 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -122,6 +122,8 @@ 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); @@ -296,9 +298,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 +307,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} }; @@ -2703,6 +2705,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 ---------------------------- */ diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 0f4655076..1ee905e6c 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -582,6 +582,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 e26461aa8..48bb5e1d6 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -274,7 +274,6 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) /* 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); @@ -307,6 +306,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); diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 5a412e48d..8a41436d3 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -19,6 +19,8 @@ enum { OP_CDR, OP_LIST, OP_LISTA, + OP_CONS_CAR, + OP_CONS_CDR, OP_INT, OP_PINT, OP_VAR, @@ -172,6 +174,8 @@ 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,\ -- GitLab From 9c1bcd0b7b96829b38004ee983a75bf17ce6ddf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Jan 2025 13:04:38 +0100 Subject: [PATCH 04/23] bytevm: use ecl_apply_from_stack_frame to dispatch calls --- src/c/interpreter.d | 88 +++++---------------------------------------- 1 file changed, 8 insertions(+), 80 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 48bb5e1d6..d1e1eeadb 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -87,18 +87,6 @@ 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() { @@ -190,7 +178,7 @@ ecl_close_around(cl_object fun, cl_object lex) { static inline cl_object call_stepper(cl_env_ptr the_env, cl_object form, cl_object delta) { - return cl_funcall(3, the_env->stepper, form, delta); + return _ecl_funcall3(the_env->stepper, form, delta); } #define SETUP_ENV(the_env) { ihs.lex_env = lex_env; } @@ -403,7 +391,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} @@ -414,7 +403,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} @@ -425,7 +415,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 @@ -435,70 +426,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)) - VEundefined_function(x); - switch (ecl_t_of(reg0)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)reg0->cfunfixed.narg)) - VEwrong_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: - VEinvalid_function(reg0); - } - break; - case t_symbol: - if (ecl_unlikely(!ECL_FBOUNDP(x))) - VEundefined_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: - VEinvalid_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; } -- GitLab From 1ff274bf083f2256e0dc245ff43d31f87810315b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 12 Dec 2024 12:08:30 +0100 Subject: [PATCH 05/23] bytevm: don't use ecl_fdefinition for OP_FUNCTION The function ecl_fdefinition checks also for lamdbas and whatnot, while all we need is a lookup in the global namespace for the function name. This commit also changes how we store SETF function definition -- instead of maintaining them in a global environment, it is stored along with the symbol. That saves us from taking a global lock repeatedly. --- src/c/all_symbols.d | 1 + src/c/alloc_2.d | 1 + src/c/assignment.d | 33 ++++++++--------------- src/c/interpreter.d | 65 ++++++++++++++++++++++++++++++++++++++------- src/c/main.d | 7 ++--- src/c/symbol.d | 2 ++ src/h/external.h | 1 - src/h/object.h | 1 + 8 files changed, 73 insertions(+), 38 deletions(-) diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 4a6fcab4f..aba1f51ef 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 e3c6497ab..c364e5cd6 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)); diff --git a/src/c/assignment.d b/src/c/assignment.d index a19f8a389..1003fcffa 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/interpreter.d b/src/c/interpreter.d index d1e1eeadb..1566bb4f2 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -87,6 +87,18 @@ 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() { @@ -150,6 +162,37 @@ _ecl_bclosure_dispatch_vararg(cl_narg narg, ...) return output; } +/* 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; +} + cl_object ecl_close_around(cl_object fun, cl_object lex) { cl_object v; @@ -604,25 +647,27 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } 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} + + Extracts a local function denoted by the index from the lexical + environment. */ - CASE(OP_LFUNCTION); { /* XXX: local function (fix comment) */ + CASE(OP_LFUNCTION); { int lex_env_index; GET_OPARG(lex_env_index, vector); reg0 = ecl_lex_env_get_fun(lex_env, lex_env_index); THREAD_NEXT; } - /* 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. + /* OP_FUNCTION name{function-name} + + 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; } diff --git a/src/c/main.d b/src/c/main.d index e46c2ec07..8a8be0340 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,7 @@ 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.plist = ECL_NIL; ECL_NIL_SYMBOL->symbol.hpack = ECL_NIL; ECL_NIL_SYMBOL->symbol.stype = ecl_stp_constant; @@ -528,6 +528,7 @@ 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.plist = ECL_NIL; ECL_T->symbol.hpack = ECL_NIL; ECL_T->symbol.stype = ecl_stp_constant; @@ -678,10 +679,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/symbol.d b/src/c/symbol.d index 0cc4e6a21..151a15562 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/h/external.h b/src/h/external.h index 36799478d..b2de0a1ea 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -220,7 +220,6 @@ struct cl_core_struct { cl_object Jan1st1970UT; cl_object system_properties; - cl_object setf_definitions; #ifdef ECL_THREADS cl_object processes; diff --git a/src/h/object.h b/src/h/object.h index 996f3c5e0..737e04b52 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 -- GitLab From 9161bd427e3df170df73f10d16f183b9b02fe963 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 18 Dec 2024 21:23:02 +0100 Subject: [PATCH 06/23] tests: add a regression test for a newly spotted bug in bytecmp --- src/tests/2am.lisp | 7 ++- src/tests/normal-tests/compiler.lsp | 71 +++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+), 2 deletions(-) diff --git a/src/tests/2am.lisp b/src/tests/2am.lisp index 865828f11..28a3449b2 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 0ee963a99..5600caa21 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -2394,3 +2394,74 @@ (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))))) -- GitLab From 85c6599d8d0902eebd9d1083b2062e48403e0771 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 17 Dec 2024 15:06:53 +0100 Subject: [PATCH 07/23] cmp: fix a bug in SET-CLOSURE-ENV wrt self-referncing objects When we were compiling bytecodes with LABELS, the function SET-CLOSURE-ENV exhibited infinite recursion by adding the record as FLET. C.f test "cmp.0100". --- src/cmp/cmpenv-fun.lsp | 92 +++++++++++++++++++++++------------------- 1 file changed, 51 insertions(+), 41 deletions(-) diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index b43be843f..1658c3360 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -175,45 +175,55 @@ 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 - ) + do (cond + ((not (listp record)) + (multiple-value-bind (record-def record-lexenv) + (function-lambda-expression record) + (let* ((self-ref (member 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 + ) finally (return definition))) -- GitLab From 8e44c6322fe5a1e4da603c31fdf4d007d9595fa0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Jan 2025 13:15:05 +0100 Subject: [PATCH 08/23] bytevm: enclose macros over local functions defined with flet/labels This change requires a kludge that addresses an issue with creating shallow copies of the environment. --- src/c/compiler.d | 24 +++++++++++----- src/c/interpreter.d | 69 +++++++++++++++++++++++++++++++++++++-------- 2 files changed, 74 insertions(+), 19 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index b8247a6a1..070815945 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -129,6 +129,9 @@ static cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambd static void FEill_formed_input(void) ecl_attr_noreturn; +static int asm_function(cl_env_ptr env, cl_object args, int flags); +static cl_object create_macro_lexenv(cl_compiler_ptr c_env); + /* -------------------- SAFE LIST HANDLING -------------------- */ static cl_object pop(cl_object *l) { @@ -941,8 +944,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; @@ -1354,12 +1355,14 @@ 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_object macro_lexenv; + cl_index nfun, lex_idx; if (def_list == ECL_NIL) { return c_locally(env, args, flags); @@ -1377,6 +1380,9 @@ c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) { push_back(v, f); } + /* Construct the macro lexenv so we can compile functions in the future. */ + macro_lexenv = create_macro_lexenv(c_env); + /* If compiling a LABELS form, add the function names to the lexical environment before compiling the functions */ if (op == OP_LABELS) @@ -1390,8 +1396,12 @@ 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); + if (!Null(macro_lexenv)) { + /* Add macros to the lexical environment. */ + lambda = ecl_close_around(lambda, macro_lexenv); + } + lex_idx = c_register_constant(env, lambda); + asm_arg(env, lex_idx); } /* If compiling a FLET form, add the function names to the lexical diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1566bb4f2..a4a62948a 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -121,9 +121,9 @@ VEclose_around_arg_type() * macro = ( { si::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) @@ -193,6 +193,57 @@ _ecl_global_function_definition(cl_object name) return fun; } +/* KLUDGE using ecl_append to create closures makes a shallow copy of LEXENV. + That means that LEXENV is _immutable_. This conflicts with the fixup in + OP_LABELS and use of ECL_RPLACA. -- jd 2024-12-18 */ +static cl_object +close_around_self(cl_object fun, cl_object lex) { + cl_object v; + if (Null(lex)) return fun; + switch (ecl_t_of(fun)) { + case t_bytecodes: + v = ecl_alloc_object(t_bclosure); + v->bclosure.code = fun; + v->bclosure.lex = ECL_NIL; + v->bclosure.entry = _ecl_bclosure_dispatch_vararg; + break; + case t_bclosure: + v = ecl_alloc_object(t_bclosure); + v->bclosure.code = fun->bclosure.code; + v->bclosure.lex = fun->bclosure.lex; + v->bclosure.entry = fun->bclosure.entry; + break; + default: + VEclose_around_arg_type(); + } + return v; +} + +static void +labels_fixup(cl_index nfun, cl_object lex_env) +{ + cl_object l = lex_env; + cl_index i = nfun; + /* Augment the environment with new closures. */ + do { + ECL_RPLACA(l, close_around_self(ECL_CONS_CAR(l), lex_env)); + l = ECL_CONS_CDR(l); + } while (--i); + /* Update newly created closures with the augmented environment. */ + l = lex_env; + i = nfun; + do { + cl_object fun = ECL_CONS_CAR(l); + /* Put the predefined macros in fun->bclosure.lex at the end of the lexenv + so that lexenv indices are still valid. Creates a shallow env copy. */ + if (Null(fun->bclosure.lex)) + fun->bclosure.lex = lex_env; + else + fun->bclosure.lex = ecl_append(lex_env, fun->bclosure.lex); + l = ECL_CONS_CDR(l); + } while (--i); +} + cl_object ecl_close_around(cl_object fun, cl_object lex) { cl_object v; @@ -611,7 +662,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) 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); + lex_env = bind_function(lex_env, f); } while (--nfun); THREAD_NEXT; } @@ -634,17 +685,11 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) do { cl_object f; GET_DATA(f, vector, data); - lex_env = bind_function(lex_env, f->bytecodes.name, f); + lex_env = bind_function(lex_env, f); } while (--i); } /* Update the closures so that all functions can call each other */ - { - cl_object l = lex_env; - do { - ECL_RPLACA(l, ecl_close_around(ECL_CONS_CAR(l), lex_env)); - l = ECL_CONS_CDR(l); - } while (--nfun); - } + labels_fixup(nfun, lex_env); THREAD_NEXT; } /* OP_LFUNCTION index{fixnum} -- GitLab From 4e95ee830ad9db5dd2620791477c31a95feb17f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 19 Dec 2024 09:22:34 +0100 Subject: [PATCH 09/23] tests: add a failing test for minimal closures --- src/tests/normal-tests/compiler.lsp | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 5600caa21..d8e30ae93 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -2465,3 +2465,15 @@ (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)))))) -- GitLab From 710ac09e1d1627c1ba67c184b68341b6898912db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Jan 2025 13:32:09 +0100 Subject: [PATCH 10/23] bytecmp: refactor handling object references - split c_tag_ref into three functions c_{tag,blk,fun}_ref, clean c_var_ref small differences between functions made the former harder to read also update comments about the compiler environment functions are refactored to have a similar shape and return the same (internal) structure that denotes the object scope and purpose - don't push special variables as locations in the environment that was (an irrelevant) bug, because special variables are not in the en - rename asm_c to asm_arg_data This name better resembles the purpose of the operator --- src/c/compiler.d | 409 ++++++++++++++++++++++++++++++----------------- src/h/internal.h | 21 ++- 2 files changed, 279 insertions(+), 151 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 070815945..0e82b92fd 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,8 @@ 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); 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); @@ -354,7 +352,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)); } @@ -370,28 +368,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 @@ -411,85 +411,81 @@ 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 c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) { const cl_compiler_ptr c_env = env->c_env; + cl_object entry = c_push_record(c_env, name, @'si::macro', exp_fun); + c_env->variables = CONS(entry, c_env->variables); c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); } 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); + return cl_macroexpand_1(2, stmt, CONS(c_env->variables, c_env->macros)); } static void @@ -539,6 +535,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*'); @@ -554,6 +551,7 @@ 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->parent_env = NULL; new->env_depth = 0; new->macros = CDR(env); new->variables = CAR(env); @@ -587,50 +585,132 @@ 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) +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; + } else { + output.place = ECL_CMPREF_LOCAL; } + output.entry = record; + output.index = n; + output.label = ecl_fixnum(ECL_CONS_CDR(label)); + return output; } n++; - } else if (type == @':block' || type == @':function') { + } 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; + } else { + output.place = ECL_CMPREF_LOCAL; + } + output.entry = record; + output.index = n; + return output; + } + n++; + } 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; + } else { + output.place = ECL_CMPREF_LOCAL; + } + output.entry = record; + output.index = n; + 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; } @@ -638,54 +718,62 @@ 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 = { ECL_CMPREF_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; + /* We can only get here when we try to redefine a symbol macro. */ + if (allow_sym_mac) { + output.place = ECL_CMPREF_SYM_MACRO; + output.entry = record; + output.index = n; + return output; } - FEprogram_error("Internal error: symbol macro ~S used as variable", - 1, var); + 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; + } else { + output.place = ECL_CMPREF_LOCAL; + } + output.entry = record; + output.index = n; + return output; } else { - output = ECL_SPECIAL_VAR_REF; - break; + output.place = ECL_CMPREF_SPECIAL_VAR; + output.entry = record; + output.index = n; + return output; } } - if (ensure_defined) { + if (ensure_def) { l = ecl_cmp_symbol_value(env, @'ext::*action-on-undefined-variable*'); if (l != ECL_NIL) { cl_funcall(3, l, undefined_variable, var); } } - if (function_boundary_crossed && output >= 0) - c_env->function_boundary_crossed = 1; return output; } @@ -699,11 +787,18 @@ 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.place) { + case ECL_CMPREF_LOCAL: + case ECL_CMPREF_CLOSE: + case ECL_CMPREF_UNDEFINED: + case ECL_CMPREF_SYM_MACRO: c_register_var(env, var, TRUE, FALSE); + break; + default: + break; + } } } @@ -788,22 +883,34 @@ 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.place) { + case ECL_CMPREF_SPECIAL_VAR: + case ECL_CMPREF_UNDEFINED: if (ecl_symbol_type(var) & ecl_stp_constant) { FEassignment_to_constant(var); } ndx = c_register_constant(env, var); - if (op == OP_SETQ) + switch(op) { + case OP_SETQ: op = OP_SETQS; - else if (op == OP_PSETQ) + break; + case OP_PSETQ: op = OP_PSETQS; - else if (op == OP_VSETQ) + break; + case OP_VSETQ: op = OP_VSETQS; + break; + default: + ecl_miscompilation_error(); + } + default: + break; } asm_op2(env, op, ndx); } @@ -978,10 +1085,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! */ @@ -1051,7 +1159,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); } @@ -1059,7 +1167,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); @@ -1470,14 +1578,14 @@ create_macro_lexenv(cl_compiler_ptr c_env) 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); + if (ref.place == ECL_CMPREF_UNDEFINED) { /* Globally defined function */ asm_op2c(env, OP_FUNCTION, function); return FLAG_REG0; } else { /* Function from a FLET/LABELS form */ - asm_op2(env, OP_LFUNCTION, ecl_fixnum(ndx)); + asm_op2(env, OP_LFUNCTION, ref.index); return FLAG_REG0; } } @@ -1517,24 +1625,23 @@ asm_function(cl_env_ptr env, cl_object function, int flags) { return FLAG_REG0; } - static int c_go(cl_env_ptr env, cl_object args, int flags) { cl_object tag = pop(&args); 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); + if (ref.place == 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))); + asm_op(env, OP_GO); + asm_arg(env, ref.index); + asm_arg(env, ref.label); return flags; } - /* (if a b) -> (cond (a b)) (if a b c) -> (cond (a b) (t c)) @@ -1734,7 +1841,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 @@ -2015,17 +2122,16 @@ c_psetq(cl_env_ptr env, cl_object old_args, int flags) { tag ; object which names the 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)) + struct cl_compiler_ref ref = c_blk_ref(env, name); + cl_object output = pop_maybe_nil(&args); + if (ref.place == ECL_CMPREF_UNDEFINED) FEprogram_error("RETURN-FROM: Unknown block name ~S.", 1, name); - if (stmt != ECL_NIL) + 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)); + asm_op2(env, OP_RETURN, ref.index); return FLAG_VALUES; } @@ -2311,12 +2417,16 @@ 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 { + switch (ref.place) { + case ECL_CMPREF_LOCAL: + case ECL_CMPREF_CLOSE: + asm_op2(env, push? OP_PUSHV : OP_VAR, ref.index); + break; + default: asm_op2c(env, push? OP_PUSHVS : OP_VARS, stmt); + break; } if (flags & FLAG_VALUES) return (flags & ~FLAG_VALUES) | FLAG_REG0; @@ -2438,6 +2548,7 @@ 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; + new_c_env.parent_env = NULL; new_c_env.env_depth = 0; new_c_env.env_size = 0; env->c_env = &new_c_env; diff --git a/src/h/internal.h b/src/h/internal.h index fe3fb5a1b..6db7d25bc 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -234,8 +234,10 @@ 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 constants; /* Constants for this form */ @@ -253,9 +255,24 @@ 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, + ECL_CMPREF_SYM_MACRO, + ECL_CMPREF_SPECIAL_VAR, +}; + +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 */ -- GitLab From 7637f84629c9fc9a6c0830561b1f523f0aef7141 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Jan 2025 13:32:14 +0100 Subject: [PATCH 11/23] bytecmp: [regression] don't stick macros at the lexenv beginning This commit causes an intentional regression in the bytecodes compiler - we don't carry over macros and symbol macros, so we can't recompile bytecompiled function with the native compiler if they reference them. That will be fixed in a more organized manner after flat closures are in place. --- src/c/compiler.d | 40 -------------------- src/c/interpreter.d | 92 ++++++++++----------------------------------- 2 files changed, 20 insertions(+), 112 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 0e82b92fd..2569d99a5 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -128,7 +128,6 @@ static cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambd static void FEill_formed_input(void) ecl_attr_noreturn; static int asm_function(cl_env_ptr env, cl_object args, int flags); -static cl_object create_macro_lexenv(cl_compiler_ptr c_env); /* -------------------- SAFE LIST HANDLING -------------------- */ static cl_object @@ -1469,7 +1468,6 @@ c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) { cl_object old_funs = c_env->macros; cl_object fnames = ECL_NIL; cl_object v, *f = &fnames; - cl_object macro_lexenv; cl_index nfun, lex_idx; if (def_list == ECL_NIL) { @@ -1488,9 +1486,6 @@ c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) { push_back(v, f); } - /* Construct the macro lexenv so we can compile functions in the future. */ - macro_lexenv = create_macro_lexenv(c_env); - /* If compiling a LABELS form, add the function names to the lexical environment before compiling the functions */ if (op == OP_LABELS) @@ -1504,10 +1499,6 @@ 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); - if (!Null(macro_lexenv)) { - /* Add macros to the lexical environment. */ - lambda = ecl_close_around(lambda, macro_lexenv); - } lex_idx = c_register_constant(env, lambda); asm_arg(env, lex_idx); } @@ -1551,30 +1542,6 @@ 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))) { @@ -1602,15 +1569,8 @@ 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); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index a4a62948a..1e3fba12c 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -107,18 +107,18 @@ VEclose_around_arg_type() /* ------------------------------ 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)) @@ -134,10 +134,11 @@ ecl_lex_env_get_record(cl_object env, int s) } while(1); } -#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_blk(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)) +#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)) /* -------------------- AIDS TO THE INTERPRETER -------------------- */ @@ -193,57 +194,6 @@ _ecl_global_function_definition(cl_object name) return fun; } -/* KLUDGE using ecl_append to create closures makes a shallow copy of LEXENV. - That means that LEXENV is _immutable_. This conflicts with the fixup in - OP_LABELS and use of ECL_RPLACA. -- jd 2024-12-18 */ -static cl_object -close_around_self(cl_object fun, cl_object lex) { - cl_object v; - if (Null(lex)) return fun; - switch (ecl_t_of(fun)) { - case t_bytecodes: - v = ecl_alloc_object(t_bclosure); - v->bclosure.code = fun; - v->bclosure.lex = ECL_NIL; - v->bclosure.entry = _ecl_bclosure_dispatch_vararg; - break; - case t_bclosure: - v = ecl_alloc_object(t_bclosure); - v->bclosure.code = fun->bclosure.code; - v->bclosure.lex = fun->bclosure.lex; - v->bclosure.entry = fun->bclosure.entry; - break; - default: - VEclose_around_arg_type(); - } - return v; -} - -static void -labels_fixup(cl_index nfun, cl_object lex_env) -{ - cl_object l = lex_env; - cl_index i = nfun; - /* Augment the environment with new closures. */ - do { - ECL_RPLACA(l, close_around_self(ECL_CONS_CAR(l), lex_env)); - l = ECL_CONS_CDR(l); - } while (--i); - /* Update newly created closures with the augmented environment. */ - l = lex_env; - i = nfun; - do { - cl_object fun = ECL_CONS_CAR(l); - /* Put the predefined macros in fun->bclosure.lex at the end of the lexenv - so that lexenv indices are still valid. Creates a shallow env copy. */ - if (Null(fun->bclosure.lex)) - fun->bclosure.lex = lex_env; - else - fun->bclosure.lex = ecl_append(lex_env, fun->bclosure.lex); - l = ECL_CONS_CDR(l); - } while (--i); -} - cl_object ecl_close_around(cl_object fun, cl_object lex) { cl_object v; @@ -255,14 +205,6 @@ ecl_close_around(cl_object fun, cl_object lex) { 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; - break; default: VEclose_around_arg_type(); } @@ -689,7 +631,13 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } while (--i); } /* Update the closures so that all functions can call each other */ - labels_fixup(nfun, lex_env); + { + cl_object l = lex_env; + do { + ECL_RPLACA(l, ecl_close_around(ECL_CONS_CAR(l), lex_env)); + l = ECL_CONS_CDR(l); + } while (--nfun); + } THREAD_NEXT; } /* OP_LFUNCTION index{fixnum} @@ -748,7 +696,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) cl_object block_record; GET_OPARG(lex_env_index, vector); /* record = (id . name) */ - block_record = ecl_lex_env_get_record(lex_env, lex_env_index); + block_record = ecl_lex_env_get_blk(lex_env, lex_env_index); the_env->values[0] = reg0; cl_return_from(ECL_CONS_CAR(block_record), ECL_CONS_CDR(block_record)); -- GitLab From 92772b1afd16a9b1d5c69e7e1e470a507a016d8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Jan 2025 16:51:04 +0100 Subject: [PATCH 12/23] bytecmp: implement flat closures This commit replaces capturing whole LEX with an explicit vector of closed variables. We introduce a set of additional opcodes that deal with closed entities. Locals are referred as lcl and closed variables as lex. --- src/c/alloc_2.d | 1 + src/c/compiler.d | 370 ++++++++++++++++++++++++++--------- src/c/interpreter.d | 390 +++++++++++++++++++++++++------------ src/c/printer/write_code.d | 13 +- src/c/read.d | 5 + src/c/serialize.d | 2 + src/cmp/cmpenv-fun.lsp | 13 +- src/cmp/cmppass1-call.lsp | 3 +- src/h/bytecodes.h | 16 ++ src/h/internal.h | 12 +- src/h/object.h | 3 +- 11 files changed, 591 insertions(+), 237 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index c364e5cd6..c52f8f209 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -646,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/compiler.d b/src/c/compiler.d index 2569d99a5..8e2c0527e 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -186,6 +186,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]); } @@ -226,6 +227,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; @@ -360,6 +370,36 @@ 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; +} + +static void +asm_arg_flex(cl_env_ptr env, cl_object o) { + asm_arg(env, c_register_captured(env, o)); +} + /* * Note: the following should match the definitions in cmp/cmpenv.lsp, as * well as CMP-ENV-REGISTER-MACROLET (lsp/defmacro.lsp) @@ -490,41 +530,46 @@ c_macro_expand1(cl_env_ptr env, cl_object stmt) 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 @@ -550,6 +595,7 @@ 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); @@ -584,6 +630,45 @@ 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; } +/* 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) { @@ -609,11 +694,12 @@ c_tag_ref(cl_env_ptr env, cl_object the_tag) 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.index = n; output.label = ecl_fixnum(ECL_CONS_CDR(label)); return output; } @@ -652,11 +738,12 @@ c_blk_ref(cl_env_ptr env, cl_object the_tag) 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.index = n; return output; } n++; @@ -695,11 +782,12 @@ c_fun_ref(cl_env_ptr env, cl_object the_tag) 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.index = n; return output; } n++; @@ -723,7 +811,9 @@ c_var_ref(cl_env_ptr env, cl_object var, bool allow_sym_mac, bool ensure_def) cl_fixnum n = 0; cl_object l, reg; int function_boundary_crossed = 0; - struct cl_compiler_ref output = { ECL_CMPREF_UNDEFINED }; + 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)) { cl_object type, special, record = ECL_CONS_CAR(l); @@ -741,29 +831,37 @@ c_var_ref(cl_env_ptr env, cl_object var, bool allow_sym_mac, bool ensure_def) } 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_sym_mac) { - output.place = ECL_CMPREF_SYM_MACRO; - output.entry = record; - output.index = n; - return output; - } - FEprogram_error("Internal error: symbol macro ~S used as variable", 1, var); } else if (Null(special)) { 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.index = n; + 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.place = ECL_CMPREF_SPECIAL_VAR; + /* 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.index = n; + output.label = ECL_CMPVAR_SPECIAL; return output; } } @@ -776,6 +874,27 @@ c_var_ref(cl_env_ptr env, cl_object var, bool allow_sym_mac, bool ensure_def) 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) { @@ -788,11 +907,10 @@ c_declare_specials(cl_env_ptr env, cl_object specials) while (!Null(specials)) { cl_object var = pop(&specials); struct cl_compiler_ref ref = c_var_ref(env, var, TRUE, FALSE); - switch(ref.place) { - case ECL_CMPREF_LOCAL: - case ECL_CMPREF_CLOSE: - case ECL_CMPREF_UNDEFINED: - case ECL_CMPREF_SYM_MACRO: + 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: @@ -888,27 +1006,16 @@ compile_setq(cl_env_ptr env, int op, cl_object var) FEillegal_variable_name(var); ref = c_var_ref(env, var,FALSE,TRUE); ndx = ref.index; - switch(ref.place) { - case ECL_CMPREF_SPECIAL_VAR: - case ECL_CMPREF_UNDEFINED: + 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); - switch(op) { - case OP_SETQ: - op = OP_SETQS; - break; - case OP_PSETQ: - op = OP_PSETQS; - break; - case OP_VSETQ: - op = OP_VSETQS; - break; - default: - ecl_miscompilation_error(); - } + /* fall through */ default: + op = c_var_ref_fix_op(ref, op); break; } asm_op2(env, op, ndx); @@ -1546,14 +1653,21 @@ 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))) { struct cl_compiler_ref ref = c_fun_ref(env, function); - if (ref.place == ECL_CMPREF_UNDEFINED) { + 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, 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)) { @@ -1575,30 +1689,41 @@ asm_function(cl_env_ptr env, cl_object function, int flags) { /* 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; } struct cl_compiler_ref ref = c_tag_ref(env, tag); - if (ref.place == ECL_CMPREF_UNDEFINED) + 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_op(env, OP_GO); - asm_arg(env, ref.index); - asm_arg(env, ref.label); + 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; } @@ -2074,24 +2199,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 args, int flags) { struct cl_compiler_ref ref = c_blk_ref(env, name); cl_object output = pop_maybe_nil(&args); - if (ref.place == ECL_CMPREF_UNDEFINED) - FEprogram_error("RETURN-FROM: Unknown block name ~S.", 1, name); if (!Null(args)) FEprogram_error("RETURN-FROM: Too many arguments.", 0); - compile_form(env, output, FLAG_VALUES); - asm_op2(env, OP_RETURN, ref.index); + 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; } @@ -2379,14 +2513,17 @@ compile_symbol(cl_env_ptr env, cl_object stmt, int flags) } else { struct cl_compiler_ref ref = c_var_ref(env, stmt, FALSE, FALSE); bool push = flags & FLAG_PUSH; - switch (ref.place) { - case ECL_CMPREF_LOCAL: - case ECL_CMPREF_CLOSE: - asm_op2(env, push? OP_PUSHV : OP_VAR, ref.index); + 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; - default: - asm_op2c(env, push? OP_PUSHVS : OP_VARS, stmt); + 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; @@ -2508,6 +2645,13 @@ 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; @@ -2911,11 +3055,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: @@ -3246,16 +3392,20 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { 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]; @@ -3347,15 +3497,41 @@ 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, entry, flex; + 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; + 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); } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1e3fba12c..9785696c7 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -126,7 +126,7 @@ VEclose_around_arg_type() #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); @@ -134,12 +134,41 @@ ecl_lex_env_get_record(cl_object env, int s) } while(1); } +#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_record(env,x) env[x] #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_CONS_CAR(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)) +/* -- Lexenv operators --------------------------------------------------- */ + +static cl_object +make_lex(cl_index n) +{ + return si_make_vector(ECL_T, ecl_make_fixnum(n), + ECL_T, ecl_make_fixnum(0), + ECL_NIL, ECL_NIL); +} + +static void +push_lex(cl_object stack, cl_object new) +{ + cl_vector_push_extend(2, new, stack); +} + +static cl_object * +data_lex(cl_object stack) +{ + return stack->vector.self.t; +} + /* -------------------- AIDS TO THE INTERPRETER -------------------- */ cl_object @@ -194,20 +223,74 @@ _ecl_global_function_definition(cl_object name) return fun; } -cl_object -ecl_close_around(cl_object fun, cl_object lex) { - cl_object v; - if (Null(lex)) return fun; - switch (ecl_t_of(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; + 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: + template = fun->bclosure.code->bytecodes.flex; + /* Close around */ + nlex = template->vector.dim; + new_lex = make_lex(nlex); + for (idx = 0; idxvector.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: 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; + 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]); + 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; } @@ -217,7 +300,7 @@ 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 = lex_env; } +#define SETUP_ENV(the_env) { ihs.lex_env = closure; } /* * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted @@ -238,14 +321,15 @@ call_stepper(cl_env_ptr the_env, cl_object form, cl_object delta) /* -------------------- 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 = Null(closure) ? NULL : data_lex(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; @@ -253,7 +337,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; @@ -271,21 +355,23 @@ 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); @@ -364,20 +450,23 @@ 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); @@ -387,9 +476,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) 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; @@ -474,7 +562,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); @@ -594,18 +682,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); - } while (--nfun); + /* Create closures. */ + for(idx = 0; idxvalues[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; + } + CASE(OP_RETURN_CFB); { + int ndx; + cl_object record; + GET_OPARG(ndx, vector); + /* record = (id . name) */ + record = ecl_lex_env_get_blk(lex_env, ndx); + the_env->values[0] = reg0; + cl_return_from(ECL_CONS_CAR(record), ECL_CONS_CDR(record)); THREAD_NEXT; } /* OP_THROW @@ -773,7 +895,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} @@ -798,13 +920,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); { @@ -812,7 +934,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; } @@ -837,22 +959,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[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. */ 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); { @@ -865,10 +997,15 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) 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); { @@ -879,12 +1016,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); { @@ -910,24 +1062,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) { @@ -935,7 +1087,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; } } @@ -955,18 +1107,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; } @@ -979,7 +1129,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); { @@ -1083,13 +1233,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; @@ -1100,7 +1250,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; } diff --git a/src/c/printer/write_code.d b/src/c/printer/write_code.d index 5abf46ec1..160a377d9 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 31dace2bc..4fba0b93b 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 650fb268c..44ecfe1f4 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/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index 1658c3360..3fb421e49 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -174,16 +174,16 @@ "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 + (flet ((handle-record (record) + (cond ((not (listp record)) (multiple-value-bind (record-def record-lexenv) (function-lambda-expression record) - (let* ((self-ref (member record record-lexenv)) + (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))) + (setf record-def (cdr record-def))) (EXT:LAMBDA-BLOCK (setf record-def (cddr record-def))) (otherwise @@ -225,5 +225,6 @@ the closure in let/flet forms for variables/functions it closes over." ;; ) ;; (t ;; Blocks: Not yet implemented - ) - finally (return definition))) + ))) + (map nil #'handle-record lexenv) + definition)) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index a52157cfc..06565e8c6 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 8a41436d3..9831e1085 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -24,9 +24,11 @@ enum { OP_INT, OP_PINT, OP_VAR, + OP_VARC, OP_VARS, OP_PUSH, OP_PUSHV, + OP_PUSHVC, OP_PUSHVS, OP_PUSHQ, OP_CALLG1, @@ -46,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, @@ -65,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, @@ -179,9 +187,11 @@ typedef int16_t cl_opcode; &&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,\ @@ -201,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,\ @@ -220,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,\ diff --git a/src/h/internal.h b/src/h/internal.h index 6db7d25bc..cc347c042 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -240,6 +240,7 @@ struct cl_compiler_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 */ @@ -262,8 +263,13 @@ enum ecl_cmpref_tag { ECL_CMPREF_LOCAL, ECL_CMPREF_CLOSE, ECL_CMPREF_UNDEFINED, - ECL_CMPREF_SYM_MACRO, - ECL_CMPREF_SPECIAL_VAR, +}; + +enum ecl_cmpvar_tag { + ECL_CMPVAR_UNDEFINED, + ECL_CMPVAR_SYM_MACRO, + ECL_CMPVAR_SPECIAL, + ECL_CMPVAR_LEXICAL, }; struct cl_compiler_ref { @@ -355,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 737e04b52..1f9b581a2 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -772,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 */ }; @@ -779,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 */ }; -- GitLab From 0fb64f5c917a0787ba02c305dedc51356e15840a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Jan 2025 10:34:24 +0100 Subject: [PATCH 13/23] bytecmp: [degression] insert CFB local macros in the lexenv This is necessary if we want to recompile bytecodes either with CCMP or BCMP. --- src/c/compiler.d | 95 ++++++++++++++++++++++++++++++++++++++++++--- src/c/interpreter.d | 14 ++++++- 2 files changed, 101 insertions(+), 8 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 8e2c0527e..1f6a7975a 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -66,6 +66,9 @@ static void asm_complete(cl_env_ptr env, int op, cl_index original); 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); static int c_catch(cl_env_ptr env, cl_object args, int flags); @@ -507,8 +510,6 @@ static void c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) { const cl_compiler_ptr c_env = env->c_env; - cl_object entry = c_push_record(c_env, name, @'si::macro', exp_fun); - c_env->variables = CONS(entry, c_env->variables); c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); } @@ -524,6 +525,14 @@ static cl_object c_macro_expand1(cl_env_ptr env, cl_object stmt) { const cl_compiler_ptr c_env = env->c_env; + 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)); } @@ -630,6 +639,65 @@ 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; } +/* 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. */ +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' && function_boundary_crossed) { + c_env->function_boundary_crossed = 1; + c_register_captured(env, record); + } + 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); + } + 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 @@ -1891,9 +1959,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) @@ -3386,6 +3453,17 @@ 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_object record) { + cl_object arg1 = pop(&record); + cl_object arg2 = pop(&record); + cl_object arg3 = pop(&record); + if (arg2 == @'si::macro' || arg2 == @'si::symbol-macro') + 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; @@ -3506,7 +3584,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { /* Process closed over entries. */ if (new_c_env->function_boundary_crossed) { - cl_object p = new_c_env->captured, entry, flex; + cl_object p = new_c_env->captured, flex, entry, macro_entry; struct cl_compiler_ref ref; int i, n, index; n = p->vector.fillp; @@ -3516,6 +3594,11 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { 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(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: diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 9785696c7..3ad0d78e9 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -243,7 +243,7 @@ close_around_self(cl_object fun) { static void close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object *lex_env) { - cl_object new_lex, template; + cl_object new_lex, template, entry; cl_fixnum nlex, idx, ndx; switch(ecl_t_of(fun)) { case t_bytecodes: @@ -254,6 +254,11 @@ close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object *lex_env) { 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)) @@ -270,7 +275,7 @@ close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object *lex_env) { cl_object ecl_close_around(cl_object fun, cl_object lcl_env, cl_object *lex_env) { - cl_object v, new_lex, template; + cl_object v, new_lex, template, entry; cl_fixnum nlex, idx, ndx; if(ecl_t_of(fun) != t_bytecodes) VEclose_around_arg_type(); @@ -280,6 +285,11 @@ ecl_close_around(cl_object fun, cl_object lcl_env, cl_object *lex_env) { 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)) -- GitLab From f56b2b91929f2c6f0d9ab1d61ece619ff70a1a4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Jan 2025 13:38:23 +0100 Subject: [PATCH 14/23] tests: add tests for local macros closing over each other --- src/tests/normal-tests/compiler.lsp | 51 +++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index d8e30ae93..4bc2f1d90 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -2477,3 +2477,54 @@ (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))))) -- GitLab From c9c532357894e8e9a39fc51cd438db9523cb4f2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 19 Mar 2025 09:44:01 +0100 Subject: [PATCH 15/23] tests: add a test for an important corner case In case that someone wants to store the definition when compiling the file, we need to make sure that the compiler does not error if it has unreadable objects. --- src/tests/normal-tests/compiler.lsp | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 4bc2f1d90..93ae0085e 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -2528,3 +2528,12 @@ (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"))))) -- GitLab From 77fe30efddcc527fe255141ba35866340563eee1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Jan 2025 13:26:58 +0100 Subject: [PATCH 16/23] bytecmp: ensure that we close around referenced local macros This is necessary to recompile bytecodes when they contain macro expansions. --- src/c/compiler.d | 53 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 45 insertions(+), 8 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 1f6a7975a..3ab16d177 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -643,6 +643,24 @@ c_restore_env(cl_env_ptr the_env, cl_compiler_env_ptr new_c_env, cl_compiler_env 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) { @@ -659,9 +677,17 @@ c_sym_ref(cl_env_ptr env, cl_object name) type = pop(®); other = pop(®); if (type == name) { - if (other == @'si::symbol-macro' && function_boundary_crossed) { - c_env->function_boundary_crossed = 1; - c_register_captured(env, record); + 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; } @@ -691,6 +717,12 @@ c_mac_ref(cl_env_ptr env, cl_object name) 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; } @@ -729,7 +761,7 @@ c_any_ref(cl_env_ptr env, cl_object entry) output.entry = record; return output; } - if (type == @':block' || type == @':function'||type == @':tag' + if (type == @':block' || type == @':function'|| type == @':tag' || Null(other)) { n++; } @@ -3454,14 +3486,19 @@ c_default(cl_env_ptr env, cl_object var, cl_object stmt, cl_object flag, cl_obje } static cl_object -fix_macro_to_lexenv(cl_object record) { +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' || arg2 == @'si::symbol-macro') + if (arg2 == @'si::macro') { + c_mac_ref(env, arg1); return CONS(arg2, CONS(arg3, arg1)); - else + } else if (arg2 == @'si::symbol-macro') { + c_sym_ref(env, arg1); + return CONS(arg2, CONS(arg3, arg1)); + } else { return ECL_NIL; + } } cl_object @@ -3594,7 +3631,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { 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(entry); + macro_entry = fix_macro_to_lexenv(env, entry); if(!Null(macro_entry)) { flex->vector.self.t[i] = macro_entry; continue; -- GitLab From 90e7a8e560dd23ed27b55d4101da4e39e9681f46 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Mar 2025 21:42:39 +0100 Subject: [PATCH 17/23] bytevm: change error names to be more descriptive VEbad_lambda_arg_excd -> VEbad_lambda_too_many_args VEbad_lambda_unk_keyw -> VEbad_lambda_unknown_keyword --- src/c/interpreter.d | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 3ad0d78e9..ec68350d9 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -22,7 +22,7 @@ /* -- Errors signaled by the interpreter. ----------------------------------- */ static void -VEbad_lambda_arg_excd(cl_object bytecodes, cl_object frame) +VEbad_lambda_too_many_args(cl_object bytecodes, cl_object frame) { FEprogram_error("Too many arguments passed to " "function ~A~&Argument list: ~S", @@ -30,7 +30,7 @@ VEbad_lambda_arg_excd(cl_object bytecodes, cl_object frame) } static void -VEbad_lambda_unk_keyw(cl_object bytecodes, cl_object frame) +VEbad_lambda_unknown_keyword(cl_object bytecodes, cl_object frame) { FEprogram_error("Unknown keyword argument passed to function ~S.~&" "Argument list: ~S", 2, bytecodes, @@ -608,7 +608,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_NOMORE); { if (ecl_unlikely(frame_index < frame->frame.size)) - VEbad_lambda_arg_excd(bytecodes, frame); + VEbad_lambda_too_many_args(bytecodes, frame); THREAD_NEXT; } /* OP_POPREST @@ -669,7 +669,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) } } if (ecl_likely(count && Null(aok))) { - VEbad_lambda_unk_keyw(bytecodes, frame); + VEbad_lambda_unknown_keyword(bytecodes, frame); } } THREAD_NEXT; -- GitLab From 479400f6fbe462275002204b4dd7b9dc51dd4686 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Mar 2025 22:07:02 +0100 Subject: [PATCH 18/23] disassembler: add newly added opcodes to bytecodes disassembler --- src/c/disassembler.d | 102 ++++++++++++++++++++++++++++++++----------- src/c/interpreter.d | 6 +-- 2 files changed, 80 insertions(+), 28 deletions(-) diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 1ee905e6c..e996b6b8c 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); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index ec68350d9..fdb5e53a6 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -981,9 +981,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) 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[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. + 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 ndx; -- GitLab From 99b37c8ab592abe05f3846613be709a17bf83074 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Mar 2025 23:02:31 +0100 Subject: [PATCH 19/23] boot: initialize macfun of ECL_T and ECL_NIL_SYMBOL to ECL_NIL Prevoiusly this slot was left uninitialized and that lead to a segmentation fault under certain conditions when we did (copy-symbol t t). --- src/c/main.d | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/c/main.d b/src/c/main.d index 8a8be0340..e7b48ec53 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -514,6 +514,7 @@ cl_boot(int argc, char **argv) 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; @@ -529,6 +530,7 @@ cl_boot(int argc, char **argv) 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; -- GitLab From bd5e72def6d8601655d26b462851848135b69e32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 20 Mar 2025 20:58:55 +0100 Subject: [PATCH 20/23] lexenv: don't use adjustable vector -- lexenv size is known --- src/c/interpreter.d | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index fdb5e53a6..00547a74b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -152,15 +152,14 @@ ecl_lcl_env_get_record(cl_object env, int s) static cl_object make_lex(cl_index n) { - return si_make_vector(ECL_T, ecl_make_fixnum(n), - ECL_T, ecl_make_fixnum(0), - ECL_NIL, ECL_NIL); + 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_extend(2, new, stack); + cl_vector_push(new, stack); } static cl_object * -- GitLab From 75dcfaf70569c3e57563b5c5671be71296a25a14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 20 Mar 2025 21:53:26 +0100 Subject: [PATCH 21/23] lexenv: don't bypass referencing the cl_object instance This is a preliminary step towards consistent access between LCL and LEX envs. --- src/c/interpreter.d | 21 ++++++++++----------- src/h/internal.h | 2 +- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 00547a74b..bf435a268 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -134,20 +134,25 @@ ecl_lcl_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_record(env,x) env[x] #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)) -/* -- Lexenv operators --------------------------------------------------- */ +/* -- Lexical and local env operators ------------------------------------------ */ static cl_object make_lex(cl_index n) @@ -162,12 +167,6 @@ push_lex(cl_object stack, cl_object new) cl_vector_push(new, stack); } -static cl_object * -data_lex(cl_object stack) -{ - return stack->vector.self.t; -} - /* -------------------- AIDS TO THE INTERPRETER -------------------- */ cl_object @@ -241,7 +240,7 @@ close_around_self(cl_object fun) { } static void -close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object *lex_env) { +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)) { @@ -273,7 +272,7 @@ close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object *lex_env) { cl_object -ecl_close_around(cl_object fun, cl_object lcl_env, cl_object *lex_env) { +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) @@ -337,7 +336,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) 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 *lex_env = Null(closure) ? NULL : data_lex(closure); + 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; diff --git a/src/h/internal.h b/src/h/internal.h index cc347c042..830e451fc 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -361,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, cl_object *flex); +extern cl_object ecl_close_around(cl_object fun, cl_object env, cl_object flex); /* ffi/backtrace.d */ -- GitLab From eb6a64def9e96f10fc2f7d4505fb6173f37f0039 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 21 Mar 2025 13:34:00 +0100 Subject: [PATCH 22/23] lexenv: remove unused function from the compiler --- src/c/compiler.d | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 3ab16d177..a30ca3e82 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -398,11 +398,6 @@ c_register_captured(cl_env_ptr env, cl_object c) return (n < 0) ? asm_captured(env, c) : n; } -static void -asm_arg_flex(cl_env_ptr env, cl_object o) { - asm_arg(env, c_register_captured(env, o)); -} - /* * Note: the following should match the definitions in cmp/cmpenv.lsp, as * well as CMP-ENV-REGISTER-MACROLET (lsp/defmacro.lsp) -- GitLab From 63a106b4cb05d9206c51351ceb4e045ac55f37ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 26 Mar 2025 10:27:59 +0100 Subject: [PATCH 23/23] bytevm: add a new low-level operator ecl_make_stack The stack is represented as an actually adjustable vector with a fill pointer. The main difference from other vector constructors is that it does not modify the process env -- most notably VALUES vector -- and can be safely used in the interpreter. --- src/c/array.d | 15 +++++++++++++++ src/h/external.h | 1 + 2 files changed, 16 insertions(+) diff --git a/src/c/array.d b/src/c/array.d index 89d7d022a..2b1e586ab 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/h/external.h b/src/h/external.h index b2de0a1ea..83a4d4903 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -311,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); -- GitLab