1.0.4.73: more x86 backend cleanups

  * Added x86 SB-VM::ENCODE-VALUE-IF-IMMEDIATE to contain a repeated
    etypecase in the backend.

diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 4504300..e30f508 100644 (file)
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -28,21 +28,7 @@
   (:ignore name)
   (:results)
   (:generator 1
-     (if (sc-is value immediate)
-        (let ((val (tn-value value)))
-           (etypecase val
-             (integer
-              (storew (fixnumize val)
-                      object offset lowtag))
-             (symbol
-              (storew (+ nil-value (static-symbol-offset val))
-                      object offset lowtag))
-             (character
-              (storew (logior (ash (char-code val) n-widetag-bits)
-                              character-widetag)
-                      object offset lowtag))))
-       ;; Else, value not immediate.
-       (storew value object offset lowtag))))
+     (storew (encode-value-if-immediate value) object offset lowtag)))
 \f
 
 

diff --git a/src/compiler/x86/memory.lisp b/src/compiler/x86/memory.lisp
index 2d89272..4a9a14a 100644 (file)
--- a/src/compiler/x86/memory.lisp
+++ b/src/compiler/x86/memory.lisp
@@ -97,21 +97,7 @@
   (:variant-vars base lowtag)
   (:info offset)
   (:generator 4
-     (if (sc-is value immediate)
-         (let ((val (tn-value value)))
-           (etypecase val
-             (integer
-              (storew (fixnumize val)
-                      object (+ base offset) lowtag))
-             (symbol
-              (storew (+ nil-value (static-symbol-offset val))
-                      object (+ base offset) lowtag))
-             (character
-              (storew (logior (ash (char-code val) n-widetag-bits)
-                              character-widetag)
-                      object (+ base offset) lowtag))))
-         ;; Else, value not immediate.
-         (storew value object (+ base offset) lowtag))))
+     (storew (encode-value-if-immediate value) object (+ base offset) lowtag)))
 
 (define-vop (slot-set-conditional)
   (:args (object :scs (descriptor-reg) :to :eval)

diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp
index 6d1ceb5..020f218 100644 (file)
--- a/src/compiler/x86/move.lisp
+++ b/src/compiler/x86/move.lisp
@@ -14,17 +14,10 @@
 (define-move-fun (load-immediate 1) (vop x y)
   ((immediate)
    (any-reg descriptor-reg))
-  (let ((val (tn-value x)))
-    (etypecase val
-      (integer
-       (if (zerop val)
-           (inst xor y y)
-         (inst mov y (fixnumize val))))
-      (symbol
-       (load-symbol y val))
-      (character
-       (inst mov y (logior (ash (char-code val) n-widetag-bits)
-                           character-widetag))))))
+  (let ((val (encode-value-if-immediate x)))
+    (if (zerop val)
+        (inst xor y y)
+        (inst mov y val))))
 
 (define-move-fun (load-number 1) (vop x y)
   ((immediate) (signed-reg unsigned-reg))
@@ -75,17 +68,10 @@
   (:generator 0
     (if (and (sc-is x immediate)
              (sc-is y any-reg descriptor-reg control-stack))
-        (let ((val (tn-value x)))
-          (etypecase val
-            (integer
-             (if (and (zerop val) (sc-is y any-reg descriptor-reg))
-                 (inst xor y y)
-               (inst mov y (fixnumize val))))
-            (symbol
-             (inst mov y (+ nil-value (static-symbol-offset val))))
-            (character
-             (inst mov y (logior (ash (char-code val) n-widetag-bits)
-                                 character-widetag)))))
+        (let ((val (encode-value-if-immediate x)))
+          (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+              (inst xor y y)
+              (inst mov y val)))
       (move y x))))
 
 (define-move-vop move :move
@@ -114,17 +100,10 @@
     (sc-case y
       ((any-reg descriptor-reg)
        (if (sc-is x immediate)
-           (let ((val (tn-value x)))
-             (etypecase val
-              (integer
-               (if (zerop val)
-                   (inst xor y y)
-                 (inst mov y (fixnumize val))))
-              (symbol
-               (load-symbol y val))
-              (character
-               (inst mov y (logior (ash (char-code val) n-widetag-bits)
-                                   character-widetag)))))
+           (let ((val (encode-value-if-immediate x)))
+             (if (zerop val)
+                 (inst xor y y)
+                 (inst mov y val)))
          (move y x)))
       ((control-stack)
        (let ((frame-offset (if (= (tn-offset fp) esp-offset)
@@ -132,19 +111,7 @@
                                (tn-offset y)
                                ;; Lisp stack
                                (frame-word-offset (tn-offset y)))))
-         (if (sc-is x immediate)
-             (let ((val (tn-value x)))
-               (etypecase val
-                 (integer
-                  (storew (fixnumize val) fp frame-offset))
-                 (symbol
-                  (storew (+ nil-value (static-symbol-offset val))
-                          fp frame-offset))
-                 (character
-                  (storew (logior (ash (char-code val) n-widetag-bits)
-                                  character-widetag)
-                          fp frame-offset))))
-             (storew x fp frame-offset)))))))
+         (storew (encode-value-if-immediate x) fp frame-offset))))))
 
 (define-move-vop move-arg :move-arg
   (any-reg descriptor-reg)

diff --git a/src/compiler/x86/pred.lisp b/src/compiler/x86/pred.lisp
index 8153429..a720559 100644 (file)
--- a/src/compiler/x86/pred.lisp
+++ b/src/compiler/x86/pred.lisp
@@ -38,33 +38,16 @@
   (:policy :fast-safe)
   (:translate eq)
   (:generator 3
-    (cond
-     ((sc-is y immediate)
-      (let ((val (tn-value y)))
-        (etypecase val
-          (integer
-           (if (and (zerop val) (sc-is x any-reg descriptor-reg))
-               (inst test x x) ; smaller
-             (inst cmp x (fixnumize val))))
-          (symbol
-           (inst cmp x (+ nil-value (static-symbol-offset val))))
-          (character
-           (inst cmp x (logior (ash (char-code val) n-widetag-bits)
-                               character-widetag))))))
-     ((sc-is x immediate) ; and y not immediate
-      ;; Swap the order to fit the compare instruction.
-      (let ((val (tn-value x)))
-        (etypecase val
-          (integer
-           (if (and (zerop val) (sc-is y any-reg descriptor-reg))
-               (inst test y y) ; smaller
-             (inst cmp y (fixnumize val))))
-          (symbol
-           (inst cmp y (+ nil-value (static-symbol-offset val))))
-          (character
-           (inst cmp y (logior (ash (char-code val) n-widetag-bits)
-                               character-widetag))))))
-      (t
-       (inst cmp x y)))
+    (let ((x-val (encode-value-if-immediate x))
+          (y-val (encode-value-if-immediate y)))
+      (cond
+        ;; Shorter instruction sequences for these two cases.
+        ((eql 0 y-val) (inst test x x))
+        ((eql 0 x-val) (inst test y y))
+
+        ;; An encoded value (literal integer) has to be the second argument.
+        ((sc-is x immediate) (inst cmp y x-val))
+
+        (t (inst cmp x y-val))))
 
     (inst jmp (if not-p :ne :e) target)))

diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp
index 1b080bc..3af49f2 100644 (file)
--- a/src/compiler/x86/vm.lisp
+++ b/src/compiler/x86/vm.lisp
@@ -404,6 +404,20 @@
                (eql value (log 2l0 10l0))
                (eql value (log 2l0 2.718281828459045235360287471352662L0)))
        (sc-number-or-lose 'fp-constant)))))
+
+;; For an immediate TN, return its value encoded for use as a literal.
+;; For any other TN, return the TN.  Only works for FIXNUMs,
+;; STATIC-SYMBOLs, and CHARACTERS (FLOATs and SAPs are handled
+;; elsewhere).
+(defun encode-value-if-immediate (tn)
+  (if (sc-is tn immediate)
+      (let ((val (tn-value tn)))
+        (etypecase val
+          (integer (fixnumize val))
+          (symbol (+ nil-value (static-symbol-offset val)))
+          (character (logior (ash (char-code val) n-widetag-bits)
+                             character-widetag))))
+      tn))
 \f
 ;;;; miscellaneous function call parameters
 

diff --git a/version.lisp-expr b/version.lisp-expr
index db0881e..ee40452 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".)
-"1.0.4.72"
+"1.0.4.73"