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 \f
1289 (defun emit-prefix (segment name)
1290   (ecase name
1291     ((nil))
1292     (:lock
1293      #!+sb-thread
1294      (emit-byte segment #xf0))
1295     (:fs
1296      (emit-byte segment #x64))
1297     (:gs
1298      (emit-byte segment #x65))))
1299
1300 (define-instruction fs-segment-prefix (segment)
1301   (:printer byte ((op #b01100100)))
1302   (:emitter
1303    (bug "FS emitted as a separate instruction!")))
1304
1305 (define-instruction gs-segment-prefix (segment)
1306   (:printer byte ((op #b01100101)))
1307   (:emitter
1308    (bug "GS emitted as a separate instruction!")))
1309
1310 ;;;; flag control instructions
1311
1312 ;;; CLC -- Clear Carry Flag.
1313 (define-instruction clc (segment)
1314   (:printer byte ((op #b11111000)))
1315   (:emitter
1316    (emit-byte segment #b11111000)))
1317
1318 ;;; CLD -- Clear Direction Flag.
1319 (define-instruction cld (segment)
1320   (:printer byte ((op #b11111100)))
1321   (:emitter
1322    (emit-byte segment #b11111100)))
1323
1324 ;;; CLI -- Clear Iterrupt Enable Flag.
1325 (define-instruction cli (segment)
1326   (:printer byte ((op #b11111010)))
1327   (:emitter
1328    (emit-byte segment #b11111010)))
1329
1330 ;;; CMC -- Complement Carry Flag.
1331 (define-instruction cmc (segment)
1332   (:printer byte ((op #b11110101)))
1333   (:emitter
1334    (emit-byte segment #b11110101)))
1335
1336 ;;; LAHF -- Load AH into flags.
1337 (define-instruction lahf (segment)
1338   (:printer byte ((op #b10011111)))
1339   (:emitter
1340    (emit-byte segment #b10011111)))
1341
1342 ;;; POPF -- Pop flags.
1343 (define-instruction popf (segment)
1344   (:printer byte ((op #b10011101)))
1345   (:emitter
1346    (emit-byte segment #b10011101)))
1347
1348 ;;; PUSHF -- push flags.
1349 (define-instruction pushf (segment)
1350   (:printer byte ((op #b10011100)))
1351   (:emitter
1352    (emit-byte segment #b10011100)))
1353
1354 ;;; SAHF -- Store AH into flags.
1355 (define-instruction sahf (segment)
1356   (:printer byte ((op #b10011110)))
1357   (:emitter
1358    (emit-byte segment #b10011110)))
1359
1360 ;;; STC -- Set Carry Flag.
1361 (define-instruction stc (segment)
1362   (:printer byte ((op #b11111001)))
1363   (:emitter
1364    (emit-byte segment #b11111001)))
1365
1366 ;;; STD -- Set Direction Flag.
1367 (define-instruction std (segment)
1368   (:printer byte ((op #b11111101)))
1369   (:emitter
1370    (emit-byte segment #b11111101)))
1371
1372 ;;; STI -- Set Interrupt Enable Flag.
1373 (define-instruction sti (segment)
1374   (:printer byte ((op #b11111011)))
1375   (:emitter
1376    (emit-byte segment #b11111011)))
1377 \f
1378 ;;;; arithmetic
1379
1380 (defun emit-random-arith-inst (name segment dst src opcode
1381                                &optional allow-constants)
1382   (let ((size (matching-operand-size dst src)))
1383     (maybe-emit-operand-size-prefix segment size)
1384     (cond
1385      ((integerp src)
1386       (cond ((and (not (eq size :byte)) (<= -128 src 127))
1387              (emit-byte segment #b10000011)
1388              (emit-ea segment dst opcode allow-constants)
1389              (emit-byte segment src))
1390             ((accumulator-p dst)
1391              (emit-byte segment
1392                         (dpb opcode
1393                              (byte 3 3)
1394                              (if (eq size :byte)
1395                                  #b00000100
1396                                  #b00000101)))
1397              (emit-sized-immediate segment size src))
1398             (t
1399              (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1400              (emit-ea segment dst opcode allow-constants)
1401              (emit-sized-immediate segment size src))))
1402      ((register-p src)
1403       (emit-byte segment
1404                  (dpb opcode
1405                       (byte 3 3)
1406                       (if (eq size :byte) #b00000000 #b00000001)))
1407       (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1408      ((register-p dst)
1409       (emit-byte segment
1410                  (dpb opcode
1411                       (byte 3 3)
1412                       (if (eq size :byte) #b00000010 #b00000011)))
1413       (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1414      (t
1415       (error "bogus operands to ~A" name)))))
1416
1417 (eval-when (:compile-toplevel :execute)
1418   (defun arith-inst-printer-list (subop)
1419     `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1420       (x66-accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1421       (reg/mem-imm ((op (#b1000000 ,subop))))
1422       (x66-reg/mem-imm ((op (#b1000000 ,subop))))
1423       (reg/mem-imm ((op (#b1000001 ,subop))
1424                     (imm nil :type signed-imm-byte)))
1425       (x66-reg/mem-imm ((op (#b1000001 ,subop))
1426                         (imm nil :type signed-imm-byte)))
1427       (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
1428       (x66-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1429   )
1430
1431 (define-instruction add (segment dst src &optional prefix)
1432   (:printer-list (arith-inst-printer-list #b000))
1433   (:emitter
1434    (emit-prefix segment prefix)
1435    (emit-random-arith-inst "ADD" segment dst src #b000)))
1436
1437 (define-instruction adc (segment dst src)
1438   (:printer-list (arith-inst-printer-list #b010))
1439   (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1440
1441 (define-instruction sub (segment dst src &optional prefix)
1442   (:printer-list (arith-inst-printer-list #b101))
1443   (:emitter
1444    (emit-prefix segment prefix)
1445    (emit-random-arith-inst "SUB" segment dst src #b101)))
1446
1447 (define-instruction sbb (segment dst src)
1448   (:printer-list (arith-inst-printer-list #b011))
1449   (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1450
1451 (define-instruction cmp (segment dst src &optional prefix)
1452   (:printer-list (arith-inst-printer-list #b111))
1453   (:emitter
1454    (emit-prefix segment prefix)
1455    (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1456
1457 (define-instruction inc (segment dst)
1458   ;; Register.
1459   (:printer reg-no-width ((op #b01000)))
1460   (:printer x66-reg-no-width ((op #b01000)))
1461   ;; Register/Memory
1462   (:printer reg/mem ((op '(#b1111111 #b000))))
1463   (:printer x66-reg/mem ((op '(#b1111111 #b000))))
1464   (:emitter
1465    (let ((size (operand-size dst)))
1466      (maybe-emit-operand-size-prefix segment size)
1467      (cond ((and (not (eq size :byte)) (register-p dst))
1468             (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1469            (t
1470             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1471             (emit-ea segment dst #b000))))))
1472
1473 (define-instruction dec (segment dst)
1474   ;; Register.
1475   (:printer reg-no-width ((op #b01001)))
1476   (:printer x66-reg-no-width ((op #b01001)))
1477   ;; Register/Memory
1478   (:printer reg/mem ((op '(#b1111111 #b001))))
1479   (:printer x66-reg/mem ((op '(#b1111111 #b001))))
1480   (:emitter
1481    (let ((size (operand-size dst)))
1482      (maybe-emit-operand-size-prefix segment size)
1483      (cond ((and (not (eq size :byte)) (register-p dst))
1484             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1485            (t
1486             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1487             (emit-ea segment dst #b001))))))
1488
1489 (define-instruction neg (segment dst)
1490   (:printer reg/mem ((op '(#b1111011 #b011))))
1491   (:printer x66-reg/mem ((op '(#b1111011 #b011))))
1492   (:emitter
1493    (let ((size (operand-size dst)))
1494      (maybe-emit-operand-size-prefix segment size)
1495      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1496      (emit-ea segment dst #b011))))
1497
1498 (define-instruction aaa (segment)
1499   (:printer byte ((op #b00110111)))
1500   (:emitter
1501    (emit-byte segment #b00110111)))
1502
1503 (define-instruction aas (segment)
1504   (:printer byte ((op #b00111111)))
1505   (:emitter
1506    (emit-byte segment #b00111111)))
1507
1508 (define-instruction daa (segment)
1509   (:printer byte ((op #b00100111)))
1510   (:emitter
1511    (emit-byte segment #b00100111)))
1512
1513 (define-instruction das (segment)
1514   (:printer byte ((op #b00101111)))
1515   (:emitter
1516    (emit-byte segment #b00101111)))
1517
1518 (define-instruction mul (segment dst src)
1519   (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1520   (:printer x66-accum-reg/mem ((op '(#b1111011 #b100))))
1521   (:emitter
1522    (let ((size (matching-operand-size dst src)))
1523      (aver (accumulator-p dst))
1524      (maybe-emit-operand-size-prefix segment size)
1525      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1526      (emit-ea segment src #b100))))
1527
1528 (define-instruction imul (segment dst &optional src1 src2)
1529   (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1530   (:printer x66-accum-reg/mem ((op '(#b1111011 #b101))))
1531   (:printer ext-reg-reg/mem ((op #b1010111)))
1532   (:printer x66-ext-reg-reg/mem ((op #b1010111)))
1533   (:printer reg-reg/mem ((op #b0110100) (width 1)
1534                          (imm nil :type 'signed-imm-word))
1535             '(:name :tab reg ", " reg/mem ", " imm))
1536   (:printer x66-reg-reg/mem ((op #b0110100) (width 1)
1537                              (imm nil :type 'signed-imm-word))
1538             '(:name :tab reg ", " reg/mem ", " imm))
1539   (:printer reg-reg/mem ((op #b0110101) (width 1)
1540                          (imm nil :type 'signed-imm-byte))
1541             '(:name :tab reg ", " reg/mem ", " imm))
1542   (:printer x66-reg-reg/mem ((op #b0110101) (width 1)
1543                              (imm nil :type 'signed-imm-byte))
1544             '(:name :tab reg ", " reg/mem ", " imm))
1545   (:emitter
1546    (flet ((r/m-with-immed-to-reg (reg r/m immed)
1547             (let* ((size (matching-operand-size reg r/m))
1548                    (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1549               (maybe-emit-operand-size-prefix segment size)
1550               (emit-byte segment (if sx #b01101011 #b01101001))
1551               (emit-ea segment r/m (reg-tn-encoding reg))
1552               (if sx
1553                   (emit-byte segment immed)
1554                   (emit-sized-immediate segment size immed)))))
1555      (cond (src2
1556             (r/m-with-immed-to-reg dst src1 src2))
1557            (src1
1558             (if (integerp src1)
1559                 (r/m-with-immed-to-reg dst dst src1)
1560                 (let ((size (matching-operand-size dst src1)))
1561                   (maybe-emit-operand-size-prefix segment size)
1562                   (emit-byte segment #b00001111)
1563                   (emit-byte segment #b10101111)
1564                   (emit-ea segment src1 (reg-tn-encoding dst)))))
1565            (t
1566             (let ((size (operand-size dst)))
1567               (maybe-emit-operand-size-prefix segment size)
1568               (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1569               (emit-ea segment dst #b101)))))))
1570
1571 (define-instruction div (segment dst src)
1572   (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1573   (:printer x66-accum-reg/mem ((op '(#b1111011 #b110))))
1574   (:emitter
1575    (let ((size (matching-operand-size dst src)))
1576      (aver (accumulator-p dst))
1577      (maybe-emit-operand-size-prefix segment size)
1578      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1579      (emit-ea segment src #b110))))
1580
1581 (define-instruction idiv (segment dst src)
1582   (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1583   (:printer x66-accum-reg/mem ((op '(#b1111011 #b111))))
1584   (:emitter
1585    (let ((size (matching-operand-size dst src)))
1586      (aver (accumulator-p dst))
1587      (maybe-emit-operand-size-prefix segment size)
1588      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1589      (emit-ea segment src #b111))))
1590
1591 (define-instruction aad (segment)
1592   (:printer two-bytes ((op '(#b11010101 #b00001010))))
1593   (:emitter
1594    (emit-byte segment #b11010101)
1595    (emit-byte segment #b00001010)))
1596
1597 (define-instruction aam (segment)
1598   (:printer two-bytes ((op '(#b11010100 #b00001010))))
1599   (:emitter
1600    (emit-byte segment #b11010100)
1601    (emit-byte segment #b00001010)))
1602
1603 (define-instruction bswap (segment dst)
1604   (:printer ext-reg-no-width ((op #b11001)))
1605   (:emitter
1606    (emit-byte segment #x0f)
1607    (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst))))
1608
1609 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1610 (define-instruction cbw (segment)
1611   (:printer two-bytes ((op '(#b01100110 #b10011000))))
1612   (:emitter
1613    (maybe-emit-operand-size-prefix segment :word)
1614    (emit-byte segment #b10011000)))
1615
1616 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1617 (define-instruction cwde (segment)
1618   (:printer byte ((op #b10011000)))
1619   (:emitter
1620    (maybe-emit-operand-size-prefix segment :dword)
1621    (emit-byte segment #b10011000)))
1622
1623 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1624 (define-instruction cwd (segment)
1625   (:printer two-bytes ((op '(#b01100110 #b10011001))))
1626   (:emitter
1627    (maybe-emit-operand-size-prefix segment :word)
1628    (emit-byte segment #b10011001)))
1629
1630 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1631 (define-instruction cdq (segment)
1632   (:printer byte ((op #b10011001)))
1633   (:emitter
1634    (maybe-emit-operand-size-prefix segment :dword)
1635    (emit-byte segment #b10011001)))
1636
1637 (define-instruction xadd (segment dst src &optional prefix)
1638   ;; Register/Memory with Register.
1639   (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1640   (:printer x66-ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1641   (:emitter
1642    (aver (register-p src))
1643    (emit-prefix segment prefix)
1644    (let ((size (matching-operand-size src dst)))
1645      (maybe-emit-operand-size-prefix segment size)
1646      (emit-byte segment #b00001111)
1647      (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1648      (emit-ea segment dst (reg-tn-encoding src)))))
1649
1650 \f
1651 ;;;; logic
1652
1653 (defun emit-shift-inst (segment dst amount opcode)
1654   (let ((size (operand-size dst)))
1655     (maybe-emit-operand-size-prefix segment size)
1656     (multiple-value-bind (major-opcode immed)
1657         (case amount
1658           (:cl (values #b11010010 nil))
1659           (1 (values #b11010000 nil))
1660           (t (values #b11000000 t)))
1661       (emit-byte segment
1662                  (if (eq size :byte) major-opcode (logior major-opcode 1)))
1663       (emit-ea segment dst opcode)
1664       (when immed
1665         (emit-byte segment amount)))))
1666
1667 (eval-when (:compile-toplevel :execute)
1668   (defun shift-inst-printer-list (subop)
1669     `((reg/mem ((op (#b1101000 ,subop)))
1670                (:name :tab reg/mem ", 1"))
1671       (x66-reg/mem ((op (#b1101000 ,subop)))
1672                    (:name :tab reg/mem ", 1"))
1673       (reg/mem ((op (#b1101001 ,subop)))
1674                (:name :tab reg/mem ", " 'cl))
1675       (x66-reg/mem ((op (#b1101001 ,subop)))
1676                    (:name :tab reg/mem ", " 'cl))
1677       (reg/mem-imm ((op (#b1100000 ,subop))
1678                     (imm nil :type signed-imm-byte)))
1679       (x66-reg/mem-imm ((op (#b1100000 ,subop))
1680                         (imm nil :type signed-imm-byte))))))
1681
1682 (define-instruction rol (segment dst amount)
1683   (:printer-list
1684    (shift-inst-printer-list #b000))
1685   (:emitter
1686    (emit-shift-inst segment dst amount #b000)))
1687
1688 (define-instruction ror (segment dst amount)
1689   (:printer-list
1690    (shift-inst-printer-list #b001))
1691   (:emitter
1692    (emit-shift-inst segment dst amount #b001)))
1693
1694 (define-instruction rcl (segment dst amount)
1695   (:printer-list
1696    (shift-inst-printer-list #b010))
1697   (:emitter
1698    (emit-shift-inst segment dst amount #b010)))
1699
1700 (define-instruction rcr (segment dst amount)
1701   (:printer-list
1702    (shift-inst-printer-list #b011))
1703   (:emitter
1704    (emit-shift-inst segment dst amount #b011)))
1705
1706 (define-instruction shl (segment dst amount)
1707   (:printer-list
1708    (shift-inst-printer-list #b100))
1709   (:emitter
1710    (emit-shift-inst segment dst amount #b100)))
1711
1712 (define-instruction shr (segment dst amount)
1713   (:printer-list
1714    (shift-inst-printer-list #b101))
1715   (:emitter
1716    (emit-shift-inst segment dst amount #b101)))
1717
1718 (define-instruction sar (segment dst amount)
1719   (:printer-list
1720    (shift-inst-printer-list #b111))
1721   (:emitter
1722    (emit-shift-inst segment dst amount #b111)))
1723
1724 (defun emit-double-shift (segment opcode dst src amt)
1725   (let ((size (matching-operand-size dst src)))
1726     (when (eq size :byte)
1727       (error "Double shifts can only be used with words."))
1728     (maybe-emit-operand-size-prefix segment size)
1729     (emit-byte segment #b00001111)
1730     (emit-byte segment (dpb opcode (byte 1 3)
1731                             (if (eq amt :cl) #b10100101 #b10100100)))
1732     #+nil
1733     (emit-ea segment dst src)
1734     (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1735     (unless (eq amt :cl)
1736       (emit-byte segment amt))))
1737
1738 (eval-when (:compile-toplevel :execute)
1739   (defun double-shift-inst-printer-list (op)
1740     `(#+nil
1741       (ext-reg-reg/mem-imm ((op ,(logior op #b10))
1742                             (imm nil :type signed-imm-byte)))
1743       (ext-reg-reg/mem ((op ,(logior op #b10)))
1744          (:name :tab reg/mem ", " reg ", " 'cl))
1745       (x66-ext-reg-reg/mem ((op ,(logior op #b10)))
1746          (:name :tab reg/mem ", " reg ", " 'cl)))))
1747
1748 (define-instruction shld (segment dst src amt)
1749   (:declare (type (or (member :cl) (mod 32)) amt))
1750   (:printer-list (double-shift-inst-printer-list #b1010000))
1751   (:emitter
1752    (emit-double-shift segment #b0 dst src amt)))
1753
1754 (define-instruction shrd (segment dst src amt)
1755   (:declare (type (or (member :cl) (mod 32)) amt))
1756   (:printer-list (double-shift-inst-printer-list #b1010100))
1757   (:emitter
1758    (emit-double-shift segment #b1 dst src amt)))
1759
1760 (define-instruction and (segment dst src)
1761   (:printer-list
1762    (arith-inst-printer-list #b100))
1763   (:emitter
1764    (emit-random-arith-inst "AND" segment dst src #b100)))
1765
1766 (define-instruction test (segment this that)
1767   (:printer accum-imm ((op #b1010100)))
1768   (:printer x66-accum-imm ((op #b1010100)))
1769   (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1770   (:printer x66-reg/mem-imm ((op '(#b1111011 #b000))))
1771   (:printer reg-reg/mem ((op #b1000010)))
1772   (:printer x66-reg-reg/mem ((op #b1000010)))
1773   (:emitter
1774    (let ((size (matching-operand-size this that)))
1775      (maybe-emit-operand-size-prefix segment size)
1776      (flet ((test-immed-and-something (immed something)
1777               (cond ((accumulator-p something)
1778                      (emit-byte segment
1779                                 (if (eq size :byte) #b10101000 #b10101001))
1780                      (emit-sized-immediate segment size immed))
1781                     (t
1782                      (emit-byte segment
1783                                 (if (eq size :byte) #b11110110 #b11110111))
1784                      (emit-ea segment something #b000)
1785                      (emit-sized-immediate segment size immed))))
1786             (test-reg-and-something (reg something)
1787               (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1788               (emit-ea segment something (reg-tn-encoding reg))))
1789        (cond ((integerp that)
1790               (test-immed-and-something that this))
1791              ((integerp this)
1792               (test-immed-and-something this that))
1793              ((register-p this)
1794               (test-reg-and-something this that))
1795              ((register-p that)
1796               (test-reg-and-something that this))
1797              (t
1798               (error "bogus operands for TEST: ~S and ~S" this that)))))))
1799
1800 ;;; Emit the most compact form of the test immediate instruction,
1801 ;;; using an 8 bit test when the immediate is only 8 bits and the
1802 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
1803 ;;; control stack.
1804 (defun emit-optimized-test-inst (x y)
1805   (typecase y
1806     ((unsigned-byte 7)
1807      (let ((offset (tn-offset x)))
1808        (cond ((and (sc-is x any-reg descriptor-reg)
1809                    (or (= offset eax-offset) (= offset ebx-offset)
1810                        (= offset ecx-offset) (= offset edx-offset)))
1811               (inst test (make-random-tn :kind :normal
1812                                          :sc (sc-or-lose 'byte-reg)
1813                                          :offset offset)
1814                     y))
1815              ((sc-is x control-stack)
1816               (inst test (make-ea :byte :base ebp-tn
1817                                   :disp (frame-byte-offset offset))
1818                     y))
1819              (t
1820               (inst test x y)))))
1821     (t
1822      (inst test x y))))
1823
1824 (define-instruction or (segment dst src &optional prefix)
1825   (:printer-list
1826    (arith-inst-printer-list #b001))
1827   (:emitter
1828    (emit-prefix segment prefix)
1829    (emit-random-arith-inst "OR" segment dst src #b001)))
1830
1831 (define-instruction xor (segment dst src &optional prefix)
1832   (:printer-list
1833    (arith-inst-printer-list #b110))
1834   (:emitter
1835    (emit-prefix segment prefix)
1836    (emit-random-arith-inst "XOR" segment dst src #b110)))
1837
1838 (define-instruction not (segment dst)
1839   (:printer reg/mem ((op '(#b1111011 #b010))))
1840   (:printer x66-reg/mem ((op '(#b1111011 #b010))))
1841   (:emitter
1842    (let ((size (operand-size dst)))
1843      (maybe-emit-operand-size-prefix segment size)
1844      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1845      (emit-ea segment dst #b010))))
1846 \f
1847 ;;;; string manipulation
1848
1849 (define-instruction cmps (segment size)
1850   (:printer string-op ((op #b1010011)))
1851   (:printer x66-string-op ((op #b1010011)))
1852   (:emitter
1853    (maybe-emit-operand-size-prefix segment size)
1854    (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1855
1856 (define-instruction ins (segment acc)
1857   (:printer string-op ((op #b0110110)))
1858   (:printer x66-string-op ((op #b0110110)))
1859   (:emitter
1860    (let ((size (operand-size acc)))
1861      (aver (accumulator-p acc))
1862      (maybe-emit-operand-size-prefix segment size)
1863      (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1864
1865 (define-instruction lods (segment acc)
1866   (:printer string-op ((op #b1010110)))
1867   (:printer x66-string-op ((op #b1010110)))
1868   (:emitter
1869    (let ((size (operand-size acc)))
1870      (aver (accumulator-p acc))
1871      (maybe-emit-operand-size-prefix segment size)
1872      (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1873
1874 (define-instruction movs (segment size)
1875   (:printer string-op ((op #b1010010)))
1876   (:printer x66-string-op ((op #b1010010)))
1877   (:emitter
1878    (maybe-emit-operand-size-prefix segment size)
1879    (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1880
1881 (define-instruction outs (segment acc)
1882   (:printer string-op ((op #b0110111)))
1883   (:printer x66-string-op ((op #b0110111)))
1884   (:emitter
1885    (let ((size (operand-size acc)))
1886      (aver (accumulator-p acc))
1887      (maybe-emit-operand-size-prefix segment size)
1888      (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1889
1890 (define-instruction scas (segment acc)
1891   (:printer string-op ((op #b1010111)))
1892   (:printer x66-string-op ((op #b1010111)))
1893   (:emitter
1894    (let ((size (operand-size acc)))
1895      (aver (accumulator-p acc))
1896      (maybe-emit-operand-size-prefix segment size)
1897      (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1898
1899 (define-instruction stos (segment acc)
1900   (:printer string-op ((op #b1010101)))
1901   (:printer x66-string-op ((op #b1010101)))
1902   (:emitter
1903    (let ((size (operand-size acc)))
1904      (aver (accumulator-p acc))
1905      (maybe-emit-operand-size-prefix segment size)
1906      (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1907
1908 (define-instruction xlat (segment)
1909   (:printer byte ((op #b11010111)))
1910   (:emitter
1911    (emit-byte segment #b11010111)))
1912
1913 (define-instruction rep (segment)
1914   (:emitter
1915    (emit-byte segment #b11110011)))
1916
1917 (define-instruction repe (segment)
1918   (:printer byte ((op #b11110011)))
1919   (:emitter
1920    (emit-byte segment #b11110011)))
1921
1922 (define-instruction repne (segment)
1923   (:printer byte ((op #b11110010)))
1924   (:emitter
1925    (emit-byte segment #b11110010)))
1926
1927 \f
1928 ;;;; bit manipulation
1929
1930 (define-instruction bsf (segment dst src)
1931   (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
1932   (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 0)))
1933   (:emitter
1934    (let ((size (matching-operand-size dst src)))
1935      (when (eq size :byte)
1936        (error "can't scan bytes: ~S" src))
1937      (maybe-emit-operand-size-prefix segment size)
1938      (emit-byte segment #b00001111)
1939      (emit-byte segment #b10111100)
1940      (emit-ea segment src (reg-tn-encoding dst)))))
1941
1942 (define-instruction bsr (segment dst src)
1943   (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
1944   (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 1)))
1945   (:emitter
1946    (let ((size (matching-operand-size dst src)))
1947      (when (eq size :byte)
1948        (error "can't scan bytes: ~S" src))
1949      (maybe-emit-operand-size-prefix segment size)
1950      (emit-byte segment #b00001111)
1951      (emit-byte segment #b10111101)
1952      (emit-ea segment src (reg-tn-encoding dst)))))
1953
1954 (defun emit-bit-test-and-mumble (segment src index opcode)
1955   (let ((size (operand-size src)))
1956     (when (eq size :byte)
1957       (error "can't scan bytes: ~S" src))
1958     (maybe-emit-operand-size-prefix segment size)
1959     (emit-byte segment #b00001111)
1960     (cond ((integerp index)
1961            (emit-byte segment #b10111010)
1962            (emit-ea segment src opcode)
1963            (emit-byte segment index))
1964           (t
1965            (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1966            (emit-ea segment src (reg-tn-encoding index))))))
1967
1968 (eval-when (:compile-toplevel :execute)
1969   (defun bit-test-inst-printer-list (subop)
1970     `((ext-reg/mem-imm ((op (#b1011101 ,subop))
1971                         (reg/mem nil :type word-reg/mem)
1972                         (imm nil :type imm-data)
1973                         (width 0)))
1974       (x66-ext-reg/mem-imm ((op (#b1011101 ,subop))
1975                             (reg/mem nil :type word-reg/mem)
1976                             (imm nil :type imm-data)
1977                             (width 0)))
1978       (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1979                         (width 1))
1980                        (:name :tab reg/mem ", " reg))
1981       (x66-ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1982                             (width 1))
1983                            (:name :tab reg/mem ", " reg)))))
1984
1985 (define-instruction bt (segment src index)
1986   (:printer-list (bit-test-inst-printer-list #b100))
1987   (:emitter
1988    (emit-bit-test-and-mumble segment src index #b100)))
1989
1990 (define-instruction btc (segment src index)
1991   (:printer-list (bit-test-inst-printer-list #b111))
1992   (:emitter
1993    (emit-bit-test-and-mumble segment src index #b111)))
1994
1995 (define-instruction btr (segment src index)
1996   (:printer-list (bit-test-inst-printer-list #b110))
1997   (:emitter
1998    (emit-bit-test-and-mumble segment src index #b110)))
1999
2000 (define-instruction bts (segment src index)
2001   (:printer-list (bit-test-inst-printer-list #b101))
2002   (:emitter
2003    (emit-bit-test-and-mumble segment src index #b101)))
2004
2005 \f
2006 ;;;; control transfer
2007
2008 (define-instruction call (segment where)
2009   (:printer near-jump ((op #b11101000)))
2010   (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
2011   (:emitter
2012    (typecase where
2013      (label
2014       (emit-byte segment #b11101000)
2015       (emit-back-patch segment
2016                        4
2017                        (lambda (segment posn)
2018                          (emit-dword segment
2019                                      (- (label-position where)
2020                                         (+ posn 4))))))
2021      (fixup
2022       (emit-byte segment #b11101000)
2023       (emit-relative-fixup segment where))
2024      (t
2025       (emit-byte segment #b11111111)
2026       (emit-ea segment where #b010)))))
2027
2028 (defun emit-byte-displacement-backpatch (segment target)
2029   (emit-back-patch segment
2030                    1
2031                    (lambda (segment posn)
2032                      (let ((disp (- (label-position target) (1+ posn))))
2033                        (aver (<= -128 disp 127))
2034                        (emit-byte segment disp)))))
2035
2036 (define-instruction jmp (segment cond &optional where)
2037   ;; conditional jumps
2038   (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
2039   (:printer near-cond-jump () '('j cc :tab label))
2040   ;; unconditional jumps
2041   (:printer short-jump ((op #b1011)))
2042   (:printer near-jump ((op #b11101001)) )
2043   (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
2044   (:emitter
2045    (cond (where
2046           (emit-chooser
2047            segment 6 2
2048            (lambda (segment posn delta-if-after)
2049              (let ((disp (- (label-position where posn delta-if-after)
2050                             (+ posn 2))))
2051                (when (<= -128 disp 127)
2052                  (emit-byte segment
2053                             (dpb (conditional-opcode cond)
2054                                  (byte 4 0)
2055                                  #b01110000))
2056                  (emit-byte-displacement-backpatch segment where)
2057                  t)))
2058            (lambda (segment posn)
2059              (let ((disp (- (label-position where) (+ posn 6))))
2060                (emit-byte segment #b00001111)
2061                (emit-byte segment
2062                           (dpb (conditional-opcode cond)
2063                                (byte 4 0)
2064                                #b10000000))
2065                (emit-dword segment disp)))))
2066          ((label-p (setq where cond))
2067           (emit-chooser
2068            segment 5 0
2069            (lambda (segment posn delta-if-after)
2070              (let ((disp (- (label-position where posn delta-if-after)
2071                             (+ posn 2))))
2072                (when (<= -128 disp 127)
2073                  (emit-byte segment #b11101011)
2074                  (emit-byte-displacement-backpatch segment where)
2075                  t)))
2076            (lambda (segment posn)
2077              (let ((disp (- (label-position where) (+ posn 5))))
2078                (emit-byte segment #b11101001)
2079                (emit-dword segment disp)))))
2080          ((fixup-p where)
2081           (emit-byte segment #b11101001)
2082           (emit-relative-fixup segment where))
2083          (t
2084           (unless (or (ea-p where) (tn-p where))
2085                   (error "don't know what to do with ~A" where))
2086           (emit-byte segment #b11111111)
2087           (emit-ea segment where #b100)))))
2088
2089 (define-instruction jmp-short (segment label)
2090   (:emitter
2091    (emit-byte segment #b11101011)
2092    (emit-byte-displacement-backpatch segment label)))
2093
2094 (define-instruction ret (segment &optional stack-delta)
2095   (:printer byte ((op #b11000011)))
2096   (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
2097             '(:name :tab imm))
2098   (:emitter
2099    (cond ((and stack-delta (not (zerop stack-delta)))
2100           (emit-byte segment #b11000010)
2101           (emit-word segment stack-delta))
2102          (t
2103           (emit-byte segment #b11000011)))))
2104
2105 (define-instruction jecxz (segment target)
2106   (:printer short-jump ((op #b0011)))
2107   (:emitter
2108    (emit-byte segment #b11100011)
2109    (emit-byte-displacement-backpatch segment target)))
2110
2111 (define-instruction loop (segment target)
2112   (:printer short-jump ((op #b0010)))
2113   (:emitter
2114    (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
2115    (emit-byte-displacement-backpatch segment target)))
2116
2117 (define-instruction loopz (segment target)
2118   (:printer short-jump ((op #b0001)))
2119   (:emitter
2120    (emit-byte segment #b11100001)
2121    (emit-byte-displacement-backpatch segment target)))
2122
2123 (define-instruction loopnz (segment target)
2124   (:printer short-jump ((op #b0000)))
2125   (:emitter
2126    (emit-byte segment #b11100000)
2127    (emit-byte-displacement-backpatch segment target)))
2128 \f
2129 ;;;; conditional move
2130 (define-instruction cmov (segment cond dst src)
2131   (:printer cond-move ())
2132   (:printer x66-cond-move ())
2133   (:emitter
2134    (aver (register-p dst))
2135    (let ((size (matching-operand-size dst src)))
2136      (aver (or (eq size :word) (eq size :dword)))
2137      (maybe-emit-operand-size-prefix segment size))
2138    (emit-byte segment #b00001111)
2139    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
2140    (emit-ea segment src (reg-tn-encoding dst))))
2141
2142 ;;;; conditional byte set
2143
2144 (define-instruction set (segment dst cond)
2145   (:printer cond-set ())
2146   (:emitter
2147    (emit-byte segment #b00001111)
2148    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
2149    (emit-ea segment dst #b000)))
2150 \f
2151 ;;;; enter/leave
2152
2153 (define-instruction enter (segment disp &optional (level 0))
2154   (:declare (type (unsigned-byte 16) disp)
2155             (type (unsigned-byte 8) level))
2156   (:printer enter-format ((op #b11001000)))
2157   (:emitter
2158    (emit-byte segment #b11001000)
2159    (emit-word segment disp)
2160    (emit-byte segment level)))
2161
2162 (define-instruction leave (segment)
2163   (:printer byte ((op #b11001001)))
2164   (:emitter
2165    (emit-byte segment #b11001001)))
2166 \f
2167 ;;;; prefetch
2168 (define-instruction prefetchnta (segment ea)
2169   (:printer prefetch ((op #b00011000) (reg #b000)))
2170   (:emitter
2171    (aver (typep ea 'ea))
2172    (aver (eq :byte (ea-size ea)))
2173    (emit-byte segment #b00001111)
2174    (emit-byte segment #b00011000)
2175    (emit-ea segment ea #b000)))
2176
2177 (define-instruction prefetcht0 (segment ea)
2178   (:printer prefetch ((op #b00011000) (reg #b001)))
2179   (:emitter
2180    (aver (typep ea 'ea))
2181    (aver (eq :byte (ea-size ea)))
2182    (emit-byte segment #b00001111)
2183    (emit-byte segment #b00011000)
2184    (emit-ea segment ea #b001)))
2185
2186 (define-instruction prefetcht1 (segment ea)
2187   (:printer prefetch ((op #b00011000) (reg #b010)))
2188   (:emitter
2189    (aver (typep ea 'ea))
2190    (aver (eq :byte (ea-size ea)))
2191    (emit-byte segment #b00001111)
2192    (emit-byte segment #b00011000)
2193    (emit-ea segment ea #b010)))
2194
2195 (define-instruction prefetcht2 (segment ea)
2196   (:printer prefetch ((op #b00011000) (reg #b011)))
2197   (:emitter
2198    (aver (typep ea 'ea))
2199    (aver (eq :byte (ea-size ea)))
2200    (emit-byte segment #b00001111)
2201    (emit-byte segment #b00011000)
2202    (emit-ea segment ea #b011)))
2203 \f
2204 ;;;; interrupt instructions
2205
2206 (defun snarf-error-junk (sap offset &optional length-only)
2207   (let* ((length (sb!sys:sap-ref-8 sap offset))
2208          (vector (make-array length :element-type '(unsigned-byte 8))))
2209     (declare (type sb!sys:system-area-pointer sap)
2210              (type (unsigned-byte 8) length)
2211              (type (simple-array (unsigned-byte 8) (*)) vector))
2212     (cond (length-only
2213            (values 0 (1+ length) nil nil))
2214           (t
2215            (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
2216                                                 vector 0 length)
2217            (collect ((sc-offsets)
2218                      (lengths))
2219              (lengths 1)                ; the length byte
2220              (let* ((index 0)
2221                     (error-number (sb!c:read-var-integer vector index)))
2222                (lengths index)
2223                (loop
2224                  (when (>= index length)
2225                    (return))
2226                  (let ((old-index index))
2227                    (sc-offsets (sb!c:read-var-integer vector index))
2228                    (lengths (- index old-index))))
2229                (values error-number
2230                        (1+ length)
2231                        (sc-offsets)
2232                        (lengths))))))))
2233
2234 #|
2235 (defmacro break-cases (breaknum &body cases)
2236   (let ((bn-temp (gensym)))
2237     (collect ((clauses))
2238       (dolist (case cases)
2239         (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
2240       `(let ((,bn-temp ,breaknum))
2241          (cond ,@(clauses))))))
2242 |#
2243
2244 (defun break-control (chunk inst stream dstate)
2245   (declare (ignore inst))
2246   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
2247     ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
2248     ;; map has it undefined; and it should be easier to look in the target
2249     ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
2250     ;; from first principles whether it's defined in some way that genesis
2251     ;; can't grok.
2252     (case #!-ud2-breakpoints (byte-imm-code chunk dstate)
2253           #!+ud2-breakpoints (word-imm-code chunk dstate)
2254       (#.error-trap
2255        (nt "error trap")
2256        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2257       (#.cerror-trap
2258        (nt "cerror trap")
2259        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2260       (#.breakpoint-trap
2261        (nt "breakpoint trap"))
2262       (#.pending-interrupt-trap
2263        (nt "pending interrupt trap"))
2264       (#.halt-trap
2265        (nt "halt trap"))
2266       (#.fun-end-breakpoint-trap
2267        (nt "function end breakpoint trap")))))
2268
2269 (define-instruction break (segment code)
2270   (:declare (type (unsigned-byte 8) code))
2271   #!-ud2-breakpoints (:printer byte-imm ((op #b11001100)) '(:name :tab code)
2272                                :control #'break-control)
2273   #!+ud2-breakpoints (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
2274                                :control #'break-control)
2275   (:emitter
2276    #!-ud2-breakpoints (emit-byte segment #b11001100)
2277    ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
2278    ;; throw a sigill with 0x0b0f instead and check for this in the
2279    ;; SIGILL handler and pass it on to the sigtrap handler if
2280    ;; appropriate
2281    #!+ud2-breakpoints (emit-word segment #b0000101100001111)
2282    (emit-byte segment code)))
2283
2284 (define-instruction int (segment number)
2285   (:declare (type (unsigned-byte 8) number))
2286   (:printer byte-imm ((op #b11001101)))
2287   (:emitter
2288    (etypecase number
2289      ((member 3)
2290       (emit-byte segment #b11001100))
2291      ((unsigned-byte 8)
2292       (emit-byte segment #b11001101)
2293       (emit-byte segment number)))))
2294
2295 (define-instruction into (segment)
2296   (:printer byte ((op #b11001110)))
2297   (:emitter
2298    (emit-byte segment #b11001110)))
2299
2300 (define-instruction bound (segment reg bounds)
2301   (:emitter
2302    (let ((size (matching-operand-size reg bounds)))
2303      (when (eq size :byte)
2304        (error "can't bounds-test bytes: ~S" reg))
2305      (maybe-emit-operand-size-prefix segment size)
2306      (emit-byte segment #b01100010)
2307      (emit-ea segment bounds (reg-tn-encoding reg)))))
2308
2309 (define-instruction iret (segment)
2310   (:printer byte ((op #b11001111)))
2311   (:emitter
2312    (emit-byte segment #b11001111)))
2313 \f
2314 ;;;; processor control
2315
2316 (define-instruction hlt (segment)
2317   (:printer byte ((op #b11110100)))
2318   (:emitter
2319    (emit-byte segment #b11110100)))
2320
2321 (define-instruction nop (segment)
2322   (:printer byte ((op #b10010000)))
2323   (:emitter
2324    (emit-byte segment #b10010000)))
2325
2326 (define-instruction wait (segment)
2327   (:printer byte ((op #b10011011)))
2328   (:emitter
2329    (emit-byte segment #b10011011)))
2330
2331 ;;; FIXME: It would be better to make the disassembler understand the prefix as part
2332 ;;; of the instructions...
2333 (define-instruction lock (segment)
2334   (:printer byte ((op #b11110000)))
2335   (:emitter
2336    (bug "LOCK prefix used as a standalone instruction")))
2337 \f
2338 ;;;; miscellaneous hackery
2339
2340 (define-instruction byte (segment byte)
2341   (:emitter
2342    (emit-byte segment byte)))
2343
2344 (define-instruction word (segment word)
2345   (:emitter
2346    (emit-word segment word)))
2347
2348 (define-instruction dword (segment dword)
2349   (:emitter
2350    (emit-dword segment dword)))
2351
2352 (defun emit-header-data (segment type)
2353   (emit-back-patch segment
2354                    4
2355                    (lambda (segment posn)
2356                      (emit-dword segment
2357                                  (logior type
2358                                          (ash (+ posn
2359                                                  (component-header-length))
2360                                               (- n-widetag-bits
2361                                                  word-shift)))))))
2362
2363 (define-instruction simple-fun-header-word (segment)
2364   (:emitter
2365    (emit-header-data segment simple-fun-header-widetag)))
2366
2367 (define-instruction lra-header-word (segment)
2368   (:emitter
2369    (emit-header-data segment return-pc-header-widetag)))
2370 \f
2371 ;;;; fp instructions
2372 ;;;;
2373 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
2374 ;;;;
2375 ;;;; Note: We treat the single-precision and double-precision variants
2376 ;;;; as separate instructions.
2377
2378 ;;; Load single to st(0).
2379 (define-instruction fld (segment source)
2380   (:printer floating-point ((op '(#b001 #b000))))
2381   (:emitter
2382     (emit-byte segment #b11011001)
2383     (emit-fp-op segment source #b000)))
2384
2385 ;;; Load double to st(0).
2386 (define-instruction fldd (segment source)
2387   (:printer floating-point ((op '(#b101 #b000))))
2388   (:printer floating-point-fp ((op '(#b001 #b000))))
2389   (:emitter
2390    (if (fp-reg-tn-p source)
2391        (emit-byte segment #b11011001)
2392      (emit-byte segment #b11011101))
2393     (emit-fp-op segment source #b000)))
2394
2395 ;;; Load long to st(0).
2396 (define-instruction fldl (segment source)
2397   (:printer floating-point ((op '(#b011 #b101))))
2398   (:emitter
2399     (emit-byte segment #b11011011)
2400     (emit-fp-op segment source #b101)))
2401
2402 ;;; Store single from st(0).
2403 (define-instruction fst (segment dest)
2404   (:printer floating-point ((op '(#b001 #b010))))
2405   (:emitter
2406     (cond ((fp-reg-tn-p dest)
2407            (emit-byte segment #b11011101)
2408            (emit-fp-op segment dest #b010))
2409           (t
2410            (emit-byte segment #b11011001)
2411            (emit-fp-op segment dest #b010)))))
2412
2413 ;;; Store double from st(0).
2414 (define-instruction fstd (segment dest)
2415   (:printer floating-point ((op '(#b101 #b010))))
2416   (:printer floating-point-fp ((op '(#b101 #b010))))
2417   (:emitter
2418    (cond ((fp-reg-tn-p dest)
2419           (emit-byte segment #b11011101)
2420           (emit-fp-op segment dest #b010))
2421          (t
2422           (emit-byte segment #b11011101)
2423           (emit-fp-op segment dest #b010)))))
2424
2425 ;;; Arithmetic ops are all done with at least one operand at top of
2426 ;;; stack. The other operand is is another register or a 32/64 bit
2427 ;;; memory loc.
2428
2429 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2430 ;;; that these conflict with the Gdb conventions for binops. To reduce
2431 ;;; the confusion I've added comments showing the mathamatical
2432 ;;; operation and the two syntaxes. By the ASM386 convention the
2433 ;;; instruction syntax is:
2434 ;;;
2435 ;;;      Fop Source
2436 ;;; or   Fop Destination, Source
2437 ;;;
2438 ;;; If only one operand is given then it is the source and the
2439 ;;; destination is ST(0). There are reversed forms of the fsub and
2440 ;;; fdiv instructions inducated by an 'R' suffix.
2441 ;;;
2442 ;;; The mathematical operation for the non-reverse form is always:
2443 ;;;     destination = destination op source
2444 ;;;
2445 ;;; For the reversed form it is:
2446 ;;;     destination = source op destination
2447 ;;;
2448 ;;; The instructions below only accept one operand at present which is
2449 ;;; usually the source. I've hack in extra instructions to implement
2450 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2451 ;;; the operand is the destination with the source being ST(0).
2452
2453 ;;; Add single:
2454 ;;;   st(0) = st(0) + memory or st(i).
2455 (define-instruction fadd (segment source)
2456   (:printer floating-point ((op '(#b000 #b000))))
2457   (:emitter
2458     (emit-byte segment #b11011000)
2459     (emit-fp-op segment source #b000)))
2460
2461 ;;; Add double:
2462 ;;;   st(0) = st(0) + memory or st(i).
2463 (define-instruction faddd (segment source)
2464   (:printer floating-point ((op '(#b100 #b000))))
2465   (:printer floating-point-fp ((op '(#b000 #b000))))
2466   (:emitter
2467    (if (fp-reg-tn-p source)
2468        (emit-byte segment #b11011000)
2469      (emit-byte segment #b11011100))
2470    (emit-fp-op segment source #b000)))
2471
2472 ;;; Add double destination st(i):
2473 ;;;   st(i) = st(0) + st(i).
2474 (define-instruction fadd-sti (segment destination)
2475   (:printer floating-point-fp ((op '(#b100 #b000))))
2476   (:emitter
2477    (aver (fp-reg-tn-p destination))
2478    (emit-byte segment #b11011100)
2479    (emit-fp-op segment destination #b000)))
2480 ;;; with pop
2481 (define-instruction faddp-sti (segment destination)
2482   (:printer floating-point-fp ((op '(#b110 #b000))))
2483   (:emitter
2484    (aver (fp-reg-tn-p destination))
2485    (emit-byte segment #b11011110)
2486    (emit-fp-op segment destination #b000)))
2487
2488 ;;; Subtract single:
2489 ;;;   st(0) = st(0) - memory or st(i).
2490 (define-instruction fsub (segment source)
2491   (:printer floating-point ((op '(#b000 #b100))))
2492   (:emitter
2493     (emit-byte segment #b11011000)
2494     (emit-fp-op segment source #b100)))
2495
2496 ;;; Subtract single, reverse:
2497 ;;;   st(0) = memory or st(i) - st(0).
2498 (define-instruction fsubr (segment source)
2499   (:printer floating-point ((op '(#b000 #b101))))
2500   (:emitter
2501     (emit-byte segment #b11011000)
2502     (emit-fp-op segment source #b101)))
2503
2504 ;;; Subtract double:
2505 ;;;   st(0) = st(0) - memory or st(i).
2506 (define-instruction fsubd (segment source)
2507   (:printer floating-point ((op '(#b100 #b100))))
2508   (:printer floating-point-fp ((op '(#b000 #b100))))
2509   (:emitter
2510    (if (fp-reg-tn-p source)
2511        (emit-byte segment #b11011000)
2512      (emit-byte segment #b11011100))
2513    (emit-fp-op segment source #b100)))
2514
2515 ;;; Subtract double, reverse:
2516 ;;;   st(0) = memory or st(i) - st(0).
2517 (define-instruction fsubrd (segment source)
2518   (:printer floating-point ((op '(#b100 #b101))))
2519   (:printer floating-point-fp ((op '(#b000 #b101))))
2520   (:emitter
2521    (if (fp-reg-tn-p source)
2522        (emit-byte segment #b11011000)
2523      (emit-byte segment #b11011100))
2524    (emit-fp-op segment source #b101)))
2525
2526 ;;; Subtract double, destination st(i):
2527 ;;;   st(i) = st(i) - st(0).
2528 ;;;
2529 ;;; ASM386 syntax: FSUB ST(i), ST
2530 ;;; Gdb    syntax: fsubr %st,%st(i)
2531 (define-instruction fsub-sti (segment destination)
2532   (:printer floating-point-fp ((op '(#b100 #b101))))
2533   (:emitter
2534    (aver (fp-reg-tn-p destination))
2535    (emit-byte segment #b11011100)
2536    (emit-fp-op segment destination #b101)))
2537 ;;; with a pop
2538 (define-instruction fsubp-sti (segment destination)
2539   (:printer floating-point-fp ((op '(#b110 #b101))))
2540   (:emitter
2541    (aver (fp-reg-tn-p destination))
2542    (emit-byte segment #b11011110)
2543    (emit-fp-op segment destination #b101)))
2544
2545 ;;; Subtract double, reverse, destination st(i):
2546 ;;;   st(i) = st(0) - st(i).
2547 ;;;
2548 ;;; ASM386 syntax: FSUBR ST(i), ST
2549 ;;; Gdb    syntax: fsub %st,%st(i)
2550 (define-instruction fsubr-sti (segment destination)
2551   (:printer floating-point-fp ((op '(#b100 #b100))))
2552   (:emitter
2553    (aver (fp-reg-tn-p destination))
2554    (emit-byte segment #b11011100)
2555    (emit-fp-op segment destination #b100)))
2556 ;;; with a pop
2557 (define-instruction fsubrp-sti (segment destination)
2558   (:printer floating-point-fp ((op '(#b110 #b100))))
2559   (:emitter
2560    (aver (fp-reg-tn-p destination))
2561    (emit-byte segment #b11011110)
2562    (emit-fp-op segment destination #b100)))
2563
2564 ;;; Multiply single:
2565 ;;;   st(0) = st(0) * memory or st(i).
2566 (define-instruction fmul (segment source)
2567   (:printer floating-point ((op '(#b000 #b001))))
2568   (:emitter
2569     (emit-byte segment #b11011000)
2570     (emit-fp-op segment source #b001)))
2571
2572 ;;; Multiply double:
2573 ;;;   st(0) = st(0) * memory or st(i).
2574 (define-instruction fmuld (segment source)
2575   (:printer floating-point ((op '(#b100 #b001))))
2576   (:printer floating-point-fp ((op '(#b000 #b001))))
2577   (:emitter
2578    (if (fp-reg-tn-p source)
2579        (emit-byte segment #b11011000)
2580      (emit-byte segment #b11011100))
2581    (emit-fp-op segment source #b001)))
2582
2583 ;;; Multiply double, destination st(i):
2584 ;;;   st(i) = st(i) * st(0).
2585 (define-instruction fmul-sti (segment destination)
2586   (:printer floating-point-fp ((op '(#b100 #b001))))
2587   (:emitter
2588    (aver (fp-reg-tn-p destination))
2589    (emit-byte segment #b11011100)
2590    (emit-fp-op segment destination #b001)))
2591
2592 ;;; Divide single:
2593 ;;;   st(0) = st(0) / memory or st(i).
2594 (define-instruction fdiv (segment source)
2595   (:printer floating-point ((op '(#b000 #b110))))
2596   (:emitter
2597     (emit-byte segment #b11011000)
2598     (emit-fp-op segment source #b110)))
2599
2600 ;;; Divide single, reverse:
2601 ;;;   st(0) = memory or st(i) / st(0).
2602 (define-instruction fdivr (segment source)
2603   (:printer floating-point ((op '(#b000 #b111))))
2604   (:emitter
2605     (emit-byte segment #b11011000)
2606     (emit-fp-op segment source #b111)))
2607
2608 ;;; Divide double:
2609 ;;;   st(0) = st(0) / memory or st(i).
2610 (define-instruction fdivd (segment source)
2611   (:printer floating-point ((op '(#b100 #b110))))
2612   (:printer floating-point-fp ((op '(#b000 #b110))))
2613   (:emitter
2614    (if (fp-reg-tn-p source)
2615        (emit-byte segment #b11011000)
2616      (emit-byte segment #b11011100))
2617    (emit-fp-op segment source #b110)))
2618
2619 ;;; Divide double, reverse:
2620 ;;;   st(0) = memory or st(i) / st(0).
2621 (define-instruction fdivrd (segment source)
2622   (:printer floating-point ((op '(#b100 #b111))))
2623   (:printer floating-point-fp ((op '(#b000 #b111))))
2624   (:emitter
2625    (if (fp-reg-tn-p source)
2626        (emit-byte segment #b11011000)
2627      (emit-byte segment #b11011100))
2628    (emit-fp-op segment source #b111)))
2629
2630 ;;; Divide double, destination st(i):
2631 ;;;   st(i) = st(i) / st(0).
2632 ;;;
2633 ;;; ASM386 syntax: FDIV ST(i), ST
2634 ;;; Gdb    syntax: fdivr %st,%st(i)
2635 (define-instruction fdiv-sti (segment destination)
2636   (:printer floating-point-fp ((op '(#b100 #b111))))
2637   (:emitter
2638    (aver (fp-reg-tn-p destination))
2639    (emit-byte segment #b11011100)
2640    (emit-fp-op segment destination #b111)))
2641
2642 ;;; Divide double, reverse, destination st(i):
2643 ;;;   st(i) = st(0) / st(i).
2644 ;;;
2645 ;;; ASM386 syntax: FDIVR ST(i), ST
2646 ;;; Gdb    syntax: fdiv %st,%st(i)
2647 (define-instruction fdivr-sti (segment destination)
2648   (:printer floating-point-fp ((op '(#b100 #b110))))
2649   (:emitter
2650    (aver (fp-reg-tn-p destination))
2651    (emit-byte segment #b11011100)
2652    (emit-fp-op segment destination #b110)))
2653
2654 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2655 (define-instruction fxch (segment source)
2656   (:printer floating-point-fp ((op '(#b001 #b001))))
2657   (:emitter
2658     (aver (and (tn-p source)
2659                (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)))
2660     (emit-byte segment #b11011001)
2661     (emit-fp-op segment source #b001)))
2662
2663 ;;; Push 32-bit integer to st0.
2664 (define-instruction fild (segment source)
2665   (:printer floating-point ((op '(#b011 #b000))))
2666   (:emitter
2667    (emit-byte segment #b11011011)
2668    (emit-fp-op segment source #b000)))
2669
2670 ;;; Push 64-bit integer to st0.
2671 (define-instruction fildl (segment source)
2672   (:printer floating-point ((op '(#b111 #b101))))
2673   (:emitter
2674    (emit-byte segment #b11011111)
2675    (emit-fp-op segment source #b101)))
2676
2677 ;;; Store 32-bit integer.
2678 (define-instruction fist (segment dest)
2679   (:printer floating-point ((op '(#b011 #b010))))
2680   (:emitter
2681    (emit-byte segment #b11011011)
2682    (emit-fp-op segment dest #b010)))
2683
2684 ;;; Store and pop 32-bit integer.
2685 (define-instruction fistp (segment dest)
2686   (:printer floating-point ((op '(#b011 #b011))))
2687   (:emitter
2688    (emit-byte segment #b11011011)
2689    (emit-fp-op segment dest #b011)))
2690
2691 ;;; Store and pop 64-bit integer.
2692 (define-instruction fistpl (segment dest)
2693   (:printer floating-point ((op '(#b111 #b111))))
2694   (:emitter
2695    (emit-byte segment #b11011111)
2696    (emit-fp-op segment dest #b111)))
2697
2698 ;;; Store single from st(0) and pop.
2699 (define-instruction fstp (segment dest)
2700   (:printer floating-point ((op '(#b001 #b011))))
2701   (:emitter
2702    (cond ((fp-reg-tn-p dest)
2703           (emit-byte segment #b11011101)
2704           (emit-fp-op segment dest #b011))
2705          (t
2706           (emit-byte segment #b11011001)
2707           (emit-fp-op segment dest #b011)))))
2708
2709 ;;; Store double from st(0) and pop.
2710 (define-instruction fstpd (segment dest)
2711   (:printer floating-point ((op '(#b101 #b011))))
2712   (:printer floating-point-fp ((op '(#b101 #b011))))
2713   (:emitter
2714    (cond ((fp-reg-tn-p dest)
2715           (emit-byte segment #b11011101)
2716           (emit-fp-op segment dest #b011))
2717          (t
2718           (emit-byte segment #b11011101)
2719           (emit-fp-op segment dest #b011)))))
2720
2721 ;;; Store long from st(0) and pop.
2722 (define-instruction fstpl (segment dest)
2723   (:printer floating-point ((op '(#b011 #b111))))
2724   (:emitter
2725     (emit-byte segment #b11011011)
2726     (emit-fp-op segment dest #b111)))
2727
2728 ;;; Decrement stack-top pointer.
2729 (define-instruction fdecstp (segment)
2730   (:printer floating-point-no ((op #b10110)))
2731   (:emitter
2732    (emit-byte segment #b11011001)
2733    (emit-byte segment #b11110110)))
2734
2735 ;;; Increment stack-top pointer.
2736 (define-instruction fincstp (segment)
2737   (:printer floating-point-no ((op #b10111)))
2738   (:emitter
2739    (emit-byte segment #b11011001)
2740    (emit-byte segment #b11110111)))
2741
2742 ;;; Free fp register.
2743 (define-instruction ffree (segment dest)
2744   (:printer floating-point-fp ((op '(#b101 #b000))))
2745   (:emitter
2746    (emit-byte segment #b11011101)
2747    (emit-fp-op segment dest #b000)))
2748
2749 (define-instruction fabs (segment)
2750   (:printer floating-point-no ((op #b00001)))
2751   (:emitter
2752    (emit-byte segment #b11011001)
2753    (emit-byte segment #b11100001)))
2754
2755 (define-instruction fchs (segment)
2756   (:printer floating-point-no ((op #b00000)))
2757   (:emitter
2758    (emit-byte segment #b11011001)
2759    (emit-byte segment #b11100000)))
2760
2761 (define-instruction frndint(segment)
2762   (:printer floating-point-no ((op #b11100)))
2763   (:emitter
2764    (emit-byte segment #b11011001)
2765    (emit-byte segment #b11111100)))
2766
2767 ;;; Initialize NPX.
2768 (define-instruction fninit(segment)
2769   (:printer floating-point-5 ((op #b00011)))
2770   (:emitter
2771    (emit-byte segment #b11011011)
2772    (emit-byte segment #b11100011)))
2773
2774 ;;; Store Status Word to AX.
2775 (define-instruction fnstsw(segment)
2776   (:printer floating-point-st ((op #b00000)))
2777   (:emitter
2778    (emit-byte segment #b11011111)
2779    (emit-byte segment #b11100000)))
2780
2781 ;;; Load Control Word.
2782 ;;;
2783 ;;; src must be a memory location
2784 (define-instruction fldcw(segment src)
2785   (:printer floating-point ((op '(#b001 #b101))))
2786   (:emitter
2787    (emit-byte segment #b11011001)
2788    (emit-fp-op segment src #b101)))
2789
2790 ;;; Store Control Word.
2791 (define-instruction fnstcw(segment dst)
2792   (:printer floating-point ((op '(#b001 #b111))))
2793   (:emitter
2794    (emit-byte segment #b11011001)
2795    (emit-fp-op segment dst #b111)))
2796
2797 ;;; Store FP Environment.
2798 (define-instruction fstenv(segment dst)
2799   (:printer floating-point ((op '(#b001 #b110))))
2800   (:emitter
2801    (emit-byte segment #b11011001)
2802    (emit-fp-op segment dst #b110)))
2803
2804 ;;; Restore FP Environment.
2805 (define-instruction fldenv(segment src)
2806   (:printer floating-point ((op '(#b001 #b100))))
2807   (:emitter
2808    (emit-byte segment #b11011001)
2809    (emit-fp-op segment src #b100)))
2810
2811 ;;; Save FP State.
2812 (define-instruction fsave(segment dst)
2813   (:printer floating-point ((op '(#b101 #b110))))
2814   (:emitter
2815    (emit-byte segment #b11011101)
2816    (emit-fp-op segment dst #b110)))
2817
2818 ;;; Restore FP State.
2819 (define-instruction frstor(segment src)
2820   (:printer floating-point ((op '(#b101 #b100))))
2821   (:emitter
2822    (emit-byte segment #b11011101)
2823    (emit-fp-op segment src #b100)))
2824
2825 ;;; Clear exceptions.
2826 (define-instruction fnclex(segment)
2827   (:printer floating-point-5 ((op #b00010)))
2828   (:emitter
2829    (emit-byte segment #b11011011)
2830    (emit-byte segment #b11100010)))
2831
2832 ;;; comparison
2833 (define-instruction fcom (segment src)
2834   (:printer floating-point ((op '(#b000 #b010))))
2835   (:emitter
2836    (emit-byte segment #b11011000)
2837    (emit-fp-op segment src #b010)))
2838
2839 (define-instruction fcomd (segment src)
2840   (:printer floating-point ((op '(#b100 #b010))))
2841   (:printer floating-point-fp ((op '(#b000 #b010))))
2842   (:emitter
2843    (if (fp-reg-tn-p src)
2844        (emit-byte segment #b11011000)
2845      (emit-byte segment #b11011100))
2846    (emit-fp-op segment src #b010)))
2847
2848 ;;; Compare ST1 to ST0, popping the stack twice.
2849 (define-instruction fcompp (segment)
2850   (:printer floating-point-3 ((op '(#b110 #b011001))))
2851   (:emitter
2852    (emit-byte segment #b11011110)
2853    (emit-byte segment #b11011001)))
2854
2855 ;;; unordered comparison
2856 (define-instruction fucom (segment src)
2857   (:printer floating-point-fp ((op '(#b101 #b100))))
2858   (:emitter
2859    (aver (fp-reg-tn-p src))
2860    (emit-byte segment #b11011101)
2861    (emit-fp-op segment src #b100)))
2862
2863 (define-instruction ftst (segment)
2864   (:printer floating-point-no ((op #b00100)))
2865   (:emitter
2866    (emit-byte segment #b11011001)
2867    (emit-byte segment #b11100100)))
2868
2869 ;;;; 80387 specials
2870
2871 (define-instruction fsqrt(segment)
2872   (:printer floating-point-no ((op #b11010)))
2873   (:emitter
2874    (emit-byte segment #b11011001)
2875    (emit-byte segment #b11111010)))
2876
2877 (define-instruction fscale(segment)
2878   (:printer floating-point-no ((op #b11101)))
2879   (:emitter
2880    (emit-byte segment #b11011001)
2881    (emit-byte segment #b11111101)))
2882
2883 (define-instruction fxtract(segment)
2884   (:printer floating-point-no ((op #b10100)))
2885   (:emitter
2886    (emit-byte segment #b11011001)
2887    (emit-byte segment #b11110100)))
2888
2889 (define-instruction fsin(segment)
2890   (:printer floating-point-no ((op #b11110)))
2891   (:emitter
2892    (emit-byte segment #b11011001)
2893    (emit-byte segment #b11111110)))
2894
2895 (define-instruction fcos(segment)
2896   (:printer floating-point-no ((op #b11111)))
2897   (:emitter
2898    (emit-byte segment #b11011001)
2899    (emit-byte segment #b11111111)))
2900
2901 (define-instruction fprem1(segment)
2902   (:printer floating-point-no ((op #b10101)))
2903   (:emitter
2904    (emit-byte segment #b11011001)
2905    (emit-byte segment #b11110101)))
2906
2907 (define-instruction fprem(segment)
2908   (:printer floating-point-no ((op #b11000)))
2909   (:emitter
2910    (emit-byte segment #b11011001)
2911    (emit-byte segment #b11111000)))
2912
2913 (define-instruction fxam (segment)
2914   (:printer floating-point-no ((op #b00101)))
2915   (:emitter
2916    (emit-byte segment #b11011001)
2917    (emit-byte segment #b11100101)))
2918
2919 ;;; These do push/pop to stack and need special handling
2920 ;;; in any VOPs that use them. See the book.
2921
2922 ;;; st0 <- st1*log2(st0)
2923 (define-instruction fyl2x(segment)      ; pops stack
2924   (:printer floating-point-no ((op #b10001)))
2925   (:emitter
2926    (emit-byte segment #b11011001)
2927    (emit-byte segment #b11110001)))
2928
2929 (define-instruction fyl2xp1(segment)
2930   (:printer floating-point-no ((op #b11001)))
2931   (:emitter
2932    (emit-byte segment #b11011001)
2933    (emit-byte segment #b11111001)))
2934
2935 (define-instruction f2xm1(segment)
2936   (:printer floating-point-no ((op #b10000)))
2937   (:emitter
2938    (emit-byte segment #b11011001)
2939    (emit-byte segment #b11110000)))
2940
2941 (define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
2942   (:printer floating-point-no ((op #b10010)))
2943   (:emitter
2944    (emit-byte segment #b11011001)
2945    (emit-byte segment #b11110010)))
2946
2947 (define-instruction fpatan(segment)     ; POPS STACK
2948   (:printer floating-point-no ((op #b10011)))
2949   (:emitter
2950    (emit-byte segment #b11011001)
2951    (emit-byte segment #b11110011)))
2952
2953 ;;;; loading constants
2954
2955 (define-instruction fldz(segment)
2956   (:printer floating-point-no ((op #b01110)))
2957   (:emitter
2958    (emit-byte segment #b11011001)
2959    (emit-byte segment #b11101110)))
2960
2961 (define-instruction fld1(segment)
2962   (:printer floating-point-no ((op #b01000)))
2963   (:emitter
2964    (emit-byte segment #b11011001)
2965    (emit-byte segment #b11101000)))
2966
2967 (define-instruction fldpi(segment)
2968   (:printer floating-point-no ((op #b01011)))
2969   (:emitter
2970    (emit-byte segment #b11011001)
2971    (emit-byte segment #b11101011)))
2972
2973 (define-instruction fldl2t(segment)
2974   (:printer floating-point-no ((op #b01001)))
2975   (:emitter
2976    (emit-byte segment #b11011001)
2977    (emit-byte segment #b11101001)))
2978
2979 (define-instruction fldl2e(segment)
2980   (:printer floating-point-no ((op #b01010)))
2981   (:emitter
2982    (emit-byte segment #b11011001)
2983    (emit-byte segment #b11101010)))
2984
2985 (define-instruction fldlg2(segment)
2986   (:printer floating-point-no ((op #b01100)))
2987   (:emitter
2988    (emit-byte segment #b11011001)
2989    (emit-byte segment #b11101100)))
2990
2991 (define-instruction fldln2(segment)
2992   (:printer floating-point-no ((op #b01101)))
2993   (:emitter
2994    (emit-byte segment #b11011001)
2995    (emit-byte segment #b11101101)))
2996
2997 ;;;; Miscellany
2998
2999 (define-instruction cpuid (segment)
3000   (:printer two-bytes ((op '(#b00001111 #b10100010))))
3001   (:emitter
3002    (emit-byte segment #b00001111)
3003    (emit-byte segment #b10100010)))
3004
3005 (define-instruction rdtsc (segment)
3006   (:printer two-bytes ((op '(#b00001111 #b00110001))))
3007   (:emitter
3008    (emit-byte segment #b00001111)
3009    (emit-byte segment #b00110001)))
3010
3011 ;;;; Late VM definitions
3012 (defun canonicalize-inline-constant (constant)
3013   (let ((first (car constant)))
3014     (typecase first
3015       (single-float (setf constant (list :single-float first)))
3016       (double-float (setf constant (list :double-float first)))))
3017   (destructuring-bind (type value) constant
3018     (ecase type
3019       ((:byte :word :dword)
3020          (aver (integerp value))
3021          (cons type value))
3022       ((:base-char)
3023          (aver (base-char-p value))
3024          (cons :byte (char-code value)))
3025       ((:character)
3026          (aver (characterp value))
3027          (cons :dword (char-code value)))
3028       ((:single-float)
3029          (aver (typep value 'single-float))
3030          (cons :dword (ldb (byte 32 0) (single-float-bits value))))
3031       ((:double-float-bits)
3032          (aver (integerp value))
3033          (cons :double-float (ldb (byte 64 0) value)))
3034       ((:double-float)
3035          (aver (typep value 'double-float))
3036          (cons :double-float
3037                (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
3038                                         (double-float-low-bits value))))))))
3039
3040 (defun inline-constant-value (constant)
3041   (let ((label (gen-label))
3042         (size  (ecase (car constant)
3043                  ((:byte :word :dword) (car constant))
3044                  (:double-float :dword))))
3045     (values label (make-ea size
3046                            :disp (make-fixup nil :code-object label)))))
3047
3048 (defun emit-constant-segment-header (constants optimize)
3049   (declare (ignore constants))
3050   (loop repeat (if optimize 64 16) do (inst byte #x90)))
3051
3052 (defun size-nbyte (size)
3053   (ecase size
3054     (:byte  1)
3055     (:word  2)
3056     (:dword 4)
3057     (:double-float 8)))
3058
3059 (defun sort-inline-constants (constants)
3060   (stable-sort constants #'> :key (lambda (constant)
3061                                     (size-nbyte (caar constant)))))
3062
3063 (defun emit-inline-constant (constant label)
3064   (let ((size (size-nbyte (car constant))))
3065     (emit-alignment (integer-length (1- size)))
3066     (emit-label label)
3067     (let ((val (cdr constant)))
3068       (loop repeat size
3069             do (inst byte (ldb (byte 8 0) val))
3070                (setf val (ash val -8))))))