1.0.36.8: deal with environment argument in TYPEP transforms

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

diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp
index 794c90d..4edb1a4 100644 (file)
--- a/src/compiler/x86/insts.lisp
+++ b/src/compiler/x86/insts.lisp
@@ -608,6 +608,13 @@
   ;; optional fields
   (imm))
 
+;;; reg-no-width with #x0f prefix
+(sb!disassem:define-instruction-format (ext-reg-no-width 16
+                                        :default-printer '(:name :tab reg))
+  (prefix  :field (byte 8 0)    :value #b00001111)
+  (op    :field (byte 5 11))
+  (reg   :field (byte 3 8) :type 'reg))
+
 ;;; Same as reg/mem, but with a prefix of #b00001111
 (sb!disassem:define-instruction-format (ext-reg/mem 24
                                         :default-printer '(:name :tab reg/mem))
@@ -922,6 +929,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)))
        (emit-mod-reg-r/m-byte segment mod reg r/m)
        (when (= r/m #b100)
          (let ((ss (1- (integer-length scale)))
@@ -1588,6 +1600,12 @@
    (emit-byte segment #b11010100)
    (emit-byte segment #b00001010)))
 
+(define-instruction bswap (segment dst)
+  (:printer ext-reg-no-width ((op #b11001)))
+  (:emitter
+   (emit-byte segment #x0f)
+   (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst))))
+
 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
 (define-instruction cbw (segment)
   (:printer two-bytes ((op '(#b01100110 #b10011000))))
@@ -2637,9 +2655,8 @@
 (define-instruction fxch (segment source)
   (:printer floating-point-fp ((op '(#b001 #b001))))
   (:emitter
-    (unless (and (tn-p source)
-                 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
-      (cl:break))
+    (aver (and (tn-p source)
+               (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)))
     (emit-byte segment #b11011001)
     (emit-fp-op segment source #b001)))
 
@@ -2990,3 +3007,61 @@
   (:emitter
    (emit-byte segment #b00001111)
    (emit-byte segment #b00110001)))
+
+;;;; Late VM definitions
+(defun canonicalize-inline-constant (constant)
+  (let ((first (car constant)))
+    (typecase first
+      (single-float (setf constant (list :single-float first)))
+      (double-float (setf constant (list :double-float first)))))
+  (destructuring-bind (type value) constant
+    (ecase type
+      ((:byte :word :dword)
+         (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 :dword (ldb (byte 32 0) (single-float-bits value))))
+      ((:double-float)
+         (aver (typep value 'double-float))
+         (cons :double-float
+               (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
+                                        (double-float-low-bits value))))))))
+
+(defun inline-constant-value (constant)
+  (let ((label (gen-label))
+        (size  (ecase (car constant)
+                 ((:byte :word :dword) (car constant))
+                 (:double-float :dword))))
+    (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)
+    (:double-float 8)))
+
+(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))))))