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] 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