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 ;;; Same as reg/mem, but with a prefix of #b00001111
 612 (sb!disassem:define-instruction-format (ext-reg/mem 24
 613                                         :default-printer '(:name :tab reg/mem))
 614   (prefix  :field (byte 8 0)    :value #b00001111)
 615   (op      :fields (list (byte 7 9) (byte 3 19)))
 616   (width   :field (byte 1 8)    :type 'width)
 617   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 618                                 :type 'sized-reg/mem)
 619   ;; optional fields
 620   (imm))
 621
 622 (sb!disassem:define-instruction-format (x66-ext-reg/mem 32
 623                                         :default-printer '(:name :tab reg/mem))
 624   (x66     :field (byte 8 0)    :type 'x66 :value #x66)
 625   (prefix  :field (byte 8 8)    :value #b00001111)
 626   (op      :fields (list (byte 7 17) (byte 3 27)))
 627   (width   :field (byte 1 16)    :type 'width)
 628   (reg/mem :fields (list (byte 2 30) (byte 3 22))
 629                                 :type 'sized-reg/mem)
 630   ;; optional fields
 631   (imm))
 632
 633 (sb!disassem:define-instruction-format (ext-reg/mem-imm 24
 634                                         :include 'ext-reg/mem
 635                                         :default-printer
 636                                         '(:name :tab reg/mem ", " imm))
 637   (imm :type 'imm-data))
 638
 639 (sb!disassem:define-instruction-format (x66-ext-reg/mem-imm 32
 640                                         :include 'x66-ext-reg/mem
 641                                         :default-printer
 642                                         '(:name :tab reg/mem ", " imm))
 643   (imm :type 'imm-data))
 644 \f
 645 ;;;; This section was added by jrd, for fp instructions.
 646
 647 ;;; regular fp inst to/from registers/memory
 648 (sb!disassem:define-instruction-format (floating-point 16
 649                                         :default-printer
 650                                         `(:name :tab reg/mem))
 651   (prefix :field (byte 5 3) :value #b11011)
 652   (op     :fields (list (byte 3 0) (byte 3 11)))
 653   (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
 654
 655 ;;; fp insn to/from fp reg
 656 (sb!disassem:define-instruction-format (floating-point-fp 16
 657                                         :default-printer `(:name :tab fp-reg))
 658   (prefix :field (byte 5 3) :value #b11011)
 659   (suffix :field (byte 2 14) :value #b11)
 660   (op     :fields (list (byte 3 0) (byte 3 11)))
 661   (fp-reg :field (byte 3 8) :type 'fp-reg))
 662
 663 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
 664 (sb!disassem:define-instruction-format
 665  (floating-point-fp-d 16
 666    :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
 667   (prefix :field (byte 5 3) :value #b11011)
 668   (suffix :field (byte 2 14) :value #b11)
 669   (op     :fields (list (byte 2 0) (byte 3 11)))
 670   (d      :field (byte 1 2))
 671   (fp-reg :field (byte 3 8) :type 'fp-reg))
 672
 673
 674 ;;; (added by (?) pfw)
 675 ;;; fp no operand isns
 676 (sb!disassem:define-instruction-format (floating-point-no 16
 677                                       :default-printer '(:name))
 678   (prefix :field (byte 8  0) :value #b11011001)
 679   (suffix :field (byte 3 13) :value #b111)
 680   (op     :field (byte 5  8)))
 681
 682 (sb!disassem:define-instruction-format (floating-point-3 16
 683                                       :default-printer '(:name))
 684   (prefix :field (byte 5 3) :value #b11011)
 685   (suffix :field (byte 2 14) :value #b11)
 686   (op     :fields (list (byte 3 0) (byte 6 8))))
 687
 688 (sb!disassem:define-instruction-format (floating-point-5 16
 689                                       :default-printer '(:name))
 690   (prefix :field (byte 8  0) :value #b11011011)
 691   (suffix :field (byte 3 13) :value #b111)
 692   (op     :field (byte 5  8)))
 693
 694 (sb!disassem:define-instruction-format (floating-point-st 16
 695                                       :default-printer '(:name))
 696   (prefix :field (byte 8  0) :value #b11011111)
 697   (suffix :field (byte 3 13) :value #b111)
 698   (op     :field (byte 5  8)))
 699
 700 (sb!disassem:define-instruction-format (string-op 8
 701                                      :include 'simple
 702                                      :default-printer '(:name width)))
 703
 704 (sb!disassem:define-instruction-format (x66-string-op 16
 705                                      :include 'x66-simple
 706                                      :default-printer '(:name width)))
 707
 708 (sb!disassem:define-instruction-format (short-cond-jump 16)
 709   (op    :field (byte 4 4))
 710   (cc    :field (byte 4 0) :type 'condition-code)
 711   (label :field (byte 8 8) :type 'displacement))
 712
 713 (sb!disassem:define-instruction-format (short-jump 16
 714                                      :default-printer '(:name :tab label))
 715   (const :field (byte 4 4) :value #b1110)
 716   (op    :field (byte 4 0))
 717   (label :field (byte 8 8) :type 'displacement))
 718
 719 (sb!disassem:define-instruction-format (near-cond-jump 16)
 720   (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
 721   (cc    :field (byte 4 8) :type 'condition-code)
 722   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 723   ;; long, so we fake it by using a prefilter to read the offset.
 724   (label :type 'displacement
 725          :prefilter (lambda (value dstate)
 726                       (declare (ignore value)) ; always nil anyway
 727                       (sb!disassem:read-signed-suffix 32 dstate))))
 728
 729 (sb!disassem:define-instruction-format (near-jump 8
 730                                      :default-printer '(:name :tab label))
 731   (op    :field (byte 8 0))
 732   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 733   ;; long, so we fake it by using a prefilter to read the address.
 734   (label :type 'displacement
 735          :prefilter (lambda (value dstate)
 736                       (declare (ignore value)) ; always nil anyway
 737                       (sb!disassem:read-signed-suffix 32 dstate))))
 738
 739
 740 (sb!disassem:define-instruction-format (cond-set 24
 741                                      :default-printer '('set cc :tab reg/mem))
 742   (prefix :field (byte 8 0) :value #b00001111)
 743   (op    :field (byte 4 12) :value #b1001)
 744   (cc    :field (byte 4 8) :type 'condition-code)
 745   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 746            :type 'byte-reg/mem)
 747   (reg     :field (byte 3 19)   :value #b000))
 748
 749 (sb!disassem:define-instruction-format (cond-move 24
 750                                      :default-printer
 751                                         '('cmov cc :tab reg ", " reg/mem))
 752   (prefix  :field (byte 8 0)    :value #b00001111)
 753   (op      :field (byte 4 12)   :value #b0100)
 754   (cc      :field (byte 4 8)    :type 'condition-code)
 755   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 756                                 :type 'reg/mem)
 757   (reg     :field (byte 3 19)   :type 'reg))
 758
 759 (sb!disassem:define-instruction-format (x66-cond-move 32
 760                                      :default-printer
 761                                         '('cmov cc :tab reg ", " reg/mem))
 762   (x66   :field (byte 8 0) :type 'x66 :value #x66)
 763   (prefix  :field (byte 8 8)    :value #b00001111)
 764   (op      :field (byte 4 20)   :value #b0100)
 765   (cc      :field (byte 4 16)    :type 'condition-code)
 766   (reg/mem :fields (list (byte 2 30) (byte 3 24))
 767                                 :type 'reg/mem)
 768   (reg     :field (byte 3 27)   :type 'reg))
 769
 770 (sb!disassem:define-instruction-format (enter-format 32
 771                                      :default-printer '(:name
 772                                                         :tab disp
 773                                                         (:unless (:constant 0)
 774                                                           ", " level)))
 775   (op :field (byte 8 0))
 776   (disp :field (byte 16 8))
 777   (level :field (byte 8 24)))
 778
 779 (sb!disassem:define-instruction-format (prefetch 24
 780                                                  :default-printer
 781                                                  '(:name ", " reg/mem))
 782   (prefix :field (byte 8 0) :value #b00001111)
 783   (op :field (byte 8 8) :value #b00011000)
 784   (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem)
 785   (reg :field (byte 3 19) :type 'reg))
 786
 787 ;;; Single byte instruction with an immediate byte argument.
 788 (sb!disassem:define-instruction-format (byte-imm 16
 789                                      :default-printer '(:name :tab code))
 790  (op :field (byte 8 0))
 791  (code :field (byte 8 8)))
 792
 793 ;;; Two byte instruction with an immediate byte argument.
 794 ;;;
 795 (sb!disassem:define-instruction-format (word-imm 24
 796                                      :default-printer '(:name :tab code))
 797   (op :field (byte 16 0))
 798   (code :field (byte 8 16)))
 799
 800 \f
 801 ;;;; primitive emitters
 802
 803 (define-bitfield-emitter emit-word 16
 804   (byte 16 0))
 805
 806 (define-bitfield-emitter emit-dword 32
 807   (byte 32 0))
 808
 809 (define-bitfield-emitter emit-byte-with-reg 8
 810   (byte 5 3) (byte 3 0))
 811
 812 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
 813   (byte 2 6) (byte 3 3) (byte 3 0))
 814
 815 (define-bitfield-emitter emit-sib-byte 8
 816   (byte 2 6) (byte 3 3) (byte 3 0))
 817 \f
 818 ;;;; fixup emitters
 819
 820 (defun emit-absolute-fixup (segment fixup)
 821   (note-fixup segment :absolute fixup)
 822   (let ((offset (fixup-offset fixup)))
 823     (if (label-p offset)
 824         (emit-back-patch segment
 825                          4 ; FIXME: n-word-bytes
 826                          (lambda (segment posn)
 827                            (declare (ignore posn))
 828                            (emit-dword segment
 829                                        (- (+ (component-header-length)
 830                                              (or (label-position offset)
 831                                                  0))
 832                                           other-pointer-lowtag))))
 833         (emit-dword segment (or offset 0)))))
 834
 835 (defun emit-relative-fixup (segment fixup)
 836   (note-fixup segment :relative fixup)
 837   (emit-dword segment (or (fixup-offset fixup) 0)))
 838 \f
 839 ;;;; the effective-address (ea) structure
 840
 841 (defun reg-tn-encoding (tn)
 842   (declare (type tn tn))
 843   (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
 844   (let ((offset (tn-offset tn)))
 845     (logior (ash (logand offset 1) 2)
 846             (ash offset -1))))
 847
 848 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
 849                (:copier nil))
 850   (size nil :type (member :byte :word :dword))
 851   (base nil :type (or tn null))
 852   (index nil :type (or tn null))
 853   (scale 1 :type (member 1 2 4 8))
 854   (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
 855 (def!method print-object ((ea ea) stream)
 856   (cond ((or *print-escape* *print-readably*)
 857          (print-unreadable-object (ea stream :type t)
 858            (format stream
 859                    "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
 860                    (ea-size ea)
 861                    (ea-base ea)
 862                    (ea-index ea)
 863                    (let ((scale (ea-scale ea)))
 864                      (if (= scale 1) nil scale))
 865                    (ea-disp ea))))
 866         (t
 867          (format stream "~A PTR [" (symbol-name (ea-size ea)))
 868          (when (ea-base ea)
 869            (write-string (sb!c::location-print-name (ea-base ea)) stream)
 870            (when (ea-index ea)
 871              (write-string "+" stream)))
 872          (when (ea-index ea)
 873            (write-string (sb!c::location-print-name (ea-index ea)) stream))
 874          (unless (= (ea-scale ea) 1)
 875            (format stream "*~A" (ea-scale ea)))
 876          (typecase (ea-disp ea)
 877            (null)
 878            (integer
 879             (format stream "~@D" (ea-disp ea)))
 880            (t
 881             (format stream "+~A" (ea-disp ea))))
 882          (write-char #\] stream))))
 883
 884 (defun emit-ea (segment thing reg &optional allow-constants)
 885   (etypecase thing
 886     (tn
 887      (ecase (sb-name (sc-sb (tn-sc thing)))
 888        (registers
 889         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
 890        (stack
 891         ;; Convert stack tns into an index off of EBP.
 892         (let ((disp (frame-byte-offset (tn-offset thing))))
 893           (cond ((<= -128 disp 127)
 894                  (emit-mod-reg-r/m-byte segment #b01 reg #b101)
 895                  (emit-byte segment disp))
 896                 (t
 897                  (emit-mod-reg-r/m-byte segment #b10 reg #b101)
 898                  (emit-dword segment disp)))))
 899        (constant
 900         (unless allow-constants
 901           (error
 902            "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
 903         (emit-mod-reg-r/m-byte segment #b00 reg #b101)
 904         (emit-absolute-fixup segment
 905                              (make-fixup nil
 906                                          :code-object
 907                                          (- (* (tn-offset thing) n-word-bytes)
 908                                             other-pointer-lowtag))))))
 909     (ea
 910      (let* ((base (ea-base thing))
 911             (index (ea-index thing))
 912             (scale (ea-scale thing))
 913             (disp (ea-disp thing))
 914             (mod (cond ((or (null base)
 915                             (and (eql disp 0)
 916                                  (not (= (reg-tn-encoding base) #b101))))
 917                         #b00)
 918                        ((and (fixnump disp) (<= -128 disp 127))
 919                         #b01)
 920                        (t
 921                         #b10)))
 922             (r/m (cond (index #b100)
 923                        ((null base) #b101)
 924                        (t (reg-tn-encoding base)))))
 925        (emit-mod-reg-r/m-byte segment mod reg r/m)
 926        (when (= r/m #b100)
 927          (let ((ss (1- (integer-length scale)))
 928                (index (if (null index)
 929                           #b100
 930                           (let ((index (reg-tn-encoding index)))
 931                             (if (= index #b100)
 932                                 (error "can't index off of ESP")
 933                                 index))))
 934                (base (if (null base)
 935                          #b101
 936                          (reg-tn-encoding base))))
 937            (emit-sib-byte segment ss index base)))
 938        (cond ((= mod #b01)
 939               (emit-byte segment disp))
 940              ((or (= mod #b10) (null base))
 941               (if (fixup-p disp)
 942                   (emit-absolute-fixup segment disp)
 943                   (emit-dword segment disp))))))
 944     (fixup
 945      (emit-mod-reg-r/m-byte segment #b00 reg #b101)
 946      (emit-absolute-fixup segment thing))))
 947
 948 (defun fp-reg-tn-p (thing)
 949   (and (tn-p thing)
 950        (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
 951
 952 ;;; like the above, but for fp-instructions--jrd
 953 (defun emit-fp-op (segment thing op)
 954   (if (fp-reg-tn-p thing)
 955       (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
 956                                                  (byte 3 0)
 957                                                  #b11000000)))
 958     (emit-ea segment thing op)))
 959
 960 (defun byte-reg-p (thing)
 961   (and (tn-p thing)
 962        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 963        (member (sc-name (tn-sc thing)) *byte-sc-names*)
 964        t))
 965
 966 (defun byte-ea-p (thing)
 967   (typecase thing
 968     (ea (eq (ea-size thing) :byte))
 969     (tn
 970      (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
 971     (t nil)))
 972
 973 (defun word-reg-p (thing)
 974   (and (tn-p thing)
 975        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 976        (member (sc-name (tn-sc thing)) *word-sc-names*)
 977        t))
 978
 979 (defun word-ea-p (thing)
 980   (typecase thing
 981     (ea (eq (ea-size thing) :word))
 982     (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
 983     (t nil)))
 984
 985 (defun dword-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)) *dword-sc-names*)
 989        t))
 990
 991 (defun dword-ea-p (thing)
 992   (typecase thing
 993     (ea (eq (ea-size thing) :dword))
 994     (tn
 995      (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
 996     (t nil)))
 997
 998 (defun register-p (thing)
 999   (and (tn-p thing)
1000        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
1001
1002 (defun accumulator-p (thing)
1003   (and (register-p thing)
1004        (= (tn-offset thing) 0)))
1005 \f
1006 ;;;; utilities
1007
1008 (def!constant +operand-size-prefix-byte+ #b01100110)
1009
1010 (defun maybe-emit-operand-size-prefix (segment size)
1011   (unless (or (eq size :byte) (eq size +default-operand-size+))
1012     (emit-byte segment +operand-size-prefix-byte+)))
1013
1014 (defun operand-size (thing)
1015   (typecase thing
1016     (tn
1017      ;; FIXME: might as well be COND instead of having to use #. readmacro
1018      ;; to hack up the code
1019      (case (sc-name (tn-sc thing))
1020        (#.*dword-sc-names*
1021         :dword)
1022        (#.*word-sc-names*
1023         :word)
1024        (#.*byte-sc-names*
1025         :byte)
1026        ;; added by jrd: float-registers is a separate size (?)
1027        (#.*float-sc-names*
1028         :float)
1029        (#.*double-sc-names*
1030         :double)
1031        (t
1032         (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
1033     (ea
1034      (ea-size thing))
1035     (t
1036      nil)))
1037
1038 (defun matching-operand-size (dst src)
1039   (let ((dst-size (operand-size dst))
1040         (src-size (operand-size src)))
1041     (if dst-size
1042         (if src-size
1043             (if (eq dst-size src-size)
1044                 dst-size
1045                 (error "size mismatch: ~S is a ~S and ~S is a ~S."
1046                        dst dst-size src src-size))
1047             dst-size)
1048         (if src-size
1049             src-size
1050             (error "can't tell the size of either ~S or ~S" dst src)))))
1051
1052 (defun emit-sized-immediate (segment size value)
1053   (ecase size
1054     (:byte
1055      (emit-byte segment value))
1056     (:word
1057      (emit-word segment value))
1058     (:dword
1059      (emit-dword segment value))))
1060 \f
1061 ;;;; general data transfer
1062
1063 (define-instruction mov (segment dst src &optional prefix)
1064   ;; immediate to register
1065   (:printer reg ((op #b1011) (imm nil :type 'imm-data))
1066             '(:name :tab reg ", " imm))
1067   (:printer x66-reg ((op #b1011) (imm nil :type 'imm-data))
1068             '(:name :tab reg ", " imm))
1069   ;; absolute mem to/from accumulator
1070   (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
1071             `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
1072   (:printer x66-simple-dir ((op #b101000) (imm nil :type 'imm-addr))
1073             `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
1074   ;; register to/from register/memory
1075   (:printer reg-reg/mem-dir ((op #b100010)))
1076   (:printer x66-reg-reg/mem-dir ((op #b100010)))
1077   ;; immediate to register/memory
1078   (:printer reg/mem-imm ((op '(#b1100011 #b000))))
1079   (:printer x66-reg/mem-imm ((op '(#b1100011 #b000))))
1080
1081   (:emitter
1082    (emit-prefix segment prefix)
1083    (let ((size (matching-operand-size dst src)))
1084      (maybe-emit-operand-size-prefix segment size)
1085      (cond ((register-p dst)
1086             (cond ((integerp src)
1087                    (emit-byte-with-reg segment
1088                                        (if (eq size :byte)
1089                                            #b10110
1090                                            #b10111)
1091                                        (reg-tn-encoding dst))
1092                    (emit-sized-immediate segment size src))
1093                   ((and (fixup-p src) (accumulator-p dst))
1094                    (emit-byte segment
1095                               (if (eq size :byte)
1096                                   #b10100000
1097                                   #b10100001))
1098                    (emit-absolute-fixup segment src))
1099                   (t
1100                    (emit-byte segment
1101                               (if (eq size :byte)
1102                                   #b10001010
1103                                   #b10001011))
1104                    (emit-ea segment src (reg-tn-encoding dst) t))))
1105            ((and (fixup-p dst) (accumulator-p src))
1106             (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
1107             (emit-absolute-fixup segment dst))
1108            ((integerp src)
1109             (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
1110             (emit-ea segment dst #b000)
1111             (emit-sized-immediate segment size src))
1112            ((register-p src)
1113             (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
1114             (emit-ea segment dst (reg-tn-encoding src)))
1115            ((fixup-p src)
1116             (aver (eq size :dword))
1117             (emit-byte segment #b11000111)
1118             (emit-ea segment dst #b000)
1119             (emit-absolute-fixup segment src))
1120            (t
1121             (error "bogus arguments to MOV: ~S ~S" dst src))))))
1122
1123 (defun emit-move-with-extension (segment dst src opcode)
1124   (aver (register-p dst))
1125   (let ((dst-size (operand-size dst))
1126         (src-size (operand-size src)))
1127     (ecase dst-size
1128       (:word
1129        (aver (eq src-size :byte))
1130        (maybe-emit-operand-size-prefix segment :word)
1131        (emit-byte segment #b00001111)
1132        (emit-byte segment opcode)
1133        (emit-ea segment src (reg-tn-encoding dst)))
1134       (:dword
1135        (ecase src-size
1136          (:byte
1137           (maybe-emit-operand-size-prefix segment :dword)
1138           (emit-byte segment #b00001111)
1139           (emit-byte segment opcode)
1140           (emit-ea segment src (reg-tn-encoding dst)))
1141          (:word
1142           (emit-byte segment #b00001111)
1143           (emit-byte segment (logior opcode 1))
1144           (emit-ea segment src (reg-tn-encoding dst))))))))
1145
1146 (define-instruction movsx (segment dst src)
1147   (:printer ext-reg-reg/mem ((op #b1011111)
1148                              (reg nil :type 'word-reg)
1149                              (reg/mem nil :type 'sized-reg/mem)))
1150   (:printer x66-ext-reg-reg/mem ((op #b1011111)
1151                                  (reg nil :type 'word-reg)
1152                                  (reg/mem nil :type 'sized-reg/mem)))
1153   (:emitter (emit-move-with-extension segment dst src #b10111110)))
1154
1155 (define-instruction movzx (segment dst src)
1156   (:printer ext-reg-reg/mem ((op #b1011011)
1157                              (reg nil :type 'word-reg)
1158                              (reg/mem nil :type 'sized-reg/mem)))
1159   (:printer x66-ext-reg-reg/mem ((op #b1011011)
1160                                  (reg nil :type 'word-reg)
1161                                  (reg/mem nil :type 'sized-reg/mem)))
1162   (:emitter (emit-move-with-extension segment dst src #b10110110)))
1163
1164 (define-instruction push (segment src &optional prefix)
1165   ;; register
1166   (:printer reg-no-width ((op #b01010)))
1167   (:printer x66-reg-no-width ((op #b01010)))
1168   ;; register/memory
1169   (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
1170   (:printer x66-reg/mem ((op '(#b1111111 #b110)) (width 1)))
1171   ;; immediate
1172   (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
1173             '(:name :tab imm))
1174   (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
1175             '(:name :tab imm))
1176   ;; ### segment registers?
1177
1178   (:emitter
1179    (emit-prefix segment prefix)
1180    (cond ((integerp src)
1181           (cond ((<= -128 src 127)
1182                  (emit-byte segment #b01101010)
1183                  (emit-byte segment src))
1184                 (t
1185                  (emit-byte segment #b01101000)
1186                  (emit-dword segment src))))
1187          ((fixup-p src)
1188           ;; Interpret the fixup as an immediate dword to push.
1189           (emit-byte segment #b01101000)
1190           (emit-absolute-fixup segment src))
1191          (t
1192           (let ((size (operand-size src)))
1193             (aver (not (eq size :byte)))
1194             (maybe-emit-operand-size-prefix segment size)
1195             (cond ((register-p src)
1196                    (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
1197                   (t
1198                    (emit-byte segment #b11111111)
1199                    (emit-ea segment src #b110 t))))))))
1200
1201 (define-instruction pusha (segment)
1202   (:printer byte ((op #b01100000)))
1203   (:emitter
1204    (emit-byte segment #b01100000)))
1205
1206 (define-instruction pop (segment dst)
1207   (:printer x66-reg-no-width ((op #b01011)))
1208   (:printer reg-no-width ((op #b01011)))
1209   (:printer x66-reg/mem ((op '(#b1000111 #b000)) (width 1)))
1210   (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
1211   (:emitter
1212    (let ((size (operand-size dst)))
1213      (aver (not (eq size :byte)))
1214      (maybe-emit-operand-size-prefix segment size)
1215      (cond ((register-p dst)
1216             (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
1217            (t
1218             (emit-byte segment #b10001111)
1219             (emit-ea segment dst #b000))))))
1220
1221 (define-instruction popa (segment)
1222   (:printer byte ((op #b01100001)))
1223   (:emitter
1224    (emit-byte segment #b01100001)))
1225
1226 (define-instruction xchg (segment operand1 operand2)
1227   ;; Register with accumulator.
1228   (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1229   (:printer x66-reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1230   ;; Register/Memory with Register.
1231   (:printer reg-reg/mem ((op #b1000011)))
1232   (:printer x66-reg-reg/mem ((op #b1000011)))
1233   (:emitter
1234    (let ((size (matching-operand-size operand1 operand2)))
1235      (maybe-emit-operand-size-prefix segment size)
1236      (labels ((xchg-acc-with-something (acc something)
1237                 (if (and (not (eq size :byte)) (register-p something))
1238                     (emit-byte-with-reg segment
1239                                         #b10010
1240                                         (reg-tn-encoding something))
1241                     (xchg-reg-with-something acc something)))
1242               (xchg-reg-with-something (reg something)
1243                 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1244                 (emit-ea segment something (reg-tn-encoding reg))))
1245        (cond ((accumulator-p operand1)
1246               (xchg-acc-with-something operand1 operand2))
1247              ((accumulator-p operand2)
1248               (xchg-acc-with-something operand2 operand1))
1249              ((register-p operand1)
1250               (xchg-reg-with-something operand1 operand2))
1251              ((register-p operand2)
1252               (xchg-reg-with-something operand2 operand1))
1253              (t
1254               (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1255
1256 (define-instruction lea (segment dst src)
1257   (:printer reg-reg/mem ((op #b1000110) (width 1)))
1258   (:emitter
1259    (aver (dword-reg-p dst))
1260    (emit-byte segment #b10001101)
1261    (emit-ea segment src (reg-tn-encoding dst))))
1262
1263 (define-instruction cmpxchg (segment dst src &optional prefix)
1264   ;; Register/Memory with Register.
1265   (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1266   (:printer x66-ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1267   (:emitter
1268    (aver (register-p src))
1269    (emit-prefix segment prefix)
1270    (let ((size (matching-operand-size src dst)))
1271      (maybe-emit-operand-size-prefix segment size)
1272      (emit-byte segment #b00001111)
1273      (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1274      (emit-ea segment dst (reg-tn-encoding src)))))
1275
1276 \f
1277 (defun emit-prefix (segment name)
1278   (ecase name
1279     ((nil))
1280     (:lock
1281      #!+sb-thread
1282      (emit-byte segment #xf0))
1283     (:fs
1284      (emit-byte segment #x64))
1285     (:gs
1286      (emit-byte segment #x65))))
1287
1288 (define-instruction fs-segment-prefix (segment)
1289   (:printer byte ((op #b01100100)))
1290   (:emitter
1291    (bug "FS emitted as a separate instruction!")))
1292
1293 (define-instruction gs-segment-prefix (segment)
1294   (:printer byte ((op #b01100101)))
1295   (:emitter
1296    (bug "GS emitted as a separate instruction!")))
1297
1298 ;;;; flag control instructions
1299
1300 ;;; CLC -- Clear Carry Flag.
1301 (define-instruction clc (segment)
1302   (:printer byte ((op #b11111000)))
1303   (:emitter
1304    (emit-byte segment #b11111000)))
1305
1306 ;;; CLD -- Clear Direction Flag.
1307 (define-instruction cld (segment)
1308   (:printer byte ((op #b11111100)))
1309   (:emitter
1310    (emit-byte segment #b11111100)))
1311
1312 ;;; CLI -- Clear Iterrupt Enable Flag.
1313 (define-instruction cli (segment)
1314   (:printer byte ((op #b11111010)))
1315   (:emitter
1316    (emit-byte segment #b11111010)))
1317
1318 ;;; CMC -- Complement Carry Flag.
1319 (define-instruction cmc (segment)
1320   (:printer byte ((op #b11110101)))
1321   (:emitter
1322    (emit-byte segment #b11110101)))
1323
1324 ;;; LAHF -- Load AH into flags.
1325 (define-instruction lahf (segment)
1326   (:printer byte ((op #b10011111)))
1327   (:emitter
1328    (emit-byte segment #b10011111)))
1329
1330 ;;; POPF -- Pop flags.
1331 (define-instruction popf (segment)
1332   (:printer byte ((op #b10011101)))
1333   (:emitter
1334    (emit-byte segment #b10011101)))
1335
1336 ;;; PUSHF -- push flags.
1337 (define-instruction pushf (segment)
1338   (:printer byte ((op #b10011100)))
1339   (:emitter
1340    (emit-byte segment #b10011100)))
1341
1342 ;;; SAHF -- Store AH into flags.
1343 (define-instruction sahf (segment)
1344   (:printer byte ((op #b10011110)))
1345   (:emitter
1346    (emit-byte segment #b10011110)))
1347
1348 ;;; STC -- Set Carry Flag.
1349 (define-instruction stc (segment)
1350   (:printer byte ((op #b11111001)))
1351   (:emitter
1352    (emit-byte segment #b11111001)))
1353
1354 ;;; STD -- Set Direction Flag.
1355 (define-instruction std (segment)
1356   (:printer byte ((op #b11111101)))
1357   (:emitter
1358    (emit-byte segment #b11111101)))
1359
1360 ;;; STI -- Set Interrupt Enable Flag.
1361 (define-instruction sti (segment)
1362   (:printer byte ((op #b11111011)))
1363   (:emitter
1364    (emit-byte segment #b11111011)))
1365 \f
1366 ;;;; arithmetic
1367
1368 (defun emit-random-arith-inst (name segment dst src opcode
1369                                &optional allow-constants)
1370   (let ((size (matching-operand-size dst src)))
1371     (maybe-emit-operand-size-prefix segment size)
1372     (cond
1373      ((integerp src)
1374       (cond ((and (not (eq size :byte)) (<= -128 src 127))
1375              (emit-byte segment #b10000011)
1376              (emit-ea segment dst opcode allow-constants)
1377              (emit-byte segment src))
1378             ((accumulator-p dst)
1379              (emit-byte segment
1380                         (dpb opcode
1381                              (byte 3 3)
1382                              (if (eq size :byte)
1383                                  #b00000100
1384                                  #b00000101)))
1385              (emit-sized-immediate segment size src))
1386             (t
1387              (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1388              (emit-ea segment dst opcode allow-constants)
1389              (emit-sized-immediate segment size src))))
1390      ((register-p src)
1391       (emit-byte segment
1392                  (dpb opcode
1393                       (byte 3 3)
1394                       (if (eq size :byte) #b00000000 #b00000001)))
1395       (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1396      ((register-p dst)
1397       (emit-byte segment
1398                  (dpb opcode
1399                       (byte 3 3)
1400                       (if (eq size :byte) #b00000010 #b00000011)))
1401       (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1402      (t
1403       (error "bogus operands to ~A" name)))))
1404
1405 (eval-when (:compile-toplevel :execute)
1406   (defun arith-inst-printer-list (subop)
1407     `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1408       (x66-accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1409       (reg/mem-imm ((op (#b1000000 ,subop))))
1410       (x66-reg/mem-imm ((op (#b1000000 ,subop))))
1411       (reg/mem-imm ((op (#b1000001 ,subop))
1412                     (imm nil :type signed-imm-byte)))
1413       (x66-reg/mem-imm ((op (#b1000001 ,subop))
1414                         (imm nil :type signed-imm-byte)))
1415       (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
1416       (x66-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1417   )
1418
1419 (define-instruction add (segment dst src &optional prefix)
1420   (:printer-list (arith-inst-printer-list #b000))
1421   (:emitter
1422    (emit-prefix segment prefix)
1423    (emit-random-arith-inst "ADD" segment dst src #b000)))
1424
1425 (define-instruction adc (segment dst src)
1426   (:printer-list (arith-inst-printer-list #b010))
1427   (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1428
1429 (define-instruction sub (segment dst src &optional prefix)
1430   (:printer-list (arith-inst-printer-list #b101))
1431   (:emitter
1432    (emit-prefix segment prefix)
1433    (emit-random-arith-inst "SUB" segment dst src #b101)))
1434
1435 (define-instruction sbb (segment dst src)
1436   (:printer-list (arith-inst-printer-list #b011))
1437   (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1438
1439 (define-instruction cmp (segment dst src &optional prefix)
1440   (:printer-list (arith-inst-printer-list #b111))
1441   (:emitter
1442    (emit-prefix segment prefix)
1443    (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1444
1445 (define-instruction inc (segment dst)
1446   ;; Register.
1447   (:printer reg-no-width ((op #b01000)))
1448   (:printer x66-reg-no-width ((op #b01000)))
1449   ;; Register/Memory
1450   (:printer reg/mem ((op '(#b1111111 #b000))))
1451   (:printer x66-reg/mem ((op '(#b1111111 #b000))))
1452   (:emitter
1453    (let ((size (operand-size dst)))
1454      (maybe-emit-operand-size-prefix segment size)
1455      (cond ((and (not (eq size :byte)) (register-p dst))
1456             (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1457            (t
1458             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1459             (emit-ea segment dst #b000))))))
1460
1461 (define-instruction dec (segment dst)
1462   ;; Register.
1463   (:printer reg-no-width ((op #b01001)))
1464   (:printer x66-reg-no-width ((op #b01001)))
1465   ;; Register/Memory
1466   (:printer reg/mem ((op '(#b1111111 #b001))))
1467   (:printer x66-reg/mem ((op '(#b1111111 #b001))))
1468   (:emitter
1469    (let ((size (operand-size dst)))
1470      (maybe-emit-operand-size-prefix segment size)
1471      (cond ((and (not (eq size :byte)) (register-p dst))
1472             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1473            (t
1474             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1475             (emit-ea segment dst #b001))))))
1476
1477 (define-instruction neg (segment dst)
1478   (:printer reg/mem ((op '(#b1111011 #b011))))
1479   (:printer x66-reg/mem ((op '(#b1111011 #b011))))
1480   (:emitter
1481    (let ((size (operand-size dst)))
1482      (maybe-emit-operand-size-prefix segment size)
1483      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1484      (emit-ea segment dst #b011))))
1485
1486 (define-instruction aaa (segment)
1487   (:printer byte ((op #b00110111)))
1488   (:emitter
1489    (emit-byte segment #b00110111)))
1490
1491 (define-instruction aas (segment)
1492   (:printer byte ((op #b00111111)))
1493   (:emitter
1494    (emit-byte segment #b00111111)))
1495
1496 (define-instruction daa (segment)
1497   (:printer byte ((op #b00100111)))
1498   (:emitter
1499    (emit-byte segment #b00100111)))
1500
1501 (define-instruction das (segment)
1502   (:printer byte ((op #b00101111)))
1503   (:emitter
1504    (emit-byte segment #b00101111)))
1505
1506 (define-instruction mul (segment dst src)
1507   (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1508   (:printer x66-accum-reg/mem ((op '(#b1111011 #b100))))
1509   (:emitter
1510    (let ((size (matching-operand-size dst src)))
1511      (aver (accumulator-p dst))
1512      (maybe-emit-operand-size-prefix segment size)
1513      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1514      (emit-ea segment src #b100))))
1515
1516 (define-instruction imul (segment dst &optional src1 src2)
1517   (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1518   (:printer x66-accum-reg/mem ((op '(#b1111011 #b101))))
1519   (:printer ext-reg-reg/mem ((op #b1010111)))
1520   (:printer x66-ext-reg-reg/mem ((op #b1010111)))
1521   (:printer reg-reg/mem ((op #b0110100) (width 1)
1522                          (imm nil :type 'signed-imm-word))
1523             '(:name :tab reg ", " reg/mem ", " imm))
1524   (:printer x66-reg-reg/mem ((op #b0110100) (width 1)
1525                              (imm nil :type 'signed-imm-word))
1526             '(:name :tab reg ", " reg/mem ", " imm))
1527   (:printer reg-reg/mem ((op #b0110101) (width 1)
1528                          (imm nil :type 'signed-imm-byte))
1529             '(:name :tab reg ", " reg/mem ", " imm))
1530   (:printer x66-reg-reg/mem ((op #b0110101) (width 1)
1531                              (imm nil :type 'signed-imm-byte))
1532             '(:name :tab reg ", " reg/mem ", " imm))
1533   (:emitter
1534    (flet ((r/m-with-immed-to-reg (reg r/m immed)
1535             (let* ((size (matching-operand-size reg r/m))
1536                    (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1537               (maybe-emit-operand-size-prefix segment size)
1538               (emit-byte segment (if sx #b01101011 #b01101001))
1539               (emit-ea segment r/m (reg-tn-encoding reg))
1540               (if sx
1541                   (emit-byte segment immed)
1542                   (emit-sized-immediate segment size immed)))))
1543      (cond (src2
1544             (r/m-with-immed-to-reg dst src1 src2))
1545            (src1
1546             (if (integerp src1)
1547                 (r/m-with-immed-to-reg dst dst src1)
1548                 (let ((size (matching-operand-size dst src1)))
1549                   (maybe-emit-operand-size-prefix segment size)
1550                   (emit-byte segment #b00001111)
1551                   (emit-byte segment #b10101111)
1552                   (emit-ea segment src1 (reg-tn-encoding dst)))))
1553            (t
1554             (let ((size (operand-size dst)))
1555               (maybe-emit-operand-size-prefix segment size)
1556               (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1557               (emit-ea segment dst #b101)))))))
1558
1559 (define-instruction div (segment dst src)
1560   (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1561   (:printer x66-accum-reg/mem ((op '(#b1111011 #b110))))
1562   (:emitter
1563    (let ((size (matching-operand-size dst src)))
1564      (aver (accumulator-p dst))
1565      (maybe-emit-operand-size-prefix segment size)
1566      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1567      (emit-ea segment src #b110))))
1568
1569 (define-instruction idiv (segment dst src)
1570   (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1571   (:printer x66-accum-reg/mem ((op '(#b1111011 #b111))))
1572   (:emitter
1573    (let ((size (matching-operand-size dst src)))
1574      (aver (accumulator-p dst))
1575      (maybe-emit-operand-size-prefix segment size)
1576      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1577      (emit-ea segment src #b111))))
1578
1579 (define-instruction aad (segment)
1580   (:printer two-bytes ((op '(#b11010101 #b00001010))))
1581   (:emitter
1582    (emit-byte segment #b11010101)
1583    (emit-byte segment #b00001010)))
1584
1585 (define-instruction aam (segment)
1586   (:printer two-bytes ((op '(#b11010100 #b00001010))))
1587   (:emitter
1588    (emit-byte segment #b11010100)
1589    (emit-byte segment #b00001010)))
1590
1591 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1592 (define-instruction cbw (segment)
1593   (:printer two-bytes ((op '(#b01100110 #b10011000))))
1594   (:emitter
1595    (maybe-emit-operand-size-prefix segment :word)
1596    (emit-byte segment #b10011000)))
1597
1598 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1599 (define-instruction cwde (segment)
1600   (:printer byte ((op #b10011000)))
1601   (:emitter
1602    (maybe-emit-operand-size-prefix segment :dword)
1603    (emit-byte segment #b10011000)))
1604
1605 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1606 (define-instruction cwd (segment)
1607   (:printer two-bytes ((op '(#b01100110 #b10011001))))
1608   (:emitter
1609    (maybe-emit-operand-size-prefix segment :word)
1610    (emit-byte segment #b10011001)))
1611
1612 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1613 (define-instruction cdq (segment)
1614   (:printer byte ((op #b10011001)))
1615   (:emitter
1616    (maybe-emit-operand-size-prefix segment :dword)
1617    (emit-byte segment #b10011001)))
1618
1619 (define-instruction xadd (segment dst src &optional prefix)
1620   ;; Register/Memory with Register.
1621   (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1622   (:printer x66-ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1623   (:emitter
1624    (aver (register-p src))
1625    (emit-prefix segment prefix)
1626    (let ((size (matching-operand-size src dst)))
1627      (maybe-emit-operand-size-prefix segment size)
1628      (emit-byte segment #b00001111)
1629      (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1630      (emit-ea segment dst (reg-tn-encoding src)))))
1631
1632 \f
1633 ;;;; logic
1634
1635 (defun emit-shift-inst (segment dst amount opcode)
1636   (let ((size (operand-size dst)))
1637     (maybe-emit-operand-size-prefix segment size)
1638     (multiple-value-bind (major-opcode immed)
1639         (case amount
1640           (:cl (values #b11010010 nil))
1641           (1 (values #b11010000 nil))
1642           (t (values #b11000000 t)))
1643       (emit-byte segment
1644                  (if (eq size :byte) major-opcode (logior major-opcode 1)))
1645       (emit-ea segment dst opcode)
1646       (when immed
1647         (emit-byte segment amount)))))
1648
1649 (eval-when (:compile-toplevel :execute)
1650   (defun shift-inst-printer-list (subop)
1651     `((reg/mem ((op (#b1101000 ,subop)))
1652                (:name :tab reg/mem ", 1"))
1653       (x66-reg/mem ((op (#b1101000 ,subop)))
1654                    (:name :tab reg/mem ", 1"))
1655       (reg/mem ((op (#b1101001 ,subop)))
1656                (:name :tab reg/mem ", " 'cl))
1657       (x66-reg/mem ((op (#b1101001 ,subop)))
1658                    (:name :tab reg/mem ", " 'cl))
1659       (reg/mem-imm ((op (#b1100000 ,subop))
1660                     (imm nil :type signed-imm-byte)))
1661       (x66-reg/mem-imm ((op (#b1100000 ,subop))
1662                         (imm nil :type signed-imm-byte))))))
1663
1664 (define-instruction rol (segment dst amount)
1665   (:printer-list
1666    (shift-inst-printer-list #b000))
1667   (:emitter
1668    (emit-shift-inst segment dst amount #b000)))
1669
1670 (define-instruction ror (segment dst amount)
1671   (:printer-list
1672    (shift-inst-printer-list #b001))
1673   (:emitter
1674    (emit-shift-inst segment dst amount #b001)))
1675
1676 (define-instruction rcl (segment dst amount)
1677   (:printer-list
1678    (shift-inst-printer-list #b010))
1679   (:emitter
1680    (emit-shift-inst segment dst amount #b010)))
1681
1682 (define-instruction rcr (segment dst amount)
1683   (:printer-list
1684    (shift-inst-printer-list #b011))
1685   (:emitter
1686    (emit-shift-inst segment dst amount #b011)))
1687
1688 (define-instruction shl (segment dst amount)
1689   (:printer-list
1690    (shift-inst-printer-list #b100))
1691   (:emitter
1692    (emit-shift-inst segment dst amount #b100)))
1693
1694 (define-instruction shr (segment dst amount)
1695   (:printer-list
1696    (shift-inst-printer-list #b101))
1697   (:emitter
1698    (emit-shift-inst segment dst amount #b101)))
1699
1700 (define-instruction sar (segment dst amount)
1701   (:printer-list
1702    (shift-inst-printer-list #b111))
1703   (:emitter
1704    (emit-shift-inst segment dst amount #b111)))
1705
1706 (defun emit-double-shift (segment opcode dst src amt)
1707   (let ((size (matching-operand-size dst src)))
1708     (when (eq size :byte)
1709       (error "Double shifts can only be used with words."))
1710     (maybe-emit-operand-size-prefix segment size)
1711     (emit-byte segment #b00001111)
1712     (emit-byte segment (dpb opcode (byte 1 3)
1713                             (if (eq amt :cl) #b10100101 #b10100100)))
1714     #+nil
1715     (emit-ea segment dst src)
1716     (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1717     (unless (eq amt :cl)
1718       (emit-byte segment amt))))
1719
1720 (eval-when (:compile-toplevel :execute)
1721   (defun double-shift-inst-printer-list (op)
1722     `(#+nil
1723       (ext-reg-reg/mem-imm ((op ,(logior op #b10))
1724                             (imm nil :type signed-imm-byte)))
1725       (ext-reg-reg/mem ((op ,(logior op #b10)))
1726          (:name :tab reg/mem ", " reg ", " 'cl))
1727       (x66-ext-reg-reg/mem ((op ,(logior op #b10)))
1728          (:name :tab reg/mem ", " reg ", " 'cl)))))
1729
1730 (define-instruction shld (segment dst src amt)
1731   (:declare (type (or (member :cl) (mod 32)) amt))
1732   (:printer-list (double-shift-inst-printer-list #b1010000))
1733   (:emitter
1734    (emit-double-shift segment #b0 dst src amt)))
1735
1736 (define-instruction shrd (segment dst src amt)
1737   (:declare (type (or (member :cl) (mod 32)) amt))
1738   (:printer-list (double-shift-inst-printer-list #b1010100))
1739   (:emitter
1740    (emit-double-shift segment #b1 dst src amt)))
1741
1742 (define-instruction and (segment dst src)
1743   (:printer-list
1744    (arith-inst-printer-list #b100))
1745   (:emitter
1746    (emit-random-arith-inst "AND" segment dst src #b100)))
1747
1748 (define-instruction test (segment this that)
1749   (:printer accum-imm ((op #b1010100)))
1750   (:printer x66-accum-imm ((op #b1010100)))
1751   (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1752   (:printer x66-reg/mem-imm ((op '(#b1111011 #b000))))
1753   (:printer reg-reg/mem ((op #b1000010)))
1754   (:printer x66-reg-reg/mem ((op #b1000010)))
1755   (:emitter
1756    (let ((size (matching-operand-size this that)))
1757      (maybe-emit-operand-size-prefix segment size)
1758      (flet ((test-immed-and-something (immed something)
1759               (cond ((accumulator-p something)
1760                      (emit-byte segment
1761                                 (if (eq size :byte) #b10101000 #b10101001))
1762                      (emit-sized-immediate segment size immed))
1763                     (t
1764                      (emit-byte segment
1765                                 (if (eq size :byte) #b11110110 #b11110111))
1766                      (emit-ea segment something #b000)
1767                      (emit-sized-immediate segment size immed))))
1768             (test-reg-and-something (reg something)
1769               (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1770               (emit-ea segment something (reg-tn-encoding reg))))
1771        (cond ((integerp that)
1772               (test-immed-and-something that this))
1773              ((integerp this)
1774               (test-immed-and-something this that))
1775              ((register-p this)
1776               (test-reg-and-something this that))
1777              ((register-p that)
1778               (test-reg-and-something that this))
1779              (t
1780               (error "bogus operands for TEST: ~S and ~S" this that)))))))
1781
1782 ;;; Emit the most compact form of the test immediate instruction,
1783 ;;; using an 8 bit test when the immediate is only 8 bits and the
1784 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
1785 ;;; control stack.
1786 (defun emit-optimized-test-inst (x y)
1787   (typecase y
1788     ((unsigned-byte 7)
1789      (let ((offset (tn-offset x)))
1790        (cond ((and (sc-is x any-reg descriptor-reg)
1791                    (or (= offset eax-offset) (= offset ebx-offset)
1792                        (= offset ecx-offset) (= offset edx-offset)))
1793               (inst test (make-random-tn :kind :normal
1794                                          :sc (sc-or-lose 'byte-reg)
1795                                          :offset offset)
1796                     y))
1797              ((sc-is x control-stack)
1798               (inst test (make-ea :byte :base ebp-tn
1799                                   :disp (frame-byte-offset offset))
1800                     y))
1801              (t
1802               (inst test x y)))))
1803     (t
1804      (inst test x y))))
1805
1806 (define-instruction or (segment dst src &optional prefix)
1807   (:printer-list
1808    (arith-inst-printer-list #b001))
1809   (:emitter
1810    (emit-prefix segment prefix)
1811    (emit-random-arith-inst "OR" segment dst src #b001)))
1812
1813 (define-instruction xor (segment dst src &optional prefix)
1814   (:printer-list
1815    (arith-inst-printer-list #b110))
1816   (:emitter
1817    (emit-prefix segment prefix)
1818    (emit-random-arith-inst "XOR" segment dst src #b110)))
1819
1820 (define-instruction not (segment dst)
1821   (:printer reg/mem ((op '(#b1111011 #b010))))
1822   (:printer x66-reg/mem ((op '(#b1111011 #b010))))
1823   (:emitter
1824    (let ((size (operand-size dst)))
1825      (maybe-emit-operand-size-prefix segment size)
1826      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1827      (emit-ea segment dst #b010))))
1828 \f
1829 ;;;; string manipulation
1830
1831 (define-instruction cmps (segment size)
1832   (:printer string-op ((op #b1010011)))
1833   (:printer x66-string-op ((op #b1010011)))
1834   (:emitter
1835    (maybe-emit-operand-size-prefix segment size)
1836    (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1837
1838 (define-instruction ins (segment acc)
1839   (:printer string-op ((op #b0110110)))
1840   (:printer x66-string-op ((op #b0110110)))
1841   (:emitter
1842    (let ((size (operand-size acc)))
1843      (aver (accumulator-p acc))
1844      (maybe-emit-operand-size-prefix segment size)
1845      (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1846
1847 (define-instruction lods (segment acc)
1848   (:printer string-op ((op #b1010110)))
1849   (:printer x66-string-op ((op #b1010110)))
1850   (:emitter
1851    (let ((size (operand-size acc)))
1852      (aver (accumulator-p acc))
1853      (maybe-emit-operand-size-prefix segment size)
1854      (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1855
1856 (define-instruction movs (segment size)
1857   (:printer string-op ((op #b1010010)))
1858   (:printer x66-string-op ((op #b1010010)))
1859   (:emitter
1860    (maybe-emit-operand-size-prefix segment size)
1861    (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1862
1863 (define-instruction outs (segment acc)
1864   (:printer string-op ((op #b0110111)))
1865   (:printer x66-string-op ((op #b0110111)))
1866   (:emitter
1867    (let ((size (operand-size acc)))
1868      (aver (accumulator-p acc))
1869      (maybe-emit-operand-size-prefix segment size)
1870      (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1871
1872 (define-instruction scas (segment acc)
1873   (:printer string-op ((op #b1010111)))
1874   (:printer x66-string-op ((op #b1010111)))
1875   (:emitter
1876    (let ((size (operand-size acc)))
1877      (aver (accumulator-p acc))
1878      (maybe-emit-operand-size-prefix segment size)
1879      (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1880
1881 (define-instruction stos (segment acc)
1882   (:printer string-op ((op #b1010101)))
1883   (:printer x66-string-op ((op #b1010101)))
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) #b10101010 #b10101011)))))
1889
1890 (define-instruction xlat (segment)
1891   (:printer byte ((op #b11010111)))
1892   (:emitter
1893    (emit-byte segment #b11010111)))
1894
1895 (define-instruction rep (segment)
1896   (:emitter
1897    (emit-byte segment #b11110011)))
1898
1899 (define-instruction repe (segment)
1900   (:printer byte ((op #b11110011)))
1901   (:emitter
1902    (emit-byte segment #b11110011)))
1903
1904 (define-instruction repne (segment)
1905   (:printer byte ((op #b11110010)))
1906   (:emitter
1907    (emit-byte segment #b11110010)))
1908
1909 \f
1910 ;;;; bit manipulation
1911
1912 (define-instruction bsf (segment dst src)
1913   (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
1914   (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 0)))
1915   (:emitter
1916    (let ((size (matching-operand-size dst src)))
1917      (when (eq size :byte)
1918        (error "can't scan bytes: ~S" src))
1919      (maybe-emit-operand-size-prefix segment size)
1920      (emit-byte segment #b00001111)
1921      (emit-byte segment #b10111100)
1922      (emit-ea segment src (reg-tn-encoding dst)))))
1923
1924 (define-instruction bsr (segment dst src)
1925   (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
1926   (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 1)))
1927   (:emitter
1928    (let ((size (matching-operand-size dst src)))
1929      (when (eq size :byte)
1930        (error "can't scan bytes: ~S" src))
1931      (maybe-emit-operand-size-prefix segment size)
1932      (emit-byte segment #b00001111)
1933      (emit-byte segment #b10111101)
1934      (emit-ea segment src (reg-tn-encoding dst)))))
1935
1936 (defun emit-bit-test-and-mumble (segment src index opcode)
1937   (let ((size (operand-size src)))
1938     (when (eq size :byte)
1939       (error "can't scan bytes: ~S" src))
1940     (maybe-emit-operand-size-prefix segment size)
1941     (emit-byte segment #b00001111)
1942     (cond ((integerp index)
1943            (emit-byte segment #b10111010)
1944            (emit-ea segment src opcode)
1945            (emit-byte segment index))
1946           (t
1947            (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1948            (emit-ea segment src (reg-tn-encoding index))))))
1949
1950 (eval-when (:compile-toplevel :execute)
1951   (defun bit-test-inst-printer-list (subop)
1952     `((ext-reg/mem-imm ((op (#b1011101 ,subop))
1953                         (reg/mem nil :type word-reg/mem)
1954                         (imm nil :type imm-data)
1955                         (width 0)))
1956       (x66-ext-reg/mem-imm ((op (#b1011101 ,subop))
1957                             (reg/mem nil :type word-reg/mem)
1958                             (imm nil :type imm-data)
1959                             (width 0)))
1960       (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1961                         (width 1))
1962                        (:name :tab reg/mem ", " reg))
1963       (x66-ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1964                             (width 1))
1965                            (:name :tab reg/mem ", " reg)))))
1966
1967 (define-instruction bt (segment src index)
1968   (:printer-list (bit-test-inst-printer-list #b100))
1969   (:emitter
1970    (emit-bit-test-and-mumble segment src index #b100)))
1971
1972 (define-instruction btc (segment src index)
1973   (:printer-list (bit-test-inst-printer-list #b111))
1974   (:emitter
1975    (emit-bit-test-and-mumble segment src index #b111)))
1976
1977 (define-instruction btr (segment src index)
1978   (:printer-list (bit-test-inst-printer-list #b110))
1979   (:emitter
1980    (emit-bit-test-and-mumble segment src index #b110)))
1981
1982 (define-instruction bts (segment src index)
1983   (:printer-list (bit-test-inst-printer-list #b101))
1984   (:emitter
1985    (emit-bit-test-and-mumble segment src index #b101)))
1986
1987 \f
1988 ;;;; control transfer
1989
1990 (define-instruction call (segment where)
1991   (:printer near-jump ((op #b11101000)))
1992   (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
1993   (:emitter
1994    (typecase where
1995      (label
1996       (emit-byte segment #b11101000)
1997       (emit-back-patch segment
1998                        4
1999                        (lambda (segment posn)
2000                          (emit-dword segment
2001                                      (- (label-position where)
2002                                         (+ posn 4))))))
2003      (fixup
2004       (emit-byte segment #b11101000)
2005       (emit-relative-fixup segment where))
2006      (t
2007       (emit-byte segment #b11111111)
2008       (emit-ea segment where #b010)))))
2009
2010 (defun emit-byte-displacement-backpatch (segment target)
2011   (emit-back-patch segment
2012                    1
2013                    (lambda (segment posn)
2014                      (let ((disp (- (label-position target) (1+ posn))))
2015                        (aver (<= -128 disp 127))
2016                        (emit-byte segment disp)))))
2017
2018 (define-instruction jmp (segment cond &optional where)
2019   ;; conditional jumps
2020   (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
2021   (:printer near-cond-jump () '('j cc :tab label))
2022   ;; unconditional jumps
2023   (:printer short-jump ((op #b1011)))
2024   (:printer near-jump ((op #b11101001)) )
2025   (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
2026   (:emitter
2027    (cond (where
2028           (emit-chooser
2029            segment 6 2
2030            (lambda (segment posn delta-if-after)
2031              (let ((disp (- (label-position where posn delta-if-after)
2032                             (+ posn 2))))
2033                (when (<= -128 disp 127)
2034                  (emit-byte segment
2035                             (dpb (conditional-opcode cond)
2036                                  (byte 4 0)
2037                                  #b01110000))
2038                  (emit-byte-displacement-backpatch segment where)
2039                  t)))
2040            (lambda (segment posn)
2041              (let ((disp (- (label-position where) (+ posn 6))))
2042                (emit-byte segment #b00001111)
2043                (emit-byte segment
2044                           (dpb (conditional-opcode cond)
2045                                (byte 4 0)
2046                                #b10000000))
2047                (emit-dword segment disp)))))
2048          ((label-p (setq where cond))
2049           (emit-chooser
2050            segment 5 0
2051            (lambda (segment posn delta-if-after)
2052              (let ((disp (- (label-position where posn delta-if-after)
2053                             (+ posn 2))))
2054                (when (<= -128 disp 127)
2055                  (emit-byte segment #b11101011)
2056                  (emit-byte-displacement-backpatch segment where)
2057                  t)))
2058            (lambda (segment posn)
2059              (let ((disp (- (label-position where) (+ posn 5))))
2060                (emit-byte segment #b11101001)
2061                (emit-dword segment disp)))))
2062          ((fixup-p where)
2063           (emit-byte segment #b11101001)
2064           (emit-relative-fixup segment where))
2065          (t
2066           (unless (or (ea-p where) (tn-p where))
2067                   (error "don't know what to do with ~A" where))
2068           (emit-byte segment #b11111111)
2069           (emit-ea segment where #b100)))))
2070
2071 (define-instruction jmp-short (segment label)
2072   (:emitter
2073    (emit-byte segment #b11101011)
2074    (emit-byte-displacement-backpatch segment label)))
2075
2076 (define-instruction ret (segment &optional stack-delta)
2077   (:printer byte ((op #b11000011)))
2078   (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
2079             '(:name :tab imm))
2080   (:emitter
2081    (cond ((and stack-delta (not (zerop stack-delta)))
2082           (emit-byte segment #b11000010)
2083           (emit-word segment stack-delta))
2084          (t
2085           (emit-byte segment #b11000011)))))
2086
2087 (define-instruction jecxz (segment target)
2088   (:printer short-jump ((op #b0011)))
2089   (:emitter
2090    (emit-byte segment #b11100011)
2091    (emit-byte-displacement-backpatch segment target)))
2092
2093 (define-instruction loop (segment target)
2094   (:printer short-jump ((op #b0010)))
2095   (:emitter
2096    (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
2097    (emit-byte-displacement-backpatch segment target)))
2098
2099 (define-instruction loopz (segment target)
2100   (:printer short-jump ((op #b0001)))
2101   (:emitter
2102    (emit-byte segment #b11100001)
2103    (emit-byte-displacement-backpatch segment target)))
2104
2105 (define-instruction loopnz (segment target)
2106   (:printer short-jump ((op #b0000)))
2107   (:emitter
2108    (emit-byte segment #b11100000)
2109    (emit-byte-displacement-backpatch segment target)))
2110 \f
2111 ;;;; conditional move
2112 (define-instruction cmov (segment cond dst src)
2113   (:printer cond-move ())
2114   (:printer x66-cond-move ())
2115   (:emitter
2116    (aver (register-p dst))
2117    (let ((size (matching-operand-size dst src)))
2118      (aver (or (eq size :word) (eq size :dword)))
2119      (maybe-emit-operand-size-prefix segment size))
2120    (emit-byte segment #b00001111)
2121    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
2122    (emit-ea segment src (reg-tn-encoding dst))))
2123
2124 ;;;; conditional byte set
2125
2126 (define-instruction set (segment dst cond)
2127   (:printer cond-set ())
2128   (:emitter
2129    (emit-byte segment #b00001111)
2130    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
2131    (emit-ea segment dst #b000)))
2132 \f
2133 ;;;; enter/leave
2134
2135 (define-instruction enter (segment disp &optional (level 0))
2136   (:declare (type (unsigned-byte 16) disp)
2137             (type (unsigned-byte 8) level))
2138   (:printer enter-format ((op #b11001000)))
2139   (:emitter
2140    (emit-byte segment #b11001000)
2141    (emit-word segment disp)
2142    (emit-byte segment level)))
2143
2144 (define-instruction leave (segment)
2145   (:printer byte ((op #b11001001)))
2146   (:emitter
2147    (emit-byte segment #b11001001)))
2148 \f
2149 ;;;; prefetch
2150 (define-instruction prefetchnta (segment ea)
2151   (:printer prefetch ((op #b00011000) (reg #b000)))
2152   (:emitter
2153    (aver (typep ea 'ea))
2154    (aver (eq :byte (ea-size ea)))
2155    (emit-byte segment #b00001111)
2156    (emit-byte segment #b00011000)
2157    (emit-ea segment ea #b000)))
2158
2159 (define-instruction prefetcht0 (segment ea)
2160   (:printer prefetch ((op #b00011000) (reg #b001)))
2161   (:emitter
2162    (aver (typep ea 'ea))
2163    (aver (eq :byte (ea-size ea)))
2164    (emit-byte segment #b00001111)
2165    (emit-byte segment #b00011000)
2166    (emit-ea segment ea #b001)))
2167
2168 (define-instruction prefetcht1 (segment ea)
2169   (:printer prefetch ((op #b00011000) (reg #b010)))
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 #b010)))
2176
2177 (define-instruction prefetcht2 (segment ea)
2178   (:printer prefetch ((op #b00011000) (reg #b011)))
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 #b011)))
2185 \f
2186 ;;;; interrupt instructions
2187
2188 (defun snarf-error-junk (sap offset &optional length-only)
2189   (let* ((length (sb!sys:sap-ref-8 sap offset))
2190          (vector (make-array length :element-type '(unsigned-byte 8))))
2191     (declare (type sb!sys:system-area-pointer sap)
2192              (type (unsigned-byte 8) length)
2193              (type (simple-array (unsigned-byte 8) (*)) vector))
2194     (cond (length-only
2195            (values 0 (1+ length) nil nil))
2196           (t
2197            (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
2198                                                 vector 0 length)
2199            (collect ((sc-offsets)
2200                      (lengths))
2201              (lengths 1)                ; the length byte
2202              (let* ((index 0)
2203                     (error-number (sb!c:read-var-integer vector index)))
2204                (lengths index)
2205                (loop
2206                  (when (>= index length)
2207                    (return))
2208                  (let ((old-index index))
2209                    (sc-offsets (sb!c:read-var-integer vector index))
2210                    (lengths (- index old-index))))
2211                (values error-number
2212                        (1+ length)
2213                        (sc-offsets)
2214                        (lengths))))))))
2215
2216 #|
2217 (defmacro break-cases (breaknum &body cases)
2218   (let ((bn-temp (gensym)))
2219     (collect ((clauses))
2220       (dolist (case cases)
2221         (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
2222       `(let ((,bn-temp ,breaknum))
2223          (cond ,@(clauses))))))
2224 |#
2225
2226 (defun break-control (chunk inst stream dstate)
2227   (declare (ignore inst))
2228   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
2229     ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
2230     ;; map has it undefined; and it should be easier to look in the target
2231     ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
2232     ;; from first principles whether it's defined in some way that genesis
2233     ;; can't grok.
2234     (case #!-darwin (byte-imm-code chunk dstate)
2235           #!+darwin (word-imm-code chunk dstate)
2236       (#.error-trap
2237        (nt "error trap")
2238        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2239       (#.cerror-trap
2240        (nt "cerror trap")
2241        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2242       (#.breakpoint-trap
2243        (nt "breakpoint trap"))
2244       (#.pending-interrupt-trap
2245        (nt "pending interrupt trap"))
2246       (#.halt-trap
2247        (nt "halt trap"))
2248       (#.fun-end-breakpoint-trap
2249        (nt "function end breakpoint trap")))))
2250
2251 (define-instruction break (segment code)
2252   (:declare (type (unsigned-byte 8) code))
2253   #!-darwin (:printer byte-imm ((op #b11001100)) '(:name :tab code)
2254                      :control #'break-control)
2255   #!+darwin (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
2256                      :control #'break-control)
2257   (:emitter
2258    #!-darwin (emit-byte segment #b11001100)
2259    ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
2260    ;; throw a sigill with 0x0b0f instead and check for this in the
2261    ;; SIGILL handler and pass it on to the sigtrap handler if
2262    ;; appropriate
2263    #!+darwin (emit-word segment #b0000101100001111)
2264    (emit-byte segment code)))
2265
2266 (define-instruction int (segment number)
2267   (:declare (type (unsigned-byte 8) number))
2268   (:printer byte-imm ((op #b11001101)))
2269   (:emitter
2270    (etypecase number
2271      ((member 3)
2272       (emit-byte segment #b11001100))
2273      ((unsigned-byte 8)
2274       (emit-byte segment #b11001101)
2275       (emit-byte segment number)))))
2276
2277 (define-instruction into (segment)
2278   (:printer byte ((op #b11001110)))
2279   (:emitter
2280    (emit-byte segment #b11001110)))
2281
2282 (define-instruction bound (segment reg bounds)
2283   (:emitter
2284    (let ((size (matching-operand-size reg bounds)))
2285      (when (eq size :byte)
2286        (error "can't bounds-test bytes: ~S" reg))
2287      (maybe-emit-operand-size-prefix segment size)
2288      (emit-byte segment #b01100010)
2289      (emit-ea segment bounds (reg-tn-encoding reg)))))
2290
2291 (define-instruction iret (segment)
2292   (:printer byte ((op #b11001111)))
2293   (:emitter
2294    (emit-byte segment #b11001111)))
2295 \f
2296 ;;;; processor control
2297
2298 (define-instruction hlt (segment)
2299   (:printer byte ((op #b11110100)))
2300   (:emitter
2301    (emit-byte segment #b11110100)))
2302
2303 (define-instruction nop (segment)
2304   (:printer byte ((op #b10010000)))
2305   (:emitter
2306    (emit-byte segment #b10010000)))
2307
2308 (define-instruction wait (segment)
2309   (:printer byte ((op #b10011011)))
2310   (:emitter
2311    (emit-byte segment #b10011011)))
2312
2313 ;;; FIXME: It would be better to make the disassembler understand the prefix as part
2314 ;;; of the instructions...
2315 (define-instruction lock (segment)
2316   (:printer byte ((op #b11110000)))
2317   (:emitter
2318    (bug "LOCK prefix used as a standalone instruction")))
2319 \f
2320 ;;;; miscellaneous hackery
2321
2322 (define-instruction byte (segment byte)
2323   (:emitter
2324    (emit-byte segment byte)))
2325
2326 (define-instruction word (segment word)
2327   (:emitter
2328    (emit-word segment word)))
2329
2330 (define-instruction dword (segment dword)
2331   (:emitter
2332    (emit-dword segment dword)))
2333
2334 (defun emit-header-data (segment type)
2335   (emit-back-patch segment
2336                    4
2337                    (lambda (segment posn)
2338                      (emit-dword segment
2339                                  (logior type
2340                                          (ash (+ posn
2341                                                  (component-header-length))
2342                                               (- n-widetag-bits
2343                                                  word-shift)))))))
2344
2345 (define-instruction simple-fun-header-word (segment)
2346   (:emitter
2347    (emit-header-data segment simple-fun-header-widetag)))
2348
2349 (define-instruction lra-header-word (segment)
2350   (:emitter
2351    (emit-header-data segment return-pc-header-widetag)))
2352 \f
2353 ;;;; fp instructions
2354 ;;;;
2355 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
2356 ;;;;
2357 ;;;; Note: We treat the single-precision and double-precision variants
2358 ;;;; as separate instructions.
2359
2360 ;;; Load single to st(0).
2361 (define-instruction fld (segment source)
2362   (:printer floating-point ((op '(#b001 #b000))))
2363   (:emitter
2364     (emit-byte segment #b11011001)
2365     (emit-fp-op segment source #b000)))
2366
2367 ;;; Load double to st(0).
2368 (define-instruction fldd (segment source)
2369   (:printer floating-point ((op '(#b101 #b000))))
2370   (:printer floating-point-fp ((op '(#b001 #b000))))
2371   (:emitter
2372    (if (fp-reg-tn-p source)
2373        (emit-byte segment #b11011001)
2374      (emit-byte segment #b11011101))
2375     (emit-fp-op segment source #b000)))
2376
2377 ;;; Load long to st(0).
2378 (define-instruction fldl (segment source)
2379   (:printer floating-point ((op '(#b011 #b101))))
2380   (:emitter
2381     (emit-byte segment #b11011011)
2382     (emit-fp-op segment source #b101)))
2383
2384 ;;; Store single from st(0).
2385 (define-instruction fst (segment dest)
2386   (:printer floating-point ((op '(#b001 #b010))))
2387   (:emitter
2388     (cond ((fp-reg-tn-p dest)
2389            (emit-byte segment #b11011101)
2390            (emit-fp-op segment dest #b010))
2391           (t
2392            (emit-byte segment #b11011001)
2393            (emit-fp-op segment dest #b010)))))
2394
2395 ;;; Store double from st(0).
2396 (define-instruction fstd (segment dest)
2397   (:printer floating-point ((op '(#b101 #b010))))
2398   (:printer floating-point-fp ((op '(#b101 #b010))))
2399   (:emitter
2400    (cond ((fp-reg-tn-p dest)
2401           (emit-byte segment #b11011101)
2402           (emit-fp-op segment dest #b010))
2403          (t
2404           (emit-byte segment #b11011101)
2405           (emit-fp-op segment dest #b010)))))
2406
2407 ;;; Arithmetic ops are all done with at least one operand at top of
2408 ;;; stack. The other operand is is another register or a 32/64 bit
2409 ;;; memory loc.
2410
2411 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2412 ;;; that these conflict with the Gdb conventions for binops. To reduce
2413 ;;; the confusion I've added comments showing the mathamatical
2414 ;;; operation and the two syntaxes. By the ASM386 convention the
2415 ;;; instruction syntax is:
2416 ;;;
2417 ;;;      Fop Source
2418 ;;; or   Fop Destination, Source
2419 ;;;
2420 ;;; If only one operand is given then it is the source and the
2421 ;;; destination is ST(0). There are reversed forms of the fsub and
2422 ;;; fdiv instructions inducated by an 'R' suffix.
2423 ;;;
2424 ;;; The mathematical operation for the non-reverse form is always:
2425 ;;;     destination = destination op source
2426 ;;;
2427 ;;; For the reversed form it is:
2428 ;;;     destination = source op destination
2429 ;;;
2430 ;;; The instructions below only accept one operand at present which is
2431 ;;; usually the source. I've hack in extra instructions to implement
2432 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2433 ;;; the operand is the destination with the source being ST(0).
2434
2435 ;;; Add single:
2436 ;;;   st(0) = st(0) + memory or st(i).
2437 (define-instruction fadd (segment source)
2438   (:printer floating-point ((op '(#b000 #b000))))
2439   (:emitter
2440     (emit-byte segment #b11011000)
2441     (emit-fp-op segment source #b000)))
2442
2443 ;;; Add double:
2444 ;;;   st(0) = st(0) + memory or st(i).
2445 (define-instruction faddd (segment source)
2446   (:printer floating-point ((op '(#b100 #b000))))
2447   (:printer floating-point-fp ((op '(#b000 #b000))))
2448   (:emitter
2449    (if (fp-reg-tn-p source)
2450        (emit-byte segment #b11011000)
2451      (emit-byte segment #b11011100))
2452    (emit-fp-op segment source #b000)))
2453
2454 ;;; Add double destination st(i):
2455 ;;;   st(i) = st(0) + st(i).
2456 (define-instruction fadd-sti (segment destination)
2457   (:printer floating-point-fp ((op '(#b100 #b000))))
2458   (:emitter
2459    (aver (fp-reg-tn-p destination))
2460    (emit-byte segment #b11011100)
2461    (emit-fp-op segment destination #b000)))
2462 ;;; with pop
2463 (define-instruction faddp-sti (segment destination)
2464   (:printer floating-point-fp ((op '(#b110 #b000))))
2465   (:emitter
2466    (aver (fp-reg-tn-p destination))
2467    (emit-byte segment #b11011110)
2468    (emit-fp-op segment destination #b000)))
2469
2470 ;;; Subtract single:
2471 ;;;   st(0) = st(0) - memory or st(i).
2472 (define-instruction fsub (segment source)
2473   (:printer floating-point ((op '(#b000 #b100))))
2474   (:emitter
2475     (emit-byte segment #b11011000)
2476     (emit-fp-op segment source #b100)))
2477
2478 ;;; Subtract single, reverse:
2479 ;;;   st(0) = memory or st(i) - st(0).
2480 (define-instruction fsubr (segment source)
2481   (:printer floating-point ((op '(#b000 #b101))))
2482   (:emitter
2483     (emit-byte segment #b11011000)
2484     (emit-fp-op segment source #b101)))
2485
2486 ;;; Subtract double:
2487 ;;;   st(0) = st(0) - memory or st(i).
2488 (define-instruction fsubd (segment source)
2489   (:printer floating-point ((op '(#b100 #b100))))
2490   (:printer floating-point-fp ((op '(#b000 #b100))))
2491   (:emitter
2492    (if (fp-reg-tn-p source)
2493        (emit-byte segment #b11011000)
2494      (emit-byte segment #b11011100))
2495    (emit-fp-op segment source #b100)))
2496
2497 ;;; Subtract double, reverse:
2498 ;;;   st(0) = memory or st(i) - st(0).
2499 (define-instruction fsubrd (segment source)
2500   (:printer floating-point ((op '(#b100 #b101))))
2501   (:printer floating-point-fp ((op '(#b000 #b101))))
2502   (:emitter
2503    (if (fp-reg-tn-p source)
2504        (emit-byte segment #b11011000)
2505      (emit-byte segment #b11011100))
2506    (emit-fp-op segment source #b101)))
2507
2508 ;;; Subtract double, destination st(i):
2509 ;;;   st(i) = st(i) - st(0).
2510 ;;;
2511 ;;; ASM386 syntax: FSUB ST(i), ST
2512 ;;; Gdb    syntax: fsubr %st,%st(i)
2513 (define-instruction fsub-sti (segment destination)
2514   (:printer floating-point-fp ((op '(#b100 #b101))))
2515   (:emitter
2516    (aver (fp-reg-tn-p destination))
2517    (emit-byte segment #b11011100)
2518    (emit-fp-op segment destination #b101)))
2519 ;;; with a pop
2520 (define-instruction fsubp-sti (segment destination)
2521   (:printer floating-point-fp ((op '(#b110 #b101))))
2522   (:emitter
2523    (aver (fp-reg-tn-p destination))
2524    (emit-byte segment #b11011110)
2525    (emit-fp-op segment destination #b101)))
2526
2527 ;;; Subtract double, reverse, destination st(i):
2528 ;;;   st(i) = st(0) - st(i).
2529 ;;;
2530 ;;; ASM386 syntax: FSUBR ST(i), ST
2531 ;;; Gdb    syntax: fsub %st,%st(i)
2532 (define-instruction fsubr-sti (segment destination)
2533   (:printer floating-point-fp ((op '(#b100 #b100))))
2534   (:emitter
2535    (aver (fp-reg-tn-p destination))
2536    (emit-byte segment #b11011100)
2537    (emit-fp-op segment destination #b100)))
2538 ;;; with a pop
2539 (define-instruction fsubrp-sti (segment destination)
2540   (:printer floating-point-fp ((op '(#b110 #b100))))
2541   (:emitter
2542    (aver (fp-reg-tn-p destination))
2543    (emit-byte segment #b11011110)
2544    (emit-fp-op segment destination #b100)))
2545
2546 ;;; Multiply single:
2547 ;;;   st(0) = st(0) * memory or st(i).
2548 (define-instruction fmul (segment source)
2549   (:printer floating-point ((op '(#b000 #b001))))
2550   (:emitter
2551     (emit-byte segment #b11011000)
2552     (emit-fp-op segment source #b001)))
2553
2554 ;;; Multiply double:
2555 ;;;   st(0) = st(0) * memory or st(i).
2556 (define-instruction fmuld (segment source)
2557   (:printer floating-point ((op '(#b100 #b001))))
2558   (:printer floating-point-fp ((op '(#b000 #b001))))
2559   (:emitter
2560    (if (fp-reg-tn-p source)
2561        (emit-byte segment #b11011000)
2562      (emit-byte segment #b11011100))
2563    (emit-fp-op segment source #b001)))
2564
2565 ;;; Multiply double, destination st(i):
2566 ;;;   st(i) = st(i) * st(0).
2567 (define-instruction fmul-sti (segment destination)
2568   (:printer floating-point-fp ((op '(#b100 #b001))))
2569   (:emitter
2570    (aver (fp-reg-tn-p destination))
2571    (emit-byte segment #b11011100)
2572    (emit-fp-op segment destination #b001)))
2573
2574 ;;; Divide single:
2575 ;;;   st(0) = st(0) / memory or st(i).
2576 (define-instruction fdiv (segment source)
2577   (:printer floating-point ((op '(#b000 #b110))))
2578   (:emitter
2579     (emit-byte segment #b11011000)
2580     (emit-fp-op segment source #b110)))
2581
2582 ;;; Divide single, reverse:
2583 ;;;   st(0) = memory or st(i) / st(0).
2584 (define-instruction fdivr (segment source)
2585   (:printer floating-point ((op '(#b000 #b111))))
2586   (:emitter
2587     (emit-byte segment #b11011000)
2588     (emit-fp-op segment source #b111)))
2589
2590 ;;; Divide double:
2591 ;;;   st(0) = st(0) / memory or st(i).
2592 (define-instruction fdivd (segment source)
2593   (:printer floating-point ((op '(#b100 #b110))))
2594   (:printer floating-point-fp ((op '(#b000 #b110))))
2595   (:emitter
2596    (if (fp-reg-tn-p source)
2597        (emit-byte segment #b11011000)
2598      (emit-byte segment #b11011100))
2599    (emit-fp-op segment source #b110)))
2600
2601 ;;; Divide double, reverse:
2602 ;;;   st(0) = memory or st(i) / st(0).
2603 (define-instruction fdivrd (segment source)
2604   (:printer floating-point ((op '(#b100 #b111))))
2605   (:printer floating-point-fp ((op '(#b000 #b111))))
2606   (:emitter
2607    (if (fp-reg-tn-p source)
2608        (emit-byte segment #b11011000)
2609      (emit-byte segment #b11011100))
2610    (emit-fp-op segment source #b111)))
2611
2612 ;;; Divide double, destination st(i):
2613 ;;;   st(i) = st(i) / st(0).
2614 ;;;
2615 ;;; ASM386 syntax: FDIV ST(i), ST
2616 ;;; Gdb    syntax: fdivr %st,%st(i)
2617 (define-instruction fdiv-sti (segment destination)
2618   (:printer floating-point-fp ((op '(#b100 #b111))))
2619   (:emitter
2620    (aver (fp-reg-tn-p destination))
2621    (emit-byte segment #b11011100)
2622    (emit-fp-op segment destination #b111)))
2623
2624 ;;; Divide double, reverse, destination st(i):
2625 ;;;   st(i) = st(0) / st(i).
2626 ;;;
2627 ;;; ASM386 syntax: FDIVR ST(i), ST
2628 ;;; Gdb    syntax: fdiv %st,%st(i)
2629 (define-instruction fdivr-sti (segment destination)
2630   (:printer floating-point-fp ((op '(#b100 #b110))))
2631   (:emitter
2632    (aver (fp-reg-tn-p destination))
2633    (emit-byte segment #b11011100)
2634    (emit-fp-op segment destination #b110)))
2635
2636 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2637 (define-instruction fxch (segment source)
2638   (:printer floating-point-fp ((op '(#b001 #b001))))
2639   (:emitter
2640     (unless (and (tn-p source)
2641                  (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
2642       (cl:break))
2643     (emit-byte segment #b11011001)
2644     (emit-fp-op segment source #b001)))
2645
2646 ;;; Push 32-bit integer to st0.
2647 (define-instruction fild (segment source)
2648   (:printer floating-point ((op '(#b011 #b000))))
2649   (:emitter
2650    (emit-byte segment #b11011011)
2651    (emit-fp-op segment source #b000)))
2652
2653 ;;; Push 64-bit integer to st0.
2654 (define-instruction fildl (segment source)
2655   (:printer floating-point ((op '(#b111 #b101))))
2656   (:emitter
2657    (emit-byte segment #b11011111)
2658    (emit-fp-op segment source #b101)))
2659
2660 ;;; Store 32-bit integer.
2661 (define-instruction fist (segment dest)
2662   (:printer floating-point ((op '(#b011 #b010))))
2663   (:emitter
2664    (emit-byte segment #b11011011)
2665    (emit-fp-op segment dest #b010)))
2666
2667 ;;; Store and pop 32-bit integer.
2668 (define-instruction fistp (segment dest)
2669   (:printer floating-point ((op '(#b011 #b011))))
2670   (:emitter
2671    (emit-byte segment #b11011011)
2672    (emit-fp-op segment dest #b011)))
2673
2674 ;;; Store and pop 64-bit integer.
2675 (define-instruction fistpl (segment dest)
2676   (:printer floating-point ((op '(#b111 #b111))))
2677   (:emitter
2678    (emit-byte segment #b11011111)
2679    (emit-fp-op segment dest #b111)))
2680
2681 ;;; Store single from st(0) and pop.
2682 (define-instruction fstp (segment dest)
2683   (:printer floating-point ((op '(#b001 #b011))))
2684   (:emitter
2685    (cond ((fp-reg-tn-p dest)
2686           (emit-byte segment #b11011101)
2687           (emit-fp-op segment dest #b011))
2688          (t
2689           (emit-byte segment #b11011001)
2690           (emit-fp-op segment dest #b011)))))
2691
2692 ;;; Store double from st(0) and pop.
2693 (define-instruction fstpd (segment dest)
2694   (:printer floating-point ((op '(#b101 #b011))))
2695   (:printer floating-point-fp ((op '(#b101 #b011))))
2696   (:emitter
2697    (cond ((fp-reg-tn-p dest)
2698           (emit-byte segment #b11011101)
2699           (emit-fp-op segment dest #b011))
2700          (t
2701           (emit-byte segment #b11011101)
2702           (emit-fp-op segment dest #b011)))))
2703
2704 ;;; Store long from st(0) and pop.
2705 (define-instruction fstpl (segment dest)
2706   (:printer floating-point ((op '(#b011 #b111))))
2707   (:emitter
2708     (emit-byte segment #b11011011)
2709     (emit-fp-op segment dest #b111)))
2710
2711 ;;; Decrement stack-top pointer.
2712 (define-instruction fdecstp (segment)
2713   (:printer floating-point-no ((op #b10110)))
2714   (:emitter
2715    (emit-byte segment #b11011001)
2716    (emit-byte segment #b11110110)))
2717
2718 ;;; Increment stack-top pointer.
2719 (define-instruction fincstp (segment)
2720   (:printer floating-point-no ((op #b10111)))
2721   (:emitter
2722    (emit-byte segment #b11011001)
2723    (emit-byte segment #b11110111)))
2724
2725 ;;; Free fp register.
2726 (define-instruction ffree (segment dest)
2727   (:printer floating-point-fp ((op '(#b101 #b000))))
2728   (:emitter
2729    (emit-byte segment #b11011101)
2730    (emit-fp-op segment dest #b000)))
2731
2732 (define-instruction fabs (segment)
2733   (:printer floating-point-no ((op #b00001)))
2734   (:emitter
2735    (emit-byte segment #b11011001)
2736    (emit-byte segment #b11100001)))
2737
2738 (define-instruction fchs (segment)
2739   (:printer floating-point-no ((op #b00000)))
2740   (:emitter
2741    (emit-byte segment #b11011001)
2742    (emit-byte segment #b11100000)))
2743
2744 (define-instruction frndint(segment)
2745   (:printer floating-point-no ((op #b11100)))
2746   (:emitter
2747    (emit-byte segment #b11011001)
2748    (emit-byte segment #b11111100)))
2749
2750 ;;; Initialize NPX.
2751 (define-instruction fninit(segment)
2752   (:printer floating-point-5 ((op #b00011)))
2753   (:emitter
2754    (emit-byte segment #b11011011)
2755    (emit-byte segment #b11100011)))
2756
2757 ;;; Store Status Word to AX.
2758 (define-instruction fnstsw(segment)
2759   (:printer floating-point-st ((op #b00000)))
2760   (:emitter
2761    (emit-byte segment #b11011111)
2762    (emit-byte segment #b11100000)))
2763
2764 ;;; Load Control Word.
2765 ;;;
2766 ;;; src must be a memory location
2767 (define-instruction fldcw(segment src)
2768   (:printer floating-point ((op '(#b001 #b101))))
2769   (:emitter
2770    (emit-byte segment #b11011001)
2771    (emit-fp-op segment src #b101)))
2772
2773 ;;; Store Control Word.
2774 (define-instruction fnstcw(segment dst)
2775   (:printer floating-point ((op '(#b001 #b111))))
2776   (:emitter
2777    (emit-byte segment #b11011001)
2778    (emit-fp-op segment dst #b111)))
2779
2780 ;;; Store FP Environment.
2781 (define-instruction fstenv(segment dst)
2782   (:printer floating-point ((op '(#b001 #b110))))
2783   (:emitter
2784    (emit-byte segment #b11011001)
2785    (emit-fp-op segment dst #b110)))
2786
2787 ;;; Restore FP Environment.
2788 (define-instruction fldenv(segment src)
2789   (:printer floating-point ((op '(#b001 #b100))))
2790   (:emitter
2791    (emit-byte segment #b11011001)
2792    (emit-fp-op segment src #b100)))
2793
2794 ;;; Save FP State.
2795 (define-instruction fsave(segment dst)
2796   (:printer floating-point ((op '(#b101 #b110))))
2797   (:emitter
2798    (emit-byte segment #b11011101)
2799    (emit-fp-op segment dst #b110)))
2800
2801 ;;; Restore FP State.
2802 (define-instruction frstor(segment src)
2803   (:printer floating-point ((op '(#b101 #b100))))
2804   (:emitter
2805    (emit-byte segment #b11011101)
2806    (emit-fp-op segment src #b100)))
2807
2808 ;;; Clear exceptions.
2809 (define-instruction fnclex(segment)
2810   (:printer floating-point-5 ((op #b00010)))
2811   (:emitter
2812    (emit-byte segment #b11011011)
2813    (emit-byte segment #b11100010)))
2814
2815 ;;; comparison
2816 (define-instruction fcom (segment src)
2817   (:printer floating-point ((op '(#b000 #b010))))
2818   (:emitter
2819    (emit-byte segment #b11011000)
2820    (emit-fp-op segment src #b010)))
2821
2822 (define-instruction fcomd (segment src)
2823   (:printer floating-point ((op '(#b100 #b010))))
2824   (:printer floating-point-fp ((op '(#b000 #b010))))
2825   (:emitter
2826    (if (fp-reg-tn-p src)
2827        (emit-byte segment #b11011000)
2828      (emit-byte segment #b11011100))
2829    (emit-fp-op segment src #b010)))
2830
2831 ;;; Compare ST1 to ST0, popping the stack twice.
2832 (define-instruction fcompp (segment)
2833   (:printer floating-point-3 ((op '(#b110 #b011001))))
2834   (:emitter
2835    (emit-byte segment #b11011110)
2836    (emit-byte segment #b11011001)))
2837
2838 ;;; unordered comparison
2839 (define-instruction fucom (segment src)
2840   (:printer floating-point-fp ((op '(#b101 #b100))))
2841   (:emitter
2842    (aver (fp-reg-tn-p src))
2843    (emit-byte segment #b11011101)
2844    (emit-fp-op segment src #b100)))
2845
2846 (define-instruction ftst (segment)
2847   (:printer floating-point-no ((op #b00100)))
2848   (:emitter
2849    (emit-byte segment #b11011001)
2850    (emit-byte segment #b11100100)))
2851
2852 ;;;; 80387 specials
2853
2854 (define-instruction fsqrt(segment)
2855   (:printer floating-point-no ((op #b11010)))
2856   (:emitter
2857    (emit-byte segment #b11011001)
2858    (emit-byte segment #b11111010)))
2859
2860 (define-instruction fscale(segment)
2861   (:printer floating-point-no ((op #b11101)))
2862   (:emitter
2863    (emit-byte segment #b11011001)
2864    (emit-byte segment #b11111101)))
2865
2866 (define-instruction fxtract(segment)
2867   (:printer floating-point-no ((op #b10100)))
2868   (:emitter
2869    (emit-byte segment #b11011001)
2870    (emit-byte segment #b11110100)))
2871
2872 (define-instruction fsin(segment)
2873   (:printer floating-point-no ((op #b11110)))
2874   (:emitter
2875    (emit-byte segment #b11011001)
2876    (emit-byte segment #b11111110)))
2877
2878 (define-instruction fcos(segment)
2879   (:printer floating-point-no ((op #b11111)))
2880   (:emitter
2881    (emit-byte segment #b11011001)
2882    (emit-byte segment #b11111111)))
2883
2884 (define-instruction fprem1(segment)
2885   (:printer floating-point-no ((op #b10101)))
2886   (:emitter
2887    (emit-byte segment #b11011001)
2888    (emit-byte segment #b11110101)))
2889
2890 (define-instruction fprem(segment)
2891   (:printer floating-point-no ((op #b11000)))
2892   (:emitter
2893    (emit-byte segment #b11011001)
2894    (emit-byte segment #b11111000)))
2895
2896 (define-instruction fxam (segment)
2897   (:printer floating-point-no ((op #b00101)))
2898   (:emitter
2899    (emit-byte segment #b11011001)
2900    (emit-byte segment #b11100101)))
2901
2902 ;;; These do push/pop to stack and need special handling
2903 ;;; in any VOPs that use them. See the book.
2904
2905 ;;; st0 <- st1*log2(st0)
2906 (define-instruction fyl2x(segment)      ; pops stack
2907   (:printer floating-point-no ((op #b10001)))
2908   (:emitter
2909    (emit-byte segment #b11011001)
2910    (emit-byte segment #b11110001)))
2911
2912 (define-instruction fyl2xp1(segment)
2913   (:printer floating-point-no ((op #b11001)))
2914   (:emitter
2915    (emit-byte segment #b11011001)
2916    (emit-byte segment #b11111001)))
2917
2918 (define-instruction f2xm1(segment)
2919   (:printer floating-point-no ((op #b10000)))
2920   (:emitter
2921    (emit-byte segment #b11011001)
2922    (emit-byte segment #b11110000)))
2923
2924 (define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
2925   (:printer floating-point-no ((op #b10010)))
2926   (:emitter
2927    (emit-byte segment #b11011001)
2928    (emit-byte segment #b11110010)))
2929
2930 (define-instruction fpatan(segment)     ; POPS STACK
2931   (:printer floating-point-no ((op #b10011)))
2932   (:emitter
2933    (emit-byte segment #b11011001)
2934    (emit-byte segment #b11110011)))
2935
2936 ;;;; loading constants
2937
2938 (define-instruction fldz(segment)
2939   (:printer floating-point-no ((op #b01110)))
2940   (:emitter
2941    (emit-byte segment #b11011001)
2942    (emit-byte segment #b11101110)))
2943
2944 (define-instruction fld1(segment)
2945   (:printer floating-point-no ((op #b01000)))
2946   (:emitter
2947    (emit-byte segment #b11011001)
2948    (emit-byte segment #b11101000)))
2949
2950 (define-instruction fldpi(segment)
2951   (:printer floating-point-no ((op #b01011)))
2952   (:emitter
2953    (emit-byte segment #b11011001)
2954    (emit-byte segment #b11101011)))
2955
2956 (define-instruction fldl2t(segment)
2957   (:printer floating-point-no ((op #b01001)))
2958   (:emitter
2959    (emit-byte segment #b11011001)
2960    (emit-byte segment #b11101001)))
2961
2962 (define-instruction fldl2e(segment)
2963   (:printer floating-point-no ((op #b01010)))
2964   (:emitter
2965    (emit-byte segment #b11011001)
2966    (emit-byte segment #b11101010)))
2967
2968 (define-instruction fldlg2(segment)
2969   (:printer floating-point-no ((op #b01100)))
2970   (:emitter
2971    (emit-byte segment #b11011001)
2972    (emit-byte segment #b11101100)))
2973
2974 (define-instruction fldln2(segment)
2975   (:printer floating-point-no ((op #b01101)))
2976   (:emitter
2977    (emit-byte segment #b11011001)
2978    (emit-byte segment #b11101101)))
2979
2980 ;;;; Miscellany
2981
2982 (define-instruction cpuid (segment)
2983   (:printer two-bytes ((op '(#b00001111 #b10100010))))
2984   (:emitter
2985    (emit-byte segment #b00001111)
2986    (emit-byte segment #b10100010)))
2987
2988 (define-instruction rdtsc (segment)
2989   (:printer two-bytes ((op '(#b00001111 #b00110001))))
2990   (:emitter
2991    (emit-byte segment #b00001111)
2992    (emit-byte segment #b00110001)))