Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3407/src/compiler/x86-64

Modified Files:
	cell.lisp macros.lisp parms.lisp 
Log Message:
0.9.4.8:
  * put a TLS-INDEX-LOCK and pseudo-atomic around tls index
    allocation to make bind thread and signal safe


Index: cell.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/cell.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- cell.lisp	26 Aug 2005 20:30:04 -0000	1.8
+++ cell.lisp	26 Aug 2005 22:16:47 -0000	1.9
@@ -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))

Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/macros.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- macros.lisp	14 Jul 2005 19:13:49 -0000	1.10
+++ macros.lisp	26 Aug 2005 22:16:47 -0000	1.11
@@ -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)

Index: parms.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/parms.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- parms.lisp	11 Aug 2005 14:44:16 -0000	1.11
+++ parms.lisp	26 Aug 2005 22:16:47 -0000	1.12
@@ -195,6 +195,7 @@
     *gc-pending*
 
     *free-tls-index*
+    *tls-index-lock*
 
     *allocation-pointer*
     *binding-stack-pointer*