mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-30 12:21:02 -08:00
Code Issues Projects Releases Packages Wiki Activity

bytevm: don't use ecl_fdefinition for OP_FUNCTION

Browse source 
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.
This commit is contained in:
Daniel Kochmański 2024-12-12 12:08:30 +01:00
parent 9c1bcd0b7b
commit 1ff274bf08
8 changed files with 73 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

1
src/c/all_symbols.d
View file

@ -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;

1
src/c/alloc_2.d
View file

@ -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));

33
src/c/assignment.d
View file

@ -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)

65
src/c/interpreter.d
View file

@ -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;
}

7
src/c/main.d
View file

@ -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));

2
src/c/symbol.d
View file

@ -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;

1
src/h/external.h
View file

@ -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;

1
src/h/object.h
View file

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