From: Alastair Bridgewater <lisphacker@users.sourceforge.net>
Date: Sun, 8 Aug 2010 01:12:28 +0000 (+0000)
Subject: 1.0.41.34: ppc: Implement multithreaded symbol binding / unbinding.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=43a3cc06f2671f6a3e75ae22c17f369e6306b6bb;p=sbcl.git

1.0.41.34: ppc: Implement multithreaded symbol binding / unbinding.

  * This is roughly based on the x86-64 version, but with TLS
allocation inline and synchronization made up with a copy of
"The PowerPC Architecture" in front of me.

  * This does not have any check for TLS index overflow.

  * Also implement the spinlock stuff used by the runtime to
do its TLS index allocation for dynamic binding.
---

diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp
index 7a2eb8d..491941c 100644
--- a/src/compiler/ppc/cell.lisp
+++ b/src/compiler/ppc/cell.lisp
@@ -228,6 +228,63 @@
 ;;; the symbol on the binding stack and stuff the new value into the
 ;;; symbol.
 
+#!+sb-thread
+(define-vop (bind)
+  (:args (val :scs (any-reg descriptor-reg))
+         (symbol :scs (descriptor-reg)))
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:temporary (:scs (descriptor-reg)) temp tls-index)
+  (:generator 5
+     (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+     (inst cmpwi tls-index 0)
+     (inst bne TLS-VALID)
+
+     ;; No TLS slot allocated, so allocate one.
+     (pseudo-atomic (pa-flag)
+       (without-scheduling ()
+         (assemble ()
+           (inst li temp (+ (static-symbol-offset '*tls-index-lock*)
+                            (ash symbol-value-slot word-shift)
+                            (- other-pointer-lowtag)))
+           OBTAIN-LOCK
+           (inst lwarx tls-index null-tn temp)
+           (inst cmpwi tls-index 0)
+           (inst bne OBTAIN-LOCK)
+           (inst stwcx. thread-base-tn null-tn temp)
+           (inst bne OBTAIN-LOCK)
+           (inst isync)
+
+           ;; Check to see if the TLS index was set while we were waiting.
+           (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+           (inst cmpwi tls-index 0)
+           (inst bne RELEASE-LOCK)
+
+           (load-symbol-value tls-index *free-tls-index*)
+           ;; FIXME: Check for TLS index overflow.
+           (inst addi tls-index tls-index n-word-bytes)
+           (store-symbol-value tls-index *free-tls-index*)
+           (inst addi tls-index tls-index (- n-word-bytes))
+           (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+
+           ;; The sync instruction doesn't need to happen if we branch
+           ;; directly to RELEASE-LOCK as we didn't do any stores in that
+           ;; case.
+           (inst sync)
+           RELEASE-LOCK
+           (inst stwx zero-tn null-tn temp)
+
+           ;; temp is a boxed register, but we've been storing crap in it.
+           ;; fix it before we leave pseudo-atomic.
+           (inst li temp 0))))
+
+     TLS-VALID
+     (inst lwzx temp thread-base-tn tls-index)
+     (inst addi bsp-tn bsp-tn (* 2 n-word-bytes))
+     (storew temp bsp-tn (- binding-value-slot binding-size))
+     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
+     (inst stwx val thread-base-tn tls-index)))
+
+#!-sb-thread
 (define-vop (bind)
   (:args (val :scs (any-reg descriptor-reg))
          (symbol :scs (descriptor-reg)))
@@ -239,7 +296,19 @@
     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 
+#!+sb-thread
+(define-vop (unbind)
+  (:temporary (:scs (descriptor-reg)) tls-index value)
+  (:generator 0
+    (loadw tls-index bsp-tn (- binding-symbol-slot binding-size))
+    (loadw tls-index tls-index symbol-tls-index-slot other-pointer-lowtag)
+    (loadw value bsp-tn (- binding-value-slot binding-size))
+    (inst stwx value thread-base-tn tls-index)
+    (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
+    (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
 
+#!-sb-thread
 (define-vop (unbind)
   (:temporary (:scs (descriptor-reg)) symbol value)
   (:generator 0
@@ -268,6 +337,11 @@
       (inst cmpwi symbol 0)
       (inst beq skip)
       (loadw value bsp-tn (- binding-value-slot binding-size))
+      #!+sb-thread
+      (loadw symbol symbol symbol-tls-index-slot other-pointer-lowtag)
+      #!+sb-thread
+      (inst stwx value thread-base-tn symbol)
+      #!-sb-thread
       (storew value symbol symbol-value-slot other-pointer-lowtag)
       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 
diff --git a/src/runtime/ppc-arch.h b/src/runtime/ppc-arch.h
index 573f0ea..b225869 100644
--- a/src/runtime/ppc-arch.h
+++ b/src/runtime/ppc-arch.h
@@ -1,15 +1,34 @@
 #ifndef _PPC_ARCH_H
 #define _PPC_ARCH_H
 
-static inline void
+static inline long
 get_spinlock(lispobj *word,long value)
 {
-    *word=value;                /* FIXME for threads */
+#ifdef LISP_FEATURE_SB_THREAD
+    long temp;
+
+    asm volatile("1: lwarx %0,0,%1;"
+                 "   cmpwi %0,0;"
+                 "   bne- 1b;"
+                 "   stwcx. %2,0,%1;"
+                 "   bne- 1b;"
+                 "   isync"
+                 : "=&r" (temp)
+                 : "r" (word), "r" (value)
+                 : "cr0", "memory");
+    return temp;
+#else
+    *word=value;
+    return 0;
+#endif
 }
 
 static inline void
 release_spinlock(lispobj *word)
 {
+#ifdef LISP_FEATURE_SB_THREAD
+    asm volatile ("sync" : : : "memory");
+#endif
     *word=0;
 }
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 1057799..8bfe795 100644
--- 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".)
-"1.0.41.33"
+"1.0.41.34"