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 ;;; Disassembling x86 code needs to take into account little things
44 ;;; like instructions that have a byte/word length bit in their
45 ;;; encoding, prefixes to change the default word length for a single
46 ;;; instruction, and so on. Unfortunately, there is no easy way with
47 ;;; this disassembler framework to handle prefixes that will work
48 ;;; correctly in all cases, so we copy the x86-64 version which at
49 ;;; least can handle the code output by the compiler.
51 ;;; Width information for an instruction is stored as an inst-prop on
52 ;;; the dstate. The inst-props are cleared automatically after each
53 ;;; instruction, must be set by prefilters, and contain a single bit
54 ;;; of data each (presence/absence). As such, each instruction that
55 ;;; can emit an operand-size prefix (x66 prefix) needs to have a set
56 ;;; of printers declared for both the prefixed and non-prefixed
59 ;;; Return the operand size based on the prefixes and width bit from
61 (defun inst-operand-size (dstate)
62 (declare (type sb!disassem:disassem-state dstate))
63 (cond ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-8)
65 ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-16)
68 +default-operand-size+)))
70 ;;; Return the operand size for a "word-sized" operand based on the
71 ;;; prefixes from the dstate.
72 (defun inst-word-operand-size (dstate)
73 (declare (type sb!disassem:disassem-state dstate))
74 (if (sb!disassem:dstate-get-inst-prop dstate 'operand-size-16)
78 (defun print-reg-with-width (value width stream dstate)
79 (declare (ignore dstate))
80 (princ (aref (ecase width
81 (:byte *byte-reg-names*)
82 (:word *word-reg-names*)
83 (:dword *dword-reg-names*))
86 ;; XXX plus should do some source-var notes
89 (defun print-reg (value stream dstate)
90 (declare (type reg value)
92 (type sb!disassem:disassem-state dstate))
93 (print-reg-with-width value
94 (inst-operand-size dstate)
98 (defun print-word-reg (value stream dstate)
99 (declare (type reg value)
101 (type sb!disassem:disassem-state dstate))
102 (print-reg-with-width value
103 (inst-word-operand-size dstate)
107 (defun print-byte-reg (value stream dstate)
108 (declare (type reg value)
110 (type sb!disassem:disassem-state dstate))
111 (print-reg-with-width value :byte stream dstate))
113 (defun print-addr-reg (value stream dstate)
114 (declare (type reg value)
116 (type sb!disassem:disassem-state dstate))
117 (print-reg-with-width value *default-address-size* stream dstate))
119 (defun print-reg/mem (value stream dstate)
120 (declare (type (or list reg) value)
122 (type sb!disassem:disassem-state dstate))
123 (if (typep value 'reg)
124 (print-reg value stream dstate)
125 (print-mem-access value stream nil dstate)))
127 ;; Same as print-reg/mem, but prints an explicit size indicator for
128 ;; memory references.
129 (defun print-sized-reg/mem (value stream dstate)
130 (declare (type (or list reg) value)
132 (type sb!disassem:disassem-state dstate))
133 (if (typep value 'reg)
134 (print-reg value stream dstate)
135 (print-mem-access value stream t dstate)))
137 (defun print-byte-reg/mem (value stream dstate)
138 (declare (type (or list reg) value)
140 (type sb!disassem:disassem-state dstate))
141 (if (typep value 'reg)
142 (print-byte-reg value stream dstate)
143 (print-mem-access value stream t dstate)))
145 (defun print-word-reg/mem (value stream dstate)
146 (declare (type (or list reg) value)
148 (type sb!disassem:disassem-state dstate))
149 (if (typep value 'reg)
150 (print-word-reg value stream dstate)
151 (print-mem-access value stream nil dstate)))
153 (defun print-label (value stream dstate)
154 (declare (ignore dstate))
155 (sb!disassem:princ16 value stream))
157 ;;; Returns either an integer, meaning a register, or a list of
158 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
159 ;;; may be missing or nil to indicate that it's not used or has the
160 ;;; obvious default value (e.g., 1 for the index-scale).
161 (defun prefilter-reg/mem (value dstate)
162 (declare (type list value)
163 (type sb!disassem:disassem-state dstate))
164 (let ((mod (car value))
166 (declare (type (unsigned-byte 2) mod)
167 (type (unsigned-byte 3) r/m))
173 (let ((sib (sb!disassem:read-suffix 8 dstate)))
174 (declare (type (unsigned-byte 8) sib))
175 (let ((base-reg (ldb (byte 3 0) sib))
176 (index-reg (ldb (byte 3 3) sib))
177 (index-scale (ldb (byte 2 6) sib)))
178 (declare (type (unsigned-byte 3) base-reg index-reg)
179 (type (unsigned-byte 2) index-scale))
183 (if (= base-reg #b101)
184 (sb!disassem:read-signed-suffix 32 dstate)
187 (sb!disassem:read-signed-suffix 8 dstate))
189 (sb!disassem:read-signed-suffix 32 dstate)))))
190 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
192 (if (= index-reg #b100) nil index-reg)
193 (ash 1 index-scale))))))
194 ((and (= mod #b00) (= r/m #b101))
195 (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
199 (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
201 (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
204 ;;; This is a sort of bogus prefilter that just stores the info globally for
205 ;;; other people to use; it probably never gets printed.
206 (defun prefilter-width (value dstate)
207 (declare (type bit value)
208 (type sb!disassem:disassem-state dstate))
210 (sb!disassem:dstate-put-inst-prop dstate 'operand-size-8))
213 ;;; This prefilter is used solely for its side effect, namely to put
214 ;;; the property OPERAND-SIZE-16 into the DSTATE.
215 (defun prefilter-x66 (value dstate)
216 (declare (type (eql #x66) value)
218 (type sb!disassem:disassem-state dstate))
219 (sb!disassem:dstate-put-inst-prop dstate 'operand-size-16))
221 (defun read-address (value dstate)
222 (declare (ignore value)) ; always nil anyway
223 (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
225 (defun width-bits (width)
235 ;;;; disassembler argument types
237 (sb!disassem:define-arg-type displacement
239 :use-label #'offset-next
240 :printer (lambda (value stream dstate)
241 (sb!disassem:maybe-note-assembler-routine value nil dstate)
242 (print-label value stream dstate)))
244 (sb!disassem:define-arg-type accum
245 :printer (lambda (value stream dstate)
246 (declare (ignore value)
248 (type sb!disassem:disassem-state dstate))
249 (print-reg 0 stream dstate)))
251 (sb!disassem:define-arg-type word-accum
252 :printer (lambda (value stream dstate)
253 (declare (ignore value)
255 (type sb!disassem:disassem-state dstate))
256 (print-word-reg 0 stream dstate)))
258 (sb!disassem:define-arg-type reg
259 :printer #'print-reg)
261 (sb!disassem:define-arg-type addr-reg
262 :printer #'print-addr-reg)
264 (sb!disassem:define-arg-type word-reg
265 :printer #'print-word-reg)
267 (sb!disassem:define-arg-type imm-addr
268 :prefilter #'read-address
269 :printer #'print-label)
271 (sb!disassem:define-arg-type imm-data
272 :prefilter (lambda (value dstate)
273 (declare (ignore value)) ; always nil anyway
274 (sb!disassem:read-suffix
275 (width-bits (inst-operand-size dstate))
278 (sb!disassem:define-arg-type signed-imm-data
279 :prefilter (lambda (value dstate)
280 (declare (ignore value)) ; always nil anyway
281 (let ((width (inst-operand-size dstate)))
282 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
284 (sb!disassem:define-arg-type signed-imm-byte
285 :prefilter (lambda (value dstate)
286 (declare (ignore value)) ; always nil anyway
287 (sb!disassem:read-signed-suffix 8 dstate)))
289 (sb!disassem:define-arg-type signed-imm-dword
290 :prefilter (lambda (value dstate)
291 (declare (ignore value)) ; always nil anyway
292 (sb!disassem:read-signed-suffix 32 dstate)))
294 (sb!disassem:define-arg-type imm-word
295 :prefilter (lambda (value dstate)
296 (declare (ignore value)) ; always nil anyway
297 (let ((width (inst-word-operand-size dstate)))
298 (sb!disassem:read-suffix (width-bits width) dstate))))
300 (sb!disassem:define-arg-type signed-imm-word
301 :prefilter (lambda (value dstate)
302 (declare (ignore value)) ; always nil anyway
303 (let ((width (inst-word-operand-size dstate)))
304 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
306 ;;; needed for the ret imm16 instruction
307 (sb!disassem:define-arg-type imm-word-16
308 :prefilter (lambda (value dstate)
309 (declare (ignore value)) ; always nil anyway
310 (sb!disassem:read-suffix 16 dstate)))
312 (sb!disassem:define-arg-type reg/mem
313 :prefilter #'prefilter-reg/mem
314 :printer #'print-reg/mem)
315 (sb!disassem:define-arg-type sized-reg/mem
316 ;; Same as reg/mem, but prints an explicit size indicator for
317 ;; memory references.
318 :prefilter #'prefilter-reg/mem
319 :printer #'print-sized-reg/mem)
320 (sb!disassem:define-arg-type byte-reg/mem
321 :prefilter #'prefilter-reg/mem
322 :printer #'print-byte-reg/mem)
323 (sb!disassem:define-arg-type word-reg/mem
324 :prefilter #'prefilter-reg/mem
325 :printer #'print-word-reg/mem)
328 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
329 (defun print-fp-reg (value stream dstate)
330 (declare (ignore dstate))
331 (format stream "FR~D" value))
332 (defun prefilter-fp-reg (value dstate)
334 (declare (ignore dstate))
337 (sb!disassem:define-arg-type fp-reg
338 :prefilter #'prefilter-fp-reg
339 :printer #'print-fp-reg)
341 (sb!disassem:define-arg-type width
342 :prefilter #'prefilter-width
343 :printer (lambda (value stream dstate)
344 (declare (ignore value))
345 (princ (schar (symbol-name (inst-operand-size dstate)) 0)
348 ;;; Used to capture the effect of the #x66 operand size override prefix.
349 (sb!disassem:define-arg-type x66
350 :prefilter #'prefilter-x66)
352 (eval-when (:compile-toplevel :load-toplevel :execute)
353 (defparameter *conditions*
356 (:b . 2) (:nae . 2) (:c . 2)
357 (:nb . 3) (:ae . 3) (:nc . 3)
358 (:eq . 4) (:e . 4) (:z . 4)
365 (:np . 11) (:po . 11)
366 (:l . 12) (:nge . 12)
367 (:nl . 13) (:ge . 13)
368 (:le . 14) (:ng . 14)
369 (:nle . 15) (:g . 15)))
370 (defparameter *condition-name-vec*
371 (let ((vec (make-array 16 :initial-element nil)))
372 (dolist (cond *conditions*)
373 (when (null (aref vec (cdr cond)))
374 (setf (aref vec (cdr cond)) (car cond))))
378 ;;; Set assembler parameters. (In CMU CL, this was done with
379 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
380 (eval-when (:compile-toplevel :load-toplevel :execute)
381 (setf sb!assem:*assem-scheduler-p* nil))
383 (sb!disassem:define-arg-type condition-code
384 :printer *condition-name-vec*)
386 (defun conditional-opcode (condition)
387 (cdr (assoc condition *conditions* :test #'eq)))
389 ;;;; disassembler instruction formats
391 (eval-when (:compile-toplevel :execute)
392 (defun swap-if (direction field1 separator field2)
393 `(:if (,direction :constant 0)
394 (,field1 ,separator ,field2)
395 (,field2 ,separator ,field1))))
397 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
398 (op :field (byte 8 0))
403 (sb!disassem:define-instruction-format (simple 8)
404 (op :field (byte 7 1))
405 (width :field (byte 1 0) :type 'width)
410 (sb!disassem:define-instruction-format (x66-simple 16)
411 (x66 :field (byte 8 0) :type 'x66 :value #x66)
412 (op :field (byte 7 9))
413 (width :field (byte 1 8) :type 'width)
418 (sb!disassem:define-instruction-format (two-bytes 16
419 :default-printer '(:name))
420 (op :fields (list (byte 8 0) (byte 8 8))))
422 ;;; Same as simple, but with direction bit
423 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
424 (op :field (byte 6 2))
425 (dir :field (byte 1 1)))
427 (sb!disassem:define-instruction-format (x66-simple-dir 16 :include 'x66-simple)
428 (op :field (byte 6 10))
429 (dir :field (byte 1 9)))
431 ;;; Same as simple, but with the immediate value occurring by default,
432 ;;; and with an appropiate printer.
433 (sb!disassem:define-instruction-format (accum-imm 8
435 :default-printer '(:name
436 :tab accum ", " imm))
437 (imm :type 'imm-data))
439 (sb!disassem:define-instruction-format (x66-accum-imm 16
441 :default-printer '(:name
442 :tab accum ", " imm))
443 (imm :type 'imm-data))
445 (sb!disassem:define-instruction-format (reg-no-width 8
446 :default-printer '(:name :tab reg))
447 (op :field (byte 5 3))
448 (reg :field (byte 3 0) :type 'word-reg)
450 (accum :type 'word-accum)
453 (sb!disassem:define-instruction-format (x66-reg-no-width 16
454 :default-printer '(:name :tab reg))
455 (x66 :field (byte 8 0) :type 'x66 :value #x66)
456 (op :field (byte 5 11))
457 (reg :field (byte 3 8) :type 'word-reg)
459 (accum :type 'word-accum)
462 ;;; adds a width field to reg-no-width
463 (sb!disassem:define-instruction-format (reg 8
464 :default-printer '(:name :tab reg))
465 (op :field (byte 4 4))
466 (width :field (byte 1 3) :type 'width)
467 (reg :field (byte 3 0) :type 'reg)
473 (sb!disassem:define-instruction-format (x66-reg 16
474 :default-printer '(:name :tab reg))
475 (x66 :field (byte 8 0) :type 'x66 :value #x66)
476 (op :field (byte 4 12))
477 (width :field (byte 1 11) :type 'width)
478 (reg :field (byte 3 8) :type 'reg)
484 ;;; Same as reg, but with direction bit
485 (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
486 (op :field (byte 3 5))
487 (dir :field (byte 1 4)))
489 (sb!disassem:define-instruction-format (two-bytes 16
490 :default-printer '(:name))
491 (op :fields (list (byte 8 0) (byte 8 8))))
493 (sb!disassem:define-instruction-format (reg-reg/mem 16
495 `(:name :tab reg ", " reg/mem))
496 (op :field (byte 7 1))
497 (width :field (byte 1 0) :type 'width)
498 (reg/mem :fields (list (byte 2 14) (byte 3 8))
500 (reg :field (byte 3 11) :type 'reg)
504 (sb!disassem:define-instruction-format (x66-reg-reg/mem 24
506 `(:name :tab reg ", " reg/mem))
507 (x66 :field (byte 8 0) :type 'x66 :value #x66)
508 (op :field (byte 7 9))
509 (width :field (byte 1 8) :type 'width)
510 (reg/mem :fields (list (byte 2 22) (byte 3 16))
512 (reg :field (byte 3 19) :type 'reg)
516 ;;; same as reg-reg/mem, but with direction bit
517 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
518 :include 'reg-reg/mem
522 ,(swap-if 'dir 'reg/mem ", " 'reg)))
523 (op :field (byte 6 2))
524 (dir :field (byte 1 1)))
526 (sb!disassem:define-instruction-format (x66-reg-reg/mem-dir 24
527 :include 'x66-reg-reg/mem
531 ,(swap-if 'dir 'reg/mem ", " 'reg)))
532 (op :field (byte 6 10))
533 (dir :field (byte 1 9)))
535 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
536 (sb!disassem:define-instruction-format (reg/mem 16
537 :default-printer '(:name :tab reg/mem))
538 (op :fields (list (byte 7 1) (byte 3 11)))
539 (width :field (byte 1 0) :type 'width)
540 (reg/mem :fields (list (byte 2 14) (byte 3 8))
541 :type 'sized-reg/mem)
545 (sb!disassem:define-instruction-format (x66-reg/mem 24
546 :default-printer '(:name :tab reg/mem))
547 (x66 :field (byte 8 0) :type 'x66 :value #x66)
548 (op :fields (list (byte 7 9) (byte 3 19)))
549 (width :field (byte 1 8) :type 'width)
550 (reg/mem :fields (list (byte 2 22) (byte 3 16))
551 :type 'sized-reg/mem)
555 ;;; Same as reg/mem, but with the immediate value occurring by default,
556 ;;; and with an appropiate printer.
557 (sb!disassem:define-instruction-format (reg/mem-imm 16
560 '(:name :tab reg/mem ", " imm))
561 (reg/mem :type 'sized-reg/mem)
562 (imm :type 'imm-data))
564 (sb!disassem:define-instruction-format (x66-reg/mem-imm 24
565 :include 'x66-reg/mem
567 '(:name :tab reg/mem ", " imm))
568 (reg/mem :type 'sized-reg/mem)
569 (imm :type 'imm-data))
571 ;;; Same as reg/mem, but with using the accumulator in the default printer
572 (sb!disassem:define-instruction-format
574 :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
575 (reg/mem :type 'reg/mem) ; don't need a size
576 (accum :type 'accum))
578 (sb!disassem:define-instruction-format (x66-accum-reg/mem 24
579 :include 'x66-reg/mem
581 '(:name :tab accum ", " reg/mem))
582 (reg/mem :type 'reg/mem) ; don't need a size
583 (accum :type 'accum))
585 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
586 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
588 `(:name :tab reg ", " reg/mem))
589 (prefix :field (byte 8 0) :value #b00001111)
590 (op :field (byte 7 9))
591 (width :field (byte 1 8) :type 'width)
592 (reg/mem :fields (list (byte 2 22) (byte 3 16))
594 (reg :field (byte 3 19) :type 'reg)
598 (sb!disassem:define-instruction-format (x66-ext-reg-reg/mem 32
600 `(:name :tab reg ", " reg/mem))
601 (x66 :field (byte 8 0) :type 'x66 :value #x66)
602 (prefix :field (byte 8 8) :value #b00001111)
603 (op :field (byte 7 17))
604 (width :field (byte 1 16) :type 'width)
605 (reg/mem :fields (list (byte 2 30) (byte 3 24))
607 (reg :field (byte 3 27) :type 'reg)
611 ;;; reg-no-width with #x0f prefix
612 (sb!disassem:define-instruction-format (ext-reg-no-width 16
613 :default-printer '(:name :tab reg))
614 (prefix :field (byte 8 0) :value #b00001111)
615 (op :field (byte 5 11))
616 (reg :field (byte 3 8) :type 'reg))
618 ;;; Same as reg/mem, but with a prefix of #b00001111
619 (sb!disassem:define-instruction-format (ext-reg/mem 24
620 :default-printer '(:name :tab reg/mem))
621 (prefix :field (byte 8 0) :value #b00001111)
622 (op :fields (list (byte 7 9) (byte 3 19)))
623 (width :field (byte 1 8) :type 'width)
624 (reg/mem :fields (list (byte 2 22) (byte 3 16))
625 :type 'sized-reg/mem)
629 (sb!disassem:define-instruction-format (x66-ext-reg/mem 32
630 :default-printer '(:name :tab reg/mem))
631 (x66 :field (byte 8 0) :type 'x66 :value #x66)
632 (prefix :field (byte 8 8) :value #b00001111)
633 (op :fields (list (byte 7 17) (byte 3 27)))
634 (width :field (byte 1 16) :type 'width)
635 (reg/mem :fields (list (byte 2 30) (byte 3 22))
636 :type 'sized-reg/mem)
640 (sb!disassem:define-instruction-format (ext-reg/mem-imm 24
641 :include 'ext-reg/mem
643 '(:name :tab reg/mem ", " imm))
644 (imm :type 'imm-data))
646 (sb!disassem:define-instruction-format (x66-ext-reg/mem-imm 32
647 :include 'x66-ext-reg/mem
649 '(:name :tab reg/mem ", " imm))
650 (imm :type 'imm-data))
652 ;;;; This section was added by jrd, for fp instructions.
654 ;;; regular fp inst to/from registers/memory
655 (sb!disassem:define-instruction-format (floating-point 16
657 `(:name :tab reg/mem))
658 (prefix :field (byte 5 3) :value #b11011)
659 (op :fields (list (byte 3 0) (byte 3 11)))
660 (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
662 ;;; fp insn to/from fp reg
663 (sb!disassem:define-instruction-format (floating-point-fp 16
664 :default-printer `(:name :tab fp-reg))
665 (prefix :field (byte 5 3) :value #b11011)
666 (suffix :field (byte 2 14) :value #b11)
667 (op :fields (list (byte 3 0) (byte 3 11)))
668 (fp-reg :field (byte 3 8) :type 'fp-reg))
670 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
671 (sb!disassem:define-instruction-format
672 (floating-point-fp-d 16
673 :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
674 (prefix :field (byte 5 3) :value #b11011)
675 (suffix :field (byte 2 14) :value #b11)
676 (op :fields (list (byte 2 0) (byte 3 11)))
677 (d :field (byte 1 2))
678 (fp-reg :field (byte 3 8) :type 'fp-reg))
681 ;;; (added by (?) pfw)
682 ;;; fp no operand isns
683 (sb!disassem:define-instruction-format (floating-point-no 16
684 :default-printer '(:name))
685 (prefix :field (byte 8 0) :value #b11011001)
686 (suffix :field (byte 3 13) :value #b111)
687 (op :field (byte 5 8)))
689 (sb!disassem:define-instruction-format (floating-point-3 16
690 :default-printer '(:name))
691 (prefix :field (byte 5 3) :value #b11011)
692 (suffix :field (byte 2 14) :value #b11)
693 (op :fields (list (byte 3 0) (byte 6 8))))
695 (sb!disassem:define-instruction-format (floating-point-5 16
696 :default-printer '(:name))
697 (prefix :field (byte 8 0) :value #b11011011)
698 (suffix :field (byte 3 13) :value #b111)
699 (op :field (byte 5 8)))
701 (sb!disassem:define-instruction-format (floating-point-st 16
702 :default-printer '(:name))
703 (prefix :field (byte 8 0) :value #b11011111)
704 (suffix :field (byte 3 13) :value #b111)
705 (op :field (byte 5 8)))
707 (sb!disassem:define-instruction-format (string-op 8
709 :default-printer '(:name width)))
711 (sb!disassem:define-instruction-format (x66-string-op 16
713 :default-printer '(:name width)))
715 (sb!disassem:define-instruction-format (short-cond-jump 16)
716 (op :field (byte 4 4))
717 (cc :field (byte 4 0) :type 'condition-code)
718 (label :field (byte 8 8) :type 'displacement))
720 (sb!disassem:define-instruction-format (short-jump 16
721 :default-printer '(:name :tab label))
722 (const :field (byte 4 4) :value #b1110)
723 (op :field (byte 4 0))
724 (label :field (byte 8 8) :type 'displacement))
726 (sb!disassem:define-instruction-format (near-cond-jump 16)
727 (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
728 (cc :field (byte 4 8) :type 'condition-code)
729 ;; The disassembler currently doesn't let you have an instruction > 32 bits
730 ;; long, so we fake it by using a prefilter to read the offset.
731 (label :type 'displacement
732 :prefilter (lambda (value dstate)
733 (declare (ignore value)) ; always nil anyway
734 (sb!disassem:read-signed-suffix 32 dstate))))
736 (sb!disassem:define-instruction-format (near-jump 8
737 :default-printer '(:name :tab label))
738 (op :field (byte 8 0))
739 ;; The disassembler currently doesn't let you have an instruction > 32 bits
740 ;; long, so we fake it by using a prefilter to read the address.
741 (label :type 'displacement
742 :prefilter (lambda (value dstate)
743 (declare (ignore value)) ; always nil anyway
744 (sb!disassem:read-signed-suffix 32 dstate))))
747 (sb!disassem:define-instruction-format (cond-set 24
748 :default-printer '('set cc :tab reg/mem))
749 (prefix :field (byte 8 0) :value #b00001111)
750 (op :field (byte 4 12) :value #b1001)
751 (cc :field (byte 4 8) :type 'condition-code)
752 (reg/mem :fields (list (byte 2 22) (byte 3 16))
754 (reg :field (byte 3 19) :value #b000))
756 (sb!disassem:define-instruction-format (cond-move 24
758 '('cmov cc :tab reg ", " reg/mem))
759 (prefix :field (byte 8 0) :value #b00001111)
760 (op :field (byte 4 12) :value #b0100)
761 (cc :field (byte 4 8) :type 'condition-code)
762 (reg/mem :fields (list (byte 2 22) (byte 3 16))
764 (reg :field (byte 3 19) :type 'reg))
766 (sb!disassem:define-instruction-format (x66-cond-move 32
768 '('cmov cc :tab reg ", " reg/mem))
769 (x66 :field (byte 8 0) :type 'x66 :value #x66)
770 (prefix :field (byte 8 8) :value #b00001111)
771 (op :field (byte 4 20) :value #b0100)
772 (cc :field (byte 4 16) :type 'condition-code)
773 (reg/mem :fields (list (byte 2 30) (byte 3 24))
775 (reg :field (byte 3 27) :type 'reg))
777 (sb!disassem:define-instruction-format (enter-format 32
778 :default-printer '(:name
780 (:unless (:constant 0)
782 (op :field (byte 8 0))
783 (disp :field (byte 16 8))
784 (level :field (byte 8 24)))
786 (sb!disassem:define-instruction-format (prefetch 24
788 '(:name ", " reg/mem))
789 (prefix :field (byte 8 0) :value #b00001111)
790 (op :field (byte 8 8) :value #b00011000)
791 (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem)
792 (reg :field (byte 3 19) :type 'reg))
794 ;;; Single byte instruction with an immediate byte argument.
795 (sb!disassem:define-instruction-format (byte-imm 16
796 :default-printer '(:name :tab code))
797 (op :field (byte 8 0))
798 (code :field (byte 8 8)))
800 ;;; Two byte instruction with an immediate byte argument.
802 (sb!disassem:define-instruction-format (word-imm 24
803 :default-printer '(:name :tab code))
804 (op :field (byte 16 0))
805 (code :field (byte 8 16)))
808 ;;;; primitive emitters
810 (define-bitfield-emitter emit-word 16
813 (define-bitfield-emitter emit-dword 32
816 (define-bitfield-emitter emit-byte-with-reg 8
817 (byte 5 3) (byte 3 0))
819 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
820 (byte 2 6) (byte 3 3) (byte 3 0))
822 (define-bitfield-emitter emit-sib-byte 8
823 (byte 2 6) (byte 3 3) (byte 3 0))
827 (defun emit-absolute-fixup (segment fixup)
828 (note-fixup segment :absolute fixup)
829 (let ((offset (fixup-offset fixup)))
831 (emit-back-patch segment
832 4 ; FIXME: n-word-bytes
833 (lambda (segment posn)
834 (declare (ignore posn))
836 (- (+ (component-header-length)
837 (or (label-position offset)
839 other-pointer-lowtag))))
840 (emit-dword segment (or offset 0)))))
842 (defun emit-relative-fixup (segment fixup)
843 (note-fixup segment :relative fixup)
844 (emit-dword segment (or (fixup-offset fixup) 0)))
846 ;;;; the effective-address (ea) structure
848 (defun reg-tn-encoding (tn)
849 (declare (type tn tn))
850 (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
851 (let ((offset (tn-offset tn)))
852 (logior (ash (logand offset 1) 2)
855 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
857 (size nil :type (member :byte :word :dword))
858 (base nil :type (or tn null))
859 (index nil :type (or tn null))
860 (scale 1 :type (member 1 2 4 8))
861 (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
862 (def!method print-object ((ea ea) stream)
863 (cond ((or *print-escape* *print-readably*)
864 (print-unreadable-object (ea stream :type t)
866 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
870 (let ((scale (ea-scale ea)))
871 (if (= scale 1) nil scale))
874 (format stream "~A PTR [" (symbol-name (ea-size ea)))
876 (write-string (sb!c::location-print-name (ea-base ea)) stream)
878 (write-string "+" stream)))
880 (write-string (sb!c::location-print-name (ea-index ea)) stream))
881 (unless (= (ea-scale ea) 1)
882 (format stream "*~A" (ea-scale ea)))
883 (typecase (ea-disp ea)
886 (format stream "~@D" (ea-disp ea)))
888 (format stream "+~A" (ea-disp ea))))
889 (write-char #\] stream))))
891 (defun emit-ea (segment thing reg &optional allow-constants)
894 (ecase (sb-name (sc-sb (tn-sc thing)))
896 (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
898 ;; Convert stack tns into an index off of EBP.
899 (let ((disp (frame-byte-offset (tn-offset thing))))
900 (cond ((<= -128 disp 127)
901 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
902 (emit-byte segment disp))
904 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
905 (emit-dword segment disp)))))
907 (unless allow-constants
909 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
910 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
911 (emit-absolute-fixup segment
914 (- (* (tn-offset thing) n-word-bytes)
915 other-pointer-lowtag))))))
917 (let* ((base (ea-base thing))
918 (index (ea-index thing))
919 (scale (ea-scale thing))
920 (disp (ea-disp thing))
921 (mod (cond ((or (null base)
923 (not (= (reg-tn-encoding base) #b101))))
925 ((and (fixnump disp) (<= -128 disp 127))
929 (r/m (cond (index #b100)
931 (t (reg-tn-encoding base)))))
932 (when (and (fixup-p disp)
933 (label-p (fixup-offset disp)))
936 (return-from emit-ea (emit-ea segment disp reg allow-constants)))
937 (emit-mod-reg-r/m-byte segment mod reg r/m)
939 (let ((ss (1- (integer-length scale)))
940 (index (if (null index)
942 (let ((index (reg-tn-encoding index)))
944 (error "can't index off of ESP")
946 (base (if (null base)
948 (reg-tn-encoding base))))
949 (emit-sib-byte segment ss index base)))
951 (emit-byte segment disp))
952 ((or (= mod #b10) (null base))
954 (emit-absolute-fixup segment disp)
955 (emit-dword segment disp))))))
957 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
958 (emit-absolute-fixup segment thing))))
960 (defun fp-reg-tn-p (thing)
962 (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
964 ;;; like the above, but for fp-instructions--jrd
965 (defun emit-fp-op (segment thing op)
966 (if (fp-reg-tn-p thing)
967 (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
970 (emit-ea segment thing op)))
972 (defun byte-reg-p (thing)
974 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
975 (member (sc-name (tn-sc thing)) *byte-sc-names*)
978 (defun byte-ea-p (thing)
980 (ea (eq (ea-size thing) :byte))
982 (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
985 (defun word-reg-p (thing)
987 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
988 (member (sc-name (tn-sc thing)) *word-sc-names*)
991 (defun word-ea-p (thing)
993 (ea (eq (ea-size thing) :word))
994 (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
997 (defun dword-reg-p (thing)
999 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
1000 (member (sc-name (tn-sc thing)) *dword-sc-names*)
1003 (defun dword-ea-p (thing)
1005 (ea (eq (ea-size thing) :dword))
1007 (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
1010 (defun register-p (thing)
1012 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
1014 (defun accumulator-p (thing)
1015 (and (register-p thing)
1016 (= (tn-offset thing) 0)))
1020 (def!constant +operand-size-prefix-byte+ #b01100110)
1022 (defun maybe-emit-operand-size-prefix (segment size)
1023 (unless (or (eq size :byte) (eq size +default-operand-size+))
1024 (emit-byte segment +operand-size-prefix-byte+)))
1026 (defun operand-size (thing)
1029 ;; FIXME: might as well be COND instead of having to use #. readmacro
1030 ;; to hack up the code
1031 (case (sc-name (tn-sc thing))
1038 ;; added by jrd: float-registers is a separate size (?)
1041 (#.*double-sc-names*
1044 (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
1050 (defun matching-operand-size (dst src)
1051 (let ((dst-size (operand-size dst))
1052 (src-size (operand-size src)))
1055 (if (eq dst-size src-size)
1057 (error "size mismatch: ~S is a ~S and ~S is a ~S."
1058 dst dst-size src src-size))
1062 (error "can't tell the size of either ~S or ~S" dst src)))))
1064 (defun emit-sized-immediate (segment size value)
1067 (emit-byte segment value))
1069 (emit-word segment value))
1071 (emit-dword segment value))))
1073 ;;;; general data transfer
1075 (define-instruction mov (segment dst src &optional prefix)
1076 ;; immediate to register
1077 (:printer reg ((op #b1011) (imm nil :type 'imm-data))
1078 '(:name :tab reg ", " imm))
1079 (:printer x66-reg ((op #b1011) (imm nil :type 'imm-data))
1080 '(:name :tab reg ", " imm))
1081 ;; absolute mem to/from accumulator
1082 (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
1083 `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
1084 (:printer x66-simple-dir ((op #b101000) (imm nil :type 'imm-addr))
1085 `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
1086 ;; register to/from register/memory
1087 (:printer reg-reg/mem-dir ((op #b100010)))
1088 (:printer x66-reg-reg/mem-dir ((op #b100010)))
1089 ;; immediate to register/memory
1090 (:printer reg/mem-imm ((op '(#b1100011 #b000))))
1091 (:printer x66-reg/mem-imm ((op '(#b1100011 #b000))))
1094 (emit-prefix segment prefix)
1095 (let ((size (matching-operand-size dst src)))
1096 (maybe-emit-operand-size-prefix segment size)
1097 (cond ((register-p dst)
1098 (cond ((integerp src)
1099 (emit-byte-with-reg segment
1103 (reg-tn-encoding dst))
1104 (emit-sized-immediate segment size src))
1105 ((and (fixup-p src) (accumulator-p dst))
1110 (emit-absolute-fixup segment src))
1116 (emit-ea segment src (reg-tn-encoding dst) t))))
1117 ((and (fixup-p dst) (accumulator-p src))
1118 (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
1119 (emit-absolute-fixup segment dst))
1121 (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
1122 (emit-ea segment dst #b000)
1123 (emit-sized-immediate segment size src))
1125 (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
1126 (emit-ea segment dst (reg-tn-encoding src)))
1128 (aver (eq size :dword))
1129 (emit-byte segment #b11000111)
1130 (emit-ea segment dst #b000)
1131 (emit-absolute-fixup segment src))
1133 (error "bogus arguments to MOV: ~S ~S" dst src))))))
1135 (defun emit-move-with-extension (segment dst src opcode)
1136 (aver (register-p dst))
1137 (let ((dst-size (operand-size dst))
1138 (src-size (operand-size src)))
1141 (aver (eq src-size :byte))
1142 (maybe-emit-operand-size-prefix segment :word)
1143 (emit-byte segment #b00001111)
1144 (emit-byte segment opcode)
1145 (emit-ea segment src (reg-tn-encoding dst)))
1149 (maybe-emit-operand-size-prefix segment :dword)
1150 (emit-byte segment #b00001111)
1151 (emit-byte segment opcode)
1152 (emit-ea segment src (reg-tn-encoding dst)))
1154 (emit-byte segment #b00001111)
1155 (emit-byte segment (logior opcode 1))
1156 (emit-ea segment src (reg-tn-encoding dst))))))))
1158 (define-instruction movsx (segment dst src)
1159 (:printer ext-reg-reg/mem ((op #b1011111)
1160 (reg nil :type 'word-reg)
1161 (reg/mem nil :type 'sized-reg/mem)))
1162 (:printer x66-ext-reg-reg/mem ((op #b1011111)
1163 (reg nil :type 'word-reg)
1164 (reg/mem nil :type 'sized-reg/mem)))
1165 (:emitter (emit-move-with-extension segment dst src #b10111110)))
1167 (define-instruction movzx (segment dst src)
1168 (:printer ext-reg-reg/mem ((op #b1011011)
1169 (reg nil :type 'word-reg)
1170 (reg/mem nil :type 'sized-reg/mem)))
1171 (:printer x66-ext-reg-reg/mem ((op #b1011011)
1172 (reg nil :type 'word-reg)
1173 (reg/mem nil :type 'sized-reg/mem)))
1174 (:emitter (emit-move-with-extension segment dst src #b10110110)))
1176 (define-instruction push (segment src &optional prefix)
1178 (:printer reg-no-width ((op #b01010)))
1179 (:printer x66-reg-no-width ((op #b01010)))
1181 (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
1182 (:printer x66-reg/mem ((op '(#b1111111 #b110)) (width 1)))
1184 (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
1186 (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
1188 ;; ### segment registers?
1191 (emit-prefix segment prefix)
1192 (cond ((integerp src)
1193 (cond ((<= -128 src 127)
1194 (emit-byte segment #b01101010)
1195 (emit-byte segment src))
1197 (emit-byte segment #b01101000)
1198 (emit-dword segment src))))
1200 ;; Interpret the fixup as an immediate dword to push.
1201 (emit-byte segment #b01101000)
1202 (emit-absolute-fixup segment src))
1204 (let ((size (operand-size src)))
1205 (aver (not (eq size :byte)))
1206 (maybe-emit-operand-size-prefix segment size)
1207 (cond ((register-p src)
1208 (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
1210 (emit-byte segment #b11111111)
1211 (emit-ea segment src #b110 t))))))))
1213 (define-instruction pusha (segment)
1214 (:printer byte ((op #b01100000)))
1216 (emit-byte segment #b01100000)))
1218 (define-instruction pop (segment dst)
1219 (:printer x66-reg-no-width ((op #b01011)))
1220 (:printer reg-no-width ((op #b01011)))
1221 (:printer x66-reg/mem ((op '(#b1000111 #b000)) (width 1)))
1222 (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
1224 (let ((size (operand-size dst)))
1225 (aver (not (eq size :byte)))
1226 (maybe-emit-operand-size-prefix segment size)
1227 (cond ((register-p dst)
1228 (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
1230 (emit-byte segment #b10001111)
1231 (emit-ea segment dst #b000))))))
1233 (define-instruction popa (segment)
1234 (:printer byte ((op #b01100001)))
1236 (emit-byte segment #b01100001)))
1238 (define-instruction xchg (segment operand1 operand2)
1239 ;; Register with accumulator.
1240 (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1241 (:printer x66-reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1242 ;; Register/Memory with Register.
1243 (:printer reg-reg/mem ((op #b1000011)))
1244 (:printer x66-reg-reg/mem ((op #b1000011)))
1246 (let ((size (matching-operand-size operand1 operand2)))
1247 (maybe-emit-operand-size-prefix segment size)
1248 (labels ((xchg-acc-with-something (acc something)
1249 (if (and (not (eq size :byte)) (register-p something))
1250 (emit-byte-with-reg segment
1252 (reg-tn-encoding something))
1253 (xchg-reg-with-something acc something)))
1254 (xchg-reg-with-something (reg something)
1255 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1256 (emit-ea segment something (reg-tn-encoding reg))))
1257 (cond ((accumulator-p operand1)
1258 (xchg-acc-with-something operand1 operand2))
1259 ((accumulator-p operand2)
1260 (xchg-acc-with-something operand2 operand1))
1261 ((register-p operand1)
1262 (xchg-reg-with-something operand1 operand2))
1263 ((register-p operand2)
1264 (xchg-reg-with-something operand2 operand1))
1266 (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1268 (define-instruction lea (segment dst src)
1269 (:printer reg-reg/mem ((op #b1000110) (width 1)))
1271 (aver (dword-reg-p dst))
1272 (emit-byte segment #b10001101)
1273 (emit-ea segment src (reg-tn-encoding dst))))
1275 (define-instruction cmpxchg (segment dst src &optional prefix)
1276 ;; Register/Memory with Register.
1277 (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1278 (:printer x66-ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1280 (aver (register-p src))
1281 (emit-prefix segment prefix)
1282 (let ((size (matching-operand-size src dst)))
1283 (maybe-emit-operand-size-prefix segment size)
1284 (emit-byte segment #b00001111)
1285 (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1286 (emit-ea segment dst (reg-tn-encoding src)))))
1288 (define-instruction pause (segment)
1289 (:printer two-bytes ((op '(#xf3 #x90))))
1291 (emit-byte segment #xf3)
1292 (emit-byte segment #x90)))
1294 (defun emit-prefix (segment name)
1299 (emit-byte segment #xf0))
1301 (emit-byte segment #x64))
1303 (emit-byte segment #x65))))
1305 (define-instruction fs-segment-prefix (segment)
1306 (:printer byte ((op #b01100100)))
1308 (bug "FS emitted as a separate instruction!")))
1310 (define-instruction gs-segment-prefix (segment)
1311 (:printer byte ((op #b01100101)))
1313 (bug "GS emitted as a separate instruction!")))
1315 ;;;; flag control instructions
1317 ;;; CLC -- Clear Carry Flag.
1318 (define-instruction clc (segment)
1319 (:printer byte ((op #b11111000)))
1321 (emit-byte segment #b11111000)))
1323 ;;; CLD -- Clear Direction Flag.
1324 (define-instruction cld (segment)
1325 (:printer byte ((op #b11111100)))
1327 (emit-byte segment #b11111100)))
1329 ;;; CLI -- Clear Iterrupt Enable Flag.
1330 (define-instruction cli (segment)
1331 (:printer byte ((op #b11111010)))
1333 (emit-byte segment #b11111010)))
1335 ;;; CMC -- Complement Carry Flag.
1336 (define-instruction cmc (segment)
1337 (:printer byte ((op #b11110101)))
1339 (emit-byte segment #b11110101)))
1341 ;;; LAHF -- Load AH into flags.
1342 (define-instruction lahf (segment)
1343 (:printer byte ((op #b10011111)))
1345 (emit-byte segment #b10011111)))
1347 ;;; POPF -- Pop flags.
1348 (define-instruction popf (segment)
1349 (:printer byte ((op #b10011101)))
1351 (emit-byte segment #b10011101)))
1353 ;;; PUSHF -- push flags.
1354 (define-instruction pushf (segment)
1355 (:printer byte ((op #b10011100)))
1357 (emit-byte segment #b10011100)))
1359 ;;; SAHF -- Store AH into flags.
1360 (define-instruction sahf (segment)
1361 (:printer byte ((op #b10011110)))
1363 (emit-byte segment #b10011110)))
1365 ;;; STC -- Set Carry Flag.
1366 (define-instruction stc (segment)
1367 (:printer byte ((op #b11111001)))
1369 (emit-byte segment #b11111001)))
1371 ;;; STD -- Set Direction Flag.
1372 (define-instruction std (segment)
1373 (:printer byte ((op #b11111101)))
1375 (emit-byte segment #b11111101)))
1377 ;;; STI -- Set Interrupt Enable Flag.
1378 (define-instruction sti (segment)
1379 (:printer byte ((op #b11111011)))
1381 (emit-byte segment #b11111011)))
1385 (defun emit-random-arith-inst (name segment dst src opcode
1386 &optional allow-constants)
1387 (let ((size (matching-operand-size dst src)))
1388 (maybe-emit-operand-size-prefix segment size)
1391 (cond ((and (not (eq size :byte)) (<= -128 src 127))
1392 (emit-byte segment #b10000011)
1393 (emit-ea segment dst opcode allow-constants)
1394 (emit-byte segment src))
1395 ((accumulator-p dst)
1402 (emit-sized-immediate segment size src))
1404 (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1405 (emit-ea segment dst opcode allow-constants)
1406 (emit-sized-immediate segment size src))))
1411 (if (eq size :byte) #b00000000 #b00000001)))
1412 (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1417 (if (eq size :byte) #b00000010 #b00000011)))
1418 (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1420 (error "bogus operands to ~A" name)))))
1422 (eval-when (:compile-toplevel :execute)
1423 (defun arith-inst-printer-list (subop)
1424 `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1425 (x66-accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1426 (reg/mem-imm ((op (#b1000000 ,subop))))
1427 (x66-reg/mem-imm ((op (#b1000000 ,subop))))
1428 (reg/mem-imm ((op (#b1000001 ,subop))
1429 (imm nil :type signed-imm-byte)))
1430 (x66-reg/mem-imm ((op (#b1000001 ,subop))
1431 (imm nil :type signed-imm-byte)))
1432 (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
1433 (x66-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1436 (define-instruction add (segment dst src &optional prefix)
1437 (:printer-list (arith-inst-printer-list #b000))
1439 (emit-prefix segment prefix)
1440 (emit-random-arith-inst "ADD" segment dst src #b000)))
1442 (define-instruction adc (segment dst src)
1443 (:printer-list (arith-inst-printer-list #b010))
1444 (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1446 (define-instruction sub (segment dst src &optional prefix)
1447 (:printer-list (arith-inst-printer-list #b101))
1449 (emit-prefix segment prefix)
1450 (emit-random-arith-inst "SUB" segment dst src #b101)))
1452 (define-instruction sbb (segment dst src)
1453 (:printer-list (arith-inst-printer-list #b011))
1454 (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1456 (define-instruction cmp (segment dst src &optional prefix)
1457 (:printer-list (arith-inst-printer-list #b111))
1459 (emit-prefix segment prefix)
1460 (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1462 (define-instruction inc (segment dst)
1464 (:printer reg-no-width ((op #b01000)))
1465 (:printer x66-reg-no-width ((op #b01000)))
1467 (:printer reg/mem ((op '(#b1111111 #b000))))
1468 (:printer x66-reg/mem ((op '(#b1111111 #b000))))
1470 (let ((size (operand-size dst)))
1471 (maybe-emit-operand-size-prefix segment size)
1472 (cond ((and (not (eq size :byte)) (register-p dst))
1473 (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1475 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1476 (emit-ea segment dst #b000))))))
1478 (define-instruction dec (segment dst)
1480 (:printer reg-no-width ((op #b01001)))
1481 (:printer x66-reg-no-width ((op #b01001)))
1483 (:printer reg/mem ((op '(#b1111111 #b001))))
1484 (:printer x66-reg/mem ((op '(#b1111111 #b001))))
1486 (let ((size (operand-size dst)))
1487 (maybe-emit-operand-size-prefix segment size)
1488 (cond ((and (not (eq size :byte)) (register-p dst))
1489 (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1491 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1492 (emit-ea segment dst #b001))))))
1494 (define-instruction neg (segment dst)
1495 (:printer reg/mem ((op '(#b1111011 #b011))))
1496 (:printer x66-reg/mem ((op '(#b1111011 #b011))))
1498 (let ((size (operand-size dst)))
1499 (maybe-emit-operand-size-prefix segment size)
1500 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1501 (emit-ea segment dst #b011))))
1503 (define-instruction aaa (segment)
1504 (:printer byte ((op #b00110111)))
1506 (emit-byte segment #b00110111)))
1508 (define-instruction aas (segment)
1509 (:printer byte ((op #b00111111)))
1511 (emit-byte segment #b00111111)))
1513 (define-instruction daa (segment)
1514 (:printer byte ((op #b00100111)))
1516 (emit-byte segment #b00100111)))
1518 (define-instruction das (segment)
1519 (:printer byte ((op #b00101111)))
1521 (emit-byte segment #b00101111)))
1523 (define-instruction mul (segment dst src)
1524 (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1525 (:printer x66-accum-reg/mem ((op '(#b1111011 #b100))))
1527 (let ((size (matching-operand-size dst src)))
1528 (aver (accumulator-p dst))
1529 (maybe-emit-operand-size-prefix segment size)
1530 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1531 (emit-ea segment src #b100))))
1533 (define-instruction imul (segment dst &optional src1 src2)
1534 (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1535 (:printer x66-accum-reg/mem ((op '(#b1111011 #b101))))
1536 (:printer ext-reg-reg/mem ((op #b1010111)))
1537 (:printer x66-ext-reg-reg/mem ((op #b1010111)))
1538 (:printer reg-reg/mem ((op #b0110100) (width 1)
1539 (imm nil :type 'signed-imm-word))
1540 '(:name :tab reg ", " reg/mem ", " imm))
1541 (:printer x66-reg-reg/mem ((op #b0110100) (width 1)
1542 (imm nil :type 'signed-imm-word))
1543 '(:name :tab reg ", " reg/mem ", " imm))
1544 (:printer reg-reg/mem ((op #b0110101) (width 1)
1545 (imm nil :type 'signed-imm-byte))
1546 '(:name :tab reg ", " reg/mem ", " imm))
1547 (:printer x66-reg-reg/mem ((op #b0110101) (width 1)
1548 (imm nil :type 'signed-imm-byte))
1549 '(:name :tab reg ", " reg/mem ", " imm))
1551 (flet ((r/m-with-immed-to-reg (reg r/m immed)
1552 (let* ((size (matching-operand-size reg r/m))
1553 (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1554 (maybe-emit-operand-size-prefix segment size)
1555 (emit-byte segment (if sx #b01101011 #b01101001))
1556 (emit-ea segment r/m (reg-tn-encoding reg))
1558 (emit-byte segment immed)
1559 (emit-sized-immediate segment size immed)))))
1561 (r/m-with-immed-to-reg dst src1 src2))
1564 (r/m-with-immed-to-reg dst dst src1)
1565 (let ((size (matching-operand-size dst src1)))
1566 (maybe-emit-operand-size-prefix segment size)
1567 (emit-byte segment #b00001111)
1568 (emit-byte segment #b10101111)
1569 (emit-ea segment src1 (reg-tn-encoding dst)))))
1571 (let ((size (operand-size dst)))
1572 (maybe-emit-operand-size-prefix segment size)
1573 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1574 (emit-ea segment dst #b101)))))))
1576 (define-instruction div (segment dst src)
1577 (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1578 (:printer x66-accum-reg/mem ((op '(#b1111011 #b110))))
1580 (let ((size (matching-operand-size dst src)))
1581 (aver (accumulator-p dst))
1582 (maybe-emit-operand-size-prefix segment size)
1583 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1584 (emit-ea segment src #b110))))
1586 (define-instruction idiv (segment dst src)
1587 (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1588 (:printer x66-accum-reg/mem ((op '(#b1111011 #b111))))
1590 (let ((size (matching-operand-size dst src)))
1591 (aver (accumulator-p dst))
1592 (maybe-emit-operand-size-prefix segment size)
1593 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1594 (emit-ea segment src #b111))))
1596 (define-instruction aad (segment)
1597 (:printer two-bytes ((op '(#b11010101 #b00001010))))
1599 (emit-byte segment #b11010101)
1600 (emit-byte segment #b00001010)))
1602 (define-instruction aam (segment)
1603 (:printer two-bytes ((op '(#b11010100 #b00001010))))
1605 (emit-byte segment #b11010100)
1606 (emit-byte segment #b00001010)))
1608 (define-instruction bswap (segment dst)
1609 (:printer ext-reg-no-width ((op #b11001)))
1611 (emit-byte segment #x0f)
1612 (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst))))
1614 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1615 (define-instruction cbw (segment)
1616 (:printer two-bytes ((op '(#b01100110 #b10011000))))
1618 (maybe-emit-operand-size-prefix segment :word)
1619 (emit-byte segment #b10011000)))
1621 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1622 (define-instruction cwde (segment)
1623 (:printer byte ((op #b10011000)))
1625 (maybe-emit-operand-size-prefix segment :dword)
1626 (emit-byte segment #b10011000)))
1628 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1629 (define-instruction cwd (segment)
1630 (:printer two-bytes ((op '(#b01100110 #b10011001))))
1632 (maybe-emit-operand-size-prefix segment :word)
1633 (emit-byte segment #b10011001)))
1635 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1636 (define-instruction cdq (segment)
1637 (:printer byte ((op #b10011001)))
1639 (maybe-emit-operand-size-prefix segment :dword)
1640 (emit-byte segment #b10011001)))
1642 (define-instruction xadd (segment dst src &optional prefix)
1643 ;; Register/Memory with Register.
1644 (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1645 (:printer x66-ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1647 (aver (register-p src))
1648 (emit-prefix segment prefix)
1649 (let ((size (matching-operand-size src dst)))
1650 (maybe-emit-operand-size-prefix segment size)
1651 (emit-byte segment #b00001111)
1652 (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1653 (emit-ea segment dst (reg-tn-encoding src)))))
1658 (defun emit-shift-inst (segment dst amount opcode)
1659 (let ((size (operand-size dst)))
1660 (maybe-emit-operand-size-prefix segment size)
1661 (multiple-value-bind (major-opcode immed)
1663 (:cl (values #b11010010 nil))
1664 (1 (values #b11010000 nil))
1665 (t (values #b11000000 t)))
1667 (if (eq size :byte) major-opcode (logior major-opcode 1)))
1668 (emit-ea segment dst opcode)
1670 (emit-byte segment amount)))))
1672 (eval-when (:compile-toplevel :execute)
1673 (defun shift-inst-printer-list (subop)
1674 `((reg/mem ((op (#b1101000 ,subop)))
1675 (:name :tab reg/mem ", 1"))
1676 (x66-reg/mem ((op (#b1101000 ,subop)))
1677 (:name :tab reg/mem ", 1"))
1678 (reg/mem ((op (#b1101001 ,subop)))
1679 (:name :tab reg/mem ", " 'cl))
1680 (x66-reg/mem ((op (#b1101001 ,subop)))
1681 (:name :tab reg/mem ", " 'cl))
1682 (reg/mem-imm ((op (#b1100000 ,subop))
1683 (imm nil :type signed-imm-byte)))
1684 (x66-reg/mem-imm ((op (#b1100000 ,subop))
1685 (imm nil :type signed-imm-byte))))))
1687 (define-instruction rol (segment dst amount)
1689 (shift-inst-printer-list #b000))
1691 (emit-shift-inst segment dst amount #b000)))
1693 (define-instruction ror (segment dst amount)
1695 (shift-inst-printer-list #b001))
1697 (emit-shift-inst segment dst amount #b001)))
1699 (define-instruction rcl (segment dst amount)
1701 (shift-inst-printer-list #b010))
1703 (emit-shift-inst segment dst amount #b010)))
1705 (define-instruction rcr (segment dst amount)
1707 (shift-inst-printer-list #b011))
1709 (emit-shift-inst segment dst amount #b011)))
1711 (define-instruction shl (segment dst amount)
1713 (shift-inst-printer-list #b100))
1715 (emit-shift-inst segment dst amount #b100)))
1717 (define-instruction shr (segment dst amount)
1719 (shift-inst-printer-list #b101))
1721 (emit-shift-inst segment dst amount #b101)))
1723 (define-instruction sar (segment dst amount)
1725 (shift-inst-printer-list #b111))
1727 (emit-shift-inst segment dst amount #b111)))
1729 (defun emit-double-shift (segment opcode dst src amt)
1730 (let ((size (matching-operand-size dst src)))
1731 (when (eq size :byte)
1732 (error "Double shifts can only be used with words."))
1733 (maybe-emit-operand-size-prefix segment size)
1734 (emit-byte segment #b00001111)
1735 (emit-byte segment (dpb opcode (byte 1 3)
1736 (if (eq amt :cl) #b10100101 #b10100100)))
1738 (emit-ea segment dst src)
1739 (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1740 (unless (eq amt :cl)
1741 (emit-byte segment amt))))
1743 (eval-when (:compile-toplevel :execute)
1744 (defun double-shift-inst-printer-list (op)
1746 (ext-reg-reg/mem-imm ((op ,(logior op #b10))
1747 (imm nil :type signed-imm-byte)))
1748 (ext-reg-reg/mem ((op ,(logior op #b10)))
1749 (:name :tab reg/mem ", " reg ", " 'cl))
1750 (x66-ext-reg-reg/mem ((op ,(logior op #b10)))
1751 (:name :tab reg/mem ", " reg ", " 'cl)))))
1753 (define-instruction shld (segment dst src amt)
1754 (:declare (type (or (member :cl) (mod 32)) amt))
1755 (:printer-list (double-shift-inst-printer-list #b1010000))
1757 (emit-double-shift segment #b0 dst src amt)))
1759 (define-instruction shrd (segment dst src amt)
1760 (:declare (type (or (member :cl) (mod 32)) amt))
1761 (:printer-list (double-shift-inst-printer-list #b1010100))
1763 (emit-double-shift segment #b1 dst src amt)))
1765 (define-instruction and (segment dst src)
1767 (arith-inst-printer-list #b100))
1769 (emit-random-arith-inst "AND" segment dst src #b100)))
1771 (define-instruction test (segment this that)
1772 (:printer accum-imm ((op #b1010100)))
1773 (:printer x66-accum-imm ((op #b1010100)))
1774 (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1775 (:printer x66-reg/mem-imm ((op '(#b1111011 #b000))))
1776 (:printer reg-reg/mem ((op #b1000010)))
1777 (:printer x66-reg-reg/mem ((op #b1000010)))
1779 (let ((size (matching-operand-size this that)))
1780 (maybe-emit-operand-size-prefix segment size)
1781 (flet ((test-immed-and-something (immed something)
1782 (cond ((accumulator-p something)
1784 (if (eq size :byte) #b10101000 #b10101001))
1785 (emit-sized-immediate segment size immed))
1788 (if (eq size :byte) #b11110110 #b11110111))
1789 (emit-ea segment something #b000)
1790 (emit-sized-immediate segment size immed))))
1791 (test-reg-and-something (reg something)
1792 (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1793 (emit-ea segment something (reg-tn-encoding reg))))
1794 (cond ((integerp that)
1795 (test-immed-and-something that this))
1797 (test-immed-and-something this that))
1799 (test-reg-and-something this that))
1801 (test-reg-and-something that this))
1803 (error "bogus operands for TEST: ~S and ~S" this that)))))))
1805 ;;; Emit the most compact form of the test immediate instruction,
1806 ;;; using an 8 bit test when the immediate is only 8 bits and the
1807 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
1809 (defun emit-optimized-test-inst (x y)
1812 (let ((offset (tn-offset x)))
1813 (cond ((and (sc-is x any-reg descriptor-reg)
1814 (or (= offset eax-offset) (= offset ebx-offset)
1815 (= offset ecx-offset) (= offset edx-offset)))
1816 (inst test (make-random-tn :kind :normal
1817 :sc (sc-or-lose 'byte-reg)
1820 ((sc-is x control-stack)
1821 (inst test (make-ea :byte :base ebp-tn
1822 :disp (frame-byte-offset offset))
1829 (define-instruction or (segment dst src &optional prefix)
1831 (arith-inst-printer-list #b001))
1833 (emit-prefix segment prefix)
1834 (emit-random-arith-inst "OR" segment dst src #b001)))
1836 (define-instruction xor (segment dst src &optional prefix)
1838 (arith-inst-printer-list #b110))
1840 (emit-prefix segment prefix)
1841 (emit-random-arith-inst "XOR" segment dst src #b110)))
1843 (define-instruction not (segment dst)
1844 (:printer reg/mem ((op '(#b1111011 #b010))))
1845 (:printer x66-reg/mem ((op '(#b1111011 #b010))))
1847 (let ((size (operand-size dst)))
1848 (maybe-emit-operand-size-prefix segment size)
1849 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1850 (emit-ea segment dst #b010))))
1852 ;;;; string manipulation
1854 (define-instruction cmps (segment size)
1855 (:printer string-op ((op #b1010011)))
1856 (:printer x66-string-op ((op #b1010011)))
1858 (maybe-emit-operand-size-prefix segment size)
1859 (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1861 (define-instruction ins (segment acc)
1862 (:printer string-op ((op #b0110110)))
1863 (:printer x66-string-op ((op #b0110110)))
1865 (let ((size (operand-size acc)))
1866 (aver (accumulator-p acc))
1867 (maybe-emit-operand-size-prefix segment size)
1868 (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1870 (define-instruction lods (segment acc)
1871 (:printer string-op ((op #b1010110)))
1872 (:printer x66-string-op ((op #b1010110)))
1874 (let ((size (operand-size acc)))
1875 (aver (accumulator-p acc))
1876 (maybe-emit-operand-size-prefix segment size)
1877 (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1879 (define-instruction movs (segment size)
1880 (:printer string-op ((op #b1010010)))
1881 (:printer x66-string-op ((op #b1010010)))
1883 (maybe-emit-operand-size-prefix segment size)
1884 (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1886 (define-instruction outs (segment acc)
1887 (:printer string-op ((op #b0110111)))
1888 (:printer x66-string-op ((op #b0110111)))
1890 (let ((size (operand-size acc)))
1891 (aver (accumulator-p acc))
1892 (maybe-emit-operand-size-prefix segment size)
1893 (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1895 (define-instruction scas (segment acc)
1896 (:printer string-op ((op #b1010111)))
1897 (:printer x66-string-op ((op #b1010111)))
1899 (let ((size (operand-size acc)))
1900 (aver (accumulator-p acc))
1901 (maybe-emit-operand-size-prefix segment size)
1902 (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1904 (define-instruction stos (segment acc)
1905 (:printer string-op ((op #b1010101)))
1906 (:printer x66-string-op ((op #b1010101)))
1908 (let ((size (operand-size acc)))
1909 (aver (accumulator-p acc))
1910 (maybe-emit-operand-size-prefix segment size)
1911 (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1913 (define-instruction xlat (segment)
1914 (:printer byte ((op #b11010111)))
1916 (emit-byte segment #b11010111)))
1918 (define-instruction rep (segment)
1920 (emit-byte segment #b11110011)))
1922 (define-instruction repe (segment)
1923 (:printer byte ((op #b11110011)))
1925 (emit-byte segment #b11110011)))
1927 (define-instruction repne (segment)
1928 (:printer byte ((op #b11110010)))
1930 (emit-byte segment #b11110010)))
1933 ;;;; bit manipulation
1935 (define-instruction bsf (segment dst src)
1936 (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
1937 (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 0)))
1939 (let ((size (matching-operand-size dst src)))
1940 (when (eq size :byte)
1941 (error "can't scan bytes: ~S" src))
1942 (maybe-emit-operand-size-prefix segment size)
1943 (emit-byte segment #b00001111)
1944 (emit-byte segment #b10111100)
1945 (emit-ea segment src (reg-tn-encoding dst)))))
1947 (define-instruction bsr (segment dst src)
1948 (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
1949 (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 1)))
1951 (let ((size (matching-operand-size dst src)))
1952 (when (eq size :byte)
1953 (error "can't scan bytes: ~S" src))
1954 (maybe-emit-operand-size-prefix segment size)
1955 (emit-byte segment #b00001111)
1956 (emit-byte segment #b10111101)
1957 (emit-ea segment src (reg-tn-encoding dst)))))
1959 (defun emit-bit-test-and-mumble (segment src index opcode)
1960 (let ((size (operand-size src)))
1961 (when (eq size :byte)
1962 (error "can't scan bytes: ~S" src))
1963 (maybe-emit-operand-size-prefix segment size)
1964 (emit-byte segment #b00001111)
1965 (cond ((integerp index)
1966 (emit-byte segment #b10111010)
1967 (emit-ea segment src opcode)
1968 (emit-byte segment index))
1970 (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1971 (emit-ea segment src (reg-tn-encoding index))))))
1973 (eval-when (:compile-toplevel :execute)
1974 (defun bit-test-inst-printer-list (subop)
1975 `((ext-reg/mem-imm ((op (#b1011101 ,subop))
1976 (reg/mem nil :type word-reg/mem)
1977 (imm nil :type imm-data)
1979 (x66-ext-reg/mem-imm ((op (#b1011101 ,subop))
1980 (reg/mem nil :type word-reg/mem)
1981 (imm nil :type imm-data)
1983 (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1985 (:name :tab reg/mem ", " reg))
1986 (x66-ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1988 (:name :tab reg/mem ", " reg)))))
1990 (define-instruction bt (segment src index)
1991 (:printer-list (bit-test-inst-printer-list #b100))
1993 (emit-bit-test-and-mumble segment src index #b100)))
1995 (define-instruction btc (segment src index)
1996 (:printer-list (bit-test-inst-printer-list #b111))
1998 (emit-bit-test-and-mumble segment src index #b111)))
2000 (define-instruction btr (segment src index)
2001 (:printer-list (bit-test-inst-printer-list #b110))
2003 (emit-bit-test-and-mumble segment src index #b110)))
2005 (define-instruction bts (segment src index)
2006 (:printer-list (bit-test-inst-printer-list #b101))
2008 (emit-bit-test-and-mumble segment src index #b101)))
2011 ;;;; control transfer
2013 (define-instruction call (segment where)
2014 (:printer near-jump ((op #b11101000)))
2015 (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
2019 (emit-byte segment #b11101000)
2020 (emit-back-patch segment
2022 (lambda (segment posn)
2024 (- (label-position where)
2027 (emit-byte segment #b11101000)
2028 (emit-relative-fixup segment where))
2030 (emit-byte segment #b11111111)
2031 (emit-ea segment where #b010)))))
2033 (defun emit-byte-displacement-backpatch (segment target)
2034 (emit-back-patch segment
2036 (lambda (segment posn)
2037 (let ((disp (- (label-position target) (1+ posn))))
2038 (aver (<= -128 disp 127))
2039 (emit-byte segment disp)))))
2041 (define-instruction jmp (segment cond &optional where)
2042 ;; conditional jumps
2043 (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
2044 (:printer near-cond-jump () '('j cc :tab label))
2045 ;; unconditional jumps
2046 (:printer short-jump ((op #b1011)))
2047 (:printer near-jump ((op #b11101001)) )
2048 (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
2053 (lambda (segment posn delta-if-after)
2054 (let ((disp (- (label-position where posn delta-if-after)
2056 (when (<= -128 disp 127)
2058 (dpb (conditional-opcode cond)
2061 (emit-byte-displacement-backpatch segment where)
2063 (lambda (segment posn)
2064 (let ((disp (- (label-position where) (+ posn 6))))
2065 (emit-byte segment #b00001111)
2067 (dpb (conditional-opcode cond)
2070 (emit-dword segment disp)))))
2071 ((label-p (setq where cond))
2074 (lambda (segment posn delta-if-after)
2075 (let ((disp (- (label-position where posn delta-if-after)
2077 (when (<= -128 disp 127)
2078 (emit-byte segment #b11101011)
2079 (emit-byte-displacement-backpatch segment where)
2081 (lambda (segment posn)
2082 (let ((disp (- (label-position where) (+ posn 5))))
2083 (emit-byte segment #b11101001)
2084 (emit-dword segment disp)))))
2086 (emit-byte segment #b11101001)
2087 (emit-relative-fixup segment where))
2089 (unless (or (ea-p where) (tn-p where))
2090 (error "don't know what to do with ~A" where))
2091 (emit-byte segment #b11111111)
2092 (emit-ea segment where #b100)))))
2094 (define-instruction jmp-short (segment label)
2096 (emit-byte segment #b11101011)
2097 (emit-byte-displacement-backpatch segment label)))
2099 (define-instruction ret (segment &optional stack-delta)
2100 (:printer byte ((op #b11000011)))
2101 (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
2104 (cond ((and stack-delta (not (zerop stack-delta)))
2105 (emit-byte segment #b11000010)
2106 (emit-word segment stack-delta))
2108 (emit-byte segment #b11000011)))))
2110 (define-instruction jecxz (segment target)
2111 (:printer short-jump ((op #b0011)))
2113 (emit-byte segment #b11100011)
2114 (emit-byte-displacement-backpatch segment target)))
2116 (define-instruction loop (segment target)
2117 (:printer short-jump ((op #b0010)))
2119 (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
2120 (emit-byte-displacement-backpatch segment target)))
2122 (define-instruction loopz (segment target)
2123 (:printer short-jump ((op #b0001)))
2125 (emit-byte segment #b11100001)
2126 (emit-byte-displacement-backpatch segment target)))
2128 (define-instruction loopnz (segment target)
2129 (:printer short-jump ((op #b0000)))
2131 (emit-byte segment #b11100000)
2132 (emit-byte-displacement-backpatch segment target)))
2134 ;;;; conditional move
2135 (define-instruction cmov (segment cond dst src)
2136 (:printer cond-move ())
2137 (:printer x66-cond-move ())
2139 (aver (register-p dst))
2140 (let ((size (matching-operand-size dst src)))
2141 (aver (or (eq size :word) (eq size :dword)))
2142 (maybe-emit-operand-size-prefix segment size))
2143 (emit-byte segment #b00001111)
2144 (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
2145 (emit-ea segment src (reg-tn-encoding dst))))
2147 ;;;; conditional byte set
2149 (define-instruction set (segment dst cond)
2150 (:printer cond-set ())
2152 (emit-byte segment #b00001111)
2153 (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
2154 (emit-ea segment dst #b000)))
2158 (define-instruction enter (segment disp &optional (level 0))
2159 (:declare (type (unsigned-byte 16) disp)
2160 (type (unsigned-byte 8) level))
2161 (:printer enter-format ((op #b11001000)))
2163 (emit-byte segment #b11001000)
2164 (emit-word segment disp)
2165 (emit-byte segment level)))
2167 (define-instruction leave (segment)
2168 (:printer byte ((op #b11001001)))
2170 (emit-byte segment #b11001001)))
2173 (define-instruction prefetchnta (segment ea)
2174 (:printer prefetch ((op #b00011000) (reg #b000)))
2176 (aver (typep ea 'ea))
2177 (aver (eq :byte (ea-size ea)))
2178 (emit-byte segment #b00001111)
2179 (emit-byte segment #b00011000)
2180 (emit-ea segment ea #b000)))
2182 (define-instruction prefetcht0 (segment ea)
2183 (:printer prefetch ((op #b00011000) (reg #b001)))
2185 (aver (typep ea 'ea))
2186 (aver (eq :byte (ea-size ea)))
2187 (emit-byte segment #b00001111)
2188 (emit-byte segment #b00011000)
2189 (emit-ea segment ea #b001)))
2191 (define-instruction prefetcht1 (segment ea)
2192 (:printer prefetch ((op #b00011000) (reg #b010)))
2194 (aver (typep ea 'ea))
2195 (aver (eq :byte (ea-size ea)))
2196 (emit-byte segment #b00001111)
2197 (emit-byte segment #b00011000)
2198 (emit-ea segment ea #b010)))
2200 (define-instruction prefetcht2 (segment ea)
2201 (:printer prefetch ((op #b00011000) (reg #b011)))
2203 (aver (typep ea 'ea))
2204 (aver (eq :byte (ea-size ea)))
2205 (emit-byte segment #b00001111)
2206 (emit-byte segment #b00011000)
2207 (emit-ea segment ea #b011)))
2209 ;;;; interrupt instructions
2211 (defun snarf-error-junk (sap offset &optional length-only)
2212 (let* ((length (sb!sys:sap-ref-8 sap offset))
2213 (vector (make-array length :element-type '(unsigned-byte 8))))
2214 (declare (type sb!sys:system-area-pointer sap)
2215 (type (unsigned-byte 8) length)
2216 (type (simple-array (unsigned-byte 8) (*)) vector))
2218 (values 0 (1+ length) nil nil))
2220 (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
2222 (collect ((sc-offsets)
2224 (lengths 1) ; the length byte
2226 (error-number (sb!c:read-var-integer vector index)))
2229 (when (>= index length)
2231 (let ((old-index index))
2232 (sc-offsets (sb!c:read-var-integer vector index))
2233 (lengths (- index old-index))))
2234 (values error-number
2240 (defmacro break-cases (breaknum &body cases)
2241 (let ((bn-temp (gensym)))
2242 (collect ((clauses))
2243 (dolist (case cases)
2244 (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
2245 `(let ((,bn-temp ,breaknum))
2246 (cond ,@(clauses))))))
2249 (defun break-control (chunk inst stream dstate)
2250 (declare (ignore inst))
2251 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
2252 ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
2253 ;; map has it undefined; and it should be easier to look in the target
2254 ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
2255 ;; from first principles whether it's defined in some way that genesis
2257 (case #!-ud2-breakpoints (byte-imm-code chunk dstate)
2258 #!+ud2-breakpoints (word-imm-code chunk dstate)
2261 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2264 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2266 (nt "breakpoint trap"))
2267 (#.pending-interrupt-trap
2268 (nt "pending interrupt trap"))
2271 (#.fun-end-breakpoint-trap
2272 (nt "function end breakpoint trap")))))
2274 (define-instruction break (segment code)
2275 (:declare (type (unsigned-byte 8) code))
2276 #!-ud2-breakpoints (:printer byte-imm ((op #b11001100)) '(:name :tab code)
2277 :control #'break-control)
2278 #!+ud2-breakpoints (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
2279 :control #'break-control)
2281 #!-ud2-breakpoints (emit-byte segment #b11001100)
2282 ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
2283 ;; throw a sigill with 0x0b0f instead and check for this in the
2284 ;; SIGILL handler and pass it on to the sigtrap handler if
2286 #!+ud2-breakpoints (emit-word segment #b0000101100001111)
2287 (emit-byte segment code)))
2289 (define-instruction int (segment number)
2290 (:declare (type (unsigned-byte 8) number))
2291 (:printer byte-imm ((op #b11001101)))
2295 (emit-byte segment #b11001100))
2297 (emit-byte segment #b11001101)
2298 (emit-byte segment number)))))
2300 (define-instruction into (segment)
2301 (:printer byte ((op #b11001110)))
2303 (emit-byte segment #b11001110)))
2305 (define-instruction bound (segment reg bounds)
2307 (let ((size (matching-operand-size reg bounds)))
2308 (when (eq size :byte)
2309 (error "can't bounds-test bytes: ~S" reg))
2310 (maybe-emit-operand-size-prefix segment size)
2311 (emit-byte segment #b01100010)
2312 (emit-ea segment bounds (reg-tn-encoding reg)))))
2314 (define-instruction iret (segment)
2315 (:printer byte ((op #b11001111)))
2317 (emit-byte segment #b11001111)))
2319 ;;;; processor control
2321 (define-instruction hlt (segment)
2322 (:printer byte ((op #b11110100)))
2324 (emit-byte segment #b11110100)))
2326 (define-instruction nop (segment)
2327 (:printer byte ((op #b10010000)))
2329 (emit-byte segment #b10010000)))
2331 (define-instruction wait (segment)
2332 (:printer byte ((op #b10011011)))
2334 (emit-byte segment #b10011011)))
2336 ;;; FIXME: It would be better to make the disassembler understand the prefix as part
2337 ;;; of the instructions...
2338 (define-instruction lock (segment)
2339 (:printer byte ((op #b11110000)))
2341 (bug "LOCK prefix used as a standalone instruction")))
2343 ;;;; miscellaneous hackery
2345 (define-instruction byte (segment byte)
2347 (emit-byte segment byte)))
2349 (define-instruction word (segment word)
2351 (emit-word segment word)))
2353 (define-instruction dword (segment dword)
2355 (emit-dword segment dword)))
2357 (defun emit-header-data (segment type)
2358 (emit-back-patch segment
2360 (lambda (segment posn)
2364 (component-header-length))
2368 (define-instruction simple-fun-header-word (segment)
2370 (emit-header-data segment simple-fun-header-widetag)))
2372 (define-instruction lra-header-word (segment)
2374 (emit-header-data segment return-pc-header-widetag)))
2376 ;;;; fp instructions
2378 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
2380 ;;;; Note: We treat the single-precision and double-precision variants
2381 ;;;; as separate instructions.
2383 ;;; Load single to st(0).
2384 (define-instruction fld (segment source)
2385 (:printer floating-point ((op '(#b001 #b000))))
2387 (emit-byte segment #b11011001)
2388 (emit-fp-op segment source #b000)))
2390 ;;; Load double to st(0).
2391 (define-instruction fldd (segment source)
2392 (:printer floating-point ((op '(#b101 #b000))))
2393 (:printer floating-point-fp ((op '(#b001 #b000))))
2395 (if (fp-reg-tn-p source)
2396 (emit-byte segment #b11011001)
2397 (emit-byte segment #b11011101))
2398 (emit-fp-op segment source #b000)))
2400 ;;; Load long to st(0).
2401 (define-instruction fldl (segment source)
2402 (:printer floating-point ((op '(#b011 #b101))))
2404 (emit-byte segment #b11011011)
2405 (emit-fp-op segment source #b101)))
2407 ;;; Store single from st(0).
2408 (define-instruction fst (segment dest)
2409 (:printer floating-point ((op '(#b001 #b010))))
2411 (cond ((fp-reg-tn-p dest)
2412 (emit-byte segment #b11011101)
2413 (emit-fp-op segment dest #b010))
2415 (emit-byte segment #b11011001)
2416 (emit-fp-op segment dest #b010)))))
2418 ;;; Store double from st(0).
2419 (define-instruction fstd (segment dest)
2420 (:printer floating-point ((op '(#b101 #b010))))
2421 (:printer floating-point-fp ((op '(#b101 #b010))))
2423 (cond ((fp-reg-tn-p dest)
2424 (emit-byte segment #b11011101)
2425 (emit-fp-op segment dest #b010))
2427 (emit-byte segment #b11011101)
2428 (emit-fp-op segment dest #b010)))))
2430 ;;; Arithmetic ops are all done with at least one operand at top of
2431 ;;; stack. The other operand is is another register or a 32/64 bit
2434 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2435 ;;; that these conflict with the Gdb conventions for binops. To reduce
2436 ;;; the confusion I've added comments showing the mathamatical
2437 ;;; operation and the two syntaxes. By the ASM386 convention the
2438 ;;; instruction syntax is:
2441 ;;; or Fop Destination, Source
2443 ;;; If only one operand is given then it is the source and the
2444 ;;; destination is ST(0). There are reversed forms of the fsub and
2445 ;;; fdiv instructions inducated by an 'R' suffix.
2447 ;;; The mathematical operation for the non-reverse form is always:
2448 ;;; destination = destination op source
2450 ;;; For the reversed form it is:
2451 ;;; destination = source op destination
2453 ;;; The instructions below only accept one operand at present which is
2454 ;;; usually the source. I've hack in extra instructions to implement
2455 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2456 ;;; the operand is the destination with the source being ST(0).
2459 ;;; st(0) = st(0) + memory or st(i).
2460 (define-instruction fadd (segment source)
2461 (:printer floating-point ((op '(#b000 #b000))))
2463 (emit-byte segment #b11011000)
2464 (emit-fp-op segment source #b000)))
2467 ;;; st(0) = st(0) + memory or st(i).
2468 (define-instruction faddd (segment source)
2469 (:printer floating-point ((op '(#b100 #b000))))
2470 (:printer floating-point-fp ((op '(#b000 #b000))))
2472 (if (fp-reg-tn-p source)
2473 (emit-byte segment #b11011000)
2474 (emit-byte segment #b11011100))
2475 (emit-fp-op segment source #b000)))
2477 ;;; Add double destination st(i):
2478 ;;; st(i) = st(0) + st(i).
2479 (define-instruction fadd-sti (segment destination)
2480 (:printer floating-point-fp ((op '(#b100 #b000))))
2482 (aver (fp-reg-tn-p destination))
2483 (emit-byte segment #b11011100)
2484 (emit-fp-op segment destination #b000)))
2486 (define-instruction faddp-sti (segment destination)
2487 (:printer floating-point-fp ((op '(#b110 #b000))))
2489 (aver (fp-reg-tn-p destination))
2490 (emit-byte segment #b11011110)
2491 (emit-fp-op segment destination #b000)))
2493 ;;; Subtract single:
2494 ;;; st(0) = st(0) - memory or st(i).
2495 (define-instruction fsub (segment source)
2496 (:printer floating-point ((op '(#b000 #b100))))
2498 (emit-byte segment #b11011000)
2499 (emit-fp-op segment source #b100)))
2501 ;;; Subtract single, reverse:
2502 ;;; st(0) = memory or st(i) - st(0).
2503 (define-instruction fsubr (segment source)
2504 (:printer floating-point ((op '(#b000 #b101))))
2506 (emit-byte segment #b11011000)
2507 (emit-fp-op segment source #b101)))
2509 ;;; Subtract double:
2510 ;;; st(0) = st(0) - memory or st(i).
2511 (define-instruction fsubd (segment source)
2512 (:printer floating-point ((op '(#b100 #b100))))
2513 (:printer floating-point-fp ((op '(#b000 #b100))))
2515 (if (fp-reg-tn-p source)
2516 (emit-byte segment #b11011000)
2517 (emit-byte segment #b11011100))
2518 (emit-fp-op segment source #b100)))
2520 ;;; Subtract double, reverse:
2521 ;;; st(0) = memory or st(i) - st(0).
2522 (define-instruction fsubrd (segment source)
2523 (:printer floating-point ((op '(#b100 #b101))))
2524 (:printer floating-point-fp ((op '(#b000 #b101))))
2526 (if (fp-reg-tn-p source)
2527 (emit-byte segment #b11011000)
2528 (emit-byte segment #b11011100))
2529 (emit-fp-op segment source #b101)))
2531 ;;; Subtract double, destination st(i):
2532 ;;; st(i) = st(i) - st(0).
2534 ;;; ASM386 syntax: FSUB ST(i), ST
2535 ;;; Gdb syntax: fsubr %st,%st(i)
2536 (define-instruction fsub-sti (segment destination)
2537 (:printer floating-point-fp ((op '(#b100 #b101))))
2539 (aver (fp-reg-tn-p destination))
2540 (emit-byte segment #b11011100)
2541 (emit-fp-op segment destination #b101)))
2543 (define-instruction fsubp-sti (segment destination)
2544 (:printer floating-point-fp ((op '(#b110 #b101))))
2546 (aver (fp-reg-tn-p destination))
2547 (emit-byte segment #b11011110)
2548 (emit-fp-op segment destination #b101)))
2550 ;;; Subtract double, reverse, destination st(i):
2551 ;;; st(i) = st(0) - st(i).
2553 ;;; ASM386 syntax: FSUBR ST(i), ST
2554 ;;; Gdb syntax: fsub %st,%st(i)
2555 (define-instruction fsubr-sti (segment destination)
2556 (:printer floating-point-fp ((op '(#b100 #b100))))
2558 (aver (fp-reg-tn-p destination))
2559 (emit-byte segment #b11011100)
2560 (emit-fp-op segment destination #b100)))
2562 (define-instruction fsubrp-sti (segment destination)
2563 (:printer floating-point-fp ((op '(#b110 #b100))))
2565 (aver (fp-reg-tn-p destination))
2566 (emit-byte segment #b11011110)
2567 (emit-fp-op segment destination #b100)))
2569 ;;; Multiply single:
2570 ;;; st(0) = st(0) * memory or st(i).
2571 (define-instruction fmul (segment source)
2572 (:printer floating-point ((op '(#b000 #b001))))
2574 (emit-byte segment #b11011000)
2575 (emit-fp-op segment source #b001)))
2577 ;;; Multiply double:
2578 ;;; st(0) = st(0) * memory or st(i).
2579 (define-instruction fmuld (segment source)
2580 (:printer floating-point ((op '(#b100 #b001))))
2581 (:printer floating-point-fp ((op '(#b000 #b001))))
2583 (if (fp-reg-tn-p source)
2584 (emit-byte segment #b11011000)
2585 (emit-byte segment #b11011100))
2586 (emit-fp-op segment source #b001)))
2588 ;;; Multiply double, destination st(i):
2589 ;;; st(i) = st(i) * st(0).
2590 (define-instruction fmul-sti (segment destination)
2591 (:printer floating-point-fp ((op '(#b100 #b001))))
2593 (aver (fp-reg-tn-p destination))
2594 (emit-byte segment #b11011100)
2595 (emit-fp-op segment destination #b001)))
2598 ;;; st(0) = st(0) / memory or st(i).
2599 (define-instruction fdiv (segment source)
2600 (:printer floating-point ((op '(#b000 #b110))))
2602 (emit-byte segment #b11011000)
2603 (emit-fp-op segment source #b110)))
2605 ;;; Divide single, reverse:
2606 ;;; st(0) = memory or st(i) / st(0).
2607 (define-instruction fdivr (segment source)
2608 (:printer floating-point ((op '(#b000 #b111))))
2610 (emit-byte segment #b11011000)
2611 (emit-fp-op segment source #b111)))
2614 ;;; st(0) = st(0) / memory or st(i).
2615 (define-instruction fdivd (segment source)
2616 (:printer floating-point ((op '(#b100 #b110))))
2617 (:printer floating-point-fp ((op '(#b000 #b110))))
2619 (if (fp-reg-tn-p source)
2620 (emit-byte segment #b11011000)
2621 (emit-byte segment #b11011100))
2622 (emit-fp-op segment source #b110)))
2624 ;;; Divide double, reverse:
2625 ;;; st(0) = memory or st(i) / st(0).
2626 (define-instruction fdivrd (segment source)
2627 (:printer floating-point ((op '(#b100 #b111))))
2628 (:printer floating-point-fp ((op '(#b000 #b111))))
2630 (if (fp-reg-tn-p source)
2631 (emit-byte segment #b11011000)
2632 (emit-byte segment #b11011100))
2633 (emit-fp-op segment source #b111)))
2635 ;;; Divide double, destination st(i):
2636 ;;; st(i) = st(i) / st(0).
2638 ;;; ASM386 syntax: FDIV ST(i), ST
2639 ;;; Gdb syntax: fdivr %st,%st(i)
2640 (define-instruction fdiv-sti (segment destination)
2641 (:printer floating-point-fp ((op '(#b100 #b111))))
2643 (aver (fp-reg-tn-p destination))
2644 (emit-byte segment #b11011100)
2645 (emit-fp-op segment destination #b111)))
2647 ;;; Divide double, reverse, destination st(i):
2648 ;;; st(i) = st(0) / st(i).
2650 ;;; ASM386 syntax: FDIVR ST(i), ST
2651 ;;; Gdb syntax: fdiv %st,%st(i)
2652 (define-instruction fdivr-sti (segment destination)
2653 (:printer floating-point-fp ((op '(#b100 #b110))))
2655 (aver (fp-reg-tn-p destination))
2656 (emit-byte segment #b11011100)
2657 (emit-fp-op segment destination #b110)))
2659 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2660 (define-instruction fxch (segment source)
2661 (:printer floating-point-fp ((op '(#b001 #b001))))
2663 (aver (and (tn-p source)
2664 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)))
2665 (emit-byte segment #b11011001)
2666 (emit-fp-op segment source #b001)))
2668 ;;; Push 32-bit integer to st0.
2669 (define-instruction fild (segment source)
2670 (:printer floating-point ((op '(#b011 #b000))))
2672 (emit-byte segment #b11011011)
2673 (emit-fp-op segment source #b000)))
2675 ;;; Push 64-bit integer to st0.
2676 (define-instruction fildl (segment source)
2677 (:printer floating-point ((op '(#b111 #b101))))
2679 (emit-byte segment #b11011111)
2680 (emit-fp-op segment source #b101)))
2682 ;;; Store 32-bit integer.
2683 (define-instruction fist (segment dest)
2684 (:printer floating-point ((op '(#b011 #b010))))
2686 (emit-byte segment #b11011011)
2687 (emit-fp-op segment dest #b010)))
2689 ;;; Store and pop 32-bit integer.
2690 (define-instruction fistp (segment dest)
2691 (:printer floating-point ((op '(#b011 #b011))))
2693 (emit-byte segment #b11011011)
2694 (emit-fp-op segment dest #b011)))
2696 ;;; Store and pop 64-bit integer.
2697 (define-instruction fistpl (segment dest)
2698 (:printer floating-point ((op '(#b111 #b111))))
2700 (emit-byte segment #b11011111)
2701 (emit-fp-op segment dest #b111)))
2703 ;;; Store single from st(0) and pop.
2704 (define-instruction fstp (segment dest)
2705 (:printer floating-point ((op '(#b001 #b011))))
2707 (cond ((fp-reg-tn-p dest)
2708 (emit-byte segment #b11011101)
2709 (emit-fp-op segment dest #b011))
2711 (emit-byte segment #b11011001)
2712 (emit-fp-op segment dest #b011)))))
2714 ;;; Store double from st(0) and pop.
2715 (define-instruction fstpd (segment dest)
2716 (:printer floating-point ((op '(#b101 #b011))))
2717 (:printer floating-point-fp ((op '(#b101 #b011))))
2719 (cond ((fp-reg-tn-p dest)
2720 (emit-byte segment #b11011101)
2721 (emit-fp-op segment dest #b011))
2723 (emit-byte segment #b11011101)
2724 (emit-fp-op segment dest #b011)))))
2726 ;;; Store long from st(0) and pop.
2727 (define-instruction fstpl (segment dest)
2728 (:printer floating-point ((op '(#b011 #b111))))
2730 (emit-byte segment #b11011011)
2731 (emit-fp-op segment dest #b111)))
2733 ;;; Decrement stack-top pointer.
2734 (define-instruction fdecstp (segment)
2735 (:printer floating-point-no ((op #b10110)))
2737 (emit-byte segment #b11011001)
2738 (emit-byte segment #b11110110)))
2740 ;;; Increment stack-top pointer.
2741 (define-instruction fincstp (segment)
2742 (:printer floating-point-no ((op #b10111)))
2744 (emit-byte segment #b11011001)
2745 (emit-byte segment #b11110111)))
2747 ;;; Free fp register.
2748 (define-instruction ffree (segment dest)
2749 (:printer floating-point-fp ((op '(#b101 #b000))))
2751 (emit-byte segment #b11011101)
2752 (emit-fp-op segment dest #b000)))
2754 (define-instruction fabs (segment)
2755 (:printer floating-point-no ((op #b00001)))
2757 (emit-byte segment #b11011001)
2758 (emit-byte segment #b11100001)))
2760 (define-instruction fchs (segment)
2761 (:printer floating-point-no ((op #b00000)))
2763 (emit-byte segment #b11011001)
2764 (emit-byte segment #b11100000)))
2766 (define-instruction frndint(segment)
2767 (:printer floating-point-no ((op #b11100)))
2769 (emit-byte segment #b11011001)
2770 (emit-byte segment #b11111100)))
2773 (define-instruction fninit(segment)
2774 (:printer floating-point-5 ((op #b00011)))
2776 (emit-byte segment #b11011011)
2777 (emit-byte segment #b11100011)))
2779 ;;; Store Status Word to AX.
2780 (define-instruction fnstsw(segment)
2781 (:printer floating-point-st ((op #b00000)))
2783 (emit-byte segment #b11011111)
2784 (emit-byte segment #b11100000)))
2786 ;;; Load Control Word.
2788 ;;; src must be a memory location
2789 (define-instruction fldcw(segment src)
2790 (:printer floating-point ((op '(#b001 #b101))))
2792 (emit-byte segment #b11011001)
2793 (emit-fp-op segment src #b101)))
2795 ;;; Store Control Word.
2796 (define-instruction fnstcw(segment dst)
2797 (:printer floating-point ((op '(#b001 #b111))))
2799 (emit-byte segment #b11011001)
2800 (emit-fp-op segment dst #b111)))
2802 ;;; Store FP Environment.
2803 (define-instruction fstenv(segment dst)
2804 (:printer floating-point ((op '(#b001 #b110))))
2806 (emit-byte segment #b11011001)
2807 (emit-fp-op segment dst #b110)))
2809 ;;; Restore FP Environment.
2810 (define-instruction fldenv(segment src)
2811 (:printer floating-point ((op '(#b001 #b100))))
2813 (emit-byte segment #b11011001)
2814 (emit-fp-op segment src #b100)))
2817 (define-instruction fsave(segment dst)
2818 (:printer floating-point ((op '(#b101 #b110))))
2820 (emit-byte segment #b11011101)
2821 (emit-fp-op segment dst #b110)))
2823 ;;; Restore FP State.
2824 (define-instruction frstor(segment src)
2825 (:printer floating-point ((op '(#b101 #b100))))
2827 (emit-byte segment #b11011101)
2828 (emit-fp-op segment src #b100)))
2830 ;;; Clear exceptions.
2831 (define-instruction fnclex(segment)
2832 (:printer floating-point-5 ((op #b00010)))
2834 (emit-byte segment #b11011011)
2835 (emit-byte segment #b11100010)))
2838 (define-instruction fcom (segment src)
2839 (:printer floating-point ((op '(#b000 #b010))))
2841 (emit-byte segment #b11011000)
2842 (emit-fp-op segment src #b010)))
2844 (define-instruction fcomd (segment src)
2845 (:printer floating-point ((op '(#b100 #b010))))
2846 (:printer floating-point-fp ((op '(#b000 #b010))))
2848 (if (fp-reg-tn-p src)
2849 (emit-byte segment #b11011000)
2850 (emit-byte segment #b11011100))
2851 (emit-fp-op segment src #b010)))
2853 ;;; Compare ST1 to ST0, popping the stack twice.
2854 (define-instruction fcompp (segment)
2855 (:printer floating-point-3 ((op '(#b110 #b011001))))
2857 (emit-byte segment #b11011110)
2858 (emit-byte segment #b11011001)))
2860 ;;; unordered comparison
2861 (define-instruction fucom (segment src)
2862 (:printer floating-point-fp ((op '(#b101 #b100))))
2864 (aver (fp-reg-tn-p src))
2865 (emit-byte segment #b11011101)
2866 (emit-fp-op segment src #b100)))
2868 (define-instruction ftst (segment)
2869 (:printer floating-point-no ((op #b00100)))
2871 (emit-byte segment #b11011001)
2872 (emit-byte segment #b11100100)))
2876 (define-instruction fsqrt(segment)
2877 (:printer floating-point-no ((op #b11010)))
2879 (emit-byte segment #b11011001)
2880 (emit-byte segment #b11111010)))
2882 (define-instruction fscale(segment)
2883 (:printer floating-point-no ((op #b11101)))
2885 (emit-byte segment #b11011001)
2886 (emit-byte segment #b11111101)))
2888 (define-instruction fxtract(segment)
2889 (:printer floating-point-no ((op #b10100)))
2891 (emit-byte segment #b11011001)
2892 (emit-byte segment #b11110100)))
2894 (define-instruction fsin(segment)
2895 (:printer floating-point-no ((op #b11110)))
2897 (emit-byte segment #b11011001)
2898 (emit-byte segment #b11111110)))
2900 (define-instruction fcos(segment)
2901 (:printer floating-point-no ((op #b11111)))
2903 (emit-byte segment #b11011001)
2904 (emit-byte segment #b11111111)))
2906 (define-instruction fprem1(segment)
2907 (:printer floating-point-no ((op #b10101)))
2909 (emit-byte segment #b11011001)
2910 (emit-byte segment #b11110101)))
2912 (define-instruction fprem(segment)
2913 (:printer floating-point-no ((op #b11000)))
2915 (emit-byte segment #b11011001)
2916 (emit-byte segment #b11111000)))
2918 (define-instruction fxam (segment)
2919 (:printer floating-point-no ((op #b00101)))
2921 (emit-byte segment #b11011001)
2922 (emit-byte segment #b11100101)))
2924 ;;; These do push/pop to stack and need special handling
2925 ;;; in any VOPs that use them. See the book.
2927 ;;; st0 <- st1*log2(st0)
2928 (define-instruction fyl2x(segment) ; pops stack
2929 (:printer floating-point-no ((op #b10001)))
2931 (emit-byte segment #b11011001)
2932 (emit-byte segment #b11110001)))
2934 (define-instruction fyl2xp1(segment)
2935 (:printer floating-point-no ((op #b11001)))
2937 (emit-byte segment #b11011001)
2938 (emit-byte segment #b11111001)))
2940 (define-instruction f2xm1(segment)
2941 (:printer floating-point-no ((op #b10000)))
2943 (emit-byte segment #b11011001)
2944 (emit-byte segment #b11110000)))
2946 (define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
2947 (:printer floating-point-no ((op #b10010)))
2949 (emit-byte segment #b11011001)
2950 (emit-byte segment #b11110010)))
2952 (define-instruction fpatan(segment) ; POPS STACK
2953 (:printer floating-point-no ((op #b10011)))
2955 (emit-byte segment #b11011001)
2956 (emit-byte segment #b11110011)))
2958 ;;;; loading constants
2960 (define-instruction fldz(segment)
2961 (:printer floating-point-no ((op #b01110)))
2963 (emit-byte segment #b11011001)
2964 (emit-byte segment #b11101110)))
2966 (define-instruction fld1(segment)
2967 (:printer floating-point-no ((op #b01000)))
2969 (emit-byte segment #b11011001)
2970 (emit-byte segment #b11101000)))
2972 (define-instruction fldpi(segment)
2973 (:printer floating-point-no ((op #b01011)))
2975 (emit-byte segment #b11011001)
2976 (emit-byte segment #b11101011)))
2978 (define-instruction fldl2t(segment)
2979 (:printer floating-point-no ((op #b01001)))
2981 (emit-byte segment #b11011001)
2982 (emit-byte segment #b11101001)))
2984 (define-instruction fldl2e(segment)
2985 (:printer floating-point-no ((op #b01010)))
2987 (emit-byte segment #b11011001)
2988 (emit-byte segment #b11101010)))
2990 (define-instruction fldlg2(segment)
2991 (:printer floating-point-no ((op #b01100)))
2993 (emit-byte segment #b11011001)
2994 (emit-byte segment #b11101100)))
2996 (define-instruction fldln2(segment)
2997 (:printer floating-point-no ((op #b01101)))
2999 (emit-byte segment #b11011001)
3000 (emit-byte segment #b11101101)))
3004 (define-instruction cpuid (segment)
3005 (:printer two-bytes ((op '(#b00001111 #b10100010))))
3007 (emit-byte segment #b00001111)
3008 (emit-byte segment #b10100010)))
3010 (define-instruction rdtsc (segment)
3011 (:printer two-bytes ((op '(#b00001111 #b00110001))))
3013 (emit-byte segment #b00001111)
3014 (emit-byte segment #b00110001)))
3016 ;;;; Late VM definitions
3017 (defun canonicalize-inline-constant (constant)
3018 (let ((first (car constant)))
3020 (single-float (setf constant (list :single-float first)))
3021 (double-float (setf constant (list :double-float first)))))
3022 (destructuring-bind (type value) constant
3024 ((:byte :word :dword)
3025 (aver (integerp value))
3028 (aver (base-char-p value))
3029 (cons :byte (char-code value)))
3031 (aver (characterp value))
3032 (cons :dword (char-code value)))
3034 (aver (typep value 'single-float))
3035 (cons :dword (ldb (byte 32 0) (single-float-bits value))))
3036 ((:double-float-bits)
3037 (aver (integerp value))
3038 (cons :double-float (ldb (byte 64 0) value)))
3040 (aver (typep value 'double-float))
3042 (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
3043 (double-float-low-bits value))))))))
3045 (defun inline-constant-value (constant)
3046 (let ((label (gen-label))
3047 (size (ecase (car constant)
3048 ((:byte :word :dword) (car constant))
3049 (:double-float :dword))))
3050 (values label (make-ea size
3051 :disp (make-fixup nil :code-object label)))))
3053 (defun emit-constant-segment-header (constants optimize)
3054 (declare (ignore constants))
3055 (loop repeat (if optimize 64 16) do (inst byte #x90)))
3057 (defun size-nbyte (size)
3064 (defun sort-inline-constants (constants)
3065 (stable-sort constants #'> :key (lambda (constant)
3066 (size-nbyte (caar constant)))))
3068 (defun emit-inline-constant (constant label)
3069 (let ((size (size-nbyte (car constant))))
3070 (emit-alignment (integer-length (1- size)))
3072 (let ((val (cdr constant)))
3074 do (inst byte (ldb (byte 8 0) val))
3075 (setf val (ash val -8))))))