0.9.4.8:

  * put a TLS-INDEX-LOCK and pseudo-atomic around tls index
    allocation to make bind thread and signal safe

diff --git a/NEWS b/NEWS
index af2db8d..39717a2 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4:
     ** bug fix: binding a special with PROGV to no value is not
        the same as that symbol not having been bound (thanks to
        Hannu Koivisto)
+    ** bug fix: binding specials is thread safe (thanks to
+       Hannu Koivisto)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** ENSURE-GENERIC-FUNCTION should take a method class object for
        the :method-class keyword argument.

diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 6a3a89c..3d4b698 100644 (file)
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -283,22 +283,40 @@
 (define-vop (bind)
   (:args (val :scs (any-reg descriptor-reg))
          (symbol :scs (descriptor-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset) rax)
   (:temporary (:sc unsigned-reg) tls-index temp bsp)
-  (:generator 5
-    (let ((tls-index-valid (gen-label)))
+  (:generator 10
+    (let ((tls-index-valid (gen-label))
+          (get-tls-index-lock (gen-label))
+          (release-tls-index-lock (gen-label)))
       (load-tl-symbol-value bsp *binding-stack-pointer*)
       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
       (inst add bsp (* binding-size n-word-bytes))
       (store-tl-symbol-value bsp *binding-stack-pointer* temp)
-
       (inst or tls-index tls-index)
       (inst jmp :ne tls-index-valid)
-      ;; allocate a new tls-index
-      (load-symbol-value tls-index *free-tls-index*)
-      (inst add tls-index 8)            ;XXX surely we can do this more
-      (store-symbol-value tls-index *free-tls-index*) ;succintly
-      (inst sub tls-index 8)
-      (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+
+      (pseudo-atomic
+       (emit-label get-tls-index-lock)
+       (inst mov temp 1)
+       (inst xor rax rax)
+       (inst lock)
+       (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) temp)
+       (inst jmp :ne get-tls-index-lock)
+       ;; now with the lock held, see if the symbol's tls index has
+       ;; been set in the meantime
+       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+       (inst or tls-index tls-index)
+       (inst jmp :ne release-tls-index-lock)
+       ;; allocate a new tls-index
+       (load-symbol-value tls-index *free-tls-index*)
+       (inst add tls-index 8)          ;XXX surely we can do this more
+       (store-symbol-value tls-index *free-tls-index*) ;succintly
+       (inst sub tls-index 8)
+       (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+       (emit-label release-tls-index-lock)
+       (store-symbol-value 0 *tls-index-lock*))
+
       (emit-label tls-index-valid)
       (inst mov temp
             (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 0a1ae74..4a6a36b 100644 (file)
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -52,32 +52,31 @@
 (defmacro load-symbol (reg symbol)
   `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
 
+(defmacro make-ea-for-symbol-value (symbol)
+  `(make-ea :qword
+    :disp (+ nil-value
+           (static-symbol-offset ',symbol)
+           (ash symbol-value-slot word-shift)
+           (- other-pointer-lowtag))))
+
 (defmacro load-symbol-value (reg symbol)
-  `(inst mov ,reg
-         (make-ea :qword
-                  :disp (+ nil-value
-                           (static-symbol-offset ',symbol)
-                           (ash symbol-value-slot word-shift)
-                           (- other-pointer-lowtag)))))
+  `(inst mov ,reg (make-ea-for-symbol-value ,symbol)))
 
 (defmacro store-symbol-value (reg symbol)
-  `(inst mov
-         (make-ea :qword
-                  :disp (+ nil-value
-                           (static-symbol-offset ',symbol)
-                           (ash symbol-value-slot word-shift)
-                           (- other-pointer-lowtag)))
-         ,reg))
+  `(inst mov (make-ea-for-symbol-value ,symbol) ,reg))
+
+#!+sb-thread
+(defmacro make-ea-for-symbol-tls-index (symbol)
+  `(make-ea :qword
+    :disp (+ nil-value
+           (static-symbol-offset ',symbol)
+           (ash symbol-tls-index-slot word-shift)
+           (- other-pointer-lowtag))))
 
 #!+sb-thread
 (defmacro load-tl-symbol-value (reg symbol)
   `(progn
-    (inst mov ,reg
-     (make-ea :qword
-      :disp (+ nil-value
-               (static-symbol-offset ',symbol)
-               (ash symbol-tls-index-slot word-shift)
-               (- other-pointer-lowtag))))
+    (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol))
     (inst mov ,reg (make-ea :qword :base thread-base-tn :scale 1 :index ,reg))))
 #!-sb-thread
 (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
@@ -85,12 +84,7 @@
 #!+sb-thread
 (defmacro store-tl-symbol-value (reg symbol temp)
   `(progn
-    (inst mov ,temp
-     (make-ea :qword
-      :disp (+ nil-value
-               (static-symbol-offset ',symbol)
-               (ash symbol-tls-index-slot word-shift)
-               (- other-pointer-lowtag))))
+    (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol))
     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index ,temp) ,reg)))
 #!-sb-thread
 (defmacro store-tl-symbol-value (reg symbol temp)

diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp
index 1a68504..f80bbf2 100644 (file)
--- a/src/compiler/x86-64/parms.lisp
+++ b/src/compiler/x86-64/parms.lisp
@@ -195,6 +195,7 @@
     *gc-pending*
 
     *free-tls-index*
+    *tls-index-lock*
 
     *allocation-pointer*
     *binding-stack-pointer*

diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 74c23e9..f8b139e 100644 (file)
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -287,22 +287,40 @@
 (define-vop (bind)
   (:args (val :scs (any-reg descriptor-reg))
          (symbol :scs (descriptor-reg)))
+  (:temporary (:sc descriptor-reg :offset eax-offset) eax)
   (:temporary (:sc unsigned-reg) tls-index temp bsp)
-  (:generator 5
-    (let ((tls-index-valid (gen-label)))
+  (:generator 10
+    (let ((tls-index-valid (gen-label))
+          (get-tls-index-lock (gen-label))
+          (release-tls-index-lock (gen-label)))
       (load-tl-symbol-value bsp *binding-stack-pointer*)
       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
       (inst add bsp (* binding-size n-word-bytes))
       (store-tl-symbol-value bsp *binding-stack-pointer* temp)
-
       (inst or tls-index tls-index)
       (inst jmp :ne tls-index-valid)
-      ;; allocate a new tls-index
-      (load-symbol-value tls-index *free-tls-index*)
-      (inst add tls-index 4)            ;XXX surely we can do this more
-      (store-symbol-value tls-index *free-tls-index*) ;succintly
-      (inst sub tls-index 4)
-      (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+
+      (pseudo-atomic
+       (emit-label get-tls-index-lock)
+       (inst mov temp 1)
+       (inst xor eax eax)
+       (inst lock)
+       (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) temp)
+       (inst jmp :ne get-tls-index-lock)
+       ;; now with the lock held, see if the symbol's tls index has
+       ;; been set in the meantime
+       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+       (inst or tls-index tls-index)
+       (inst jmp :ne release-tls-index-lock)
+       ;; allocate a new tls-index
+       (load-symbol-value tls-index *free-tls-index*)
+       (inst add tls-index 4)          ;XXX surely we can do this more
+       (store-symbol-value tls-index *free-tls-index*) ;succintly
+       (inst sub tls-index 4)
+       (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+       (emit-label release-tls-index-lock)
+       (store-symbol-value 0 *tls-index-lock*))
+
       (emit-label tls-index-valid)
       (inst fs-segment-prefix)
       (inst mov temp (make-ea :dword :scale 1 :index tls-index))

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 477a806..b0f685f 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -67,32 +67,31 @@
 (defmacro load-symbol (reg symbol)
   `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
 
+(defmacro make-ea-for-symbol-value (symbol)
+  `(make-ea :dword
+    :disp (+ nil-value
+           (static-symbol-offset ',symbol)
+           (ash symbol-value-slot word-shift)
+           (- other-pointer-lowtag))))
+
 (defmacro load-symbol-value (reg symbol)
-  `(inst mov ,reg
-         (make-ea :dword
-                  :disp (+ nil-value
-                           (static-symbol-offset ',symbol)
-                           (ash symbol-value-slot word-shift)
-                           (- other-pointer-lowtag)))))
+  `(inst mov ,reg (make-ea-for-symbol-value ,symbol)))
 
 (defmacro store-symbol-value (reg symbol)
-  `(inst mov
-         (make-ea :dword
-                  :disp (+ nil-value
-                           (static-symbol-offset ',symbol)
-                           (ash symbol-value-slot word-shift)
-                           (- other-pointer-lowtag)))
-         ,reg))
+  `(inst mov (make-ea-for-symbol-value ,symbol) ,reg))
+
+#!+sb-thread
+(defmacro make-ea-for-symbol-tls-index (symbol)
+  `(make-ea :dword
+    :disp (+ nil-value
+           (static-symbol-offset ',symbol)
+           (ash symbol-tls-index-slot word-shift)
+           (- other-pointer-lowtag))))
 
 #!+sb-thread
 (defmacro load-tl-symbol-value (reg symbol)
   `(progn
-    (inst mov ,reg
-     (make-ea :dword
-      :disp (+ nil-value
-               (static-symbol-offset ',symbol)
-               (ash symbol-tls-index-slot word-shift)
-               (- other-pointer-lowtag))))
+    (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol))
     (inst fs-segment-prefix)
     (inst mov ,reg (make-ea :dword :scale 1 :index ,reg))))
 #!-sb-thread
@@ -101,12 +100,7 @@
 #!+sb-thread
 (defmacro store-tl-symbol-value (reg symbol temp)
   `(progn
-    (inst mov ,temp
-     (make-ea :dword
-      :disp (+ nil-value
-               (static-symbol-offset ',symbol)
-               (ash symbol-tls-index-slot word-shift)
-               (- other-pointer-lowtag))))
+    (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol))
     (inst fs-segment-prefix)
     (inst mov (make-ea :dword :scale 1 :index ,temp) ,reg)))
 #!-sb-thread

diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp
index 23fc57b..0107ecd 100644 (file)
--- a/src/compiler/x86/parms.lisp
+++ b/src/compiler/x86/parms.lisp
@@ -315,6 +315,7 @@
     *gc-pending*
 
     *free-tls-index*
+    *tls-index-lock*
 
     *allocation-pointer*
     *binding-stack-pointer*

diff --git a/src/runtime/dynbind.c b/src/runtime/dynbind.c
index 8c2d26a..da22189 100644 (file)
--- a/src/runtime/dynbind.c
+++ b/src/runtime/dynbind.c
@@ -36,16 +36,27 @@ void bind_variable(lispobj symbol, lispobj value, void *th)
     lispobj old_tl_value;
     struct binding *binding;
     struct thread *thread=(struct thread *)th;
-#ifdef LISP_FEATURE_SB_THREAD
-    struct symbol *sym=(struct symbol *)native_pointer(symbol);
-#endif
     binding = GetBSP();
     SetBSP(binding+1);
 #ifdef LISP_FEATURE_SB_THREAD
-    if(!sym->tls_index) {
-        sym->tls_index=SymbolValue(FREE_TLS_INDEX,0);
-        SetSymbolValue(FREE_TLS_INDEX,
-                       make_fixnum(fixnum_value(sym->tls_index)+1),0);
+    {
+        struct symbol *sym=(struct symbol *)native_pointer(symbol);
+        if(!sym->tls_index) {
+            lispobj *tls_index_lock=
+                &((struct symbol *)native_pointer(TLS_INDEX_LOCK))->value;
+            SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0),th);
+            SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1),th);
+            get_spinlock(tls_index_lock,(long)th);
+            if(!sym->tls_index) {
+                sym->tls_index=SymbolValue(FREE_TLS_INDEX,0);
+                SetSymbolValue(FREE_TLS_INDEX,
+                               make_fixnum(fixnum_value(sym->tls_index)+1),0);
+            }
+            release_spinlock(tls_index_lock);
+            SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0),th);
+            if (fixnum_value(SymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th)))
+                do_pending_interrupt();
+        }
     }
 #endif
     old_tl_value=SymbolTlValue(symbol,thread);

diff --git a/src/runtime/thread.c b/src/runtime/thread.c
index 117e3ec..0377562 100644 (file)
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -174,12 +174,14 @@ create_thread_struct(lispobj initial_function) {
         int i;
         for(i=0;i<(dynamic_values_bytes/sizeof(lispobj));i++)
             per_thread->dynamic_values[i]=NO_TLS_VALUE_MARKER_WIDETAG;
-        if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG)
+        if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) {
             SetSymbolValue
                 (FREE_TLS_INDEX,
                  make_fixnum(MAX_INTERRUPTS+
                              sizeof(struct thread)/sizeof(lispobj)),
                  0);
+            SetSymbolValue(TLS_INDEX_LOCK,make_fixnum(0),0);
+        }
 #define STATIC_TLS_INIT(sym,field) \
   ((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
   make_fixnum(THREAD_SLOT_OFFSET_WORDS(field))

diff --git a/version.lisp-expr b/version.lisp-expr
index 0a106d9..6f0e405 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.4.7"
+"0.9.4.8"