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 and whether a segment
52 ;;; override prefix was seen is stored as an inst-prop on the dstate.
53 ;;; The inst-props are cleared automatically after each non-prefix
54 ;;; instruction, must be set by prefilters, and contain a single bit of
55 ;;; data each (presence/absence).
57 ;;; Return the operand size based on the prefixes and width bit from
59 (defun inst-operand-size (dstate)
60 (declare (type sb!disassem:disassem-state dstate))
61 (cond ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-8)
63 ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-16)
66 +default-operand-size+)))
68 ;;; Return the operand size for a "word-sized" operand based on the
69 ;;; prefixes from the dstate.
70 (defun inst-word-operand-size (dstate)
71 (declare (type sb!disassem:disassem-state dstate))
72 (if (sb!disassem:dstate-get-inst-prop dstate 'operand-size-16)
76 (defun print-reg-with-width (value width stream dstate)
77 (declare (ignore dstate))
78 (princ (aref (ecase width
79 (:byte *byte-reg-names*)
80 (:word *word-reg-names*)
81 (:dword *dword-reg-names*))
84 ;; XXX plus should do some source-var notes
87 (defun print-reg (value stream dstate)
88 (declare (type reg value)
90 (type sb!disassem:disassem-state dstate))
91 (print-reg-with-width value
92 (inst-operand-size dstate)
96 (defun print-word-reg (value stream dstate)
97 (declare (type reg value)
99 (type sb!disassem:disassem-state dstate))
100 (print-reg-with-width value
101 (inst-word-operand-size dstate)
105 (defun print-byte-reg (value stream dstate)
106 (declare (type reg value)
108 (type sb!disassem:disassem-state dstate))
109 (print-reg-with-width value :byte stream dstate))
111 (defun print-addr-reg (value stream dstate)
112 (declare (type reg value)
114 (type sb!disassem:disassem-state dstate))
115 (print-reg-with-width value *default-address-size* stream dstate))
117 (defun print-reg/mem (value stream dstate)
118 (declare (type (or list reg) value)
120 (type sb!disassem:disassem-state dstate))
121 (if (typep value 'reg)
122 (print-reg value stream dstate)
123 (print-mem-access value stream nil dstate)))
125 ;; Same as print-reg/mem, but prints an explicit size indicator for
126 ;; memory references.
127 (defun print-sized-reg/mem (value stream dstate)
128 (declare (type (or list reg) value)
130 (type sb!disassem:disassem-state dstate))
131 (if (typep value 'reg)
132 (print-reg value stream dstate)
133 (print-mem-access value stream t dstate)))
135 (defun print-byte-reg/mem (value stream dstate)
136 (declare (type (or list reg) value)
138 (type sb!disassem:disassem-state dstate))
139 (if (typep value 'reg)
140 (print-byte-reg value stream dstate)
141 (print-mem-access value stream t dstate)))
143 (defun print-word-reg/mem (value stream dstate)
144 (declare (type (or list reg) value)
146 (type sb!disassem:disassem-state dstate))
147 (if (typep value 'reg)
148 (print-word-reg value stream dstate)
149 (print-mem-access value stream nil dstate)))
151 (defun print-label (value stream dstate)
152 (declare (ignore dstate))
153 (sb!disassem:princ16 value stream))
155 (defun maybe-print-segment-override (stream dstate)
156 (cond ((sb!disassem:dstate-get-inst-prop dstate 'fs-segment-prefix)
157 (princ "FS:" stream))
158 ((sb!disassem:dstate-get-inst-prop dstate 'gs-segment-prefix)
159 (princ "GS:" stream))))
161 ;;; Returns either an integer, meaning a register, or a list of
162 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
163 ;;; may be missing or nil to indicate that it's not used or has the
164 ;;; obvious default value (e.g., 1 for the index-scale).
165 (defun prefilter-reg/mem (value dstate)
166 (declare (type list value)
167 (type sb!disassem:disassem-state dstate))
168 (let ((mod (car value))
170 (declare (type (unsigned-byte 2) mod)
171 (type (unsigned-byte 3) r/m))
177 (let ((sib (sb!disassem:read-suffix 8 dstate)))
178 (declare (type (unsigned-byte 8) sib))
179 (let ((base-reg (ldb (byte 3 0) sib))
180 (index-reg (ldb (byte 3 3) sib))
181 (index-scale (ldb (byte 2 6) sib)))
182 (declare (type (unsigned-byte 3) base-reg index-reg)
183 (type (unsigned-byte 2) index-scale))
187 (if (= base-reg #b101)
188 (sb!disassem:read-signed-suffix 32 dstate)
191 (sb!disassem:read-signed-suffix 8 dstate))
193 (sb!disassem:read-signed-suffix 32 dstate)))))
194 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
196 (if (= index-reg #b100) nil index-reg)
197 (ash 1 index-scale))))))
198 ((and (= mod #b00) (= r/m #b101))
199 (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
203 (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
205 (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
208 ;;; This is a sort of bogus prefilter that just stores the info globally for
209 ;;; other people to use; it probably never gets printed.
210 (defun prefilter-width (value dstate)
211 (declare (type bit value)
212 (type sb!disassem:disassem-state dstate))
214 (sb!disassem:dstate-put-inst-prop dstate 'operand-size-8))
217 ;;; This prefilter is used solely for its side effect, namely to put
218 ;;; the property OPERAND-SIZE-16 into the DSTATE.
219 (defun prefilter-x66 (value dstate)
220 (declare (type (eql #x66) value)
222 (type sb!disassem:disassem-state dstate))
223 (sb!disassem:dstate-put-inst-prop dstate 'operand-size-16))
225 ;;; This prefilter is used solely for its side effect, namely to put
226 ;;; one of the properties [FG]S-SEGMENT-PREFIX into the DSTATE.
227 ;;; Unlike PREFILTER-X66, this prefilter only catches the low bit of
229 (defun prefilter-seg (value dstate)
230 (declare (type bit value)
231 (type sb!disassem:disassem-state dstate))
232 (sb!disassem:dstate-put-inst-prop
233 dstate (elt '(fs-segment-prefix gs-segment-prefix) value)))
235 (defun read-address (value dstate)
236 (declare (ignore value)) ; always nil anyway
237 (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
239 (defun width-bits (width)
249 ;;;; disassembler argument types
251 (sb!disassem:define-arg-type displacement
253 :use-label #'offset-next
254 :printer (lambda (value stream dstate)
255 (sb!disassem:maybe-note-assembler-routine value nil dstate)
256 (print-label value stream dstate)))
258 (sb!disassem:define-arg-type accum
259 :printer (lambda (value stream dstate)
260 (declare (ignore value)
262 (type sb!disassem:disassem-state dstate))
263 (print-reg 0 stream dstate)))
265 (sb!disassem:define-arg-type word-accum
266 :printer (lambda (value stream dstate)
267 (declare (ignore value)
269 (type sb!disassem:disassem-state dstate))
270 (print-word-reg 0 stream dstate)))
272 (sb!disassem:define-arg-type reg
273 :printer #'print-reg)
275 (sb!disassem:define-arg-type addr-reg
276 :printer #'print-addr-reg)
278 (sb!disassem:define-arg-type word-reg
279 :printer #'print-word-reg)
281 (sb!disassem:define-arg-type imm-addr
282 :prefilter #'read-address
283 :printer #'print-label)
285 (sb!disassem:define-arg-type imm-data
286 :prefilter (lambda (value dstate)
287 (declare (ignore value)) ; always nil anyway
288 (sb!disassem:read-suffix
289 (width-bits (inst-operand-size dstate))
292 (sb!disassem:define-arg-type signed-imm-data
293 :prefilter (lambda (value dstate)
294 (declare (ignore value)) ; always nil anyway
295 (let ((width (inst-operand-size dstate)))
296 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
298 (sb!disassem:define-arg-type imm-byte
299 :prefilter (lambda (value dstate)
300 (declare (ignore value)) ; always nil anyway
301 (sb!disassem:read-suffix 8 dstate)))
303 (sb!disassem:define-arg-type signed-imm-byte
304 :prefilter (lambda (value dstate)
305 (declare (ignore value)) ; always nil anyway
306 (sb!disassem:read-signed-suffix 8 dstate)))
308 (sb!disassem:define-arg-type signed-imm-dword
309 :prefilter (lambda (value dstate)
310 (declare (ignore value)) ; always nil anyway
311 (sb!disassem:read-signed-suffix 32 dstate)))
313 (sb!disassem:define-arg-type imm-word
314 :prefilter (lambda (value dstate)
315 (declare (ignore value)) ; always nil anyway
316 (let ((width (inst-word-operand-size dstate)))
317 (sb!disassem:read-suffix (width-bits width) dstate))))
319 (sb!disassem:define-arg-type signed-imm-word
320 :prefilter (lambda (value dstate)
321 (declare (ignore value)) ; always nil anyway
322 (let ((width (inst-word-operand-size dstate)))
323 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
325 ;;; needed for the ret imm16 instruction
326 (sb!disassem:define-arg-type imm-word-16
327 :prefilter (lambda (value dstate)
328 (declare (ignore value)) ; always nil anyway
329 (sb!disassem:read-suffix 16 dstate)))
331 (sb!disassem:define-arg-type reg/mem
332 :prefilter #'prefilter-reg/mem
333 :printer #'print-reg/mem)
334 (sb!disassem:define-arg-type sized-reg/mem
335 ;; Same as reg/mem, but prints an explicit size indicator for
336 ;; memory references.
337 :prefilter #'prefilter-reg/mem
338 :printer #'print-sized-reg/mem)
339 (sb!disassem:define-arg-type byte-reg/mem
340 :prefilter #'prefilter-reg/mem
341 :printer #'print-byte-reg/mem)
342 (sb!disassem:define-arg-type word-reg/mem
343 :prefilter #'prefilter-reg/mem
344 :printer #'print-word-reg/mem)
347 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
348 (defun print-fp-reg (value stream dstate)
349 (declare (ignore dstate))
350 (format stream "FR~D" value))
351 (defun prefilter-fp-reg (value dstate)
353 (declare (ignore dstate))
356 (sb!disassem:define-arg-type fp-reg
357 :prefilter #'prefilter-fp-reg
358 :printer #'print-fp-reg)
360 (sb!disassem:define-arg-type width
361 :prefilter #'prefilter-width
362 :printer (lambda (value stream dstate)
363 (declare (ignore value))
364 (princ (schar (symbol-name (inst-operand-size dstate)) 0)
367 ;;; Used to capture the effect of the #x66 operand size override prefix.
368 (sb!disassem:define-arg-type x66
369 :prefilter #'prefilter-x66)
371 ;;; Used to capture the effect of the #x64 and #x65 segment override
373 (sb!disassem:define-arg-type seg
374 :prefilter #'prefilter-seg)
376 (eval-when (:compile-toplevel :load-toplevel :execute)
377 (defparameter *conditions*
380 (:b . 2) (:nae . 2) (:c . 2)
381 (:nb . 3) (:ae . 3) (:nc . 3)
382 (:eq . 4) (:e . 4) (:z . 4)
389 (:np . 11) (:po . 11)
390 (:l . 12) (:nge . 12)
391 (:nl . 13) (:ge . 13)
392 (:le . 14) (:ng . 14)
393 (:nle . 15) (:g . 15)))
394 (defparameter *condition-name-vec*
395 (let ((vec (make-array 16 :initial-element nil)))
396 (dolist (cond *conditions*)
397 (when (null (aref vec (cdr cond)))
398 (setf (aref vec (cdr cond)) (car cond))))
402 ;;; Set assembler parameters. (In CMU CL, this was done with
403 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
404 (eval-when (:compile-toplevel :load-toplevel :execute)
405 (setf sb!assem:*assem-scheduler-p* nil))
407 (sb!disassem:define-arg-type condition-code
408 :printer *condition-name-vec*)
410 (defun conditional-opcode (condition)
411 (cdr (assoc condition *conditions* :test #'eq)))
413 ;;;; disassembler instruction formats
415 (eval-when (:compile-toplevel :execute)
416 (defun swap-if (direction field1 separator field2)
417 `(:if (,direction :constant 0)
418 (,field1 ,separator ,field2)
419 (,field2 ,separator ,field1))))
421 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
422 (op :field (byte 8 0))
427 ;;; Prefix instructions
429 (sb!disassem:define-instruction-format (x66 8)
430 (x66 :field (byte 8 0) :type 'x66 :value #x66))
432 (sb!disassem:define-instruction-format (seg 8)
433 (seg :field (byte 7 1) :value #x32)
434 (fsgs :field (byte 1 0) :type 'seg))
436 (sb!disassem:define-instruction-format (simple 8)
437 (op :field (byte 7 1))
438 (width :field (byte 1 0) :type 'width)
443 (sb!disassem:define-instruction-format (two-bytes 16
444 :default-printer '(:name))
445 (op :fields (list (byte 8 0) (byte 8 8))))
447 ;;; Same as simple, but with direction bit
448 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
449 (op :field (byte 6 2))
450 (dir :field (byte 1 1)))
452 ;;; Same as simple, but with the immediate value occurring by default,
453 ;;; and with an appropiate printer.
454 (sb!disassem:define-instruction-format (accum-imm 8
456 :default-printer '(:name
457 :tab accum ", " imm))
458 (imm :type 'imm-data))
460 (sb!disassem:define-instruction-format (reg-no-width 8
461 :default-printer '(:name :tab reg))
462 (op :field (byte 5 3))
463 (reg :field (byte 3 0) :type 'word-reg)
465 (accum :type 'word-accum)
468 ;;; adds a width field to reg-no-width
469 (sb!disassem:define-instruction-format (reg 8
470 :default-printer '(:name :tab reg))
471 (op :field (byte 4 4))
472 (width :field (byte 1 3) :type 'width)
473 (reg :field (byte 3 0) :type 'reg)
479 ;;; Same as reg, but with direction bit
480 (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
481 (op :field (byte 3 5))
482 (dir :field (byte 1 4)))
484 (sb!disassem:define-instruction-format (two-bytes 16
485 :default-printer '(:name))
486 (op :fields (list (byte 8 0) (byte 8 8))))
488 (sb!disassem:define-instruction-format (reg-reg/mem 16
490 `(:name :tab reg ", " reg/mem))
491 (op :field (byte 7 1))
492 (width :field (byte 1 0) :type 'width)
493 (reg/mem :fields (list (byte 2 14) (byte 3 8))
495 (reg :field (byte 3 11) :type 'reg)
499 ;;; same as reg-reg/mem, but with direction bit
500 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
501 :include 'reg-reg/mem
505 ,(swap-if 'dir 'reg/mem ", " 'reg)))
506 (op :field (byte 6 2))
507 (dir :field (byte 1 1)))
509 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
510 (sb!disassem:define-instruction-format (reg/mem 16
511 :default-printer '(:name :tab reg/mem))
512 (op :fields (list (byte 7 1) (byte 3 11)))
513 (width :field (byte 1 0) :type 'width)
514 (reg/mem :fields (list (byte 2 14) (byte 3 8))
515 :type 'sized-reg/mem)
519 ;;; Same as reg/mem, but with the immediate value occurring by default,
520 ;;; and with an appropiate printer.
521 (sb!disassem:define-instruction-format (reg/mem-imm 16
524 '(:name :tab reg/mem ", " imm))
525 (reg/mem :type 'sized-reg/mem)
526 (imm :type 'imm-data))
528 ;;; Same as reg/mem, but with using the accumulator in the default printer
529 (sb!disassem:define-instruction-format
531 :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
532 (reg/mem :type 'reg/mem) ; don't need a size
533 (accum :type 'accum))
535 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
536 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
538 `(:name :tab reg ", " reg/mem))
539 (prefix :field (byte 8 0) :value #b00001111)
540 (op :field (byte 7 9))
541 (width :field (byte 1 8) :type 'width)
542 (reg/mem :fields (list (byte 2 22) (byte 3 16))
544 (reg :field (byte 3 19) :type 'reg)
548 (sb!disassem:define-instruction-format (ext-reg-reg/mem-no-width 24
550 `(:name :tab reg ", " reg/mem))
551 (prefix :field (byte 8 0) :value #b00001111)
552 (op :field (byte 8 8))
553 (reg/mem :fields (list (byte 2 22) (byte 3 16))
555 (reg :field (byte 3 19) :type 'reg)
559 (sb!disassem:define-instruction-format (ext-reg/mem-no-width 24
561 `(:name :tab reg/mem))
562 (prefix :field (byte 8 0) :value #b00001111)
563 (op :fields (list (byte 8 8) (byte 3 19)))
564 (reg/mem :fields (list (byte 2 22) (byte 3 16))
567 ;;; reg-no-width with #x0f prefix
568 (sb!disassem:define-instruction-format (ext-reg-no-width 16
569 :default-printer '(:name :tab reg))
570 (prefix :field (byte 8 0) :value #b00001111)
571 (op :field (byte 5 11))
572 (reg :field (byte 3 8) :type 'reg))
574 ;;; Same as reg/mem, but with a prefix of #b00001111
575 (sb!disassem:define-instruction-format (ext-reg/mem 24
576 :default-printer '(:name :tab reg/mem))
577 (prefix :field (byte 8 0) :value #b00001111)
578 (op :fields (list (byte 7 9) (byte 3 19)))
579 (width :field (byte 1 8) :type 'width)
580 (reg/mem :fields (list (byte 2 22) (byte 3 16))
581 :type 'sized-reg/mem)
585 (sb!disassem:define-instruction-format (ext-reg/mem-imm 24
586 :include 'ext-reg/mem
588 '(:name :tab reg/mem ", " imm))
589 (imm :type 'imm-data))
591 (sb!disassem:define-instruction-format (ext-reg/mem-no-width+imm8 24
592 :include 'ext-reg/mem-no-width
594 '(:name :tab reg/mem ", " imm))
595 (imm :type 'imm-byte))
597 ;;;; This section was added by jrd, for fp instructions.
599 ;;; regular fp inst to/from registers/memory
600 (sb!disassem:define-instruction-format (floating-point 16
602 `(:name :tab reg/mem))
603 (prefix :field (byte 5 3) :value #b11011)
604 (op :fields (list (byte 3 0) (byte 3 11)))
605 (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
607 ;;; fp insn to/from fp reg
608 (sb!disassem:define-instruction-format (floating-point-fp 16
609 :default-printer `(:name :tab fp-reg))
610 (prefix :field (byte 5 3) :value #b11011)
611 (suffix :field (byte 2 14) :value #b11)
612 (op :fields (list (byte 3 0) (byte 3 11)))
613 (fp-reg :field (byte 3 8) :type 'fp-reg))
615 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
616 (sb!disassem:define-instruction-format
617 (floating-point-fp-d 16
618 :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
619 (prefix :field (byte 5 3) :value #b11011)
620 (suffix :field (byte 2 14) :value #b11)
621 (op :fields (list (byte 2 0) (byte 3 11)))
622 (d :field (byte 1 2))
623 (fp-reg :field (byte 3 8) :type 'fp-reg))
626 ;;; (added by (?) pfw)
627 ;;; fp no operand isns
628 (sb!disassem:define-instruction-format (floating-point-no 16
629 :default-printer '(:name))
630 (prefix :field (byte 8 0) :value #b11011001)
631 (suffix :field (byte 3 13) :value #b111)
632 (op :field (byte 5 8)))
634 (sb!disassem:define-instruction-format (floating-point-3 16
635 :default-printer '(:name))
636 (prefix :field (byte 5 3) :value #b11011)
637 (suffix :field (byte 2 14) :value #b11)
638 (op :fields (list (byte 3 0) (byte 6 8))))
640 (sb!disassem:define-instruction-format (floating-point-5 16
641 :default-printer '(:name))
642 (prefix :field (byte 8 0) :value #b11011011)
643 (suffix :field (byte 3 13) :value #b111)
644 (op :field (byte 5 8)))
646 (sb!disassem:define-instruction-format (floating-point-st 16
647 :default-printer '(:name))
648 (prefix :field (byte 8 0) :value #b11011111)
649 (suffix :field (byte 3 13) :value #b111)
650 (op :field (byte 5 8)))
652 (sb!disassem:define-instruction-format (string-op 8
654 :default-printer '(:name width)))
656 (sb!disassem:define-instruction-format (short-cond-jump 16)
657 (op :field (byte 4 4))
658 (cc :field (byte 4 0) :type 'condition-code)
659 (label :field (byte 8 8) :type 'displacement))
661 (sb!disassem:define-instruction-format (short-jump 16
662 :default-printer '(:name :tab label))
663 (const :field (byte 4 4) :value #b1110)
664 (op :field (byte 4 0))
665 (label :field (byte 8 8) :type 'displacement))
667 (sb!disassem:define-instruction-format (near-cond-jump 16)
668 (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
669 (cc :field (byte 4 8) :type 'condition-code)
670 ;; The disassembler currently doesn't let you have an instruction > 32 bits
671 ;; long, so we fake it by using a prefilter to read the offset.
672 (label :type 'displacement
673 :prefilter (lambda (value dstate)
674 (declare (ignore value)) ; always nil anyway
675 (sb!disassem:read-signed-suffix 32 dstate))))
677 (sb!disassem:define-instruction-format (near-jump 8
678 :default-printer '(:name :tab label))
679 (op :field (byte 8 0))
680 ;; The disassembler currently doesn't let you have an instruction > 32 bits
681 ;; long, so we fake it by using a prefilter to read the address.
682 (label :type 'displacement
683 :prefilter (lambda (value dstate)
684 (declare (ignore value)) ; always nil anyway
685 (sb!disassem:read-signed-suffix 32 dstate))))
688 (sb!disassem:define-instruction-format (cond-set 24
689 :default-printer '('set cc :tab reg/mem))
690 (prefix :field (byte 8 0) :value #b00001111)
691 (op :field (byte 4 12) :value #b1001)
692 (cc :field (byte 4 8) :type 'condition-code)
693 (reg/mem :fields (list (byte 2 22) (byte 3 16))
695 (reg :field (byte 3 19) :value #b000))
697 (sb!disassem:define-instruction-format (cond-move 24
699 '('cmov cc :tab reg ", " reg/mem))
700 (prefix :field (byte 8 0) :value #b00001111)
701 (op :field (byte 4 12) :value #b0100)
702 (cc :field (byte 4 8) :type 'condition-code)
703 (reg/mem :fields (list (byte 2 22) (byte 3 16))
705 (reg :field (byte 3 19) :type 'reg))
707 (sb!disassem:define-instruction-format (enter-format 32
708 :default-printer '(:name
710 (:unless (:constant 0)
712 (op :field (byte 8 0))
713 (disp :field (byte 16 8))
714 (level :field (byte 8 24)))
716 (sb!disassem:define-instruction-format (prefetch 24
718 '(:name ", " reg/mem))
719 (prefix :field (byte 8 0) :value #b00001111)
720 (op :field (byte 8 8) :value #b00011000)
721 (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem)
722 (reg :field (byte 3 19) :type 'reg))
724 ;;; Single byte instruction with an immediate byte argument.
725 (sb!disassem:define-instruction-format (byte-imm 16
726 :default-printer '(:name :tab code))
727 (op :field (byte 8 0))
728 (code :field (byte 8 8)))
730 ;;; Two byte instruction with an immediate byte argument.
732 (sb!disassem:define-instruction-format (word-imm 24
733 :default-printer '(:name :tab code))
734 (op :field (byte 16 0))
735 (code :field (byte 8 16)))
738 ;;;; primitive emitters
740 (define-bitfield-emitter emit-word 16
743 (define-bitfield-emitter emit-dword 32
746 (define-bitfield-emitter emit-byte-with-reg 8
747 (byte 5 3) (byte 3 0))
749 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
750 (byte 2 6) (byte 3 3) (byte 3 0))
752 (define-bitfield-emitter emit-sib-byte 8
753 (byte 2 6) (byte 3 3) (byte 3 0))
757 (defun emit-absolute-fixup (segment fixup)
758 (note-fixup segment :absolute fixup)
759 (let ((offset (fixup-offset fixup)))
761 (emit-back-patch segment
762 4 ; FIXME: n-word-bytes
763 (lambda (segment posn)
764 (declare (ignore posn))
766 (- (+ (component-header-length)
767 (or (label-position offset)
769 other-pointer-lowtag))))
770 (emit-dword segment (or offset 0)))))
772 (defun emit-relative-fixup (segment fixup)
773 (note-fixup segment :relative fixup)
774 (emit-dword segment (or (fixup-offset fixup) 0)))
776 ;;;; the effective-address (ea) structure
778 (defun reg-tn-encoding (tn)
779 (declare (type tn tn))
780 (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
781 (let ((offset (tn-offset tn)))
782 (logior (ash (logand offset 1) 2)
785 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
787 (size nil :type (member :byte :word :dword))
788 (base nil :type (or tn null))
789 (index nil :type (or tn null))
790 (scale 1 :type (member 1 2 4 8))
791 (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
792 (def!method print-object ((ea ea) stream)
793 (cond ((or *print-escape* *print-readably*)
794 (print-unreadable-object (ea stream :type t)
796 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
800 (let ((scale (ea-scale ea)))
801 (if (= scale 1) nil scale))
804 (format stream "~A PTR [" (symbol-name (ea-size ea)))
806 (write-string (sb!c::location-print-name (ea-base ea)) stream)
808 (write-string "+" stream)))
810 (write-string (sb!c::location-print-name (ea-index ea)) stream))
811 (unless (= (ea-scale ea) 1)
812 (format stream "*~A" (ea-scale ea)))
813 (typecase (ea-disp ea)
816 (format stream "~@D" (ea-disp ea)))
818 (format stream "+~A" (ea-disp ea))))
819 (write-char #\] stream))))
821 (defun emit-ea (segment thing reg &optional allow-constants)
824 (ecase (sb-name (sc-sb (tn-sc thing)))
826 (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
828 ;; Convert stack tns into an index off of EBP.
829 (let ((disp (frame-byte-offset (tn-offset thing))))
830 (cond ((<= -128 disp 127)
831 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
832 (emit-byte segment disp))
834 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
835 (emit-dword segment disp)))))
837 (unless allow-constants
839 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
840 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
841 (emit-absolute-fixup segment
844 (- (* (tn-offset thing) n-word-bytes)
845 other-pointer-lowtag))))))
847 (let* ((base (ea-base thing))
848 (index (ea-index thing))
849 (scale (ea-scale thing))
850 (disp (ea-disp thing))
851 (mod (cond ((or (null base)
853 (not (= (reg-tn-encoding base) #b101))))
855 ((and (fixnump disp) (<= -128 disp 127))
859 (r/m (cond (index #b100)
861 (t (reg-tn-encoding base)))))
862 (when (and (fixup-p disp)
863 (label-p (fixup-offset disp)))
866 (return-from emit-ea (emit-ea segment disp reg allow-constants)))
867 (emit-mod-reg-r/m-byte segment mod reg r/m)
869 (let ((ss (1- (integer-length scale)))
870 (index (if (null index)
872 (let ((index (reg-tn-encoding index)))
874 (error "can't index off of ESP")
876 (base (if (null base)
878 (reg-tn-encoding base))))
879 (emit-sib-byte segment ss index base)))
881 (emit-byte segment disp))
882 ((or (= mod #b10) (null base))
884 (emit-absolute-fixup segment disp)
885 (emit-dword segment disp))))))
887 (emit-mod-reg-r/m-byte segment #b00 reg #b101)
888 (emit-absolute-fixup segment thing))))
890 (defun fp-reg-tn-p (thing)
892 (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
894 ;;; like the above, but for fp-instructions--jrd
895 (defun emit-fp-op (segment thing op)
896 (if (fp-reg-tn-p thing)
897 (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
900 (emit-ea segment thing op)))
902 (defun byte-reg-p (thing)
904 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
905 (member (sc-name (tn-sc thing)) *byte-sc-names*)
908 (defun byte-ea-p (thing)
910 (ea (eq (ea-size thing) :byte))
912 (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
915 (defun word-reg-p (thing)
917 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
918 (member (sc-name (tn-sc thing)) *word-sc-names*)
921 (defun word-ea-p (thing)
923 (ea (eq (ea-size thing) :word))
924 (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
927 (defun dword-reg-p (thing)
929 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
930 (member (sc-name (tn-sc thing)) *dword-sc-names*)
933 (defun dword-ea-p (thing)
935 (ea (eq (ea-size thing) :dword))
937 (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
940 (defun register-p (thing)
942 (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
944 (defun accumulator-p (thing)
945 (and (register-p thing)
946 (= (tn-offset thing) 0)))
950 (def!constant +operand-size-prefix-byte+ #b01100110)
952 (defun maybe-emit-operand-size-prefix (segment size)
953 (unless (or (eq size :byte) (eq size +default-operand-size+))
954 (emit-byte segment +operand-size-prefix-byte+)))
956 (defun operand-size (thing)
959 ;; FIXME: might as well be COND instead of having to use #. readmacro
960 ;; to hack up the code
961 (case (sc-name (tn-sc thing))
968 ;; added by jrd: float-registers is a separate size (?)
974 (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
980 (defun matching-operand-size (dst src)
981 (let ((dst-size (operand-size dst))
982 (src-size (operand-size src)))
985 (if (eq dst-size src-size)
987 (error "size mismatch: ~S is a ~S and ~S is a ~S."
988 dst dst-size src src-size))
992 (error "can't tell the size of either ~S or ~S" dst src)))))
994 (defun emit-sized-immediate (segment size value)
997 (emit-byte segment value))
999 (emit-word segment value))
1001 (emit-dword segment value))))
1005 (define-instruction x66 (segment)
1006 (:printer x66 () nil :print-name nil)
1008 (bug "#X66 prefix used as a standalone instruction")))
1010 (defun emit-prefix (segment name)
1015 (emit-byte segment #xf0))
1017 (emit-byte segment #x64))
1019 (emit-byte segment #x65))))
1021 (define-instruction fs (segment)
1022 (:printer seg ((fsgs #b0)) nil :print-name nil)
1024 (bug "FS prefix used as a standalone instruction")))
1026 (define-instruction gs (segment)
1027 (:printer seg ((fsgs #b1)) nil :print-name nil)
1029 (bug "GS prefix used as a standalone instruction")))
1031 (define-instruction lock (segment)
1032 (:printer byte ((op #b11110000)) nil)
1034 (bug "LOCK prefix used as a standalone instruction")))
1036 (define-instruction rep (segment)
1038 (emit-byte segment #b11110011)))
1040 (define-instruction repe (segment)
1041 (:printer byte ((op #b11110011)) nil)
1043 (emit-byte segment #b11110011)))
1045 (define-instruction repne (segment)
1046 (:printer byte ((op #b11110010)) nil)
1048 (emit-byte segment #b11110010)))
1050 ;;;; general data transfer
1052 (define-instruction mov (segment dst src &optional prefix)
1053 ;; immediate to register
1054 (:printer reg ((op #b1011) (imm nil :type 'imm-data))
1055 '(:name :tab reg ", " imm))
1056 ;; absolute mem to/from accumulator
1057 (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
1058 `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
1059 ;; register to/from register/memory
1060 (:printer reg-reg/mem-dir ((op #b100010)))
1061 ;; immediate to register/memory
1062 (:printer reg/mem-imm ((op '(#b1100011 #b000))))
1065 (emit-prefix segment prefix)
1066 (let ((size (matching-operand-size dst src)))
1067 (maybe-emit-operand-size-prefix segment size)
1068 (cond ((register-p dst)
1069 (cond ((integerp src)
1070 (emit-byte-with-reg segment
1074 (reg-tn-encoding dst))
1075 (emit-sized-immediate segment size src))
1076 ((and (fixup-p src) (accumulator-p dst))
1081 (emit-absolute-fixup segment src))
1087 (emit-ea segment src (reg-tn-encoding dst) t))))
1088 ((and (fixup-p dst) (accumulator-p src))
1089 (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
1090 (emit-absolute-fixup segment dst))
1092 (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
1093 (emit-ea segment dst #b000)
1094 (emit-sized-immediate segment size src))
1096 (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
1097 (emit-ea segment dst (reg-tn-encoding src)))
1099 (aver (eq size :dword))
1100 (emit-byte segment #b11000111)
1101 (emit-ea segment dst #b000)
1102 (emit-absolute-fixup segment src))
1104 (error "bogus arguments to MOV: ~S ~S" dst src))))))
1106 (defun emit-move-with-extension (segment dst src opcode)
1107 (aver (register-p dst))
1108 (let ((dst-size (operand-size dst))
1109 (src-size (operand-size src)))
1112 (aver (eq src-size :byte))
1113 (maybe-emit-operand-size-prefix segment :word)
1114 (emit-byte segment #b00001111)
1115 (emit-byte segment opcode)
1116 (emit-ea segment src (reg-tn-encoding dst)))
1120 (maybe-emit-operand-size-prefix segment :dword)
1121 (emit-byte segment #b00001111)
1122 (emit-byte segment opcode)
1123 (emit-ea segment src (reg-tn-encoding dst)))
1125 (emit-byte segment #b00001111)
1126 (emit-byte segment (logior opcode 1))
1127 (emit-ea segment src (reg-tn-encoding dst))))))))
1129 (define-instruction movsx (segment dst src)
1130 (:printer ext-reg-reg/mem ((op #b1011111)
1131 (reg nil :type 'word-reg)
1132 (reg/mem nil :type 'sized-reg/mem)))
1133 (:emitter (emit-move-with-extension segment dst src #b10111110)))
1135 (define-instruction movzx (segment dst src)
1136 (:printer ext-reg-reg/mem ((op #b1011011)
1137 (reg nil :type 'word-reg)
1138 (reg/mem nil :type 'sized-reg/mem)))
1139 (:emitter (emit-move-with-extension segment dst src #b10110110)))
1141 (define-instruction push (segment src &optional prefix)
1143 (:printer reg-no-width ((op #b01010)))
1145 (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
1147 (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
1149 (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
1151 ;; ### segment registers?
1154 (emit-prefix segment prefix)
1155 (cond ((integerp src)
1156 (cond ((<= -128 src 127)
1157 (emit-byte segment #b01101010)
1158 (emit-byte segment src))
1160 (emit-byte segment #b01101000)
1161 (emit-dword segment src))))
1163 ;; Interpret the fixup as an immediate dword to push.
1164 (emit-byte segment #b01101000)
1165 (emit-absolute-fixup segment src))
1167 (let ((size (operand-size src)))
1168 (aver (not (eq size :byte)))
1169 (maybe-emit-operand-size-prefix segment size)
1170 (cond ((register-p src)
1171 (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
1173 (emit-byte segment #b11111111)
1174 (emit-ea segment src #b110 t))))))))
1176 (define-instruction pusha (segment)
1177 (:printer byte ((op #b01100000)))
1179 (emit-byte segment #b01100000)))
1181 (define-instruction pop (segment dst)
1182 (:printer reg-no-width ((op #b01011)))
1183 (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
1185 (let ((size (operand-size dst)))
1186 (aver (not (eq size :byte)))
1187 (maybe-emit-operand-size-prefix segment size)
1188 (cond ((register-p dst)
1189 (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
1191 (emit-byte segment #b10001111)
1192 (emit-ea segment dst #b000))))))
1194 (define-instruction popa (segment)
1195 (:printer byte ((op #b01100001)))
1197 (emit-byte segment #b01100001)))
1199 (define-instruction xchg (segment operand1 operand2)
1200 ;; Register with accumulator.
1201 (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1202 ;; Register/Memory with Register.
1203 (:printer reg-reg/mem ((op #b1000011)))
1205 (let ((size (matching-operand-size operand1 operand2)))
1206 (maybe-emit-operand-size-prefix segment size)
1207 (labels ((xchg-acc-with-something (acc something)
1208 (if (and (not (eq size :byte)) (register-p something))
1209 (emit-byte-with-reg segment
1211 (reg-tn-encoding something))
1212 (xchg-reg-with-something acc something)))
1213 (xchg-reg-with-something (reg something)
1214 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1215 (emit-ea segment something (reg-tn-encoding reg))))
1216 (cond ((accumulator-p operand1)
1217 (xchg-acc-with-something operand1 operand2))
1218 ((accumulator-p operand2)
1219 (xchg-acc-with-something operand2 operand1))
1220 ((register-p operand1)
1221 (xchg-reg-with-something operand1 operand2))
1222 ((register-p operand2)
1223 (xchg-reg-with-something operand2 operand1))
1225 (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1227 (define-instruction lea (segment dst src)
1228 (:printer reg-reg/mem ((op #b1000110) (width 1)))
1230 (aver (dword-reg-p dst))
1231 (emit-byte segment #b10001101)
1232 (emit-ea segment src (reg-tn-encoding dst))))
1234 (define-instruction cmpxchg (segment dst src &optional prefix)
1235 ;; Register/Memory with Register.
1236 (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1238 (aver (register-p src))
1239 (emit-prefix segment prefix)
1240 (let ((size (matching-operand-size src dst)))
1241 (maybe-emit-operand-size-prefix segment size)
1242 (emit-byte segment #b00001111)
1243 (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1244 (emit-ea segment dst (reg-tn-encoding src)))))
1246 (define-instruction pause (segment)
1247 (:printer two-bytes ((op '(#xf3 #x90))))
1249 (emit-byte segment #xf3)
1250 (emit-byte segment #x90)))
1252 ;;;; flag control instructions
1254 ;;; CLC -- Clear Carry Flag.
1255 (define-instruction clc (segment)
1256 (:printer byte ((op #b11111000)))
1258 (emit-byte segment #b11111000)))
1260 ;;; CLD -- Clear Direction Flag.
1261 (define-instruction cld (segment)
1262 (:printer byte ((op #b11111100)))
1264 (emit-byte segment #b11111100)))
1266 ;;; CLI -- Clear Iterrupt Enable Flag.
1267 (define-instruction cli (segment)
1268 (:printer byte ((op #b11111010)))
1270 (emit-byte segment #b11111010)))
1272 ;;; CMC -- Complement Carry Flag.
1273 (define-instruction cmc (segment)
1274 (:printer byte ((op #b11110101)))
1276 (emit-byte segment #b11110101)))
1278 ;;; LAHF -- Load AH into flags.
1279 (define-instruction lahf (segment)
1280 (:printer byte ((op #b10011111)))
1282 (emit-byte segment #b10011111)))
1284 ;;; POPF -- Pop flags.
1285 (define-instruction popf (segment)
1286 (:printer byte ((op #b10011101)))
1288 (emit-byte segment #b10011101)))
1290 ;;; PUSHF -- push flags.
1291 (define-instruction pushf (segment)
1292 (:printer byte ((op #b10011100)))
1294 (emit-byte segment #b10011100)))
1296 ;;; SAHF -- Store AH into flags.
1297 (define-instruction sahf (segment)
1298 (:printer byte ((op #b10011110)))
1300 (emit-byte segment #b10011110)))
1302 ;;; STC -- Set Carry Flag.
1303 (define-instruction stc (segment)
1304 (:printer byte ((op #b11111001)))
1306 (emit-byte segment #b11111001)))
1308 ;;; STD -- Set Direction Flag.
1309 (define-instruction std (segment)
1310 (:printer byte ((op #b11111101)))
1312 (emit-byte segment #b11111101)))
1314 ;;; STI -- Set Interrupt Enable Flag.
1315 (define-instruction sti (segment)
1316 (:printer byte ((op #b11111011)))
1318 (emit-byte segment #b11111011)))
1322 (defun emit-random-arith-inst (name segment dst src opcode
1323 &optional allow-constants)
1324 (let ((size (matching-operand-size dst src)))
1325 (maybe-emit-operand-size-prefix segment size)
1328 (cond ((and (not (eq size :byte)) (<= -128 src 127))
1329 (emit-byte segment #b10000011)
1330 (emit-ea segment dst opcode allow-constants)
1331 (emit-byte segment src))
1332 ((accumulator-p dst)
1339 (emit-sized-immediate segment size src))
1341 (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1342 (emit-ea segment dst opcode allow-constants)
1343 (emit-sized-immediate segment size src))))
1348 (if (eq size :byte) #b00000000 #b00000001)))
1349 (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1354 (if (eq size :byte) #b00000010 #b00000011)))
1355 (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1357 (error "bogus operands to ~A" name)))))
1359 (eval-when (:compile-toplevel :execute)
1360 (defun arith-inst-printer-list (subop)
1361 `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1362 (reg/mem-imm ((op (#b1000000 ,subop))))
1363 (reg/mem-imm ((op (#b1000001 ,subop))
1364 (imm nil :type signed-imm-byte)))
1365 (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))))))
1367 (define-instruction add (segment dst src &optional prefix)
1368 (:printer-list (arith-inst-printer-list #b000))
1370 (emit-prefix segment prefix)
1371 (emit-random-arith-inst "ADD" segment dst src #b000)))
1373 (define-instruction adc (segment dst src)
1374 (:printer-list (arith-inst-printer-list #b010))
1375 (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1377 (define-instruction sub (segment dst src &optional prefix)
1378 (:printer-list (arith-inst-printer-list #b101))
1380 (emit-prefix segment prefix)
1381 (emit-random-arith-inst "SUB" segment dst src #b101)))
1383 (define-instruction sbb (segment dst src)
1384 (:printer-list (arith-inst-printer-list #b011))
1385 (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1387 (define-instruction cmp (segment dst src &optional prefix)
1388 (:printer-list (arith-inst-printer-list #b111))
1390 (emit-prefix segment prefix)
1391 (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1393 (define-instruction inc (segment dst)
1395 (:printer reg-no-width ((op #b01000)))
1397 (:printer reg/mem ((op '(#b1111111 #b000))))
1399 (let ((size (operand-size dst)))
1400 (maybe-emit-operand-size-prefix segment size)
1401 (cond ((and (not (eq size :byte)) (register-p dst))
1402 (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1404 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1405 (emit-ea segment dst #b000))))))
1407 (define-instruction dec (segment dst)
1409 (:printer reg-no-width ((op #b01001)))
1411 (:printer reg/mem ((op '(#b1111111 #b001))))
1413 (let ((size (operand-size dst)))
1414 (maybe-emit-operand-size-prefix segment size)
1415 (cond ((and (not (eq size :byte)) (register-p dst))
1416 (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1418 (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1419 (emit-ea segment dst #b001))))))
1421 (define-instruction neg (segment dst)
1422 (:printer reg/mem ((op '(#b1111011 #b011))))
1424 (let ((size (operand-size dst)))
1425 (maybe-emit-operand-size-prefix segment size)
1426 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1427 (emit-ea segment dst #b011))))
1429 (define-instruction aaa (segment)
1430 (:printer byte ((op #b00110111)))
1432 (emit-byte segment #b00110111)))
1434 (define-instruction aas (segment)
1435 (:printer byte ((op #b00111111)))
1437 (emit-byte segment #b00111111)))
1439 (define-instruction daa (segment)
1440 (:printer byte ((op #b00100111)))
1442 (emit-byte segment #b00100111)))
1444 (define-instruction das (segment)
1445 (:printer byte ((op #b00101111)))
1447 (emit-byte segment #b00101111)))
1449 (define-instruction mul (segment dst src)
1450 (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1452 (let ((size (matching-operand-size dst src)))
1453 (aver (accumulator-p dst))
1454 (maybe-emit-operand-size-prefix segment size)
1455 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1456 (emit-ea segment src #b100))))
1458 (define-instruction imul (segment dst &optional src1 src2)
1459 (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1460 (:printer ext-reg-reg/mem ((op #b1010111)))
1461 (:printer reg-reg/mem ((op #b0110100) (width 1)
1462 (imm nil :type 'signed-imm-word))
1463 '(:name :tab reg ", " reg/mem ", " imm))
1464 (:printer reg-reg/mem ((op #b0110101) (width 1)
1465 (imm nil :type 'signed-imm-byte))
1466 '(:name :tab reg ", " reg/mem ", " imm))
1468 (flet ((r/m-with-immed-to-reg (reg r/m immed)
1469 (let* ((size (matching-operand-size reg r/m))
1470 (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1471 (maybe-emit-operand-size-prefix segment size)
1472 (emit-byte segment (if sx #b01101011 #b01101001))
1473 (emit-ea segment r/m (reg-tn-encoding reg))
1475 (emit-byte segment immed)
1476 (emit-sized-immediate segment size immed)))))
1478 (r/m-with-immed-to-reg dst src1 src2))
1481 (r/m-with-immed-to-reg dst dst src1)
1482 (let ((size (matching-operand-size dst src1)))
1483 (maybe-emit-operand-size-prefix segment size)
1484 (emit-byte segment #b00001111)
1485 (emit-byte segment #b10101111)
1486 (emit-ea segment src1 (reg-tn-encoding dst)))))
1488 (let ((size (operand-size dst)))
1489 (maybe-emit-operand-size-prefix segment size)
1490 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1491 (emit-ea segment dst #b101)))))))
1493 (define-instruction div (segment dst src)
1494 (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1496 (let ((size (matching-operand-size dst src)))
1497 (aver (accumulator-p dst))
1498 (maybe-emit-operand-size-prefix segment size)
1499 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1500 (emit-ea segment src #b110))))
1502 (define-instruction idiv (segment dst src)
1503 (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1505 (let ((size (matching-operand-size dst src)))
1506 (aver (accumulator-p dst))
1507 (maybe-emit-operand-size-prefix segment size)
1508 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1509 (emit-ea segment src #b111))))
1511 (define-instruction aad (segment)
1512 (:printer two-bytes ((op '(#b11010101 #b00001010))))
1514 (emit-byte segment #b11010101)
1515 (emit-byte segment #b00001010)))
1517 (define-instruction aam (segment)
1518 (:printer two-bytes ((op '(#b11010100 #b00001010))))
1520 (emit-byte segment #b11010100)
1521 (emit-byte segment #b00001010)))
1523 (define-instruction bswap (segment dst)
1524 (:printer ext-reg-no-width ((op #b11001)))
1526 (emit-byte segment #x0f)
1527 (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst))))
1529 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1530 (define-instruction cbw (segment)
1531 (:printer two-bytes ((op '(#b01100110 #b10011000))))
1533 (maybe-emit-operand-size-prefix segment :word)
1534 (emit-byte segment #b10011000)))
1536 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1537 (define-instruction cwde (segment)
1538 (:printer byte ((op #b10011000)))
1540 (maybe-emit-operand-size-prefix segment :dword)
1541 (emit-byte segment #b10011000)))
1543 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1544 (define-instruction cwd (segment)
1545 (:printer two-bytes ((op '(#b01100110 #b10011001))))
1547 (maybe-emit-operand-size-prefix segment :word)
1548 (emit-byte segment #b10011001)))
1550 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1551 (define-instruction cdq (segment)
1552 (:printer byte ((op #b10011001)))
1554 (maybe-emit-operand-size-prefix segment :dword)
1555 (emit-byte segment #b10011001)))
1557 (define-instruction xadd (segment dst src &optional prefix)
1558 ;; Register/Memory with Register.
1559 (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1561 (aver (register-p src))
1562 (emit-prefix segment prefix)
1563 (let ((size (matching-operand-size src dst)))
1564 (maybe-emit-operand-size-prefix segment size)
1565 (emit-byte segment #b00001111)
1566 (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1567 (emit-ea segment dst (reg-tn-encoding src)))))
1572 (defun emit-shift-inst (segment dst amount opcode)
1573 (let ((size (operand-size dst)))
1574 (maybe-emit-operand-size-prefix segment size)
1575 (multiple-value-bind (major-opcode immed)
1577 (:cl (values #b11010010 nil))
1578 (1 (values #b11010000 nil))
1579 (t (values #b11000000 t)))
1581 (if (eq size :byte) major-opcode (logior major-opcode 1)))
1582 (emit-ea segment dst opcode)
1584 (emit-byte segment amount)))))
1586 (eval-when (:compile-toplevel :execute)
1587 (defun shift-inst-printer-list (subop)
1588 `((reg/mem ((op (#b1101000 ,subop)))
1589 (:name :tab reg/mem ", 1"))
1590 (reg/mem ((op (#b1101001 ,subop)))
1591 (:name :tab reg/mem ", " 'cl))
1592 (reg/mem-imm ((op (#b1100000 ,subop))
1593 (imm nil :type signed-imm-byte))))))
1595 (define-instruction rol (segment dst amount)
1597 (shift-inst-printer-list #b000))
1599 (emit-shift-inst segment dst amount #b000)))
1601 (define-instruction ror (segment dst amount)
1603 (shift-inst-printer-list #b001))
1605 (emit-shift-inst segment dst amount #b001)))
1607 (define-instruction rcl (segment dst amount)
1609 (shift-inst-printer-list #b010))
1611 (emit-shift-inst segment dst amount #b010)))
1613 (define-instruction rcr (segment dst amount)
1615 (shift-inst-printer-list #b011))
1617 (emit-shift-inst segment dst amount #b011)))
1619 (define-instruction shl (segment dst amount)
1621 (shift-inst-printer-list #b100))
1623 (emit-shift-inst segment dst amount #b100)))
1625 (define-instruction shr (segment dst amount)
1627 (shift-inst-printer-list #b101))
1629 (emit-shift-inst segment dst amount #b101)))
1631 (define-instruction sar (segment dst amount)
1633 (shift-inst-printer-list #b111))
1635 (emit-shift-inst segment dst amount #b111)))
1637 (defun emit-double-shift (segment opcode dst src amt)
1638 (let ((size (matching-operand-size dst src)))
1639 (when (eq size :byte)
1640 (error "Double shifts can only be used with words."))
1641 (maybe-emit-operand-size-prefix segment size)
1642 (emit-byte segment #b00001111)
1643 (emit-byte segment (dpb opcode (byte 1 3)
1644 (if (eq amt :cl) #b10100101 #b10100100)))
1646 (emit-ea segment dst src)
1647 (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1648 (unless (eq amt :cl)
1649 (emit-byte segment amt))))
1651 (eval-when (:compile-toplevel :execute)
1652 (defun double-shift-inst-printer-list (op)
1653 `((ext-reg-reg/mem ((op ,(logior op #b10)) (width 0)
1654 (imm nil :type signed-imm-byte))
1655 (:name :tab reg/mem ", " reg ", " imm))
1656 (ext-reg-reg/mem ((op ,(logior op #b10)) (width 1))
1657 (:name :tab reg/mem ", " reg ", " 'cl)))))
1659 (define-instruction shld (segment dst src amt)
1660 (:declare (type (or (member :cl) (mod 32)) amt))
1661 (:printer-list (double-shift-inst-printer-list #b1010000))
1663 (emit-double-shift segment #b0 dst src amt)))
1665 (define-instruction shrd (segment dst src amt)
1666 (:declare (type (or (member :cl) (mod 32)) amt))
1667 (:printer-list (double-shift-inst-printer-list #b1010100))
1669 (emit-double-shift segment #b1 dst src amt)))
1671 (define-instruction and (segment dst src)
1673 (arith-inst-printer-list #b100))
1675 (emit-random-arith-inst "AND" segment dst src #b100)))
1677 (define-instruction test (segment this that)
1678 (:printer accum-imm ((op #b1010100)))
1679 (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1680 (:printer reg-reg/mem ((op #b1000010)))
1682 (let ((size (matching-operand-size this that)))
1683 (maybe-emit-operand-size-prefix segment size)
1684 (flet ((test-immed-and-something (immed something)
1685 (cond ((accumulator-p something)
1687 (if (eq size :byte) #b10101000 #b10101001))
1688 (emit-sized-immediate segment size immed))
1691 (if (eq size :byte) #b11110110 #b11110111))
1692 (emit-ea segment something #b000)
1693 (emit-sized-immediate segment size immed))))
1694 (test-reg-and-something (reg something)
1695 (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1696 (emit-ea segment something (reg-tn-encoding reg))))
1697 (cond ((integerp that)
1698 (test-immed-and-something that this))
1700 (test-immed-and-something this that))
1702 (test-reg-and-something this that))
1704 (test-reg-and-something that this))
1706 (error "bogus operands for TEST: ~S and ~S" this that)))))))
1708 ;;; Emit the most compact form of the test immediate instruction,
1709 ;;; using an 8 bit test when the immediate is only 8 bits and the
1710 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
1712 (defun emit-optimized-test-inst (x y)
1715 (let ((offset (tn-offset x)))
1716 (cond ((and (sc-is x any-reg descriptor-reg)
1717 (or (= offset eax-offset) (= offset ebx-offset)
1718 (= offset ecx-offset) (= offset edx-offset)))
1719 (inst test (make-random-tn :kind :normal
1720 :sc (sc-or-lose 'byte-reg)
1723 ((sc-is x control-stack)
1724 (inst test (make-ea :byte :base ebp-tn
1725 :disp (frame-byte-offset offset))
1732 (define-instruction or (segment dst src &optional prefix)
1734 (arith-inst-printer-list #b001))
1736 (emit-prefix segment prefix)
1737 (emit-random-arith-inst "OR" segment dst src #b001)))
1739 (define-instruction xor (segment dst src &optional prefix)
1741 (arith-inst-printer-list #b110))
1743 (emit-prefix segment prefix)
1744 (emit-random-arith-inst "XOR" segment dst src #b110)))
1746 (define-instruction not (segment dst)
1747 (:printer reg/mem ((op '(#b1111011 #b010))))
1749 (let ((size (operand-size dst)))
1750 (maybe-emit-operand-size-prefix segment size)
1751 (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1752 (emit-ea segment dst #b010))))
1754 ;;;; string manipulation
1756 (define-instruction cmps (segment size)
1757 (:printer string-op ((op #b1010011)))
1759 (maybe-emit-operand-size-prefix segment size)
1760 (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1762 (define-instruction ins (segment acc)
1763 (:printer string-op ((op #b0110110)))
1765 (let ((size (operand-size acc)))
1766 (aver (accumulator-p acc))
1767 (maybe-emit-operand-size-prefix segment size)
1768 (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1770 (define-instruction lods (segment acc)
1771 (:printer string-op ((op #b1010110)))
1773 (let ((size (operand-size acc)))
1774 (aver (accumulator-p acc))
1775 (maybe-emit-operand-size-prefix segment size)
1776 (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1778 (define-instruction movs (segment size)
1779 (:printer string-op ((op #b1010010)))
1781 (maybe-emit-operand-size-prefix segment size)
1782 (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1784 (define-instruction outs (segment acc)
1785 (:printer string-op ((op #b0110111)))
1787 (let ((size (operand-size acc)))
1788 (aver (accumulator-p acc))
1789 (maybe-emit-operand-size-prefix segment size)
1790 (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1792 (define-instruction scas (segment acc)
1793 (:printer string-op ((op #b1010111)))
1795 (let ((size (operand-size acc)))
1796 (aver (accumulator-p acc))
1797 (maybe-emit-operand-size-prefix segment size)
1798 (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1800 (define-instruction stos (segment acc)
1801 (:printer string-op ((op #b1010101)))
1803 (let ((size (operand-size acc)))
1804 (aver (accumulator-p acc))
1805 (maybe-emit-operand-size-prefix segment size)
1806 (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1808 (define-instruction xlat (segment)
1809 (:printer byte ((op #b11010111)))
1811 (emit-byte segment #b11010111)))
1814 ;;;; bit manipulation
1816 (define-instruction bsf (segment dst src)
1817 (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
1819 (let ((size (matching-operand-size dst src)))
1820 (when (eq size :byte)
1821 (error "can't scan bytes: ~S" src))
1822 (maybe-emit-operand-size-prefix segment size)
1823 (emit-byte segment #b00001111)
1824 (emit-byte segment #b10111100)
1825 (emit-ea segment src (reg-tn-encoding dst)))))
1827 (define-instruction bsr (segment dst src)
1828 (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
1830 (let ((size (matching-operand-size dst src)))
1831 (when (eq size :byte)
1832 (error "can't scan bytes: ~S" src))
1833 (maybe-emit-operand-size-prefix segment size)
1834 (emit-byte segment #b00001111)
1835 (emit-byte segment #b10111101)
1836 (emit-ea segment src (reg-tn-encoding dst)))))
1838 (defun emit-bit-test-and-mumble (segment src index opcode)
1839 (let ((size (operand-size src)))
1840 (when (eq size :byte)
1841 (error "can't scan bytes: ~S" src))
1842 (maybe-emit-operand-size-prefix segment size)
1843 (emit-byte segment #b00001111)
1844 (cond ((integerp index)
1845 (emit-byte segment #b10111010)
1846 (emit-ea segment src opcode)
1847 (emit-byte segment index))
1849 (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1850 (emit-ea segment src (reg-tn-encoding index))))))
1852 (eval-when (:compile-toplevel :execute)
1853 (defun bit-test-inst-printer-list (subop)
1854 `((ext-reg/mem-no-width+imm8 ((op (#xBA ,subop))))
1855 (ext-reg-reg/mem-no-width ((op ,(dpb subop (byte 3 3) #b10000011))
1856 (reg/mem nil :type sized-reg/mem))
1857 (:name :tab reg/mem ", " reg)))))
1859 (macrolet ((define (inst opcode-extension)
1860 `(define-instruction ,inst (segment src index)
1861 (:printer-list (bit-test-inst-printer-list ,opcode-extension))
1862 (:emitter (emit-bit-test-and-mumble segment src index
1863 ,opcode-extension)))))
1870 ;;;; control transfer
1872 (define-instruction call (segment where)
1873 (:printer near-jump ((op #b11101000)))
1874 (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
1878 (emit-byte segment #b11101000)
1879 (emit-back-patch segment
1881 (lambda (segment posn)
1883 (- (label-position where)
1886 (emit-byte segment #b11101000)
1887 (emit-relative-fixup segment where))
1889 (emit-byte segment #b11111111)
1890 (emit-ea segment where #b010)))))
1892 (defun emit-byte-displacement-backpatch (segment target)
1893 (emit-back-patch segment
1895 (lambda (segment posn)
1896 (let ((disp (- (label-position target) (1+ posn))))
1897 (aver (<= -128 disp 127))
1898 (emit-byte segment disp)))))
1900 (define-instruction jmp (segment cond &optional where)
1901 ;; conditional jumps
1902 (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
1903 (:printer near-cond-jump () '('j cc :tab label))
1904 ;; unconditional jumps
1905 (:printer short-jump ((op #b1011)))
1906 (:printer near-jump ((op #b11101001)) )
1907 (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
1912 (lambda (segment posn delta-if-after)
1913 (let ((disp (- (label-position where posn delta-if-after)
1915 (when (<= -128 disp 127)
1917 (dpb (conditional-opcode cond)
1920 (emit-byte-displacement-backpatch segment where)
1922 (lambda (segment posn)
1923 (let ((disp (- (label-position where) (+ posn 6))))
1924 (emit-byte segment #b00001111)
1926 (dpb (conditional-opcode cond)
1929 (emit-dword segment disp)))))
1930 ((label-p (setq where cond))
1933 (lambda (segment posn delta-if-after)
1934 (let ((disp (- (label-position where posn delta-if-after)
1936 (when (<= -128 disp 127)
1937 (emit-byte segment #b11101011)
1938 (emit-byte-displacement-backpatch segment where)
1940 (lambda (segment posn)
1941 (let ((disp (- (label-position where) (+ posn 5))))
1942 (emit-byte segment #b11101001)
1943 (emit-dword segment disp)))))
1945 (emit-byte segment #b11101001)
1946 (emit-relative-fixup segment where))
1948 (unless (or (ea-p where) (tn-p where))
1949 (error "don't know what to do with ~A" where))
1950 (emit-byte segment #b11111111)
1951 (emit-ea segment where #b100)))))
1953 (define-instruction jmp-short (segment label)
1955 (emit-byte segment #b11101011)
1956 (emit-byte-displacement-backpatch segment label)))
1958 (define-instruction ret (segment &optional stack-delta)
1959 (:printer byte ((op #b11000011)))
1960 (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
1963 (cond ((and stack-delta (not (zerop stack-delta)))
1964 (emit-byte segment #b11000010)
1965 (emit-word segment stack-delta))
1967 (emit-byte segment #b11000011)))))
1969 (define-instruction jecxz (segment target)
1970 (:printer short-jump ((op #b0011)))
1972 (emit-byte segment #b11100011)
1973 (emit-byte-displacement-backpatch segment target)))
1975 (define-instruction loop (segment target)
1976 (:printer short-jump ((op #b0010)))
1978 (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
1979 (emit-byte-displacement-backpatch segment target)))
1981 (define-instruction loopz (segment target)
1982 (:printer short-jump ((op #b0001)))
1984 (emit-byte segment #b11100001)
1985 (emit-byte-displacement-backpatch segment target)))
1987 (define-instruction loopnz (segment target)
1988 (:printer short-jump ((op #b0000)))
1990 (emit-byte segment #b11100000)
1991 (emit-byte-displacement-backpatch segment target)))
1993 ;;;; conditional move
1994 (define-instruction cmov (segment cond dst src)
1995 (:printer cond-move ())
1997 (aver (register-p dst))
1998 (let ((size (matching-operand-size dst src)))
1999 (aver (or (eq size :word) (eq size :dword)))
2000 (maybe-emit-operand-size-prefix segment size))
2001 (emit-byte segment #b00001111)
2002 (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
2003 (emit-ea segment src (reg-tn-encoding dst))))
2005 ;;;; conditional byte set
2007 (define-instruction set (segment dst cond)
2008 (:printer cond-set ())
2010 (emit-byte segment #b00001111)
2011 (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
2012 (emit-ea segment dst #b000)))
2016 (define-instruction enter (segment disp &optional (level 0))
2017 (:declare (type (unsigned-byte 16) disp)
2018 (type (unsigned-byte 8) level))
2019 (:printer enter-format ((op #b11001000)))
2021 (emit-byte segment #b11001000)
2022 (emit-word segment disp)
2023 (emit-byte segment level)))
2025 (define-instruction leave (segment)
2026 (:printer byte ((op #b11001001)))
2028 (emit-byte segment #b11001001)))
2031 (define-instruction prefetchnta (segment ea)
2032 (:printer prefetch ((op #b00011000) (reg #b000)))
2034 (aver (typep ea 'ea))
2035 (aver (eq :byte (ea-size ea)))
2036 (emit-byte segment #b00001111)
2037 (emit-byte segment #b00011000)
2038 (emit-ea segment ea #b000)))
2040 (define-instruction prefetcht0 (segment ea)
2041 (:printer prefetch ((op #b00011000) (reg #b001)))
2043 (aver (typep ea 'ea))
2044 (aver (eq :byte (ea-size ea)))
2045 (emit-byte segment #b00001111)
2046 (emit-byte segment #b00011000)
2047 (emit-ea segment ea #b001)))
2049 (define-instruction prefetcht1 (segment ea)
2050 (:printer prefetch ((op #b00011000) (reg #b010)))
2052 (aver (typep ea 'ea))
2053 (aver (eq :byte (ea-size ea)))
2054 (emit-byte segment #b00001111)
2055 (emit-byte segment #b00011000)
2056 (emit-ea segment ea #b010)))
2058 (define-instruction prefetcht2 (segment ea)
2059 (:printer prefetch ((op #b00011000) (reg #b011)))
2061 (aver (typep ea 'ea))
2062 (aver (eq :byte (ea-size ea)))
2063 (emit-byte segment #b00001111)
2064 (emit-byte segment #b00011000)
2065 (emit-ea segment ea #b011)))
2067 ;;;; interrupt instructions
2069 (defun snarf-error-junk (sap offset &optional length-only)
2070 (let* ((length (sb!sys:sap-ref-8 sap offset))
2071 (vector (make-array length :element-type '(unsigned-byte 8))))
2072 (declare (type sb!sys:system-area-pointer sap)
2073 (type (unsigned-byte 8) length)
2074 (type (simple-array (unsigned-byte 8) (*)) vector))
2076 (values 0 (1+ length) nil nil))
2078 (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
2080 (collect ((sc-offsets)
2082 (lengths 1) ; the length byte
2084 (error-number (sb!c:read-var-integer vector index)))
2087 (when (>= index length)
2089 (let ((old-index index))
2090 (sc-offsets (sb!c:read-var-integer vector index))
2091 (lengths (- index old-index))))
2092 (values error-number
2098 (defmacro break-cases (breaknum &body cases)
2099 (let ((bn-temp (gensym)))
2100 (collect ((clauses))
2101 (dolist (case cases)
2102 (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
2103 `(let ((,bn-temp ,breaknum))
2104 (cond ,@(clauses))))))
2107 (defun break-control (chunk inst stream dstate)
2108 (declare (ignore inst))
2109 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
2110 ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
2111 ;; map has it undefined; and it should be easier to look in the target
2112 ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
2113 ;; from first principles whether it's defined in some way that genesis
2115 (case #!-ud2-breakpoints (byte-imm-code chunk dstate)
2116 #!+ud2-breakpoints (word-imm-code chunk dstate)
2119 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2122 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2124 (nt "breakpoint trap"))
2125 (#.pending-interrupt-trap
2126 (nt "pending interrupt trap"))
2129 (#.fun-end-breakpoint-trap
2130 (nt "function end breakpoint trap")))))
2132 (define-instruction break (segment code)
2133 (:declare (type (unsigned-byte 8) code))
2134 #!-ud2-breakpoints (:printer byte-imm ((op #b11001100)) '(:name :tab code)
2135 :control #'break-control)
2136 #!+ud2-breakpoints (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
2137 :control #'break-control)
2139 #!-ud2-breakpoints (emit-byte segment #b11001100)
2140 ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
2141 ;; throw a sigill with 0x0b0f instead and check for this in the
2142 ;; SIGILL handler and pass it on to the sigtrap handler if
2144 #!+ud2-breakpoints (emit-word segment #b0000101100001111)
2145 (emit-byte segment code)))
2147 (define-instruction int (segment number)
2148 (:declare (type (unsigned-byte 8) number))
2149 (:printer byte-imm ((op #b11001101)))
2153 (emit-byte segment #b11001100))
2155 (emit-byte segment #b11001101)
2156 (emit-byte segment number)))))
2158 (define-instruction into (segment)
2159 (:printer byte ((op #b11001110)))
2161 (emit-byte segment #b11001110)))
2163 (define-instruction bound (segment reg bounds)
2165 (let ((size (matching-operand-size reg bounds)))
2166 (when (eq size :byte)
2167 (error "can't bounds-test bytes: ~S" reg))
2168 (maybe-emit-operand-size-prefix segment size)
2169 (emit-byte segment #b01100010)
2170 (emit-ea segment bounds (reg-tn-encoding reg)))))
2172 (define-instruction iret (segment)
2173 (:printer byte ((op #b11001111)))
2175 (emit-byte segment #b11001111)))
2177 ;;;; processor control
2179 (define-instruction hlt (segment)
2180 (:printer byte ((op #b11110100)))
2182 (emit-byte segment #b11110100)))
2184 (define-instruction nop (segment)
2185 (:printer byte ((op #b10010000)))
2187 (emit-byte segment #b10010000)))
2189 (define-instruction wait (segment)
2190 (:printer byte ((op #b10011011)))
2192 (emit-byte segment #b10011011)))
2194 ;;;; miscellaneous hackery
2196 (define-instruction byte (segment byte)
2198 (emit-byte segment byte)))
2200 (define-instruction word (segment word)
2202 (emit-word segment word)))
2204 (define-instruction dword (segment dword)
2206 (emit-dword segment dword)))
2208 (defun emit-header-data (segment type)
2209 (emit-back-patch segment
2211 (lambda (segment posn)
2215 (component-header-length))
2219 (define-instruction simple-fun-header-word (segment)
2221 (emit-header-data segment simple-fun-header-widetag)))
2223 (define-instruction lra-header-word (segment)
2225 (emit-header-data segment return-pc-header-widetag)))
2227 ;;;; fp instructions
2229 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
2231 ;;;; Note: We treat the single-precision and double-precision variants
2232 ;;;; as separate instructions.
2234 ;;; Load single to st(0).
2235 (define-instruction fld (segment source)
2236 (:printer floating-point ((op '(#b001 #b000))))
2238 (emit-byte segment #b11011001)
2239 (emit-fp-op segment source #b000)))
2241 ;;; Load double to st(0).
2242 (define-instruction fldd (segment source)
2243 (:printer floating-point ((op '(#b101 #b000))))
2244 (:printer floating-point-fp ((op '(#b001 #b000))))
2246 (if (fp-reg-tn-p source)
2247 (emit-byte segment #b11011001)
2248 (emit-byte segment #b11011101))
2249 (emit-fp-op segment source #b000)))
2251 ;;; Load long to st(0).
2252 (define-instruction fldl (segment source)
2253 (:printer floating-point ((op '(#b011 #b101))))
2255 (emit-byte segment #b11011011)
2256 (emit-fp-op segment source #b101)))
2258 ;;; Store single from st(0).
2259 (define-instruction fst (segment dest)
2260 (:printer floating-point ((op '(#b001 #b010))))
2262 (cond ((fp-reg-tn-p dest)
2263 (emit-byte segment #b11011101)
2264 (emit-fp-op segment dest #b010))
2266 (emit-byte segment #b11011001)
2267 (emit-fp-op segment dest #b010)))))
2269 ;;; Store double from st(0).
2270 (define-instruction fstd (segment dest)
2271 (:printer floating-point ((op '(#b101 #b010))))
2272 (:printer floating-point-fp ((op '(#b101 #b010))))
2274 (cond ((fp-reg-tn-p dest)
2275 (emit-byte segment #b11011101)
2276 (emit-fp-op segment dest #b010))
2278 (emit-byte segment #b11011101)
2279 (emit-fp-op segment dest #b010)))))
2281 ;;; Arithmetic ops are all done with at least one operand at top of
2282 ;;; stack. The other operand is is another register or a 32/64 bit
2285 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2286 ;;; that these conflict with the Gdb conventions for binops. To reduce
2287 ;;; the confusion I've added comments showing the mathamatical
2288 ;;; operation and the two syntaxes. By the ASM386 convention the
2289 ;;; instruction syntax is:
2292 ;;; or Fop Destination, Source
2294 ;;; If only one operand is given then it is the source and the
2295 ;;; destination is ST(0). There are reversed forms of the fsub and
2296 ;;; fdiv instructions inducated by an 'R' suffix.
2298 ;;; The mathematical operation for the non-reverse form is always:
2299 ;;; destination = destination op source
2301 ;;; For the reversed form it is:
2302 ;;; destination = source op destination
2304 ;;; The instructions below only accept one operand at present which is
2305 ;;; usually the source. I've hack in extra instructions to implement
2306 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2307 ;;; the operand is the destination with the source being ST(0).
2310 ;;; st(0) = st(0) + memory or st(i).
2311 (define-instruction fadd (segment source)
2312 (:printer floating-point ((op '(#b000 #b000))))
2314 (emit-byte segment #b11011000)
2315 (emit-fp-op segment source #b000)))
2318 ;;; st(0) = st(0) + memory or st(i).
2319 (define-instruction faddd (segment source)
2320 (:printer floating-point ((op '(#b100 #b000))))
2321 (:printer floating-point-fp ((op '(#b000 #b000))))
2323 (if (fp-reg-tn-p source)
2324 (emit-byte segment #b11011000)
2325 (emit-byte segment #b11011100))
2326 (emit-fp-op segment source #b000)))
2328 ;;; Add double destination st(i):
2329 ;;; st(i) = st(0) + st(i).
2330 (define-instruction fadd-sti (segment destination)
2331 (:printer floating-point-fp ((op '(#b100 #b000))))
2333 (aver (fp-reg-tn-p destination))
2334 (emit-byte segment #b11011100)
2335 (emit-fp-op segment destination #b000)))
2337 (define-instruction faddp-sti (segment destination)
2338 (:printer floating-point-fp ((op '(#b110 #b000))))
2340 (aver (fp-reg-tn-p destination))
2341 (emit-byte segment #b11011110)
2342 (emit-fp-op segment destination #b000)))
2344 ;;; Subtract single:
2345 ;;; st(0) = st(0) - memory or st(i).
2346 (define-instruction fsub (segment source)
2347 (:printer floating-point ((op '(#b000 #b100))))
2349 (emit-byte segment #b11011000)
2350 (emit-fp-op segment source #b100)))
2352 ;;; Subtract single, reverse:
2353 ;;; st(0) = memory or st(i) - st(0).
2354 (define-instruction fsubr (segment source)
2355 (:printer floating-point ((op '(#b000 #b101))))
2357 (emit-byte segment #b11011000)
2358 (emit-fp-op segment source #b101)))
2360 ;;; Subtract double:
2361 ;;; st(0) = st(0) - memory or st(i).
2362 (define-instruction fsubd (segment source)
2363 (:printer floating-point ((op '(#b100 #b100))))
2364 (:printer floating-point-fp ((op '(#b000 #b100))))
2366 (if (fp-reg-tn-p source)
2367 (emit-byte segment #b11011000)
2368 (emit-byte segment #b11011100))
2369 (emit-fp-op segment source #b100)))
2371 ;;; Subtract double, reverse:
2372 ;;; st(0) = memory or st(i) - st(0).
2373 (define-instruction fsubrd (segment source)
2374 (:printer floating-point ((op '(#b100 #b101))))
2375 (:printer floating-point-fp ((op '(#b000 #b101))))
2377 (if (fp-reg-tn-p source)
2378 (emit-byte segment #b11011000)
2379 (emit-byte segment #b11011100))
2380 (emit-fp-op segment source #b101)))
2382 ;;; Subtract double, destination st(i):
2383 ;;; st(i) = st(i) - st(0).
2385 ;;; ASM386 syntax: FSUB ST(i), ST
2386 ;;; Gdb syntax: fsubr %st,%st(i)
2387 (define-instruction fsub-sti (segment destination)
2388 (:printer floating-point-fp ((op '(#b100 #b101))))
2390 (aver (fp-reg-tn-p destination))
2391 (emit-byte segment #b11011100)
2392 (emit-fp-op segment destination #b101)))
2394 (define-instruction fsubp-sti (segment destination)
2395 (:printer floating-point-fp ((op '(#b110 #b101))))
2397 (aver (fp-reg-tn-p destination))
2398 (emit-byte segment #b11011110)
2399 (emit-fp-op segment destination #b101)))
2401 ;;; Subtract double, reverse, destination st(i):
2402 ;;; st(i) = st(0) - st(i).
2404 ;;; ASM386 syntax: FSUBR ST(i), ST
2405 ;;; Gdb syntax: fsub %st,%st(i)
2406 (define-instruction fsubr-sti (segment destination)
2407 (:printer floating-point-fp ((op '(#b100 #b100))))
2409 (aver (fp-reg-tn-p destination))
2410 (emit-byte segment #b11011100)
2411 (emit-fp-op segment destination #b100)))
2413 (define-instruction fsubrp-sti (segment destination)
2414 (:printer floating-point-fp ((op '(#b110 #b100))))
2416 (aver (fp-reg-tn-p destination))
2417 (emit-byte segment #b11011110)
2418 (emit-fp-op segment destination #b100)))
2420 ;;; Multiply single:
2421 ;;; st(0) = st(0) * memory or st(i).
2422 (define-instruction fmul (segment source)
2423 (:printer floating-point ((op '(#b000 #b001))))
2425 (emit-byte segment #b11011000)
2426 (emit-fp-op segment source #b001)))
2428 ;;; Multiply double:
2429 ;;; st(0) = st(0) * memory or st(i).
2430 (define-instruction fmuld (segment source)
2431 (:printer floating-point ((op '(#b100 #b001))))
2432 (:printer floating-point-fp ((op '(#b000 #b001))))
2434 (if (fp-reg-tn-p source)
2435 (emit-byte segment #b11011000)
2436 (emit-byte segment #b11011100))
2437 (emit-fp-op segment source #b001)))
2439 ;;; Multiply double, destination st(i):
2440 ;;; st(i) = st(i) * st(0).
2441 (define-instruction fmul-sti (segment destination)
2442 (:printer floating-point-fp ((op '(#b100 #b001))))
2444 (aver (fp-reg-tn-p destination))
2445 (emit-byte segment #b11011100)
2446 (emit-fp-op segment destination #b001)))
2449 ;;; st(0) = st(0) / memory or st(i).
2450 (define-instruction fdiv (segment source)
2451 (:printer floating-point ((op '(#b000 #b110))))
2453 (emit-byte segment #b11011000)
2454 (emit-fp-op segment source #b110)))
2456 ;;; Divide single, reverse:
2457 ;;; st(0) = memory or st(i) / st(0).
2458 (define-instruction fdivr (segment source)
2459 (:printer floating-point ((op '(#b000 #b111))))
2461 (emit-byte segment #b11011000)
2462 (emit-fp-op segment source #b111)))
2465 ;;; st(0) = st(0) / memory or st(i).
2466 (define-instruction fdivd (segment source)
2467 (:printer floating-point ((op '(#b100 #b110))))
2468 (:printer floating-point-fp ((op '(#b000 #b110))))
2470 (if (fp-reg-tn-p source)
2471 (emit-byte segment #b11011000)
2472 (emit-byte segment #b11011100))
2473 (emit-fp-op segment source #b110)))
2475 ;;; Divide double, reverse:
2476 ;;; st(0) = memory or st(i) / st(0).
2477 (define-instruction fdivrd (segment source)
2478 (:printer floating-point ((op '(#b100 #b111))))
2479 (:printer floating-point-fp ((op '(#b000 #b111))))
2481 (if (fp-reg-tn-p source)
2482 (emit-byte segment #b11011000)
2483 (emit-byte segment #b11011100))
2484 (emit-fp-op segment source #b111)))
2486 ;;; Divide double, destination st(i):
2487 ;;; st(i) = st(i) / st(0).
2489 ;;; ASM386 syntax: FDIV ST(i), ST
2490 ;;; Gdb syntax: fdivr %st,%st(i)
2491 (define-instruction fdiv-sti (segment destination)
2492 (:printer floating-point-fp ((op '(#b100 #b111))))
2494 (aver (fp-reg-tn-p destination))
2495 (emit-byte segment #b11011100)
2496 (emit-fp-op segment destination #b111)))
2498 ;;; Divide double, reverse, destination st(i):
2499 ;;; st(i) = st(0) / st(i).
2501 ;;; ASM386 syntax: FDIVR ST(i), ST
2502 ;;; Gdb syntax: fdiv %st,%st(i)
2503 (define-instruction fdivr-sti (segment destination)
2504 (:printer floating-point-fp ((op '(#b100 #b110))))
2506 (aver (fp-reg-tn-p destination))
2507 (emit-byte segment #b11011100)
2508 (emit-fp-op segment destination #b110)))
2510 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2511 (define-instruction fxch (segment source)
2512 (:printer floating-point-fp ((op '(#b001 #b001))))
2514 (aver (and (tn-p source)
2515 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)))
2516 (emit-byte segment #b11011001)
2517 (emit-fp-op segment source #b001)))
2519 ;;; Push 32-bit integer to st0.
2520 (define-instruction fild (segment source)
2521 (:printer floating-point ((op '(#b011 #b000))))
2523 (emit-byte segment #b11011011)
2524 (emit-fp-op segment source #b000)))
2526 ;;; Push 64-bit integer to st0.
2527 (define-instruction fildl (segment source)
2528 (:printer floating-point ((op '(#b111 #b101))))
2530 (emit-byte segment #b11011111)
2531 (emit-fp-op segment source #b101)))
2533 ;;; Store 32-bit integer.
2534 (define-instruction fist (segment dest)
2535 (:printer floating-point ((op '(#b011 #b010))))
2537 (emit-byte segment #b11011011)
2538 (emit-fp-op segment dest #b010)))
2540 ;;; Store and pop 32-bit integer.
2541 (define-instruction fistp (segment dest)
2542 (:printer floating-point ((op '(#b011 #b011))))
2544 (emit-byte segment #b11011011)
2545 (emit-fp-op segment dest #b011)))
2547 ;;; Store and pop 64-bit integer.
2548 (define-instruction fistpl (segment dest)
2549 (:printer floating-point ((op '(#b111 #b111))))
2551 (emit-byte segment #b11011111)
2552 (emit-fp-op segment dest #b111)))
2554 ;;; Store single from st(0) and pop.
2555 (define-instruction fstp (segment dest)
2556 (:printer floating-point ((op '(#b001 #b011))))
2558 (cond ((fp-reg-tn-p dest)
2559 (emit-byte segment #b11011101)
2560 (emit-fp-op segment dest #b011))
2562 (emit-byte segment #b11011001)
2563 (emit-fp-op segment dest #b011)))))
2565 ;;; Store double from st(0) and pop.
2566 (define-instruction fstpd (segment dest)
2567 (:printer floating-point ((op '(#b101 #b011))))
2568 (:printer floating-point-fp ((op '(#b101 #b011))))
2570 (cond ((fp-reg-tn-p dest)
2571 (emit-byte segment #b11011101)
2572 (emit-fp-op segment dest #b011))
2574 (emit-byte segment #b11011101)
2575 (emit-fp-op segment dest #b011)))))
2577 ;;; Store long from st(0) and pop.
2578 (define-instruction fstpl (segment dest)
2579 (:printer floating-point ((op '(#b011 #b111))))
2581 (emit-byte segment #b11011011)
2582 (emit-fp-op segment dest #b111)))
2584 ;;; Decrement stack-top pointer.
2585 (define-instruction fdecstp (segment)
2586 (:printer floating-point-no ((op #b10110)))
2588 (emit-byte segment #b11011001)
2589 (emit-byte segment #b11110110)))
2591 ;;; Increment stack-top pointer.
2592 (define-instruction fincstp (segment)
2593 (:printer floating-point-no ((op #b10111)))
2595 (emit-byte segment #b11011001)
2596 (emit-byte segment #b11110111)))
2598 ;;; Free fp register.
2599 (define-instruction ffree (segment dest)
2600 (:printer floating-point-fp ((op '(#b101 #b000))))
2602 (emit-byte segment #b11011101)
2603 (emit-fp-op segment dest #b000)))
2605 (define-instruction fabs (segment)
2606 (:printer floating-point-no ((op #b00001)))
2608 (emit-byte segment #b11011001)
2609 (emit-byte segment #b11100001)))
2611 (define-instruction fchs (segment)
2612 (:printer floating-point-no ((op #b00000)))
2614 (emit-byte segment #b11011001)
2615 (emit-byte segment #b11100000)))
2617 (define-instruction frndint(segment)
2618 (:printer floating-point-no ((op #b11100)))
2620 (emit-byte segment #b11011001)
2621 (emit-byte segment #b11111100)))
2624 (define-instruction fninit(segment)
2625 (:printer floating-point-5 ((op #b00011)))
2627 (emit-byte segment #b11011011)
2628 (emit-byte segment #b11100011)))
2630 ;;; Store Status Word to AX.
2631 (define-instruction fnstsw(segment)
2632 (:printer floating-point-st ((op #b00000)))
2634 (emit-byte segment #b11011111)
2635 (emit-byte segment #b11100000)))
2637 ;;; Load Control Word.
2639 ;;; src must be a memory location
2640 (define-instruction fldcw(segment src)
2641 (:printer floating-point ((op '(#b001 #b101))))
2643 (emit-byte segment #b11011001)
2644 (emit-fp-op segment src #b101)))
2646 ;;; Store Control Word.
2647 (define-instruction fnstcw(segment dst)
2648 (:printer floating-point ((op '(#b001 #b111))))
2650 (emit-byte segment #b11011001)
2651 (emit-fp-op segment dst #b111)))
2653 ;;; Store FP Environment.
2654 (define-instruction fstenv(segment dst)
2655 (:printer floating-point ((op '(#b001 #b110))))
2657 (emit-byte segment #b11011001)
2658 (emit-fp-op segment dst #b110)))
2660 ;;; Restore FP Environment.
2661 (define-instruction fldenv(segment src)
2662 (:printer floating-point ((op '(#b001 #b100))))
2664 (emit-byte segment #b11011001)
2665 (emit-fp-op segment src #b100)))
2668 (define-instruction fsave(segment dst)
2669 (:printer floating-point ((op '(#b101 #b110))))
2671 (emit-byte segment #b11011101)
2672 (emit-fp-op segment dst #b110)))
2674 ;;; Restore FP State.
2675 (define-instruction frstor(segment src)
2676 (:printer floating-point ((op '(#b101 #b100))))
2678 (emit-byte segment #b11011101)
2679 (emit-fp-op segment src #b100)))
2681 ;;; Clear exceptions.
2682 (define-instruction fnclex(segment)
2683 (:printer floating-point-5 ((op #b00010)))
2685 (emit-byte segment #b11011011)
2686 (emit-byte segment #b11100010)))
2689 (define-instruction fcom (segment src)
2690 (:printer floating-point ((op '(#b000 #b010))))
2692 (emit-byte segment #b11011000)
2693 (emit-fp-op segment src #b010)))
2695 (define-instruction fcomd (segment src)
2696 (:printer floating-point ((op '(#b100 #b010))))
2697 (:printer floating-point-fp ((op '(#b000 #b010))))
2699 (if (fp-reg-tn-p src)
2700 (emit-byte segment #b11011000)
2701 (emit-byte segment #b11011100))
2702 (emit-fp-op segment src #b010)))
2704 ;;; Compare ST1 to ST0, popping the stack twice.
2705 (define-instruction fcompp (segment)
2706 (:printer floating-point-3 ((op '(#b110 #b011001))))
2708 (emit-byte segment #b11011110)
2709 (emit-byte segment #b11011001)))
2711 ;;; unordered comparison
2712 (define-instruction fucom (segment src)
2713 (:printer floating-point-fp ((op '(#b101 #b100))))
2715 (aver (fp-reg-tn-p src))
2716 (emit-byte segment #b11011101)
2717 (emit-fp-op segment src #b100)))
2719 (define-instruction ftst (segment)
2720 (:printer floating-point-no ((op #b00100)))
2722 (emit-byte segment #b11011001)
2723 (emit-byte segment #b11100100)))
2727 (define-instruction fsqrt(segment)
2728 (:printer floating-point-no ((op #b11010)))
2730 (emit-byte segment #b11011001)
2731 (emit-byte segment #b11111010)))
2733 (define-instruction fscale(segment)
2734 (:printer floating-point-no ((op #b11101)))
2736 (emit-byte segment #b11011001)
2737 (emit-byte segment #b11111101)))
2739 (define-instruction fxtract(segment)
2740 (:printer floating-point-no ((op #b10100)))
2742 (emit-byte segment #b11011001)
2743 (emit-byte segment #b11110100)))
2745 (define-instruction fsin(segment)
2746 (:printer floating-point-no ((op #b11110)))
2748 (emit-byte segment #b11011001)
2749 (emit-byte segment #b11111110)))
2751 (define-instruction fcos(segment)
2752 (:printer floating-point-no ((op #b11111)))
2754 (emit-byte segment #b11011001)
2755 (emit-byte segment #b11111111)))
2757 (define-instruction fprem1(segment)
2758 (:printer floating-point-no ((op #b10101)))
2760 (emit-byte segment #b11011001)
2761 (emit-byte segment #b11110101)))
2763 (define-instruction fprem(segment)
2764 (:printer floating-point-no ((op #b11000)))
2766 (emit-byte segment #b11011001)
2767 (emit-byte segment #b11111000)))
2769 (define-instruction fxam (segment)
2770 (:printer floating-point-no ((op #b00101)))
2772 (emit-byte segment #b11011001)
2773 (emit-byte segment #b11100101)))
2775 ;;; These do push/pop to stack and need special handling
2776 ;;; in any VOPs that use them. See the book.
2778 ;;; st0 <- st1*log2(st0)
2779 (define-instruction fyl2x(segment) ; pops stack
2780 (:printer floating-point-no ((op #b10001)))
2782 (emit-byte segment #b11011001)
2783 (emit-byte segment #b11110001)))
2785 (define-instruction fyl2xp1(segment)
2786 (:printer floating-point-no ((op #b11001)))
2788 (emit-byte segment #b11011001)
2789 (emit-byte segment #b11111001)))
2791 (define-instruction f2xm1(segment)
2792 (:printer floating-point-no ((op #b10000)))
2794 (emit-byte segment #b11011001)
2795 (emit-byte segment #b11110000)))
2797 (define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
2798 (:printer floating-point-no ((op #b10010)))
2800 (emit-byte segment #b11011001)
2801 (emit-byte segment #b11110010)))
2803 (define-instruction fpatan(segment) ; POPS STACK
2804 (:printer floating-point-no ((op #b10011)))
2806 (emit-byte segment #b11011001)
2807 (emit-byte segment #b11110011)))
2809 ;;;; loading constants
2811 (define-instruction fldz(segment)
2812 (:printer floating-point-no ((op #b01110)))
2814 (emit-byte segment #b11011001)
2815 (emit-byte segment #b11101110)))
2817 (define-instruction fld1(segment)
2818 (:printer floating-point-no ((op #b01000)))
2820 (emit-byte segment #b11011001)
2821 (emit-byte segment #b11101000)))
2823 (define-instruction fldpi(segment)
2824 (:printer floating-point-no ((op #b01011)))
2826 (emit-byte segment #b11011001)
2827 (emit-byte segment #b11101011)))
2829 (define-instruction fldl2t(segment)
2830 (:printer floating-point-no ((op #b01001)))
2832 (emit-byte segment #b11011001)
2833 (emit-byte segment #b11101001)))
2835 (define-instruction fldl2e(segment)
2836 (:printer floating-point-no ((op #b01010)))
2838 (emit-byte segment #b11011001)
2839 (emit-byte segment #b11101010)))
2841 (define-instruction fldlg2(segment)
2842 (:printer floating-point-no ((op #b01100)))
2844 (emit-byte segment #b11011001)
2845 (emit-byte segment #b11101100)))
2847 (define-instruction fldln2(segment)
2848 (:printer floating-point-no ((op #b01101)))
2850 (emit-byte segment #b11011001)
2851 (emit-byte segment #b11101101)))
2855 (define-instruction cpuid (segment)
2856 (:printer two-bytes ((op '(#b00001111 #b10100010))))
2858 (emit-byte segment #b00001111)
2859 (emit-byte segment #b10100010)))
2861 (define-instruction rdtsc (segment)
2862 (:printer two-bytes ((op '(#b00001111 #b00110001))))
2864 (emit-byte segment #b00001111)
2865 (emit-byte segment #b00110001)))
2867 ;;;; Late VM definitions
2868 (defun canonicalize-inline-constant (constant)
2869 (let ((first (car constant)))
2871 (single-float (setf constant (list :single-float first)))
2872 (double-float (setf constant (list :double-float first)))))
2873 (destructuring-bind (type value) constant
2875 ((:byte :word :dword)
2876 (aver (integerp value))
2879 (aver (base-char-p value))
2880 (cons :byte (char-code value)))
2882 (aver (characterp value))
2883 (cons :dword (char-code value)))
2885 (aver (typep value 'single-float))
2886 (cons :dword (ldb (byte 32 0) (single-float-bits value))))
2887 ((:double-float-bits)
2888 (aver (integerp value))
2889 (cons :double-float (ldb (byte 64 0) value)))
2891 (aver (typep value 'double-float))
2893 (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
2894 (double-float-low-bits value))))))))
2896 (defun inline-constant-value (constant)
2897 (let ((label (gen-label))
2898 (size (ecase (car constant)
2899 ((:byte :word :dword) (car constant))
2900 (:double-float :dword))))
2901 (values label (make-ea size
2902 :disp (make-fixup nil :code-object label)))))
2904 (defun emit-constant-segment-header (segment constants optimize)
2905 (declare (ignore segment constants))
2906 (loop repeat (if optimize 64 16) do (inst byte #x90)))
2908 (defun size-nbyte (size)
2915 (defun sort-inline-constants (constants)
2916 (stable-sort constants #'> :key (lambda (constant)
2917 (size-nbyte (caar constant)))))
2919 (defun emit-inline-constant (constant label)
2920 (let ((size (size-nbyte (car constant))))
2921 (emit-alignment (integer-length (1- size)))
2923 (let ((val (cdr constant)))
2925 do (inst byte (ldb (byte 8 0) val))
2926 (setf val (ash val -8))))))