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