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