1 ;;;; that part of the description of the x86 instruction set (for
2 ;;;; 80386 and above) which can live on the cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
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.
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.
18 ;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
19 (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
21 (deftype reg () '(unsigned-byte 3))
23 (def!constant +default-operand-size+ :dword)
25 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
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))
32 (defparameter *default-address-size*
33 ;; Actually, :DWORD is the only one really supported.
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))
43 (defun print-reg-with-width (value width stream dstate)
44 (declare (ignore dstate))
45 (princ (aref (ecase width
46 (:byte *byte-reg-names*)
47 (:word *word-reg-names*)
48 (:dword *dword-reg-names*))
51 ;; XXX plus should do some source-var notes
54 (defun print-reg (value stream dstate)
55 (declare (type reg value)
57 (type sb!disassem:disassem-state dstate))
58 (print-reg-with-width value
59 (sb!disassem:dstate-get-prop dstate 'width)
63 (defun print-word-reg (value stream dstate)
64 (declare (type reg value)
66 (type sb!disassem:disassem-state dstate))
67 (print-reg-with-width value
68 (or (sb!disassem:dstate-get-prop dstate 'word-width)
69 +default-operand-size+)
73 (defun print-byte-reg (value stream dstate)
74 (declare (type reg value)
76 (type sb!disassem:disassem-state dstate))
77 (print-reg-with-width value :byte stream dstate))
79 (defun print-addr-reg (value stream dstate)
80 (declare (type reg value)
82 (type sb!disassem:disassem-state dstate))
83 (print-reg-with-width value *default-address-size* stream dstate))
85 (defun print-reg/mem (value stream dstate)
86 (declare (type (or list reg) value)
88 (type sb!disassem:disassem-state dstate))
89 (if (typep value 'reg)
90 (print-reg value stream dstate)
91 (print-mem-access value stream nil dstate)))
93 ;; Same as print-reg/mem, but prints an explicit size indicator for
95 (defun print-sized-reg/mem (value stream dstate)
96 (declare (type (or list reg) value)
98 (type sb!disassem:disassem-state dstate))
99 (if (typep value 'reg)
100 (print-reg value stream dstate)
101 (print-mem-access value stream t dstate)))
103 (defun print-byte-reg/mem (value stream dstate)
104 (declare (type (or list reg) value)
106 (type sb!disassem:disassem-state dstate))
107 (if (typep value 'reg)
108 (print-byte-reg value stream dstate)
109 (print-mem-access value stream t dstate)))
111 (defun print-word-reg/mem (value stream dstate)
112 (declare (type (or list reg) value)
114 (type sb!disassem:disassem-state dstate))
115 (if (typep value 'reg)
116 (print-word-reg value stream dstate)
117 (print-mem-access value stream nil dstate)))
119 (defun print-label (value stream dstate)
120 (declare (ignore dstate))
121 (sb!disassem:princ16 value stream))
123 ;;; Returns either an integer, meaning a register, or a list of
124 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
125 ;;; may be missing or nil to indicate that it's not used or has the
126 ;;; obvious default value (e.g., 1 for the index-scale).
127 (defun prefilter-reg/mem (value dstate)
128 (declare (type list value)
129 (type sb!disassem:disassem-state dstate))
130 (let ((mod (car value))
132 (declare (type (unsigned-byte 2) mod)
133 (type (unsigned-byte 3) r/m))
139 (let ((sib (sb!disassem:read-suffix 8 dstate)))
140 (declare (type (unsigned-byte 8) sib))
141 (let ((base-reg (ldb (byte 3 0) sib))
142 (index-reg (ldb (byte 3 3) sib))
143 (index-scale (ldb (byte 2 6) sib)))
144 (declare (type (unsigned-byte 3) base-reg index-reg)
145 (type (unsigned-byte 2) index-scale))
149 (if (= base-reg #b101)
150 (sb!disassem:read-signed-suffix 32 dstate)
153 (sb!disassem:read-signed-suffix 8 dstate))
155 (sb!disassem:read-signed-suffix 32 dstate)))))
156 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
158 (if (= index-reg #b100) nil index-reg)
159 (ash 1 index-scale))))))
160 ((and (= mod #b00) (= r/m #b101))
161 (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
165 (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
167 (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
170 ;;; This is a sort of bogus prefilter that just stores the info globally for
171 ;;; other people to use; it probably never gets printed.
172 (defun prefilter-width (value dstate)
173 (setf (sb!disassem:dstate-get-prop dstate 'width)
177 ;; set by a prefix instruction
178 (or (sb!disassem:dstate-get-prop dstate 'word-width)
179 +default-operand-size+)))
180 (when (not (eql word-width +default-operand-size+))
182 (setf (sb!disassem:dstate-get-prop dstate 'word-width)
183 +default-operand-size+))
186 (defun read-address (value dstate)
187 (declare (ignore value)) ; always nil anyway
188 (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
190 (defun width-bits (width)
200 ;;;; disassembler argument types
202 (sb!disassem:define-arg-type displacement
204 :use-label #'offset-next
205 :printer (lambda (value stream dstate)
206 (sb!disassem:maybe-note-assembler-routine value nil dstate)
207 (print-label value stream dstate)))
209 (sb!disassem:define-arg-type accum
210 :printer (lambda (value stream dstate)
211 (declare (ignore value)
213 (type sb!disassem:disassem-state dstate))
214 (print-reg 0 stream dstate)))
216 (sb!disassem:define-arg-type word-accum
217 :printer (lambda (value stream dstate)
218 (declare (ignore value)
220 (type sb!disassem:disassem-state dstate))
221 (print-word-reg 0 stream dstate)))
223 (sb!disassem:define-arg-type reg
224 :printer #'print-reg)
226 (sb!disassem:define-arg-type addr-reg
227 :printer #'print-addr-reg)
229 (sb!disassem:define-arg-type word-reg
230 :printer #'print-word-reg)
232 (sb!disassem:define-arg-type imm-addr
233 :prefilter #'read-address
234 :printer #'print-label)
236 (sb!disassem:define-arg-type imm-data
237 :prefilter (lambda (value dstate)
238 (declare (ignore value)) ; always nil anyway
239 (sb!disassem:read-suffix
240 (width-bits (sb!disassem:dstate-get-prop dstate 'width))
243 (sb!disassem:define-arg-type signed-imm-data
244 :prefilter (lambda (value dstate)
245 (declare (ignore value)) ; always nil anyway
246 (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
247 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
249 (sb!disassem:define-arg-type signed-imm-byte
250 :prefilter (lambda (value dstate)
251 (declare (ignore value)) ; always nil anyway
252 (sb!disassem:read-signed-suffix 8 dstate)))
254 (sb!disassem:define-arg-type signed-imm-dword
255 :prefilter (lambda (value dstate)
256 (declare (ignore value)) ; always nil anyway
257 (sb!disassem:read-signed-suffix 32 dstate)))
259 (sb!disassem:define-arg-type imm-word
260 :prefilter (lambda (value dstate)
261 (declare (ignore value)) ; always nil anyway
263 (or (sb!disassem:dstate-get-prop dstate 'word-width)
264 +default-operand-size+)))
265 (sb!disassem:read-suffix (width-bits width) dstate))))
267 (sb!disassem:define-arg-type signed-imm-word
268 :prefilter (lambda (value dstate)
269 (declare (ignore value)) ; always nil anyway
271 (or (sb!disassem:dstate-get-prop dstate 'word-width)
272 +default-operand-size+)))
273 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
275 ;;; needed for the ret imm16 instruction
276 (sb!disassem:define-arg-type imm-word-16
277 :prefilter (lambda (value dstate)
278 (declare (ignore value)) ; always nil anyway
279 (sb!disassem:read-suffix 16 dstate)))
281 (sb!disassem:define-arg-type reg/mem
282 :prefilter #'prefilter-reg/mem
283 :printer #'print-reg/mem)
284 (sb!disassem:define-arg-type sized-reg/mem
285 ;; Same as reg/mem, but prints an explicit size indicator for
286 ;; memory references.
287 :prefilter #'prefilter-reg/mem
288 :printer #'print-sized-reg/mem)
289 (sb!disassem:define-arg-type byte-reg/mem
290 :prefilter #'prefilter-reg/mem
291 :printer #'print-byte-reg/mem)
292 (sb!disassem:define-arg-type word-reg/mem
293 :prefilter #'prefilter-reg/mem
294 :printer #'print-word-reg/mem)
297 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
298 (defun print-fp-reg (value stream dstate)
299 (declare (ignore dstate))
300 (format stream "FR~D" value))
301 (defun prefilter-fp-reg (value dstate)
303 (declare (ignore dstate))
306 (sb!disassem:define-arg-type fp-reg
307 :prefilter #'prefilter-fp-reg
308 :printer #'print-fp-reg)
310 (sb!disassem:define-arg-type width
311 :prefilter #'prefilter-width
312 :printer (lambda (value stream dstate)
315 (and (numberp value) (zerop value))) ; zzz jrd
318 ;; set by a prefix instruction
319 (or (sb!disassem:dstate-get-prop dstate 'word-width)
320 +default-operand-size+)))
321 (princ (schar (symbol-name word-width) 0) stream)))))
323 (eval-when (:compile-toplevel :load-toplevel :execute)
324 (defparameter *conditions*
327 (:b . 2) (:nae . 2) (:c . 2)
328 (:nb . 3) (:ae . 3) (:nc . 3)
329 (:eq . 4) (:e . 4) (:z . 4)
336 (:np . 11) (:po . 11)
337 (:l . 12) (:nge . 12)
338 (:nl . 13) (:ge . 13)
339 (:le . 14) (:ng . 14)
340 (:nle . 15) (:g . 15)))
341 (defparameter *condition-name-vec*
342 (let ((vec (make-array 16 :initial-element nil)))
343 (dolist (cond *conditions*)
344 (when (null (aref vec (cdr cond)))
345 (setf (aref vec (cdr cond)) (car cond))))
349 ;;; Set assembler parameters. (In CMU CL, this was done with
350 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
351 (eval-when (:compile-toplevel :load-toplevel :execute)
352 (setf sb!assem:*assem-scheduler-p* nil))
354 (sb!disassem:define-arg-type condition-code
355 :printer *condition-name-vec*)
357 (defun conditional-opcode (condition)
358 (cdr (assoc condition *conditions* :test #'eq)))
360 ;;;; disassembler instruction formats
362 (eval-when (:compile-toplevel :execute)
363 (defun swap-if (direction field1 separator field2)
364 `(:if (,direction :constant 0)
365 (,field1 ,separator ,field2)
366 (,field2 ,separator ,field1))))
368 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
369 (op :field (byte 8 0))
374 (sb!disassem:define-instruction-format (simple 8)
375 (op :field (byte 7 1))
376 (width :field (byte 1 0) :type 'width)
381 (sb!disassem:define-instruction-format (two-bytes 16
382 :default-printer '(:name))
383 (op :fields (list (byte 8 0) (byte 8 8))))
385 ;;; Same as simple, but with direction bit
386 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
387 (op :field (byte 6 2))
388 (dir :field (byte 1 1)))
390 ;;; Same as simple, but with the immediate value occurring by default,
391 ;;; and with an appropiate printer.
392 (sb!disassem:define-instruction-format (accum-imm 8
394 :default-printer '(:name
395 :tab accum ", " imm))
396 (imm :type 'imm-data))
398 (sb!disassem:define-instruction-format (reg-no-width 8
399 :default-printer '(:name :tab reg))
400 (op :field (byte 5 3))
401 (reg :field (byte 3 0) :type 'word-reg)
403 (accum :type 'word-accum)
406 ;;; adds a width field to reg-no-width
407 (sb!disassem:define-instruction-format (reg 8
408 :default-printer '(:name :tab reg))
409 (op :field (byte 4 4))
410 (width :field (byte 1 3) :type 'width)
411 (reg :field (byte 3 0) :type 'reg)
417 ;;; Same as reg, but with direction bit
418 (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
419 (op :field (byte 3 5))
420 (dir :field (byte 1 4)))
422 (sb!disassem:define-instruction-format (two-bytes 16
423 :default-printer '(:name))
424 (op :fields (list (byte 8 0) (byte 8 8))))
426 (sb!disassem:define-instruction-format (reg-reg/mem 16
428 `(:name :tab reg ", " reg/mem))
429 (op :field (byte 7 1))
430 (width :field (byte 1 0) :type 'width)
431 (reg/mem :fields (list (byte 2 14) (byte 3 8))
433 (reg :field (byte 3 11) :type 'reg)
437 ;;; same as reg-reg/mem, but with direction bit
438 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
439 :include 'reg-reg/mem
443 ,(swap-if 'dir 'reg/mem ", " 'reg)))
444 (op :field (byte 6 2))
445 (dir :field (byte 1 1)))
447 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
448 (sb!disassem:define-instruction-format (reg/mem 16
449 :default-printer '(:name :tab reg/mem))
450 (op :fields (list (byte 7 1) (byte 3 11)))
451 (width :field (byte 1 0) :type 'width)
452 (reg/mem :fields (list (byte 2 14) (byte 3 8))
453 :type 'sized-reg/mem)
457 ;;; Same as reg/mem, but with the immediate value occurring by default,
458 ;;; and with an appropiate printer.
459 (sb!disassem:define-instruction-format (reg/mem-imm 16
462 '(:name :tab reg/mem ", " imm))
463 (reg/mem :type 'sized-reg/mem)
464 (imm :type 'imm-data))
466 ;;; Same as reg/mem, but with using the accumulator in the default printer
467 (sb!disassem:define-instruction-format
469 :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
470 (reg/mem :type 'reg/mem) ; don't need a size
471 (accum :type 'accum))
473 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
474 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
476 `(:name :tab reg ", " reg/mem))
477 (prefix :field (byte 8 0) :value #b00001111)
478 (op :field (byte 7 9))
479 (width :field (byte 1 8) :type 'width)
480 (reg/mem :fields (list (byte 2 22) (byte 3 16))
482 (reg :field (byte 3 19) :type 'reg)
486 ;;; Same as reg/mem, but with a prefix of #b00001111
487 (sb!disassem:define-instruction-format (ext-reg/mem 24
488 :default-printer '(:name :tab reg/mem))
489 (prefix :field (byte 8 0) :value #b00001111)
490 (op :fields (list (byte 7 9) (byte 3 19)))
491 (width :field (byte 1 8) :type 'width)
492 (reg/mem :fields (list (byte 2 22) (byte 3 16))
493 :type 'sized-reg/mem)
497 (sb!disassem:define-instruction-format (ext-reg/mem-imm 24
498 :include 'ext-reg/mem
500 '(:name :tab reg/mem ", " imm))
501 (imm :type 'imm-data))
503 ;;;; This section was added by jrd, for fp instructions.
505 ;;; regular fp inst to/from registers/memory
506 (sb!disassem:define-instruction-format (floating-point 16
508 `(:name :tab reg/mem))
509 (prefix :field (byte 5 3) :value #b11011)
510 (op :fields (list (byte 3 0) (byte 3 11)))
511 (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
513 ;;; fp insn to/from fp reg
514 (sb!disassem:define-instruction-format (floating-point-fp 16
515 :default-printer `(:name :tab fp-reg))
516 (prefix :field (byte 5 3) :value #b11011)
517 (suffix :field (byte 2 14) :value #b11)
518 (op :fields (list (byte 3 0) (byte 3 11)))
519 (fp-reg :field (byte 3 8) :type 'fp-reg))
521 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
522 (sb!disassem:define-instruction-format
523 (floating-point-fp-d 16
524 :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
525 (prefix :field (byte 5 3) :value #b11011)
526 (suffix :field (byte 2 14) :value #b11)
527 (op :fields (list (byte 2 0) (byte 3 11)))
528 (d :field (byte 1 2))
529 (fp-reg :field (byte 3 8) :type 'fp-reg))
532 ;;; (added by (?) pfw)
533 ;;; fp no operand isns
534 (sb!disassem:define-instruction-format (floating-point-no 16
535 :default-printer '(:name))
536 (prefix :field (byte 8 0) :value #b11011001)
537 (suffix :field (byte 3 13) :value #b111)
538 (op :field (byte 5 8)))
540 (sb!disassem:define-instruction-format (floating-point-3 16
541 :default-printer '(:name))
542 (prefix :field (byte 5 3) :value #b11011)
543 (suffix :field (byte 2 14) :value #b11)
544 (op :fields (list (byte 3 0) (byte 6 8))))
546 (sb!disassem:define-instruction-format (floating-point-5 16
547 :default-printer '(:name))
548 (prefix :field (byte 8 0) :value #b11011011)
549 (suffix :field (byte 3 13) :value #b111)
550 (op :field (byte 5 8)))
552 (sb!disassem:define-instruction-format (floating-point-st 16
553 :default-printer '(:name))
554 (prefix :field (byte 8 0) :value #b11011111)
555 (suffix :field (byte 3 13) :value #b111)
556 (op :field (byte 5 8)))
558 (sb!disassem:define-instruction-format (string-op 8
560 :default-printer '(:name width)))
562 (sb!disassem:define-instruction-format (short-cond-jump 16)
563 (op :field (byte 4 4))
564 (cc :field (byte 4 0) :type 'condition-code)
565 (label :field (byte 8 8) :type 'displacement))
567 (sb!disassem:define-instruction-format (short-jump 16
568 :default-printer '(:name :tab label))
569 (const :field (byte 4 4) :value #b1110)
570 (op :field (byte 4 0))
571 (label :field (byte 8 8) :type 'displacement))
573 (sb!disassem:define-instruction-format (near-cond-jump 16)
574 (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
575 (cc :field (byte 4 8) :type 'condition-code)
576 ;; The disassembler currently doesn't let you have an instruction > 32 bits
577 ;; long, so we fake it by using a prefilter to read the offset.
578 (label :type 'displacement
579 :prefilter (lambda (value dstate)
580 (declare (ignore value)) ; always nil anyway
581 (sb!disassem:read-signed-suffix 32 dstate))))
583 (sb!disassem:define-instruction-format (near-jump 8
584 :default-printer '(:name :tab label))
585 (op :field (byte 8 0))
586 ;; The disassembler currently doesn't let you have an instruction > 32 bits
587 ;; long, so we fake it by using a prefilter to read the address.
588 (label :type 'displacement
589 :prefilter (lambda (value dstate)
590 (declare (ignore value)) ; always nil anyway
591 (sb!disassem:read-signed-suffix 32 dstate))))
594 (sb!disassem:define-instruction-format (cond-set 24
595 :default-printer '('set cc :tab reg/mem))
596 (prefix :field (byte 8 0) :value #b00001111)
597 (op :field (byte 4 12) :value #b1001)
598 (cc :field (byte 4 8) :type 'condition-code)
599 (reg/mem :fields (list (byte 2 22) (byte 3 16))
601 (reg :field (byte 3 19) :value #b000))
603 (sb!disassem:define-instruction-format (cond-move 24
605 '('cmov cc :tab reg ", " reg/mem))
606 (prefix :field (byte 8 0) :value #b00001111)
607 (op :field (byte 4 12) :value #b0100)
608 (cc :field (byte 4 8) :type 'condition-code)
609 (reg/mem :fields (list (byte 2 22) (byte 3 16))
611 (reg :field (byte 3 19) :type 'reg))
613 (sb!disassem:define-instruction-format (enter-format 32
614 :default-printer '(:name
616 (:unless (:constant 0)
618 (op :field (byte 8 0))
619 (disp :field (byte 16 8))
620 (level :field (byte 8 24)))
622 (sb!disassem:define-instruction-format (prefetch 24
624 '(:name ", " reg/mem))
625 (prefix :field (byte 8 0) :value #b00001111)
626 (op :field (byte 8 8) :value #b00011000)
627 (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem)
628 (reg :field (byte 3 19) :type 'reg))
630 ;;; Single byte instruction with an immediate byte argument.
631 (sb!disassem:define-instruction-format (byte-imm 16
632 :default-printer '(:name :tab code))
633 (op :field (byte 8 0))
634 (code :field (byte 8 8)))
636 ;;; Two byte instruction with an immediate byte argument.
638 (sb!disassem:define-instruction-format (word-imm 24
639 :default-printer '(:name :tab code))
640 (op :field (byte 16 0))
641 (code :field (byte 8 16)))
644 ;;;; primitive emitters
646 (define-bitfield-emitter emit-word 16
649 (define-bitfield-emitter emit-dword 32
652 (define-bitfield-emitter emit-byte-with-reg 8
653 (byte 5 3) (byte 3 0))
655 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
656 (byte 2 6) (byte 3 3) (byte 3 0))
658 (define-bitfield-emitter emit-sib-byte 8
659 (byte 2 6) (byte 3 3) (byte 3 0))
663 (defun emit-absolute-fixup (segment fixup)
664 (note-fixup segment :absolute fixup)
665 (let ((offset (fixup-offset fixup)))
667 (emit-back-patch segment
668 4 ; FIXME: n-word-bytes
669 (lambda (segment posn)
670 (declare (ignore posn))
672 (- (+ (component-header-length)
673 (or (label-position offset)
675 other-pointer-lowtag))))
676 (emit-dword segment (or offset 0)))))
678 (defun emit-relative-fixup (segment fixup)
679 (note-fixup segment :relative fixup)
680 (emit-dword segment (or (fixup-offset fixup) 0)))
682 ;;;; the effective-address (ea) structure
684 (defun reg-tn-encoding (tn)
685 (declare (type tn tn))
686 (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
687 (let ((offset (tn-offset tn)))
688 (logior (ash (logand offset 1) 2)
691 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
693 (size nil :type (member :byte :word :dword))
694 (base nil :type (or tn null))
695 (index nil :type (or tn null))
696 (scale 1 :type (member 1 2 4 8))
697 (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
698 (def!method print-object ((ea ea) stream)
699 (cond ((or *print-escape* *print-readably*)
700 (print-unreadable-object (ea stream :type t)
702 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
706 (let ((scale (ea-scale ea)))
707 (if (= scale 1) nil scale))
710 (format stream "~A PTR [" (symbol-name (ea-size ea)))
712 (write-string (sb!c::location-print-name (ea-base ea)) stream)
714 (write-string "+" stream)))
716 (write-string (sb!c::location-print-name (ea-index ea)) stream))
717 (unless (= (ea-scale ea) 1)
718 (format stream "*~A" (ea-scale ea)))
719 (typecase (ea-disp ea)
722 (format stream "~@D" (ea-disp ea)))
724 (format stream "+~A" (ea-disp ea))))
725 (write-char #\] stream))))
727 (defun emit-ea (segment thing reg &optional allow-constants)
730 (ecase (sb-name (sc-sb (tn-sc thing)))
732 (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
734 ;; Convert stack tns into an index off of EBP.
735 (let ((disp (frame-byte-offset (tn-offset thing))))
736 (cond ((<= -128 disp 127)
737 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
738 (emit-byte segment disp))
740 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
741 (emit-dword segment disp)))))
743 (unless allow-constants
745 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
746 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
747 (emit-absolute-fixup segment
750 (- (* (tn-offset thing) n-word-bytes)
751 other-pointer-lowtag))))))
753 (let* ((base (ea-base thing))
754 (index (ea-index thing))
755 (scale (ea-scale thing))
756 (disp (ea-disp thing))
757 (mod (cond ((or (null base)
759 (not (= (reg-tn-encoding base) #b101))))
761 ((and (fixnump disp) (<= -128 disp 127))
765 (r/m (cond (index #b100)
767 (t (reg-tn-encoding base)))))
768 (emit-mod-reg-r/m-byte segment mod reg r/m)
770 (let ((ss (1- (integer-length scale)))
771 (index (if (null index)
773 (let ((index (reg-tn-encoding index)))
775 (error "can't index off of ESP")
777 (base (if (null base)
779 (reg-tn-encoding base))))
780 (emit-sib-byte segment ss index base)))
782 (emit-byte segment disp))
783 ((or (= mod #b10) (null base))
785 (emit-absolute-fixup segment disp)
786 (emit-dword segment disp))))))
788 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
789 (emit-absolute-fixup segment thing))))
791 (defun fp-reg-tn-p (thing)
793 (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
795 ;;; like the above, but for fp-instructions--jrd
796 (defun emit-fp-op (segment thing op)
797 (if (fp-reg-tn-p thing)
798 (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
801 (emit-ea segment thing op)))
803 (defun byte-reg-p (thing)
805 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
806 (member (sc-name (tn-sc thing)) *byte-sc-names*)
809 (defun byte-ea-p (thing)
811 (ea (eq (ea-size thing) :byte))
813 (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
816 (defun word-reg-p (thing)
818 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
819 (member (sc-name (tn-sc thing)) *word-sc-names*)
822 (defun word-ea-p (thing)
824 (ea (eq (ea-size thing) :word))
825 (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
828 (defun dword-reg-p (thing)
830 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
831 (member (sc-name (tn-sc thing)) *dword-sc-names*)
834 (defun dword-ea-p (thing)
836 (ea (eq (ea-size thing) :dword))
838 (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
841 (defun register-p (thing)
843 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
845 (defun accumulator-p (thing)
846 (and (register-p thing)
847 (= (tn-offset thing) 0)))
851 (def!constant +operand-size-prefix-byte+ #b01100110)
853 (defun maybe-emit-operand-size-prefix (segment size)
854 (unless (or (eq size :byte) (eq size +default-operand-size+))
855 (emit-byte segment +operand-size-prefix-byte+)))
857 (defun operand-size (thing)
860 ;; FIXME: might as well be COND instead of having to use #. readmacro
861 ;; to hack up the code
862 (case (sc-name (tn-sc thing))
869 ;; added by jrd: float-registers is a separate size (?)
875 (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
881 (defun matching-operand-size (dst src)
882 (let ((dst-size (operand-size dst))
883 (src-size (operand-size src)))
886 (if (eq dst-size src-size)
888 (error "size mismatch: ~S is a ~S and ~S is a ~S."
889 dst dst-size src src-size))
893 (error "can't tell the size of either ~S or ~S" dst src)))))
895 (defun emit-sized-immediate (segment size value)
898 (emit-byte segment value))
900 (emit-word segment value))
902 (emit-dword segment value))))
904 (defun toggle-word-width (chunk inst stream dstate)
905 (declare (ignore chunk inst stream))
906 (let ((word-width (or (sb!disassem:dstate-get-prop dstate 'word-width)
907 +default-operand-size+)))
908 (setf (sb!disassem:dstate-get-prop dstate 'word-width)
913 ;;; This is a "prefix" instruction, which means that it modifies the
914 ;;; following instruction in some way without having an actual
915 ;;; mnemonic of its own.
916 (define-instruction operand-size-prefix (segment)
917 (:printer byte ((op +operand-size-prefix-byte+))
918 nil ; don't actually print it
919 :control #'toggle-word-width))
921 ;;;; general data transfer
923 (define-instruction mov (segment dst src)
924 ;; immediate to register
925 (:printer reg ((op #b1011) (imm nil :type 'imm-data))
926 '(:name :tab reg ", " imm))
927 ;; absolute mem to/from accumulator
928 (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
929 `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
930 ;; register to/from register/memory
931 (:printer reg-reg/mem-dir ((op #b100010)))
932 ;; immediate to register/memory
933 (:printer reg/mem-imm ((op '(#b1100011 #b000))))
936 (let ((size (matching-operand-size dst src)))
937 (maybe-emit-operand-size-prefix segment size)
938 (cond ((register-p dst)
939 (cond ((integerp src)
940 (emit-byte-with-reg segment
944 (reg-tn-encoding dst))
945 (emit-sized-immediate segment size src))
946 ((and (fixup-p src) (accumulator-p dst))
951 (emit-absolute-fixup segment src))
957 (emit-ea segment src (reg-tn-encoding dst) t))))
958 ((and (fixup-p dst) (accumulator-p src))
959 (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
960 (emit-absolute-fixup segment dst))
962 (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
963 (emit-ea segment dst #b000)
964 (emit-sized-immediate segment size src))
966 (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
967 (emit-ea segment dst (reg-tn-encoding src)))
969 (aver (eq size :dword))
970 (emit-byte segment #b11000111)
971 (emit-ea segment dst #b000)
972 (emit-absolute-fixup segment src))
974 (error "bogus arguments to MOV: ~S ~S" dst src))))))
976 (defun emit-move-with-extension (segment dst src opcode)
977 (aver (register-p dst))
978 (let ((dst-size (operand-size dst))
979 (src-size (operand-size src)))
982 (aver (eq src-size :byte))
983 (maybe-emit-operand-size-prefix segment :word)
984 (emit-byte segment #b00001111)
985 (emit-byte segment opcode)
986 (emit-ea segment src (reg-tn-encoding dst)))
990 (maybe-emit-operand-size-prefix segment :dword)
991 (emit-byte segment #b00001111)
992 (emit-byte segment opcode)
993 (emit-ea segment src (reg-tn-encoding dst)))
995 (emit-byte segment #b00001111)
996 (emit-byte segment (logior opcode 1))
997 (emit-ea segment src (reg-tn-encoding dst))))))))
999 (define-instruction movsx (segment dst src)
1000 (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
1001 (:emitter (emit-move-with-extension segment dst src #b10111110)))
1003 (define-instruction movzx (segment dst src)
1004 (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
1005 (:emitter (emit-move-with-extension segment dst src #b10110110)))
1007 (define-instruction push (segment src)
1009 (:printer reg-no-width ((op #b01010)))
1011 (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
1013 (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
1015 (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
1017 ;; ### segment registers?
1020 (cond ((integerp src)
1021 (cond ((<= -128 src 127)
1022 (emit-byte segment #b01101010)
1023 (emit-byte segment src))
1025 (emit-byte segment #b01101000)
1026 (emit-dword segment src))))
1028 ;; Interpret the fixup as an immediate dword to push.
1029 (emit-byte segment #b01101000)
1030 (emit-absolute-fixup segment src))
1032 (let ((size (operand-size src)))
1033 (aver (not (eq size :byte)))
1034 (maybe-emit-operand-size-prefix segment size)
1035 (cond ((register-p src)
1036 (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
1038 (emit-byte segment #b11111111)
1039 (emit-ea segment src #b110 t))))))))
1041 (define-instruction pusha (segment)
1042 (:printer byte ((op #b01100000)))
1044 (emit-byte segment #b01100000)))
1046 (define-instruction pop (segment dst)
1047 (:printer reg-no-width ((op #b01011)))
1048 (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
1050 (let ((size (operand-size dst)))
1051 (aver (not (eq size :byte)))
1052 (maybe-emit-operand-size-prefix segment size)
1053 (cond ((register-p dst)
1054 (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
1056 (emit-byte segment #b10001111)
1057 (emit-ea segment dst #b000))))))
1059 (define-instruction popa (segment)
1060 (:printer byte ((op #b01100001)))
1062 (emit-byte segment #b01100001)))
1064 (define-instruction xchg (segment operand1 operand2)
1065 ;; Register with accumulator.
1066 (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1067 ;; Register/Memory with Register.
1068 (:printer reg-reg/mem ((op #b1000011)))
1070 (let ((size (matching-operand-size operand1 operand2)))
1071 (maybe-emit-operand-size-prefix segment size)
1072 (labels ((xchg-acc-with-something (acc something)
1073 (if (and (not (eq size :byte)) (register-p something))
1074 (emit-byte-with-reg segment
1076 (reg-tn-encoding something))
1077 (xchg-reg-with-something acc something)))
1078 (xchg-reg-with-something (reg something)
1079 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1080 (emit-ea segment something (reg-tn-encoding reg))))
1081 (cond ((accumulator-p operand1)
1082 (xchg-acc-with-something operand1 operand2))
1083 ((accumulator-p operand2)
1084 (xchg-acc-with-something operand2 operand1))
1085 ((register-p operand1)
1086 (xchg-reg-with-something operand1 operand2))
1087 ((register-p operand2)
1088 (xchg-reg-with-something operand2 operand1))
1090 (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1092 (define-instruction lea (segment dst src)
1093 (:printer reg-reg/mem ((op #b1000110) (width 1)))
1095 (aver (dword-reg-p dst))
1096 (emit-byte segment #b10001101)
1097 (emit-ea segment src (reg-tn-encoding dst))))
1099 (define-instruction cmpxchg (segment dst src)
1100 ;; Register/Memory with Register.
1101 (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1103 (aver (register-p src))
1104 (let ((size (matching-operand-size src dst)))
1105 (maybe-emit-operand-size-prefix segment size)
1106 (emit-byte segment #b00001111)
1107 (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1108 (emit-ea segment dst (reg-tn-encoding src)))))
1112 (define-instruction fs-segment-prefix (segment)
1113 (:printer byte ((op #b01100100)))
1115 (emit-byte segment #x64)))
1117 (define-instruction gs-segment-prefix (segment)
1118 (:printer byte ((op #b01100101)))
1120 (emit-byte segment #x65)))
1122 ;;;; flag control instructions
1124 ;;; CLC -- Clear Carry Flag.
1125 (define-instruction clc (segment)
1126 (:printer byte ((op #b11111000)))
1128 (emit-byte segment #b11111000)))
1130 ;;; CLD -- Clear Direction Flag.
1131 (define-instruction cld (segment)
1132 (:printer byte ((op #b11111100)))
1134 (emit-byte segment #b11111100)))
1136 ;;; CLI -- Clear Iterrupt Enable Flag.
1137 (define-instruction cli (segment)
1138 (:printer byte ((op #b11111010)))
1140 (emit-byte segment #b11111010)))
1142 ;;; CMC -- Complement Carry Flag.
1143 (define-instruction cmc (segment)
1144 (:printer byte ((op #b11110101)))
1146 (emit-byte segment #b11110101)))
1148 ;;; LAHF -- Load AH into flags.
1149 (define-instruction lahf (segment)
1150 (:printer byte ((op #b10011111)))
1152 (emit-byte segment #b10011111)))
1154 ;;; POPF -- Pop flags.
1155 (define-instruction popf (segment)
1156 (:printer byte ((op #b10011101)))
1158 (emit-byte segment #b10011101)))
1160 ;;; PUSHF -- push flags.
1161 (define-instruction pushf (segment)
1162 (:printer byte ((op #b10011100)))
1164 (emit-byte segment #b10011100)))
1166 ;;; SAHF -- Store AH into flags.
1167 (define-instruction sahf (segment)
1168 (:printer byte ((op #b10011110)))
1170 (emit-byte segment #b10011110)))
1172 ;;; STC -- Set Carry Flag.
1173 (define-instruction stc (segment)
1174 (:printer byte ((op #b11111001)))
1176 (emit-byte segment #b11111001)))
1178 ;;; STD -- Set Direction Flag.
1179 (define-instruction std (segment)
1180 (:printer byte ((op #b11111101)))
1182 (emit-byte segment #b11111101)))
1184 ;;; STI -- Set Interrupt Enable Flag.
1185 (define-instruction sti (segment)
1186 (:printer byte ((op #b11111011)))
1188 (emit-byte segment #b11111011)))
1192 (defun emit-random-arith-inst (name segment dst src opcode
1193 &optional allow-constants)
1194 (let ((size (matching-operand-size dst src)))
1195 (maybe-emit-operand-size-prefix segment size)
1198 (cond ((and (not (eq size :byte)) (<= -128 src 127))
1199 (emit-byte segment #b10000011)
1200 (emit-ea segment dst opcode allow-constants)
1201 (emit-byte segment src))
1202 ((accumulator-p dst)
1209 (emit-sized-immediate segment size src))
1211 (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1212 (emit-ea segment dst opcode allow-constants)
1213 (emit-sized-immediate segment size src))))
1218 (if (eq size :byte) #b00000000 #b00000001)))
1219 (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1224 (if (eq size :byte) #b00000010 #b00000011)))
1225 (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1227 (error "bogus operands to ~A" name)))))
1229 (eval-when (:compile-toplevel :execute)
1230 (defun arith-inst-printer-list (subop)
1231 `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1232 (reg/mem-imm ((op (#b1000000 ,subop))))
1233 (reg/mem-imm ((op (#b1000001 ,subop))
1234 (imm nil :type signed-imm-byte)))
1235 (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1238 (define-instruction add (segment dst src)
1239 (:printer-list (arith-inst-printer-list #b000))
1240 (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
1242 (define-instruction adc (segment dst src)
1243 (:printer-list (arith-inst-printer-list #b010))
1244 (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1246 (define-instruction sub (segment dst src)
1247 (:printer-list (arith-inst-printer-list #b101))
1248 (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
1250 (define-instruction sbb (segment dst src)
1251 (:printer-list (arith-inst-printer-list #b011))
1252 (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1254 (define-instruction cmp (segment dst src)
1255 (:printer-list (arith-inst-printer-list #b111))
1256 (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1258 (define-instruction inc (segment dst)
1260 (:printer reg-no-width ((op #b01000)))
1262 (:printer reg/mem ((op '(#b1111111 #b000))))
1264 (let ((size (operand-size dst)))
1265 (maybe-emit-operand-size-prefix segment size)
1266 (cond ((and (not (eq size :byte)) (register-p dst))
1267 (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1269 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1270 (emit-ea segment dst #b000))))))
1272 (define-instruction dec (segment dst)
1274 (:printer reg-no-width ((op #b01001)))
1276 (:printer reg/mem ((op '(#b1111111 #b001))))
1278 (let ((size (operand-size dst)))
1279 (maybe-emit-operand-size-prefix segment size)
1280 (cond ((and (not (eq size :byte)) (register-p dst))
1281 (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1283 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1284 (emit-ea segment dst #b001))))))
1286 (define-instruction neg (segment dst)
1287 (:printer reg/mem ((op '(#b1111011 #b011))))
1289 (let ((size (operand-size dst)))
1290 (maybe-emit-operand-size-prefix segment size)
1291 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1292 (emit-ea segment dst #b011))))
1294 (define-instruction aaa (segment)
1295 (:printer byte ((op #b00110111)))
1297 (emit-byte segment #b00110111)))
1299 (define-instruction aas (segment)
1300 (:printer byte ((op #b00111111)))
1302 (emit-byte segment #b00111111)))
1304 (define-instruction daa (segment)
1305 (:printer byte ((op #b00100111)))
1307 (emit-byte segment #b00100111)))
1309 (define-instruction das (segment)
1310 (:printer byte ((op #b00101111)))
1312 (emit-byte segment #b00101111)))
1314 (define-instruction mul (segment dst src)
1315 (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1317 (let ((size (matching-operand-size dst src)))
1318 (aver (accumulator-p dst))
1319 (maybe-emit-operand-size-prefix segment size)
1320 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1321 (emit-ea segment src #b100))))
1323 (define-instruction imul (segment dst &optional src1 src2)
1324 (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1325 (:printer ext-reg-reg/mem ((op #b1010111)))
1326 (:printer reg-reg/mem ((op #b0110100) (width 1)
1327 (imm nil :type 'signed-imm-word))
1328 '(:name :tab reg ", " reg/mem ", " imm))
1329 (:printer reg-reg/mem ((op #b0110101) (width 1)
1330 (imm nil :type 'signed-imm-byte))
1331 '(:name :tab reg ", " reg/mem ", " imm))
1333 (flet ((r/m-with-immed-to-reg (reg r/m immed)
1334 (let* ((size (matching-operand-size reg r/m))
1335 (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1336 (maybe-emit-operand-size-prefix segment size)
1337 (emit-byte segment (if sx #b01101011 #b01101001))
1338 (emit-ea segment r/m (reg-tn-encoding reg))
1340 (emit-byte segment immed)
1341 (emit-sized-immediate segment size immed)))))
1343 (r/m-with-immed-to-reg dst src1 src2))
1346 (r/m-with-immed-to-reg dst dst src1)
1347 (let ((size (matching-operand-size dst src1)))
1348 (maybe-emit-operand-size-prefix segment size)
1349 (emit-byte segment #b00001111)
1350 (emit-byte segment #b10101111)
1351 (emit-ea segment src1 (reg-tn-encoding dst)))))
1353 (let ((size (operand-size dst)))
1354 (maybe-emit-operand-size-prefix segment size)
1355 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1356 (emit-ea segment dst #b101)))))))
1358 (define-instruction div (segment dst src)
1359 (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1361 (let ((size (matching-operand-size dst src)))
1362 (aver (accumulator-p dst))
1363 (maybe-emit-operand-size-prefix segment size)
1364 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1365 (emit-ea segment src #b110))))
1367 (define-instruction idiv (segment dst src)
1368 (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1370 (let ((size (matching-operand-size dst src)))
1371 (aver (accumulator-p dst))
1372 (maybe-emit-operand-size-prefix segment size)
1373 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1374 (emit-ea segment src #b111))))
1376 (define-instruction aad (segment)
1377 (:printer two-bytes ((op '(#b11010101 #b00001010))))
1379 (emit-byte segment #b11010101)
1380 (emit-byte segment #b00001010)))
1382 (define-instruction aam (segment)
1383 (:printer two-bytes ((op '(#b11010100 #b00001010))))
1385 (emit-byte segment #b11010100)
1386 (emit-byte segment #b00001010)))
1388 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1389 (define-instruction cbw (segment)
1391 (maybe-emit-operand-size-prefix segment :word)
1392 (emit-byte segment #b10011000)))
1394 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1395 (define-instruction cwde (segment)
1397 (maybe-emit-operand-size-prefix segment :dword)
1398 (emit-byte segment #b10011000)))
1400 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1401 (define-instruction cwd (segment)
1403 (maybe-emit-operand-size-prefix segment :word)
1404 (emit-byte segment #b10011001)))
1406 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1407 (define-instruction cdq (segment)
1408 (:printer byte ((op #b10011001)))
1410 (maybe-emit-operand-size-prefix segment :dword)
1411 (emit-byte segment #b10011001)))
1413 (define-instruction xadd (segment dst src)
1414 ;; Register/Memory with Register.
1415 (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1417 (aver (register-p src))
1418 (let ((size (matching-operand-size src dst)))
1419 (maybe-emit-operand-size-prefix segment size)
1420 (emit-byte segment #b00001111)
1421 (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1422 (emit-ea segment dst (reg-tn-encoding src)))))
1427 (defun emit-shift-inst (segment dst amount opcode)
1428 (let ((size (operand-size dst)))
1429 (maybe-emit-operand-size-prefix segment size)
1430 (multiple-value-bind (major-opcode immed)
1432 (:cl (values #b11010010 nil))
1433 (1 (values #b11010000 nil))
1434 (t (values #b11000000 t)))
1436 (if (eq size :byte) major-opcode (logior major-opcode 1)))
1437 (emit-ea segment dst opcode)
1439 (emit-byte segment amount)))))
1441 (eval-when (:compile-toplevel :execute)
1442 (defun shift-inst-printer-list (subop)
1443 `((reg/mem ((op (#b1101000 ,subop)))
1444 (:name :tab reg/mem ", 1"))
1445 (reg/mem ((op (#b1101001 ,subop)))
1446 (:name :tab reg/mem ", " 'cl))
1447 (reg/mem-imm ((op (#b1100000 ,subop))
1448 (imm nil :type signed-imm-byte))))))
1450 (define-instruction rol (segment dst amount)
1452 (shift-inst-printer-list #b000))
1454 (emit-shift-inst segment dst amount #b000)))
1456 (define-instruction ror (segment dst amount)
1458 (shift-inst-printer-list #b001))
1460 (emit-shift-inst segment dst amount #b001)))
1462 (define-instruction rcl (segment dst amount)
1464 (shift-inst-printer-list #b010))
1466 (emit-shift-inst segment dst amount #b010)))
1468 (define-instruction rcr (segment dst amount)
1470 (shift-inst-printer-list #b011))
1472 (emit-shift-inst segment dst amount #b011)))
1474 (define-instruction shl (segment dst amount)
1476 (shift-inst-printer-list #b100))
1478 (emit-shift-inst segment dst amount #b100)))
1480 (define-instruction shr (segment dst amount)
1482 (shift-inst-printer-list #b101))
1484 (emit-shift-inst segment dst amount #b101)))
1486 (define-instruction sar (segment dst amount)
1488 (shift-inst-printer-list #b111))
1490 (emit-shift-inst segment dst amount #b111)))
1492 (defun emit-double-shift (segment opcode dst src amt)
1493 (let ((size (matching-operand-size dst src)))
1494 (when (eq size :byte)
1495 (error "Double shifts can only be used with words."))
1496 (maybe-emit-operand-size-prefix segment size)
1497 (emit-byte segment #b00001111)
1498 (emit-byte segment (dpb opcode (byte 1 3)
1499 (if (eq amt :cl) #b10100101 #b10100100)))
1501 (emit-ea segment dst src)
1502 (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1503 (unless (eq amt :cl)
1504 (emit-byte segment amt))))
1506 (eval-when (:compile-toplevel :execute)
1507 (defun double-shift-inst-printer-list (op)
1509 (ext-reg-reg/mem-imm ((op ,(logior op #b10))
1510 (imm nil :type signed-imm-byte)))
1511 (ext-reg-reg/mem ((op ,(logior op #b10)))
1512 (:name :tab reg/mem ", " reg ", " 'cl)))))
1514 (define-instruction shld (segment dst src amt)
1515 (:declare (type (or (member :cl) (mod 32)) amt))
1516 (:printer-list (double-shift-inst-printer-list #b1010000))
1518 (emit-double-shift segment #b0 dst src amt)))
1520 (define-instruction shrd (segment dst src amt)
1521 (:declare (type (or (member :cl) (mod 32)) amt))
1522 (:printer-list (double-shift-inst-printer-list #b1010100))
1524 (emit-double-shift segment #b1 dst src amt)))
1526 (define-instruction and (segment dst src)
1528 (arith-inst-printer-list #b100))
1530 (emit-random-arith-inst "AND" segment dst src #b100)))
1532 (define-instruction test (segment this that)
1533 (:printer accum-imm ((op #b1010100)))
1534 (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1535 (:printer reg-reg/mem ((op #b1000010)))
1537 (let ((size (matching-operand-size this that)))
1538 (maybe-emit-operand-size-prefix segment size)
1539 (flet ((test-immed-and-something (immed something)
1540 (cond ((accumulator-p something)
1542 (if (eq size :byte) #b10101000 #b10101001))
1543 (emit-sized-immediate segment size immed))
1546 (if (eq size :byte) #b11110110 #b11110111))
1547 (emit-ea segment something #b000)
1548 (emit-sized-immediate segment size immed))))
1549 (test-reg-and-something (reg something)
1550 (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1551 (emit-ea segment something (reg-tn-encoding reg))))
1552 (cond ((integerp that)
1553 (test-immed-and-something that this))
1555 (test-immed-and-something this that))
1557 (test-reg-and-something this that))
1559 (test-reg-and-something that this))
1561 (error "bogus operands for TEST: ~S and ~S" this that)))))))
1563 ;;; Emit the most compact form of the test immediate instruction,
1564 ;;; using an 8 bit test when the immediate is only 8 bits and the
1565 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
1567 (defun emit-optimized-test-inst (x y)
1570 (let ((offset (tn-offset x)))
1571 (cond ((and (sc-is x any-reg descriptor-reg)
1572 (or (= offset eax-offset) (= offset ebx-offset)
1573 (= offset ecx-offset) (= offset edx-offset)))
1574 (inst test (make-random-tn :kind :normal
1575 :sc (sc-or-lose 'byte-reg)
1578 ((sc-is x control-stack)
1579 (inst test (make-ea :byte :base ebp-tn
1580 :disp (- (* (1+ offset) n-word-bytes)))
1587 (define-instruction or (segment dst src)
1589 (arith-inst-printer-list #b001))
1591 (emit-random-arith-inst "OR" segment dst src #b001)))
1593 (define-instruction xor (segment dst src)
1595 (arith-inst-printer-list #b110))
1597 (emit-random-arith-inst "XOR" segment dst src #b110)))
1599 (define-instruction not (segment dst)
1600 (:printer reg/mem ((op '(#b1111011 #b010))))
1602 (let ((size (operand-size dst)))
1603 (maybe-emit-operand-size-prefix segment size)
1604 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1605 (emit-ea segment dst #b010))))
1607 ;;;; string manipulation
1609 (define-instruction cmps (segment size)
1610 (:printer string-op ((op #b1010011)))
1612 (maybe-emit-operand-size-prefix segment size)
1613 (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1615 (define-instruction ins (segment acc)
1616 (:printer string-op ((op #b0110110)))
1618 (let ((size (operand-size acc)))
1619 (aver (accumulator-p acc))
1620 (maybe-emit-operand-size-prefix segment size)
1621 (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1623 (define-instruction lods (segment acc)
1624 (:printer string-op ((op #b1010110)))
1626 (let ((size (operand-size acc)))
1627 (aver (accumulator-p acc))
1628 (maybe-emit-operand-size-prefix segment size)
1629 (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1631 (define-instruction movs (segment size)
1632 (:printer string-op ((op #b1010010)))
1634 (maybe-emit-operand-size-prefix segment size)
1635 (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1637 (define-instruction outs (segment acc)
1638 (:printer string-op ((op #b0110111)))
1640 (let ((size (operand-size acc)))
1641 (aver (accumulator-p acc))
1642 (maybe-emit-operand-size-prefix segment size)
1643 (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1645 (define-instruction scas (segment acc)
1646 (:printer string-op ((op #b1010111)))
1648 (let ((size (operand-size acc)))
1649 (aver (accumulator-p acc))
1650 (maybe-emit-operand-size-prefix segment size)
1651 (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1653 (define-instruction stos (segment acc)
1654 (:printer string-op ((op #b1010101)))
1656 (let ((size (operand-size acc)))
1657 (aver (accumulator-p acc))
1658 (maybe-emit-operand-size-prefix segment size)
1659 (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1661 (define-instruction xlat (segment)
1662 (:printer byte ((op #b11010111)))
1664 (emit-byte segment #b11010111)))
1666 (define-instruction rep (segment)
1668 (emit-byte segment #b11110010)))
1670 (define-instruction repe (segment)
1671 (:printer byte ((op #b11110011)))
1673 (emit-byte segment #b11110011)))
1675 (define-instruction repne (segment)
1676 (:printer byte ((op #b11110010)))
1678 (emit-byte segment #b11110010)))
1681 ;;;; bit manipulation
1683 (define-instruction bsf (segment dst src)
1684 (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
1686 (let ((size (matching-operand-size dst src)))
1687 (when (eq size :byte)
1688 (error "can't scan bytes: ~S" src))
1689 (maybe-emit-operand-size-prefix segment size)
1690 (emit-byte segment #b00001111)
1691 (emit-byte segment #b10111100)
1692 (emit-ea segment src (reg-tn-encoding dst)))))
1694 (define-instruction bsr (segment dst src)
1695 (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
1697 (let ((size (matching-operand-size dst src)))
1698 (when (eq size :byte)
1699 (error "can't scan bytes: ~S" src))
1700 (maybe-emit-operand-size-prefix segment size)
1701 (emit-byte segment #b00001111)
1702 (emit-byte segment #b10111101)
1703 (emit-ea segment src (reg-tn-encoding dst)))))
1705 (defun emit-bit-test-and-mumble (segment src index opcode)
1706 (let ((size (operand-size src)))
1707 (when (eq size :byte)
1708 (error "can't scan bytes: ~S" src))
1709 (maybe-emit-operand-size-prefix segment size)
1710 (emit-byte segment #b00001111)
1711 (cond ((integerp index)
1712 (emit-byte segment #b10111010)
1713 (emit-ea segment src opcode)
1714 (emit-byte segment index))
1716 (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1717 (emit-ea segment src (reg-tn-encoding index))))))
1719 (eval-when (:compile-toplevel :execute)
1720 (defun bit-test-inst-printer-list (subop)
1721 `((ext-reg/mem-imm ((op (#b1011101 ,subop))
1722 (reg/mem nil :type word-reg/mem)
1723 (imm nil :type imm-data)
1725 (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1727 (:name :tab reg/mem ", " reg)))))
1729 (define-instruction bt (segment src index)
1730 (:printer-list (bit-test-inst-printer-list #b100))
1732 (emit-bit-test-and-mumble segment src index #b100)))
1734 (define-instruction btc (segment src index)
1735 (:printer-list (bit-test-inst-printer-list #b111))
1737 (emit-bit-test-and-mumble segment src index #b111)))
1739 (define-instruction btr (segment src index)
1740 (:printer-list (bit-test-inst-printer-list #b110))
1742 (emit-bit-test-and-mumble segment src index #b110)))
1744 (define-instruction bts (segment src index)
1745 (:printer-list (bit-test-inst-printer-list #b101))
1747 (emit-bit-test-and-mumble segment src index #b101)))
1750 ;;;; control transfer
1752 (define-instruction call (segment where)
1753 (:printer near-jump ((op #b11101000)))
1754 (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
1758 (emit-byte segment #b11101000)
1759 (emit-back-patch segment
1761 (lambda (segment posn)
1763 (- (label-position where)
1766 (emit-byte segment #b11101000)
1767 (emit-relative-fixup segment where))
1769 (emit-byte segment #b11111111)
1770 (emit-ea segment where #b010)))))
1772 (defun emit-byte-displacement-backpatch (segment target)
1773 (emit-back-patch segment
1775 (lambda (segment posn)
1776 (let ((disp (- (label-position target) (1+ posn))))
1777 (aver (<= -128 disp 127))
1778 (emit-byte segment disp)))))
1780 (define-instruction jmp (segment cond &optional where)
1781 ;; conditional jumps
1782 (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
1783 (:printer near-cond-jump () '('j cc :tab label))
1784 ;; unconditional jumps
1785 (:printer short-jump ((op #b1011)))
1786 (:printer near-jump ((op #b11101001)) )
1787 (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
1792 (lambda (segment posn delta-if-after)
1793 (let ((disp (- (label-position where posn delta-if-after)
1795 (when (<= -128 disp 127)
1797 (dpb (conditional-opcode cond)
1800 (emit-byte-displacement-backpatch segment where)
1802 (lambda (segment posn)
1803 (let ((disp (- (label-position where) (+ posn 6))))
1804 (emit-byte segment #b00001111)
1806 (dpb (conditional-opcode cond)
1809 (emit-dword segment disp)))))
1810 ((label-p (setq where cond))
1813 (lambda (segment posn delta-if-after)
1814 (let ((disp (- (label-position where posn delta-if-after)
1816 (when (<= -128 disp 127)
1817 (emit-byte segment #b11101011)
1818 (emit-byte-displacement-backpatch segment where)
1820 (lambda (segment posn)
1821 (let ((disp (- (label-position where) (+ posn 5))))
1822 (emit-byte segment #b11101001)
1823 (emit-dword segment disp)))))
1825 (emit-byte segment #b11101001)
1826 (emit-relative-fixup segment where))
1828 (unless (or (ea-p where) (tn-p where))
1829 (error "don't know what to do with ~A" where))
1830 (emit-byte segment #b11111111)
1831 (emit-ea segment where #b100)))))
1833 (define-instruction jmp-short (segment label)
1835 (emit-byte segment #b11101011)
1836 (emit-byte-displacement-backpatch segment label)))
1838 (define-instruction ret (segment &optional stack-delta)
1839 (:printer byte ((op #b11000011)))
1840 (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
1844 (emit-byte segment #b11000010)
1845 (emit-word segment stack-delta))
1847 (emit-byte segment #b11000011)))))
1849 (define-instruction jecxz (segment target)
1850 (:printer short-jump ((op #b0011)))
1852 (emit-byte segment #b11100011)
1853 (emit-byte-displacement-backpatch segment target)))
1855 (define-instruction loop (segment target)
1856 (:printer short-jump ((op #b0010)))
1858 (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
1859 (emit-byte-displacement-backpatch segment target)))
1861 (define-instruction loopz (segment target)
1862 (:printer short-jump ((op #b0001)))
1864 (emit-byte segment #b11100001)
1865 (emit-byte-displacement-backpatch segment target)))
1867 (define-instruction loopnz (segment target)
1868 (:printer short-jump ((op #b0000)))
1870 (emit-byte segment #b11100000)
1871 (emit-byte-displacement-backpatch segment target)))
1873 ;;;; conditional move
1874 (define-instruction cmov (segment cond dst src)
1875 (:printer cond-move ())
1877 (aver (register-p dst))
1878 (let ((size (matching-operand-size dst src)))
1879 (aver (or (eq size :word) (eq size :dword)))
1880 (maybe-emit-operand-size-prefix segment size))
1881 (emit-byte segment #b00001111)
1882 (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
1883 (emit-ea segment src (reg-tn-encoding dst))))
1885 ;;;; conditional byte set
1887 (define-instruction set (segment dst cond)
1888 (:printer cond-set ())
1890 (emit-byte segment #b00001111)
1891 (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
1892 (emit-ea segment dst #b000)))
1896 (define-instruction enter (segment disp &optional (level 0))
1897 (:declare (type (unsigned-byte 16) disp)
1898 (type (unsigned-byte 8) level))
1899 (:printer enter-format ((op #b11001000)))
1901 (emit-byte segment #b11001000)
1902 (emit-word segment disp)
1903 (emit-byte segment level)))
1905 (define-instruction leave (segment)
1906 (:printer byte ((op #b11001001)))
1908 (emit-byte segment #b11001001)))
1911 (define-instruction prefetchnta (segment ea)
1912 (:printer prefetch ((op #b00011000) (reg #b000)))
1914 (aver (typep ea 'ea))
1915 (aver (eq :byte (ea-size ea)))
1916 (emit-byte segment #b00001111)
1917 (emit-byte segment #b00011000)
1918 (emit-ea segment ea #b000)))
1920 (define-instruction prefetcht0 (segment ea)
1921 (:printer prefetch ((op #b00011000) (reg #b001)))
1923 (aver (typep ea 'ea))
1924 (aver (eq :byte (ea-size ea)))
1925 (emit-byte segment #b00001111)
1926 (emit-byte segment #b00011000)
1927 (emit-ea segment ea #b001)))
1929 (define-instruction prefetcht1 (segment ea)
1930 (:printer prefetch ((op #b00011000) (reg #b010)))
1932 (aver (typep ea 'ea))
1933 (aver (eq :byte (ea-size ea)))
1934 (emit-byte segment #b00001111)
1935 (emit-byte segment #b00011000)
1936 (emit-ea segment ea #b010)))
1938 (define-instruction prefetcht2 (segment ea)
1939 (:printer prefetch ((op #b00011000) (reg #b011)))
1941 (aver (typep ea 'ea))
1942 (aver (eq :byte (ea-size ea)))
1943 (emit-byte segment #b00001111)
1944 (emit-byte segment #b00011000)
1945 (emit-ea segment ea #b011)))
1947 ;;;; interrupt instructions
1949 (defun snarf-error-junk (sap offset &optional length-only)
1950 (let* ((length (sb!sys:sap-ref-8 sap offset))
1951 (vector (make-array length :element-type '(unsigned-byte 8))))
1952 (declare (type sb!sys:system-area-pointer sap)
1953 (type (unsigned-byte 8) length)
1954 (type (simple-array (unsigned-byte 8) (*)) vector))
1956 (values 0 (1+ length) nil nil))
1958 (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
1960 (collect ((sc-offsets)
1962 (lengths 1) ; the length byte
1964 (error-number (sb!c:read-var-integer vector index)))
1967 (when (>= index length)
1969 (let ((old-index index))
1970 (sc-offsets (sb!c:read-var-integer vector index))
1971 (lengths (- index old-index))))
1972 (values error-number
1978 (defmacro break-cases (breaknum &body cases)
1979 (let ((bn-temp (gensym)))
1980 (collect ((clauses))
1981 (dolist (case cases)
1982 (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
1983 `(let ((,bn-temp ,breaknum))
1984 (cond ,@(clauses))))))
1987 (defun break-control (chunk inst stream dstate)
1988 (declare (ignore inst))
1989 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
1990 ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
1991 ;; map has it undefined; and it should be easier to look in the target
1992 ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
1993 ;; from first principles whether it's defined in some way that genesis
1995 (case #!-darwin (byte-imm-code chunk dstate)
1996 #!+darwin (word-imm-code chunk dstate)
1999 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2002 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2004 (nt "breakpoint trap"))
2005 (#.pending-interrupt-trap
2006 (nt "pending interrupt trap"))
2009 (#.fun-end-breakpoint-trap
2010 (nt "function end breakpoint trap")))))
2012 (define-instruction break (segment code)
2013 (:declare (type (unsigned-byte 8) code))
2014 #!-darwin (:printer byte-imm ((op #b11001100)) '(:name :tab code)
2015 :control #'break-control)
2016 #!+darwin (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
2017 :control #'break-control)
2019 #!-darwin (emit-byte segment #b11001100)
2020 ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
2021 ;; throw a sigill with 0x0b0f instead and check for this in the
2022 ;; SIGILL handler and pass it on to the sigtrap handler if
2024 #!+darwin (emit-word segment #b0000101100001111)
2025 (emit-byte segment code)))
2027 (define-instruction int (segment number)
2028 (:declare (type (unsigned-byte 8) number))
2029 (:printer byte-imm ((op #b11001101)))
2033 (emit-byte segment #b11001100))
2035 (emit-byte segment #b11001101)
2036 (emit-byte segment number)))))
2038 (define-instruction into (segment)
2039 (:printer byte ((op #b11001110)))
2041 (emit-byte segment #b11001110)))
2043 (define-instruction bound (segment reg bounds)
2045 (let ((size (matching-operand-size reg bounds)))
2046 (when (eq size :byte)
2047 (error "can't bounds-test bytes: ~S" reg))
2048 (maybe-emit-operand-size-prefix segment size)
2049 (emit-byte segment #b01100010)
2050 (emit-ea segment bounds (reg-tn-encoding reg)))))
2052 (define-instruction iret (segment)
2053 (:printer byte ((op #b11001111)))
2055 (emit-byte segment #b11001111)))
2057 ;;;; processor control
2059 (define-instruction hlt (segment)
2060 (:printer byte ((op #b11110100)))
2062 (emit-byte segment #b11110100)))
2064 (define-instruction nop (segment)
2065 (:printer byte ((op #b10010000)))
2067 (emit-byte segment #b10010000)))
2069 (define-instruction wait (segment)
2070 (:printer byte ((op #b10011011)))
2072 (emit-byte segment #b10011011)))
2074 (define-instruction lock (segment)
2075 (:printer byte ((op #b11110000)))
2077 (emit-byte segment #b11110000)))
2079 ;;;; miscellaneous hackery
2081 (define-instruction byte (segment byte)
2083 (emit-byte segment byte)))
2085 (define-instruction word (segment word)
2087 (emit-word segment word)))
2089 (define-instruction dword (segment dword)
2091 (emit-dword segment dword)))
2093 (defun emit-header-data (segment type)
2094 (emit-back-patch segment
2096 (lambda (segment posn)
2100 (component-header-length))
2104 (define-instruction simple-fun-header-word (segment)
2106 (emit-header-data segment simple-fun-header-widetag)))
2108 (define-instruction lra-header-word (segment)
2110 (emit-header-data segment return-pc-header-widetag)))
2112 ;;;; fp instructions
2114 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
2116 ;;;; Note: We treat the single-precision and double-precision variants
2117 ;;;; as separate instructions.
2119 ;;; Load single to st(0).
2120 (define-instruction fld (segment source)
2121 (:printer floating-point ((op '(#b001 #b000))))
2123 (emit-byte segment #b11011001)
2124 (emit-fp-op segment source #b000)))
2126 ;;; Load double to st(0).
2127 (define-instruction fldd (segment source)
2128 (:printer floating-point ((op '(#b101 #b000))))
2129 (:printer floating-point-fp ((op '(#b001 #b000))))
2131 (if (fp-reg-tn-p source)
2132 (emit-byte segment #b11011001)
2133 (emit-byte segment #b11011101))
2134 (emit-fp-op segment source #b000)))
2136 ;;; Load long to st(0).
2137 (define-instruction fldl (segment source)
2138 (:printer floating-point ((op '(#b011 #b101))))
2140 (emit-byte segment #b11011011)
2141 (emit-fp-op segment source #b101)))
2143 ;;; Store single from st(0).
2144 (define-instruction fst (segment dest)
2145 (:printer floating-point ((op '(#b001 #b010))))
2147 (cond ((fp-reg-tn-p dest)
2148 (emit-byte segment #b11011101)
2149 (emit-fp-op segment dest #b010))
2151 (emit-byte segment #b11011001)
2152 (emit-fp-op segment dest #b010)))))
2154 ;;; Store double from st(0).
2155 (define-instruction fstd (segment dest)
2156 (:printer floating-point ((op '(#b101 #b010))))
2157 (:printer floating-point-fp ((op '(#b101 #b010))))
2159 (cond ((fp-reg-tn-p dest)
2160 (emit-byte segment #b11011101)
2161 (emit-fp-op segment dest #b010))
2163 (emit-byte segment #b11011101)
2164 (emit-fp-op segment dest #b010)))))
2166 ;;; Arithmetic ops are all done with at least one operand at top of
2167 ;;; stack. The other operand is is another register or a 32/64 bit
2170 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2171 ;;; that these conflict with the Gdb conventions for binops. To reduce
2172 ;;; the confusion I've added comments showing the mathamatical
2173 ;;; operation and the two syntaxes. By the ASM386 convention the
2174 ;;; instruction syntax is:
2177 ;;; or Fop Destination, Source
2179 ;;; If only one operand is given then it is the source and the
2180 ;;; destination is ST(0). There are reversed forms of the fsub and
2181 ;;; fdiv instructions inducated by an 'R' suffix.
2183 ;;; The mathematical operation for the non-reverse form is always:
2184 ;;; destination = destination op source
2186 ;;; For the reversed form it is:
2187 ;;; destination = source op destination
2189 ;;; The instructions below only accept one operand at present which is
2190 ;;; usually the source. I've hack in extra instructions to implement
2191 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2192 ;;; the operand is the destination with the source being ST(0).
2195 ;;; st(0) = st(0) + memory or st(i).
2196 (define-instruction fadd (segment source)
2197 (:printer floating-point ((op '(#b000 #b000))))
2199 (emit-byte segment #b11011000)
2200 (emit-fp-op segment source #b000)))
2203 ;;; st(0) = st(0) + memory or st(i).
2204 (define-instruction faddd (segment source)
2205 (:printer floating-point ((op '(#b100 #b000))))
2206 (:printer floating-point-fp ((op '(#b000 #b000))))
2208 (if (fp-reg-tn-p source)
2209 (emit-byte segment #b11011000)
2210 (emit-byte segment #b11011100))
2211 (emit-fp-op segment source #b000)))
2213 ;;; Add double destination st(i):
2214 ;;; st(i) = st(0) + st(i).
2215 (define-instruction fadd-sti (segment destination)
2216 (:printer floating-point-fp ((op '(#b100 #b000))))
2218 (aver (fp-reg-tn-p destination))
2219 (emit-byte segment #b11011100)
2220 (emit-fp-op segment destination #b000)))
2222 (define-instruction faddp-sti (segment destination)
2223 (:printer floating-point-fp ((op '(#b110 #b000))))
2225 (aver (fp-reg-tn-p destination))
2226 (emit-byte segment #b11011110)
2227 (emit-fp-op segment destination #b000)))
2229 ;;; Subtract single:
2230 ;;; st(0) = st(0) - memory or st(i).
2231 (define-instruction fsub (segment source)
2232 (:printer floating-point ((op '(#b000 #b100))))
2234 (emit-byte segment #b11011000)
2235 (emit-fp-op segment source #b100)))
2237 ;;; Subtract single, reverse:
2238 ;;; st(0) = memory or st(i) - st(0).
2239 (define-instruction fsubr (segment source)
2240 (:printer floating-point ((op '(#b000 #b101))))
2242 (emit-byte segment #b11011000)
2243 (emit-fp-op segment source #b101)))
2245 ;;; Subtract double:
2246 ;;; st(0) = st(0) - memory or st(i).
2247 (define-instruction fsubd (segment source)
2248 (:printer floating-point ((op '(#b100 #b100))))
2249 (:printer floating-point-fp ((op '(#b000 #b100))))
2251 (if (fp-reg-tn-p source)
2252 (emit-byte segment #b11011000)
2253 (emit-byte segment #b11011100))
2254 (emit-fp-op segment source #b100)))
2256 ;;; Subtract double, reverse:
2257 ;;; st(0) = memory or st(i) - st(0).
2258 (define-instruction fsubrd (segment source)
2259 (:printer floating-point ((op '(#b100 #b101))))
2260 (:printer floating-point-fp ((op '(#b000 #b101))))
2262 (if (fp-reg-tn-p source)
2263 (emit-byte segment #b11011000)
2264 (emit-byte segment #b11011100))
2265 (emit-fp-op segment source #b101)))
2267 ;;; Subtract double, destination st(i):
2268 ;;; st(i) = st(i) - st(0).
2270 ;;; ASM386 syntax: FSUB ST(i), ST
2271 ;;; Gdb syntax: fsubr %st,%st(i)
2272 (define-instruction fsub-sti (segment destination)
2273 (:printer floating-point-fp ((op '(#b100 #b101))))
2275 (aver (fp-reg-tn-p destination))
2276 (emit-byte segment #b11011100)
2277 (emit-fp-op segment destination #b101)))
2279 (define-instruction fsubp-sti (segment destination)
2280 (:printer floating-point-fp ((op '(#b110 #b101))))
2282 (aver (fp-reg-tn-p destination))
2283 (emit-byte segment #b11011110)
2284 (emit-fp-op segment destination #b101)))
2286 ;;; Subtract double, reverse, destination st(i):
2287 ;;; st(i) = st(0) - st(i).
2289 ;;; ASM386 syntax: FSUBR ST(i), ST
2290 ;;; Gdb syntax: fsub %st,%st(i)
2291 (define-instruction fsubr-sti (segment destination)
2292 (:printer floating-point-fp ((op '(#b100 #b100))))
2294 (aver (fp-reg-tn-p destination))
2295 (emit-byte segment #b11011100)
2296 (emit-fp-op segment destination #b100)))
2298 (define-instruction fsubrp-sti (segment destination)
2299 (:printer floating-point-fp ((op '(#b110 #b100))))
2301 (aver (fp-reg-tn-p destination))
2302 (emit-byte segment #b11011110)
2303 (emit-fp-op segment destination #b100)))
2305 ;;; Multiply single:
2306 ;;; st(0) = st(0) * memory or st(i).
2307 (define-instruction fmul (segment source)
2308 (:printer floating-point ((op '(#b000 #b001))))
2310 (emit-byte segment #b11011000)
2311 (emit-fp-op segment source #b001)))
2313 ;;; Multiply double:
2314 ;;; st(0) = st(0) * memory or st(i).
2315 (define-instruction fmuld (segment source)
2316 (:printer floating-point ((op '(#b100 #b001))))
2317 (:printer floating-point-fp ((op '(#b000 #b001))))
2319 (if (fp-reg-tn-p source)
2320 (emit-byte segment #b11011000)
2321 (emit-byte segment #b11011100))
2322 (emit-fp-op segment source #b001)))
2324 ;;; Multiply double, destination st(i):
2325 ;;; st(i) = st(i) * st(0).
2326 (define-instruction fmul-sti (segment destination)
2327 (:printer floating-point-fp ((op '(#b100 #b001))))
2329 (aver (fp-reg-tn-p destination))
2330 (emit-byte segment #b11011100)
2331 (emit-fp-op segment destination #b001)))
2334 ;;; st(0) = st(0) / memory or st(i).
2335 (define-instruction fdiv (segment source)
2336 (:printer floating-point ((op '(#b000 #b110))))
2338 (emit-byte segment #b11011000)
2339 (emit-fp-op segment source #b110)))
2341 ;;; Divide single, reverse:
2342 ;;; st(0) = memory or st(i) / st(0).
2343 (define-instruction fdivr (segment source)
2344 (:printer floating-point ((op '(#b000 #b111))))
2346 (emit-byte segment #b11011000)
2347 (emit-fp-op segment source #b111)))
2350 ;;; st(0) = st(0) / memory or st(i).
2351 (define-instruction fdivd (segment source)
2352 (:printer floating-point ((op '(#b100 #b110))))
2353 (:printer floating-point-fp ((op '(#b000 #b110))))
2355 (if (fp-reg-tn-p source)
2356 (emit-byte segment #b11011000)
2357 (emit-byte segment #b11011100))
2358 (emit-fp-op segment source #b110)))
2360 ;;; Divide double, reverse:
2361 ;;; st(0) = memory or st(i) / st(0).
2362 (define-instruction fdivrd (segment source)
2363 (:printer floating-point ((op '(#b100 #b111))))
2364 (:printer floating-point-fp ((op '(#b000 #b111))))
2366 (if (fp-reg-tn-p source)
2367 (emit-byte segment #b11011000)
2368 (emit-byte segment #b11011100))
2369 (emit-fp-op segment source #b111)))
2371 ;;; Divide double, destination st(i):
2372 ;;; st(i) = st(i) / st(0).
2374 ;;; ASM386 syntax: FDIV ST(i), ST
2375 ;;; Gdb syntax: fdivr %st,%st(i)
2376 (define-instruction fdiv-sti (segment destination)
2377 (:printer floating-point-fp ((op '(#b100 #b111))))
2379 (aver (fp-reg-tn-p destination))
2380 (emit-byte segment #b11011100)
2381 (emit-fp-op segment destination #b111)))
2383 ;;; Divide double, reverse, destination st(i):
2384 ;;; st(i) = st(0) / st(i).
2386 ;;; ASM386 syntax: FDIVR ST(i), ST
2387 ;;; Gdb syntax: fdiv %st,%st(i)
2388 (define-instruction fdivr-sti (segment destination)
2389 (:printer floating-point-fp ((op '(#b100 #b110))))
2391 (aver (fp-reg-tn-p destination))
2392 (emit-byte segment #b11011100)
2393 (emit-fp-op segment destination #b110)))
2395 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2396 (define-instruction fxch (segment source)
2397 (:printer floating-point-fp ((op '(#b001 #b001))))
2399 (unless (and (tn-p source)
2400 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
2402 (emit-byte segment #b11011001)
2403 (emit-fp-op segment source #b001)))
2405 ;;; Push 32-bit integer to st0.
2406 (define-instruction fild (segment source)
2407 (:printer floating-point ((op '(#b011 #b000))))
2409 (emit-byte segment #b11011011)
2410 (emit-fp-op segment source #b000)))
2412 ;;; Push 64-bit integer to st0.
2413 (define-instruction fildl (segment source)
2414 (:printer floating-point ((op '(#b111 #b101))))
2416 (emit-byte segment #b11011111)
2417 (emit-fp-op segment source #b101)))
2419 ;;; Store 32-bit integer.
2420 (define-instruction fist (segment dest)
2421 (:printer floating-point ((op '(#b011 #b010))))
2423 (emit-byte segment #b11011011)
2424 (emit-fp-op segment dest #b010)))
2426 ;;; Store and pop 32-bit integer.
2427 (define-instruction fistp (segment dest)
2428 (:printer floating-point ((op '(#b011 #b011))))
2430 (emit-byte segment #b11011011)
2431 (emit-fp-op segment dest #b011)))
2433 ;;; Store and pop 64-bit integer.
2434 (define-instruction fistpl (segment dest)
2435 (:printer floating-point ((op '(#b111 #b111))))
2437 (emit-byte segment #b11011111)
2438 (emit-fp-op segment dest #b111)))
2440 ;;; Store single from st(0) and pop.
2441 (define-instruction fstp (segment dest)
2442 (:printer floating-point ((op '(#b001 #b011))))
2444 (cond ((fp-reg-tn-p dest)
2445 (emit-byte segment #b11011101)
2446 (emit-fp-op segment dest #b011))
2448 (emit-byte segment #b11011001)
2449 (emit-fp-op segment dest #b011)))))
2451 ;;; Store double from st(0) and pop.
2452 (define-instruction fstpd (segment dest)
2453 (:printer floating-point ((op '(#b101 #b011))))
2454 (:printer floating-point-fp ((op '(#b101 #b011))))
2456 (cond ((fp-reg-tn-p dest)
2457 (emit-byte segment #b11011101)
2458 (emit-fp-op segment dest #b011))
2460 (emit-byte segment #b11011101)
2461 (emit-fp-op segment dest #b011)))))
2463 ;;; Store long from st(0) and pop.
2464 (define-instruction fstpl (segment dest)
2465 (:printer floating-point ((op '(#b011 #b111))))
2467 (emit-byte segment #b11011011)
2468 (emit-fp-op segment dest #b111)))
2470 ;;; Decrement stack-top pointer.
2471 (define-instruction fdecstp (segment)
2472 (:printer floating-point-no ((op #b10110)))
2474 (emit-byte segment #b11011001)
2475 (emit-byte segment #b11110110)))
2477 ;;; Increment stack-top pointer.
2478 (define-instruction fincstp (segment)
2479 (:printer floating-point-no ((op #b10111)))
2481 (emit-byte segment #b11011001)
2482 (emit-byte segment #b11110111)))
2484 ;;; Free fp register.
2485 (define-instruction ffree (segment dest)
2486 (:printer floating-point-fp ((op '(#b101 #b000))))
2488 (emit-byte segment #b11011101)
2489 (emit-fp-op segment dest #b000)))
2491 (define-instruction fabs (segment)
2492 (:printer floating-point-no ((op #b00001)))
2494 (emit-byte segment #b11011001)
2495 (emit-byte segment #b11100001)))
2497 (define-instruction fchs (segment)
2498 (:printer floating-point-no ((op #b00000)))
2500 (emit-byte segment #b11011001)
2501 (emit-byte segment #b11100000)))
2503 (define-instruction frndint(segment)
2504 (:printer floating-point-no ((op #b11100)))
2506 (emit-byte segment #b11011001)
2507 (emit-byte segment #b11111100)))
2510 (define-instruction fninit(segment)
2511 (:printer floating-point-5 ((op #b00011)))
2513 (emit-byte segment #b11011011)
2514 (emit-byte segment #b11100011)))
2516 ;;; Store Status Word to AX.
2517 (define-instruction fnstsw(segment)
2518 (:printer floating-point-st ((op #b00000)))
2520 (emit-byte segment #b11011111)
2521 (emit-byte segment #b11100000)))
2523 ;;; Load Control Word.
2525 ;;; src must be a memory location
2526 (define-instruction fldcw(segment src)
2527 (:printer floating-point ((op '(#b001 #b101))))
2529 (emit-byte segment #b11011001)
2530 (emit-fp-op segment src #b101)))
2532 ;;; Store Control Word.
2533 (define-instruction fnstcw(segment dst)
2534 (:printer floating-point ((op '(#b001 #b111))))
2536 (emit-byte segment #b11011001)
2537 (emit-fp-op segment dst #b111)))
2539 ;;; Store FP Environment.
2540 (define-instruction fstenv(segment dst)
2541 (:printer floating-point ((op '(#b001 #b110))))
2543 (emit-byte segment #b11011001)
2544 (emit-fp-op segment dst #b110)))
2546 ;;; Restore FP Environment.
2547 (define-instruction fldenv(segment src)
2548 (:printer floating-point ((op '(#b001 #b100))))
2550 (emit-byte segment #b11011001)
2551 (emit-fp-op segment src #b100)))
2554 (define-instruction fsave(segment dst)
2555 (:printer floating-point ((op '(#b101 #b110))))
2557 (emit-byte segment #b11011101)
2558 (emit-fp-op segment dst #b110)))
2560 ;;; Restore FP State.
2561 (define-instruction frstor(segment src)
2562 (:printer floating-point ((op '(#b101 #b100))))
2564 (emit-byte segment #b11011101)
2565 (emit-fp-op segment src #b100)))
2567 ;;; Clear exceptions.
2568 (define-instruction fnclex(segment)
2569 (:printer floating-point-5 ((op #b00010)))
2571 (emit-byte segment #b11011011)
2572 (emit-byte segment #b11100010)))
2575 (define-instruction fcom (segment src)
2576 (:printer floating-point ((op '(#b000 #b010))))
2578 (emit-byte segment #b11011000)
2579 (emit-fp-op segment src #b010)))
2581 (define-instruction fcomd (segment src)
2582 (:printer floating-point ((op '(#b100 #b010))))
2583 (:printer floating-point-fp ((op '(#b000 #b010))))
2585 (if (fp-reg-tn-p src)
2586 (emit-byte segment #b11011000)
2587 (emit-byte segment #b11011100))
2588 (emit-fp-op segment src #b010)))
2590 ;;; Compare ST1 to ST0, popping the stack twice.
2591 (define-instruction fcompp (segment)
2592 (:printer floating-point-3 ((op '(#b110 #b011001))))
2594 (emit-byte segment #b11011110)
2595 (emit-byte segment #b11011001)))
2597 ;;; unordered comparison
2598 (define-instruction fucom (segment src)
2599 (:printer floating-point-fp ((op '(#b101 #b100))))
2601 (aver (fp-reg-tn-p src))
2602 (emit-byte segment #b11011101)
2603 (emit-fp-op segment src #b100)))
2605 (define-instruction ftst (segment)
2606 (:printer floating-point-no ((op #b00100)))
2608 (emit-byte segment #b11011001)
2609 (emit-byte segment #b11100100)))
2613 (define-instruction fsqrt(segment)
2614 (:printer floating-point-no ((op #b11010)))
2616 (emit-byte segment #b11011001)
2617 (emit-byte segment #b11111010)))
2619 (define-instruction fscale(segment)
2620 (:printer floating-point-no ((op #b11101)))
2622 (emit-byte segment #b11011001)
2623 (emit-byte segment #b11111101)))
2625 (define-instruction fxtract(segment)
2626 (:printer floating-point-no ((op #b10100)))
2628 (emit-byte segment #b11011001)
2629 (emit-byte segment #b11110100)))
2631 (define-instruction fsin(segment)
2632 (:printer floating-point-no ((op #b11110)))
2634 (emit-byte segment #b11011001)
2635 (emit-byte segment #b11111110)))
2637 (define-instruction fcos(segment)
2638 (:printer floating-point-no ((op #b11111)))
2640 (emit-byte segment #b11011001)
2641 (emit-byte segment #b11111111)))
2643 (define-instruction fprem1(segment)
2644 (:printer floating-point-no ((op #b10101)))
2646 (emit-byte segment #b11011001)
2647 (emit-byte segment #b11110101)))
2649 (define-instruction fprem(segment)
2650 (:printer floating-point-no ((op #b11000)))
2652 (emit-byte segment #b11011001)
2653 (emit-byte segment #b11111000)))
2655 (define-instruction fxam (segment)
2656 (:printer floating-point-no ((op #b00101)))
2658 (emit-byte segment #b11011001)
2659 (emit-byte segment #b11100101)))
2661 ;;; These do push/pop to stack and need special handling
2662 ;;; in any VOPs that use them. See the book.
2664 ;;; st0 <- st1*log2(st0)
2665 (define-instruction fyl2x(segment) ; pops stack
2666 (:printer floating-point-no ((op #b10001)))
2668 (emit-byte segment #b11011001)
2669 (emit-byte segment #b11110001)))
2671 (define-instruction fyl2xp1(segment)
2672 (:printer floating-point-no ((op #b11001)))
2674 (emit-byte segment #b11011001)
2675 (emit-byte segment #b11111001)))
2677 (define-instruction f2xm1(segment)
2678 (:printer floating-point-no ((op #b10000)))
2680 (emit-byte segment #b11011001)
2681 (emit-byte segment #b11110000)))
2683 (define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
2684 (:printer floating-point-no ((op #b10010)))
2686 (emit-byte segment #b11011001)
2687 (emit-byte segment #b11110010)))
2689 (define-instruction fpatan(segment) ; POPS STACK
2690 (:printer floating-point-no ((op #b10011)))
2692 (emit-byte segment #b11011001)
2693 (emit-byte segment #b11110011)))
2695 ;;;; loading constants
2697 (define-instruction fldz(segment)
2698 (:printer floating-point-no ((op #b01110)))
2700 (emit-byte segment #b11011001)
2701 (emit-byte segment #b11101110)))
2703 (define-instruction fld1(segment)
2704 (:printer floating-point-no ((op #b01000)))
2706 (emit-byte segment #b11011001)
2707 (emit-byte segment #b11101000)))
2709 (define-instruction fldpi(segment)
2710 (:printer floating-point-no ((op #b01011)))
2712 (emit-byte segment #b11011001)
2713 (emit-byte segment #b11101011)))
2715 (define-instruction fldl2t(segment)
2716 (:printer floating-point-no ((op #b01001)))
2718 (emit-byte segment #b11011001)
2719 (emit-byte segment #b11101001)))
2721 (define-instruction fldl2e(segment)
2722 (:printer floating-point-no ((op #b01010)))
2724 (emit-byte segment #b11011001)
2725 (emit-byte segment #b11101010)))
2727 (define-instruction fldlg2(segment)
2728 (:printer floating-point-no ((op #b01100)))
2730 (emit-byte segment #b11011001)
2731 (emit-byte segment #b11101100)))
2733 (define-instruction fldln2(segment)
2734 (:printer floating-point-no ((op #b01101)))
2736 (emit-byte segment #b11011001)
2737 (emit-byte segment #b11101101)))
2741 (define-instruction cpuid (segment)
2742 (:printer two-bytes ((op '(#b00001111 #b10100010))))
2744 (emit-byte segment #b00001111)
2745 (emit-byte segment #b10100010)))
2747 (define-instruction rdtsc (segment)
2748 (:printer two-bytes ((op '(#b00001111 #b00110001))))
2750 (emit-byte segment #b00001111)
2751 (emit-byte segment #b00110001)))