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