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