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

@@ -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, ...)
 {

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;

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;

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

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

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

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

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

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

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

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 */

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

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

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

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(),

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

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