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