Fri Dec 26 23:37:47 CST 2008  Stephen Compall <scompall@nocandysw.com>
  * A portable API for fluids, with tests
diff -rN -u old-bordeaux-threads/src/bordeaux-threads.lisp new-bordeaux-threads/src/bordeaux-threads.lisp
--- old-bordeaux-threads/src/bordeaux-threads.lisp	2008-12-27 20:33:11.000000000 -0600
+++ new-bordeaux-threads/src/bordeaux-threads.lisp	2008-12-27 20:33:11.000000000 -0600
@@ -60,7 +60,9 @@
        #:with-timeout #:timeout
 
 	   #:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p
-       #:join-thread))
+       #:join-thread
+
+	   #:make-fluid #:fluid-lock #:fluid-value))
 
 (in-package #:bordeaux-threads)
 
@@ -117,3 +119,43 @@
     (error
      (make-condition 'bordeaux-mp-condition
                      :message "Can not destroy the current thread"))))
+
+;;; Fluids
+
+(defstruct fluid
+  "A container for a different value in each thread.  Values are not
+inherited."
+  (lock (make-lock))
+  (table (make-hash-table :test #'eql) :type hash-table :read-only t)
+  (gc-function #'identity :type (or symbol cons function) :read-only t)
+  (gc-count 0 :type (and (integer 0) fixnum))
+  (gc-frequency 30 :type (and (integer 1) fixnum) :read-only t))
+
+(defun fluid-value (fluid &optional (thread (current-thread)))
+  "Answer two values: the value of FLUID for THREAD, and whether a
+value is present."
+  (let ((table (fluid-table fluid)))
+    (with-lock-held ((fluid-lock fluid))
+      (gethash thread table))))
+
+(defun fluid-gc (fluid)
+  "Clean up FLUID.  *Assume it is locked in this thread.*"
+  (let (to-gc (table (fluid-table fluid)) (gcer (fluid-gc-function fluid)))
+    (maphash (lambda (thread v)
+	       (unless (thread-alive-p thread)
+		 (push thread to-gc)
+		 (funcall gcer v)))
+	     table)
+    (dolist (thread to-gc)
+      (remhash thread table)))
+  (setf (fluid-gc-count fluid) 0))
+
+(defun (setf fluid-value) (new-value fluid &optional (thread (current-thread)))
+  "Alter the value of FLUID for THREAD to NEW-VALUE, answering
+NEW-VALUE."
+  (with-lock-held ((fluid-lock fluid))
+    (setf (gethash thread (fluid-table fluid)) new-value)
+    (when (>= (incf (fluid-gc-count fluid))
+	      (fluid-gc-frequency fluid))
+      (fluid-gc fluid)))
+  new-value)
diff -rN -u old-bordeaux-threads/test/bordeaux-threads-test.lisp new-bordeaux-threads/test/bordeaux-threads-test.lisp
--- old-bordeaux-threads/test/bordeaux-threads-test.lisp	2008-12-27 20:33:11.000000000 -0600
+++ new-bordeaux-threads/test/bordeaux-threads-test.lisp	2008-12-27 20:33:11.000000000 -0600
@@ -81,4 +81,65 @@
       (loop
          until (= num-procs *shared*)
          do (condition-wait *condition-variable* *lock*)))
-    (ensure-same num-procs *shared*)))
\ No newline at end of file
+    (ensure-same num-procs *shared*)))
+
+(addtest fluid-storage
+  ;; test for fluid-independent parallelizable storage and retrieval
+  (let ((fluid3 (make-fluid)) (fluid5 (make-fluid))
+	(sync (make-condition-variable))
+	values1 values2 (setcount 0))
+    (labels ((wait-until-set ()
+	       (with-lock-held (*lock*)
+		 (incf setcount 2)
+		 (loop until (= 4 setcount)
+		       do (condition-wait sync *lock*)))
+	       (condition-notify sync))
+	     (thread-thunk (modifier place)
+	       (lambda ()
+		 (setf (fluid-value fluid3) (* 3 modifier)
+		       (fluid-value fluid5) (* 5 modifier))
+		 (wait-until-set)
+		 (funcall place (list (fluid-value fluid3) (fluid-value fluid5))))))
+      (let ((threads
+	     (list (make-thread (thread-thunk 7 (lambda (n) (setf values1 n))))
+		   (make-thread (thread-thunk 13 (lambda (n) (setf values2 n)))))))
+	(loop while (some #'thread-alive-p threads)
+	      do (thread-yield))))
+    (ensure-same values1 (list 21 35))
+    (ensure-same values2 (list 39 65))
+    (ensure-same (fluid-value fluid3) (values nil nil))))
+
+(addtest fluid-gc
+  (let* ((death-stack '())
+	 (fluid (make-fluid :gc-frequency 5
+			    :gc-function (lambda (n) (push n death-stack))))
+	 (stay-alive (make-condition-variable))
+	 (fincount 0) (finp (make-condition-variable)))
+    (flet ((fluidia (n)
+	     (make-thread (lambda ()
+			    (setf (fluid-value fluid) n))))
+	   (spaceball (n)
+	     (make-thread
+	      (lambda ()
+		(setf (fluid-value fluid) n)
+		(with-lock-held (*lock*)
+		  (incf fincount))
+		(condition-notify finp)
+		(with-lock-held (*lock*)
+		  (condition-wait stay-alive *lock*))))))
+      (let ((dead-threads (loop for n from 1 to 3
+				collect (fluidia n))))
+	(loop while (some #'thread-alive-p dead-threads)
+	      do (thread-yield)))
+      (let ((living-threads (loop for n from 4 to 5
+				  collect (spaceball n))))
+	(with-lock-held (*lock*)
+	  (loop until (= 2 fincount)
+		do (condition-wait finp *lock*)))
+	(ensure (thread-alive-p (first living-threads)))
+	(ensure (thread-alive-p (second living-threads)))
+	(ensure-null (set-difference death-stack '(1 2 3)))
+	(ensure-null (set-difference '(1 2 3) death-stack))
+	(loop while (some #'thread-alive-p living-threads)
+	      do (condition-notify stay-alive)
+		 (thread-yield))))))