src/compiler/x86/insts.lisp

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