src/compiler/x86/insts.lisp

   1 ;;;; that part of the description of the x86 instruction set (for
   2 ;;;; 80386 and above) which can live on the cross-compilation host
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14 ;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
  15 ;;; I wonder whether the separation of the disassembler from the
  16 ;;; virtual machine is valid or adds value.
  17
  18 (file-comment
  19   "$Header$")
  20
  21 ;;; FIXME: In CMU CL, the code in this file seems to be fully
  22 ;;; compiled, not byte compiled. I'm not sure that's reasonable:
  23 ;;; there's a lot of code in this file, and considering the overall
  24 ;;; speed of the compiler, having some byte-interpretation overhead
  25 ;;; for every few bytes emitted doesn't seem likely to be noticeable.
  26 ;;; I'd like to see what happens if I come back and byte-compile this
  27 ;;; file.
  28
  29 ;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
  30 (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
  31
  32 (deftype reg () '(unsigned-byte 3))
  33 \f
  34 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  35
  36 (defun offset-next (value dstate)
  37   (declare (type integer value)
  38            (type sb!disassem:disassem-state dstate))
  39   (+ (sb!disassem:dstate-next-addr dstate) value))
  40
  41 (defparameter *default-address-size*
  42   ;; Actually, :DWORD is the only one really supported.
  43   :dword)
  44
  45 (defparameter *byte-reg-names*
  46   #(al cl dl bl ah ch dh bh))
  47 (defparameter *word-reg-names*
  48   #(ax cx dx bx sp bp si di))
  49 (defparameter *dword-reg-names*
  50   #(eax ecx edx ebx esp ebp esi edi))
  51
  52 (defun print-reg-with-width (value width stream dstate)
  53   (declare (ignore dstate))
  54   (princ (aref (ecase width
  55                  (:byte *byte-reg-names*)
  56                  (:word *word-reg-names*)
  57                  (:dword *dword-reg-names*))
  58                value)
  59          stream)
  60   ;; XXX plus should do some source-var notes
  61   )
  62
  63 (defun print-reg (value stream dstate)
  64   (declare (type reg value)
  65            (type stream stream)
  66            (type sb!disassem:disassem-state dstate))
  67   (print-reg-with-width value
  68                         (sb!disassem:dstate-get-prop dstate 'width)
  69                         stream
  70                         dstate))
  71
  72 (defun print-word-reg (value stream dstate)
  73   (declare (type reg value)
  74            (type stream stream)
  75            (type sb!disassem:disassem-state dstate))
  76   (print-reg-with-width value
  77                         (or (sb!disassem:dstate-get-prop dstate 'word-width)
  78                             +default-operand-size+)
  79                         stream
  80                         dstate))
  81
  82 (defun print-byte-reg (value stream dstate)
  83   (declare (type reg value)
  84            (type stream stream)
  85            (type sb!disassem:disassem-state dstate))
  86   (print-reg-with-width value :byte stream dstate))
  87
  88 (defun print-addr-reg (value stream dstate)
  89   (declare (type reg value)
  90            (type stream stream)
  91            (type sb!disassem:disassem-state dstate))
  92   (print-reg-with-width value *default-address-size* stream dstate))
  93
  94 (defun print-reg/mem (value stream dstate)
  95   (declare (type (or list reg) value)
  96            (type stream stream)
  97            (type sb!disassem:disassem-state dstate))
  98   (if (typep value 'reg)
  99       (print-reg value stream dstate)
 100       (print-mem-access value stream nil dstate)))
 101
 102 ;; Same as print-reg/mem, but prints an explicit size indicator for
 103 ;; memory references.
 104 (defun print-sized-reg/mem (value stream dstate)
 105   (declare (type (or list reg) value)
 106            (type stream stream)
 107            (type sb!disassem:disassem-state dstate))
 108   (if (typep value 'reg)
 109       (print-reg value stream dstate)
 110       (print-mem-access value stream t dstate)))
 111
 112 (defun print-byte-reg/mem (value stream dstate)
 113   (declare (type (or list reg) value)
 114            (type stream stream)
 115            (type sb!disassem:disassem-state dstate))
 116   (if (typep value 'reg)
 117       (print-byte-reg value stream dstate)
 118       (print-mem-access value stream t dstate)))
 119
 120 (defun print-label (value stream dstate)
 121   (declare (ignore dstate))
 122   (sb!disassem:princ16 value stream))
 123
 124 ;;; Returns either an integer, meaning a register, or a list of
 125 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
 126 ;;; may be missing or nil to indicate that it's not used or has the
 127 ;;; obvious default value (e.g., 1 for the index-scale).
 128 (defun prefilter-reg/mem (value dstate)
 129   (declare (type list value)
 130            (type sb!disassem:disassem-state dstate))
 131   (let ((mod (car value))
 132         (r/m (cadr value)))
 133     (declare (type (unsigned-byte 2) mod)
 134              (type (unsigned-byte 3) r/m))
 135     (cond ((= mod #b11)
 136            ;; registers
 137            r/m)
 138           ((= r/m #b100)
 139            ;; sib byte
 140            (let ((sib (sb!disassem:read-suffix 8 dstate)))
 141              (declare (type (unsigned-byte 8) sib))
 142              (let ((base-reg (ldb (byte 3 0) sib))
 143                    (index-reg (ldb (byte 3 3) sib))
 144                    (index-scale (ldb (byte 2 6) sib)))
 145                (declare (type (unsigned-byte 3) base-reg index-reg)
 146                         (type (unsigned-byte 2) index-scale))
 147                (let* ((offset
 148                        (case mod
 149                          (#b00
 150                           (if (= base-reg #b101)
 151                               (sb!disassem:read-signed-suffix 32 dstate)
 152                               nil))
 153                          (#b01
 154                           (sb!disassem:read-signed-suffix 8 dstate))
 155                          (#b10
 156                           (sb!disassem:read-signed-suffix 32 dstate)))))
 157                  (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
 158                        offset
 159                        (if (= index-reg #b100) nil index-reg)
 160                        (ash 1 index-scale))))))
 161           ((and (= mod #b00) (= r/m #b101))
 162            (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
 163           ((= mod #b00)
 164            (list r/m))
 165           ((= mod #b01)
 166            (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
 167           (t                            ; (= mod #b10)
 168            (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
 169
 170
 171 ;;; This is a sort of bogus prefilter that just stores the info globally for
 172 ;;; other people to use; it probably never gets printed.
 173 (defun prefilter-width (value dstate)
 174   (setf (sb!disassem:dstate-get-prop dstate 'width)
 175         (if (zerop value)
 176             :byte
 177             (let ((word-width
 178                    ;; set by a prefix instruction
 179                    (or (sb!disassem:dstate-get-prop dstate 'word-width)
 180                        +default-operand-size+)))
 181               (when (not (eql word-width +default-operand-size+))
 182                 ;; Reset it.
 183                 (setf (sb!disassem:dstate-get-prop dstate 'word-width)
 184                       +default-operand-size+))
 185               word-width))))
 186
 187 (defun read-address (value dstate)
 188   (declare (ignore value))              ; always nil anyway
 189   (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
 190
 191 (defun width-bits (width)
 192   (ecase width
 193     (:byte 8)
 194     (:word 16)
 195     (:dword 32)
 196     (:float 32)
 197     (:double 64)))
 198
 199 ) ; EVAL-WHEN
 200 \f
 201 ;;;; disassembler argument types
 202
 203 (sb!disassem:define-argument-type displacement
 204   :sign-extend t
 205   :use-label #'offset-next)
 206
 207 (sb!disassem:define-argument-type accum
 208   :printer #'(lambda (value stream dstate)
 209                (declare (ignore value)
 210                         (type stream stream)
 211                         (type sb!disassem:disassem-state dstate))
 212                (print-reg 0 stream dstate))
 213   )
 214
 215 (sb!disassem:define-argument-type word-accum
 216   :printer #'(lambda (value stream dstate)
 217                (declare (ignore value)
 218                         (type stream stream)
 219                         (type sb!disassem:disassem-state dstate))
 220                (print-word-reg 0 stream dstate)))
 221
 222 (sb!disassem:define-argument-type reg
 223   :printer #'print-reg)
 224
 225 (sb!disassem:define-argument-type addr-reg
 226   :printer #'print-addr-reg)
 227
 228 (sb!disassem:define-argument-type word-reg
 229   :printer #'print-word-reg)
 230
 231 (sb!disassem:define-argument-type imm-addr
 232   :prefilter #'read-address
 233   :printer #'print-label)
 234
 235 (sb!disassem:define-argument-type imm-data
 236   :prefilter #'(lambda (value dstate)
 237                  (declare (ignore value)) ; always nil anyway
 238                  (sb!disassem:read-suffix
 239                   (width-bits (sb!disassem:dstate-get-prop dstate 'width))
 240                   dstate))
 241   )
 242
 243 (sb!disassem:define-argument-type signed-imm-data
 244   :prefilter #'(lambda (value dstate)
 245                  (declare (ignore value)) ; always nil anyway
 246                  (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
 247                    (sb!disassem:read-signed-suffix (width-bits width) dstate)))
 248   )
 249
 250 (sb!disassem:define-argument-type signed-imm-byte
 251   :prefilter #'(lambda (value dstate)
 252                  (declare (ignore value)) ; always nil anyway
 253                  (sb!disassem:read-signed-suffix 8 dstate)))
 254
 255 (sb!disassem:define-argument-type signed-imm-dword
 256   :prefilter #'(lambda (value dstate)
 257                  (declare (ignore value))               ; always nil anyway
 258                  (sb!disassem:read-signed-suffix 32 dstate)))
 259
 260 (sb!disassem:define-argument-type imm-word
 261   :prefilter #'(lambda (value dstate)
 262                  (declare (ignore value)) ; always nil anyway
 263                  (let ((width
 264                         (or (sb!disassem:dstate-get-prop dstate 'word-width)
 265                             +default-operand-size+)))
 266                    (sb!disassem:read-suffix (width-bits width) dstate))))
 267
 268 ;;; needed for the ret imm16 instruction
 269 (sb!disassem:define-argument-type imm-word-16
 270   :prefilter #'(lambda (value dstate)
 271                  (declare (ignore value)) ; always nil anyway
 272                  (sb!disassem:read-suffix 16 dstate)))
 273
 274 (sb!disassem:define-argument-type reg/mem
 275   :prefilter #'prefilter-reg/mem
 276   :printer #'print-reg/mem)
 277 (sb!disassem:define-argument-type sized-reg/mem
 278   ;; Same as reg/mem, but prints an explicit size indicator for
 279   ;; memory references.
 280   :prefilter #'prefilter-reg/mem
 281   :printer #'print-sized-reg/mem)
 282 (sb!disassem:define-argument-type byte-reg/mem
 283   :prefilter #'prefilter-reg/mem
 284   :printer #'print-byte-reg/mem)
 285
 286 ;;; added by jrd
 287 (eval-when (:compile-toplevel :load-toplevel :execute)
 288 (defun print-fp-reg (value stream dstate)
 289   (declare (ignore dstate))
 290   (format stream "FR~D" value))
 291
 292 (defun prefilter-fp-reg (value dstate)
 293   ;; just return it
 294   (declare (ignore dstate))
 295   value)
 296 )
 297 (sb!disassem:define-argument-type fp-reg
 298                                   :prefilter #'prefilter-fp-reg
 299                                   :printer #'print-fp-reg)
 300
 301 (sb!disassem:define-argument-type width
 302   :prefilter #'prefilter-width
 303   :printer #'(lambda (value stream dstate)
 304                (if ;; (zerop value)
 305                    (or (null value)
 306                        (and (numberp value) (zerop value))) ; zzz jrd
 307                    (princ 'b stream)
 308                    (let ((word-width
 309                           ;; set by a prefix instruction
 310                           (or (sb!disassem:dstate-get-prop dstate 'word-width)
 311                               +default-operand-size+)))
 312                      (princ (schar (symbol-name word-width) 0) stream)))))
 313
 314 (eval-when (:compile-toplevel :load-toplevel :execute)
 315 (defconstant conditions
 316   '((:o . 0)
 317     (:no . 1)
 318     (:b . 2) (:nae . 2) (:c . 2)
 319     (:nb . 3) (:ae . 3) (:nc . 3)
 320     (:eq . 4) (:e . 4) (:z . 4)
 321     (:ne . 5) (:nz . 5)
 322     (:be . 6) (:na . 6)
 323     (:nbe . 7) (:a . 7)
 324     (:s . 8)
 325     (:ns . 9)
 326     (:p . 10) (:pe . 10)
 327     (:np . 11) (:po . 11)
 328     (:l . 12) (:nge . 12)
 329     (:nl . 13) (:ge . 13)
 330     (:le . 14) (:ng . 14)
 331     (:nle . 15) (:g . 15)))
 332
 333 (defparameter *condition-name-vec*
 334   (let ((vec (make-array 16 :initial-element nil)))
 335     (dolist (cond conditions)
 336       (when (null (aref vec (cdr cond)))
 337         (setf (aref vec (cdr cond)) (car cond))))
 338     vec))
 339 );EVAL-WHEN
 340
 341 ;;; Set assembler parameters. (In CMU CL, this was done with
 342 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
 343 (eval-when (:compile-toplevel :load-toplevel :execute)
 344   (setf sb!assem:*assem-scheduler-p* nil))
 345
 346 (sb!disassem:define-argument-type condition-code
 347   :printer *condition-name-vec*)
 348
 349 (defun conditional-opcode (condition)
 350   (cdr (assoc condition conditions :test #'eq)))
 351 \f
 352 ;;;; disassembler instruction formats
 353
 354 (eval-when (:compile-toplevel :execute)
 355   (defun swap-if (direction field1 separator field2)
 356     `(:if (,direction :constant 0)
 357           (,field1 ,separator ,field2)
 358           (,field2 ,separator ,field1))))
 359
 360 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
 361   (op    :field (byte 8 0))
 362   ;; optional fields
 363   (accum :type 'accum)
 364   (imm))
 365
 366 (sb!disassem:define-instruction-format (simple 8)
 367   (op    :field (byte 7 1))
 368   (width :field (byte 1 0) :type 'width)
 369   ;; optional fields
 370   (accum :type 'accum)
 371   (imm))
 372
 373 ;;; Same as simple, but with direction bit
 374 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
 375   (op :field (byte 6 2))
 376   (dir :field (byte 1 1)))
 377
 378 ;;; Same as simple, but with the immediate value occurring by default,
 379 ;;; and with an appropiate printer.
 380 (sb!disassem:define-instruction-format (accum-imm 8
 381                                      :include 'simple
 382                                      :default-printer '(:name
 383                                                         :tab accum ", " imm))
 384   (imm :type 'imm-data))
 385
 386 (sb!disassem:define-instruction-format (reg-no-width 8
 387                                      :default-printer '(:name :tab reg))
 388   (op    :field (byte 5 3))
 389   (reg   :field (byte 3 0) :type 'word-reg)
 390   ;; optional fields
 391   (accum :type 'word-accum)
 392   (imm))
 393
 394 ;;; adds a width field to reg-no-width
 395 (sb!disassem:define-instruction-format (reg 8
 396                                         :default-printer '(:name :tab reg))
 397   (op    :field (byte 4 4))
 398   (width :field (byte 1 3) :type 'width)
 399   (reg   :field (byte 3 0) :type 'reg)
 400   ;; optional fields
 401   (accum :type 'accum)
 402   (imm)
 403   )
 404
 405 ;;; Same as reg, but with direction bit
 406 (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
 407   (op  :field (byte 3 5))
 408   (dir :field (byte 1 4)))
 409
 410 (sb!disassem:define-instruction-format (two-bytes 16
 411                                         :default-printer '(:name))
 412   (op :fields (list (byte 8 0) (byte 8 8))))
 413
 414 (sb!disassem:define-instruction-format (reg-reg/mem 16
 415                                         :default-printer
 416                                         `(:name :tab reg ", " reg/mem))
 417   (op      :field (byte 7 1))
 418   (width   :field (byte 1 0)    :type 'width)
 419   (reg/mem :fields (list (byte 2 14) (byte 3 8))
 420                                 :type 'reg/mem)
 421   (reg     :field (byte 3 11)   :type 'reg)
 422   ;; optional fields
 423   (imm))
 424
 425 ;;; same as reg-reg/mem, but with direction bit
 426 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
 427                                         :include 'reg-reg/mem
 428                                         :default-printer
 429                                         `(:name
 430                                           :tab
 431                                           ,(swap-if 'dir 'reg/mem ", " 'reg)))
 432   (op  :field (byte 6 2))
 433   (dir :field (byte 1 1)))
 434
 435 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
 436 (sb!disassem:define-instruction-format (reg/mem 16
 437                                         :default-printer '(:name :tab reg/mem))
 438   (op      :fields (list (byte 7 1) (byte 3 11)))
 439   (width   :field (byte 1 0)    :type 'width)
 440   (reg/mem :fields (list (byte 2 14) (byte 3 8))
 441                                 :type 'sized-reg/mem)
 442   ;; optional fields
 443   (imm))
 444
 445 ;;; Same as reg/mem, but with the immediate value occurring by default,
 446 ;;; and with an appropiate printer.
 447 (sb!disassem:define-instruction-format (reg/mem-imm 16
 448                                         :include 'reg/mem
 449                                         :default-printer
 450                                         '(:name :tab reg/mem ", " imm))
 451   (reg/mem :type 'sized-reg/mem)
 452   (imm     :type 'imm-data))
 453
 454 ;;; Same as reg/mem, but with using the accumulator in the default printer
 455 (sb!disassem:define-instruction-format
 456     (accum-reg/mem 16
 457      :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
 458   (reg/mem :type 'reg/mem)              ; don't need a size
 459   (accum :type 'accum))
 460
 461 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
 462 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
 463                                         :default-printer
 464                                         `(:name :tab reg ", " reg/mem))
 465   (prefix  :field (byte 8 0)    :value #b00001111)
 466   (op      :field (byte 7 9))
 467   (width   :field (byte 1 8)    :type 'width)
 468   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 469                                 :type 'reg/mem)
 470   (reg     :field (byte 3 19)   :type 'reg)
 471   ;; optional fields
 472   (imm))
 473
 474 ;;; Same as reg/mem, but with a prefix of #b00001111
 475 (sb!disassem:define-instruction-format (ext-reg/mem 24
 476                                         :default-printer '(:name :tab reg/mem))
 477   (prefix  :field (byte 8 0)    :value #b00001111)
 478   (op      :fields (list (byte 7 9) (byte 3 19)))
 479   (width   :field (byte 1 8)    :type 'width)
 480   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 481                                 :type 'sized-reg/mem)
 482   ;; optional fields
 483   (imm))
 484 \f
 485 ;;;; This section was added by jrd, for fp instructions.
 486
 487 ;;; regular fp inst to/from registers/memory
 488 (sb!disassem:define-instruction-format (floating-point 16
 489                                         :default-printer
 490                                         `(:name :tab reg/mem))
 491   (prefix :field (byte 5 3) :value #b11011)
 492   (op     :fields (list (byte 3 0) (byte 3 11)))
 493   (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
 494
 495 ;;; fp insn to/from fp reg
 496 (sb!disassem:define-instruction-format (floating-point-fp 16
 497                                         :default-printer `(:name :tab fp-reg))
 498   (prefix :field (byte 5 3) :value #b11011)
 499   (suffix :field (byte 2 14) :value #b11)
 500   (op     :fields (list (byte 3 0) (byte 3 11)))
 501   (fp-reg :field (byte 3 8) :type 'fp-reg))
 502
 503 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
 504 (sb!disassem:define-instruction-format
 505  (floating-point-fp-d 16
 506    :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
 507   (prefix :field (byte 5 3) :value #b11011)
 508   (suffix :field (byte 2 14) :value #b11)
 509   (op     :fields (list (byte 2 0) (byte 3 11)))
 510   (d      :field (byte 1 2))
 511   (fp-reg :field (byte 3 8) :type 'fp-reg))
 512
 513
 514 ;;; (added by (?) pfw)
 515 ;;; fp no operand isns
 516 (sb!disassem:define-instruction-format (floating-point-no 16
 517                                       :default-printer '(:name))
 518   (prefix :field (byte 8  0) :value #b11011001)
 519   (suffix :field (byte 3 13) :value #b111)
 520   (op     :field (byte 5  8)))
 521
 522 (sb!disassem:define-instruction-format (floating-point-3 16
 523                                       :default-printer '(:name))
 524   (prefix :field (byte 5 3) :value #b11011)
 525   (suffix :field (byte 2 14) :value #b11)
 526   (op     :fields (list (byte 3 0) (byte 6 8))))
 527
 528 (sb!disassem:define-instruction-format (floating-point-5 16
 529                                       :default-printer '(:name))
 530   (prefix :field (byte 8  0) :value #b11011011)
 531   (suffix :field (byte 3 13) :value #b111)
 532   (op     :field (byte 5  8)))
 533
 534 (sb!disassem:define-instruction-format (floating-point-st 16
 535                                       :default-printer '(:name))
 536   (prefix :field (byte 8  0) :value #b11011111)
 537   (suffix :field (byte 3 13) :value #b111)
 538   (op     :field (byte 5  8)))
 539
 540 (sb!disassem:define-instruction-format (string-op 8
 541                                      :include 'simple
 542                                      :default-printer '(:name width)))
 543
 544 (sb!disassem:define-instruction-format (short-cond-jump 16)
 545   (op    :field (byte 4 4))
 546   (cc    :field (byte 4 0) :type 'condition-code)
 547   (label :field (byte 8 8) :type 'displacement))
 548
 549 (sb!disassem:define-instruction-format (short-jump 16
 550                                      :default-printer '(:name :tab label))
 551   (const :field (byte 4 4) :value #b1110)
 552   (op    :field (byte 4 0))
 553   (label :field (byte 8 8) :type 'displacement))
 554
 555 (sb!disassem:define-instruction-format (near-cond-jump 16)
 556   (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
 557   (cc    :field (byte 4 8) :type 'condition-code)
 558   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 559   ;; long, so we fake it by using a prefilter to read the offset.
 560   (label :type 'displacement
 561          :prefilter #'(lambda (value dstate)
 562                         (declare (ignore value))   ; always nil anyway
 563                         (sb!disassem:read-signed-suffix 32 dstate))))
 564
 565 (sb!disassem:define-instruction-format (near-jump 8
 566                                      :default-printer '(:name :tab label))
 567   (op    :field (byte 8 0))
 568   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 569   ;; long, so we fake it by using a prefilter to read the address.
 570   (label :type 'displacement
 571          :prefilter #'(lambda (value dstate)
 572                         (declare (ignore value))   ; always nil anyway
 573                         (sb!disassem:read-signed-suffix 32 dstate))))
 574
 575
 576 (sb!disassem:define-instruction-format (cond-set 24
 577                                      :default-printer '('set cc :tab reg/mem))
 578   (prefix :field (byte 8 0) :value #b00001111)
 579   (op    :field (byte 4 12) :value #b1001)
 580   (cc    :field (byte 4 8) :type 'condition-code)
 581   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 582            :type 'byte-reg/mem)
 583   (reg     :field (byte 3 19)   :value #b000))
 584
 585 (sb!disassem:define-instruction-format (enter-format 32
 586                                      :default-printer '(:name
 587                                                         :tab disp
 588                                                         (:unless (:constant 0)
 589                                                           ", " level)))
 590   (op :field (byte 8 0))
 591   (disp :field (byte 16 8))
 592   (level :field (byte 8 24)))
 593
 594 ;;; Single byte instruction with an immediate byte argument.
 595 (sb!disassem:define-instruction-format (byte-imm 16
 596                                      :default-printer '(:name :tab code))
 597  (op :field (byte 8 0))
 598  (code :field (byte 8 8)))
 599 \f
 600 ;;;; primitive emitters
 601
 602 (define-bitfield-emitter emit-word 16
 603   (byte 16 0))
 604
 605 (define-bitfield-emitter emit-dword 32
 606   (byte 32 0))
 607
 608 (define-bitfield-emitter emit-byte-with-reg 8
 609   (byte 5 3) (byte 3 0))
 610
 611 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
 612   (byte 2 6) (byte 3 3) (byte 3 0))
 613
 614 (define-bitfield-emitter emit-sib-byte 8
 615   (byte 2 6) (byte 3 3) (byte 3 0))
 616 \f
 617 ;;;; fixup emitters
 618
 619 (defun emit-absolute-fixup (segment fixup)
 620   (note-fixup segment :absolute fixup)
 621   (let ((offset (fixup-offset fixup)))
 622     (if (label-p offset)
 623         (emit-back-patch segment
 624                          4 ; FIXME: sb!vm:word-bytes
 625                          #'(lambda (segment posn)
 626                              (declare (ignore posn))
 627                              (emit-dword segment
 628                                          (- (+ (component-header-length)
 629                                                (or (label-position offset)
 630                                                    0))
 631                                             other-pointer-type))))
 632         (emit-dword segment (or offset 0)))))
 633
 634 (defun emit-relative-fixup (segment fixup)
 635   (note-fixup segment :relative fixup)
 636   (emit-dword segment (or (fixup-offset fixup) 0)))
 637 \f
 638 ;;;; the effective-address (ea) structure
 639
 640 (defun reg-tn-encoding (tn)
 641   (declare (type tn tn))
 642   (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
 643   (let ((offset (tn-offset tn)))
 644     (logior (ash (logand offset 1) 2)
 645             (ash offset -1))))
 646
 647 (defstruct (ea (:constructor make-ea (size &key base index scale disp)))
 648   (size nil :type (member :byte :word :dword))
 649   (base nil :type (or tn null))
 650   (index nil :type (or tn null))
 651   (scale 1 :type (member 1 2 4 8))
 652   (disp 0 :type (or (signed-byte 32) fixup)))
 653 (def!method print-object ((ea ea) stream)
 654   (cond ((or *print-escape* *print-readably*)
 655          (print-unreadable-object (ea stream :type t)
 656            (format stream
 657                    "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
 658                    (ea-size ea)
 659                    (ea-base ea)
 660                    (ea-index ea)
 661                    (let ((scale (ea-scale ea)))
 662                      (if (= scale 1) nil scale))
 663                    (ea-disp ea))))
 664         (t
 665          (format stream "~A PTR [" (symbol-name (ea-size ea)))
 666          (when (ea-base ea)
 667            (write-string (x86-location-print-name (ea-base ea)) stream)
 668            (when (ea-index ea)
 669              (write-string "+" stream)))
 670          (when (ea-index ea)
 671            (write-string (x86-location-print-name (ea-index ea)) stream))
 672          (unless (= (ea-scale ea) 1)
 673            (format stream "*~A" (ea-scale ea)))
 674          (typecase (ea-disp ea)
 675            (null)
 676            (integer
 677             (format stream "~@D" (ea-disp ea)))
 678            (t
 679             (format stream "+~A" (ea-disp ea))))
 680          (write-char #\] stream))))
 681
 682 (defun emit-ea (segment thing reg &optional allow-constants)
 683   (etypecase thing
 684     (tn
 685      (ecase (sb-name (sc-sb (tn-sc thing)))
 686        (registers
 687         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
 688        (stack
 689         ;; Convert stack tns into an index off of EBP.
 690         (let ((disp (- (* (1+ (tn-offset thing)) word-bytes))))
 691           (cond ((< -128 disp 127)
 692                  (emit-mod-reg-r/m-byte segment #b01 reg #b101)
 693                  (emit-byte segment disp))
 694                 (t
 695                  (emit-mod-reg-r/m-byte segment #b10 reg #b101)
 696                  (emit-dword segment disp)))))
 697        (constant
 698         (unless allow-constants
 699           (error
 700            "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
 701         (emit-mod-reg-r/m-byte segment #b00 reg #b101)
 702         (emit-absolute-fixup segment
 703                              (make-fixup nil
 704                                          :code-object
 705                                          (- (* (tn-offset thing) word-bytes)
 706                                             other-pointer-type))))))
 707     (ea
 708      (let* ((base (ea-base thing))
 709             (index (ea-index thing))
 710             (scale (ea-scale thing))
 711             (disp (ea-disp thing))
 712             (mod (cond ((or (null base)
 713                             (and (eql disp 0)
 714                                  (not (= (reg-tn-encoding base) #b101))))
 715                         #b00)
 716                        ((and (target-fixnump disp) (<= -128 disp 127))
 717                         #b01)
 718                        (t
 719                         #b10)))
 720             (r/m (cond (index #b100)
 721                        ((null base) #b101)
 722                        (t (reg-tn-encoding base)))))
 723        (emit-mod-reg-r/m-byte segment mod reg r/m)
 724        (when (= r/m #b100)
 725          (let ((ss (1- (integer-length scale)))
 726                (index (if (null index)
 727                           #b100
 728                           (let ((index (reg-tn-encoding index)))
 729                             (if (= index #b100)
 730                                 (error "can't index off of ESP")
 731                                 index))))
 732                (base (if (null base)
 733                          #b101
 734                          (reg-tn-encoding base))))
 735            (emit-sib-byte segment ss index base)))
 736        (cond ((= mod #b01)
 737               (emit-byte segment disp))
 738              ((or (= mod #b10) (null base))
 739               (if (fixup-p disp)
 740                   (emit-absolute-fixup segment disp)
 741                   (emit-dword segment disp))))))
 742     (fixup
 743      (emit-mod-reg-r/m-byte segment #b00 reg #b101)
 744      (emit-absolute-fixup segment thing))))
 745
 746 (defun fp-reg-tn-p (thing)
 747   (and (tn-p thing)
 748        (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
 749
 750 ;;; like the above, but for fp-instructions--jrd
 751 (defun emit-fp-op (segment thing op)
 752   (if (fp-reg-tn-p thing)
 753       (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
 754                                                  (byte 3 0)
 755                                                  #b11000000)))
 756     (emit-ea segment thing op)))
 757
 758 (defun byte-reg-p (thing)
 759   (and (tn-p thing)
 760        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 761        (member (sc-name (tn-sc thing)) byte-sc-names)
 762        t))
 763
 764 (defun byte-ea-p (thing)
 765   (typecase thing
 766     (ea (eq (ea-size thing) :byte))
 767     (tn
 768      (and (member (sc-name (tn-sc thing)) byte-sc-names) t))
 769     (t nil)))
 770
 771 (defun word-reg-p (thing)
 772   (and (tn-p thing)
 773        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 774        (member (sc-name (tn-sc thing)) word-sc-names)
 775        t))
 776
 777 (defun word-ea-p (thing)
 778   (typecase thing
 779     (ea (eq (ea-size thing) :word))
 780     (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t))
 781     (t nil)))
 782
 783 (defun dword-reg-p (thing)
 784   (and (tn-p thing)
 785        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 786        (member (sc-name (tn-sc thing)) dword-sc-names)
 787        t))
 788
 789 (defun dword-ea-p (thing)
 790   (typecase thing
 791     (ea (eq (ea-size thing) :dword))
 792     (tn
 793      (and (member (sc-name (tn-sc thing)) dword-sc-names) t))
 794     (t nil)))
 795
 796 (defun register-p (thing)
 797   (and (tn-p thing)
 798        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
 799
 800 (defun accumulator-p (thing)
 801   (and (register-p thing)
 802        (= (tn-offset thing) 0)))
 803 \f
 804 ;;;; utilities
 805
 806 (defconstant +operand-size-prefix-byte+ #b01100110)
 807
 808 (defconstant +default-operand-size+ :dword)
 809
 810 (defun maybe-emit-operand-size-prefix (segment size)
 811   (unless (or (eq size :byte) (eq size +default-operand-size+))
 812     (emit-byte segment +operand-size-prefix-byte+)))
 813
 814 (defun operand-size (thing)
 815   (typecase thing
 816     (tn
 817      (case (sc-name (tn-sc thing))
 818        (#.dword-sc-names
 819         :dword)
 820        (#.word-sc-names
 821         :word)
 822        (#.byte-sc-names
 823         :byte)
 824        ;; added by jrd. float-registers is a separate size (?)
 825        (#.float-sc-names
 826         :float)
 827        (#.double-sc-names
 828         :double)
 829        (t
 830         (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
 831     (ea
 832      (ea-size thing))
 833     (t
 834      nil)))
 835
 836 (defun matching-operand-size (dst src)
 837   (let ((dst-size (operand-size dst))
 838         (src-size (operand-size src)))
 839     (if dst-size
 840         (if src-size
 841             (if (eq dst-size src-size)
 842                 dst-size
 843                 (error "size mismatch: ~S is a ~S and ~S is a ~S."
 844                        dst dst-size src src-size))
 845             dst-size)
 846         (if src-size
 847             src-size
 848             (error "can't tell the size of either ~S or ~S" dst src)))))
 849
 850 (defun emit-sized-immediate (segment size value)
 851   (ecase size
 852     (:byte
 853      (emit-byte segment value))
 854     (:word
 855      (emit-word segment value))
 856     (:dword
 857      (emit-dword segment value))))
 858 \f
 859 ;;;; general data transfer
 860
 861 (define-instruction mov (segment dst src)
 862   ;; immediate to register
 863   (:printer reg ((op #b1011) (imm nil :type 'imm-data))
 864             '(:name :tab reg ", " imm))
 865   ;; absolute mem to/from accumulator
 866   (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
 867             `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
 868   ;; register to/from register/memory
 869   (:printer reg-reg/mem-dir ((op #b100010)))
 870   ;; immediate to register/memory
 871   (:printer reg/mem-imm ((op '(#b1100011 #b000))))
 872
 873   (:emitter
 874    (let ((size (matching-operand-size dst src)))
 875      (maybe-emit-operand-size-prefix segment size)
 876      (cond ((register-p dst)
 877             (cond ((integerp src)
 878                    (emit-byte-with-reg segment
 879                                        (if (eq size :byte)
 880                                            #b10110
 881                                            #b10111)
 882                                        (reg-tn-encoding dst))
 883                    (emit-sized-immediate segment size src))
 884                   ((and (fixup-p src) (accumulator-p dst))
 885                    (emit-byte segment
 886                               (if (eq size :byte)
 887                                   #b10100000
 888                                   #b10100001))
 889                    (emit-absolute-fixup segment src))
 890                   (t
 891                    (emit-byte segment
 892                               (if (eq size :byte)
 893                                   #b10001010
 894                                   #b10001011))
 895                    (emit-ea segment src (reg-tn-encoding dst) t))))
 896            ((and (fixup-p dst) (accumulator-p src))
 897             (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
 898             (emit-absolute-fixup segment dst))
 899            ((integerp src)
 900             (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
 901             (emit-ea segment dst #b000)
 902             (emit-sized-immediate segment size src))
 903            ((register-p src)
 904             (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
 905             (emit-ea segment dst (reg-tn-encoding src)))
 906            ((fixup-p src)
 907             (assert (eq size :dword))
 908             (emit-byte segment #b11000111)
 909             (emit-ea segment dst #b000)
 910             (emit-absolute-fixup segment src))
 911            (t
 912             (error "bogus arguments to MOV: ~S ~S" dst src))))))
 913
 914 (defun emit-move-with-extension (segment dst src opcode)
 915   (assert (register-p dst))
 916   (let ((dst-size (operand-size dst))
 917         (src-size (operand-size src)))
 918     (ecase dst-size
 919       (:word
 920        (assert (eq src-size :byte))
 921        (maybe-emit-operand-size-prefix segment :word)
 922        (emit-byte segment #b00001111)
 923        (emit-byte segment opcode)
 924        (emit-ea segment src (reg-tn-encoding dst)))
 925       (:dword
 926        (ecase src-size
 927          (:byte
 928           (maybe-emit-operand-size-prefix segment :dword)
 929           (emit-byte segment #b00001111)
 930           (emit-byte segment opcode)
 931           (emit-ea segment src (reg-tn-encoding dst)))
 932          (:word
 933           (emit-byte segment #b00001111)
 934           (emit-byte segment (logior opcode 1))
 935           (emit-ea segment src (reg-tn-encoding dst))))))))
 936
 937 (define-instruction movsx (segment dst src)
 938   (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
 939   (:emitter (emit-move-with-extension segment dst src #b10111110)))
 940
 941 (define-instruction movzx (segment dst src)
 942   (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
 943   (:emitter (emit-move-with-extension segment dst src #b10110110)))
 944
 945 (define-instruction push (segment src)
 946   ;; register
 947   (:printer reg-no-width ((op #b01010)))
 948   ;; register/memory
 949   (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
 950   ;; immediate
 951   (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
 952             '(:name :tab imm))
 953   (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
 954             '(:name :tab imm))
 955   ;; ### segment registers?
 956
 957   (:emitter
 958    (cond ((integerp src)
 959           (cond ((<= -128 src 127)
 960                  (emit-byte segment #b01101010)
 961                  (emit-byte segment src))
 962                 (t
 963                  (emit-byte segment #b01101000)
 964                  (emit-dword segment src))))
 965          ((fixup-p src)
 966           ;; Interpret the fixup as an immediate dword to push.
 967           (emit-byte segment #b01101000)
 968           (emit-absolute-fixup segment src))
 969          (t
 970           (let ((size (operand-size src)))
 971             (assert (not (eq size :byte)))
 972             (maybe-emit-operand-size-prefix segment size)
 973             (cond ((register-p src)
 974                    (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
 975                   (t
 976                    (emit-byte segment #b11111111)
 977                    (emit-ea segment src #b110 t))))))))
 978
 979 (define-instruction pusha (segment)
 980   (:printer byte ((op #b01100000)))
 981   (:emitter
 982    (emit-byte segment #b01100000)))
 983
 984 (define-instruction pop (segment dst)
 985   (:printer reg-no-width ((op #b01011)))
 986   (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
 987   (:emitter
 988    (let ((size (operand-size dst)))
 989      (assert (not (eq size :byte)))
 990      (maybe-emit-operand-size-prefix segment size)
 991      (cond ((register-p dst)
 992             (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
 993            (t
 994             (emit-byte segment #b10001111)
 995             (emit-ea segment dst #b000))))))
 996
 997 (define-instruction popa (segment)
 998   (:printer byte ((op #b01100001)))
 999   (:emitter
1000    (emit-byte segment #b01100001)))
1001
1002 (define-instruction xchg (segment operand1 operand2)
1003   ;; Register with accumulator.
1004   (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1005   ;; Register/Memory with Register.
1006   (:printer reg-reg/mem ((op #b1000011)))
1007   (:emitter
1008    (let ((size (matching-operand-size operand1 operand2)))
1009      (maybe-emit-operand-size-prefix segment size)
1010      (labels ((xchg-acc-with-something (acc something)
1011                 (if (and (not (eq size :byte)) (register-p something))
1012                     (emit-byte-with-reg segment
1013                                         #b10010
1014                                         (reg-tn-encoding something))
1015                     (xchg-reg-with-something acc something)))
1016               (xchg-reg-with-something (reg something)
1017                 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1018                 (emit-ea segment something (reg-tn-encoding reg))))
1019        (cond ((accumulator-p operand1)
1020               (xchg-acc-with-something operand1 operand2))
1021              ((accumulator-p operand2)
1022               (xchg-acc-with-something operand2 operand1))
1023              ((register-p operand1)
1024               (xchg-reg-with-something operand1 operand2))
1025              ((register-p operand2)
1026               (xchg-reg-with-something operand2 operand1))
1027              (t
1028               (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1029
1030 (define-instruction lea (segment dst src)
1031   (:printer reg-reg/mem ((op #b1000110) (width 1)))
1032   (:emitter
1033    (assert (dword-reg-p dst))
1034    (emit-byte segment #b10001101)
1035    (emit-ea segment src (reg-tn-encoding dst))))
1036
1037 (define-instruction cmpxchg (segment dst src)
1038   ;; Register/Memory with Register.
1039   (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1040   (:emitter
1041    (assert (register-p src))
1042    (let ((size (matching-operand-size src dst)))
1043      (maybe-emit-operand-size-prefix segment size)
1044      (emit-byte segment #b00001111)
1045      (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1046      (emit-ea segment dst (reg-tn-encoding src)))))
1047
1048 \f
1049 ;;;; flag control instructions
1050
1051 ;;; CLC -- Clear Carry Flag.
1052 (define-instruction clc (segment)
1053   (:printer byte ((op #b11111000)))
1054   (:emitter
1055    (emit-byte segment #b11111000)))
1056
1057 ;;; CLD -- Clear Direction Flag.
1058 (define-instruction cld (segment)
1059   (:printer byte ((op #b11111100)))
1060   (:emitter
1061    (emit-byte segment #b11111100)))
1062
1063 ;;; CLI -- Clear Iterrupt Enable Flag.
1064 (define-instruction cli (segment)
1065   (:printer byte ((op #b11111010)))
1066   (:emitter
1067    (emit-byte segment #b11111010)))
1068
1069 ;;; CMC -- Complement Carry Flag.
1070 (define-instruction cmc (segment)
1071   (:printer byte ((op #b11110101)))
1072   (:emitter
1073    (emit-byte segment #b11110101)))
1074
1075 ;;; LAHF -- Load AH into flags.
1076 (define-instruction lahf (segment)
1077   (:printer byte ((op #b10011111)))
1078   (:emitter
1079    (emit-byte segment #b10011111)))
1080
1081 ;;; POPF -- Pop flags.
1082 (define-instruction popf (segment)
1083   (:printer byte ((op #b10011101)))
1084   (:emitter
1085    (emit-byte segment #b10011101)))
1086
1087 ;;; PUSHF -- push flags.
1088 (define-instruction pushf (segment)
1089   (:printer byte ((op #b10011100)))
1090   (:emitter
1091    (emit-byte segment #b10011100)))
1092
1093 ;;; SAHF -- Store AH into flags.
1094 (define-instruction sahf (segment)
1095   (:printer byte ((op #b10011110)))
1096   (:emitter
1097    (emit-byte segment #b10011110)))
1098
1099 ;;; STC -- Set Carry Flag.
1100 (define-instruction stc (segment)
1101   (:printer byte ((op #b11111001)))
1102   (:emitter
1103    (emit-byte segment #b11111001)))
1104
1105 ;;; STD -- Set Direction Flag.
1106 (define-instruction std (segment)
1107   (:printer byte ((op #b11111101)))
1108   (:emitter
1109    (emit-byte segment #b11111101)))
1110
1111 ;;; STI -- Set Interrupt Enable Flag.
1112 (define-instruction sti (segment)
1113   (:printer byte ((op #b11111011)))
1114   (:emitter
1115    (emit-byte segment #b11111011)))
1116 \f
1117 ;;;; arithmetic
1118
1119 (defun emit-random-arith-inst (name segment dst src opcode
1120                                     &optional allow-constants)
1121   (let ((size (matching-operand-size dst src)))
1122     (maybe-emit-operand-size-prefix segment size)
1123     (cond
1124      ((integerp src)
1125       (cond ((and (not (eq size :byte)) (<= -128 src 127))
1126              (emit-byte segment #b10000011)
1127              (emit-ea segment dst opcode)
1128              (emit-byte segment src))
1129             ((accumulator-p dst)
1130              (emit-byte segment
1131                         (dpb opcode
1132                              (byte 3 3)
1133                              (if (eq size :byte)
1134                                  #b00000100
1135                                  #b00000101)))
1136              (emit-sized-immediate segment size src))
1137             (t
1138              (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1139              (emit-ea segment dst opcode)
1140              (emit-sized-immediate segment size src))))
1141      ((register-p src)
1142       (emit-byte segment
1143                  (dpb opcode
1144                       (byte 3 3)
1145                       (if (eq size :byte) #b00000000 #b00000001)))
1146       (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1147      ((register-p dst)
1148       (emit-byte segment
1149                  (dpb opcode
1150                       (byte 3 3)
1151                       (if (eq size :byte) #b00000010 #b00000011)))
1152       (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1153      (t
1154       (error "bogus operands to ~A" name)))))
1155
1156 (eval-when (:compile-toplevel :execute)
1157   (defun arith-inst-printer-list (subop)
1158     `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1159       (reg/mem-imm ((op (#b1000000 ,subop))))
1160       (reg/mem-imm ((op (#b1000001 ,subop))
1161                     (imm nil :type signed-imm-byte)))
1162       (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1163   )
1164
1165 (define-instruction add (segment dst src)
1166   (:printer-list (arith-inst-printer-list #b000))
1167   (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
1168
1169 (define-instruction adc (segment dst src)
1170   (:printer-list (arith-inst-printer-list #b010))
1171   (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1172
1173 (define-instruction sub (segment dst src)
1174   (:printer-list (arith-inst-printer-list #b101))
1175   (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
1176
1177 (define-instruction sbb (segment dst src)
1178   (:printer-list (arith-inst-printer-list #b011))
1179   (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1180
1181 (define-instruction cmp (segment dst src)
1182   (:printer-list (arith-inst-printer-list #b111))
1183   (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1184
1185 (define-instruction inc (segment dst)
1186   ;; Register.
1187   (:printer reg-no-width ((op #b01000)))
1188   ;; Register/Memory
1189   (:printer reg/mem ((op '(#b1111111 #b000))))
1190   (:emitter
1191    (let ((size (operand-size dst)))
1192      (maybe-emit-operand-size-prefix segment size)
1193      (cond ((and (not (eq size :byte)) (register-p dst))
1194             (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1195            (t
1196             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1197             (emit-ea segment dst #b000))))))
1198
1199 (define-instruction dec (segment dst)
1200   ;; Register.
1201   (:printer reg-no-width ((op #b01001)))
1202   ;; Register/Memory
1203   (:printer reg/mem ((op '(#b1111111 #b001))))
1204   (:emitter
1205    (let ((size (operand-size dst)))
1206      (maybe-emit-operand-size-prefix segment size)
1207      (cond ((and (not (eq size :byte)) (register-p dst))
1208             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1209            (t
1210             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1211             (emit-ea segment dst #b001))))))
1212
1213 (define-instruction neg (segment dst)
1214   (:printer reg/mem ((op '(#b1111011 #b011))))
1215   (:emitter
1216    (let ((size (operand-size dst)))
1217      (maybe-emit-operand-size-prefix segment size)
1218      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1219      (emit-ea segment dst #b011))))
1220
1221 (define-instruction aaa (segment)
1222   (:printer byte ((op #b00110111)))
1223   (:emitter
1224    (emit-byte segment #b00110111)))
1225
1226 (define-instruction aas (segment)
1227   (:printer byte ((op #b00111111)))
1228   (:emitter
1229    (emit-byte segment #b00111111)))
1230
1231 (define-instruction daa (segment)
1232   (:printer byte ((op #b00100111)))
1233   (:emitter
1234    (emit-byte segment #b00100111)))
1235
1236 (define-instruction das (segment)
1237   (:printer byte ((op #b00101111)))
1238   (:emitter
1239    (emit-byte segment #b00101111)))
1240
1241 (define-instruction mul (segment dst src)
1242   (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1243   (:emitter
1244    (let ((size (matching-operand-size dst src)))
1245      (assert (accumulator-p dst))
1246      (maybe-emit-operand-size-prefix segment size)
1247      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1248      (emit-ea segment src #b100))))
1249
1250 (define-instruction imul (segment dst &optional src1 src2)
1251   (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1252   (:printer ext-reg-reg/mem ((op #b1010111)))
1253   (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word))
1254             '(:name :tab reg ", " reg/mem ", " imm))
1255   (:printer reg-reg/mem ((op #b0110101) (width 1)
1256                          (imm nil :type 'signed-imm-byte))
1257             '(:name :tab reg ", " reg/mem ", " imm))
1258   (:emitter
1259    (flet ((r/m-with-immed-to-reg (reg r/m immed)
1260             (let* ((size (matching-operand-size reg r/m))
1261                    (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1262               (maybe-emit-operand-size-prefix segment size)
1263               (emit-byte segment (if sx #b01101011 #b01101001))
1264               (emit-ea segment r/m (reg-tn-encoding reg))
1265               (if sx
1266                   (emit-byte segment immed)
1267                   (emit-sized-immediate segment size immed)))))
1268      (cond (src2
1269             (r/m-with-immed-to-reg dst src1 src2))
1270            (src1
1271             (if (integerp src1)
1272                 (r/m-with-immed-to-reg dst dst src1)
1273                 (let ((size (matching-operand-size dst src1)))
1274                   (maybe-emit-operand-size-prefix segment size)
1275                   (emit-byte segment #b00001111)
1276                   (emit-byte segment #b10101111)
1277                   (emit-ea segment src1 (reg-tn-encoding dst)))))
1278            (t
1279             (let ((size (operand-size dst)))
1280               (maybe-emit-operand-size-prefix segment size)
1281               (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1282               (emit-ea segment dst #b101)))))))
1283
1284 (define-instruction div (segment dst src)
1285   (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1286   (:emitter
1287    (let ((size (matching-operand-size dst src)))
1288      (assert (accumulator-p dst))
1289      (maybe-emit-operand-size-prefix segment size)
1290      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1291      (emit-ea segment src #b110))))
1292
1293 (define-instruction idiv (segment dst src)
1294   (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1295   (:emitter
1296    (let ((size (matching-operand-size dst src)))
1297      (assert (accumulator-p dst))
1298      (maybe-emit-operand-size-prefix segment size)
1299      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1300      (emit-ea segment src #b111))))
1301
1302 (define-instruction aad (segment)
1303   (:printer two-bytes ((op '(#b11010101 #b00001010))))
1304   (:emitter
1305    (emit-byte segment #b11010101)
1306    (emit-byte segment #b00001010)))
1307
1308 (define-instruction aam (segment)
1309   (:printer two-bytes ((op '(#b11010100 #b00001010))))
1310   (:emitter
1311    (emit-byte segment #b11010100)
1312    (emit-byte segment #b00001010)))
1313
1314 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1315 (define-instruction cbw (segment)
1316   (:emitter
1317    (maybe-emit-operand-size-prefix segment :word)
1318    (emit-byte segment #b10011000)))
1319
1320 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1321 (define-instruction cwde (segment)
1322   (:emitter
1323    (maybe-emit-operand-size-prefix segment :dword)
1324    (emit-byte segment #b10011000)))
1325
1326 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1327 (define-instruction cwd (segment)
1328   (:emitter
1329    (maybe-emit-operand-size-prefix segment :word)
1330    (emit-byte segment #b10011001)))
1331
1332 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1333 (define-instruction cdq (segment)
1334   (:printer byte ((op #b10011001)))
1335   (:emitter
1336    (maybe-emit-operand-size-prefix segment :dword)
1337    (emit-byte segment #b10011001)))
1338
1339 (define-instruction xadd (segment dst src)
1340   ;; Register/Memory with Register.
1341   (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1342   (:emitter
1343    (assert (register-p src))
1344    (let ((size (matching-operand-size src dst)))
1345      (maybe-emit-operand-size-prefix segment size)
1346      (emit-byte segment #b00001111)
1347      (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1348      (emit-ea segment dst (reg-tn-encoding src)))))
1349
1350 \f
1351 ;;;; logic
1352
1353 (defun emit-shift-inst (segment dst amount opcode)
1354   (let ((size (operand-size dst)))
1355     (maybe-emit-operand-size-prefix segment size)
1356     (multiple-value-bind (major-opcode immed)
1357         (case amount
1358           (:cl (values #b11010010 nil))
1359           (1 (values #b11010000 nil))
1360           (t (values #b11000000 t)))
1361       (emit-byte segment
1362                  (if (eq size :byte) major-opcode (logior major-opcode 1)))
1363       (emit-ea segment dst opcode)
1364       (when immed
1365         (emit-byte segment amount)))))
1366
1367 (eval-when (:compile-toplevel :execute)
1368   (defun shift-inst-printer-list (subop)
1369     `((reg/mem ((op (#b1101000 ,subop)))
1370                (:name :tab reg/mem ", 1"))
1371       (reg/mem ((op (#b1101001 ,subop)))
1372                (:name :tab reg/mem ", " 'cl))
1373       (reg/mem-imm ((op (#b1100000 ,subop))
1374                     (imm nil :type signed-imm-byte))))))
1375
1376 (define-instruction rol (segment dst amount)
1377   (:printer-list
1378    (shift-inst-printer-list #b000))
1379   (:emitter
1380    (emit-shift-inst segment dst amount #b000)))
1381
1382 (define-instruction ror (segment dst amount)
1383   (:printer-list
1384    (shift-inst-printer-list #b001))
1385   (:emitter
1386    (emit-shift-inst segment dst amount #b001)))
1387
1388 (define-instruction rcl (segment dst amount)
1389   (:printer-list
1390    (shift-inst-printer-list #b010))
1391   (:emitter
1392    (emit-shift-inst segment dst amount #b010)))
1393
1394 (define-instruction rcr (segment dst amount)
1395   (:printer-list
1396    (shift-inst-printer-list #b011))
1397   (:emitter
1398    (emit-shift-inst segment dst amount #b011)))
1399
1400 (define-instruction shl (segment dst amount)
1401   (:printer-list
1402    (shift-inst-printer-list #b100))
1403   (:emitter
1404    (emit-shift-inst segment dst amount #b100)))
1405
1406 (define-instruction shr (segment dst amount)
1407   (:printer-list
1408    (shift-inst-printer-list #b101))
1409   (:emitter
1410    (emit-shift-inst segment dst amount #b101)))
1411
1412 (define-instruction sar (segment dst amount)
1413   (:printer-list
1414    (shift-inst-printer-list #b111))
1415   (:emitter
1416    (emit-shift-inst segment dst amount #b111)))
1417
1418 (defun emit-double-shift (segment opcode dst src amt)
1419   (let ((size (matching-operand-size dst src)))
1420     (when (eq size :byte)
1421       (error "Double shifts can only be used with words."))
1422     (maybe-emit-operand-size-prefix segment size)
1423     (emit-byte segment #b00001111)
1424     (emit-byte segment (dpb opcode (byte 1 3)
1425                             (if (eq amt :cl) #b10100101 #b10100100)))
1426     #+nil
1427     (emit-ea segment dst src)
1428     (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1429     (unless (eq amt :cl)
1430       (emit-byte segment amt))))
1431
1432 (eval-when (:compile-toplevel :execute)
1433   (defun double-shift-inst-printer-list (op)
1434     `(#+nil
1435       (ext-reg-reg/mem-imm ((op ,(logior op #b100))
1436                             (imm nil :type signed-imm-byte)))
1437       (ext-reg-reg/mem ((op ,(logior op #b101)))
1438          (:name :tab reg/mem ", " 'cl)))))
1439
1440 (define-instruction shld (segment dst src amt)
1441   (:declare (type (or (member :cl) (mod 32)) amt))
1442   (:printer-list (double-shift-inst-printer-list #b10100000))
1443   (:emitter
1444    (emit-double-shift segment #b0 dst src amt)))
1445
1446 (define-instruction shrd (segment dst src amt)
1447   (:declare (type (or (member :cl) (mod 32)) amt))
1448   (:printer-list (double-shift-inst-printer-list #b10101000))
1449   (:emitter
1450    (emit-double-shift segment #b1 dst src amt)))
1451
1452 (define-instruction and (segment dst src)
1453   (:printer-list
1454    (arith-inst-printer-list #b100))
1455   (:emitter
1456    (emit-random-arith-inst "AND" segment dst src #b100)))
1457
1458 (define-instruction test (segment this that)
1459   (:printer accum-imm ((op #b1010100)))
1460   (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1461   (:printer reg-reg/mem ((op #b1000010)))
1462   (:emitter
1463    (let ((size (matching-operand-size this that)))
1464      (maybe-emit-operand-size-prefix segment size)
1465      (flet ((test-immed-and-something (immed something)
1466               (cond ((accumulator-p something)
1467                      (emit-byte segment
1468                                 (if (eq size :byte) #b10101000 #b10101001))
1469                      (emit-sized-immediate segment size immed))
1470                     (t
1471                      (emit-byte segment
1472                                 (if (eq size :byte) #b11110110 #b11110111))
1473                      (emit-ea segment something #b000)
1474                      (emit-sized-immediate segment size immed))))
1475             (test-reg-and-something (reg something)
1476               (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1477               (emit-ea segment something (reg-tn-encoding reg))))
1478        (cond ((integerp that)
1479               (test-immed-and-something that this))
1480              ((integerp this)
1481               (test-immed-and-something this that))
1482              ((register-p this)
1483               (test-reg-and-something this that))
1484              ((register-p that)
1485               (test-reg-and-something that this))
1486              (t
1487               (error "bogus operands for TEST: ~S and ~S" this that)))))))
1488
1489 (define-instruction or (segment dst src)
1490   (:printer-list
1491    (arith-inst-printer-list #b001))
1492   (:emitter
1493    (emit-random-arith-inst "OR" segment dst src #b001)))
1494
1495 (define-instruction xor (segment dst src)
1496   (:printer-list
1497    (arith-inst-printer-list #b110))
1498   (:emitter
1499    (emit-random-arith-inst "XOR" segment dst src #b110)))
1500
1501 (define-instruction not (segment dst)
1502   (:printer reg/mem ((op '(#b1111011 #b010))))
1503   (:emitter
1504    (let ((size (operand-size dst)))
1505      (maybe-emit-operand-size-prefix segment size)
1506      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1507      (emit-ea segment dst #b010))))
1508 \f
1509 ;;;; string manipulation
1510
1511 (define-instruction cmps (segment size)
1512   (:printer string-op ((op #b1010011)))
1513   (:emitter
1514    (maybe-emit-operand-size-prefix segment size)
1515    (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1516
1517 (define-instruction ins (segment acc)
1518   (:printer string-op ((op #b0110110)))
1519   (:emitter
1520    (let ((size (operand-size acc)))
1521      (assert (accumulator-p acc))
1522      (maybe-emit-operand-size-prefix segment size)
1523      (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1524
1525 (define-instruction lods (segment acc)
1526   (:printer string-op ((op #b1010110)))
1527   (:emitter
1528    (let ((size (operand-size acc)))
1529      (assert (accumulator-p acc))
1530      (maybe-emit-operand-size-prefix segment size)
1531      (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1532
1533 (define-instruction movs (segment size)
1534   (:printer string-op ((op #b1010010)))
1535   (:emitter
1536    (maybe-emit-operand-size-prefix segment size)
1537    (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1538
1539 (define-instruction outs (segment acc)
1540   (:printer string-op ((op #b0110111)))
1541   (:emitter
1542    (let ((size (operand-size acc)))
1543      (assert (accumulator-p acc))
1544      (maybe-emit-operand-size-prefix segment size)
1545      (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1546
1547 (define-instruction scas (segment acc)
1548   (:printer string-op ((op #b1010111)))
1549   (:emitter
1550    (let ((size (operand-size acc)))
1551      (assert (accumulator-p acc))
1552      (maybe-emit-operand-size-prefix segment size)
1553      (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1554
1555 (define-instruction stos (segment acc)
1556   (:printer string-op ((op #b1010101)))
1557   (:emitter
1558    (let ((size (operand-size acc)))
1559      (assert (accumulator-p acc))
1560      (maybe-emit-operand-size-prefix segment size)
1561      (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1562
1563 (define-instruction xlat (segment)
1564   (:printer byte ((op #b11010111)))
1565   (:emitter
1566    (emit-byte segment #b11010111)))
1567
1568 (define-instruction rep (segment)
1569   (:emitter
1570    (emit-byte segment #b11110010)))
1571
1572 (define-instruction repe (segment)
1573   (:printer byte ((op #b11110011)))
1574   (:emitter
1575    (emit-byte segment #b11110011)))
1576
1577 (define-instruction repne (segment)
1578   (:printer byte ((op #b11110010)))
1579   (:emitter
1580    (emit-byte segment #b11110010)))
1581
1582 \f
1583 ;;;; bit manipulation
1584
1585 (define-instruction bsf (segment dst src)
1586   (:emitter
1587    (let ((size (matching-operand-size dst src)))
1588      (when (eq size :byte)
1589        (error "can't scan bytes: ~S" src))
1590      (maybe-emit-operand-size-prefix segment size)
1591      (emit-byte segment #b00001111)
1592      (emit-byte segment #b10111100)
1593      (emit-ea segment src (reg-tn-encoding dst)))))
1594
1595 (define-instruction bsr (segment dst src)
1596   (:emitter
1597    (let ((size (matching-operand-size dst src)))
1598      (when (eq size :byte)
1599        (error "can't scan bytes: ~S" src))
1600      (maybe-emit-operand-size-prefix segment size)
1601      (emit-byte segment #b00001111)
1602      (emit-byte segment #b10111101)
1603      (emit-ea segment src (reg-tn-encoding dst)))))
1604
1605 (defun emit-bit-test-and-mumble (segment src index opcode)
1606   (let ((size (operand-size src)))
1607     (when (eq size :byte)
1608       (error "can't scan bytes: ~S" src))
1609     (maybe-emit-operand-size-prefix segment size)
1610     (emit-byte segment #b00001111)
1611     (cond ((integerp index)
1612            (emit-byte segment #b10111010)
1613            (emit-ea segment src opcode)
1614            (emit-byte segment index))
1615           (t
1616            (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1617            (emit-ea segment src (reg-tn-encoding index))))))
1618
1619 (define-instruction bt (segment src index)
1620   (:emitter
1621    (emit-bit-test-and-mumble segment src index #b100)))
1622
1623 (define-instruction btc (segment src index)
1624   (:emitter
1625    (emit-bit-test-and-mumble segment src index #b111)))
1626
1627 (define-instruction btr (segment src index)
1628   (:emitter
1629    (emit-bit-test-and-mumble segment src index #b110)))
1630
1631 (define-instruction bts (segment src index)
1632   (:emitter
1633    (emit-bit-test-and-mumble segment src index #b101)))
1634
1635 \f
1636 ;;;; control transfer
1637
1638 (define-instruction call (segment where)
1639   (:printer near-jump ((op #b11101000)))
1640   (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
1641   (:emitter
1642    (typecase where
1643      (label
1644       (emit-byte segment #b11101000)
1645       (emit-back-patch segment
1646                        4
1647                        #'(lambda (segment posn)
1648                            (emit-dword segment
1649                                        (- (label-position where)
1650                                           (+ posn 4))))))
1651      (fixup
1652       (emit-byte segment #b11101000)
1653       (emit-relative-fixup segment where))
1654      (t
1655       (emit-byte segment #b11111111)
1656       (emit-ea segment where #b010)))))
1657
1658 (defun emit-byte-displacement-backpatch (segment target)
1659   (emit-back-patch segment
1660                    1
1661                    #'(lambda (segment posn)
1662                        (let ((disp (- (label-position target) (1+ posn))))
1663                          (assert (<= -128 disp 127))
1664                          (emit-byte segment disp)))))
1665
1666 (define-instruction jmp (segment cond &optional where)
1667   ;; conditional jumps
1668   (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
1669   (:printer near-cond-jump () '('j cc :tab label))
1670   ;; unconditional jumps
1671   (:printer short-jump ((op #b1011)))
1672   (:printer near-jump ((op #b11101001)) )
1673   (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
1674   (:emitter
1675    (cond (where
1676           (emit-chooser
1677            segment 6 2
1678            #'(lambda (segment posn delta-if-after)
1679                (let ((disp (- (label-position where posn delta-if-after)
1680                               (+ posn 2))))
1681                  (when (<= -128 disp 127)
1682                        (emit-byte segment
1683                                   (dpb (conditional-opcode cond)
1684                                        (byte 4 0)
1685                                        #b01110000))
1686                        (emit-byte-displacement-backpatch segment where)
1687                        t)))
1688            #'(lambda (segment posn)
1689                (let ((disp (- (label-position where) (+ posn 6))))
1690                  (emit-byte segment #b00001111)
1691                  (emit-byte segment
1692                             (dpb (conditional-opcode cond)
1693                                  (byte 4 0)
1694                                  #b10000000))
1695                  (emit-dword segment disp)))))
1696          ((label-p (setq where cond))
1697           (emit-chooser
1698            segment 5 0
1699            #'(lambda (segment posn delta-if-after)
1700                (let ((disp (- (label-position where posn delta-if-after)
1701                               (+ posn 2))))
1702                  (when (<= -128 disp 127)
1703                        (emit-byte segment #b11101011)
1704                        (emit-byte-displacement-backpatch segment where)
1705                        t)))
1706            #'(lambda (segment posn)
1707                (let ((disp (- (label-position where) (+ posn 5))))
1708                  (emit-byte segment #b11101001)
1709                  (emit-dword segment disp))
1710                )))
1711          ((fixup-p where)
1712           (emit-byte segment #b11101001)
1713           (emit-relative-fixup segment where))
1714          (t
1715           (unless (or (ea-p where) (tn-p where))
1716                   (error "don't know what to do with ~A" where))
1717           (emit-byte segment #b11111111)
1718           (emit-ea segment where #b100)))))
1719
1720 (define-instruction jmp-short (segment label)
1721   (:emitter
1722    (emit-byte segment #b11101011)
1723    (emit-byte-displacement-backpatch segment label)))
1724
1725 (define-instruction ret (segment &optional stack-delta)
1726   (:printer byte ((op #b11000011)))
1727   (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
1728             '(:name :tab imm))
1729   (:emitter
1730    (cond (stack-delta
1731           (emit-byte segment #b11000010)
1732           (emit-word segment stack-delta))
1733          (t
1734           (emit-byte segment #b11000011)))))
1735
1736 (define-instruction jecxz (segment target)
1737   (:printer short-jump ((op #b0011)))
1738   (:emitter
1739    (emit-byte segment #b11100011)
1740    (emit-byte-displacement-backpatch segment target)))
1741
1742 (define-instruction loop (segment target)
1743   (:printer short-jump ((op #b0010)))
1744   (:emitter
1745    (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
1746    (emit-byte-displacement-backpatch segment target)))
1747
1748 (define-instruction loopz (segment target)
1749   (:printer short-jump ((op #b0001)))
1750   (:emitter
1751    (emit-byte segment #b11100001)
1752    (emit-byte-displacement-backpatch segment target)))
1753
1754 (define-instruction loopnz (segment target)
1755   (:printer short-jump ((op #b0000)))
1756   (:emitter
1757    (emit-byte segment #b11100000)
1758    (emit-byte-displacement-backpatch segment target)))
1759 \f
1760 ;;;; conditional byte set
1761
1762 (define-instruction set (segment dst cond)
1763   (:printer cond-set ())
1764   (:emitter
1765    (emit-byte segment #b00001111)
1766    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
1767    (emit-ea segment dst #b000)))
1768 \f
1769 ;;;; enter/leave
1770
1771 (define-instruction enter (segment disp &optional (level 0))
1772   (:declare (type (unsigned-byte 16) disp)
1773             (type (unsigned-byte 8) level))
1774   (:printer enter-format ((op #b11001000)))
1775   (:emitter
1776    (emit-byte segment #b11001000)
1777    (emit-word segment disp)
1778    (emit-byte segment level)))
1779
1780 (define-instruction leave (segment)
1781   (:printer byte ((op #b11001001)))
1782   (:emitter
1783    (emit-byte segment #b11001001)))
1784 \f
1785 ;;;; interrupt instructions
1786
1787 (defun snarf-error-junk (sap offset &optional length-only)
1788   (let* ((length (sb!sys:sap-ref-8 sap offset))
1789          (vector (make-array length :element-type '(unsigned-byte 8))))
1790     (declare (type sb!sys:system-area-pointer sap)
1791              (type (unsigned-byte 8) length)
1792              (type (simple-array (unsigned-byte 8) (*)) vector))
1793     (cond (length-only
1794            (values 0 (1+ length) nil nil))
1795           (t
1796            (sb!kernel:copy-from-system-area sap (* byte-bits (1+ offset))
1797                                             vector (* word-bits
1798                                                       vector-data-offset)
1799                                             (* length byte-bits))
1800            (collect ((sc-offsets)
1801                      (lengths))
1802              (lengths 1)                ; the length byte
1803              (let* ((index 0)
1804                     (error-number (sb!c::read-var-integer vector index)))
1805                (lengths index)
1806                (loop
1807                  (when (>= index length)
1808                    (return))
1809                  (let ((old-index index))
1810                    (sc-offsets (sb!c::read-var-integer vector index))
1811                    (lengths (- index old-index))))
1812                (values error-number
1813                        (1+ length)
1814                        (sc-offsets)
1815                        (lengths))))))))
1816
1817 #|
1818 (defmacro break-cases (breaknum &body cases)
1819   (let ((bn-temp (gensym)))
1820     (collect ((clauses))
1821       (dolist (case cases)
1822         (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
1823       `(let ((,bn-temp ,breaknum))
1824          (cond ,@(clauses))))))
1825 |#
1826
1827 (defun break-control (chunk inst stream dstate)
1828   (declare (ignore inst))
1829   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
1830     ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
1831     ;; map has it undefined; and it should be easier to look in the target
1832     ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
1833     ;; from first principles whether it's defined in some way that genesis
1834     ;; can't grok.
1835     (case (byte-imm-code chunk dstate)
1836       (#.sb!vm:error-trap
1837        (nt "error trap")
1838        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1839       (#.sb!vm:cerror-trap
1840        (nt "cerror trap")
1841        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1842       (#.sb!vm:breakpoint-trap
1843        (nt "breakpoint trap"))
1844       (#.sb!vm:pending-interrupt-trap
1845        (nt "pending interrupt trap"))
1846       (#.sb!vm:halt-trap
1847        (nt "halt trap"))
1848       (#.sb!vm:function-end-breakpoint-trap
1849        (nt "function end breakpoint trap")))))
1850
1851 (define-instruction break (segment code)
1852   (:declare (type (unsigned-byte 8) code))
1853   (:printer byte-imm ((op #b11001100)) '(:name :tab code)
1854             :control #'break-control)
1855   (:emitter
1856    (emit-byte segment #b11001100)
1857    (emit-byte segment code)))
1858
1859 (define-instruction int (segment number)
1860   (:declare (type (unsigned-byte 8) number))
1861   (:printer byte-imm ((op #b11001101)))
1862   (:emitter
1863    (etypecase number
1864      ((member 3)
1865       (emit-byte segment #b11001100))
1866      ((unsigned-byte 8)
1867       (emit-byte segment #b11001101)
1868       (emit-byte segment number)))))
1869
1870 (define-instruction into (segment)
1871   (:printer byte ((op #b11001110)))
1872   (:emitter
1873    (emit-byte segment #b11001110)))
1874
1875 (define-instruction bound (segment reg bounds)
1876   (:emitter
1877    (let ((size (matching-operand-size reg bounds)))
1878      (when (eq size :byte)
1879        (error "can't bounds-test bytes: ~S" reg))
1880      (maybe-emit-operand-size-prefix segment size)
1881      (emit-byte segment #b01100010)
1882      (emit-ea segment bounds (reg-tn-encoding reg)))))
1883
1884 (define-instruction iret (segment)
1885   (:printer byte ((op #b11001111)))
1886   (:emitter
1887    (emit-byte segment #b11001111)))
1888 \f
1889 ;;;; processor control
1890
1891 (define-instruction hlt (segment)
1892   (:printer byte ((op #b11110100)))
1893   (:emitter
1894    (emit-byte segment #b11110100)))
1895
1896 (define-instruction nop (segment)
1897   (:printer byte ((op #b10010000)))
1898   (:emitter
1899    (emit-byte segment #b10010000)))
1900
1901 (define-instruction wait (segment)
1902   (:printer byte ((op #b10011011)))
1903   (:emitter
1904    (emit-byte segment #b10011011)))
1905
1906 (define-instruction lock (segment)
1907   (:printer byte ((op #b11110000)))
1908   (:emitter
1909    (emit-byte segment #b11110000)))
1910 \f
1911 ;;;; miscellaneous hackery
1912
1913 (define-instruction byte (segment byte)
1914   (:emitter
1915    (emit-byte segment byte)))
1916
1917 (define-instruction word (segment word)
1918   (:emitter
1919    (emit-word segment word)))
1920
1921 (define-instruction dword (segment dword)
1922   (:emitter
1923    (emit-dword segment dword)))
1924
1925 (defun emit-header-data (segment type)
1926   (emit-back-patch segment
1927                    4
1928                    (lambda (segment posn)
1929                      (emit-dword segment
1930                                  (logior type
1931                                          (ash (+ posn
1932                                                  (component-header-length))
1933                                               (- type-bits
1934                                                  word-shift)))))))
1935
1936 (define-instruction function-header-word (segment)
1937   (:emitter
1938    (emit-header-data segment function-header-type)))
1939
1940 (define-instruction lra-header-word (segment)
1941   (:emitter
1942    (emit-header-data segment return-pc-header-type)))
1943 \f
1944 ;;;; fp instructions
1945 ;;;;
1946 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
1947 ;;;;
1948 ;;;; Note: We treat the single-precision and double-precision variants
1949 ;;;; as separate instructions.
1950
1951 ;;; Load single to st(0).
1952 (define-instruction fld (segment source)
1953   (:printer floating-point ((op '(#b001 #b000))))
1954   (:emitter
1955     (emit-byte segment #b11011001)
1956     (emit-fp-op segment source #b000)))
1957
1958 ;;; Load double to st(0).
1959 (define-instruction fldd (segment source)
1960   (:printer floating-point ((op '(#b101 #b000))))
1961   (:printer floating-point-fp ((op '(#b001 #b000))))
1962   (:emitter
1963    (if (fp-reg-tn-p source)
1964        (emit-byte segment #b11011001)
1965      (emit-byte segment #b11011101))
1966     (emit-fp-op segment source #b000)))
1967
1968 ;;; Load long to st(0).
1969 (define-instruction fldl (segment source)
1970   (:printer floating-point ((op '(#b011 #b101))))
1971   (:emitter
1972     (emit-byte segment #b11011011)
1973     (emit-fp-op segment source #b101)))
1974
1975 ;;; Store single from st(0).
1976 (define-instruction fst (segment dest)
1977   (:printer floating-point ((op '(#b001 #b010))))
1978   (:emitter
1979     (cond ((fp-reg-tn-p dest)
1980            (emit-byte segment #b11011101)
1981            (emit-fp-op segment dest #b010))
1982           (t
1983            (emit-byte segment #b11011001)
1984            (emit-fp-op segment dest #b010)))))
1985
1986 ;;; Store double from st(0).
1987 (define-instruction fstd (segment dest)
1988   (:printer floating-point ((op '(#b101 #b010))))
1989   (:printer floating-point-fp ((op '(#b101 #b010))))
1990   (:emitter
1991    (cond ((fp-reg-tn-p dest)
1992           (emit-byte segment #b11011101)
1993           (emit-fp-op segment dest #b010))
1994          (t
1995           (emit-byte segment #b11011101)
1996           (emit-fp-op segment dest #b010)))))
1997
1998 ;;; Arithmetic ops are all done with at least one operand at top of
1999 ;;; stack. The other operand is is another register or a 32/64 bit
2000 ;;; memory loc.
2001
2002 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2003 ;;; that these conflict with the Gdb conventions for binops. To reduce
2004 ;;; the confusion I've added comments showing the mathamatical
2005 ;;; operation and the two syntaxes. By the ASM386 convention the
2006 ;;; instruction syntax is:
2007 ;;;
2008 ;;;      Fop Source
2009 ;;; or   Fop Destination, Source
2010 ;;;
2011 ;;; If only one operand is given then it is the source and the
2012 ;;; destination is ST(0). There are reversed forms of the fsub and
2013 ;;; fdiv instructions inducated by an 'R' suffix.
2014 ;;;
2015 ;;; The mathematical operation for the non-reverse form is always:
2016 ;;;     destination = destination op source
2017 ;;;
2018 ;;; For the reversed form it is:
2019 ;;;     destination = source op destination
2020 ;;;
2021 ;;; The instructions below only accept one operand at present which is
2022 ;;; usually the source. I've hack in extra instructions to implement
2023 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2024 ;;; the operand is the destination with the source being ST(0).
2025
2026 ;;; Add single:
2027 ;;;   st(0) = st(0) + memory or st(i).
2028 (define-instruction fadd (segment source)
2029   (:printer floating-point ((op '(#b000 #b000))))
2030   (:emitter
2031     (emit-byte segment #b11011000)
2032     (emit-fp-op segment source #b000)))
2033
2034 ;;; Add double:
2035 ;;;   st(0) = st(0) + memory or st(i).
2036 (define-instruction faddd (segment source)
2037   (:printer floating-point ((op '(#b100 #b000))))
2038   (:printer floating-point-fp ((op '(#b000 #b000))))
2039   (:emitter
2040    (if (fp-reg-tn-p source)
2041        (emit-byte segment #b11011000)
2042      (emit-byte segment #b11011100))
2043    (emit-fp-op segment source #b000)))
2044
2045 ;;; Add double destination st(i):
2046 ;;;   st(i) = st(0) + st(i).
2047 (define-instruction fadd-sti (segment destination)
2048   (:printer floating-point-fp ((op '(#b100 #b000))))
2049   (:emitter
2050    (assert (fp-reg-tn-p destination))
2051    (emit-byte segment #b11011100)
2052    (emit-fp-op segment destination #b000)))
2053 ;;; with pop
2054 (define-instruction faddp-sti (segment destination)
2055   (:printer floating-point-fp ((op '(#b110 #b000))))
2056   (:emitter
2057    (assert (fp-reg-tn-p destination))
2058    (emit-byte segment #b11011110)
2059    (emit-fp-op segment destination #b000)))
2060
2061 ;;; Subtract single:
2062 ;;;   st(0) = st(0) - memory or st(i).
2063 (define-instruction fsub (segment source)
2064   (:printer floating-point ((op '(#b000 #b100))))
2065   (:emitter
2066     (emit-byte segment #b11011000)
2067     (emit-fp-op segment source #b100)))
2068
2069 ;;; Subtract single, reverse:
2070 ;;;   st(0) = memory or st(i) - st(0).
2071 (define-instruction fsubr (segment source)
2072   (:printer floating-point ((op '(#b000 #b101))))
2073   (:emitter
2074     (emit-byte segment #b11011000)
2075     (emit-fp-op segment source #b101)))
2076
2077 ;;; Subtract double:
2078 ;;;   st(0) = st(0) - memory or st(i).
2079 (define-instruction fsubd (segment source)
2080   (:printer floating-point ((op '(#b100 #b100))))
2081   (:printer floating-point-fp ((op '(#b000 #b100))))
2082   (:emitter
2083    (if (fp-reg-tn-p source)
2084        (emit-byte segment #b11011000)
2085      (emit-byte segment #b11011100))
2086    (emit-fp-op segment source #b100)))
2087
2088 ;;; Subtract double, reverse:
2089 ;;;   st(0) = memory or st(i) - st(0).
2090 (define-instruction fsubrd (segment source)
2091   (:printer floating-point ((op '(#b100 #b101))))
2092   (:printer floating-point-fp ((op '(#b000 #b101))))
2093   (:emitter
2094    (if (fp-reg-tn-p source)
2095        (emit-byte segment #b11011000)
2096      (emit-byte segment #b11011100))
2097    (emit-fp-op segment source #b101)))
2098
2099 ;;; Subtract double, destination st(i):
2100 ;;;   st(i) = st(i) - st(0).
2101 ;;;
2102 ;;; ASM386 syntax: FSUB ST(i), ST
2103 ;;; Gdb    syntax: fsubr %st,%st(i)
2104 (define-instruction fsub-sti (segment destination)
2105   (:printer floating-point-fp ((op '(#b100 #b101))))
2106   (:emitter
2107    (assert (fp-reg-tn-p destination))
2108    (emit-byte segment #b11011100)
2109    (emit-fp-op segment destination #b101)))
2110 ;;; with a pop
2111 (define-instruction fsubp-sti (segment destination)
2112   (:printer floating-point-fp ((op '(#b110 #b101))))
2113   (:emitter
2114    (assert (fp-reg-tn-p destination))
2115    (emit-byte segment #b11011110)
2116    (emit-fp-op segment destination #b101)))
2117
2118 ;;; Subtract double, reverse, destination st(i):
2119 ;;;   st(i) = st(0) - st(i).
2120 ;;;
2121 ;;; ASM386 syntax: FSUBR ST(i), ST
2122 ;;; Gdb    syntax: fsub %st,%st(i)
2123 (define-instruction fsubr-sti (segment destination)
2124   (:printer floating-point-fp ((op '(#b100 #b100))))
2125   (:emitter
2126    (assert (fp-reg-tn-p destination))
2127    (emit-byte segment #b11011100)
2128    (emit-fp-op segment destination #b100)))
2129 ;;; with a pop
2130 (define-instruction fsubrp-sti (segment destination)
2131   (:printer floating-point-fp ((op '(#b110 #b100))))
2132   (:emitter
2133    (assert (fp-reg-tn-p destination))
2134    (emit-byte segment #b11011110)
2135    (emit-fp-op segment destination #b100)))
2136
2137 ;;; Multiply single:
2138 ;;;   st(0) = st(0) * memory or st(i).
2139 (define-instruction fmul (segment source)
2140   (:printer floating-point ((op '(#b000 #b001))))
2141   (:emitter
2142     (emit-byte segment #b11011000)
2143     (emit-fp-op segment source #b001)))
2144
2145 ;;; Multiply double:
2146 ;;;   st(0) = st(0) * memory or st(i).
2147 (define-instruction fmuld (segment source)
2148   (:printer floating-point ((op '(#b100 #b001))))
2149   (:printer floating-point-fp ((op '(#b000 #b001))))
2150   (:emitter
2151    (if (fp-reg-tn-p source)
2152        (emit-byte segment #b11011000)
2153      (emit-byte segment #b11011100))
2154    (emit-fp-op segment source #b001)))
2155
2156 ;;; Multiply double, destination st(i):
2157 ;;;   st(i) = st(i) * st(0).
2158 (define-instruction fmul-sti (segment destination)
2159   (:printer floating-point-fp ((op '(#b100 #b001))))
2160   (:emitter
2161    (assert (fp-reg-tn-p destination))
2162    (emit-byte segment #b11011100)
2163    (emit-fp-op segment destination #b001)))
2164
2165 ;;; Divide single:
2166 ;;;   st(0) = st(0) / memory or st(i).
2167 (define-instruction fdiv (segment source)
2168   (:printer floating-point ((op '(#b000 #b110))))
2169   (:emitter
2170     (emit-byte segment #b11011000)
2171     (emit-fp-op segment source #b110)))
2172
2173 ;;; Divide single, reverse:
2174 ;;;   st(0) = memory or st(i) / st(0).
2175 (define-instruction fdivr (segment source)
2176   (:printer floating-point ((op '(#b000 #b111))))
2177   (:emitter
2178     (emit-byte segment #b11011000)
2179     (emit-fp-op segment source #b111)))
2180
2181 ;;; Divide double:
2182 ;;;   st(0) = st(0) / memory or st(i).
2183 (define-instruction fdivd (segment source)
2184   (:printer floating-point ((op '(#b100 #b110))))
2185   (:printer floating-point-fp ((op '(#b000 #b110))))
2186   (:emitter
2187    (if (fp-reg-tn-p source)
2188        (emit-byte segment #b11011000)
2189      (emit-byte segment #b11011100))
2190    (emit-fp-op segment source #b110)))
2191
2192 ;;; Divide double, reverse:
2193 ;;;   st(0) = memory or st(i) / st(0).
2194 (define-instruction fdivrd (segment source)
2195   (:printer floating-point ((op '(#b100 #b111))))
2196   (:printer floating-point-fp ((op '(#b000 #b111))))
2197   (:emitter
2198    (if (fp-reg-tn-p source)
2199        (emit-byte segment #b11011000)
2200      (emit-byte segment #b11011100))
2201    (emit-fp-op segment source #b111)))
2202
2203 ;;; Divide double, destination st(i):
2204 ;;;   st(i) = st(i) / st(0).
2205 ;;;
2206 ;;; ASM386 syntax: FDIV ST(i), ST
2207 ;;; Gdb    syntax: fdivr %st,%st(i)
2208 (define-instruction fdiv-sti (segment destination)
2209   (:printer floating-point-fp ((op '(#b100 #b111))))
2210   (:emitter
2211    (assert (fp-reg-tn-p destination))
2212    (emit-byte segment #b11011100)
2213    (emit-fp-op segment destination #b111)))
2214
2215 ;;; Divide double, reverse, destination st(i):
2216 ;;;   st(i) = st(0) / st(i).
2217 ;;;
2218 ;;; ASM386 syntax: FDIVR ST(i), ST
2219 ;;; Gdb    syntax: fdiv %st,%st(i)
2220 (define-instruction fdivr-sti (segment destination)
2221   (:printer floating-point-fp ((op '(#b100 #b110))))
2222   (:emitter
2223    (assert (fp-reg-tn-p destination))
2224    (emit-byte segment #b11011100)
2225    (emit-fp-op segment destination #b110)))
2226
2227 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2228 (define-instruction fxch (segment source)
2229   (:printer floating-point-fp ((op '(#b001 #b001))))
2230   (:emitter
2231     (unless (and (tn-p source)
2232                  (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
2233       (cl:break))
2234     (emit-byte segment #b11011001)
2235     (emit-fp-op segment source #b001)))
2236
2237 ;;; Push 32-bit integer to st0.
2238 (define-instruction fild (segment source)
2239   (:printer floating-point ((op '(#b011 #b000))))
2240   (:emitter
2241    (emit-byte segment #b11011011)
2242    (emit-fp-op segment source #b000)))
2243
2244 ;;; Push 64-bit integer to st0.
2245 (define-instruction fildl (segment source)
2246   (:printer floating-point ((op '(#b111 #b101))))
2247   (:emitter
2248    (emit-byte segment #b11011111)
2249    (emit-fp-op segment source #b101)))
2250
2251 ;;; Store 32-bit integer.
2252 (define-instruction fist (segment dest)
2253   (:printer floating-point ((op '(#b011 #b010))))
2254   (:emitter
2255    (emit-byte segment #b11011011)
2256    (emit-fp-op segment dest #b010)))
2257
2258 ;;; Store and pop 32-bit integer.
2259 (define-instruction fistp (segment dest)
2260   (:printer floating-point ((op '(#b011 #b011))))
2261   (:emitter
2262    (emit-byte segment #b11011011)
2263    (emit-fp-op segment dest #b011)))
2264
2265 ;;; Store and pop 64-bit integer.
2266 (define-instruction fistpl (segment dest)
2267   (:printer floating-point ((op '(#b111 #b111))))
2268   (:emitter
2269    (emit-byte segment #b11011111)
2270    (emit-fp-op segment dest #b111)))
2271
2272 ;;; Store single from st(0) and pop.
2273 (define-instruction fstp (segment dest)
2274   (:printer floating-point ((op '(#b001 #b011))))
2275   (:emitter
2276    (cond ((fp-reg-tn-p dest)
2277           (emit-byte segment #b11011101)
2278           (emit-fp-op segment dest #b011))
2279          (t
2280           (emit-byte segment #b11011001)
2281           (emit-fp-op segment dest #b011)))))
2282
2283 ;;; Store double from st(0) and pop.
2284 (define-instruction fstpd (segment dest)
2285   (:printer floating-point ((op '(#b101 #b011))))
2286   (:printer floating-point-fp ((op '(#b101 #b011))))
2287   (:emitter
2288    (cond ((fp-reg-tn-p dest)
2289           (emit-byte segment #b11011101)
2290           (emit-fp-op segment dest #b011))
2291          (t
2292           (emit-byte segment #b11011101)
2293           (emit-fp-op segment dest #b011)))))
2294
2295 ;;; Store long from st(0) and pop.
2296 (define-instruction fstpl (segment dest)
2297   (:printer floating-point ((op '(#b011 #b111))))
2298   (:emitter
2299     (emit-byte segment #b11011011)
2300     (emit-fp-op segment dest #b111)))
2301
2302 ;;; Decrement stack-top pointer.
2303 (define-instruction fdecstp (segment)
2304   (:printer floating-point-no ((op #b10110)))
2305   (:emitter
2306    (emit-byte segment #b11011001)
2307    (emit-byte segment #b11110110)))
2308
2309 ;;; Increment stack-top pointer.
2310 (define-instruction fincstp (segment)
2311   (:printer floating-point-no ((op #b10111)))
2312   (:emitter
2313    (emit-byte segment #b11011001)
2314    (emit-byte segment #b11110111)))
2315
2316 ;;; Free fp register.
2317 (define-instruction ffree (segment dest)
2318   (:printer floating-point-fp ((op '(#b101 #b000))))
2319   (:emitter
2320    (emit-byte segment #b11011101)
2321    (emit-fp-op segment dest #b000)))
2322
2323 (define-instruction fabs (segment)
2324   (:printer floating-point-no ((op #b00001)))
2325   (:emitter
2326    (emit-byte segment #b11011001)
2327    (emit-byte segment #b11100001)))
2328
2329 (define-instruction fchs (segment)
2330   (:printer floating-point-no ((op #b00000)))
2331   (:emitter
2332    (emit-byte segment #b11011001)
2333    (emit-byte segment #b11100000)))
2334
2335 (define-instruction frndint(segment)
2336   (:printer floating-point-no ((op #b11100)))
2337   (:emitter
2338    (emit-byte segment #b11011001)
2339    (emit-byte segment #b11111100)))
2340
2341 ;;; Initialize NPX.
2342 (define-instruction fninit(segment)
2343   (:printer floating-point-5 ((op #b00011)))
2344   (:emitter
2345    (emit-byte segment #b11011011)
2346    (emit-byte segment #b11100011)))
2347
2348 ;;; Store Status Word to AX.
2349 (define-instruction fnstsw(segment)
2350   (:printer floating-point-st ((op #b00000)))
2351   (:emitter
2352    (emit-byte segment #b11011111)
2353    (emit-byte segment #b11100000)))
2354
2355 ;;; Load Control Word.
2356 ;;;
2357 ;;; src must be a memory location
2358 (define-instruction fldcw(segment src)
2359   (:printer floating-point ((op '(#b001 #b101))))
2360   (:emitter
2361    (emit-byte segment #b11011001)
2362    (emit-fp-op segment src #b101)))
2363
2364 ;;; Store Control Word.
2365 (define-instruction fnstcw(segment dst)
2366   (:printer floating-point ((op '(#b001 #b111))))
2367   (:emitter
2368    (emit-byte segment #b11011001)
2369    (emit-fp-op segment dst #b111)))
2370
2371 ;;; Store FP Environment.
2372 (define-instruction fstenv(segment dst)
2373   (:printer floating-point ((op '(#b001 #b110))))
2374   (:emitter
2375    (emit-byte segment #b11011001)
2376    (emit-fp-op segment dst #b110)))
2377
2378 ;;; Restore FP Environment.
2379 (define-instruction fldenv(segment src)
2380   (:printer floating-point ((op '(#b001 #b100))))
2381   (:emitter
2382    (emit-byte segment #b11011001)
2383    (emit-fp-op segment src #b100)))
2384
2385 ;;; Save FP State.
2386 (define-instruction fsave(segment dst)
2387   (:printer floating-point ((op '(#b101 #b110))))
2388   (:emitter
2389    (emit-byte segment #b11011101)
2390    (emit-fp-op segment dst #b110)))
2391
2392 ;;; Restore FP State.
2393 (define-instruction frstor(segment src)
2394   (:printer floating-point ((op '(#b101 #b100))))
2395   (:emitter
2396    (emit-byte segment #b11011101)
2397    (emit-fp-op segment src #b100)))
2398
2399 ;;; Clear exceptions.
2400 (define-instruction fnclex(segment)
2401   (:printer floating-point-5 ((op #b00010)))
2402   (:emitter
2403    (emit-byte segment #b11011011)
2404    (emit-byte segment #b11100010)))
2405
2406 ;;; comparison
2407 (define-instruction fcom (segment src)
2408   (:printer floating-point ((op '(#b000 #b010))))
2409   (:emitter
2410    (emit-byte segment #b11011000)
2411    (emit-fp-op segment src #b010)))
2412
2413 (define-instruction fcomd (segment src)
2414   (:printer floating-point ((op '(#b100 #b010))))
2415   (:printer floating-point-fp ((op '(#b000 #b010))))
2416   (:emitter
2417    (if (fp-reg-tn-p src)
2418        (emit-byte segment #b11011000)
2419      (emit-byte segment #b11011100))
2420    (emit-fp-op segment src #b010)))
2421
2422 ;;; Compare ST1 to ST0, popping the stack twice.
2423 (define-instruction fcompp (segment)
2424   (:printer floating-point-3 ((op '(#b110 #b011001))))
2425   (:emitter
2426    (emit-byte segment #b11011110)
2427    (emit-byte segment #b11011001)))
2428
2429 ;;; unordered comparison
2430 (define-instruction fucom (segment src)
2431   ;; XX Printer conflicts with frstor
2432   ;; (:printer floating-point ((op '(#b101 #b100))))
2433   (:emitter
2434    (assert (fp-reg-tn-p src))
2435    (emit-byte segment #b11011101)
2436    (emit-fp-op segment src #b100)))
2437
2438 (define-instruction ftst (segment)
2439   (:printer floating-point-no ((op #b00100)))
2440   (:emitter
2441    (emit-byte segment #b11011001)
2442    (emit-byte segment #b11100100)))
2443
2444 ;;;; 80387 specials
2445
2446 (define-instruction fsqrt(segment)
2447   (:printer floating-point-no ((op #b11010)))
2448   (:emitter
2449    (emit-byte segment #b11011001)
2450    (emit-byte segment #b11111010)))
2451
2452 (define-instruction fscale(segment)
2453   (:printer floating-point-no ((op #b11101)))
2454   (:emitter
2455    (emit-byte segment #b11011001)
2456    (emit-byte segment #b11111101)))
2457
2458 (define-instruction fxtract(segment)
2459   (:printer floating-point-no ((op #b10100)))
2460   (:emitter
2461    (emit-byte segment #b11011001)
2462    (emit-byte segment #b11110100)))
2463
2464 (define-instruction fsin(segment)
2465   (:printer floating-point-no ((op #b11110)))
2466   (:emitter
2467    (emit-byte segment #b11011001)
2468    (emit-byte segment #b11111110)))
2469
2470 (define-instruction fcos(segment)
2471   (:printer floating-point-no ((op #b11111)))
2472   (:emitter
2473    (emit-byte segment #b11011001)
2474    (emit-byte segment #b11111111)))
2475
2476 (define-instruction fprem1(segment)
2477   (:printer floating-point-no ((op #b10101)))
2478   (:emitter
2479    (emit-byte segment #b11011001)
2480    (emit-byte segment #b11110101)))
2481
2482 (define-instruction fprem(segment)
2483   (:printer floating-point-no ((op #b11000)))
2484   (:emitter
2485    (emit-byte segment #b11011001)
2486    (emit-byte segment #b11111000)))
2487
2488 (define-instruction fxam (segment)
2489   (:printer floating-point-no ((op #b00101)))
2490   (:emitter
2491    (emit-byte segment #b11011001)
2492    (emit-byte segment #b11100101)))
2493
2494 ;;; These do push/pop to stack and need special handling
2495 ;;; in any VOPs that use them. See the book.
2496
2497 ;;; st0 <- st1*log2(st0)
2498 (define-instruction fyl2x(segment)      ; pops stack
2499   (:printer floating-point-no ((op #b10001)))
2500   (:emitter
2501    (emit-byte segment #b11011001)
2502    (emit-byte segment #b11110001)))
2503
2504 (define-instruction fyl2xp1(segment)
2505   (:printer floating-point-no ((op #b11001)))
2506   (:emitter
2507    (emit-byte segment #b11011001)
2508    (emit-byte segment #b11111001)))
2509
2510 (define-instruction f2xm1(segment)
2511   (:printer floating-point-no ((op #b10000)))
2512   (:emitter
2513    (emit-byte segment #b11011001)
2514    (emit-byte segment #b11110000)))
2515
2516 (define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
2517   (:printer floating-point-no ((op #b10010)))
2518   (:emitter
2519    (emit-byte segment #b11011001)
2520    (emit-byte segment #b11110010)))
2521
2522 (define-instruction fpatan(segment)     ; POPS STACK
2523   (:printer floating-point-no ((op #b10011)))
2524   (:emitter
2525    (emit-byte segment #b11011001)
2526    (emit-byte segment #b11110011)))
2527
2528 ;;;; loading constants
2529
2530 (define-instruction fldz(segment)
2531   (:printer floating-point-no ((op #b01110)))
2532   (:emitter
2533    (emit-byte segment #b11011001)
2534    (emit-byte segment #b11101110)))
2535
2536 (define-instruction fld1(segment)
2537   (:printer floating-point-no ((op #b01000)))
2538   (:emitter
2539    (emit-byte segment #b11011001)
2540    (emit-byte segment #b11101000)))
2541
2542 (define-instruction fldpi(segment)
2543   (:printer floating-point-no ((op #b01011)))
2544   (:emitter
2545    (emit-byte segment #b11011001)
2546    (emit-byte segment #b11101011)))
2547
2548 (define-instruction fldl2t(segment)
2549   (:printer floating-point-no ((op #b01001)))
2550   (:emitter
2551    (emit-byte segment #b11011001)
2552    (emit-byte segment #b11101001)))
2553
2554 (define-instruction fldl2e(segment)
2555   (:printer floating-point-no ((op #b01010)))
2556   (:emitter
2557    (emit-byte segment #b11011001)
2558    (emit-byte segment #b11101010)))
2559
2560 (define-instruction fldlg2(segment)
2561   (:printer floating-point-no ((op #b01100)))
2562   (:emitter
2563    (emit-byte segment #b11011001)
2564    (emit-byte segment #b11101100)))
2565
2566 (define-instruction fldln2(segment)
2567   (:printer floating-point-no ((op #b01101)))
2568   (:emitter
2569    (emit-byte segment #b11011001)
2570    (emit-byte segment #b11101101)))