src/compiler/x86/insts.lisp

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