Factor out most x86 code using the FS prefix into a macro WITH-TLS-EA.

The macro expands into the exact same forms it replaces at the moment.

Windows threading will be able to plug into this macro with few changes,
and notably much reduced read-time conditionals.

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 01cf930..8cd0e07 100755 (executable)
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -355,9 +355,10 @@
     (aver (not (location= result esp-tn)))
     (unless (zerop amount)
       (let ((delta (logandc2 (+ amount 3) 3)))
-        (inst mov temp
-              (make-ea-for-symbol-tls-index *alien-stack*))
-        (inst sub (make-ea :dword :base temp) delta :fs)))
+        (with-tls-ea (EA :base temp
+                         :disp-type :index
+                         :disp (make-ea-for-symbol-tls-index *alien-stack*))
+          (inst sub EA delta :maybe-fs))))
     (load-tl-symbol-value result *alien-stack*))
   #!-sb-thread
   (:generator 0
@@ -375,9 +376,10 @@
   (:generator 0
     (unless (zerop amount)
       (let ((delta (logandc2 (+ amount 3) 3)))
-        (inst mov temp
-              (make-ea-for-symbol-tls-index *alien-stack*))
-        (inst add (make-ea :dword :base temp) delta :fs))))
+        (with-tls-ea (EA :base temp
+                         :disp-type :index
+                         :disp (make-ea-for-symbol-tls-index *alien-stack*))
+          (inst add EA delta :maybe-fs)))))
   #!-sb-thread
   (:generator 0
     (unless (zerop amount)

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp
index 72936a3..d9fdc1a 100644 (file)
--- a/src/compiler/x86/call.lisp
+++ b/src/compiler/x86/call.lisp
@@ -1465,9 +1465,10 @@
   ;; register on -SB-THREAD.
   #!+sb-thread
   (progn
-    (inst cmp (make-ea :dword
-                       :disp (* thread-stepping-slot n-word-bytes))
-          nil-value :fs))
+    (with-tls-ea (EA :base :unused
+                     :disp-type :constant
+                     :disp (* thread-stepping-slot n-word-bytes))
+      (inst cmp EA nil-value :maybe-fs)))
   #!-sb-thread
   (inst cmp (make-ea-for-symbol-value sb!impl::*stepping*)
         nil-value))

diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 0239ac1..44d2760 100644 (file)
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -73,7 +73,8 @@
       (progn
         (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
         ;; Thread-local area, no LOCK needed.
-        (inst cmpxchg (make-ea :dword :base tls) new :fs)
+        (with-tls-ea (EA :base tls :base-already-live-p t)
+          (inst cmpxchg EA new :maybe-fs))
         (inst cmp eax no-tls-value-marker-widetag)
         (inst jmp :ne check)
         (move eax old))
@@ -117,9 +118,10 @@
       (let ((global-val (gen-label))
             (done (gen-label)))
         (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
-        (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs)
-        (inst jmp :z global-val)
-        (inst mov (make-ea :dword :base tls) value :fs)
+        (with-tls-ea (EA :base tls :base-already-live-p t)
+          (inst cmp EA no-tls-value-marker-widetag :maybe-fs)
+          (inst jmp :z global-val)
+          (inst mov EA value :maybe-fs))
         (inst jmp done)
         (emit-label global-val)
         (storew value symbol symbol-value-slot other-pointer-lowtag)
@@ -139,7 +141,8 @@
              (err-lab (generate-error-code vop 'unbound-symbol-error object))
              (ret-lab (gen-label)))
         (loadw value object symbol-tls-index-slot other-pointer-lowtag)
-        (inst mov value (make-ea :dword :base value) :fs)
+        (with-tls-ea (EA :base value :base-already-live-p t)
+          (inst mov value EA :maybe-fs))
         (inst cmp value no-tls-value-marker-widetag)
         (inst jmp :ne check-unbound-label)
         (loadw value object symbol-value-slot other-pointer-lowtag)
@@ -159,7 +162,8 @@
     (:generator 8
       (let ((ret-lab (gen-label)))
         (loadw value object symbol-tls-index-slot other-pointer-lowtag)
-        (inst mov value (make-ea :dword :base value) :fs)
+        (with-tls-ea (EA :base value :base-already-live-p t)
+          (inst mov value EA :maybe-fs))
         (inst cmp value no-tls-value-marker-widetag)
         (inst jmp :ne ret-lab)
         (loadw value object symbol-value-slot other-pointer-lowtag)
@@ -183,7 +187,8 @@
   (:generator 9
     (let ((check-unbound-label (gen-label)))
       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
-      (inst mov value (make-ea :dword :base value) :fs)
+      (with-tls-ea (EA :base value :base-already-live-p t)
+        (inst mov value EA :maybe-fs))
       (inst cmp value no-tls-value-marker-widetag)
       (inst jmp :ne check-unbound-label)
       (loadw value object symbol-value-slot other-pointer-lowtag)
@@ -299,10 +304,11 @@
                     (#.esi-offset 'alloc-tls-index-in-esi))
                   :assembly-routine))
       (emit-label tls-index-valid)
-      (inst push (make-ea :dword :base tls-index) :fs)
-      (popw bsp (- binding-value-slot binding-size))
-      (storew symbol bsp (- binding-symbol-slot binding-size))
-      (inst mov (make-ea :dword :base tls-index) val :fs))))
+      (with-tls-ea (EA :base tls-index :base-already-live-p t)
+        (inst push EA :maybe-fs)
+        (popw bsp (- binding-value-slot binding-size))
+        (storew symbol bsp (- binding-symbol-slot binding-size))
+        (inst mov EA val :maybe-fs)))))
 
 #!-sb-thread
 (define-vop (bind)
@@ -328,7 +334,8 @@
     (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
     ;; Load VALUE from stack, then restore it to the TLS area.
     (loadw temp bsp (- binding-value-slot binding-size))
-    (inst mov (make-ea :dword :base tls-index) temp :fs)
+    (with-tls-ea (EA :base tls-index :base-already-live-p t)
+      (inst mov EA temp :maybe-fs))
     ;; Zero out the stack.
     (storew 0 bsp (- binding-symbol-slot binding-size))
     (storew 0 bsp (- binding-value-slot binding-size))
@@ -369,7 +376,8 @@
 
     #!+sb-thread (loadw
                   tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
-    #!+sb-thread (inst mov (make-ea :dword :base tls-index) value :fs)
+    #!+sb-thread (with-tls-ea (EA :base tls-index :base-already-live-p t)
+                   (inst mov EA value :maybe-fs))
     (storew 0 bsp (- binding-symbol-slot binding-size))
 
     SKIP

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 344b72d..b218fa9 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -110,17 +110,19 @@
 
 #!+sb-thread
 (defmacro load-tl-symbol-value (reg symbol)
-  `(progn
-    (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol))
-    (inst mov ,reg (make-ea :dword :base ,reg) :fs)))
+  `(with-tls-ea (EA :base ,reg
+                    :disp-type :index
+                    :disp (make-ea-for-symbol-tls-index ,symbol))
+     (inst mov ,reg (make-ea :dword :base ,reg) :maybe-fs)))
 #!-sb-thread
 (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
 
 #!+sb-thread
 (defmacro store-tl-symbol-value (reg symbol temp)
-  `(progn
-    (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol))
-    (inst mov (make-ea :dword :base ,temp) ,reg :fs)))
+  `(with-tls-ea (EA :base ,temp
+                    :disp-type :index
+                    :disp (make-ea-for-symbol-tls-index ,symbol))
+     (inst mov EA ,reg :maybe-fs)))
 #!-sb-thread
 (defmacro store-tl-symbol-value (reg symbol temp)
   (declare (ignore temp))
@@ -128,19 +130,29 @@
 
 (defmacro load-binding-stack-pointer (reg)
   #!+sb-thread
-  `(progn
-     (inst mov ,reg (make-ea :dword
-                             :disp (* 4 thread-binding-stack-pointer-slot))
-           :fs))
+  `(with-tls-ea (EA :base ,reg
+                    :disp-type :constant
+                    :disp (* 4 thread-binding-stack-pointer-slot))
+     (inst mov ,reg EA :maybe-fs))
   #!-sb-thread
   `(load-symbol-value ,reg *binding-stack-pointer*))
 
 (defmacro store-binding-stack-pointer (reg)
   #!+sb-thread
   `(progn
-     (inst mov (make-ea :dword
+     #!+win32
+     (progn
+       (inst push eax-tn)
+       (inst push ,reg)
+       (with-tls-ea (EA :base eax-tn
+                        :disp-type :constant
                         :disp (* 4 thread-binding-stack-pointer-slot))
-           ,reg :fs))
+         (inst pop EA))
+       (inst pop eax-tn))
+     #!-win32
+     (with-tls-ea (EA :disp-type :constant
+                      :disp (* 4 thread-binding-stack-pointer-slot))
+       (inst mov EA ,reg :maybe-fs)))
   #!-sb-thread
   `(store-symbol-value ,reg *binding-stack-pointer*))
 
@@ -577,3 +589,56 @@ collection."
                            `(touch-object ,pin))
                          pins)))))
       `(progn ,@body)))
+
+;;; Helper to hide the fact that thread access on Windows needs one more
+;;; instruction, needs the FS prefix in that instruction _instead_ of
+;;; the actual load/store, and partially hide the resulting need for a
+;;; temporary TN when the non-windows might have have dereferenced an EA
+;;; without a TN as a base.
+
+(defmacro with-tls-ea ((ea-var &key base
+                                    base-already-live-p
+                                    (disp-type :constant)
+                                    (disp 0))
+                       &body body)
+  "Execute BODY with various magic.  BODY is expected to emit instructions.
+
+   In the body, EA-VAR will be an alias for an EA which BODY can use to
+   perform a thread-local load or store.
+
+   Within the body, :MAYBE-FS will be replaced with :FS or NIL,
+   depending on the target, and needs to be included in any instruction
+   performing an access through the EA.
+
+   DISP-TYPE must be :INDEX, or :CONSTANT, and DISP must be an EA/TN,
+   or an expression returning an integer, respectively.
+
+   BASE must be a temporary TN, except in the following situation: BASE
+   will be unused when DISP-TYPE is constant, BASE-ALREADY-LIVE-P is
+   true, _and_ we're on POSIX.  This is an intentional optimization, and
+   the caller needs to take care to ignore the TN in this case, or can
+   omit this parameter.
+
+   BASE-ALREADY-LIVE-P means that at run-time, the BASE register already
+   holds an offset that we should add to instead of overwriting it.
+   The value of the BASE register is undefined following the macro invocation."
+  (check-type base-already-live-p boolean)
+  (check-type disp-type (member :index :constant))
+  (let ((body (subst :fs :maybe-fs body)))
+    (ecase disp-type
+      (:constant
+       `(progn
+          ,@(subst (if base-already-live-p
+                       ;; use BASE and DISP
+                       `(make-ea :dword :base ,base :disp ,disp)
+                       ;; BASE not live and not needed, just use DISP
+                       `(make-ea :dword :disp ,disp))
+                   ea-var
+                   body)))
+      (:index
+       ;; need to use BASE in any case; and DISP is an EA
+       `(progn
+          (inst ,(if base-already-live-p 'add 'mov) ,base ,disp)
+          ,@(subst `(make-ea :dword :base ,base)
+                   ea-var
+                   body))))))