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 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
25 (defun offset-next (value dstate)
26 (declare (type integer value)
27 (type sb!disassem:disassem-state dstate))
28 (+ (sb!disassem:dstate-next-addr dstate) value))
30 (defparameter *default-address-size*
31 ;; Actually, :DWORD is the only one really supported.
34 (defparameter *byte-reg-names*
35 #(al cl dl bl ah ch dh bh))
36 (defparameter *word-reg-names*
37 #(ax cx dx bx sp bp si di))
38 (defparameter *dword-reg-names*
39 #(eax ecx edx ebx esp ebp esi edi))
41 (defun print-reg-with-width (value width stream dstate)
42 (declare (ignore dstate))
43 (princ (aref (ecase width
44 (:byte *byte-reg-names*)
45 (:word *word-reg-names*)
46 (:dword *dword-reg-names*))
49 ;; XXX plus should do some source-var notes
52 (defun print-reg (value stream dstate)
53 (declare (type reg value)
55 (type sb!disassem:disassem-state dstate))
56 (print-reg-with-width value
57 (sb!disassem:dstate-get-prop dstate 'width)
61 (defun print-word-reg (value stream dstate)
62 (declare (type reg value)
64 (type sb!disassem:disassem-state dstate))
65 (print-reg-with-width value
66 (or (sb!disassem:dstate-get-prop dstate 'word-width)
67 +default-operand-size+)
71 (defun print-byte-reg (value stream dstate)
72 (declare (type reg value)
74 (type sb!disassem:disassem-state dstate))
75 (print-reg-with-width value :byte stream dstate))
77 (defun print-addr-reg (value stream dstate)
78 (declare (type reg value)
80 (type sb!disassem:disassem-state dstate))
81 (print-reg-with-width value *default-address-size* stream dstate))
83 (defun print-reg/mem (value stream dstate)
84 (declare (type (or list reg) value)
86 (type sb!disassem:disassem-state dstate))
87 (if (typep value 'reg)
88 (print-reg value stream dstate)
89 (print-mem-access value stream nil dstate)))
91 ;; Same as print-reg/mem, but prints an explicit size indicator for
93 (defun print-sized-reg/mem (value stream dstate)
94 (declare (type (or list reg) value)
96 (type sb!disassem:disassem-state dstate))
97 (if (typep value 'reg)
98 (print-reg value stream dstate)
99 (print-mem-access value stream t dstate)))
101 (defun print-byte-reg/mem (value stream dstate)
102 (declare (type (or list reg) value)
104 (type sb!disassem:disassem-state dstate))
105 (if (typep value 'reg)
106 (print-byte-reg value stream dstate)
107 (print-mem-access value stream t dstate)))
109 (defun print-label (value stream dstate)
110 (declare (ignore dstate))
111 (sb!disassem:princ16 value stream))
113 ;;; Returns either an integer, meaning a register, or a list of
114 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
115 ;;; may be missing or nil to indicate that it's not used or has the
116 ;;; obvious default value (e.g., 1 for the index-scale).
117 (defun prefilter-reg/mem (value dstate)
118 (declare (type list value)
119 (type sb!disassem:disassem-state dstate))
120 (let ((mod (car value))
122 (declare (type (unsigned-byte 2) mod)
123 (type (unsigned-byte 3) r/m))
129 (let ((sib (sb!disassem:read-suffix 8 dstate)))
130 (declare (type (unsigned-byte 8) sib))
131 (let ((base-reg (ldb (byte 3 0) sib))
132 (index-reg (ldb (byte 3 3) sib))
133 (index-scale (ldb (byte 2 6) sib)))
134 (declare (type (unsigned-byte 3) base-reg index-reg)
135 (type (unsigned-byte 2) index-scale))
139 (if (= base-reg #b101)
140 (sb!disassem:read-signed-suffix 32 dstate)
143 (sb!disassem:read-signed-suffix 8 dstate))
145 (sb!disassem:read-signed-suffix 32 dstate)))))
146 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
148 (if (= index-reg #b100) nil index-reg)
149 (ash 1 index-scale))))))
150 ((and (= mod #b00) (= r/m #b101))
151 (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
155 (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
157 (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
160 ;;; This is a sort of bogus prefilter that just stores the info globally for
161 ;;; other people to use; it probably never gets printed.
162 (defun prefilter-width (value dstate)
163 (setf (sb!disassem:dstate-get-prop dstate 'width)
167 ;; set by a prefix instruction
168 (or (sb!disassem:dstate-get-prop dstate 'word-width)
169 +default-operand-size+)))
170 (when (not (eql word-width +default-operand-size+))
172 (setf (sb!disassem:dstate-get-prop dstate 'word-width)
173 +default-operand-size+))
176 (defun read-address (value dstate)
177 (declare (ignore value)) ; always nil anyway
178 (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
180 (defun width-bits (width)
190 ;;;; disassembler argument types
192 (sb!disassem:define-argument-type displacement
194 :use-label #'offset-next
195 :printer #'(lambda (value stream dstate)
196 (sb!disassem:maybe-note-assembler-routine value nil dstate)
197 (print-label value stream dstate)))
199 (sb!disassem:define-argument-type accum
200 :printer #'(lambda (value stream dstate)
201 (declare (ignore value)
203 (type sb!disassem:disassem-state dstate))
204 (print-reg 0 stream dstate))
207 (sb!disassem:define-argument-type word-accum
208 :printer #'(lambda (value stream dstate)
209 (declare (ignore value)
211 (type sb!disassem:disassem-state dstate))
212 (print-word-reg 0 stream dstate)))
214 (sb!disassem:define-argument-type reg
215 :printer #'print-reg)
217 (sb!disassem:define-argument-type addr-reg
218 :printer #'print-addr-reg)
220 (sb!disassem:define-argument-type word-reg
221 :printer #'print-word-reg)
223 (sb!disassem:define-argument-type imm-addr
224 :prefilter #'read-address
225 :printer #'print-label)
227 (sb!disassem:define-argument-type imm-data
228 :prefilter #'(lambda (value dstate)
229 (declare (ignore value)) ; always nil anyway
230 (sb!disassem:read-suffix
231 (width-bits (sb!disassem:dstate-get-prop dstate 'width))
235 (sb!disassem:define-argument-type signed-imm-data
236 :prefilter #'(lambda (value dstate)
237 (declare (ignore value)) ; always nil anyway
238 (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
239 (sb!disassem:read-signed-suffix (width-bits width) dstate)))
242 (sb!disassem:define-argument-type signed-imm-byte
243 :prefilter #'(lambda (value dstate)
244 (declare (ignore value)) ; always nil anyway
245 (sb!disassem:read-signed-suffix 8 dstate)))
247 (sb!disassem:define-argument-type signed-imm-dword
248 :prefilter #'(lambda (value dstate)
249 (declare (ignore value)) ; always nil anyway
250 (sb!disassem:read-signed-suffix 32 dstate)))
252 (sb!disassem:define-argument-type imm-word
253 :prefilter #'(lambda (value dstate)
254 (declare (ignore value)) ; always nil anyway
256 (or (sb!disassem:dstate-get-prop dstate 'word-width)
257 +default-operand-size+)))
258 (sb!disassem:read-suffix (width-bits width) dstate))))
260 ;;; needed for the ret imm16 instruction
261 (sb!disassem:define-argument-type imm-word-16
262 :prefilter #'(lambda (value dstate)
263 (declare (ignore value)) ; always nil anyway
264 (sb!disassem:read-suffix 16 dstate)))
266 (sb!disassem:define-argument-type reg/mem
267 :prefilter #'prefilter-reg/mem
268 :printer #'print-reg/mem)
269 (sb!disassem:define-argument-type sized-reg/mem
270 ;; Same as reg/mem, but prints an explicit size indicator for
271 ;; memory references.
272 :prefilter #'prefilter-reg/mem
273 :printer #'print-sized-reg/mem)
274 (sb!disassem:define-argument-type byte-reg/mem
275 :prefilter #'prefilter-reg/mem
276 :printer #'print-byte-reg/mem)
279 (eval-when (:compile-toplevel :load-toplevel :execute)
280 (defun print-fp-reg (value stream dstate)
281 (declare (ignore dstate))
282 (format stream "FR~D" value))
283 (defun prefilter-fp-reg (value dstate)
285 (declare (ignore dstate))
288 (sb!disassem:define-argument-type fp-reg
289 :prefilter #'prefilter-fp-reg
290 :printer #'print-fp-reg)
292 (sb!disassem:define-argument-type width
293 :prefilter #'prefilter-width
294 :printer #'(lambda (value stream dstate)
297 (and (numberp value) (zerop value))) ; zzz jrd
300 ;; set by a prefix instruction
301 (or (sb!disassem:dstate-get-prop dstate 'word-width)
302 +default-operand-size+)))
303 (princ (schar (symbol-name word-width) 0) stream)))))
305 (eval-when (:compile-toplevel :load-toplevel :execute)
306 (defparameter *conditions*
309 (:b . 2) (:nae . 2) (:c . 2)
310 (:nb . 3) (:ae . 3) (:nc . 3)
311 (:eq . 4) (:e . 4) (:z . 4)
318 (:np . 11) (:po . 11)
319 (:l . 12) (:nge . 12)
320 (:nl . 13) (:ge . 13)
321 (:le . 14) (:ng . 14)
322 (:nle . 15) (:g . 15)))
323 (defparameter *condition-name-vec*
324 (let ((vec (make-array 16 :initial-element nil)))
325 (dolist (cond *conditions*)
326 (when (null (aref vec (cdr cond)))
327 (setf (aref vec (cdr cond)) (car cond))))
331 ;;; Set assembler parameters. (In CMU CL, this was done with
332 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
333 (eval-when (:compile-toplevel :load-toplevel :execute)
334 (setf sb!assem:*assem-scheduler-p* nil))
336 (sb!disassem:define-argument-type condition-code
337 :printer *condition-name-vec*)
339 (defun conditional-opcode (condition)
340 (cdr (assoc condition *conditions* :test #'eq)))
342 ;;;; disassembler instruction formats
344 (eval-when (:compile-toplevel :execute)
345 (defun swap-if (direction field1 separator field2)
346 `(:if (,direction :constant 0)
347 (,field1 ,separator ,field2)
348 (,field2 ,separator ,field1))))
350 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
351 (op :field (byte 8 0))
356 (sb!disassem:define-instruction-format (simple 8)
357 (op :field (byte 7 1))
358 (width :field (byte 1 0) :type 'width)
363 ;;; Same as simple, but with direction bit
364 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
365 (op :field (byte 6 2))
366 (dir :field (byte 1 1)))
368 ;;; Same as simple, but with the immediate value occurring by default,
369 ;;; and with an appropiate printer.
370 (sb!disassem:define-instruction-format (accum-imm 8
372 :default-printer '(:name
373 :tab accum ", " imm))
374 (imm :type 'imm-data))
376 (sb!disassem:define-instruction-format (reg-no-width 8
377 :default-printer '(:name :tab reg))
378 (op :field (byte 5 3))
379 (reg :field (byte 3 0) :type 'word-reg)
381 (accum :type 'word-accum)
384 ;;; adds a width field to reg-no-width
385 (sb!disassem:define-instruction-format (reg 8
386 :default-printer '(:name :tab reg))
387 (op :field (byte 4 4))
388 (width :field (byte 1 3) :type 'width)
389 (reg :field (byte 3 0) :type 'reg)
395 ;;; Same as reg, but with direction bit
396 (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
397 (op :field (byte 3 5))
398 (dir :field (byte 1 4)))
400 (sb!disassem:define-instruction-format (two-bytes 16
401 :default-printer '(:name))
402 (op :fields (list (byte 8 0) (byte 8 8))))
404 (sb!disassem:define-instruction-format (reg-reg/mem 16
406 `(:name :tab reg ", " reg/mem))
407 (op :field (byte 7 1))
408 (width :field (byte 1 0) :type 'width)
409 (reg/mem :fields (list (byte 2 14) (byte 3 8))
411 (reg :field (byte 3 11) :type 'reg)
415 ;;; same as reg-reg/mem, but with direction bit
416 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
417 :include 'reg-reg/mem
421 ,(swap-if 'dir 'reg/mem ", " 'reg)))
422 (op :field (byte 6 2))
423 (dir :field (byte 1 1)))
425 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
426 (sb!disassem:define-instruction-format (reg/mem 16
427 :default-printer '(:name :tab reg/mem))
428 (op :fields (list (byte 7 1) (byte 3 11)))
429 (width :field (byte 1 0) :type 'width)
430 (reg/mem :fields (list (byte 2 14) (byte 3 8))
431 :type 'sized-reg/mem)
435 ;;; Same as reg/mem, but with the immediate value occurring by default,
436 ;;; and with an appropiate printer.
437 (sb!disassem:define-instruction-format (reg/mem-imm 16
440 '(:name :tab reg/mem ", " imm))
441 (reg/mem :type 'sized-reg/mem)
442 (imm :type 'imm-data))
444 ;;; Same as reg/mem, but with using the accumulator in the default printer
445 (sb!disassem:define-instruction-format
447 :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
448 (reg/mem :type 'reg/mem) ; don't need a size
449 (accum :type 'accum))
451 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
452 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
454 `(:name :tab reg ", " reg/mem))
455 (prefix :field (byte 8 0) :value #b00001111)
456 (op :field (byte 7 9))
457 (width :field (byte 1 8) :type 'width)
458 (reg/mem :fields (list (byte 2 22) (byte 3 16))
460 (reg :field (byte 3 19) :type 'reg)
464 ;;; Same as reg/mem, but with a prefix of #b00001111
465 (sb!disassem:define-instruction-format (ext-reg/mem 24
466 :default-printer '(:name :tab reg/mem))
467 (prefix :field (byte 8 0) :value #b00001111)
468 (op :fields (list (byte 7 9) (byte 3 19)))
469 (width :field (byte 1 8) :type 'width)
470 (reg/mem :fields (list (byte 2 22) (byte 3 16))
471 :type 'sized-reg/mem)
475 ;;;; This section was added by jrd, for fp instructions.
477 ;;; regular fp inst to/from registers/memory
478 (sb!disassem:define-instruction-format (floating-point 16
480 `(:name :tab reg/mem))
481 (prefix :field (byte 5 3) :value #b11011)
482 (op :fields (list (byte 3 0) (byte 3 11)))
483 (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
485 ;;; fp insn to/from fp reg
486 (sb!disassem:define-instruction-format (floating-point-fp 16
487 :default-printer `(:name :tab fp-reg))
488 (prefix :field (byte 5 3) :value #b11011)
489 (suffix :field (byte 2 14) :value #b11)
490 (op :fields (list (byte 3 0) (byte 3 11)))
491 (fp-reg :field (byte 3 8) :type 'fp-reg))
493 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
494 (sb!disassem:define-instruction-format
495 (floating-point-fp-d 16
496 :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
497 (prefix :field (byte 5 3) :value #b11011)
498 (suffix :field (byte 2 14) :value #b11)
499 (op :fields (list (byte 2 0) (byte 3 11)))
500 (d :field (byte 1 2))
501 (fp-reg :field (byte 3 8) :type 'fp-reg))
504 ;;; (added by (?) pfw)
505 ;;; fp no operand isns
506 (sb!disassem:define-instruction-format (floating-point-no 16
507 :default-printer '(:name))
508 (prefix :field (byte 8 0) :value #b11011001)
509 (suffix :field (byte 3 13) :value #b111)
510 (op :field (byte 5 8)))
512 (sb!disassem:define-instruction-format (floating-point-3 16
513 :default-printer '(:name))
514 (prefix :field (byte 5 3) :value #b11011)
515 (suffix :field (byte 2 14) :value #b11)
516 (op :fields (list (byte 3 0) (byte 6 8))))
518 (sb!disassem:define-instruction-format (floating-point-5 16
519 :default-printer '(:name))
520 (prefix :field (byte 8 0) :value #b11011011)
521 (suffix :field (byte 3 13) :value #b111)
522 (op :field (byte 5 8)))
524 (sb!disassem:define-instruction-format (floating-point-st 16
525 :default-printer '(:name))
526 (prefix :field (byte 8 0) :value #b11011111)
527 (suffix :field (byte 3 13) :value #b111)
528 (op :field (byte 5 8)))
530 (sb!disassem:define-instruction-format (string-op 8
532 :default-printer '(:name width)))
534 (sb!disassem:define-instruction-format (short-cond-jump 16)
535 (op :field (byte 4 4))
536 (cc :field (byte 4 0) :type 'condition-code)
537 (label :field (byte 8 8) :type 'displacement))
539 (sb!disassem:define-instruction-format (short-jump 16
540 :default-printer '(:name :tab label))
541 (const :field (byte 4 4) :value #b1110)
542 (op :field (byte 4 0))
543 (label :field (byte 8 8) :type 'displacement))
545 (sb!disassem:define-instruction-format (near-cond-jump 16)
546 (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
547 (cc :field (byte 4 8) :type 'condition-code)
548 ;; The disassembler currently doesn't let you have an instruction > 32 bits
549 ;; long, so we fake it by using a prefilter to read the offset.
550 (label :type 'displacement
551 :prefilter #'(lambda (value dstate)
552 (declare (ignore value)) ; always nil anyway
553 (sb!disassem:read-signed-suffix 32 dstate))))
555 (sb!disassem:define-instruction-format (near-jump 8
556 :default-printer '(:name :tab label))
557 (op :field (byte 8 0))
558 ;; The disassembler currently doesn't let you have an instruction > 32 bits
559 ;; long, so we fake it by using a prefilter to read the address.
560 (label :type 'displacement
561 :prefilter #'(lambda (value dstate)
562 (declare (ignore value)) ; always nil anyway
563 (sb!disassem:read-signed-suffix 32 dstate))))
566 (sb!disassem:define-instruction-format (cond-set 24
567 :default-printer '('set cc :tab reg/mem))
568 (prefix :field (byte 8 0) :value #b00001111)
569 (op :field (byte 4 12) :value #b1001)
570 (cc :field (byte 4 8) :type 'condition-code)
571 (reg/mem :fields (list (byte 2 22) (byte 3 16))
573 (reg :field (byte 3 19) :value #b000))
575 (sb!disassem:define-instruction-format (enter-format 32
576 :default-printer '(:name
578 (:unless (:constant 0)
580 (op :field (byte 8 0))
581 (disp :field (byte 16 8))
582 (level :field (byte 8 24)))
584 ;;; Single byte instruction with an immediate byte argument.
585 (sb!disassem:define-instruction-format (byte-imm 16
586 :default-printer '(:name :tab code))
587 (op :field (byte 8 0))
588 (code :field (byte 8 8)))
590 ;;;; primitive emitters
592 (define-bitfield-emitter emit-word 16
595 (define-bitfield-emitter emit-dword 32
598 (define-bitfield-emitter emit-byte-with-reg 8
599 (byte 5 3) (byte 3 0))
601 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
602 (byte 2 6) (byte 3 3) (byte 3 0))
604 (define-bitfield-emitter emit-sib-byte 8
605 (byte 2 6) (byte 3 3) (byte 3 0))
609 (defun emit-absolute-fixup (segment fixup)
610 (note-fixup segment :absolute fixup)
611 (let ((offset (fixup-offset fixup)))
613 (emit-back-patch segment
614 4 ; FIXME: sb!vm:n-word-bytes
615 #'(lambda (segment posn)
616 (declare (ignore posn))
618 (- (+ (component-header-length)
619 (or (label-position offset)
621 other-pointer-lowtag))))
622 (emit-dword segment (or offset 0)))))
624 (defun emit-relative-fixup (segment fixup)
625 (note-fixup segment :relative fixup)
626 (emit-dword segment (or (fixup-offset fixup) 0)))
628 ;;;; the effective-address (ea) structure
630 (defun reg-tn-encoding (tn)
631 (declare (type tn tn))
632 (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
633 (let ((offset (tn-offset tn)))
634 (logior (ash (logand offset 1) 2)
637 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
639 (size nil :type (member :byte :word :dword))
640 (base nil :type (or tn null))
641 (index nil :type (or tn null))
642 (scale 1 :type (member 1 2 4 8))
643 (disp 0 :type (or (signed-byte 32) fixup)))
644 (def!method print-object ((ea ea) stream)
645 (cond ((or *print-escape* *print-readably*)
646 (print-unreadable-object (ea stream :type t)
648 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
652 (let ((scale (ea-scale ea)))
653 (if (= scale 1) nil scale))
656 (format stream "~A PTR [" (symbol-name (ea-size ea)))
658 (write-string (sb!c::location-print-name (ea-base ea)) stream)
660 (write-string "+" stream)))
662 (write-string (sb!c::location-print-name (ea-index ea)) stream))
663 (unless (= (ea-scale ea) 1)
664 (format stream "*~A" (ea-scale ea)))
665 (typecase (ea-disp ea)
668 (format stream "~@D" (ea-disp ea)))
670 (format stream "+~A" (ea-disp ea))))
671 (write-char #\] stream))))
673 (defun emit-ea (segment thing reg &optional allow-constants)
676 (ecase (sb-name (sc-sb (tn-sc thing)))
678 (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
680 ;; Convert stack tns into an index off of EBP.
681 (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
682 (cond ((< -128 disp 127)
683 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
684 (emit-byte segment disp))
686 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
687 (emit-dword segment disp)))))
689 (unless allow-constants
691 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
692 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
693 (emit-absolute-fixup segment
696 (- (* (tn-offset thing) n-word-bytes)
697 other-pointer-lowtag))))))
699 (let* ((base (ea-base thing))
700 (index (ea-index thing))
701 (scale (ea-scale thing))
702 (disp (ea-disp thing))
703 (mod (cond ((or (null base)
705 (not (= (reg-tn-encoding base) #b101))))
707 ((and (fixnump disp) (<= -128 disp 127))
711 (r/m (cond (index #b100)
713 (t (reg-tn-encoding base)))))
714 (emit-mod-reg-r/m-byte segment mod reg r/m)
716 (let ((ss (1- (integer-length scale)))
717 (index (if (null index)
719 (let ((index (reg-tn-encoding index)))
721 (error "can't index off of ESP")
723 (base (if (null base)
725 (reg-tn-encoding base))))
726 (emit-sib-byte segment ss index base)))
728 (emit-byte segment disp))
729 ((or (= mod #b10) (null base))
731 (emit-absolute-fixup segment disp)
732 (emit-dword segment disp))))))
734 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
735 (emit-absolute-fixup segment thing))))
737 (defun fp-reg-tn-p (thing)
739 (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
741 ;;; like the above, but for fp-instructions--jrd
742 (defun emit-fp-op (segment thing op)
743 (if (fp-reg-tn-p thing)
744 (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
747 (emit-ea segment thing op)))
749 (defun byte-reg-p (thing)
751 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
752 (member (sc-name (tn-sc thing)) *byte-sc-names*)
755 (defun byte-ea-p (thing)
757 (ea (eq (ea-size thing) :byte))
759 (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
762 (defun word-reg-p (thing)
764 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
765 (member (sc-name (tn-sc thing)) *word-sc-names*)
768 (defun word-ea-p (thing)
770 (ea (eq (ea-size thing) :word))
771 (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
774 (defun dword-reg-p (thing)
776 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
777 (member (sc-name (tn-sc thing)) *dword-sc-names*)
780 (defun dword-ea-p (thing)
782 (ea (eq (ea-size thing) :dword))
784 (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
787 (defun register-p (thing)
789 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
791 (defun accumulator-p (thing)
792 (and (register-p thing)
793 (= (tn-offset thing) 0)))
797 (defconstant +operand-size-prefix-byte+ #b01100110)
799 (defconstant +default-operand-size+ :dword)
801 (defun maybe-emit-operand-size-prefix (segment size)
802 (unless (or (eq size :byte) (eq size +default-operand-size+))
803 (emit-byte segment +operand-size-prefix-byte+)))
805 (defun operand-size (thing)
808 ;; FIXME: might as well be COND instead of having to use #. readmacro
809 ;; to hack up the code
810 (case (sc-name (tn-sc thing))
817 ;; added by jrd: float-registers is a separate size (?)
823 (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
829 (defun matching-operand-size (dst src)
830 (let ((dst-size (operand-size dst))
831 (src-size (operand-size src)))
834 (if (eq dst-size src-size)
836 (error "size mismatch: ~S is a ~S and ~S is a ~S."
837 dst dst-size src src-size))
841 (error "can't tell the size of either ~S or ~S" dst src)))))
843 (defun emit-sized-immediate (segment size value)
846 (emit-byte segment value))
848 (emit-word segment value))
850 (emit-dword segment value))))
852 ;;;; general data transfer
854 (define-instruction mov (segment dst src)
855 ;; immediate to register
856 (:printer reg ((op #b1011) (imm nil :type 'imm-data))
857 '(:name :tab reg ", " imm))
858 ;; absolute mem to/from accumulator
859 (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
860 `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
861 ;; register to/from register/memory
862 (:printer reg-reg/mem-dir ((op #b100010)))
863 ;; immediate to register/memory
864 (:printer reg/mem-imm ((op '(#b1100011 #b000))))
867 (let ((size (matching-operand-size dst src)))
868 (maybe-emit-operand-size-prefix segment size)
869 (cond ((register-p dst)
870 (cond ((integerp src)
871 (emit-byte-with-reg segment
875 (reg-tn-encoding dst))
876 (emit-sized-immediate segment size src))
877 ((and (fixup-p src) (accumulator-p dst))
882 (emit-absolute-fixup segment src))
888 (emit-ea segment src (reg-tn-encoding dst) t))))
889 ((and (fixup-p dst) (accumulator-p src))
890 (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
891 (emit-absolute-fixup segment dst))
893 (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
894 (emit-ea segment dst #b000)
895 (emit-sized-immediate segment size src))
897 (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
898 (emit-ea segment dst (reg-tn-encoding src)))
900 (aver (eq size :dword))
901 (emit-byte segment #b11000111)
902 (emit-ea segment dst #b000)
903 (emit-absolute-fixup segment src))
905 (error "bogus arguments to MOV: ~S ~S" dst src))))))
907 (defun emit-move-with-extension (segment dst src opcode)
908 (aver (register-p dst))
909 (let ((dst-size (operand-size dst))
910 (src-size (operand-size src)))
913 (aver (eq src-size :byte))
914 (maybe-emit-operand-size-prefix segment :word)
915 (emit-byte segment #b00001111)
916 (emit-byte segment opcode)
917 (emit-ea segment src (reg-tn-encoding dst)))
921 (maybe-emit-operand-size-prefix segment :dword)
922 (emit-byte segment #b00001111)
923 (emit-byte segment opcode)
924 (emit-ea segment src (reg-tn-encoding dst)))
926 (emit-byte segment #b00001111)
927 (emit-byte segment (logior opcode 1))
928 (emit-ea segment src (reg-tn-encoding dst))))))))
930 (define-instruction movsx (segment dst src)
931 (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
932 (:emitter (emit-move-with-extension segment dst src #b10111110)))
934 (define-instruction movzx (segment dst src)
935 (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
936 (:emitter (emit-move-with-extension segment dst src #b10110110)))
938 (define-instruction push (segment src)
940 (:printer reg-no-width ((op #b01010)))
942 (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
944 (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
946 (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
948 ;; ### segment registers?
951 (cond ((integerp src)
952 (cond ((<= -128 src 127)
953 (emit-byte segment #b01101010)
954 (emit-byte segment src))
956 (emit-byte segment #b01101000)
957 (emit-dword segment src))))
959 ;; Interpret the fixup as an immediate dword to push.
960 (emit-byte segment #b01101000)
961 (emit-absolute-fixup segment src))
963 (let ((size (operand-size src)))
964 (aver (not (eq size :byte)))
965 (maybe-emit-operand-size-prefix segment size)
966 (cond ((register-p src)
967 (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
969 (emit-byte segment #b11111111)
970 (emit-ea segment src #b110 t))))))))
972 (define-instruction pusha (segment)
973 (:printer byte ((op #b01100000)))
975 (emit-byte segment #b01100000)))
977 (define-instruction pop (segment dst)
978 (:printer reg-no-width ((op #b01011)))
979 (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
981 (let ((size (operand-size dst)))
982 (aver (not (eq size :byte)))
983 (maybe-emit-operand-size-prefix segment size)
984 (cond ((register-p dst)
985 (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
987 (emit-byte segment #b10001111)
988 (emit-ea segment dst #b000))))))
990 (define-instruction popa (segment)
991 (:printer byte ((op #b01100001)))
993 (emit-byte segment #b01100001)))
995 (define-instruction xchg (segment operand1 operand2)
996 ;; Register with accumulator.
997 (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
998 ;; Register/Memory with Register.
999 (:printer reg-reg/mem ((op #b1000011)))
1001 (let ((size (matching-operand-size operand1 operand2)))
1002 (maybe-emit-operand-size-prefix segment size)
1003 (labels ((xchg-acc-with-something (acc something)
1004 (if (and (not (eq size :byte)) (register-p something))
1005 (emit-byte-with-reg segment
1007 (reg-tn-encoding something))
1008 (xchg-reg-with-something acc something)))
1009 (xchg-reg-with-something (reg something)
1010 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1011 (emit-ea segment something (reg-tn-encoding reg))))
1012 (cond ((accumulator-p operand1)
1013 (xchg-acc-with-something operand1 operand2))
1014 ((accumulator-p operand2)
1015 (xchg-acc-with-something operand2 operand1))
1016 ((register-p operand1)
1017 (xchg-reg-with-something operand1 operand2))
1018 ((register-p operand2)
1019 (xchg-reg-with-something operand2 operand1))
1021 (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1023 (define-instruction lea (segment dst src)
1024 (:printer reg-reg/mem ((op #b1000110) (width 1)))
1026 (aver (dword-reg-p dst))
1027 (emit-byte segment #b10001101)
1028 (emit-ea segment src (reg-tn-encoding dst))))
1030 (define-instruction cmpxchg (segment dst src)
1031 ;; Register/Memory with Register.
1032 (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1034 (aver (register-p src))
1035 (let ((size (matching-operand-size src dst)))
1036 (maybe-emit-operand-size-prefix segment size)
1037 (emit-byte segment #b00001111)
1038 (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1039 (emit-ea segment dst (reg-tn-encoding src)))))
1042 ;;;; flag control instructions
1044 ;;; CLC -- Clear Carry Flag.
1045 (define-instruction clc (segment)
1046 (:printer byte ((op #b11111000)))
1048 (emit-byte segment #b11111000)))
1050 ;;; CLD -- Clear Direction Flag.
1051 (define-instruction cld (segment)
1052 (:printer byte ((op #b11111100)))
1054 (emit-byte segment #b11111100)))
1056 ;;; CLI -- Clear Iterrupt Enable Flag.
1057 (define-instruction cli (segment)
1058 (:printer byte ((op #b11111010)))
1060 (emit-byte segment #b11111010)))
1062 ;;; CMC -- Complement Carry Flag.
1063 (define-instruction cmc (segment)
1064 (:printer byte ((op #b11110101)))
1066 (emit-byte segment #b11110101)))
1068 ;;; LAHF -- Load AH into flags.
1069 (define-instruction lahf (segment)
1070 (:printer byte ((op #b10011111)))
1072 (emit-byte segment #b10011111)))
1074 ;;; POPF -- Pop flags.
1075 (define-instruction popf (segment)
1076 (:printer byte ((op #b10011101)))
1078 (emit-byte segment #b10011101)))
1080 ;;; PUSHF -- push flags.
1081 (define-instruction pushf (segment)
1082 (:printer byte ((op #b10011100)))
1084 (emit-byte segment #b10011100)))
1086 ;;; SAHF -- Store AH into flags.
1087 (define-instruction sahf (segment)
1088 (:printer byte ((op #b10011110)))
1090 (emit-byte segment #b10011110)))
1092 ;;; STC -- Set Carry Flag.
1093 (define-instruction stc (segment)
1094 (:printer byte ((op #b11111001)))
1096 (emit-byte segment #b11111001)))
1098 ;;; STD -- Set Direction Flag.
1099 (define-instruction std (segment)
1100 (:printer byte ((op #b11111101)))
1102 (emit-byte segment #b11111101)))
1104 ;;; STI -- Set Interrupt Enable Flag.
1105 (define-instruction sti (segment)
1106 (:printer byte ((op #b11111011)))
1108 (emit-byte segment #b11111011)))
1112 (defun emit-random-arith-inst (name segment dst src opcode
1113 &optional allow-constants)
1114 (let ((size (matching-operand-size dst src)))
1115 (maybe-emit-operand-size-prefix segment size)
1118 (cond ((and (not (eq size :byte)) (<= -128 src 127))
1119 (emit-byte segment #b10000011)
1120 (emit-ea segment dst opcode)
1121 (emit-byte segment src))
1122 ((accumulator-p dst)
1129 (emit-sized-immediate segment size src))
1131 (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1132 (emit-ea segment dst opcode)
1133 (emit-sized-immediate segment size src))))
1138 (if (eq size :byte) #b00000000 #b00000001)))
1139 (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1144 (if (eq size :byte) #b00000010 #b00000011)))
1145 (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1147 (error "bogus operands to ~A" name)))))
1149 (eval-when (:compile-toplevel :execute)
1150 (defun arith-inst-printer-list (subop)
1151 `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1152 (reg/mem-imm ((op (#b1000000 ,subop))))
1153 (reg/mem-imm ((op (#b1000001 ,subop))
1154 (imm nil :type signed-imm-byte)))
1155 (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1158 (define-instruction add (segment dst src)
1159 (:printer-list (arith-inst-printer-list #b000))
1160 (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
1162 (define-instruction adc (segment dst src)
1163 (:printer-list (arith-inst-printer-list #b010))
1164 (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1166 (define-instruction sub (segment dst src)
1167 (:printer-list (arith-inst-printer-list #b101))
1168 (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
1170 (define-instruction sbb (segment dst src)
1171 (:printer-list (arith-inst-printer-list #b011))
1172 (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1174 (define-instruction cmp (segment dst src)
1175 (:printer-list (arith-inst-printer-list #b111))
1176 (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1178 (define-instruction inc (segment dst)
1180 (:printer reg-no-width ((op #b01000)))
1182 (:printer reg/mem ((op '(#b1111111 #b000))))
1184 (let ((size (operand-size dst)))
1185 (maybe-emit-operand-size-prefix segment size)
1186 (cond ((and (not (eq size :byte)) (register-p dst))
1187 (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1189 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1190 (emit-ea segment dst #b000))))))
1192 (define-instruction dec (segment dst)
1194 (:printer reg-no-width ((op #b01001)))
1196 (:printer reg/mem ((op '(#b1111111 #b001))))
1198 (let ((size (operand-size dst)))
1199 (maybe-emit-operand-size-prefix segment size)
1200 (cond ((and (not (eq size :byte)) (register-p dst))
1201 (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1203 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1204 (emit-ea segment dst #b001))))))
1206 (define-instruction neg (segment dst)
1207 (:printer reg/mem ((op '(#b1111011 #b011))))
1209 (let ((size (operand-size dst)))
1210 (maybe-emit-operand-size-prefix segment size)
1211 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1212 (emit-ea segment dst #b011))))
1214 (define-instruction aaa (segment)
1215 (:printer byte ((op #b00110111)))
1217 (emit-byte segment #b00110111)))
1219 (define-instruction aas (segment)
1220 (:printer byte ((op #b00111111)))
1222 (emit-byte segment #b00111111)))
1224 (define-instruction daa (segment)
1225 (:printer byte ((op #b00100111)))
1227 (emit-byte segment #b00100111)))
1229 (define-instruction das (segment)
1230 (:printer byte ((op #b00101111)))
1232 (emit-byte segment #b00101111)))
1234 (define-instruction mul (segment dst src)
1235 (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1237 (let ((size (matching-operand-size dst src)))
1238 (aver (accumulator-p dst))
1239 (maybe-emit-operand-size-prefix segment size)
1240 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1241 (emit-ea segment src #b100))))
1243 (define-instruction imul (segment dst &optional src1 src2)
1244 (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1245 (:printer ext-reg-reg/mem ((op #b1010111)))
1246 (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word))
1247 '(:name :tab reg ", " reg/mem ", " imm))
1248 (:printer reg-reg/mem ((op #b0110101) (width 1)
1249 (imm nil :type 'signed-imm-byte))
1250 '(:name :tab reg ", " reg/mem ", " imm))
1252 (flet ((r/m-with-immed-to-reg (reg r/m immed)
1253 (let* ((size (matching-operand-size reg r/m))
1254 (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1255 (maybe-emit-operand-size-prefix segment size)
1256 (emit-byte segment (if sx #b01101011 #b01101001))
1257 (emit-ea segment r/m (reg-tn-encoding reg))
1259 (emit-byte segment immed)
1260 (emit-sized-immediate segment size immed)))))
1262 (r/m-with-immed-to-reg dst src1 src2))
1265 (r/m-with-immed-to-reg dst dst src1)
1266 (let ((size (matching-operand-size dst src1)))
1267 (maybe-emit-operand-size-prefix segment size)
1268 (emit-byte segment #b00001111)
1269 (emit-byte segment #b10101111)
1270 (emit-ea segment src1 (reg-tn-encoding dst)))))
1272 (let ((size (operand-size dst)))
1273 (maybe-emit-operand-size-prefix segment size)
1274 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1275 (emit-ea segment dst #b101)))))))
1277 (define-instruction div (segment dst src)
1278 (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1280 (let ((size (matching-operand-size dst src)))
1281 (aver (accumulator-p dst))
1282 (maybe-emit-operand-size-prefix segment size)
1283 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1284 (emit-ea segment src #b110))))
1286 (define-instruction idiv (segment dst src)
1287 (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1289 (let ((size (matching-operand-size dst src)))
1290 (aver (accumulator-p dst))
1291 (maybe-emit-operand-size-prefix segment size)
1292 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1293 (emit-ea segment src #b111))))
1295 (define-instruction aad (segment)
1296 (:printer two-bytes ((op '(#b11010101 #b00001010))))
1298 (emit-byte segment #b11010101)
1299 (emit-byte segment #b00001010)))
1301 (define-instruction aam (segment)
1302 (:printer two-bytes ((op '(#b11010100 #b00001010))))
1304 (emit-byte segment #b11010100)
1305 (emit-byte segment #b00001010)))
1307 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1308 (define-instruction cbw (segment)
1310 (maybe-emit-operand-size-prefix segment :word)
1311 (emit-byte segment #b10011000)))
1313 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1314 (define-instruction cwde (segment)
1316 (maybe-emit-operand-size-prefix segment :dword)
1317 (emit-byte segment #b10011000)))
1319 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1320 (define-instruction cwd (segment)
1322 (maybe-emit-operand-size-prefix segment :word)
1323 (emit-byte segment #b10011001)))
1325 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1326 (define-instruction cdq (segment)
1327 (:printer byte ((op #b10011001)))
1329 (maybe-emit-operand-size-prefix segment :dword)
1330 (emit-byte segment #b10011001)))
1332 (define-instruction xadd (segment dst src)
1333 ;; Register/Memory with Register.
1334 (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1336 (aver (register-p src))
1337 (let ((size (matching-operand-size src dst)))
1338 (maybe-emit-operand-size-prefix segment size)
1339 (emit-byte segment #b00001111)
1340 (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1341 (emit-ea segment dst (reg-tn-encoding src)))))
1346 (defun emit-shift-inst (segment dst amount opcode)
1347 (let ((size (operand-size dst)))
1348 (maybe-emit-operand-size-prefix segment size)
1349 (multiple-value-bind (major-opcode immed)
1351 (:cl (values #b11010010 nil))
1352 (1 (values #b11010000 nil))
1353 (t (values #b11000000 t)))
1355 (if (eq size :byte) major-opcode (logior major-opcode 1)))
1356 (emit-ea segment dst opcode)
1358 (emit-byte segment amount)))))
1360 (eval-when (:compile-toplevel :execute)
1361 (defun shift-inst-printer-list (subop)
1362 `((reg/mem ((op (#b1101000 ,subop)))
1363 (:name :tab reg/mem ", 1"))
1364 (reg/mem ((op (#b1101001 ,subop)))
1365 (:name :tab reg/mem ", " 'cl))
1366 (reg/mem-imm ((op (#b1100000 ,subop))
1367 (imm nil :type signed-imm-byte))))))
1369 (define-instruction rol (segment dst amount)
1371 (shift-inst-printer-list #b000))
1373 (emit-shift-inst segment dst amount #b000)))
1375 (define-instruction ror (segment dst amount)
1377 (shift-inst-printer-list #b001))
1379 (emit-shift-inst segment dst amount #b001)))
1381 (define-instruction rcl (segment dst amount)
1383 (shift-inst-printer-list #b010))
1385 (emit-shift-inst segment dst amount #b010)))
1387 (define-instruction rcr (segment dst amount)
1389 (shift-inst-printer-list #b011))
1391 (emit-shift-inst segment dst amount #b011)))
1393 (define-instruction shl (segment dst amount)
1395 (shift-inst-printer-list #b100))
1397 (emit-shift-inst segment dst amount #b100)))
1399 (define-instruction shr (segment dst amount)
1401 (shift-inst-printer-list #b101))
1403 (emit-shift-inst segment dst amount #b101)))
1405 (define-instruction sar (segment dst amount)
1407 (shift-inst-printer-list #b111))
1409 (emit-shift-inst segment dst amount #b111)))
1411 (defun emit-double-shift (segment opcode dst src amt)
1412 (let ((size (matching-operand-size dst src)))
1413 (when (eq size :byte)
1414 (error "Double shifts can only be used with words."))
1415 (maybe-emit-operand-size-prefix segment size)
1416 (emit-byte segment #b00001111)
1417 (emit-byte segment (dpb opcode (byte 1 3)
1418 (if (eq amt :cl) #b10100101 #b10100100)))
1420 (emit-ea segment dst src)
1421 (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1422 (unless (eq amt :cl)
1423 (emit-byte segment amt))))
1425 (eval-when (:compile-toplevel :execute)
1426 (defun double-shift-inst-printer-list (op)
1428 (ext-reg-reg/mem-imm ((op ,(logior op #b100))
1429 (imm nil :type signed-imm-byte)))
1430 (ext-reg-reg/mem ((op ,(logior op #b101)))
1431 (:name :tab reg/mem ", " 'cl)))))
1433 (define-instruction shld (segment dst src amt)
1434 (:declare (type (or (member :cl) (mod 32)) amt))
1435 (:printer-list (double-shift-inst-printer-list #b10100000))
1437 (emit-double-shift segment #b0 dst src amt)))
1439 (define-instruction shrd (segment dst src amt)
1440 (:declare (type (or (member :cl) (mod 32)) amt))
1441 (:printer-list (double-shift-inst-printer-list #b10101000))
1443 (emit-double-shift segment #b1 dst src amt)))
1445 (define-instruction and (segment dst src)
1447 (arith-inst-printer-list #b100))
1449 (emit-random-arith-inst "AND" segment dst src #b100)))
1451 (define-instruction test (segment this that)
1452 (:printer accum-imm ((op #b1010100)))
1453 (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1454 (:printer reg-reg/mem ((op #b1000010)))
1456 (let ((size (matching-operand-size this that)))
1457 (maybe-emit-operand-size-prefix segment size)
1458 (flet ((test-immed-and-something (immed something)
1459 (cond ((accumulator-p something)
1461 (if (eq size :byte) #b10101000 #b10101001))
1462 (emit-sized-immediate segment size immed))
1465 (if (eq size :byte) #b11110110 #b11110111))
1466 (emit-ea segment something #b000)
1467 (emit-sized-immediate segment size immed))))
1468 (test-reg-and-something (reg something)
1469 (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1470 (emit-ea segment something (reg-tn-encoding reg))))
1471 (cond ((integerp that)
1472 (test-immed-and-something that this))
1474 (test-immed-and-something this that))
1476 (test-reg-and-something this that))
1478 (test-reg-and-something that this))
1480 (error "bogus operands for TEST: ~S and ~S" this that)))))))
1482 (define-instruction or (segment dst src)
1484 (arith-inst-printer-list #b001))
1486 (emit-random-arith-inst "OR" segment dst src #b001)))
1488 (define-instruction xor (segment dst src)
1490 (arith-inst-printer-list #b110))
1492 (emit-random-arith-inst "XOR" segment dst src #b110)))
1494 (define-instruction not (segment dst)
1495 (:printer reg/mem ((op '(#b1111011 #b010))))
1497 (let ((size (operand-size dst)))
1498 (maybe-emit-operand-size-prefix segment size)
1499 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1500 (emit-ea segment dst #b010))))
1502 ;;;; string manipulation
1504 (define-instruction cmps (segment size)
1505 (:printer string-op ((op #b1010011)))
1507 (maybe-emit-operand-size-prefix segment size)
1508 (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1510 (define-instruction ins (segment acc)
1511 (:printer string-op ((op #b0110110)))
1513 (let ((size (operand-size acc)))
1514 (aver (accumulator-p acc))
1515 (maybe-emit-operand-size-prefix segment size)
1516 (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1518 (define-instruction lods (segment acc)
1519 (:printer string-op ((op #b1010110)))
1521 (let ((size (operand-size acc)))
1522 (aver (accumulator-p acc))
1523 (maybe-emit-operand-size-prefix segment size)
1524 (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1526 (define-instruction movs (segment size)
1527 (:printer string-op ((op #b1010010)))
1529 (maybe-emit-operand-size-prefix segment size)
1530 (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1532 (define-instruction outs (segment acc)
1533 (:printer string-op ((op #b0110111)))
1535 (let ((size (operand-size acc)))
1536 (aver (accumulator-p acc))
1537 (maybe-emit-operand-size-prefix segment size)
1538 (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1540 (define-instruction scas (segment acc)
1541 (:printer string-op ((op #b1010111)))
1543 (let ((size (operand-size acc)))
1544 (aver (accumulator-p acc))
1545 (maybe-emit-operand-size-prefix segment size)
1546 (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1548 (define-instruction stos (segment acc)
1549 (:printer string-op ((op #b1010101)))
1551 (let ((size (operand-size acc)))
1552 (aver (accumulator-p acc))
1553 (maybe-emit-operand-size-prefix segment size)
1554 (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1556 (define-instruction xlat (segment)
1557 (:printer byte ((op #b11010111)))
1559 (emit-byte segment #b11010111)))
1561 (define-instruction rep (segment)
1563 (emit-byte segment #b11110010)))
1565 (define-instruction repe (segment)
1566 (:printer byte ((op #b11110011)))
1568 (emit-byte segment #b11110011)))
1570 (define-instruction repne (segment)
1571 (:printer byte ((op #b11110010)))
1573 (emit-byte segment #b11110010)))
1576 ;;;; bit manipulation
1578 (define-instruction bsf (segment dst src)
1580 (let ((size (matching-operand-size dst src)))
1581 (when (eq size :byte)
1582 (error "can't scan bytes: ~S" src))
1583 (maybe-emit-operand-size-prefix segment size)
1584 (emit-byte segment #b00001111)
1585 (emit-byte segment #b10111100)
1586 (emit-ea segment src (reg-tn-encoding dst)))))
1588 (define-instruction bsr (segment dst src)
1590 (let ((size (matching-operand-size dst src)))
1591 (when (eq size :byte)
1592 (error "can't scan bytes: ~S" src))
1593 (maybe-emit-operand-size-prefix segment size)
1594 (emit-byte segment #b00001111)
1595 (emit-byte segment #b10111101)
1596 (emit-ea segment src (reg-tn-encoding dst)))))
1598 (defun emit-bit-test-and-mumble (segment src index opcode)
1599 (let ((size (operand-size src)))
1600 (when (eq size :byte)
1601 (error "can't scan bytes: ~S" src))
1602 (maybe-emit-operand-size-prefix segment size)
1603 (emit-byte segment #b00001111)
1604 (cond ((integerp index)
1605 (emit-byte segment #b10111010)
1606 (emit-ea segment src opcode)
1607 (emit-byte segment index))
1609 (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1610 (emit-ea segment src (reg-tn-encoding index))))))
1612 (define-instruction bt (segment src index)
1614 (emit-bit-test-and-mumble segment src index #b100)))
1616 (define-instruction btc (segment src index)
1618 (emit-bit-test-and-mumble segment src index #b111)))
1620 (define-instruction btr (segment src index)
1622 (emit-bit-test-and-mumble segment src index #b110)))
1624 (define-instruction bts (segment src index)
1626 (emit-bit-test-and-mumble segment src index #b101)))
1629 ;;;; control transfer
1631 (define-instruction call (segment where)
1632 (:printer near-jump ((op #b11101000)))
1633 (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
1637 (emit-byte segment #b11101000)
1638 (emit-back-patch segment
1640 #'(lambda (segment posn)
1642 (- (label-position where)
1645 (emit-byte segment #b11101000)
1646 (emit-relative-fixup segment where))
1648 (emit-byte segment #b11111111)
1649 (emit-ea segment where #b010)))))
1651 (defun emit-byte-displacement-backpatch (segment target)
1652 (emit-back-patch segment
1654 #'(lambda (segment posn)
1655 (let ((disp (- (label-position target) (1+ posn))))
1656 (aver (<= -128 disp 127))
1657 (emit-byte segment disp)))))
1659 (define-instruction jmp (segment cond &optional where)
1660 ;; conditional jumps
1661 (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
1662 (:printer near-cond-jump () '('j cc :tab label))
1663 ;; unconditional jumps
1664 (:printer short-jump ((op #b1011)))
1665 (:printer near-jump ((op #b11101001)) )
1666 (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
1671 #'(lambda (segment posn delta-if-after)
1672 (let ((disp (- (label-position where posn delta-if-after)
1674 (when (<= -128 disp 127)
1676 (dpb (conditional-opcode cond)
1679 (emit-byte-displacement-backpatch segment where)
1681 #'(lambda (segment posn)
1682 (let ((disp (- (label-position where) (+ posn 6))))
1683 (emit-byte segment #b00001111)
1685 (dpb (conditional-opcode cond)
1688 (emit-dword segment disp)))))
1689 ((label-p (setq where cond))
1692 #'(lambda (segment posn delta-if-after)
1693 (let ((disp (- (label-position where posn delta-if-after)
1695 (when (<= -128 disp 127)
1696 (emit-byte segment #b11101011)
1697 (emit-byte-displacement-backpatch segment where)
1699 #'(lambda (segment posn)
1700 (let ((disp (- (label-position where) (+ posn 5))))
1701 (emit-byte segment #b11101001)
1702 (emit-dword segment disp))
1705 (emit-byte segment #b11101001)
1706 (emit-relative-fixup segment where))
1708 (unless (or (ea-p where) (tn-p where))
1709 (error "don't know what to do with ~A" where))
1710 (emit-byte segment #b11111111)
1711 (emit-ea segment where #b100)))))
1713 (define-instruction jmp-short (segment label)
1715 (emit-byte segment #b11101011)
1716 (emit-byte-displacement-backpatch segment label)))
1718 (define-instruction ret (segment &optional stack-delta)
1719 (:printer byte ((op #b11000011)))
1720 (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
1724 (emit-byte segment #b11000010)
1725 (emit-word segment stack-delta))
1727 (emit-byte segment #b11000011)))))
1729 (define-instruction jecxz (segment target)
1730 (:printer short-jump ((op #b0011)))
1732 (emit-byte segment #b11100011)
1733 (emit-byte-displacement-backpatch segment target)))
1735 (define-instruction loop (segment target)
1736 (:printer short-jump ((op #b0010)))
1738 (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
1739 (emit-byte-displacement-backpatch segment target)))
1741 (define-instruction loopz (segment target)
1742 (:printer short-jump ((op #b0001)))
1744 (emit-byte segment #b11100001)
1745 (emit-byte-displacement-backpatch segment target)))
1747 (define-instruction loopnz (segment target)
1748 (:printer short-jump ((op #b0000)))
1750 (emit-byte segment #b11100000)
1751 (emit-byte-displacement-backpatch segment target)))
1753 ;;;; conditional byte set
1755 (define-instruction set (segment dst cond)
1756 (:printer cond-set ())
1758 (emit-byte segment #b00001111)
1759 (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
1760 (emit-ea segment dst #b000)))
1764 (define-instruction enter (segment disp &optional (level 0))
1765 (:declare (type (unsigned-byte 16) disp)
1766 (type (unsigned-byte 8) level))
1767 (:printer enter-format ((op #b11001000)))
1769 (emit-byte segment #b11001000)
1770 (emit-word segment disp)
1771 (emit-byte segment level)))
1773 (define-instruction leave (segment)
1774 (:printer byte ((op #b11001001)))
1776 (emit-byte segment #b11001001)))
1778 ;;;; interrupt instructions
1780 (defun snarf-error-junk (sap offset &optional length-only)
1781 (let* ((length (sb!sys:sap-ref-8 sap offset))
1782 (vector (make-array length :element-type '(unsigned-byte 8))))
1783 (declare (type sb!sys:system-area-pointer sap)
1784 (type (unsigned-byte 8) length)
1785 (type (simple-array (unsigned-byte 8) (*)) vector))
1787 (values 0 (1+ length) nil nil))
1789 (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
1790 vector (* n-word-bits
1792 (* length n-byte-bits))
1793 (collect ((sc-offsets)
1795 (lengths 1) ; the length byte
1797 (error-number (sb!c::read-var-integer vector index)))
1800 (when (>= index length)
1802 (let ((old-index index))
1803 (sc-offsets (sb!c::read-var-integer vector index))
1804 (lengths (- index old-index))))
1805 (values error-number
1811 (defmacro break-cases (breaknum &body cases)
1812 (let ((bn-temp (gensym)))
1813 (collect ((clauses))
1814 (dolist (case cases)
1815 (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
1816 `(let ((,bn-temp ,breaknum))
1817 (cond ,@(clauses))))))
1820 (defun break-control (chunk inst stream dstate)
1821 (declare (ignore inst))
1822 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
1823 ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
1824 ;; map has it undefined; and it should be easier to look in the target
1825 ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
1826 ;; from first principles whether it's defined in some way that genesis
1828 (case (byte-imm-code chunk dstate)
1831 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1834 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1836 (nt "breakpoint trap"))
1837 (#.pending-interrupt-trap
1838 (nt "pending interrupt trap"))
1841 (#.fun-end-breakpoint-trap
1842 (nt "function end breakpoint trap")))))
1844 (define-instruction break (segment code)
1845 (:declare (type (unsigned-byte 8) code))
1846 (:printer byte-imm ((op #b11001100)) '(:name :tab code)
1847 :control #'break-control)
1849 (emit-byte segment #b11001100)
1850 (emit-byte segment code)))
1852 (define-instruction int (segment number)
1853 (:declare (type (unsigned-byte 8) number))
1854 (:printer byte-imm ((op #b11001101)))
1858 (emit-byte segment #b11001100))
1860 (emit-byte segment #b11001101)
1861 (emit-byte segment number)))))
1863 (define-instruction into (segment)
1864 (:printer byte ((op #b11001110)))
1866 (emit-byte segment #b11001110)))
1868 (define-instruction bound (segment reg bounds)
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)))))
1877 (define-instruction iret (segment)
1878 (:printer byte ((op #b11001111)))
1880 (emit-byte segment #b11001111)))
1882 ;;;; processor control
1884 (define-instruction hlt (segment)
1885 (:printer byte ((op #b11110100)))
1887 (emit-byte segment #b11110100)))
1889 (define-instruction nop (segment)
1890 (:printer byte ((op #b10010000)))
1892 (emit-byte segment #b10010000)))
1894 (define-instruction wait (segment)
1895 (:printer byte ((op #b10011011)))
1897 (emit-byte segment #b10011011)))
1899 (define-instruction lock (segment)
1900 (:printer byte ((op #b11110000)))
1902 (emit-byte segment #b11110000)))
1904 ;;;; miscellaneous hackery
1906 (define-instruction byte (segment byte)
1908 (emit-byte segment byte)))
1910 (define-instruction word (segment word)
1912 (emit-word segment word)))
1914 (define-instruction dword (segment dword)
1916 (emit-dword segment dword)))
1918 (defun emit-header-data (segment type)
1919 (emit-back-patch segment
1921 (lambda (segment posn)
1925 (component-header-length))
1929 (define-instruction simple-fun-header-word (segment)
1931 (emit-header-data segment simple-fun-header-widetag)))
1933 (define-instruction lra-header-word (segment)
1935 (emit-header-data segment return-pc-header-widetag)))
1937 ;;;; fp instructions
1939 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
1941 ;;;; Note: We treat the single-precision and double-precision variants
1942 ;;;; as separate instructions.
1944 ;;; Load single to st(0).
1945 (define-instruction fld (segment source)
1946 (:printer floating-point ((op '(#b001 #b000))))
1948 (emit-byte segment #b11011001)
1949 (emit-fp-op segment source #b000)))
1951 ;;; Load double to st(0).
1952 (define-instruction fldd (segment source)
1953 (:printer floating-point ((op '(#b101 #b000))))
1954 (:printer floating-point-fp ((op '(#b001 #b000))))
1956 (if (fp-reg-tn-p source)
1957 (emit-byte segment #b11011001)
1958 (emit-byte segment #b11011101))
1959 (emit-fp-op segment source #b000)))
1961 ;;; Load long to st(0).
1962 (define-instruction fldl (segment source)
1963 (:printer floating-point ((op '(#b011 #b101))))
1965 (emit-byte segment #b11011011)
1966 (emit-fp-op segment source #b101)))
1968 ;;; Store single from st(0).
1969 (define-instruction fst (segment dest)
1970 (:printer floating-point ((op '(#b001 #b010))))
1972 (cond ((fp-reg-tn-p dest)
1973 (emit-byte segment #b11011101)
1974 (emit-fp-op segment dest #b010))
1976 (emit-byte segment #b11011001)
1977 (emit-fp-op segment dest #b010)))))
1979 ;;; Store double from st(0).
1980 (define-instruction fstd (segment dest)
1981 (:printer floating-point ((op '(#b101 #b010))))
1982 (:printer floating-point-fp ((op '(#b101 #b010))))
1984 (cond ((fp-reg-tn-p dest)
1985 (emit-byte segment #b11011101)
1986 (emit-fp-op segment dest #b010))
1988 (emit-byte segment #b11011101)
1989 (emit-fp-op segment dest #b010)))))
1991 ;;; Arithmetic ops are all done with at least one operand at top of
1992 ;;; stack. The other operand is is another register or a 32/64 bit
1995 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
1996 ;;; that these conflict with the Gdb conventions for binops. To reduce
1997 ;;; the confusion I've added comments showing the mathamatical
1998 ;;; operation and the two syntaxes. By the ASM386 convention the
1999 ;;; instruction syntax is:
2002 ;;; or Fop Destination, Source
2004 ;;; If only one operand is given then it is the source and the
2005 ;;; destination is ST(0). There are reversed forms of the fsub and
2006 ;;; fdiv instructions inducated by an 'R' suffix.
2008 ;;; The mathematical operation for the non-reverse form is always:
2009 ;;; destination = destination op source
2011 ;;; For the reversed form it is:
2012 ;;; destination = source op destination
2014 ;;; The instructions below only accept one operand at present which is
2015 ;;; usually the source. I've hack in extra instructions to implement
2016 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2017 ;;; the operand is the destination with the source being ST(0).
2020 ;;; st(0) = st(0) + memory or st(i).
2021 (define-instruction fadd (segment source)
2022 (:printer floating-point ((op '(#b000 #b000))))
2024 (emit-byte segment #b11011000)
2025 (emit-fp-op segment source #b000)))
2028 ;;; st(0) = st(0) + memory or st(i).
2029 (define-instruction faddd (segment source)
2030 (:printer floating-point ((op '(#b100 #b000))))
2031 (:printer floating-point-fp ((op '(#b000 #b000))))
2033 (if (fp-reg-tn-p source)
2034 (emit-byte segment #b11011000)
2035 (emit-byte segment #b11011100))
2036 (emit-fp-op segment source #b000)))
2038 ;;; Add double destination st(i):
2039 ;;; st(i) = st(0) + st(i).
2040 (define-instruction fadd-sti (segment destination)
2041 (:printer floating-point-fp ((op '(#b100 #b000))))
2043 (aver (fp-reg-tn-p destination))
2044 (emit-byte segment #b11011100)
2045 (emit-fp-op segment destination #b000)))
2047 (define-instruction faddp-sti (segment destination)
2048 (:printer floating-point-fp ((op '(#b110 #b000))))
2050 (aver (fp-reg-tn-p destination))
2051 (emit-byte segment #b11011110)
2052 (emit-fp-op segment destination #b000)))
2054 ;;; Subtract single:
2055 ;;; st(0) = st(0) - memory or st(i).
2056 (define-instruction fsub (segment source)
2057 (:printer floating-point ((op '(#b000 #b100))))
2059 (emit-byte segment #b11011000)
2060 (emit-fp-op segment source #b100)))
2062 ;;; Subtract single, reverse:
2063 ;;; st(0) = memory or st(i) - st(0).
2064 (define-instruction fsubr (segment source)
2065 (:printer floating-point ((op '(#b000 #b101))))
2067 (emit-byte segment #b11011000)
2068 (emit-fp-op segment source #b101)))
2070 ;;; Subtract double:
2071 ;;; st(0) = st(0) - memory or st(i).
2072 (define-instruction fsubd (segment source)
2073 (:printer floating-point ((op '(#b100 #b100))))
2074 (:printer floating-point-fp ((op '(#b000 #b100))))
2076 (if (fp-reg-tn-p source)
2077 (emit-byte segment #b11011000)
2078 (emit-byte segment #b11011100))
2079 (emit-fp-op segment source #b100)))
2081 ;;; Subtract double, reverse:
2082 ;;; st(0) = memory or st(i) - st(0).
2083 (define-instruction fsubrd (segment source)
2084 (:printer floating-point ((op '(#b100 #b101))))
2085 (:printer floating-point-fp ((op '(#b000 #b101))))
2087 (if (fp-reg-tn-p source)
2088 (emit-byte segment #b11011000)
2089 (emit-byte segment #b11011100))
2090 (emit-fp-op segment source #b101)))
2092 ;;; Subtract double, destination st(i):
2093 ;;; st(i) = st(i) - st(0).
2095 ;;; ASM386 syntax: FSUB ST(i), ST
2096 ;;; Gdb syntax: fsubr %st,%st(i)
2097 (define-instruction fsub-sti (segment destination)
2098 (:printer floating-point-fp ((op '(#b100 #b101))))
2100 (aver (fp-reg-tn-p destination))
2101 (emit-byte segment #b11011100)
2102 (emit-fp-op segment destination #b101)))
2104 (define-instruction fsubp-sti (segment destination)
2105 (:printer floating-point-fp ((op '(#b110 #b101))))
2107 (aver (fp-reg-tn-p destination))
2108 (emit-byte segment #b11011110)
2109 (emit-fp-op segment destination #b101)))
2111 ;;; Subtract double, reverse, destination st(i):
2112 ;;; st(i) = st(0) - st(i).
2114 ;;; ASM386 syntax: FSUBR ST(i), ST
2115 ;;; Gdb syntax: fsub %st,%st(i)
2116 (define-instruction fsubr-sti (segment destination)
2117 (:printer floating-point-fp ((op '(#b100 #b100))))
2119 (aver (fp-reg-tn-p destination))
2120 (emit-byte segment #b11011100)
2121 (emit-fp-op segment destination #b100)))
2123 (define-instruction fsubrp-sti (segment destination)
2124 (:printer floating-point-fp ((op '(#b110 #b100))))
2126 (aver (fp-reg-tn-p destination))
2127 (emit-byte segment #b11011110)
2128 (emit-fp-op segment destination #b100)))
2130 ;;; Multiply single:
2131 ;;; st(0) = st(0) * memory or st(i).
2132 (define-instruction fmul (segment source)
2133 (:printer floating-point ((op '(#b000 #b001))))
2135 (emit-byte segment #b11011000)
2136 (emit-fp-op segment source #b001)))
2138 ;;; Multiply double:
2139 ;;; st(0) = st(0) * memory or st(i).
2140 (define-instruction fmuld (segment source)
2141 (:printer floating-point ((op '(#b100 #b001))))
2142 (:printer floating-point-fp ((op '(#b000 #b001))))
2144 (if (fp-reg-tn-p source)
2145 (emit-byte segment #b11011000)
2146 (emit-byte segment #b11011100))
2147 (emit-fp-op segment source #b001)))
2149 ;;; Multiply double, destination st(i):
2150 ;;; st(i) = st(i) * st(0).
2151 (define-instruction fmul-sti (segment destination)
2152 (:printer floating-point-fp ((op '(#b100 #b001))))
2154 (aver (fp-reg-tn-p destination))
2155 (emit-byte segment #b11011100)
2156 (emit-fp-op segment destination #b001)))
2159 ;;; st(0) = st(0) / memory or st(i).
2160 (define-instruction fdiv (segment source)
2161 (:printer floating-point ((op '(#b000 #b110))))
2163 (emit-byte segment #b11011000)
2164 (emit-fp-op segment source #b110)))
2166 ;;; Divide single, reverse:
2167 ;;; st(0) = memory or st(i) / st(0).
2168 (define-instruction fdivr (segment source)
2169 (:printer floating-point ((op '(#b000 #b111))))
2171 (emit-byte segment #b11011000)
2172 (emit-fp-op segment source #b111)))
2175 ;;; st(0) = st(0) / memory or st(i).
2176 (define-instruction fdivd (segment source)
2177 (:printer floating-point ((op '(#b100 #b110))))
2178 (:printer floating-point-fp ((op '(#b000 #b110))))
2180 (if (fp-reg-tn-p source)
2181 (emit-byte segment #b11011000)
2182 (emit-byte segment #b11011100))
2183 (emit-fp-op segment source #b110)))
2185 ;;; Divide double, reverse:
2186 ;;; st(0) = memory or st(i) / st(0).
2187 (define-instruction fdivrd (segment source)
2188 (:printer floating-point ((op '(#b100 #b111))))
2189 (:printer floating-point-fp ((op '(#b000 #b111))))
2191 (if (fp-reg-tn-p source)
2192 (emit-byte segment #b11011000)
2193 (emit-byte segment #b11011100))
2194 (emit-fp-op segment source #b111)))
2196 ;;; Divide double, destination st(i):
2197 ;;; st(i) = st(i) / st(0).
2199 ;;; ASM386 syntax: FDIV ST(i), ST
2200 ;;; Gdb syntax: fdivr %st,%st(i)
2201 (define-instruction fdiv-sti (segment destination)
2202 (:printer floating-point-fp ((op '(#b100 #b111))))
2204 (aver (fp-reg-tn-p destination))
2205 (emit-byte segment #b11011100)
2206 (emit-fp-op segment destination #b111)))
2208 ;;; Divide double, reverse, destination st(i):
2209 ;;; st(i) = st(0) / st(i).
2211 ;;; ASM386 syntax: FDIVR ST(i), ST
2212 ;;; Gdb syntax: fdiv %st,%st(i)
2213 (define-instruction fdivr-sti (segment destination)
2214 (:printer floating-point-fp ((op '(#b100 #b110))))
2216 (aver (fp-reg-tn-p destination))
2217 (emit-byte segment #b11011100)
2218 (emit-fp-op segment destination #b110)))
2220 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2221 (define-instruction fxch (segment source)
2222 (:printer floating-point-fp ((op '(#b001 #b001))))
2224 (unless (and (tn-p source)
2225 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
2227 (emit-byte segment #b11011001)
2228 (emit-fp-op segment source #b001)))
2230 ;;; Push 32-bit integer to st0.
2231 (define-instruction fild (segment source)
2232 (:printer floating-point ((op '(#b011 #b000))))
2234 (emit-byte segment #b11011011)
2235 (emit-fp-op segment source #b000)))
2237 ;;; Push 64-bit integer to st0.
2238 (define-instruction fildl (segment source)
2239 (:printer floating-point ((op '(#b111 #b101))))
2241 (emit-byte segment #b11011111)
2242 (emit-fp-op segment source #b101)))
2244 ;;; Store 32-bit integer.
2245 (define-instruction fist (segment dest)
2246 (:printer floating-point ((op '(#b011 #b010))))
2248 (emit-byte segment #b11011011)
2249 (emit-fp-op segment dest #b010)))
2251 ;;; Store and pop 32-bit integer.
2252 (define-instruction fistp (segment dest)
2253 (:printer floating-point ((op '(#b011 #b011))))
2255 (emit-byte segment #b11011011)
2256 (emit-fp-op segment dest #b011)))
2258 ;;; Store and pop 64-bit integer.
2259 (define-instruction fistpl (segment dest)
2260 (:printer floating-point ((op '(#b111 #b111))))
2262 (emit-byte segment #b11011111)
2263 (emit-fp-op segment dest #b111)))
2265 ;;; Store single from st(0) and pop.
2266 (define-instruction fstp (segment dest)
2267 (:printer floating-point ((op '(#b001 #b011))))
2269 (cond ((fp-reg-tn-p dest)
2270 (emit-byte segment #b11011101)
2271 (emit-fp-op segment dest #b011))
2273 (emit-byte segment #b11011001)
2274 (emit-fp-op segment dest #b011)))))
2276 ;;; Store double from st(0) and pop.
2277 (define-instruction fstpd (segment dest)
2278 (:printer floating-point ((op '(#b101 #b011))))
2279 (:printer floating-point-fp ((op '(#b101 #b011))))
2281 (cond ((fp-reg-tn-p dest)
2282 (emit-byte segment #b11011101)
2283 (emit-fp-op segment dest #b011))
2285 (emit-byte segment #b11011101)
2286 (emit-fp-op segment dest #b011)))))
2288 ;;; Store long from st(0) and pop.
2289 (define-instruction fstpl (segment dest)
2290 (:printer floating-point ((op '(#b011 #b111))))
2292 (emit-byte segment #b11011011)
2293 (emit-fp-op segment dest #b111)))
2295 ;;; Decrement stack-top pointer.
2296 (define-instruction fdecstp (segment)
2297 (:printer floating-point-no ((op #b10110)))
2299 (emit-byte segment #b11011001)
2300 (emit-byte segment #b11110110)))
2302 ;;; Increment stack-top pointer.
2303 (define-instruction fincstp (segment)
2304 (:printer floating-point-no ((op #b10111)))
2306 (emit-byte segment #b11011001)
2307 (emit-byte segment #b11110111)))
2309 ;;; Free fp register.
2310 (define-instruction ffree (segment dest)
2311 (:printer floating-point-fp ((op '(#b101 #b000))))
2313 (emit-byte segment #b11011101)
2314 (emit-fp-op segment dest #b000)))
2316 (define-instruction fabs (segment)
2317 (:printer floating-point-no ((op #b00001)))
2319 (emit-byte segment #b11011001)
2320 (emit-byte segment #b11100001)))
2322 (define-instruction fchs (segment)
2323 (:printer floating-point-no ((op #b00000)))
2325 (emit-byte segment #b11011001)
2326 (emit-byte segment #b11100000)))
2328 (define-instruction frndint(segment)
2329 (:printer floating-point-no ((op #b11100)))
2331 (emit-byte segment #b11011001)
2332 (emit-byte segment #b11111100)))
2335 (define-instruction fninit(segment)
2336 (:printer floating-point-5 ((op #b00011)))
2338 (emit-byte segment #b11011011)
2339 (emit-byte segment #b11100011)))
2341 ;;; Store Status Word to AX.
2342 (define-instruction fnstsw(segment)
2343 (:printer floating-point-st ((op #b00000)))
2345 (emit-byte segment #b11011111)
2346 (emit-byte segment #b11100000)))
2348 ;;; Load Control Word.
2350 ;;; src must be a memory location
2351 (define-instruction fldcw(segment src)
2352 (:printer floating-point ((op '(#b001 #b101))))
2354 (emit-byte segment #b11011001)
2355 (emit-fp-op segment src #b101)))
2357 ;;; Store Control Word.
2358 (define-instruction fnstcw(segment dst)
2359 (:printer floating-point ((op '(#b001 #b111))))
2361 (emit-byte segment #b11011001)
2362 (emit-fp-op segment dst #b111)))
2364 ;;; Store FP Environment.
2365 (define-instruction fstenv(segment dst)
2366 (:printer floating-point ((op '(#b001 #b110))))
2368 (emit-byte segment #b11011001)
2369 (emit-fp-op segment dst #b110)))
2371 ;;; Restore FP Environment.
2372 (define-instruction fldenv(segment src)
2373 (:printer floating-point ((op '(#b001 #b100))))
2375 (emit-byte segment #b11011001)
2376 (emit-fp-op segment src #b100)))
2379 (define-instruction fsave(segment dst)
2380 (:printer floating-point ((op '(#b101 #b110))))
2382 (emit-byte segment #b11011101)
2383 (emit-fp-op segment dst #b110)))
2385 ;;; Restore FP State.
2386 (define-instruction frstor(segment src)
2387 (:printer floating-point ((op '(#b101 #b100))))
2389 (emit-byte segment #b11011101)
2390 (emit-fp-op segment src #b100)))
2392 ;;; Clear exceptions.
2393 (define-instruction fnclex(segment)
2394 (:printer floating-point-5 ((op #b00010)))
2396 (emit-byte segment #b11011011)
2397 (emit-byte segment #b11100010)))
2400 (define-instruction fcom (segment src)
2401 (:printer floating-point ((op '(#b000 #b010))))
2403 (emit-byte segment #b11011000)
2404 (emit-fp-op segment src #b010)))
2406 (define-instruction fcomd (segment src)
2407 (:printer floating-point ((op '(#b100 #b010))))
2408 (:printer floating-point-fp ((op '(#b000 #b010))))
2410 (if (fp-reg-tn-p src)
2411 (emit-byte segment #b11011000)
2412 (emit-byte segment #b11011100))
2413 (emit-fp-op segment src #b010)))
2415 ;;; Compare ST1 to ST0, popping the stack twice.
2416 (define-instruction fcompp (segment)
2417 (:printer floating-point-3 ((op '(#b110 #b011001))))
2419 (emit-byte segment #b11011110)
2420 (emit-byte segment #b11011001)))
2422 ;;; unordered comparison
2423 (define-instruction fucom (segment src)
2424 ;; XX Printer conflicts with frstor
2425 ;; (:printer floating-point ((op '(#b101 #b100))))
2427 (aver (fp-reg-tn-p src))
2428 (emit-byte segment #b11011101)
2429 (emit-fp-op segment src #b100)))
2431 (define-instruction ftst (segment)
2432 (:printer floating-point-no ((op #b00100)))
2434 (emit-byte segment #b11011001)
2435 (emit-byte segment #b11100100)))
2439 (define-instruction fsqrt(segment)
2440 (:printer floating-point-no ((op #b11010)))
2442 (emit-byte segment #b11011001)
2443 (emit-byte segment #b11111010)))
2445 (define-instruction fscale(segment)
2446 (:printer floating-point-no ((op #b11101)))
2448 (emit-byte segment #b11011001)
2449 (emit-byte segment #b11111101)))
2451 (define-instruction fxtract(segment)
2452 (:printer floating-point-no ((op #b10100)))
2454 (emit-byte segment #b11011001)
2455 (emit-byte segment #b11110100)))
2457 (define-instruction fsin(segment)
2458 (:printer floating-point-no ((op #b11110)))
2460 (emit-byte segment #b11011001)
2461 (emit-byte segment #b11111110)))
2463 (define-instruction fcos(segment)
2464 (:printer floating-point-no ((op #b11111)))
2466 (emit-byte segment #b11011001)
2467 (emit-byte segment #b11111111)))
2469 (define-instruction fprem1(segment)
2470 (:printer floating-point-no ((op #b10101)))
2472 (emit-byte segment #b11011001)
2473 (emit-byte segment #b11110101)))
2475 (define-instruction fprem(segment)
2476 (:printer floating-point-no ((op #b11000)))
2478 (emit-byte segment #b11011001)
2479 (emit-byte segment #b11111000)))
2481 (define-instruction fxam (segment)
2482 (:printer floating-point-no ((op #b00101)))
2484 (emit-byte segment #b11011001)
2485 (emit-byte segment #b11100101)))
2487 ;;; These do push/pop to stack and need special handling
2488 ;;; in any VOPs that use them. See the book.
2490 ;;; st0 <- st1*log2(st0)
2491 (define-instruction fyl2x(segment) ; pops stack
2492 (:printer floating-point-no ((op #b10001)))
2494 (emit-byte segment #b11011001)
2495 (emit-byte segment #b11110001)))
2497 (define-instruction fyl2xp1(segment)
2498 (:printer floating-point-no ((op #b11001)))
2500 (emit-byte segment #b11011001)
2501 (emit-byte segment #b11111001)))
2503 (define-instruction f2xm1(segment)
2504 (:printer floating-point-no ((op #b10000)))
2506 (emit-byte segment #b11011001)
2507 (emit-byte segment #b11110000)))
2509 (define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
2510 (:printer floating-point-no ((op #b10010)))
2512 (emit-byte segment #b11011001)
2513 (emit-byte segment #b11110010)))
2515 (define-instruction fpatan(segment) ; POPS STACK
2516 (:printer floating-point-no ((op #b10011)))
2518 (emit-byte segment #b11011001)
2519 (emit-byte segment #b11110011)))
2521 ;;;; loading constants
2523 (define-instruction fldz(segment)
2524 (:printer floating-point-no ((op #b01110)))
2526 (emit-byte segment #b11011001)
2527 (emit-byte segment #b11101110)))
2529 (define-instruction fld1(segment)
2530 (:printer floating-point-no ((op #b01000)))
2532 (emit-byte segment #b11011001)
2533 (emit-byte segment #b11101000)))
2535 (define-instruction fldpi(segment)
2536 (:printer floating-point-no ((op #b01011)))
2538 (emit-byte segment #b11011001)
2539 (emit-byte segment #b11101011)))
2541 (define-instruction fldl2t(segment)
2542 (:printer floating-point-no ((op #b01001)))
2544 (emit-byte segment #b11011001)
2545 (emit-byte segment #b11101001)))
2547 (define-instruction fldl2e(segment)
2548 (:printer floating-point-no ((op #b01010)))
2550 (emit-byte segment #b11011001)
2551 (emit-byte segment #b11101010)))
2553 (define-instruction fldlg2(segment)
2554 (:printer floating-point-no ((op #b01100)))
2556 (emit-byte segment #b11011001)
2557 (emit-byte segment #b11101100)))
2559 (define-instruction fldln2(segment)
2560 (:printer floating-point-no ((op #b01101)))
2562 (emit-byte segment #b11011001)
2563 (emit-byte segment #b11101101)))