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.

9 files changed, 125 insertions, 32 deletions

diff --git a/NEWS b/NEWS
index 96cc959d9..d70397e97 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,13 @@ guile2.2, guile-2, guile2, and then guile.  The found prefix is also
 applied to guild, guile-config, and the like.  Thanks to Freja Nordsiek
 for this work.
 
+** Add thread-local fluids
+
+Guile now has support for fluids whose values are not captured by
+`current-dynamic-state' and not inheritied by child threads, and thus
+are local to the kernel thread they run on.  See "Thread-Local
+Variables" in the manual, for more.
+
 * Bug fixes
 
 ** Fix type inference when multiplying flonum with complex
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index 77d98b44e..b0c9e7202 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1727,6 +1727,9 @@ used for testing whether an object is actually a fluid.  The values
 stored in a fluid can be accessed with @code{fluid-ref} and
 @code{fluid-set!}.
 
+@xref{Thread-Local Variables}, for further notes on fluids, threads,
+parameters, and dynamic states.
+
 @deffn {Scheme Procedure} make-fluid [dflt]
 @deffnx {C Function} scm_make_fluid ()
 @deffnx {C Function} scm_make_fluid_with_default (dflt)
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index ff8473ae2..7b39a03d6 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -9,7 +9,7 @@
 
 @menu
 * Threads::                     Multiple threads of execution.
-* Thread Local Variables::      Guile doesn't really have these.
+* Thread Local Variables::      Some fluids are thread-local.
 * Asyncs::                      Asynchronous interrupts.
 * Atomics::                     Atomic references.
 * Mutexes and Condition Variables:: Synchronization primitives.
@@ -169,9 +169,7 @@ information.
 @subsection Thread-Local Variables
 
 Sometimes you want to establish a variable binding that is only valid
-for a given thread: a ``thread-local variable''.  Guile doesn't really
-have this facility, but what it does have can work well for most use
-cases we know about.
+for a given thread: a ``thread-local variable''.
 
 You would think that fluids or parameters would be Guile's answer for
 thread-local variables, since establishing a new fluid binding doesn't
@@ -191,26 +189,44 @@ bindings comes from a desire to isolate a binding from its setting in
 unrelated threads, then fluids and parameters apply nicely.
 
 On the other hand, if your use case is to prevent concurrent access to a
-value from multiple threads, then using fluids or parameters is not
-appropriate.  In this case, our current suggestion is to use weak hash
-tables or object properties whose keys are thread objects.  For example:
+value from multiple threads, then using vanilla fluids or parameters is
+not appropriate.  For this purpose, Guile has @dfn{thread-local fluids}.
+A fluid created with @code{make-thread-local-fluid} won't be captured by
+@code{current-dynamic-state} and won't be propagated to new threads.
 
-@example
-(define (get-my-sensitive-data-structure)
-  ...)
+@deffn {Scheme Procedure} make-thread-local-fluid [dflt]
+@deffnx {C Function} scm_make_thread_local_fluid (dflt)
+Return a newly created fluid, whose initial value is @var{dflt}, or
+@code{#f} if @var{dflt} is not given.  Unlike fluids made with
+@code{make-fluid}, thread local fluids are not captured by
+@code{make-dynamic-state}.  Similarly, a newly spawned child thread does
+not inherit thread-local fluid values from the parent thread.
+@end deffn
+
+@deffn {Scheme Procedure} fluid-thread-local? fluid
+@deffnx {C Function} scm_fluid_thread_local_p (fluid)
+Return @code{#t} if the fluid @var{fluid} is is thread-local, or
+@code{#f} otherwise.
+@end deffn
+
+For example:
 
-(define %thread-local (make-weak-key-hash-table))
+@example
+(define %thread-local (make-thread-local-fluid))
 
-(define (current-thread-local)
-  (or (hashq-ref %thread-local (current-thread))
-      (let ((val (get-my-sensitive-data-structure)))
-        (hashq-set! %thread-local (current-thread) val)
-        val)))
+(with-fluids ((%thread-local (compute-data)))
+  ... (fluid-ref %thread-local) ...)
 @end example
 
-It's not a terribly nice facility and perhaps we should have a better
-answer, like Racket's ``non-preserved thread cells''.  Your input is
-very welcome; we look forward to hearing from your experience.
+You can also make a thread-local parameter out of a thread-local fluid
+using the normal @code{fluid->parameter}:
+
+@example
+(define param (fluid->parameter (make-thread-local-fluid)))
+
+(parameterize ((param (compute-data)))
+  ... (param) ...)
+@end example
 
 
 @node Asyncs
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);
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index c043d94d3..9eca6f29d 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -260,4 +260,10 @@
                       (fluid-ref fluid))))
                  (lambda (k) k))))
         (and (eqv? (fluid-ref fluid) #f)
-             (eqv? (k) #t))))))
+             (eqv? (k) #t)))))
+
+  (pass-if "exception handler not captured"
+    (let ((state (catch #t (lambda () (current-dynamic-state)) error)))
+      (catch #t
+        (lambda () (with-dynamic-state state (/ 1 0)))
+        (lambda _ #t)))))