From 52e62805dd7ed086cadff24a6e92373df11448d1 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 22 Jul 2023 20:47:30 +0200 Subject: [PATCH 1/7] remove ECL_SAFE option This is inconsistently implemented in that only very few places actually check for proper lists. Moreover, it slows down code that uses those functions a lot. --- src/c/symbol.d | 9 --------- src/h/config-internal.h.in | 3 --- 2 files changed, 12 deletions(-) diff --git a/src/c/symbol.d b/src/c/symbol.d index 79e3cdff0..b3c9e79fa 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -171,9 +171,6 @@ ecl_getf(cl_object place, cl_object indicator, cl_object deflt) { cl_object l; -#ifdef ECL_SAFE - assert_type_proper_list(place); -#endif for (l = place; CONSP(l); ) { cl_object cdr_l = ECL_CONS_CDR(l); if (!CONSP(cdr_l)) @@ -203,9 +200,6 @@ si_put_f(cl_object place, cl_object value, cl_object indicator) { cl_object l; -#ifdef ECL_SAFE - assert_type_proper_list(place); -#endif /* This loop guarantees finishing for circular lists */ for (l = place; CONSP(l); ) { cl_object cdr_l = ECL_CONS_CDR(l); @@ -295,9 +289,6 @@ cl_get_properties(cl_object place, cl_object indicator_list) const cl_env_ptr the_env = ecl_process_env(); cl_object l; -#ifdef ECL_SAFE - assert_type_proper_list(place); -#endif for (l = place; CONSP(l); ) { cl_object cdr_l = ECL_CONS_CDR(l); if (!CONSP(cdr_l)) diff --git a/src/h/config-internal.h.in b/src/h/config-internal.h.in index 7a6228fb9..e7fcdd59b 100644 --- a/src/h/config-internal.h.in +++ b/src/h/config-internal.h.in @@ -28,9 +28,6 @@ /* Allow loading dynamically linked code */ #undef ENABLE_DLOPEN -/* Undefine this if you do not want ECL to check for circular lists */ -#define ECL_SAFE - /* Activate Boehm-Weiser incremental garbage collector */ #undef GBC_BOEHM_GENGC From d437bd0779701db65791a4045d8dee4fcf0febfe Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 22 Jul 2023 22:10:13 +0200 Subject: [PATCH 2/7] speed up looking up and setting values of dynamic variables Introduce ecl_cmp_symbol_value and ecl_cmp_setq which do the minimal amount of work needed to implement symbol-value and setq for dynamic variables which we have checked to be non-null and of type symbol in the compiler. Also introduce a type check in ecl_symbol_value to be consistent with ecl_setq which also checks the type. These two functions are mainly used for the embedding interface now, so for that reason it is also useful to have a type check in there. --- src/c/assignment.d | 35 ++++++++++------- src/c/compiler.d | 4 +- src/c/format.d | 2 +- src/c/load.d | 14 +++---- src/c/macros.d | 2 +- src/c/num_rand.d | 2 +- src/c/package.d | 4 +- src/c/pathname.d | 4 +- src/c/print.d | 50 +++++++++++++------------ src/c/printer/write_object.d | 17 +++++---- src/c/read.d | 2 +- src/c/symbol.d | 29 +++++++++----- src/c/threads/barrier.d | 4 +- src/c/threads/process.d | 2 +- src/c/threads/semaphore.d | 4 +- src/cmp/cmpbackend-cxx/cmppass2-var.lsp | 6 +-- src/h/external.h | 2 + 17 files changed, 105 insertions(+), 78 deletions(-) diff --git a/src/c/assignment.d b/src/c/assignment.d index e18633cbf..81aa4817d 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -34,10 +34,31 @@ cl_set(cl_object var, cl_object value) unlikely_if (ecl_t_of(var) != t_symbol) { FEwrong_type_nth_arg(@[set], 1, var, @[symbol]); } + ecl_return1(env, ecl_cmp_setq(env, var, value)); +} + +cl_object +ecl_setq(cl_env_ptr env, cl_object var, cl_object value) +{ + unlikely_if (Null(var)) { + FEconstant_assignment(var); + } + unlikely_if (ecl_t_of(var) != t_symbol) { + FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); + } + return ecl_cmp_setq(env, var, value); +} + +/* ecl_cmp_setq does the minimal amount of checking necessary to + * implement SETQ for objects that have been checked to be non-null + * symbols by the compiler. */ +cl_object +ecl_cmp_setq(cl_env_ptr env, cl_object var, cl_object value) +{ unlikely_if (var->symbol.stype & ecl_stp_constant) { FEconstant_assignment(var); } - ecl_return1(env, ECL_SETQ(env, var, value)); + return ECL_SETQ(env, var, value); } #ifdef ECL_THREADS @@ -72,18 +93,6 @@ mp_atomic_incf_symbol_value(cl_object var, cl_object increment) } #endif /* ECL_THREADS */ -cl_object -ecl_setq(cl_env_ptr env, cl_object var, cl_object value) -{ - unlikely_if (Null(var)) { - FEconstant_assignment(var); - } - unlikely_if (ecl_t_of(var) != t_symbol) { - FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); - } - return ECL_SETQ(env, var, value); -} - static cl_object unbound_setf_function_error(cl_narg narg, ...) { diff --git a/src/c/compiler.d b/src/c/compiler.d index 93f665b19..c7004553d 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -680,7 +680,7 @@ c_var_ref(cl_env_ptr env, cl_object var, int allow_symbol_macro, bool ensure_def } } if (ensure_defined) { - l = ecl_symbol_value(@'ext::*action-on-undefined-variable*'); + l = ecl_cmp_symbol_value(env, @'ext::*action-on-undefined-variable*'); if (l != ECL_NIL) { funcall(3, l, undefined_variable, var); } @@ -3241,7 +3241,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { c_undo_bindings(env, old_c_env->variables, 1); asm_op(env, OP_EXIT); - if (Null(ecl_symbol_value(@'si::*keep-definitions*'))) + if (Null(ecl_cmp_symbol_value(env, @'si::*keep-definitions*'))) lambda = ECL_NIL; output = asm_end(env, handle, lambda); output->bytecodes.name = name; diff --git a/src/c/format.d b/src/c/format.d index 013a3f0c8..9dc5aff56 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -2194,7 +2194,7 @@ format(format_stack fmt, cl_index start, cl_index end) #endif null_strm = 1; } else if (strm == ECL_T) { - strm = ecl_symbol_value(@'*standard-output*'); + strm = ecl_cmp_symbol_value(the_env, @'*standard-output*'); } if (ecl_stringp(strm)) { output = strm; diff --git a/src/c/load.d b/src/c/load.d index 88e08fb56..3b5efe069 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -45,7 +45,7 @@ si_load_binary(cl_object filename, cl_object verbose, goto GO_ON; /* Next try to call "init_FILE()" where FILE is the file name */ - prefix = ecl_symbol_value(@'si::*init-function-prefix*'); + prefix = ecl_cmp_symbol_value(the_env, @'si::*init-function-prefix*'); init_prefix = _ecl_library_init_prefix(); if (Null(prefix)) { prefix = init_prefix; @@ -200,11 +200,11 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec } @(defun load (source - &key (verbose ecl_symbol_value(@'*load-verbose*')) - (print ecl_symbol_value(@'*load-print*')) + &key (verbose ecl_cmp_symbol_value(the_env, @'*load-verbose*')) + (print ecl_cmp_symbol_value(the_env, @'*load-print*')) (if_does_not_exist @':error') (external_format @':default') - (search_list ecl_symbol_value(@'si::*load-search-list*')) + (search_list ecl_cmp_symbol_value(the_env, @'si::*load-search-list*')) &aux pathname pntype hooks filename function ok file_kind) bool not_a_filename = 0; @ @@ -222,7 +222,7 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec pntype = pathname->pathname.type; filename = ECL_NIL; - hooks = ecl_symbol_value(@'ext::*load-hooks*'); + hooks = ecl_cmp_symbol_value(the_env, @'ext::*load-hooks*'); if (Null(pathname->pathname.directory) && Null(pathname->pathname.host) && Null(pathname->pathname.device) && @@ -284,8 +284,8 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec cl_format(3, ECL_T, @"~&;;; Loading ~s~%", filename); } - ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*')); - ecl_bds_bind(the_env, @'*readtable*', ecl_symbol_value(@'*readtable*')); + ecl_bds_bind(the_env, @'*package*', ecl_cmp_symbol_value(the_env, @'*package*')); + ecl_bds_bind(the_env, @'*readtable*', ecl_cmp_symbol_value(the_env, @'*readtable*')); ecl_bds_bind(the_env, @'*load-pathname*', not_a_filename? ECL_NIL : source); ecl_bds_bind(the_env, @'*load-truename*', not_a_filename? ECL_NIL : (filename = cl_truename(filename))); diff --git a/src/c/macros.d b/src/c/macros.d index e9ce12677..de1d49280 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -102,7 +102,7 @@ search_macro_function(cl_object name, cl_object env) exp_fun = search_macro_function(head, env); } if (!Null(exp_fun)) { - cl_object hook = ecl_symbol_value(@'*macroexpand-hook*'); + cl_object hook = ecl_cmp_symbol_value(the_env, @'*macroexpand-hook*'); if (hook == @'funcall') form = _ecl_funcall3(exp_fun, form, env); else diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 5da8db4cb..afb2b3ee6 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -320,7 +320,7 @@ ecl_make_random_state(cl_object rs) return z; } -@(defun random (x &optional (rs ecl_symbol_value(@'*random-state*'))) +@(defun random (x &optional (rs ecl_cmp_symbol_value(the_env, @'*random-state*'))) @ rs = ecl_check_cl_type(@'random', rs, t_random); @(return rando(x, rs)); diff --git a/src/c/package.d b/src/c/package.d index aa00c51b4..e6d6e3238 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -378,9 +378,9 @@ si_coerce_to_package(cl_object p) cl_object ecl_current_package(void) { - cl_object x = ecl_symbol_value(@'*package*'); + const cl_env_ptr env = ecl_process_env(); + cl_object x = ecl_cmp_symbol_value(env, @'*package*'); unlikely_if (!ECL_PACKAGEP(x)) { - const cl_env_ptr env = ecl_process_env(); ECL_SETQ(env, @'*package*', cl_core.user_package); FEerror("The value of *PACKAGE*, ~S, was not a package", 1, x); diff --git a/src/c/pathname.d b/src/c/pathname.d index efeca5cab..3f1c93a66 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -724,9 +724,9 @@ si_default_pathname_defaults(void) * coerced to type PATHNAME. Special care is taken so that we do * not enter an infinite loop when using PARSE-NAMESTRING, because * this routine might itself try to use the value of this variable. */ - cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object path = ecl_cmp_symbol_value(the_env, @'*default-pathname-defaults*'); unlikely_if (!ECL_PATHNAMEP(path)) { - const cl_env_ptr the_env = ecl_process_env(); ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*], path, @'pathname'); diff --git a/src/c/print.d b/src/c/print.d index db60fed08..1b2464f22 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -29,10 +29,11 @@ _ecl_stream_or_default_output(cl_object stream) int ecl_print_base(void) { - cl_object object = ecl_symbol_value(@'*print-base*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object object = ecl_cmp_symbol_value(the_env, @'*print-base*'); cl_fixnum base; unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { - ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); + ECL_SETQ(the_env, @'*print-base*', ecl_make_fixnum(10)); FEerror("The value of *PRINT-BASE*~% ~S~%" "is not of the expected type (INTEGER 2 36)", 1, object); } @@ -42,14 +43,15 @@ ecl_print_base(void) cl_fixnum ecl_print_level(void) { - cl_object object = ecl_symbol_value(@'*print-level*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object object = ecl_cmp_symbol_value(the_env, @'*print-level*'); cl_fixnum level; if (object == ECL_NIL) { level = MOST_POSITIVE_FIXNUM; } else if (ECL_FIXNUMP(object)) { level = ecl_fixnum(object); if (level < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); + ERROR: ECL_SETQ(the_env, @'*print-level*', ECL_NIL); FEerror("The value of *PRINT-LEVEL*~% ~S~%" "is not of the expected type (OR NULL (INTEGER 0 *))", 1, object); @@ -65,14 +67,15 @@ ecl_print_level(void) cl_fixnum ecl_print_length(void) { - cl_object object = ecl_symbol_value(@'*print-length*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object object = ecl_cmp_symbol_value(the_env, @'*print-length*'); cl_fixnum length; if (object == ECL_NIL) { length = MOST_POSITIVE_FIXNUM; } else if (ECL_FIXNUMP(object)) { length = ecl_fixnum(object); unlikely_if (length < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); + ERROR: ECL_SETQ(the_env, @'*print-length*', ECL_NIL); FEerror("The value of *PRINT-LENGTH*~% ~S~%" "is not of the expected type (OR NULL (INTEGER 0 *))", 1, object); @@ -94,12 +97,13 @@ ecl_print_radix(void) cl_object ecl_print_case(void) { - cl_object output = ecl_symbol_value(@'*print-case*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object output = ecl_cmp_symbol_value(the_env, @'*print-case*'); unlikely_if (output != @':upcase' && output != @':downcase' && output != @':capitalize') { - ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); + ECL_SETQ(the_env, @'*print-case*', @':downcase'); FEerror("The value of *PRINT-CASE*~% ~S~%" "is not of the expected type " "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output); @@ -139,21 +143,21 @@ ecl_print_circle(void) @(defun write (x &key ((:stream strm) ECL_NIL) - (array ecl_symbol_value(@'*print-array*')) - (base ecl_symbol_value(@'*print-base*')) - ((:case cas) ecl_symbol_value(@'*print-case*')) - (circle ecl_symbol_value(@'*print-circle*')) - (escape ecl_symbol_value(@'*print-escape*')) - (gensym ecl_symbol_value(@'*print-gensym*')) - (length ecl_symbol_value(@'*print-length*')) - (level ecl_symbol_value(@'*print-level*')) - (lines ecl_symbol_value(@'*print-lines*')) - (miser_width ecl_symbol_value(@'*print-miser-width*')) - (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) - (pretty ecl_symbol_value(@'*print-pretty*')) - (radix ecl_symbol_value(@'*print-radix*')) - (readably ecl_symbol_value(@'*print-readably*')) - (right_margin ecl_symbol_value(@'*print-right-margin*'))) + (array ecl_cmp_symbol_value(the_env, @'*print-array*')) + (base ecl_cmp_symbol_value(the_env, @'*print-base*')) + ((:case cas) ecl_cmp_symbol_value(the_env, @'*print-case*')) + (circle ecl_cmp_symbol_value(the_env, @'*print-circle*')) + (escape ecl_cmp_symbol_value(the_env, @'*print-escape*')) + (gensym ecl_cmp_symbol_value(the_env, @'*print-gensym*')) + (length ecl_cmp_symbol_value(the_env, @'*print-length*')) + (level ecl_cmp_symbol_value(the_env, @'*print-level*')) + (lines ecl_cmp_symbol_value(the_env, @'*print-lines*')) + (miser_width ecl_cmp_symbol_value(the_env, @'*print-miser-width*')) + (pprint_dispatch ecl_cmp_symbol_value(the_env, @'*print-pprint-dispatch*')) + (pretty ecl_cmp_symbol_value(the_env, @'*print-pretty*')) + (radix ecl_cmp_symbol_value(the_env, @'*print-radix*')) + (readably ecl_cmp_symbol_value(the_env, @'*print-readably*')) + (right_margin ecl_cmp_symbol_value(the_env, @'*print-right-margin*'))) @ ecl_bds_bind(the_env, @'*print-array*', array); ecl_bds_bind(the_env, @'*print-base*', base); diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d index e6559a297..1a8a0d614 100644 --- a/src/c/printer/write_object.d +++ b/src/c/printer/write_object.d @@ -19,8 +19,9 @@ bool _ecl_will_print_as_hash(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object circle_counter = ecl_cmp_symbol_value(the_env, @'si::*circle-counter*'); + cl_object circle_stack = ecl_cmp_symbol_value(the_env, @'si::*circle-stack*'); cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); if (ECL_FIXNUMP(circle_counter)) { return !(code == OBJNULL || code == ECL_NIL); @@ -44,8 +45,9 @@ _ecl_will_print_as_hash(cl_object x) cl_object si_search_print_circle(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object circle_counter = ecl_cmp_symbol_value(the_env, @'si::*circle-counter*'); + cl_object circle_stack = ecl_cmp_symbol_value(the_env, @'si::*circle-stack*'); cl_object code; code = ecl_gethash_safe(x, circle_stack, OBJNULL); @@ -69,8 +71,7 @@ si_search_print_circle(cl_object x) /* This object is referenced twice, but has no code yet */ circle_counter = ecl_make_fixnum(ecl_fixnum(circle_counter) + 1); _ecl_sethash(x, circle_stack, circle_counter); - ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', - circle_counter); + ECL_SETQ(the_env, @'si::*circle-counter*', circle_counter); return ecl_make_fixnum(-ecl_fixnum(circle_counter)); } else { return code; @@ -89,9 +90,9 @@ si_write_object_with_circle(cl_object x, cl_object stream, cl_object print_funct possibly contain cycles */ cl_object circle_counter; cl_fixnum code; - circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + const cl_env_ptr env = ecl_process_env(); + circle_counter = ecl_cmp_symbol_value(env, @'si::*circle-counter*'); if (circle_counter == ECL_NIL) { - cl_env_ptr env = ecl_process_env(); cl_object hash = cl__make_hash_table(@'eq', ecl_make_fixnum(1024), diff --git a/src/c/read.d b/src/c/read.d index 6af306d83..cdeb392c5 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1023,7 +1023,7 @@ sharp_dot_reader(cl_object in, cl_object c, cl_object d) if (read_suppress) { @(return ECL_NIL); } - unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) + unlikely_if (ecl_cmp_symbol_value(env, @'*read-eval*') == ECL_NIL) FEreader_error("Cannot evaluate the form #.~A", in, 1, c); /* FIXME! We should do something here to ensure that the #. * only uses the #n# that have been defined */ diff --git a/src/c/symbol.d b/src/c/symbol.d index b3c9e79fa..b55d83c6c 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -136,6 +136,21 @@ ecl_make_symbol(const char *s, const char *p) cl_object ecl_symbol_value(cl_object s) +{ + if (ecl_unlikely(Null(s))) { + return s; + } + if (ecl_unlikely(ecl_t_of(s) != t_symbol)) { + FEwrong_type_nth_arg(@[symbol-value], 1, s, @[symbol]); + } + return ecl_cmp_symbol_value(ecl_process_env(), s); +} + +/* ecl_cmp_symbol_value does the minimal amount of checking necessary + * to implement SYMBOL-VALUE for objects that have been checked to be + * non-null symbols by the compiler. */ +cl_object +ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s) { #ifndef ECL_FINAL /* Symbols are not initialized yet. This test is issued only during ECL @@ -144,16 +159,12 @@ ecl_symbol_value(cl_object s) ecl_internal_error("SYMBOL-VALUE: symbols are not initialized yet."); } #endif - if (Null(s)) { - return s; - } else { - /* FIXME: Should we check symbol type? */ - const cl_env_ptr the_env = ecl_process_env(); - cl_object value = ECL_SYM_VAL(the_env, s); - unlikely_if (value == OBJNULL) - FEunbound_variable(s); - return value; + /* FIXME: Should we check symbol type? */ + cl_object value = ECL_SYM_VAL(the_env, s); + if (ecl_unlikely(value == OBJNULL)) { + FEunbound_variable(s); } + return value; } static void diff --git a/src/c/threads/barrier.d b/src/c/threads/barrier.d index 3aaaf39d3..8a3d8a09c 100755 --- a/src/c/threads/barrier.d +++ b/src/c/threads/barrier.d @@ -149,9 +149,9 @@ mp_barrier_wait(cl_object barrier) { barrier->barrier.arrivers_count++; ECL_UNWIND_PROTECT_BEGIN(the_env) { do { - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); ecl_cond_var_wait(&barrier->barrier.cv, &barrier->barrier.mutex); - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); } while(!barrier->barrier.wakeup); wakeup = barrier->barrier.wakeup; if (barrier->barrier.arrivers_count - 1 == 0) { diff --git a/src/c/threads/process.d b/src/c/threads/process.d index b9bd18b00..96ef852b5 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -765,7 +765,7 @@ mp_block_signals(void) { #ifdef ECL_WINDOWS_THREADS cl_env_ptr the_env = ecl_process_env(); - cl_object previous = ecl_symbol_value(@'ext::*interrupts-enabled*'); + cl_object previous = ecl_cmp_symbol_value(the_env, @'ext::*interrupts-enabled*'); ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); @(return previous); #else diff --git a/src/c/threads/semaphore.d b/src/c/threads/semaphore.d index a8b542722..75cc973b3 100644 --- a/src/c/threads/semaphore.d +++ b/src/c/threads/semaphore.d @@ -92,9 +92,9 @@ semaphore_wait_unprotected(cl_object semaphore, cl_object count, cl_object timeo ecl_cond_var_t *cv = &semaphore->semaphore.cv; if (timeout == ECL_NIL) { do { - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); ecl_cond_var_wait(cv, mutex); - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); } while (semaphore->semaphore.counter < counter); } else { cl_object deadline = ecl_plus(cl_get_internal_real_time(), diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index 3d924b528..af4a3afe1 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -357,14 +357,14 @@ (LEXICAL (wt-lex var-loc)) ((SPECIAL GLOBAL) (if (safe-compile) - (wt "ecl_symbol_value(" var-loc ")") + (wt "ecl_cmp_symbol_value(cl_env_copy," var-loc ")") (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) (t (wt var-loc)) ))) (defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb (unless (var-p var) - (baboon :format-control "set-var: ~s is not a vairable." + (baboon :format-control "set-var: ~s is not a variable." :format-arguments (list var))) (case (var-kind var) (CLOSURE @@ -377,7 +377,7 @@ (wt #\;)) ((SPECIAL GLOBAL) (if (safe-compile) - (wt-nl "cl_set(" var-loc ",") + (wt-nl "ecl_cmp_setq(cl_env_copy," var-loc ",") (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) (wt-coerce-loc (var-rep-type var) loc) (wt ");")) diff --git a/src/h/external.h b/src/h/external.h index 8638a8eeb..3ad3ce805 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1733,7 +1733,9 @@ extern ECL_API void ecl_defparameter(cl_object s, cl_object v); extern ECL_API cl_object ecl_make_symbol(const char *s, const char*p); extern ECL_API cl_object ecl_make_keyword(const char *s); extern ECL_API cl_object ecl_symbol_value(cl_object s); +extern ECL_API cl_object ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s); extern ECL_API cl_object ecl_setq(cl_env_ptr env, cl_object var, cl_object value); +extern ECL_API cl_object ecl_cmp_setq(cl_env_ptr env, cl_object var, cl_object value); extern ECL_API cl_object ecl_symbol_name(cl_object s); extern ECL_API cl_object ecl_symbol_package(cl_object s); extern ECL_API int ecl_symbol_type(cl_object s); From 8ef84d3a9b476e45cc759ab60161332b99c64278 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 29 Jul 2023 18:41:42 +0200 Subject: [PATCH 3/7] cmp: improve error message for wrong number of arguments Mention the function name if available. Also refactor the code a bit. --- src/cmp/cmpbackend-cxx/cmppass2-fun.lsp | 35 ++++++++++++++++++------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp index 23baf92ec..da97389ad 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp @@ -105,16 +105,13 @@ (setf *tail-recursion-info* (cons *tail-recursion-info* requireds)) (setf *tail-recursion-info* nil)) - ;; check arguments - (when (policy-check-nargs) - (if (and use-narg (not varargs)) - (wt-nl "if (ecl_unlikely(narg!=" nreq ")) FEwrong_num_arguments_anonym();") - (when varargs - (when requireds - (wt-nl "if (ecl_unlikely(narg<" nreq ")) FEwrong_num_arguments_anonym();")) - (unless (or rest key-flag allow-other-keys) - (wt-nl "if (ecl_unlikely(narg>" (+ nreq nopt) ")) FEwrong_num_arguments_anonym();")))) - (open-inline-block)) + ;; check number of arguments + (wt-maybe-check-num-arguments use-narg + nreq + (if (or rest key-flag allow-other-keys) + nil + (+ nreq nopt)) + fname) ;; If the number of required arguments exceeds the number of variables we ;; want to pass on the C stack, we pass some of the arguments to the list @@ -286,3 +283,21 @@ (c2expr body) (close-inline-blocks)) + +(defun wt-maybe-check-num-arguments (use-narg minarg maxarg fname) + (when (and (policy-check-nargs) use-narg) + (flet ((wrong-num-arguments () + (if fname + (wt " FEwrong_num_arguments(" (add-symbol fname) ");") + (wt " FEwrong_num_arguments_anonym();")))) + (if (and maxarg (= minarg maxarg)) + (progn (wt-nl "if (ecl_unlikely(narg!=" minarg "))") + (wrong-num-arguments)) + (progn + (when (plusp minarg) + (wt-nl "if (ecl_unlikely(narg<" minarg "))") + (wrong-num-arguments)) + (when maxarg + (wt-nl "if (ecl_unlikely(narg>" maxarg "))") + (wrong-num-arguments))))) + (open-inline-block))) From 58c5782fe75bf053d50fd1d5835f40358bd20320 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Wed, 23 Aug 2023 20:38:35 +0200 Subject: [PATCH 4/7] cmp: also perform type propagation in disassemble --- src/cmp/cmpmain.lsp | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index cdf7e9c95..6e76b7e12 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -297,6 +297,7 @@ from the C language code. NIL means \"do not create the file\"." (let ((*compiler-output1* *standard-output*)) (apply t3local-fun args)))) (compiler-pass1 disassembled-form) + (compiler-pass/propagate-types) (ctop-write (compute-init-name "foo" :kind :fasl) (if h-file h-file "") (if data-file data-file "")) From 1bbae5a0bc923701fc9a9a0d3456d68288f8c696 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Wed, 23 Aug 2023 20:40:53 +0200 Subject: [PATCH 5/7] cmp: fix incorrect type proclamations --- src/cmp/proclamations.lsp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 849258d6c..8108fd479 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -180,10 +180,10 @@ (proclamation compile (function-name &optional (or list function)) (values (or function-name function) gen-bool gen-bool)) (proclamation compiler-macro-function (function-name &optional environment) - function) + (or function null)) (proclamation constantp (t &optional environment) gen-bool) (proclamation eval (form) (values &rest t)) -(proclamation macro-function (symbol &optional environment) function) +(proclamation macro-function (symbol &optional environment) (or function null)) (proclamation macroexpand (form &optional environment) (values form gen-bool)) (proclamation macroexpand-1 (form &optional environment) (values form gen-bool)) (proclamation proclaim (declaration-specifier) (values &rest t)) From b65b7d3825c8182a6f40016d16a8a39385330f9e Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 27 Aug 2023 20:11:02 +0200 Subject: [PATCH 6/7] cmp: expand compiler macros for callsites in the same source file as the compiler macro definition --- src/c/compiler.d | 1 + src/c/macros.d | 1 - src/cmp/cmpenv-api.lsp | 18 +++++++++++++++++- src/cmp/cmppass1-call.lsp | 2 +- src/cmp/cmppass1-top.lsp | 2 +- src/lsp/evalmacros.lsp | 3 +++ 6 files changed, 23 insertions(+), 4 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index c7004553d..24bd2cb5c 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -384,6 +384,7 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * 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 * diff --git a/src/c/macros.d b/src/c/macros.d index de1d49280..5dff42ccb 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -68,7 +68,6 @@ search_macro_function(cl_object name, cl_object env) return CADDR(record); if (tag == @'function') return ECL_NIL; - break; } } } diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 8f4aed3fe..2253d7b62 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -93,6 +93,11 @@ that are susceptible to be changed by PROCLAIM." (cmp-env-variables env)) env) +(defun cmp-env-register-compiler-macro (name macro-function) + (push (list name 'si::compiler-macro macro-function) + (cmp-env-functions *cmp-env-root*)) + (values)) + (defun cmp-env-search-function (name &optional (env *cmp-env*)) (let ((cfb nil) (unw nil) @@ -106,7 +111,7 @@ that are susceptible to be changed by PROCLAIM." (baboon :format-control "Unknown record found in environment~%~S" :format-arguments (list record))) ;; We have to use EQUAL because the name can be a list (SETF whatever) - ((equal (first record) name) + ((and (equal (first record) name) (not (eq (second record) 'si::compiler-macro))) (setf found (first (last record))) (return)))) (values found cfb unw))) @@ -166,6 +171,17 @@ that are susceptible to be changed by PROCLAIM." (or (cmp-env-search-macro name) (macro-function name))) +(defun cmp-env-search-compiler-macro (name &optional (env *cmp-env*)) + (dolist (record (cmp-env-functions env)) + (when (and (consp record) + (equal (first record) name) + (eq (second record) 'si::compiler-macro)) + (return-from cmp-env-search-compiler-macro (third record))))) + +(defun cmp-compiler-macro-function (name) + (or (cmp-env-search-compiler-macro name) + (compiler-macro-function name))) + (defun cmp-env-search-ftype (name &optional (env *cmp-env*)) (dolist (i env nil) (when (and (consp i) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index e4aafaaaf..15043babe 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -177,7 +177,7 @@ (setq fd (cmp-env-search-macro fname))) (cmp-expand-macro fd (list* fname args))) ((and (setq can-inline (inline-possible fname)) - (setq fd (compiler-macro-function fname)) + (setq fd (cmp-compiler-macro-function fname)) (progn (multiple-value-setq (fd success) (cmp-expand-compiler-macro fd fname args)) diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index 22f6df3ca..6d18e089e 100644 --- a/src/cmp/cmppass1-top.lsp +++ b/src/cmp/cmppass1-top.lsp @@ -43,7 +43,7 @@ (funcall fd args)) ((gethash fun *c1-dispatch-table*) (t1ordinary form)) - ((and (setq fd (compiler-macro-function fun)) + ((and (setq fd (cmp-compiler-macro-function fun)) (inline-possible fun) (let ((success nil)) (multiple-value-setq (fd success) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 9bf0c456f..763608e95 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -129,6 +129,9 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (print function) (setq function `(si::bc-disassemble ,function))) `(progn + ,(unless *bytecodes-compiler* + `(eval-when (:compile-toplevel) + (c::cmp-env-register-compiler-macro ',name ,function))) (put-sysprop ',name 'sys::compiler-macro ,function) ,@(si::expand-set-documentation name 'compiler-macro doc-string) ,(ext:register-with-pde whole) From 3f03a0c686137b9ca3c4216d72fcce25ee241340 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Wed, 23 Aug 2023 20:39:03 +0200 Subject: [PATCH 7/7] cmp: fix caching of type specifiers We cannot compare with (equal) here because subtype relations can differ for member and eql types even if the type specifiers are the same under equal. --- src/cmp/cmptype-arith.lsp | 12 ++++++------ src/cmp/cmputil.lsp | 23 +++++++++++++++++++---- 2 files changed, 25 insertions(+), 10 deletions(-) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 9e337f308..45d000868 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -79,7 +79,7 @@ (defun trivial-type-p (type) (subtypep T type)) -(defun-equal-cached type-and (t1 t2) +(defun-cached type-and (t1 t2) type-specifier= ;; FIXME! Should we allow "*" as type name??? (when (or (eq t1 t2) (eq t2 '*)) (return-from type-and t1)) @@ -128,7 +128,7 @@ (let ((l (1- (length type)))) (values l l))))) -(defun-equal-cached values-type-primary-type (type) +(defun-cached values-type-primary-type (type) type-specifier= ;; Extract the type of the first value returned by this form. We are ;; pragmatic and thus (VALUES) => NULL [CHECKME!] (let (aux) @@ -144,7 +144,7 @@ (t aux)))) -(defun-equal-cached values-type-to-n-types (type length) +(defun-cached values-type-to-n-types (type length) type-specifier= (when (plusp length) (do-values-type-to-n-types type length))) @@ -195,7 +195,7 @@ (return (values (nreverse required) (nreverse optional) rest a-o-k))))) -(defun-equal-cached values-type-or (t1 t2) +(defun-cached values-type-or (t1 t2) type-specifier= (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) (return-from values-type-or t2)) (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) @@ -241,7 +241,7 @@ ,@(and opt (cons '&optional (nreverse opt))) ,@(and rest (cons '&optional rest))))))) -(defun-equal-cached values-type-and (t1 t2) +(defun-cached values-type-and (t1 t2) type-specifier= (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) (return-from values-type-and t1)) (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) @@ -277,7 +277,7 @@ ,@(and opt (cons '&optional (nreverse opt))) ,@(and rest (cons '&optional rest))))))) -(defun-equal-cached type-or (t1 t2) +(defun-cached type-or (t1 t2) type-specifier= ;; FIXME! Should we allow "*" as type name??? (when (or (eq t1 t2) (eq t2 '*)) (return-from type-or t1)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index c65412987..77c127f42 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -436,6 +436,24 @@ comparing circular objects." (equal-recursive (cdr x) (cdr y) x0 y0 t (ash path-spec 1) (the fixnum (1+ n)))))))) (equal-recursive x y nil nil t 0 -1))) +(defun type-specifier= (x y) + "Compares two type specifiers for syntactic equality." + ;; This function only checks if the arguments have the same name + ;; (and arguments in case of compound type specifiers) but not if + ;; they are aliases of each other. For example (OR REAL COMPLEX) and + ;; NUMBER are considered different by this function but are of + ;; course semantically equivalent. + ;; + ;; Note that type specifiers cannot be compared with EQUAL since in + ;; eql and member types the arguments have to compared using EQL. + (if (and (consp x) (consp y)) + (if (and (member (first x) '(eql member)) + (member (first y) '(eql member))) + (every #'eql x y) + (and (type-specifier= (car x) (car y)) + (type-specifier= (cdr x) (cdr y)))) + (eql x y))) + ;; ---------------------------------------------------------------------- ;; CACHED FUNCTIONS ;; @@ -447,7 +465,7 @@ comparing circular objects." (hash-function (case test (EQ 'SI::HASH-EQ) (EQL 'SI::HASH-EQL) - ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL) + ((EQUAL EQUAL-WITH-CIRCULARITY TYPE-SPECIFIER=) 'SI::HASH-EQUAL) (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) `(progn (defvar ,cache-name @@ -469,8 +487,5 @@ comparing circular objects." (setf (aref ,cache-name hash) (list ,@lambda-list output)) output)))))))) -(defmacro defun-equal-cached (name lambda-list &body body) - `(defun-cached ,name ,lambda-list equal-with-circularity ,@body)) - (defun same-fname-p (name1 name2) (equal name1 name2))