1.0.29.54: Inline unboxed constants on x86[-64]

[sbcl.git] / src / compiler / x86-64 / insts.lisp

diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp
index 1f3cc0b..28ac794 100644 (file)
--- a/src/compiler/x86-64/insts.lisp
+++ b/src/compiler/x86-64/insts.lisp
@@ -1460,6 +1460,11 @@
             (r/m (cond (index #b100)
                        ((null base) #b101)
                        (t (reg-tn-encoding base)))))
+       (when (and (fixup-p disp)
+                  (label-p (fixup-offset disp)))
+         (aver (null base))
+         (aver (null index))
+         (return-from emit-ea (emit-ea segment disp reg allow-constants)))
        (when (and (= mod 0) (= r/m #b101))
          ;; this is rip-relative in amd64, so we'll use a sib instead
          (setf r/m #b100 scale 1))
@@ -3537,3 +3542,91 @@
   (:emitter
    (emit-byte segment #b00001111)
    (emit-byte segment #b00110001)))
+
+;;;; Late VM definitions
+
+(defun canonicalize-inline-constant (constant &aux (alignedp nil))
+  (let ((first (car constant)))
+    (when (eql first :aligned)
+      (setf alignedp t)
+      (pop constant)
+      (setf first (car constant)))
+    (typecase first
+      (single-float (setf constant (list :single-float first)))
+      (double-float (setf constant (list :double-float first)))
+      ((complex single-float)
+         (setf constant (list :complex-single-float first)))
+      ((complex double-float)
+         (setf constant (list :complex-double-float first)))))
+  (destructuring-bind (type value) constant
+    (ecase type
+      ((:byte :word :dword :qword)
+         (aver (integerp value))
+         (cons type value))
+      ((:base-char)
+         (aver (base-char-p value))
+         (cons :byte (char-code value)))
+      ((:character)
+         (aver (characterp value))
+         (cons :dword (char-code value)))
+      ((:single-float)
+         (aver (typep value 'single-float))
+         (cons (if alignedp :oword :dword)
+               (ldb (byte 32 0) (single-float-bits value))))
+      ((:double-float)
+         (aver (typep value 'double-float))
+         (cons (if alignedp :oword :qword)
+               (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
+                                        (double-float-low-bits value)))))
+      ((:complex-single-float)
+         (aver (typep value '(complex single-float)))
+         (cons (if alignedp :oword :qword)
+               (ldb (byte 64 0)
+                    (logior (ash (single-float-bits (imagpart value)) 32)
+                            (ldb (byte 32 0)
+                                 (single-float-bits (realpart value)))))))
+      ((:oword :sse)
+         (aver (integerp value))
+         (cons :oword value))
+      ((:complex-double-float)
+         (aver (typep value '(complex double-float)))
+         (cons :oword
+               (logior (ash (double-float-high-bits (imagpart value)) 96)
+                       (ash (double-float-low-bits (imagpart value)) 64)
+                       (ash (ldb (byte 32 0)
+                                 (double-float-high-bits (realpart value)))
+                            32)
+                       (double-float-low-bits (realpart value))))))))
+
+(defun inline-constant-value (constant)
+  (let ((label (gen-label))
+        (size  (ecase (car constant)
+                 ((:byte :word :dword :qword) (car constant))
+                 ((:oword) :qword))))
+    (values label (make-ea size
+                           :disp (make-fixup nil :code-object label)))))
+
+(defun emit-constant-segment-header (constants optimize)
+  (declare (ignore constants))
+  (loop repeat (if optimize 64 16) do (inst byte #x90)))
+
+(defun size-nbyte (size)
+  (ecase size
+    (:byte  1)
+    (:word  2)
+    (:dword 4)
+    (:qword 8)
+    (:oword 16)))
+
+(defun sort-inline-constants (constants)
+  (stable-sort constants #'> :key (lambda (constant)
+                                    (size-nbyte (caar constant)))))
+
+(defun emit-inline-constant (constant label)
+  (let ((size (size-nbyte (car constant))))
+    (emit-alignment (integer-length (1- size)))
+    (emit-label label)
+    (let ((val (cdr constant)))
+      (loop repeat size
+            do (inst byte (ldb (byte 8 0) val))
+               (setf val (ash val -8))))))