Add thread local fluids

* libguile/fluids.h (struct scm_dynamic_state): Add thread_local_values
  table.  Thread locals are flushed to a separate thread-local table.
  The references are strong references since the table never escapes the
  thread.
  (scm_make_thread_local_fluid, scm_fluid_thread_local_p): New
  functions.
* libguile/fluids.c (FLUID_F_THREAD_LOCAL):
  (SCM_I_FLUID_THREAD_LOCAL_P): New macros.
  (restore_dynamic_state): Add comment about precondition.
  (save_dynamic_state): Flush thread locals.
  (scm_i_fluid_print): Print thread locals nicely.
  (new_fluid): Add flags arg.
  (scm_make_fluid, scm_make_fluid_with_default, scm_make_unbound_fluid):
  Adapt.
  (scm_make_thread_local_fluid, scm_fluid_thread_local_p): New
  functions.
  (fluid_set_x): Special flushing logic for thread-locals.
  (fluid_ref): Special cache miss logic for thread locals.
* libguile/stacks.c (scm_init_stacks):
* libguile/throw.c (scm_init_throw): %stacks and %exception-handler are
  thread-locals.
* libguile/threads.c (guilify_self_2): Init thread locals table.
* test-suite/tests/fluids.test ("dynamic states"): Add test.
* doc/ref/api-control.texi (Fluids and Dynamic States): Add link to
  Thread-Local Variables.
* doc/ref/api-scheduling.texi (Thread Local Variables): Update with real
  thread-locals.
* NEWS: Update.

5 files changed, 73 insertions, 12 deletions

diff --git a/libguile/fluids.c b/libguile/fluids.c
index 7daad7781..6bdca7ddf 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -91,6 +91,10 @@
    table could share more state, as in an immutable weak array-mapped
    hash trie or something, but we don't have such a data structure.  */
 
+#define FLUID_F_THREAD_LOCAL 0x100
+#define SCM_I_FLUID_THREAD_LOCAL_P(x) \
+  (SCM_CELL_WORD_0 (x) & FLUID_F_THREAD_LOCAL)
+
 static inline int
 is_dynamic_state (SCM x)
 {
@@ -103,6 +107,8 @@ get_dynamic_state (SCM dynamic_state)
   return SCM_CELL_OBJECT_1 (dynamic_state);
 }
 
+/* Precondition: It's OK to throw away any unflushed data in the current
+   cache.  */
 static inline void
 restore_dynamic_state (SCM saved, scm_t_dynamic_state *state)
 {
@@ -133,9 +139,20 @@ save_dynamic_state (scm_t_dynamic_state *state)
       struct scm_cache_entry *entry = &state->cache.entries[slot];
       SCM key = SCM_PACK (entry->key);
       SCM value = SCM_PACK (entry->value);
-      if (entry->key &&
-          !scm_is_eq (scm_weak_table_refq (state->values, key, SCM_UNDEFINED),
-                      value))
+
+      if (!entry->key)
+        continue;
+      if (SCM_I_FLUID_THREAD_LOCAL_P (key))
+        {
+          /* Because we don't include unflushed thread-local fluids in
+             the result, we need to flush them to the table so that
+             restore_dynamic_state can just throw away the current
+             cache.  */
+          scm_hashq_set_x (state->thread_local_values, key, value);
+        }
+      else if (!scm_is_eq (scm_weak_table_refq (state->values, key,
+                                                SCM_UNDEFINED),
+                           value))
         {
           if (state->has_aliased_values)
             saved = scm_acons (key, value, saved);
@@ -177,7 +194,10 @@ copy_value_table (SCM tab)
 void
 scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
-  scm_puts ("#<fluid ", port);
+  if (SCM_I_FLUID_THREAD_LOCAL_P (exp))
+    scm_puts ("#<thread-local-fluid ", port);
+  else
+    scm_puts ("#<fluid ", port);
   scm_intprint (SCM_UNPACK (exp), 16, port);
   scm_putc ('>', port);
 }
@@ -196,15 +216,15 @@ scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED
 #define SCM_I_FLUID_DEFAULT(x)   (SCM_CELL_OBJECT_1 (x))
 
 static SCM
-new_fluid (SCM init)
+new_fluid (SCM init, scm_t_bits flags)
 {
-  return scm_cell (scm_tc7_fluid, SCM_UNPACK (init));
+  return scm_cell (scm_tc7_fluid | flags, SCM_UNPACK (init));
 }
 
 SCM
 scm_make_fluid (void)
 {
-  return new_fluid (SCM_BOOL_F);
+  return new_fluid (SCM_BOOL_F, 0);
 }
 
 SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0, 
@@ -219,7 +239,7 @@ SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0,
 	    "with its own dynamic state, you can use fluids for thread local storage.")
 #define FUNC_NAME s_scm_make_fluid_with_default
 {
-  return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt);
+  return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt, 0);
 }
 #undef FUNC_NAME
 
@@ -228,7 +248,22 @@ SCM_DEFINE (scm_make_unbound_fluid, "make-unbound-fluid", 0, 0, 0,
             "Make a fluid that is initially unbound.")
 #define FUNC_NAME s_scm_make_unbound_fluid
 {
-  return new_fluid (SCM_UNDEFINED);
+  return new_fluid (SCM_UNDEFINED, 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_thread_local_fluid, "make-thread-local-fluid", 0, 1, 0, 
+	    (SCM dflt),
+	    "Return a newly created fluid, whose initial value is @var{dflt},\n"
+            "or @code{#f} if @var{dflt} is not given.  Unlike fluids made\n"
+	    "with @code{make-fluid}, thread local fluids are not captured\n"
+            "by @code{make-dynamic-state}.  Similarly, a newly spawned\n"
+            "child thread does not inherit thread-local fluid values from\n"
+            "the parent thread.")
+#define FUNC_NAME s_scm_make_thread_local_fluid
+{
+  return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt,
+                    FLUID_F_THREAD_LOCAL);
 }
 #undef FUNC_NAME
 
@@ -242,6 +277,17 @@ SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_fluid_thread_local_p, "fluid-thread-local?", 1, 0, 0, 
+	    (SCM fluid),
+	    "Return @code{#t} if the fluid @var{fluid} is is thread local,\n"
+            "or @code{#f} otherwise.")
+#define FUNC_NAME s_scm_fluid_thread_local_p
+{
+  SCM_VALIDATE_FLUID (1, fluid);
+  return scm_from_bool (SCM_I_FLUID_THREAD_LOCAL_P (fluid));
+}
+#undef FUNC_NAME
+
 int
 scm_is_fluid (SCM obj)
 {
@@ -268,6 +314,12 @@ fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value)
       fluid = SCM_PACK (evicted.key);
       value = SCM_PACK (evicted.value);
 
+      if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
+        {
+          scm_hashq_set_x (dynamic_state->thread_local_values, fluid, value);
+          return;
+        }
+
       if (dynamic_state->has_aliased_values)
         {
           if (scm_is_eq (scm_weak_table_refq (dynamic_state->values,
@@ -294,7 +346,12 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid)
     val = SCM_PACK (entry->value);
   else
     {
-      val = scm_weak_table_refq (dynamic_state->values, fluid, SCM_UNDEFINED);
+      if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
+        val = scm_hashq_ref (dynamic_state->thread_local_values, fluid,
+                             SCM_UNDEFINED);
+      else
+        val = scm_weak_table_refq (dynamic_state->values, fluid,
+                                   SCM_UNDEFINED);
 
       if (SCM_UNBNDP (val))
         val = SCM_I_FLUID_DEFAULT (fluid);
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 6d7969e15..7997ad4d3 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -44,6 +44,7 @@
 
 struct scm_dynamic_state
 {
+  SCM thread_local_values;
   SCM values;
   uint8_t has_aliased_values;
   struct scm_cache cache;
@@ -53,8 +54,10 @@ struct scm_dynamic_state
 SCM_API SCM scm_make_fluid (void);
 SCM_API SCM scm_make_fluid_with_default (SCM dflt);
 SCM_API SCM scm_make_unbound_fluid (void);
+SCM_API SCM scm_make_thread_local_fluid (SCM dflt);
 SCM_API int scm_is_fluid (SCM obj);
 SCM_API SCM scm_fluid_p (SCM fl);
+SCM_API SCM scm_fluid_thread_local_p (SCM fluid);
 SCM_API SCM scm_fluid_ref (SCM fluid);
 SCM_API SCM scm_fluid_ref_star (SCM fluid, SCM depth);
 SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 5679bec42..9bd2db8de 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -459,7 +459,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 void
 scm_init_stacks ()
 {
-  scm_sys_stacks = scm_make_fluid ();
+  scm_sys_stacks = scm_make_thread_local_fluid (SCM_BOOL_F);
   scm_c_define ("%stacks", scm_sys_stacks);
   
   scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
diff --git a/libguile/threads.c b/libguile/threads.c
index c999411e1..9ceb5b88a 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -458,6 +458,7 @@ guilify_self_2 (SCM dynamic_state)
   }
 
   t->dynamic_state = scm_gc_typed_calloc (scm_t_dynamic_state);
+  t->dynamic_state->thread_local_values = scm_c_make_hash_table (0);
   scm_set_current_dynamic_state (dynamic_state);
 
   t->dynstack.base = scm_gc_malloc (16 * sizeof (scm_t_bits), "dynstack");
diff --git a/libguile/throw.c b/libguile/throw.c
index 5f6dcfa90..123544e79 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -648,7 +648,7 @@ scm_init_throw ()
   tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
   scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
 
-  exception_handler_fluid = scm_make_fluid_with_default (SCM_BOOL_F);
+  exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
   /* This binding is later removed when the Scheme definitions of catch,
      throw, and with-throw-handler are created in boot-9.scm.  */
   scm_c_define ("%exception-handler", exception_handler_fluid);