;; 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))
(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)))
(emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
(emit-ea segment dst (reg-tn-encoding src)))))
+(define-instruction pause (segment)
+ (:printer two-bytes ((op '(#xf3 #x90))))
+ (:emitter
+ (emit-byte segment #xf3)
+ (emit-byte segment #x90)))
\f
(defun emit-prefix (segment name)
(ecase name
(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))))
y))
((sc-is x control-stack)
(inst test (make-ea :byte :base ebp-tn
- :disp (- (* (1+ offset) n-word-bytes)))
+ :disp (frame-byte-offset offset))
y))
(t
(inst test x y)))))
(define-instruction rep (segment)
(:emitter
- (emit-byte segment #b11110010)))
+ (emit-byte segment #b11110011)))
(define-instruction repe (segment)
(:printer byte ((op #b11110011)))
(:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
'(:name :tab imm))
(:emitter
- (cond (stack-delta
+ (cond ((and stack-delta (not (zerop stack-delta)))
(emit-byte segment #b11000010)
(emit-word segment stack-delta))
(t
;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
;; from first principles whether it's defined in some way that genesis
;; can't grok.
- (case #!-darwin (byte-imm-code chunk dstate)
- #!+darwin (word-imm-code chunk dstate)
+ (case #!-ud2-breakpoints (byte-imm-code chunk dstate)
+ #!+ud2-breakpoints (word-imm-code chunk dstate)
(#.error-trap
(nt "error trap")
(sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
(define-instruction break (segment code)
(:declare (type (unsigned-byte 8) code))
- #!-darwin (:printer byte-imm ((op #b11001100)) '(:name :tab code)
- :control #'break-control)
- #!+darwin (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
- :control #'break-control)
+ #!-ud2-breakpoints (:printer byte-imm ((op #b11001100)) '(:name :tab code)
+ :control #'break-control)
+ #!+ud2-breakpoints (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
+ :control #'break-control)
(:emitter
- #!-darwin (emit-byte segment #b11001100)
+ #!-ud2-breakpoints (emit-byte segment #b11001100)
;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
;; throw a sigill with 0x0b0f instead and check for this in the
;; SIGILL handler and pass it on to the sigtrap handler if
;; appropriate
- #!+darwin (emit-word segment #b0000101100001111)
+ #!+ud2-breakpoints (emit-word segment #b0000101100001111)
(emit-byte segment code)))
(define-instruction int (segment number)
(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)))
(: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-bits)
+ (aver (integerp value))
+ (cons :double-float (ldb (byte 64 0) 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))))))
projects / sbcl.git / blobdiff