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