;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/insts.lisp,v 1.3 1997/03/26 20:25:05 dtc Exp $") ;;; ;;; ********************************************************************** ;;; ;;; Description of the x86 instruction set, for 80386 and above. ;;; ;;; Written by William Lott ;;; ;;; Debugged by Paul F. Werkowski Spring/Summer 1995. ;;; ;;; Debugging and enhancements by Douglas Crosher 1996. ;;; (in-package :x86) (use-package :new-assem) (def-assembler-params :scheduler-p nil) (disassem:set-disassem-params :instruction-alignment 8) ;;;; Primitive emitters. (define-emitter emit-word 16 (byte 16 0)) (define-emitter emit-dword 32 (byte 32 0)) (define-emitter emit-byte-with-reg 8 (byte 5 3) (byte 3 0)) (define-emitter emit-mod-reg-r/m-byte 8 (byte 2 6) (byte 3 3) (byte 3 0)) (define-emitter emit-sib-byte 8 (byte 2 6) (byte 3 3) (byte 3 0)) ;;;; Fixup emitters. (defun emit-absolute-fixup (segment fixup) (note-fixup segment :absolute fixup) (let ((offset (fixup-offset fixup))) (if (label-p offset) (emit-back-patch segment 4 #'(lambda (segment posn) (declare (ignore posn)) (emit-dword segment (- (+ (component-header-length) (or (label-position offset) 0) ) other-pointer-type)))) (emit-dword segment (or offset 0))))) (defun emit-relative-fixup (segment fixup) (note-fixup segment :relative fixup) (emit-dword segment (or (fixup-offset fixup) 0))) ;;;; The effective-address (ea) structure. (defun reg-tn-encoding (tn) (declare (type tn tn)) (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) (let ((offset (tn-offset tn))) (logior (ash (logand offset 1) 2) (ash offset -1)))) (defstruct (ea (:constructor make-ea (size &key base index scale disp)) (:print-function %print-ea)) (size nil :type (member :byte :word :dword)) (base nil :type (or tn null)) (index nil :type (or tn null)) (scale 1 :type (member 1 2 4 8)) (disp 0 :type (or (signed-byte 32) fixup))) (defun %print-ea (ea stream depth) (declare (ignore depth)) (cond ((or *print-escape* *print-readably*) (print-unreadable-object (ea stream :type t) (format stream "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]" (ea-size ea) (ea-base ea) (ea-index ea) (let ((scale (ea-scale ea))) (if (= scale 1) nil scale)) (ea-disp ea)))) (t (format stream "~A PTR [" (symbol-name (ea-size ea))) (when (ea-base ea) (write-string (x86-location-print-name (ea-base ea)) stream) (when (ea-index ea) (write-string "+" stream))) (when (ea-index ea) (write-string (x86-location-print-name (ea-index ea)) stream)) (unless (= (ea-scale ea) 1) (format stream "*~A" (ea-scale ea))) (typecase (ea-disp ea) (null) (integer (format stream "~@D" (ea-disp ea))) (t (format stream "+~A" (ea-disp ea)))) (write-char #\] stream)))) (defun emit-ea (segment thing reg &optional allow-constants) (etypecase thing (tn (ecase (sb-name (sc-sb (tn-sc thing))) (registers (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing))) (stack ;; Convert stack tns into an index off of EBP. (let ((disp (- (* (1+ (tn-offset thing)) word-bytes)))) (cond ((< -128 disp 127) (emit-mod-reg-r/m-byte segment #b01 reg #b101) (emit-byte segment disp)) (t (emit-mod-reg-r/m-byte segment #b10 reg #b101) (emit-dword segment disp))))) (constant (unless allow-constants (error "Constant TNs can only be directly used in MOV, PUSH, and CMP.")) (emit-mod-reg-r/m-byte segment #b00 reg #b101) (emit-absolute-fixup segment (make-fixup nil :code-object (- (* (tn-offset thing) word-bytes) other-pointer-type)))))) (ea (let* ((base (ea-base thing)) (index (ea-index thing)) (scale (ea-scale thing)) (disp (ea-disp thing)) (mod (cond ((or (null base) (and (eql disp 0) (not (= (reg-tn-encoding base) #b101)))) #b00) ((and (fixnump disp) (<= -128 disp 127)) #b01) (t #b10))) (r/m (cond (index #b100) ((null base) #b101) (t (reg-tn-encoding base))))) (emit-mod-reg-r/m-byte segment mod reg r/m) (when (= r/m #b100) (let ((ss (1- (integer-length scale))) (index (if (null index) #b100 (let ((index (reg-tn-encoding index))) (if (= index #b100) (error "Can't index off of ESP") index)))) (base (if (null base) #b101 (reg-tn-encoding base)))) (emit-sib-byte segment ss index base))) (cond ((= mod #b01) (emit-byte segment disp)) ((or (= mod #b10) (null base)) (if (fixup-p disp) (emit-absolute-fixup segment disp) (emit-dword segment disp)))))) (fixup (emit-mod-reg-r/m-byte segment #b00 reg #b101) (emit-absolute-fixup segment thing)))) (defun fp-reg-tn-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers))) ;;; ;;; like the above, but for fp-instructions--jrd ;;; (defun emit-fp-op (segment thing op) (if (fp-reg-tn-p thing) (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing) (byte 3 0) #b11000000))) (emit-ea segment thing op))) (defun byte-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) (member (sc-name (tn-sc thing)) byte-sc-names) t)) (defun byte-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :byte)) (tn (and (member (sc-name (tn-sc thing)) byte-sc-names) t)) (t nil))) (defun word-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) (member (sc-name (tn-sc thing)) word-sc-names) t)) (defun word-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :word)) (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t)) (t nil))) (defun dword-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) (member (sc-name (tn-sc thing)) dword-sc-names) t)) (defun dword-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :dword)) (tn (and (member (sc-name (tn-sc thing)) dword-sc-names) t)) (t nil))) (defun register-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers))) (defun accumulator-p (thing) (and (register-p thing) (= (tn-offset thing) 0))) (eval-when (compile load eval) (defconstant conditions '((:o . 0) (:no . 1) (:b . 2) (:nae . 2) (:c . 2) (:nb . 3) (:ae . 3) (:nc . 3) (:eq . 4) (:e . 4) (:z . 4) (:ne . 5) (:nz . 5) (:be . 6) (:na . 6) (:nbe . 7) (:a . 7) (:s . 8) (:ns . 9) (:p . 10) (:pe . 10) (:np . 11) (:po . 11) (:l . 12) (:nge . 12) (:nl . 13) (:ge . 13) (:le . 14) (:ng . 14) (:nle . 15) (:g . 15))) (defun conditional-opcode (condition) (cdr (assoc condition conditions :test #'eq)))) ;;;; Utilities. #-lispworks3 (defconstant operand-size-prefix-byte #b01100110) #+lispworks3 (eval-when (compile load eval) (defconstant operand-size-prefix-byte #b01100110)) (defparameter *default-operand-size* :dword) (defun maybe-emit-operand-size-prefix (segment size) (unless (or (eq size :byte) (eq size *default-operand-size*)) (emit-byte segment operand-size-prefix-byte))) (defun operand-size (thing) (typecase thing (tn (case (sc-name (tn-sc thing)) (#.dword-sc-names :dword) (#.word-sc-names :word) (#.byte-sc-names :byte) ;; added by jrd. float-registers is a separate size (?) (#.float-sc-names :float) (#.double-sc-names :double) (t (error "Can't tell the size of ~S ~S" thing (sc-name (tn-sc thing)))))) (ea (ea-size thing)) (t nil))) (defun matching-operand-size (dst src) (let ((dst-size (operand-size dst)) (src-size (operand-size src))) (if dst-size (if src-size (if (eq dst-size src-size) dst-size (error "Size mismatch: ~S is a ~S and ~S is a ~S" dst dst-size src src-size)) dst-size) (if src-size src-size (error "Can't tell the size of either ~S or ~S." dst src))))) (defun emit-sized-immediate (segment size value) (ecase size (:byte (emit-byte segment value)) (:word (emit-word segment value)) (:dword (emit-dword segment value)))) ;;;; Disassembler support stuff. (deftype reg () '(unsigned-byte 3)) #+cross-compiler (lisp:deftype reg () '(unsigned-byte 3)) (eval-when (compile eval load) (defparameter *default-address-size* ;; Actually, :dword is the only one really supported. :dword) (defparameter byte-reg-names #(al cl dl bl ah ch dh bh)) (defparameter word-reg-names #(ax cx dx bx sp bp si di)) (defparameter dword-reg-names #(eax ecx edx ebx esp ebp esi edi)) (defun print-reg-with-width (value width stream dstate) (declare (ignore dstate)) (princ (aref (ecase width (:byte byte-reg-names) (:word word-reg-names) (:dword dword-reg-names)) value) stream) ;; plus should do some source-var notes ) (defun print-reg (value stream dstate) (declare (type reg value) (type stream stream) (type disassem:disassem-state dstate)) (print-reg-with-width value (disassem:dstate-get-prop dstate 'width) stream dstate)) (defun print-word-reg (value stream dstate) (declare (type reg value) (type stream stream) (type disassem:disassem-state dstate)) (print-reg-with-width value (or (disassem:dstate-get-prop dstate 'word-width) *default-operand-size*) stream dstate)) (defun print-byte-reg (value stream dstate) (declare (type reg value) (type stream stream) (type disassem:disassem-state dstate)) (print-reg-with-width value :byte stream dstate)) (defun print-addr-reg (value stream dstate) (declare (type reg value) (type stream stream) (type disassem:disassem-state dstate)) (print-reg-with-width value *default-address-size* stream dstate)) ;;; Value is a list of (BASE-REG OFFSET INDEX-REG INDEX-SCALE) (defun print-mem-access (value stream print-size-p dstate) (declare (type list value) (type stream stream) (type (member t nil) print-size-p) (type disassem:disassem-state dstate)) (when print-size-p (princ (disassem:dstate-get-prop dstate 'width) stream) (princ '| PTR | stream)) (write-char #\[ stream) (let ((firstp t)) (macrolet ((pel ((var val) &body body) ;; Print an element of the address, maybe with ;; a leading separator. `(let ((,var ,val)) (when ,var (unless firstp (write-char #\+ stream)) ,@body (setq firstp nil))))) (pel (base-reg (first value)) (print-addr-reg base-reg stream dstate)) (pel (index-reg (third value)) (print-addr-reg index-reg stream dstate) (let ((index-scale (fourth value))) (when (and index-scale (not (= index-scale 1))) (write-char #\* stream) (princ index-scale stream)))) (let ((offset (second value))) (when (and offset (or firstp (not (zerop offset)))) (unless (or firstp (minusp offset)) (write-char #\+ stream)) (if firstp (disassem:princ16 offset stream) (princ offset stream)))))) (write-char #\] stream)) (defun print-reg/mem (value stream dstate) (declare (type (or list reg) value) (type stream stream) (type disassem:disassem-state dstate)) (if (typep value 'reg) (print-reg value stream dstate) (print-mem-access value stream nil dstate))) ;; Same as print-reg/mem, but prints an explicit size indicator for ;; memory references. (defun print-sized-reg/mem (value stream dstate) (declare (type (or list reg) value) (type stream stream) (type disassem:disassem-state dstate)) (if (typep value 'reg) (print-reg value stream dstate) (print-mem-access value stream t dstate))) (defun print-byte-reg/mem (value stream dstate) (declare (type (or list reg) value) (type stream stream) (type disassem:disassem-state dstate)) (if (typep value 'reg) (print-byte-reg value stream dstate) (print-mem-access value stream t dstate))) (defun print-label (value stream dstate) (declare (ignore dstate)) (disassem:princ16 value stream)) ;;; Returns either an integer, meaning a register, or a list of ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component ;;; may be missing or nil to indicate that it's not used or has the ;;; obvious default value (e.g., 1 for the index-scale). (defun prefilter-reg/mem (value dstate) (declare (type list value) (type disassem:disassem-state dstate)) (let ((mod (car value)) (r/m (cadr value))) (declare (type (unsigned-byte 2) mod) (type (unsigned-byte 3) r/m)) (cond ((= mod #b11) ;; registers r/m) ((= r/m #b100) ;; sib byte (let ((sib (disassem:read-suffix 8 dstate))) (declare (type (unsigned-byte 8) sib)) (let ((base-reg (ldb (byte 3 0) sib)) (index-reg (ldb (byte 3 3) sib)) (index-scale (ldb (byte 2 6) sib))) (declare (type (unsigned-byte 3) base-reg index-reg) (type (unsigned-byte 2) index-scale)) (let* ((offset (case mod (#b00 (if (= base-reg #b101) (disassem:read-suffix 32 dstate) nil)) (#b01 (disassem:read-signed-suffix 8 dstate)) (#b10 (disassem:read-suffix 32 dstate))))) (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg) offset (if (= index-reg #b100) nil index-reg) (ash 1 index-scale)))))) ((and (= mod #b00) (= r/m #b101)) (list nil (disassem:read-suffix 32 dstate)) ) ((= mod #b00) (list r/m)) ((= mod #b01) (list r/m (disassem:read-signed-suffix 8 dstate))) (t ; (= mod #b10) (list r/m (disassem:read-suffix 32 dstate)))))) ;;; This is a sort of bogus prefilter that just ;;; stores the info globally for other people to use; it ;;; probably never gets printed. (defun prefilter-width (value dstate) (setf (disassem:dstate-get-prop dstate 'width) (if (zerop value) :byte (let ((word-width ;; set by a prefix instruction (or (disassem:dstate-get-prop dstate 'word-width) *default-operand-size*))) (when (not (eql word-width *default-operand-size*)) ;; reset it (setf (disassem:dstate-get-prop dstate 'word-width) *default-operand-size*)) word-width)))) (defun offset-next (value dstate) (declare #|(type integer value)|# (type disassem:disassem-state dstate)) ;; XXX dtc; a hack to stop the disassembler causing a fatal error; ;; probably caused by out of bounds offsets? (if (or (null value) (and (listp value) (null (car value)))) 0 (+ (disassem:dstate-next-addr dstate) (if (listp value) (car value) value)))) (defun read-address (value dstate) (declare (ignore value)) ; always nil anyway (disassem:read-suffix (width-bits *default-address-size*) dstate)) (defun read-signed-imm-dword (value dstate) (declare (ignore value)) ; always nil anyway (disassem:read-signed-suffix 32 dstate)) (defun width-bits (width) (ecase width (:byte 8) (:word 16) (:dword 32) (:float 32) (:double 64))) ); eval-when ;;;; Disassembler argument types. (disassem:define-argument-type accum :printer #'(lambda (value stream dstate) (declare (ignore value) (type stream stream) (type disassem:disassem-state dstate)) (print-reg 0 stream dstate)) ) (disassem:define-argument-type word-accum :printer #'(lambda (value stream dstate) (declare (ignore value) (type stream stream) (type disassem:disassem-state dstate)) (print-word-reg 0 stream dstate)) ) (disassem:define-argument-type reg :printer #'print-reg) (disassem:define-argument-type addr-reg :printer #'print-addr-reg) (disassem:define-argument-type word-reg :printer #'print-word-reg) (disassem:define-argument-type imm-addr :prefilter #'read-address :printer #'print-label) (disassem:define-argument-type imm-data :prefilter #'(lambda (value dstate) (declare (ignore value)) ; always nil anyway (disassem:read-suffix (width-bits (disassem:dstate-get-prop dstate 'width)) dstate)) ) (disassem:define-argument-type signed-imm-data :prefilter #'(lambda (value dstate) (declare (ignore value)) ; always nil anyway (let ((width (disassem:dstate-get-prop dstate 'width))) (disassem:read-signed-suffix (width-bits width) dstate))) ) (disassem:define-argument-type signed-imm-byte :prefilter #'(lambda (value dstate) (declare (ignore value)) ; always nil anyway (disassem:read-signed-suffix 8 dstate))) (disassem:define-argument-type signed-imm-dword :prefilter #'read-signed-imm-dword) (disassem:define-argument-type imm-word :prefilter #'(lambda (value dstate) (declare (ignore value)) ; always nil anyway (let ((width (or (disassem:dstate-get-prop dstate 'word-width) *default-operand-size*))) (disassem:read-suffix (width-bits width) dstate)))) ;;; Needed for the ret imm16 instruction (disassem:define-argument-type imm-word-16 :prefilter #'(lambda (value dstate) (declare (ignore value)) ; always nil anyway (disassem:read-suffix 16 dstate))) (disassem:define-argument-type reg/mem :prefilter #'prefilter-reg/mem :printer #'print-reg/mem) (disassem:define-argument-type sized-reg/mem ;; Same as reg/mem, but prints an explicit size indicator for ;; memory references. :prefilter #'prefilter-reg/mem :printer #'print-sized-reg/mem) (disassem:define-argument-type byte-reg/mem :prefilter #'prefilter-reg/mem :printer #'print-byte-reg/mem) ;;; ;;; added by jrd ;;; (eval-when (compile load eval) (defun print-fp-reg (value stream dstate) (declare (ignore dstate)) (format stream "FR~D" value)) (defun prefilter-fp-reg (value dstate) ;; just return it (declare (ignore dstate)) value) ) (disassem:define-argument-type fp-reg :prefilter #'prefilter-fp-reg :printer #'print-fp-reg) (disassem:define-argument-type width :prefilter #'prefilter-width :printer #'(lambda (value stream dstate) (if ;; (zerop value) (or (null value) (and (numberp value) (zerop value))) ; zzz jrd (princ 'b stream) (let ((word-width ;; set by a prefix instruction (or (disassem:dstate-get-prop dstate 'word-width) *default-operand-size*))) (princ (schar (symbol-name word-width) 0) stream))))) ;;;; Disassembler instruction formats. (eval-when (compile eval) (defun swap-if (direction field1 separator field2) `(:if (,direction :constant 0) (,field1 ,separator ,field2) (,field2 ,separator ,field1)))) (disassem:define-instruction-format (byte 8 :default-printer '(:name)) (op :field (byte 8 0)) ;; optional fields (accum :type 'accum) (imm)) (disassem:define-instruction-format (simple 8) (op :field (byte 7 1)) (width :field (byte 1 0) :type 'width) ;; optional fields (accum :type 'accum) (imm)) ;;; Same as simple, but with direction bit (disassem:define-instruction-format (simple-dir 8 :include 'simple) (op :field (byte 6 2)) (dir :field (byte 1 1))) ;;; Same as simple, but with the immediate value occuring by default, ;;; and with an appropiate printer. (disassem:define-instruction-format (accum-imm 8 :include 'simple :default-printer '(:name :tab accum ", " imm)) (imm :type 'imm-data)) (disassem:define-instruction-format (reg-no-width 8 :default-printer '(:name :tab reg)) (op :field (byte 5 3)) (reg :field (byte 3 0) :type 'word-reg) ;; optional fields (accum :type 'word-accum) (imm)) ;;; adds a width field to reg-no-width (disassem:define-instruction-format (reg 8 :default-printer '(:name :tab reg)) (op :field (byte 4 4)) (width :field (byte 1 3) :type 'width) (reg :field (byte 3 0) :type 'reg) ;; optional fields (accum :type 'accum) (imm) ) ;;; Same as reg, but with direction bit (disassem:define-instruction-format (reg-dir 8 :include 'reg) (op :field (byte 3 5)) (dir :field (byte 1 4))) (disassem:define-instruction-format (two-bytes 16 :default-printer '(:name)) (op :fields (list (byte 8 0) (byte 8 8)))) (disassem:define-instruction-format (reg-reg/mem 16 :default-printer `(:name :tab reg ", " reg/mem)) (op :field (byte 7 1)) (width :field (byte 1 0) :type 'width) (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem) (reg :field (byte 3 11) :type 'reg) ;; optional fields (imm)) ;;; same as reg-reg/mem, but with direction bit (disassem:define-instruction-format (reg-reg/mem-dir 16 :include 'reg-reg/mem :default-printer `(:name :tab ,(swap-if 'dir 'reg/mem ", " 'reg))) (op :field (byte 6 2)) (dir :field (byte 1 1))) ;;; Same as reg-rem/mem, but uses the reg field as a second op code. (disassem:define-instruction-format (reg/mem 16 :default-printer '(:name :tab reg/mem)) (op :fields (list (byte 7 1) (byte 3 11))) (width :field (byte 1 0) :type 'width) (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'sized-reg/mem) ;; optional fields (imm)) ;;; Same as reg/mem, but with the immediate value occuring by default, ;;; and with an appropiate printer. (disassem:define-instruction-format (reg/mem-imm 16 :include 'reg/mem :default-printer '(:name :tab reg/mem ", " imm)) (reg/mem :type 'sized-reg/mem) (imm :type 'imm-data)) ;;; Same as reg/mem, but with using the accumulator in the default printer (disassem:define-instruction-format (accum-reg/mem 16 :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem)) (reg/mem :type 'reg/mem) ; don't need a size (accum :type 'accum)) ;;; Same as reg-reg/mem, but with a prefix of #b00001111 (disassem:define-instruction-format (ext-reg-reg/mem 24 :default-printer `(:name :tab reg ", " reg/mem)) (prefix :field (byte 8 0) :value #b00001111) (op :field (byte 7 9)) (width :field (byte 1 8) :type 'width) (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'reg/mem) (reg :field (byte 3 19) :type 'reg) ;; optional fields (imm)) ;;; Same as reg/mem, but with a prefix of #b00001111 (disassem:define-instruction-format (ext-reg/mem 24 :default-printer '(:name :tab reg/mem)) (prefix :field (byte 8 0) :value #b00001111) (op :fields (list (byte 7 9) (byte 3 19))) (width :field (byte 1 8) :type 'width) (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'sized-reg/mem) ;; optional fields (imm)) ;;; ---------------------------------------------------------------- ;;; this section added by jrd, for fp instructions. ;;; ;;; regular fp inst to/from registers/memory ;;; (disassem:define-instruction-format (floating-point 16 :default-printer `(:name :tab reg/mem)) (prefix :field (byte 5 3) :value #b11011) (op :fields (list (byte 3 0) (byte 3 11))) (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem) ) ;;; ;;; fp insn to/from fp reg ;;; (disassem:define-instruction-format (floating-point-fp 16 :default-printer `(:name :tab fp-reg)) (prefix :field (byte 5 3) :value #b11011) (suffix :field (byte 2 14) :value #b11) (op :fields (list (byte 3 0) (byte 3 11))) (fp-reg :field (byte 3 8) :type 'fp-reg) ) ;;; ;;; fp insn to/from fp reg, with the reversed source/destination flag. ;;; (disassem:define-instruction-format (floating-point-fp-d 16 :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg))) (prefix :field (byte 5 3) :value #b11011) (suffix :field (byte 2 14) :value #b11) (op :fields (list (byte 2 0) (byte 3 11))) (d :field (byte 1 2)) (fp-reg :field (byte 3 8) :type 'fp-reg) ) ;;; pfw ;;; fp no operand isns ;;; (disassem:define-instruction-format (floating-point-no 16 :default-printer '(:name)) (prefix :field (byte 8 0) :value #b11011001) (suffix :field (byte 3 13) :value #b111) (op :field (byte 5 8))) (disassem:define-instruction-format (floating-point-5 16 :default-printer '(:name)) (prefix :field (byte 8 0) :value #b11011011) (suffix :field (byte 3 13) :value #b111) (op :field (byte 5 8))) (disassem:define-instruction-format (floating-point-st 16 :default-printer '(:name)) (prefix :field (byte 8 0) :value #b11011111) (suffix :field (byte 3 13) :value #b111) (op :field (byte 5 8))) ;;; ---------------------------------------------------------------- ;;;; General Data Transfer (eval-when (eval compile load) (defun toggle-word-width (chunk inst stream dstate) (declare (ignore chunk inst stream)) (let ((ww (or (disassem:dstate-get-prop dstate 'word-width) *default-operand-size*))) (setf (disassem:dstate-get-prop dstate 'word-width) (ecase ww (:word :dword) (:dword :word)))))) ;;; This isn't a really an instruction, but it's easier to deal with it this ;;; way. We assume that it's actually used. (define-instruction toggle-data-size (segment) (:printer byte ((op operand-size-prefix-byte)) nil ; don't actually print it :control #'toggle-word-width)) (define-instruction mov (segment dst src) ;; immediate to register (:printer reg ((op #b1011) (imm nil :type 'imm-data)) '(:name :tab reg ", " imm)) ;; absolute mem to/from accumulator (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr)) `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]")))) ;; register to/from register/memory (:printer reg-reg/mem-dir ((op #b100010))) ;; immediate to register/memory (:printer reg/mem-imm ((op '(#b1100011 #b000)))) (:emitter (let ((size (matching-operand-size dst src))) (maybe-emit-operand-size-prefix segment size) (cond ((register-p dst) (cond ((integerp src) (emit-byte-with-reg segment (if (eq size :byte) #b10110 #b10111) (reg-tn-encoding dst)) (emit-sized-immediate segment size src)) ((and (fixup-p src) (accumulator-p dst)) (emit-byte segment (if (eq size :byte) #b10100000 #b10100001)) (emit-absolute-fixup segment src)) (t (emit-byte segment (if (eq size :byte) #b10001010 #b10001011)) (emit-ea segment src (reg-tn-encoding dst) t)))) ((and (fixup-p dst) (accumulator-p src)) (emit-byte segment (if (eq size :byte) #b10100010 #b10100011)) (emit-absolute-fixup segment dst)) ((integerp src) (emit-byte segment (if (eq size :byte) #b11000110 #b11000111)) (emit-ea segment dst #b000) (emit-sized-immediate segment size src)) ((register-p src) (emit-byte segment (if (eq size :byte) #b10001000 #b10001001)) (emit-ea segment dst (reg-tn-encoding src))) ((fixup-p src) (assert (eq size :dword)) (emit-byte segment #b11000111) (emit-ea segment dst #b000) (emit-absolute-fixup segment src)) (t (error "Bogus arguments to MOV: ~S ~S" dst src)))))) (defun emit-move-with-extension (segment dst src opcode) (assert (register-p dst)) (let ((dst-size (operand-size dst)) (src-size (operand-size src))) (ecase dst-size (:word (assert (eq src-size :byte)) (maybe-emit-operand-size-prefix segment :word) (emit-byte segment #b00001111) (emit-byte segment opcode) (emit-ea segment src (reg-tn-encoding dst))) (:dword (ecase src-size (:byte (maybe-emit-operand-size-prefix segment :dword) (emit-byte segment #b00001111) (emit-byte segment opcode) (emit-ea segment src (reg-tn-encoding dst))) (:word (emit-byte segment #b00001111) (emit-byte segment (logior opcode 1)) (emit-ea segment src (reg-tn-encoding dst)))))))) (define-instruction movsx (segment dst src) (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg))) (:emitter (emit-move-with-extension segment dst src #b10111110))) (define-instruction movzx (segment dst src) (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg))) (:emitter (emit-move-with-extension segment dst src #b10110110))) (define-instruction push (segment src) ;; Register. (:printer reg-no-width ((op #b01010))) ;; Register/Memory. (:printer reg/mem ((op '(#b1111111 #b110)) (width 1))) ;; Immediate. (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte)) '(:name :tab imm)) (:printer byte ((op #b01101000) (imm nil :type 'imm-word)) '(:name :tab imm)) ;; ### Segment registers? (:emitter (cond ((integerp src) (cond ((<= -128 src 127) (emit-byte segment #b01101010) (emit-byte segment src)) (t (emit-byte segment #b01101000) (emit-dword segment src)))) ((fixup-p src) ;; Interpret the fixup as an immediate dword to push (emit-byte segment #b01101000) (emit-absolute-fixup segment src)) (t (let ((size (operand-size src))) (assert (not (eq size :byte))) (maybe-emit-operand-size-prefix segment size) (cond ((register-p src) (emit-byte-with-reg segment #b01010 (reg-tn-encoding src))) (t (emit-byte segment #b11111111) (emit-ea segment src #b110 t)))))))) (define-instruction pusha (segment) (:printer byte ((op #b01100000))) (:emitter (emit-byte segment #b01100000))) (define-instruction pop (segment dst) (:printer reg-no-width ((op #b01011))) (:printer reg/mem ((op '(#b1000111 #b000)) (width 1))) (:emitter (let ((size (operand-size dst))) (assert (not (eq size :byte))) (maybe-emit-operand-size-prefix segment size) (cond ((register-p dst) (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst))) (t (emit-byte segment #b10001111) (emit-ea segment dst #b000)))))) (define-instruction popa (segment) (:printer byte ((op #b01100001))) (:emitter (emit-byte segment #b01100001))) (define-instruction xchg (segment operand1 operand2) ;; Register with accumulator. (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg)) ;; Register/Memory with Register. (:printer reg-reg/mem ((op #b1000011))) (:emitter (let ((size (matching-operand-size operand1 operand2))) (maybe-emit-operand-size-prefix segment size) (labels ((xchg-acc-with-something (acc something) (if (and (not (eq size :byte)) (register-p something)) (emit-byte-with-reg segment #b10010 (reg-tn-encoding something)) (xchg-reg-with-something acc something))) (xchg-reg-with-something (reg something) (emit-byte segment (if (eq size :byte) #b10000110 #b10000111)) (emit-ea segment something (reg-tn-encoding reg)))) (cond ((accumulator-p operand1) (xchg-acc-with-something operand1 operand2)) ((accumulator-p operand2) (xchg-acc-with-something operand2 operand1)) ((register-p operand1) (xchg-reg-with-something operand1 operand2)) ((register-p operand2) (xchg-reg-with-something operand2 operand1)) (t (error "Bogus args to XCHG: ~S ~S" operand1 operand2))))))) (define-instruction lea (segment dst src) (:printer reg-reg/mem ((op #b1000110) (width 1))) (:emitter (assert (dword-reg-p dst)) (emit-byte segment #b10001101) (emit-ea segment src (reg-tn-encoding dst)))) ;;;; Flag control instructions. ;;; CLC -- Clear Carry Flag. ;;; (define-instruction clc (segment) (:printer byte ((op #b11111000))) (:emitter (emit-byte segment #b11111000))) ;;; CLD -- Clear Direction Flag. ;;; (define-instruction cld (segment) (:printer byte ((op #b11111100))) (:emitter (emit-byte segment #b11111100))) ;;; CLI -- Clear Iterrupt Enable Flag. ;;; (define-instruction cli (segment) (:printer byte ((op #b11111010))) (:emitter (emit-byte segment #b11111010))) ;;; CMC -- Complement Carry Flag. ;;; (define-instruction cmc (segment) (:printer byte ((op #b11110101))) (:emitter (emit-byte segment #b11110101))) ;;; LAHF -- Load AH into flags. ;;; (define-instruction lahf (segment) (:printer byte ((op #b10011111))) (:emitter (emit-byte segment #b10011111))) ;;; POPF -- Pop flags. ;;; (define-instruction popf (segment) (:printer byte ((op #b10011101))) (:emitter (emit-byte segment #b10011101))) ;;; PUSHF -- push flags. ;;; (define-instruction pushf (segment) (:printer byte ((op #b10011100))) (:emitter (emit-byte segment #b10011100))) ;;; SAHF -- Store AH into flags. ;;; (define-instruction sahf (segment) (:printer byte ((op #b10011110))) (:emitter (emit-byte segment #b10011110))) ;;; STC -- Set Carry Flag. ;;; (define-instruction stc (segment) (:printer byte ((op #b11111001))) (:emitter (emit-byte segment #b11111001))) ;;; STD -- Set Direction Flag. ;;; (define-instruction std (segment) (:printer byte ((op #b11111101))) (:emitter (emit-byte segment #b11111101))) ;;; STI -- Set Interrupt Enable Flag. ;;; (define-instruction sti (segment) (:printer byte ((op #b11111011))) (:emitter (emit-byte segment #b11111011))) ;;;; Arithmetic (defun emit-random-arith-inst (name segment dst src opcode &optional allow-constants) (let ((size (matching-operand-size dst src))) (maybe-emit-operand-size-prefix segment size) (cond ((integerp src) (cond ((and (not (eq size :byte)) (<= -128 src 127)) (emit-byte segment #b10000011) (emit-ea segment dst opcode) (emit-byte segment src)) ((accumulator-p dst) (emit-byte segment (dpb opcode (byte 3 3) (if (eq size :byte) #b00000100 #b00000101))) (emit-sized-immediate segment size src)) (t (emit-byte segment (if (eq size :byte) #b10000000 #b10000001)) (emit-ea segment dst opcode) (emit-sized-immediate segment size src)))) ((register-p src) (emit-byte segment (dpb opcode (byte 3 3) (if (eq size :byte) #b00000000 #b00000001))) (emit-ea segment dst (reg-tn-encoding src) allow-constants)) ((register-p dst) (emit-byte segment (dpb opcode (byte 3 3) (if (eq size :byte) #b00000010 #b00000011))) (emit-ea segment src (reg-tn-encoding dst) allow-constants)) (t (error "Bogus operands to ~A" name))))) (eval-when (compile eval) (defun arith-inst-printer-list (subop) `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010)))) (reg/mem-imm ((op (#b1000000 ,subop)))) (reg/mem-imm ((op (#b1000001 ,subop)) (imm nil :type signed-imm-byte))) (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))))) ) (define-instruction add (segment dst src) (:printer-list (arith-inst-printer-list #b000)) (:emitter (emit-random-arith-inst "ADD" segment dst src #b000))) (define-instruction adc (segment dst src) (:printer-list (arith-inst-printer-list #b010)) (:emitter (emit-random-arith-inst "ADC" segment dst src #b010))) (define-instruction sub (segment dst src) (:printer-list (arith-inst-printer-list #b101)) (:emitter (emit-random-arith-inst "SUB" segment dst src #b101))) (define-instruction sbb (segment dst src) (:printer-list (arith-inst-printer-list #b011)) (:emitter (emit-random-arith-inst "SBB" segment dst src #b011))) (define-instruction cmp (segment dst src) (:printer-list (arith-inst-printer-list #b111)) (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t))) (define-instruction inc (segment dst) ;; Register. (:printer reg-no-width ((op #b01000))) ;; Register/Memory (:printer reg/mem ((op '(#b1111111 #b000)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (cond ((and (not (eq size :byte)) (register-p dst)) (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst))) (t (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) (emit-ea segment dst #b000)))))) (define-instruction dec (segment dst) ;; Register. (:printer reg-no-width ((op #b01001))) ;; Register/Memory (:printer reg/mem ((op '(#b1111111 #b001)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (cond ((and (not (eq size :byte)) (register-p dst)) (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst))) (t (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) (emit-ea segment dst #b001)))))) (define-instruction neg (segment dst) (:printer reg/mem ((op '(#b1111011 #b011)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment dst #b011)))) (define-instruction aaa (segment) (:printer byte ((op #b00110111))) (:emitter (emit-byte segment #b00110111))) (define-instruction aas (segment) (:printer byte ((op #b00111111))) (:emitter (emit-byte segment #b00111111))) (define-instruction daa (segment) (:printer byte ((op #b00100111))) (:emitter (emit-byte segment #b00100111))) (define-instruction das (segment) (:printer byte ((op #b00101111))) (:emitter (emit-byte segment #b00101111))) (define-instruction mul (segment dst src) (:printer accum-reg/mem ((op '(#b1111011 #b100)))) (:emitter (let ((size (matching-operand-size dst src))) (assert (accumulator-p dst)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment src #b100)))) (define-instruction imul (segment dst &optional src1 src2) (:printer accum-reg/mem ((op '(#b1111011 #b101)))) (:printer ext-reg-reg/mem ((op #b1010111))) (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word)) '(:name :tab reg ", " reg/mem ", " imm)) (:printer reg-reg/mem ((op #b0110101) (width 1) (imm nil :type 'signed-imm-byte)) '(:name :tab reg ", " reg/mem ", " imm)) (:emitter (flet ((r/m-with-immed-to-reg (reg r/m immed) (let* ((size (matching-operand-size reg r/m)) (sx (and (not (eq size :byte)) (<= -128 immed 127)))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if sx #b01101011 #b01101001)) (emit-ea segment r/m (reg-tn-encoding reg)) (if sx (emit-byte segment immed) (emit-sized-immediate segment size immed))))) (cond (src2 (r/m-with-immed-to-reg dst src1 src2)) (src1 (if (integerp src1) (r/m-with-immed-to-reg dst dst src1) (let ((size (matching-operand-size dst src1))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (emit-byte segment #b10101111) (emit-ea segment src1 (reg-tn-encoding dst))))) (t (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment dst #b101))))))) (define-instruction div (segment dst src) (:printer accum-reg/mem ((op '(#b1111011 #b110)))) (:emitter (let ((size (matching-operand-size dst src))) (assert (accumulator-p dst)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment src #b110)))) (define-instruction idiv (segment dst src) (:printer accum-reg/mem ((op '(#b1111011 #b111)))) (:emitter (let ((size (matching-operand-size dst src))) (assert (accumulator-p dst)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment src #b111)))) (define-instruction aad (segment) (:printer two-bytes ((op '(#b11010101 #b00001010)))) (:emitter (emit-byte segment #b11010101) (emit-byte segment #b00001010))) (define-instruction aam (segment) (:printer two-bytes ((op '(#b11010100 #b00001010)))) (:emitter (emit-byte segment #b11010100) (emit-byte segment #b00001010))) ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL) ;;; (define-instruction cbw (segment) (:emitter (maybe-emit-operand-size-prefix segment :word) (emit-byte segment #b10011000))) ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX) ;;; (define-instruction cwde (segment) (:emitter (maybe-emit-operand-size-prefix segment :dword) (emit-byte segment #b10011000))) ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX) ;;; (define-instruction cwd (segment) (:emitter (maybe-emit-operand-size-prefix segment :word) (emit-byte segment #b10011001))) ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX) ;;; (define-instruction cdq (segment) (:emitter (maybe-emit-operand-size-prefix segment :dword) (emit-byte segment #b10011001))) ;;;; Logic. (defun emit-shift-inst (segment dst amount opcode) (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (multiple-value-bind (major-opcode immed) (case amount (:cl (values #b11010010 nil)) (1 (values #b11010000 nil)) (t (values #b11000000 t))) (emit-byte segment (if (eq size :byte) major-opcode (logior major-opcode 1))) (emit-ea segment dst opcode) (when immed (emit-byte segment amount))))) (eval-when (compile eval) (defun shift-inst-printer-list (subop) `((reg/mem ((op (#b1101000 ,subop))) (:name :tab reg/mem ", 1")) (reg/mem ((op (#b1101001 ,subop))) (:name :tab reg/mem ", " 'cl)) (reg/mem-imm ((op (#b1100000 ,subop)) (imm nil :type signed-imm-byte)))))) (define-instruction rol (segment dst amount) (:printer-list (shift-inst-printer-list #b000)) (:emitter (emit-shift-inst segment dst amount #b000))) (define-instruction ror (segment dst amount) (:printer-list (shift-inst-printer-list #b001)) (:emitter (emit-shift-inst segment dst amount #b001))) (define-instruction rcl (segment dst amount) (:printer-list (shift-inst-printer-list #b010)) (:emitter (emit-shift-inst segment dst amount #b010))) (define-instruction rcr (segment dst amount) (:printer-list (shift-inst-printer-list #b011)) (:emitter (emit-shift-inst segment dst amount #b011))) (define-instruction shl (segment dst amount) (:printer-list (shift-inst-printer-list #b100)) (:emitter (emit-shift-inst segment dst amount #b100))) (define-instruction shr (segment dst amount) (:printer-list (shift-inst-printer-list #b101)) (:emitter (emit-shift-inst segment dst amount #b101))) (define-instruction sar (segment dst amount) (:printer-list (shift-inst-printer-list #b111)) (:emitter (emit-shift-inst segment dst amount #b111))) (defun emit-double-shift (segment opcode dst src amt) (let ((size (matching-operand-size dst src))) (when (eq size :byte) (error "Double shifts can only be used with words.")) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (emit-byte segment (dpb opcode (byte 1 3) (if (eq amt :cl) #b10100101 #b10100100))) #+nil (emit-ea segment dst src) (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this (unless (eq amt :cl) (emit-byte segment amt)))) (eval-when (compile eval) (defun double-shift-inst-printer-list (op) `(#+nil (ext-reg-reg/mem-imm ((op ,(logior op #b100)) (imm nil :type signed-imm-byte))) (ext-reg-reg/mem ((op ,(logior op #b101))) (:name :tab reg/mem ", " 'cl))))) (define-instruction shld (segment dst src amt) (:declare (type (or (member :cl) (mod 32)) amt)) (:printer-list (double-shift-inst-printer-list #b10100000)) (:emitter (emit-double-shift segment #b0 dst src amt))) (define-instruction shrd (segment dst src amt) (:declare (type (or (member :cl) (mod 32)) amt)) (:printer-list (double-shift-inst-printer-list #b10101000)) (:emitter (emit-double-shift segment #b1 dst src amt))) (define-instruction and (segment dst src) (:printer-list (arith-inst-printer-list #b100)) (:emitter (emit-random-arith-inst "AND" segment dst src #b100))) (define-instruction test (segment this that) (:printer accum-imm ((op #b1010100))) (:printer reg/mem-imm ((op '(#b1111011 #b000)))) (:printer reg-reg/mem ((op #b1000010))) (:emitter (let ((size (matching-operand-size this that))) (maybe-emit-operand-size-prefix segment size) (flet ((test-immed-and-something (immed something) (cond ((accumulator-p something) (emit-byte segment (if (eq size :byte) #b10101000 #b10101001)) (emit-sized-immediate segment size immed)) (t (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment something #b000) (emit-sized-immediate segment size immed)))) (test-reg-and-something (reg something) (emit-byte segment (if (eq size :byte) #b10000100 #b10000101)) (emit-ea segment something (reg-tn-encoding reg)))) (cond ((integerp that) (test-immed-and-something that this)) ((integerp this) (test-immed-and-something this that)) ((register-p this) (test-reg-and-something this that)) ((register-p that) (test-reg-and-something that this)) (t (error "Bogus operans for TEST: ~S and ~S" this that))))))) (define-instruction or (segment dst src) (:printer-list (arith-inst-printer-list #b001)) (:emitter (emit-random-arith-inst "OR" segment dst src #b001))) (define-instruction xor (segment dst src) (:printer-list (arith-inst-printer-list #b110)) (:emitter (emit-random-arith-inst "XOR" segment dst src #b110))) (define-instruction not (segment dst) (:printer reg/mem ((op '(#b1111011 #b010)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment dst #b010)))) ;;;; String manipulation. (disassem:define-instruction-format (string-op 8 :include 'simple :default-printer '(:name width))) (define-instruction cmps (segment size) (:printer string-op ((op #b1010011))) (:emitter (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10100110 #b10100111)))) (define-instruction ins (segment acc) (:printer string-op ((op #b0110110))) (:emitter (let ((size (operand-size acc))) (assert (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b01101100 #b01101101))))) (define-instruction lods (segment acc) (:printer string-op ((op #b1010110))) (:emitter (let ((size (operand-size acc))) (assert (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10101100 #b10101101))))) (define-instruction movs (segment size) (:printer string-op ((op #b1010010))) (:emitter (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10100100 #b10100101)))) (define-instruction outs (segment acc) (:printer string-op ((op #b0110111))) (:emitter (let ((size (operand-size acc))) (assert (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b01101110 #b01101111))))) (define-instruction scas (segment acc) (:printer string-op ((op #b1010111))) (:emitter (let ((size (operand-size acc))) (assert (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10101110 #b10101111))))) (define-instruction stos (segment acc) (:printer string-op ((op #b1010101))) (:emitter (let ((size (operand-size acc))) (assert (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10101010 #b10101011))))) (define-instruction xlat (segment) (:printer byte ((op #b11010111))) (:emitter (emit-byte segment #b11010111))) (define-instruction rep (segment) (:emitter (emit-byte segment #b11110010))) (define-instruction repe (segment) (:printer byte ((op #b11110011))) (:emitter (emit-byte segment #b11110011))) (define-instruction repne (segment) (:printer byte ((op #b11110010))) (:emitter (emit-byte segment #b11110010))) ;;;; Bit Manipulation (define-instruction bsf (segment dst src) (:emitter (let ((size (matching-operand-size dst src))) (when (eq size :byte) (error "Can't scan bytes: ~S" src)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (emit-byte segment #b10111100) (emit-ea segment src (reg-tn-encoding dst))))) (define-instruction bsr (segment dst src) (:emitter (let ((size (matching-operand-size dst src))) (when (eq size :byte) (error "Can't scan bytes: ~S" src)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (emit-byte segment #b10111101) (emit-ea segment src (reg-tn-encoding dst))))) (defun emit-bit-test-and-mumble (segment src index opcode) (let ((size (operand-size src))) (when (eq size :byte) (error "Can't scan bytes: ~S" src)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (cond ((integerp index) (emit-byte segment #b10111010) (emit-ea segment src opcode) (emit-byte segment index)) (t (emit-byte segment (dpb opcode (byte 3 3) #b10000011)) (emit-ea segment src (reg-tn-encoding index)))))) (define-instruction bt (segment src index) (:emitter (emit-bit-test-and-mumble segment src index #b100))) (define-instruction btc (segment src index) (:emitter (emit-bit-test-and-mumble segment src index #b111))) (define-instruction btr (segment src index) (:emitter (emit-bit-test-and-mumble segment src index #b110))) (define-instruction bts (segment src index) (:emitter (emit-bit-test-and-mumble segment src index #b101))) ;;;; Control transfer. (eval-when (compile load eval) (defparameter condition-name-vec (let ((vec (make-array 16 :initial-element nil))) (dolist (cond conditions) (when (null (aref vec (cdr cond))) (setf (aref vec (cdr cond)) (car cond)))) vec))) (disassem:define-argument-type condition-code :printer condition-name-vec) (disassem:define-argument-type displacement :sign-extend t :use-label #'offset-next) (disassem:define-instruction-format (short-cond-jump 16) (op :field (byte 4 4)) (cc :field (byte 4 0) :type 'condition-code) (label :field (byte 8 8) :type 'displacement)) (disassem:define-instruction-format (short-jump 16 :default-printer '(:name :tab label)) (const :field (byte 4 4) :value #b1110) (op :field (byte 4 0)) (label :field (byte 8 8) :type 'displacement)) (disassem:define-instruction-format (near-cond-jump 16) (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000)) (cc :field (byte 4 8) :type 'condition-code) ;; The disassembler currently doesn't let you have an instruction > 32 bits ;; long, so we fake it by using a prefilter to read the offset. (label :type 'displacement :prefilter #'read-signed-imm-dword)) (disassem:define-instruction-format (near-jump 8 :default-printer '(:name :tab label)) (op :field (byte 8 0)) ;; The disassembler currently doesn't let you have an instruction > 32 bits ;; long, so we fake it by using a prefilter to read the address. (label :type 'displacement :prefilter #'read-signed-imm-dword)) (define-instruction call (segment where) (:printer near-jump ((op #b11101000))) (:printer reg/mem ((op '(#b1111111 #b010)) (width 1))) (:emitter (typecase where (label (emit-byte segment #b11101000) (emit-back-patch segment 4 #'(lambda (segment posn) (emit-dword segment (- (label-position where) (+ posn 4)))))) (fixup (emit-byte segment #b11101000) (emit-relative-fixup segment where)) (t (emit-byte segment #b11111111) (emit-ea segment where #b010))))) (defun emit-byte-displacement-backpatch (segment target) (emit-back-patch segment 1 #'(lambda (segment posn) (let ((disp (- (label-position target) (1+ posn)))) (assert (<= -128 disp 127)) (emit-byte segment disp))))) (define-instruction jmp (segment cond &optional where) ;; conditional jumps (:printer short-cond-jump ((op #b0111)) '('j cc :tab label)) (:printer near-cond-jump () '('j cc :tab label)) ;; unconditional jumps (:printer short-jump ((op #b1011))) (:printer near-jump ((op #b11101001)) ) (:printer reg/mem ((op '(#b1111111 #b100)) (width 1))) (:emitter (cond (where (emit-chooser segment 6 2 #'(lambda (segment posn delta-if-after) (let ((disp (- (label-position where posn delta-if-after) (+ posn 2)))) (when (<= -128 disp 127) (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01110000)) (emit-byte-displacement-backpatch segment where) t))) #'(lambda (segment posn) (let ((disp (- (label-position where) (+ posn 6)))) (emit-byte segment #b00001111) (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10000000)) (emit-dword segment disp))))) ((label-p (setq where cond)) (emit-chooser segment 5 0 #'(lambda (segment posn delta-if-after) (let ((disp (- (label-position where posn delta-if-after) (+ posn 2)))) (when (<= -128 disp 127) (emit-byte segment #b11101011) (emit-byte-displacement-backpatch segment where) t))) #'(lambda (segment posn) (let ((disp (- (label-position where) (+ posn 5)))) (emit-byte segment #b11101001) (emit-dword segment disp)) ))) ((fixup-p where) (emit-byte segment #b11101001) (emit-relative-fixup segment where)) (t (unless (or (ea-p where) (tn-p where)) (error "Don't know what to do with ~A" where)) (emit-byte segment #b11111111) (emit-ea segment where #b100))))) (define-instruction jmp-short (segment label) (:emitter (emit-byte segment #b11101011) (emit-byte-displacement-backpatch segment label))) (define-instruction ret (segment &optional stack-delta) (:printer byte ((op #b11000011))) (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16)) '(:name :tab imm)) (:emitter (cond (stack-delta (emit-byte segment #b11000010) (emit-word segment stack-delta)) (t (emit-byte segment #b11000011))))) (define-instruction jecxz (segment target) (:printer short-jump ((op #b0011))) (:emitter (emit-byte segment #b11100011) (emit-byte-displacement-backpatch segment target))) (define-instruction loop (segment target) (:printer short-jump ((op #b0010))) (:emitter (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!! (emit-byte-displacement-backpatch segment target))) (define-instruction loopz (segment target) (:printer short-jump ((op #b0001))) (:emitter (emit-byte segment #b11100001) (emit-byte-displacement-backpatch segment target))) (define-instruction loopnz (segment target) (:printer short-jump ((op #b0000))) (:emitter (emit-byte segment #b11100000) (emit-byte-displacement-backpatch segment target))) ;;;; Conditional byte set. (disassem:define-instruction-format (cond-set 24 :default-printer '('set cc :tab reg/mem)) (prefix :field (byte 8 0) :value #b00001111) (op :field (byte 4 12) :value #b1001) (cc :field (byte 4 8) :type 'condition-code) (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem) (reg :field (byte 3 19) :value #b000)) (define-instruction set (segment dst cond) (:printer cond-set ()) (:emitter (emit-byte segment #b00001111) (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000)) (emit-ea segment dst #b000))) ;;;; Enter/Leave (disassem:define-instruction-format (enter-format 24 :default-printer '(:name :tab disp (:unless (:constant 0) ", " level))) (op :field (byte 8 0)) (disp :field (byte 16 8)) (level :field (byte 8 16))) (define-instruction enter (segment disp &optional (level 0)) (:declare (type (unsigned-byte 16) disp) (type (unsigned-byte 8) level)) (:emitter (emit-byte segment #b11001000) (emit-word segment disp) (emit-byte segment level))) (define-instruction leave (segment) (:printer byte ((op #b11001001))) (:emitter (emit-byte segment #b11001001))) ;;;; Interrupt instructions. (disassem:define-instruction-format (break 16 :default-printer '(:name :tab code)) (op :field (byte 8 0) :value #b11001100) (code :field (byte 8 8))) (define-emitter emit-break-inst 16 (byte 8 0) (byte 8 8)) (defun snarf-error-junk (sap offset &optional length-only) (let* ((length (system:sap-ref-8 sap offset)) (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type system:system-area-pointer sap) (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) (cond (length-only (values 0 (1+ length) nil nil)) (t (kernel:copy-from-system-area sap (* byte-bits (1+ offset)) vector (* word-bits vector-data-offset) (* length byte-bits)) (collect ((sc-offsets) (lengths)) (lengths 1) ; the length byte (let* ((index 0) (error-number (c::read-var-integer vector index))) (lengths index) (loop (when (>= index length) (return)) (let ((old-index index)) (sc-offsets (c::read-var-integer vector index)) (lengths (- index old-index)))) (values error-number (1+ length) (sc-offsets) (lengths)))))))) (defmacro break-cases (breaknum &body cases) (let ((bn-temp (gensym))) (collect ((clauses)) (dolist (case cases) (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) `(let ((,bn-temp ,breaknum)) (cond ,@(clauses)))))) (defun break-control (chunk inst stream dstate) (declare (ignore inst)) (flet ((nt (x) (if stream (disassem:note x dstate)))) (case (break-code chunk dstate) (#.vm:error-trap (nt "Error trap") (disassem:handle-break-args #'snarf-error-junk stream dstate)) (#.vm:cerror-trap (nt "Cerror trap") (disassem:handle-break-args #'snarf-error-junk stream dstate)) (#.vm:breakpoint-trap (nt "Breakpoint trap")) (#.vm:pending-interrupt-trap (nt "Pending interrupt trap")) (#.vm:halt-trap (nt "Halt trap")) (#.vm:function-end-breakpoint-trap (nt "Function end breakpoint trap")) ))) (define-instruction break (segment code) (:declare (type (unsigned-byte 8) code)) (:printer break ((op #b11001100)) '(:name :tab code) :control #'break-control ) (:emitter (emit-break-inst segment #b11001100 code))) (define-instruction int (segment number) (:declare (type (unsigned-byte 8) number)) (:emitter (etypecase number ((member 3) (emit-byte segment #b11001100)) ((unsigned-byte 8) (emit-byte segment #b11001101) (emit-byte segment number))))) (define-instruction into (segment) (:printer byte ((op #b11001110))) (:emitter (emit-byte segment #b11001110))) (define-instruction bound (segment reg bounds) (:emitter (let ((size (matching-operand-size reg bounds))) (when (eq size :byte) (error "Can't bounds-test bytes: ~S" reg)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b01100010) (emit-ea segment bounds (reg-tn-encoding reg))))) (define-instruction iret (segment) (:printer byte ((op #b11001111))) (:emitter (emit-byte segment #b11001111))) ;;;; Processor control (define-instruction hlt (segment) (:printer byte ((op #b11110100))) (:emitter (emit-byte segment #b11110100))) (define-instruction nop (segment) (:printer byte ((op #b10010000))) (:emitter (emit-byte segment #b10010000))) (define-instruction wait (segment) (:printer byte ((op #b10011011))) (:emitter (emit-byte segment #b10011011))) (define-instruction lock (segment) (:printer byte ((op #b11110000))) (:emitter (emit-byte segment #b11110000))) ;;;; Random hackery (define-instruction byte (segment byte) (:emitter (emit-byte segment byte))) (define-instruction word (segment word) (:emitter (emit-word segment word))) (define-instruction dword (segment dword) (:emitter (emit-dword segment dword))) (defun emit-header-data (segment type) (emit-back-patch segment 4 #'(lambda (segment posn) (emit-dword segment (logior type (ash (+ posn (component-header-length)) (- type-bits word-shift))))))) (define-instruction function-header-word (segment) (:emitter (emit-header-data segment function-header-type))) (define-instruction lra-header-word (segment) (:emitter (emit-header-data segment return-pc-header-type))) ;;; ---------------------------------------------------------------- ;;; added by jrd. fp instructions ;;; ;;; ;;; we treat the single-precision and double-precision variants ;;; as separate instructions ;;; ;;; ;;; load single to st(0) ;;; (define-instruction fld (segment source) (:printer floating-point ((op '(#b001 #b000)))) (:emitter (emit-byte segment #b11011001) (emit-fp-op segment source #b000))) ;;; ;;; load double to st(0) ;;; (define-instruction fldd (segment source) (:printer floating-point ((op '(#b101 #b000)))) (:printer floating-point-fp ((op '(#b001 #b000)))) (:emitter (if (fp-reg-tn-p source) (emit-byte segment #b11011001) (emit-byte segment #b11011101)) (emit-fp-op segment source #b000))) ;;; ;;; store single from st(0) ;;; (define-instruction fst (segment dest) (:printer floating-point ((op '(#b001 #b010)))) (:emitter (cond ((fp-reg-tn-p dest) (emit-byte segment #b11011101) (emit-fp-op segment dest #b010)) (t (emit-byte segment #b11011001) (emit-fp-op segment dest #b010))))) ;;; ;;; store double from st(0) ;;; (define-instruction fstd (segment dest) (:printer floating-point ((op '(#b101 #b010)))) (:printer floating-point-fp ((op '(#b101 #b010)))) (:emitter (cond ((fp-reg-tn-p dest) (emit-byte segment #b11011101) (emit-fp-op segment dest #b010)) (t (emit-byte segment #b11011101) (emit-fp-op segment dest #b010))))) ;;; Arithmetic ops are all done with at least one operand at top of ;;; stack. The other operand is is another register or a 32/64 bit ;;; memory loc. ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note ;;; that these conflict with the Gdb conventions for binops. To reduce ;;; the confusion I've added comments showing the mathamatical ;;; operation and the two syntaxes. By the ASM386 convention the ;;; instruction syntax is: ;;; ;;; Fop Source ;;; or Fop Destination, Source ;;; ;;; If only one operand is given then it is the source and the ;;; destination is ST(0). There are reversed forms of the fsub and ;;; fdiv instructions inducated by an 'R' suffix. ;;; ;;; The mathematical operation for the non-reverse form is always: ;;; destination = destination op source ;;; ;;; For the reversed form it is: ;;; destination = source op destination ;;; ;;; The instructions below only accept one operand at present which is ;;; usually the source. I've hack in extra instructions to implement ;;; the fops with a ST(i) destination, these have a -sti suffix and ;;; the operand is the destination with the source being ST(0). ;;; ;;; Add single ;;; st(0) = st(0) + memory or st(i) ;;; (define-instruction fadd (segment source) (:printer floating-point ((op '(#b000 #b000)))) (:emitter (emit-byte segment #b11011000) (emit-fp-op segment source #b000))) ;;; ;;; Add double ;;; st(0) = st(0) + memory or st(i) ;;; (define-instruction faddd (segment source) (:printer floating-point ((op '(#b100 #b000)))) (:printer floating-point-fp ((op '(#b000 #b000)))) (:emitter (if (fp-reg-tn-p source) (emit-byte segment #b11011000) (emit-byte segment #b11011100)) (emit-fp-op segment source #b000))) ;;; ;;; Add double destination st(i) ;;; st(i) = st(0) + st(i) ;;; (define-instruction fadd-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b000)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b000))) ;;; With pop (define-instruction faddp-sti (segment destination) (:printer floating-point-fp ((op '(#b110 #b000)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011110) (emit-fp-op segment destination #b000))) ;;; ;;; Subtract single ;;; st(0) = st(0) - memory or st(i) ;;; (define-instruction fsub (segment source) (:printer floating-point ((op '(#b000 #b100)))) (:emitter (emit-byte segment #b11011000) (emit-fp-op segment source #b100))) ;;; ;;; Subtract single, reverse ;;; st(0) = memory or st(i) - st(0) ;;; (define-instruction fsubr (segment source) (:printer floating-point ((op '(#b000 #b101)))) (:emitter (emit-byte segment #b11011000) (emit-fp-op segment source #b101))) ;;; ;;; Subtract double ;;; st(0) = st(0) - memory or st(i) ;;; (define-instruction fsubd (segment source) (:printer floating-point ((op '(#b100 #b100)))) (:printer floating-point-fp ((op '(#b000 #b100)))) (:emitter (if (fp-reg-tn-p source) (emit-byte segment #b11011000) (emit-byte segment #b11011100)) (emit-fp-op segment source #b100))) ;;; ;;; Subtract double, reverse ;;; st(0) = memory or st(i) - st(0) ;;; (define-instruction fsubrd (segment source) (:printer floating-point ((op '(#b100 #b101)))) (:printer floating-point-fp ((op '(#b000 #b101)))) (:emitter (if (fp-reg-tn-p source) (emit-byte segment #b11011000) (emit-byte segment #b11011100)) (emit-fp-op segment source #b101))) ;;; ;;; Subtract double, destination st(i) ;;; st(i) = st(i) - st(0) ;;; ;;; ASM386 syntax: FSUB ST(i), ST ;;; Gdb syntax: fsubr %st,%st(i) ;;; (define-instruction fsub-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b101)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b101))) ;;; With a pop (define-instruction fsubp-sti (segment destination) (:printer floating-point-fp ((op '(#b110 #b101)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011110) (emit-fp-op segment destination #b101))) ;;; ;;; Subtract double, reverse, destination st(i) ;;; st(i) = st(0) - st(i) ;;; ;;; ASM386 syntax: FSUBR ST(i), ST ;;; Gdb syntax: fsub %st,%st(i) ;;; (define-instruction fsubr-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b100)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b100))) ;;; With a pop (define-instruction fsubrp-sti (segment destination) (:printer floating-point-fp ((op '(#b110 #b100)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011110) (emit-fp-op segment destination #b100))) ;;; ;;; Multiply single ;;; st(0) = st(0) * memory or st(i) ;;; (define-instruction fmul (segment source) (:printer floating-point ((op '(#b000 #b001)))) (:emitter (emit-byte segment #b11011000) (emit-fp-op segment source #b001))) ;;; ;;; Multiply double ;;; st(0) = st(0) * memory or st(i) ;;; (define-instruction fmuld (segment source) (:printer floating-point ((op '(#b100 #b001)))) (:printer floating-point-fp ((op '(#b000 #b001)))) (:emitter (if (fp-reg-tn-p source) (emit-byte segment #b11011000) (emit-byte segment #b11011100)) (emit-fp-op segment source #b001))) ;;; ;;; Multiply double, destination st(i) ;;; st(i) = st(i) * st(0) ;;; (define-instruction fmul-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b001)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b001))) ;;; ;;; Divide single ;;; st(0) = st(0) / memory or st(i) ;;; (define-instruction fdiv (segment source) (:printer floating-point ((op '(#b000 #b110)))) (:emitter (emit-byte segment #b11011000) (emit-fp-op segment source #b110))) ;;; ;;; Divide single, reverse ;;; st(0) = memory or st(i) / st(0) ;;; (define-instruction fdivr (segment source) (:printer floating-point ((op '(#b000 #b111)))) (:emitter (emit-byte segment #b11011000) (emit-fp-op segment source #b111))) ;;; ;;; Divide double ;;; st(0) = st(0) / memory or st(i) ;;; (define-instruction fdivd (segment source) (:printer floating-point ((op '(#b100 #b110)))) (:printer floating-point-fp ((op '(#b000 #b110)))) (:emitter (if (fp-reg-tn-p source) (emit-byte segment #b11011000) (emit-byte segment #b11011100)) (emit-fp-op segment source #b110))) ;;; ;;; Divide double, reverse ;;; st(0) = memory or st(i) / st(0) ;;; (define-instruction fdivrd (segment source) (:printer floating-point ((op '(#b100 #b111)))) (:printer floating-point-fp ((op '(#b000 #b111)))) (:emitter (if (fp-reg-tn-p source) (emit-byte segment #b11011000) (emit-byte segment #b11011100)) (emit-fp-op segment source #b111))) ;;; ;;; Divide double, destination st(i) ;;; st(i) = st(i) / st(0) ;;; ;;; ASM386 syntax: FDIV ST(i), ST ;;; Gdb syntax: fdivr %st,%st(i) ;;; (define-instruction fdiv-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b111)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b111))) ;;; ;;; Divide double, reverse, destination st(i) ;;; st(i) = st(0) / st(i) ;;; ;;; ASM386 syntax: FDIVR ST(i), ST ;;; Gdb syntax: fdiv %st,%st(i) ;;; (define-instruction fdivr-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b110)))) (:emitter (assert (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b110))) ;;; ;;; exchange fr0 with fr(n). no double variant ;;; (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)) (lisp:break)) (emit-byte segment #b11011001) (emit-fp-op segment source #b001))) ;;; ;;; ;;; push 32-bit integer to st0 ;;; (define-instruction fild (segment source) (:printer floating-point ((op '(#b011 #b000)))) (:emitter (emit-byte segment #b11011011) (emit-fp-op segment source #b000))) ;;; ;;; push 64-bit integer to st0 ;;; (define-instruction fildl (segment source) (:printer floating-point ((op '(#b111 #b101)))) (:emitter (emit-byte segment #b11011111) (emit-fp-op segment source #b101))) ;;; ;;; store 32-bit integer ;;; (define-instruction fist (segment dest) (:printer floating-point ((op '(#b011 #b010)))) (:emitter (emit-byte segment #b11011011) (emit-fp-op segment dest #b010))) ;;; ;;; Store and pop 32-bit interger ;;; (define-instruction fistp (segment dest) (:printer floating-point ((op '(#b011 #b011)))) (:emitter (emit-byte segment #b11011011) (emit-fp-op segment dest #b011))) ;;; ;;; store single from st(0) and pop ;;; (define-instruction fstp (segment dest) (:printer floating-point ((op '(#b001 #b011)))) (:printer floating-point-fp ((op '(#b101 #b011)))) (:emitter (cond ((fp-reg-tn-p dest) (emit-byte segment #b11011101) (emit-fp-op segment dest #b011)) (t (emit-byte segment #b11011001) (emit-fp-op segment dest #b011))))) ;;; ;;; decrement stack-top pointer ;;; (define-instruction fdecstp (segment) (:printer floating-point-no ((op #b10110))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110110))) ;;; ;;; increment stack-top pointer ;;; (define-instruction fincstp (segment) (:printer floating-point-no ((op #b10111))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110111))) ;;; ;;; free fp register ;;; (define-instruction ffree (segment dest) (:printer floating-point-fp ((op '(#b101 #b000)))) (:emitter (emit-byte segment #b11011101) (emit-fp-op segment dest #b000))) (define-instruction fabs (segment) (:printer floating-point-no ((op #b00001))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11100001))) (define-instruction fchs (segment) (:printer floating-point-no ((op #b00000))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11100000))) (define-instruction frndint(segment) (:printer floating-point-no ((op #b11100))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11111100))) ;;; ;;; Initialize NPX ;;; (define-instruction fninit(segment) (:printer floating-point-5 ((op #b00011))) (:emitter (emit-byte segment #b11011011) (emit-byte segment #b11100011))) ;;; ;;; Store Status Word to AX ;;; (define-instruction fnstsw(segment) (:printer floating-point-st ((op #b00000))) (:emitter (emit-byte segment #b11011111) (emit-byte segment #b11100000))) ;;; ;;; Load Control Word ;;; ;;; src must be a memory location (define-instruction fldcw(segment src) (:printer floating-point ((op '(#b001 #b101)))) (:emitter (emit-byte segment #b11011001) (emit-fp-op segment src #b101))) ;;; ;;; Store Control Word ;;; (define-instruction fnstcw(segment dst) (:printer floating-point ((op '(#b001 #b111)))) (:emitter (emit-byte segment #b11011001) (emit-fp-op segment dst #b111))) ;;; ;;; Store FP Environment ;;; (define-instruction fstenv(segment dst) (:printer floating-point ((op '(#b001 #b110)))) (:emitter (emit-byte segment #b11011001) (emit-fp-op segment dst #b110))) ;;; ;;; Retore FP Environment ;;; (define-instruction fldenv(segment src) (:printer floating-point ((op '(#b001 #b100)))) (:emitter (emit-byte segment #b11011001) (emit-fp-op segment src #b100))) ;;; ;;; Save FP State ;;; (define-instruction fsave(segment dst) (:printer floating-point ((op '(#b101 #b110)))) (:emitter (emit-byte segment #b11011101) (emit-fp-op segment dst #b110))) ;;; ;;; Restore FP State ;;; (define-instruction frstor(segment src) (:printer floating-point ((op '(#b101 #b100)))) (:emitter (emit-byte segment #b11011101) (emit-fp-op segment src #b100))) ;;; ;;; Clear exceptions ;;; (define-instruction fnclex(segment) (:printer floating-point-5 ((op #b00010))) (:emitter (emit-byte segment #b11011011) (emit-byte segment #b11100010))) ;;; ;;; Comparison ;;; (define-instruction fcom(segment src) (:printer floating-point ((op '(#b000 #b010)))) (:emitter (emit-byte segment #b11011000) (emit-fp-op segment src #b010))) (define-instruction fcomd(segment src) (:printer floating-point ((op '(#b100 #b010)))) (:printer floating-point-fp ((op '(#b000 #b010)))) (:emitter (if (fp-reg-tn-p src) (emit-byte segment #b11011000) (emit-byte segment #b11011100)) (emit-fp-op segment src #b010))) ;;; ;;; Unordered comparison ;;; (define-instruction fucom(segment src) ;; XX Printer conflicts with frstor ;; (:printer floating-point ((op '(#b101 #b100)))) (:emitter (assert (fp-reg-tn-p src)) (emit-byte segment #b11011101) (emit-fp-op segment src #b100))) (define-instruction ftst (segment) (:printer floating-point-no ((op #b00100))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11100100))) ;;; ;;; 80387 Specials ;;; ;;; (define-instruction fsqrt(segment) (:printer floating-point-no ((op #b11010))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11111010))) (define-instruction fscale(segment) (:printer floating-point-no ((op #b11101))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11111101))) (define-instruction fxtract(segment) (:printer floating-point-no ((op #b10100))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110100))) (define-instruction fsin(segment) (:printer floating-point-no ((op #b11110))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11111110))) (define-instruction fcos(segment) (:printer floating-point-no ((op #b11111))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11111111))) (define-instruction fprem1(segment) (:printer floating-point-no ((op #b10101))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110101))) (define-instruction fprem(segment) (:printer floating-point-no ((op #b11000))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11111000))) (define-instruction fxam (segment) (:printer floating-point-no ((op #b00101))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11100101))) ;;; These do push/pop to stack and need special handling ;;; in any VOPs that use them. See the book. ;; st0 <- st1*log2(st0) (define-instruction fyl2x(segment) ; POPS STACK (:printer floating-point-no ((op #b10001))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110001))) (define-instruction fyl2xp1(segment) (:printer floating-point-no ((op #b11001))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11111001))) (define-instruction f2xm1(segment) (:printer floating-point-no ((op #b10000))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110000))) (define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan (:printer floating-point-no ((op #b10010))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110010))) (define-instruction fpatan(segment) ; POPS STACK (:printer floating-point-no ((op #b10011))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11110011))) ;;; load constant (define-instruction fldz(segment) (:printer floating-point-no ((op #b01110))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101110))) (define-instruction fld1(segment) (:printer floating-point-no ((op #b01000))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101000))) (define-instruction fldpi(segment) (:printer floating-point-no ((op #b01011))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101011))) (define-instruction fldl2t(segment) (:printer floating-point-no ((op #b01001))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101001))) (define-instruction fldl2e(segment) (:printer floating-point-no ((op #b01010))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101010))) (define-instruction fldlg2(segment) (:printer floating-point-no ((op #b01100))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101100))) (define-instruction fldln2(segment) (:printer floating-point-no ((op #b01101))) (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101101)))