stacks: manually allocate bindings table

This commit removes initial bindings array from the process and allocates it
only in the bds stack. To make fields in the structure less confusing we rename
initial_bindings slot to inherit_bindings_p.

On observable behavior change is that bindings are inherited when the process is
enabled, not when it is created. That was not specified in documentation so it
should be fine to change this behavior. Moreover it makes more sense from the
programmer perspective -- we want to inherit bindings of the process that starts
our thread, not the one that creates it.

src/c/alloc_2.d

@@ -676,12 +676,12 @@ void init_type_info (void)
     to_bitmap(&o, &(o.process.name)) |
     to_bitmap(&o, &(o.process.function)) |
     to_bitmap(&o, &(o.process.args)) |
-    to_bitmap(&o, &(o.process.env)) |
     to_bitmap(&o, &(o.process.interrupt)) |
-    to_bitmap(&o, &(o.process.initial_bindings)) |
+    to_bitmap(&o, &(o.process.inherit_bindings_p)) |
     to_bitmap(&o, &(o.process.parent)) |
     to_bitmap(&o, &(o.process.exit_values)) |
-    to_bitmap(&o, &(o.process.woken_up));
+    to_bitmap(&o, &(o.process.woken_up)) |
+    to_bitmap(&o, &(o.process.env));
   type_info[t_lock].descriptor =
     to_bitmap(&o, &(o.lock.name)) |
     to_bitmap(&o, &(o.lock.owner));
@@ -1165,6 +1165,11 @@ ecl_mark_env(struct cl_env_struct *env)
     GC_set_mark_bit((void *)env->bds_stack.org);
   }
   /* When not using threads, "env" is mmaped or statically allocated. */
+#ifdef ECL_THREADS
+  if (env->bds_stack.tl_bindings)
+    GC_push_all((void *)env->bds_stack.tl_bindings,
+                (void *)(env->bds_stack.tl_bindings + env->bds_stack.tl_bindings_size));
+#endif
   GC_push_all((void *)env, (void *)(env + 1));
 }
 

src/c/main.d

@@ -196,11 +196,15 @@ ecl_init_first_env(cl_env_ptr env)
   init_threads();
 #endif
 #ifdef ECL_THREADS
-  env->bds_stack.bindings_array
-    = si_make_vector(ECL_T, ecl_make_fixnum(1024), ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL);
-  si_fill_array_with_elt(env->bds_stack.bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
-  env->bds_stack.tl_bindings_size = env->bds_stack.bindings_array->vector.dim;
-  env->bds_stack.tl_bindings = env->bds_stack.bindings_array->vector.self.t;
+  {
+    cl_index idx;
+    cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*));
+    for(idx=0; idx<1024; idx++) {
+      vector[idx] = ECL_NO_TL_BINDING;
+    }
+    env->bds_stack.tl_bindings_size = 1024;
+    env->bds_stack.tl_bindings = vector;
+  }
 #endif
   init_env_mp(env);
   init_env_int(env);
@@ -225,6 +229,8 @@ _ecl_dealloc_env(cl_env_ptr env)
   /* Environment cleanup. This is required becauyse the environment is allocated
    * using mmap or some other method. We could do more cleaning here.*/
 #ifdef ECL_THREADS
+  ecl_free(env->bds_stack.tl_bindings);
+  env->bds_stack.tl_bindings_size = 0;
   ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock);
 #endif
 #if defined(ECL_USE_MPROTECT)

src/c/stacks.d

@@ -435,17 +435,6 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol)
   return new_index;
 }
 
-static cl_object
-ecl_extend_bindings_array(cl_object vector)
-{
-  cl_index new_size = cl_core.last_var_index * 1.25;
-  cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL,
-                                        ECL_NIL, ECL_NIL, ECL_NIL);
-  si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
-  ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim);
-  return new_vector;
-}
-
 static cl_index
 invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s)
 {
@@ -454,10 +443,17 @@ invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s)
     index = ecl_new_binding_index(env, s);
   }
   if (index >= env->bds_stack.tl_bindings_size) {
-    cl_object vector = env->bds_stack.bindings_array;
-    env->bds_stack.bindings_array = vector = ecl_extend_bindings_array(vector);
-    env->bds_stack.tl_bindings_size = vector->vector.dim;
-    env->bds_stack.tl_bindings = vector->vector.self.t;
+    cl_index osize = env->bds_stack.tl_bindings_size;
+    cl_index nsize = cl_core.last_var_index * 1.25;
+    cl_object *old_vector = env->bds_stack.tl_bindings;
+    cl_object *new_vector = ecl_realloc(old_vector,
+                                        osize*sizeof(cl_object*),
+                                        nsize*sizeof(cl_object*));
+    while(osize < nsize) {
+      new_vector[osize++] = ECL_NO_TL_BINDING;
+    }
+    env->bds_stack.tl_bindings = new_vector;
+    env->bds_stack.tl_bindings_size = nsize;
   }
   return index;
 }

src/c/threads/thread.d

@@ -273,26 +273,43 @@ thread_entry_point(void *arg)
 #endif
 }
 
+static void
+init_tl_bindings(cl_object process, cl_env_ptr env)
+{
+  cl_index bindings_size;
+  cl_object *bindings;
+  if (Null(process->process.inherit_bindings_p)) {
+    cl_index idx = 0, size = 256;
+    bindings_size = size;
+    bindings = (cl_object *)ecl_malloc(size*sizeof(cl_object*));
+    for(idx=0; idx<256; idx++) {
+      bindings[idx] = ECL_NO_TL_BINDING;
+    }
+  } else {
+    cl_env_ptr parent_env = ecl_process_env();
+    bindings_size = parent_env->bds_stack.tl_bindings_size;
+    bindings = (cl_object *)ecl_malloc(bindings_size*sizeof(cl_object*));
+    ecl_copy(bindings, parent_env->bds_stack.tl_bindings, bindings_size*sizeof(cl_object*));
+  }
+  env->bds_stack.tl_bindings_size = bindings_size;
+  env->bds_stack.tl_bindings = bindings;
+}
+
 static cl_object
 alloc_process(cl_object name, cl_object initial_bindings_p)
 {
   cl_env_ptr env = ecl_process_env();
   cl_object process = ecl_alloc_object(t_process), array;
+  cl_index bindings_size;
+  cl_object* bindings;
   process->process.phase = ECL_PROCESS_INACTIVE;
   process->process.name = name;
   process->process.function = ECL_NIL;
   process->process.args = ECL_NIL;
   process->process.interrupt = ECL_NIL;
+  process->process.inherit_bindings_p = Null(initial_bindings_p)? ECL_T : ECL_NIL;
   process->process.exit_values = ECL_NIL;
   process->process.env = NULL;
-  if (initial_bindings_p != ECL_NIL || env->bds_stack.bindings_array == OBJNULL) {
-    array = si_make_vector(ECL_T, ecl_make_fixnum(256),
-                           ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL);
-    si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
-  } else {
-    array = cl_copy_seq(ecl_process_env()->bds_stack.bindings_array);
-  }
-  process->process.initial_bindings = array;
   process->process.woken_up = ECL_NIL;
   ecl_disable_interrupts_env(env);
   ecl_mutex_init(&process->process.start_stop_lock, TRUE);
@@ -351,16 +368,14 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
 
   /* Allocate real environment, link it together with process */
   env = _ecl_alloc_env(0);
-  process = alloc_process(name, bindings);
+  process = alloc_process(name, ECL_NIL);
   process->process.env = env;
   process->process.phase = ECL_PROCESS_BOOTING;
   process->process.thread = current;
 
   /* Copy initial bindings from process to the fake environment */
   env_aux->cleanup = registered;
-  env_aux->bds_stack.bindings_array = process->process.initial_bindings;
-  env_aux->bds_stack.tl_bindings_size = env_aux->bds_stack.bindings_array->vector.dim;
-  env_aux->bds_stack.tl_bindings = env_aux->bds_stack.bindings_array->vector.self.t;
+  init_tl_bindings(process, env_aux);
 
   /* Switch over to the real environment */
   memcpy(env, env_aux, sizeof(*env));
@@ -515,11 +530,7 @@ mp_process_enable(cl_object process)
     ecl_init_env(process_env);
 
     process_env->trap_fpe_bits = process->process.trap_fpe_bits;
-    process_env->bds_stack.bindings_array = process->process.initial_bindings;
-    process_env->bds_stack.tl_bindings_size =
-      process_env->bds_stack.bindings_array->vector.dim;
-    process_env->bds_stack.tl_bindings =
-      process_env->bds_stack.bindings_array->vector.self.t;
+    init_tl_bindings(process, process_env);
 
     ecl_disable_interrupts_env(the_env);
 #ifdef ECL_WINDOWS_THREADS

src/h/external.h

@@ -26,7 +26,6 @@ struct ecl_binding_stack {
 #ifdef ECL_THREADS
         cl_index tl_bindings_size;
         cl_object *tl_bindings;
-        cl_object bindings_array;
 #endif
         cl_index size;
         cl_index limit_size;

src/h/object.h

@@ -989,7 +989,7 @@ struct ecl_process {
         cl_object args;
         struct cl_env_struct *env;
         cl_object interrupt;
-        cl_object initial_bindings;
+        cl_object inherit_bindings_p;
         cl_object parent;
         cl_object exit_values;
         cl_object woken_up;