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.
13 (in-package "SB!X86-ASM")
15 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
16 ;; Imports from this package into SB-VM
17 (import '(*condition-name-vec
* conditional-opcode
18 register-p
; FIXME: rename to GPR-P
19 make-ea ea-disp width-bits
) 'sb
!vm
)
20 ;; Imports from SB-VM into this package
21 (import '(sb!vm
::*byte-sc-names
* sb
!vm
::*word-sc-names
* sb
!vm
::*dword-sc-names
*
22 sb
!vm
::frame-byte-offset
23 sb
!vm
::registers sb
!vm
::float-registers sb
!vm
::stack
))) ; SB names
25 (!begin-instruction-definitions
)
27 (setf *disassem-inst-alignment-bytes
* 1)
29 (deftype reg
() '(unsigned-byte 3))
31 (def!constant
+default-operand-size
+ :dword
)
33 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
35 (defun offset-next (value dstate
)
36 (declare (type integer value
)
37 (type disassem-state dstate
))
38 (+ (dstate-next-addr dstate
) value
))
40 (defparameter *default-address-size
*
41 ;; Actually, :DWORD is the only one really supported.
44 (defparameter *byte-reg-names
*
45 #(al cl dl bl ah ch dh bh
))
46 (defparameter *word-reg-names
*
47 #(ax cx dx bx sp bp si di
))
48 (defparameter *dword-reg-names
*
49 #(eax ecx edx ebx esp ebp esi edi
))
51 ;;; Disassembling x86 code needs to take into account little things
52 ;;; like instructions that have a byte/word length bit in their
53 ;;; encoding, prefixes to change the default word length for a single
54 ;;; instruction, and so on. Unfortunately, there is no easy way with
55 ;;; this disassembler framework to handle prefixes that will work
56 ;;; correctly in all cases, so we copy the x86-64 version which at
57 ;;; least can handle the code output by the compiler.
59 ;;; Width information for an instruction and whether a segment
60 ;;; override prefix was seen is stored as an inst-prop on the dstate.
61 ;;; The inst-props are cleared automatically after each non-prefix
62 ;;; instruction, must be set by prefilters, and contain a single bit of
63 ;;; data each (presence/absence).
65 ;;; Return the operand size based on the prefixes and width bit from
67 (defun inst-operand-size (dstate)
68 (declare (type disassem-state dstate
))
69 (cond ((dstate-get-inst-prop dstate
'operand-size-8
) :byte
)
70 ((dstate-get-inst-prop dstate
'operand-size-16
) :word
)
71 (t +default-operand-size
+)))
73 ;;; Return the operand size for a "word-sized" operand based on the
74 ;;; prefixes from the dstate.
75 (defun inst-word-operand-size (dstate)
76 (declare (type disassem-state dstate
))
77 (if (dstate-get-inst-prop dstate
'operand-size-16
) :word
:dword
))
79 (defun print-reg-with-width (value width stream dstate
)
80 (declare (ignore dstate
))
81 (princ (aref (ecase width
82 (:byte
*byte-reg-names
*)
83 (:word
*word-reg-names
*)
84 (:dword
*dword-reg-names
*))
87 ;; XXX plus should do some source-var notes
90 (defun print-reg (value stream dstate
)
91 (declare (type reg value
)
93 (type disassem-state dstate
))
94 (print-reg-with-width value
95 (inst-operand-size dstate
)
99 (defun print-word-reg (value stream dstate
)
100 (declare (type reg value
)
102 (type disassem-state dstate
))
103 (print-reg-with-width value
104 (inst-word-operand-size dstate
)
108 (defun print-byte-reg (value stream dstate
)
109 (declare (type reg value
)
111 (type disassem-state dstate
))
112 (print-reg-with-width value
:byte stream dstate
))
114 (defun print-addr-reg (value stream dstate
)
115 (declare (type reg value
)
117 (type disassem-state dstate
))
118 (print-reg-with-width value
*default-address-size
* stream dstate
))
120 (defun print-reg/mem
(value stream dstate
)
121 (declare (type (or list reg
) value
)
123 (type disassem-state dstate
))
124 (if (typep value
'reg
)
125 (print-reg value stream dstate
)
126 (print-mem-access value stream nil dstate
)))
128 ;; Same as print-reg/mem, but prints an explicit size indicator for
129 ;; memory references.
130 (defun print-sized-reg/mem
(value stream dstate
)
131 (declare (type (or list reg
) value
)
133 (type disassem-state dstate
))
134 (if (typep value
'reg
)
135 (print-reg value stream dstate
)
136 (print-mem-access value stream t dstate
)))
138 (defun print-byte-reg/mem
(value stream dstate
)
139 (declare (type (or list reg
) value
)
141 (type disassem-state dstate
))
142 (if (typep value
'reg
)
143 (print-byte-reg value stream dstate
)
144 (print-mem-access value stream t dstate
)))
146 (defun print-word-reg/mem
(value stream dstate
)
147 (declare (type (or list reg
) value
)
149 (type disassem-state dstate
))
150 (if (typep value
'reg
)
151 (print-word-reg value stream dstate
)
152 (print-mem-access value stream nil dstate
)))
154 (defun print-label (value stream dstate
)
155 (declare (ignore dstate
))
156 (princ16 value stream
))
158 (defun maybe-print-segment-override (stream dstate
)
159 (cond ((dstate-get-inst-prop dstate
'fs-segment-prefix
)
160 (princ "FS:" stream
))
161 ((dstate-get-inst-prop dstate
'gs-segment-prefix
)
162 (princ "GS:" stream
))))
164 ;;; Returns either an integer, meaning a register, or a list of
165 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
166 ;;; may be missing or nil to indicate that it's not used or has the
167 ;;; obvious default value (e.g., 1 for the index-scale).
168 (defun prefilter-reg/mem
(value dstate
)
169 (declare (type list value
)
170 (type disassem-state dstate
))
171 (let ((mod (car value
))
173 (declare (type (unsigned-byte 2) mod
)
174 (type (unsigned-byte 3) r
/m
))
180 (let ((sib (read-suffix 8 dstate
)))
181 (declare (type (unsigned-byte 8) sib
))
182 (let ((base-reg (ldb (byte 3 0) sib
))
183 (index-reg (ldb (byte 3 3) sib
))
184 (index-scale (ldb (byte 2 6) sib
)))
185 (declare (type (unsigned-byte 3) base-reg index-reg
)
186 (type (unsigned-byte 2) index-scale
))
190 (if (= base-reg
#b101
)
191 (read-signed-suffix 32 dstate
)
194 (read-signed-suffix 8 dstate
))
196 (read-signed-suffix 32 dstate
)))))
197 (list (if (and (= mod
#b00
) (= base-reg
#b101
)) nil base-reg
)
199 (if (= index-reg
#b100
) nil index-reg
)
200 (ash 1 index-scale
))))))
201 ((and (= mod
#b00
) (= r
/m
#b101
))
202 (list nil
(read-signed-suffix 32 dstate
)) )
206 (list r
/m
(read-signed-suffix 8 dstate
)))
208 (list r
/m
(read-signed-suffix 32 dstate
))))))
211 ;;; This is a sort of bogus prefilter that just stores the info globally for
212 ;;; other people to use; it probably never gets printed.
213 (defun prefilter-width (value dstate
)
214 (declare (type bit value
)
215 (type disassem-state dstate
))
217 (dstate-put-inst-prop dstate
'operand-size-8
))
220 ;;; This prefilter is used solely for its side effect, namely to put
221 ;;; the property OPERAND-SIZE-16 into the DSTATE.
222 (defun prefilter-x66 (value dstate
)
223 (declare (type (eql #x66
) value
)
225 (type disassem-state dstate
))
226 (dstate-put-inst-prop dstate
'operand-size-16
))
228 ;;; This prefilter is used solely for its side effect, namely to put
229 ;;; one of the properties [FG]S-SEGMENT-PREFIX into the DSTATE.
230 ;;; Unlike PREFILTER-X66, this prefilter only catches the low bit of
232 (defun prefilter-seg (value dstate
)
233 (declare (type bit value
)
234 (type disassem-state dstate
))
235 (dstate-put-inst-prop
236 dstate
(elt '(fs-segment-prefix gs-segment-prefix
) value
)))
238 (defun read-address (value dstate
)
239 (declare (ignore value
)) ; always nil anyway
240 (read-suffix (width-bits *default-address-size
*) dstate
))
242 (defun width-bits (width)
252 ;;;; disassembler argument types
254 (define-arg-type displacement
256 :use-label
#'offset-next
257 :printer
(lambda (value stream dstate
)
258 (maybe-note-assembler-routine value nil dstate
)
259 (print-label value stream dstate
)))
261 (define-arg-type accum
262 :printer
(lambda (value stream dstate
)
263 (declare (ignore value
)
265 (type disassem-state dstate
))
266 (print-reg 0 stream dstate
)))
268 (define-arg-type word-accum
269 :printer
(lambda (value stream dstate
)
270 (declare (ignore value
)
272 (type disassem-state dstate
))
273 (print-word-reg 0 stream dstate
)))
275 (define-arg-type reg
:printer
#'print-reg
)
277 (define-arg-type addr-reg
:printer
#'print-addr-reg
)
279 (define-arg-type word-reg
:printer
#'print-word-reg
)
281 (define-arg-type imm-addr
282 :prefilter
#'read-address
283 :printer
#'print-label
)
285 (define-arg-type imm-data
286 :prefilter
(lambda (value dstate
)
287 (declare (ignore value
)) ; always nil anyway
288 (read-suffix (width-bits (inst-operand-size dstate
)) dstate
)))
290 (define-arg-type signed-imm-data
291 :prefilter
(lambda (value dstate
)
292 (declare (ignore value
)) ; always nil anyway
293 (let ((width (inst-operand-size dstate
)))
294 (read-signed-suffix (width-bits width
) dstate
))))
296 (define-arg-type imm-byte
297 :prefilter
(lambda (value dstate
)
298 (declare (ignore value
)) ; always nil anyway
299 (read-suffix 8 dstate
)))
301 (define-arg-type signed-imm-byte
302 :prefilter
(lambda (value dstate
)
303 (declare (ignore value
)) ; always nil anyway
304 (read-signed-suffix 8 dstate
)))
306 (define-arg-type signed-imm-dword
307 :prefilter
(lambda (value dstate
)
308 (declare (ignore value
)) ; always nil anyway
309 (read-signed-suffix 32 dstate
)))
311 (define-arg-type imm-word
312 :prefilter
(lambda (value dstate
)
313 (declare (ignore value
)) ; always nil anyway
314 (let ((width (inst-word-operand-size dstate
)))
315 (read-suffix (width-bits width
) dstate
))))
317 (define-arg-type signed-imm-word
318 :prefilter
(lambda (value dstate
)
319 (declare (ignore value
)) ; always nil anyway
320 (let ((width (inst-word-operand-size dstate
)))
321 (read-signed-suffix (width-bits width
) dstate
))))
323 ;;; needed for the ret imm16 instruction
324 (define-arg-type imm-word-16
325 :prefilter
(lambda (value dstate
)
326 (declare (ignore value
)) ; always nil anyway
327 (read-suffix 16 dstate
)))
329 (define-arg-type reg
/mem
330 :prefilter
#'prefilter-reg
/mem
331 :printer
#'print-reg
/mem
)
332 (define-arg-type sized-reg
/mem
333 ;; Same as reg/mem, but prints an explicit size indicator for
334 ;; memory references.
335 :prefilter
#'prefilter-reg
/mem
336 :printer
#'print-sized-reg
/mem
)
337 (define-arg-type byte-reg
/mem
338 :prefilter
#'prefilter-reg
/mem
339 :printer
#'print-byte-reg
/mem
)
340 (define-arg-type word-reg
/mem
341 :prefilter
#'prefilter-reg
/mem
342 :printer
#'print-word-reg
/mem
)
345 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
346 (defun print-fp-reg (value stream dstate
)
347 (declare (ignore dstate
))
348 (format stream
"FR~D" value
))
349 (defun prefilter-fp-reg (value dstate
)
351 (declare (ignore dstate
))
354 (define-arg-type fp-reg
:prefilter
#'prefilter-fp-reg
355 :printer
#'print-fp-reg
)
357 (define-arg-type width
358 :prefilter
#'prefilter-width
359 :printer
(lambda (value stream dstate
)
360 (declare (ignore value
))
361 (princ (schar (symbol-name (inst-operand-size dstate
)) 0)
364 ;;; Used to capture the effect of the #x66 operand size override prefix.
365 (define-arg-type x66
:prefilter
#'prefilter-x66
)
367 ;;; Used to capture the effect of the #x64 and #x65 segment override
369 (define-arg-type seg
:prefilter
#'prefilter-seg
)
371 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
372 (defparameter *conditions
*
375 (:b .
2) (:nae .
2) (:c .
2)
376 (:nb .
3) (:ae .
3) (:nc .
3)
377 (:eq .
4) (:e .
4) (:z .
4)
384 (:np .
11) (:po .
11)
385 (:l .
12) (:nge .
12)
386 (:nl .
13) (:ge .
13)
387 (:le .
14) (:ng .
14)
388 (:nle .
15) (:g .
15)))
389 (defparameter *condition-name-vec
*
390 (let ((vec (make-array 16 :initial-element nil
)))
391 (dolist (cond *conditions
*)
392 (when (null (aref vec
(cdr cond
)))
393 (setf (aref vec
(cdr cond
)) (car cond
))))
397 ;;; Set assembler parameters. (In CMU CL, this was done with
398 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
399 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
400 (setf sb
!assem
:*assem-scheduler-p
* nil
))
402 (define-arg-type condition-code
:printer
*condition-name-vec
*)
404 (defun conditional-opcode (condition)
405 (cdr (assoc condition
*conditions
* :test
#'eq
)))
407 ;;;; disassembler instruction formats
409 (eval-when (:compile-toplevel
:execute
)
410 (defun swap-if (direction field1 separator field2
)
411 `(:if
(,direction
:constant
0)
412 (,field1
,separator
,field2
)
413 (,field2
,separator
,field1
))))
415 (define-instruction-format (byte 8 :default-printer
'(:name
))
416 (op :field
(byte 8 0))
421 ;;; Prefix instructions
423 (define-instruction-format (x66 8)
424 (x66 :field
(byte 8 0) :type
'x66
:value
#x66
))
426 (define-instruction-format (seg 8)
427 (seg :field
(byte 7 1) :value
#x32
)
428 (fsgs :field
(byte 1 0) :type
'seg
))
430 (define-instruction-format (simple 8)
431 (op :field
(byte 7 1))
432 (width :field
(byte 1 0) :type
'width
)
437 (define-instruction-format (two-bytes 16 :default-printer
'(:name
))
438 (op :fields
(list (byte 8 0) (byte 8 8))))
440 ;;; Same as simple, but with direction bit
441 (define-instruction-format (simple-dir 8 :include simple
)
442 (op :field
(byte 6 2))
443 (dir :field
(byte 1 1)))
445 ;;; Same as simple, but with the immediate value occurring by default,
446 ;;; and with an appropiate printer.
447 (define-instruction-format (accum-imm 8
449 :default-printer
'(:name
450 :tab accum
", " imm
))
451 (imm :type
'imm-data
))
453 (define-instruction-format (reg-no-width 8 :default-printer
'(:name
:tab reg
))
454 (op :field
(byte 5 3))
455 (reg :field
(byte 3 0) :type
'word-reg
)
457 (accum :type
'word-accum
)
460 ;;; adds a width field to reg-no-width
461 (define-instruction-format (reg 8 :default-printer
'(:name
:tab reg
))
462 (op :field
(byte 4 4))
463 (width :field
(byte 1 3) :type
'width
)
464 (reg :field
(byte 3 0) :type
'reg
)
470 ;;; Same as reg, but with direction bit
471 (define-instruction-format (reg-dir 8 :include reg
)
472 (op :field
(byte 3 5))
473 (dir :field
(byte 1 4)))
475 (define-instruction-format (reg-reg/mem
16
477 `(:name
:tab reg
", " reg
/mem
))
478 (op :field
(byte 7 1))
479 (width :field
(byte 1 0) :type
'width
)
480 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
482 (reg :field
(byte 3 11) :type
'reg
)
486 ;;; same as reg-reg/mem, but with direction bit
487 (define-instruction-format (reg-reg/mem-dir
16
492 ,(swap-if 'dir
'reg
/mem
", " 'reg
)))
493 (op :field
(byte 6 2))
494 (dir :field
(byte 1 1)))
496 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
497 (define-instruction-format (reg/mem
16 :default-printer
'(:name
:tab reg
/mem
))
498 (op :fields
(list (byte 7 1) (byte 3 11)))
499 (width :field
(byte 1 0) :type
'width
)
500 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
501 :type
'sized-reg
/mem
)
505 ;;; Same as reg/mem, but with the immediate value occurring by default,
506 ;;; and with an appropiate printer.
507 (define-instruction-format (reg/mem-imm
16
510 '(:name
:tab reg
/mem
", " imm
))
511 (reg/mem
:type
'sized-reg
/mem
)
512 (imm :type
'imm-data
))
514 ;;; Same as reg/mem, but with using the accumulator in the default printer
515 (define-instruction-format
517 :include reg
/mem
:default-printer
'(:name
:tab accum
", " reg
/mem
))
518 (reg/mem
:type
'reg
/mem
) ; don't need a size
519 (accum :type
'accum
))
521 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
522 (define-instruction-format (ext-reg-reg/mem
24
524 `(:name
:tab reg
", " reg
/mem
))
525 (prefix :field
(byte 8 0) :value
#b00001111
)
526 (op :field
(byte 7 9))
527 (width :field
(byte 1 8) :type
'width
)
528 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
530 (reg :field
(byte 3 19) :type
'reg
)
534 (define-instruction-format (ext-reg-reg/mem-no-width
24
536 `(:name
:tab reg
", " reg
/mem
))
537 (prefix :field
(byte 8 0) :value
#b00001111
)
538 (op :field
(byte 8 8))
539 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
541 (reg :field
(byte 3 19) :type
'reg
)
545 (define-instruction-format (ext-reg/mem-no-width
24
547 `(:name
:tab reg
/mem
))
548 (prefix :field
(byte 8 0) :value
#b00001111
)
549 (op :fields
(list (byte 8 8) (byte 3 19)))
550 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
553 ;;; reg-no-width with #x0f prefix
554 (define-instruction-format (ext-reg-no-width 16
555 :default-printer
'(:name
:tab reg
))
556 (prefix :field
(byte 8 0) :value
#b00001111
)
557 (op :field
(byte 5 11))
558 (reg :field
(byte 3 8) :type
'reg
))
560 ;;; Same as reg/mem, but with a prefix of #b00001111
561 (define-instruction-format (ext-reg/mem
24
562 :default-printer
'(:name
:tab reg
/mem
))
563 (prefix :field
(byte 8 0) :value
#b00001111
)
564 (op :fields
(list (byte 7 9) (byte 3 19)))
565 (width :field
(byte 1 8) :type
'width
)
566 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
567 :type
'sized-reg
/mem
)
571 (define-instruction-format (ext-reg/mem-imm
24
574 '(:name
:tab reg
/mem
", " imm
))
575 (imm :type
'imm-data
))
577 (define-instruction-format (ext-reg/mem-no-width
+imm8
24
578 :include ext-reg
/mem-no-width
580 '(:name
:tab reg
/mem
", " imm
))
581 (imm :type
'imm-byte
))
583 ;;;; This section was added by jrd, for fp instructions.
585 ;;; regular fp inst to/from registers/memory
586 (define-instruction-format (floating-point 16
588 `(:name
:tab reg
/mem
))
589 (prefix :field
(byte 5 3) :value
#b11011
)
590 (op :fields
(list (byte 3 0) (byte 3 11)))
591 (reg/mem
:fields
(list (byte 2 14) (byte 3 8)) :type
'reg
/mem
))
593 ;;; fp insn to/from fp reg
594 (define-instruction-format (floating-point-fp 16
595 :default-printer
`(:name
:tab fp-reg
))
596 (prefix :field
(byte 5 3) :value
#b11011
)
597 (suffix :field
(byte 2 14) :value
#b11
)
598 (op :fields
(list (byte 3 0) (byte 3 11)))
599 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
601 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
602 (define-instruction-format (floating-point-fp-d 16
604 `(:name
:tab
,(swap-if 'd
"ST0" ", " 'fp-reg
)))
605 (prefix :field
(byte 5 3) :value
#b11011
)
606 (suffix :field
(byte 2 14) :value
#b11
)
607 (op :fields
(list (byte 2 0) (byte 3 11)))
608 (d :field
(byte 1 2))
609 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
612 ;;; (added by (?) pfw)
613 ;;; fp no operand isns
614 (define-instruction-format (floating-point-no 16 :default-printer
'(:name
))
615 (prefix :field
(byte 8 0) :value
#b11011001
)
616 (suffix :field
(byte 3 13) :value
#b111
)
617 (op :field
(byte 5 8)))
619 (define-instruction-format (floating-point-3 16 :default-printer
'(:name
))
620 (prefix :field
(byte 5 3) :value
#b11011
)
621 (suffix :field
(byte 2 14) :value
#b11
)
622 (op :fields
(list (byte 3 0) (byte 6 8))))
624 (define-instruction-format (floating-point-5 16 :default-printer
'(:name
))
625 (prefix :field
(byte 8 0) :value
#b11011011
)
626 (suffix :field
(byte 3 13) :value
#b111
)
627 (op :field
(byte 5 8)))
629 (define-instruction-format (floating-point-st 16 :default-printer
'(:name
))
630 (prefix :field
(byte 8 0) :value
#b11011111
)
631 (suffix :field
(byte 3 13) :value
#b111
)
632 (op :field
(byte 5 8)))
634 (define-instruction-format (string-op 8
636 :default-printer
'(:name width
)))
638 (define-instruction-format (short-cond-jump 16)
639 (op :field
(byte 4 4))
640 (cc :field
(byte 4 0) :type
'condition-code
)
641 (label :field
(byte 8 8) :type
'displacement
))
643 (define-instruction-format (short-jump 16 :default-printer
'(:name
:tab label
))
644 (const :field
(byte 4 4) :value
#b1110
)
645 (op :field
(byte 4 0))
646 (label :field
(byte 8 8) :type
'displacement
))
648 (define-instruction-format (near-cond-jump 16)
649 (op :fields
(list (byte 8 0) (byte 4 12)) :value
'(#b00001111
#b1000
))
650 (cc :field
(byte 4 8) :type
'condition-code
)
651 ;; The disassembler currently doesn't let you have an instruction > 32 bits
652 ;; long, so we fake it by using a prefilter to read the offset.
653 (label :type
'displacement
654 :prefilter
(lambda (value dstate
)
655 (declare (ignore value
)) ; always nil anyway
656 (read-signed-suffix 32 dstate
))))
658 (define-instruction-format (near-jump 8 :default-printer
'(:name
:tab label
))
659 (op :field
(byte 8 0))
660 ;; The disassembler currently doesn't let you have an instruction > 32 bits
661 ;; long, so we fake it by using a prefilter to read the address.
662 (label :type
'displacement
663 :prefilter
(lambda (value dstate
)
664 (declare (ignore value
)) ; always nil anyway
665 (read-signed-suffix 32 dstate
))))
668 (define-instruction-format (cond-set 24
669 :default-printer
'('set cc
:tab reg
/mem
))
670 (prefix :field
(byte 8 0) :value
#b00001111
)
671 (op :field
(byte 4 12) :value
#b1001
)
672 (cc :field
(byte 4 8) :type
'condition-code
)
673 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
675 (reg :field
(byte 3 19) :value
#b000
))
677 (define-instruction-format (cond-move 24
679 '('cmov cc
:tab reg
", " reg
/mem
))
680 (prefix :field
(byte 8 0) :value
#b00001111
)
681 (op :field
(byte 4 12) :value
#b0100
)
682 (cc :field
(byte 4 8) :type
'condition-code
)
683 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
685 (reg :field
(byte 3 19) :type
'reg
))
687 (define-instruction-format (enter-format 32
688 :default-printer
'(:name
690 (:unless
(:constant
0)
692 (op :field
(byte 8 0))
693 (disp :field
(byte 16 8))
694 (level :field
(byte 8 24)))
696 (define-instruction-format (prefetch 24 :default-printer
'(:name
", " reg
/mem
))
697 (prefix :field
(byte 8 0) :value
#b00001111
)
698 (op :field
(byte 8 8) :value
#b00011000
)
699 (reg/mem
:fields
(list (byte 2 22) (byte 3 16)) :type
'byte-reg
/mem
)
700 (reg :field
(byte 3 19) :type
'reg
))
702 ;;; Single byte instruction with an immediate byte argument.
703 (define-instruction-format (byte-imm 16 :default-printer
'(:name
:tab code
))
704 (op :field
(byte 8 0))
705 (code :field
(byte 8 8) :reader byte-imm-code
))
707 ;;; Two byte instruction with an immediate byte argument.
709 (define-instruction-format (word-imm 24 :default-printer
'(:name
:tab code
))
710 (op :field
(byte 16 0))
711 (code :field
(byte 8 16) :reader word-imm-code
))
714 ;;;; primitive emitters
716 (define-bitfield-emitter emit-word
16
719 (define-bitfield-emitter emit-dword
32
722 (define-bitfield-emitter emit-byte-with-reg
8
723 (byte 5 3) (byte 3 0))
725 (define-bitfield-emitter emit-mod-reg-r
/m-byte
8
726 (byte 2 6) (byte 3 3) (byte 3 0))
728 (define-bitfield-emitter emit-sib-byte
8
729 (byte 2 6) (byte 3 3) (byte 3 0))
733 (defun emit-absolute-fixup (segment fixup
)
734 (note-fixup segment
:absolute fixup
)
735 (let ((offset (fixup-offset fixup
)))
737 (emit-back-patch segment
738 4 ; FIXME: n-word-bytes
739 (lambda (segment posn
)
740 (declare (ignore posn
))
742 (- (+ (component-header-length)
743 (or (label-position offset
)
745 other-pointer-lowtag
))))
746 (emit-dword segment
(or offset
0)))))
748 (defun emit-relative-fixup (segment fixup
)
749 (note-fixup segment
:relative fixup
)
750 (emit-dword segment
(or (fixup-offset fixup
) 0)))
752 ;;;; the effective-address (ea) structure
754 (defun reg-tn-encoding (tn)
755 (declare (type tn tn
))
756 (aver (eq (sb-name (sc-sb (tn-sc tn
))) 'registers
))
757 (let ((offset (tn-offset tn
)))
758 (logior (ash (logand offset
1) 2)
761 (defstruct (ea (:constructor make-ea
(size &key base index scale disp
))
763 (size nil
:type
(member :byte
:word
:dword
))
764 (base nil
:type
(or tn null
))
765 (index nil
:type
(or tn null
))
766 (scale 1 :type
(member 1 2 4 8))
767 (disp 0 :type
(or (unsigned-byte 32) (signed-byte 32) fixup
)))
768 (def!method print-object
((ea ea
) stream
)
769 (cond ((or *print-escape
* *print-readably
*)
770 (print-unreadable-object (ea stream
:type t
)
772 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
776 (let ((scale (ea-scale ea
)))
777 (if (= scale
1) nil scale
))
780 (format stream
"~A PTR [" (symbol-name (ea-size ea
)))
782 (write-string (sb!c
::location-print-name
(ea-base ea
)) stream
)
784 (write-string "+" stream
)))
786 (write-string (sb!c
::location-print-name
(ea-index ea
)) stream
))
787 (unless (= (ea-scale ea
) 1)
788 (format stream
"*~A" (ea-scale ea
)))
789 (typecase (ea-disp ea
)
792 (format stream
"~@D" (ea-disp ea
)))
794 (format stream
"+~A" (ea-disp ea
))))
795 (write-char #\
] stream
))))
797 (defun emit-ea (segment thing reg
&optional allow-constants
)
800 (ecase (sb-name (sc-sb (tn-sc thing
)))
802 (emit-mod-reg-r/m-byte segment
#b11 reg
(reg-tn-encoding thing
)))
804 ;; Convert stack tns into an index off of EBP.
805 (let ((disp (frame-byte-offset (tn-offset thing
))))
806 (cond ((<= -
128 disp
127)
807 (emit-mod-reg-r/m-byte segment
#b01 reg
#b101
)
808 (emit-byte segment disp
))
810 (emit-mod-reg-r/m-byte segment
#b10 reg
#b101
)
811 (emit-dword segment disp
)))))
813 (unless allow-constants
815 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
816 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
817 (emit-absolute-fixup segment
820 (- (* (tn-offset thing
) n-word-bytes
)
821 other-pointer-lowtag
))))))
823 (let* ((base (ea-base thing
))
824 (index (ea-index thing
))
825 (scale (ea-scale thing
))
826 (disp (ea-disp thing
))
827 (mod (cond ((or (null base
)
829 (not (= (reg-tn-encoding base
) #b101
))))
831 ((and (fixnump disp
) (<= -
128 disp
127))
835 (r/m
(cond (index #b100
)
837 (t (reg-tn-encoding base
)))))
838 (when (and (fixup-p disp
)
839 (label-p (fixup-offset disp
)))
842 (return-from emit-ea
(emit-ea segment disp reg allow-constants
)))
843 (emit-mod-reg-r/m-byte segment mod reg r
/m
)
845 (let ((ss (1- (integer-length scale
)))
846 (index (if (null index
)
848 (let ((index (reg-tn-encoding index
)))
850 (error "can't index off of ESP")
852 (base (if (null base
)
854 (reg-tn-encoding base
))))
855 (emit-sib-byte segment ss index base
)))
857 (emit-byte segment disp
))
858 ((or (= mod
#b10
) (null base
))
860 (emit-absolute-fixup segment disp
)
861 (emit-dword segment disp
))))))
863 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
864 (emit-absolute-fixup segment thing
))))
866 (defun fp-reg-tn-p (thing)
868 (eq (sb-name (sc-sb (tn-sc thing
))) 'float-registers
)))
870 ;;; like the above, but for fp-instructions--jrd
871 (defun emit-fp-op (segment thing op
)
872 (if (fp-reg-tn-p thing
)
873 (emit-byte segment
(dpb op
(byte 3 3) (dpb (tn-offset thing
)
876 (emit-ea segment thing op
)))
878 (defun byte-reg-p (thing)
880 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
881 (member (sc-name (tn-sc thing
)) *byte-sc-names
*)
884 (defun byte-ea-p (thing)
886 (ea (eq (ea-size thing
) :byte
))
888 (and (member (sc-name (tn-sc thing
)) *byte-sc-names
*) t
))
891 (defun word-reg-p (thing)
893 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
894 (member (sc-name (tn-sc thing
)) *word-sc-names
*)
897 (defun word-ea-p (thing)
899 (ea (eq (ea-size thing
) :word
))
900 (tn (and (member (sc-name (tn-sc thing
)) *word-sc-names
*) t
))
903 (defun dword-reg-p (thing)
905 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
906 (member (sc-name (tn-sc thing
)) *dword-sc-names
*)
909 (defun dword-ea-p (thing)
911 (ea (eq (ea-size thing
) :dword
))
913 (and (member (sc-name (tn-sc thing
)) *dword-sc-names
*) t
))
916 (defun register-p (thing)
918 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)))
920 (defun accumulator-p (thing)
921 (and (register-p thing
)
922 (= (tn-offset thing
) 0)))
926 (def!constant
+operand-size-prefix-byte
+ #b01100110
)
928 (defun maybe-emit-operand-size-prefix (segment size
)
929 (unless (or (eq size
:byte
) (eq size
+default-operand-size
+))
930 (emit-byte segment
+operand-size-prefix-byte
+)))
932 (defun operand-size (thing)
935 ;; FIXME: might as well be COND instead of having to use #. readmacro
936 ;; to hack up the code
937 (case (sc-name (tn-sc thing
))
944 ;; added by jrd: float-registers is a separate size (?)
945 (#.sb
!vm
::*float-sc-names
*
947 (#.sb
!vm
::*double-sc-names
*
950 (error "can't tell the size of ~S ~S" thing
(sc-name (tn-sc thing
))))))
956 (defun matching-operand-size (dst src
)
957 (let ((dst-size (operand-size dst
))
958 (src-size (operand-size src
)))
961 (if (eq dst-size src-size
)
963 (error "size mismatch: ~S is a ~S and ~S is a ~S."
964 dst dst-size src src-size
))
968 (error "can't tell the size of either ~S or ~S" dst src
)))))
970 (defun emit-sized-immediate (segment size value
)
973 (emit-byte segment value
))
975 (emit-word segment value
))
977 (emit-dword segment value
))))
981 (define-instruction x66
(segment)
982 (:printer x66
() nil
:print-name nil
)
984 (bug "#X66 prefix used as a standalone instruction")))
986 (defun emit-prefix (segment name
)
991 (emit-byte segment
#xf0
))
993 (emit-byte segment
#x64
))
995 (emit-byte segment
#x65
))))
997 (define-instruction fs
(segment)
998 (:printer seg
((fsgs #b0
)) nil
:print-name nil
)
1000 (bug "FS prefix used as a standalone instruction")))
1002 (define-instruction gs
(segment)
1003 (:printer seg
((fsgs #b1
)) nil
:print-name nil
)
1005 (bug "GS prefix used as a standalone instruction")))
1007 (define-instruction lock
(segment)
1008 (:printer byte
((op #b11110000
)) nil
)
1010 (bug "LOCK prefix used as a standalone instruction")))
1012 (define-instruction rep
(segment)
1014 (emit-byte segment
#b11110011
)))
1016 (define-instruction repe
(segment)
1017 (:printer byte
((op #b11110011
)) nil
)
1019 (emit-byte segment
#b11110011
)))
1021 (define-instruction repne
(segment)
1022 (:printer byte
((op #b11110010
)) nil
)
1024 (emit-byte segment
#b11110010
)))
1026 ;;;; general data transfer
1028 (define-instruction mov
(segment dst src
&optional prefix
)
1029 ;; immediate to register
1030 (:printer reg
((op #b1011
) (imm nil
:type
'imm-data
))
1031 '(:name
:tab reg
", " imm
))
1032 ;; absolute mem to/from accumulator
1033 (:printer simple-dir
((op #b101000
) (imm nil
:type
'imm-addr
))
1034 `(:name
:tab
,(swap-if 'dir
'accum
", " '("[" imm
"]"))))
1035 ;; register to/from register/memory
1036 (:printer reg-reg
/mem-dir
((op #b100010
)))
1037 ;; immediate to register/memory
1038 (:printer reg
/mem-imm
((op '(#b1100011
#b000
))))
1041 (emit-prefix segment prefix
)
1042 (let ((size (matching-operand-size dst src
)))
1043 (maybe-emit-operand-size-prefix segment size
)
1044 (cond ((register-p dst
)
1045 (cond ((integerp src
)
1046 (emit-byte-with-reg segment
1050 (reg-tn-encoding dst
))
1051 (emit-sized-immediate segment size src
))
1052 ((and (fixup-p src
) (accumulator-p dst
))
1057 (emit-absolute-fixup segment src
))
1063 (emit-ea segment src
(reg-tn-encoding dst
) t
))))
1064 ((and (fixup-p dst
) (accumulator-p src
))
1065 (emit-byte segment
(if (eq size
:byte
) #b10100010
#b10100011
))
1066 (emit-absolute-fixup segment dst
))
1068 (emit-byte segment
(if (eq size
:byte
) #b11000110
#b11000111
))
1069 (emit-ea segment dst
#b000
)
1070 (emit-sized-immediate segment size src
))
1072 (emit-byte segment
(if (eq size
:byte
) #b10001000
#b10001001
))
1073 (emit-ea segment dst
(reg-tn-encoding src
)))
1075 (aver (eq size
:dword
))
1076 (emit-byte segment
#b11000111
)
1077 (emit-ea segment dst
#b000
)
1078 (emit-absolute-fixup segment src
))
1080 (error "bogus arguments to MOV: ~S ~S" dst src
))))))
1082 (defun emit-move-with-extension (segment dst src opcode
)
1083 (aver (register-p dst
))
1084 (let ((dst-size (operand-size dst
))
1085 (src-size (operand-size src
)))
1088 (aver (eq src-size
:byte
))
1089 (maybe-emit-operand-size-prefix segment
:word
)
1090 (emit-byte segment
#b00001111
)
1091 (emit-byte segment opcode
)
1092 (emit-ea segment src
(reg-tn-encoding dst
)))
1096 (maybe-emit-operand-size-prefix segment
:dword
)
1097 (emit-byte segment
#b00001111
)
1098 (emit-byte segment opcode
)
1099 (emit-ea segment src
(reg-tn-encoding dst
)))
1101 (emit-byte segment
#b00001111
)
1102 (emit-byte segment
(logior opcode
1))
1103 (emit-ea segment src
(reg-tn-encoding dst
))))))))
1105 (define-instruction movsx
(segment dst src
)
1106 (:printer ext-reg-reg
/mem
((op #b1011111
)
1107 (reg nil
:type
'word-reg
)
1108 (reg/mem nil
:type
'sized-reg
/mem
)))
1109 (:emitter
(emit-move-with-extension segment dst src
#b10111110
)))
1111 (define-instruction movzx
(segment dst src
)
1112 (:printer ext-reg-reg
/mem
((op #b1011011
)
1113 (reg nil
:type
'word-reg
)
1114 (reg/mem nil
:type
'sized-reg
/mem
)))
1115 (:emitter
(emit-move-with-extension segment dst src
#b10110110
)))
1117 (define-instruction push
(segment src
&optional prefix
)
1119 (:printer reg-no-width
((op #b01010
)))
1121 (:printer reg
/mem
((op '(#b1111111
#b110
)) (width 1)))
1123 (:printer byte
((op #b01101010
) (imm nil
:type
'signed-imm-byte
))
1125 (:printer byte
((op #b01101000
) (imm nil
:type
'imm-word
))
1127 ;; ### segment registers?
1130 (emit-prefix segment prefix
)
1131 (cond ((integerp src
)
1132 (cond ((<= -
128 src
127)
1133 (emit-byte segment
#b01101010
)
1134 (emit-byte segment src
))
1136 (emit-byte segment
#b01101000
)
1137 (emit-dword segment src
))))
1139 ;; Interpret the fixup as an immediate dword to push.
1140 (emit-byte segment
#b01101000
)
1141 (emit-absolute-fixup segment src
))
1143 (let ((size (operand-size src
)))
1144 (aver (not (eq size
:byte
)))
1145 (maybe-emit-operand-size-prefix segment size
)
1146 (cond ((register-p src
)
1147 (emit-byte-with-reg segment
#b01010
(reg-tn-encoding src
)))
1149 (emit-byte segment
#b11111111
)
1150 (emit-ea segment src
#b110 t
))))))))
1152 (define-instruction pusha
(segment)
1153 (:printer byte
((op #b01100000
)))
1155 (emit-byte segment
#b01100000
)))
1157 (define-instruction pop
(segment dst
)
1158 (:printer reg-no-width
((op #b01011
)))
1159 (:printer reg
/mem
((op '(#b1000111
#b000
)) (width 1)))
1161 (let ((size (operand-size dst
)))
1162 (aver (not (eq size
:byte
)))
1163 (maybe-emit-operand-size-prefix segment size
)
1164 (cond ((register-p dst
)
1165 (emit-byte-with-reg segment
#b01011
(reg-tn-encoding dst
)))
1167 (emit-byte segment
#b10001111
)
1168 (emit-ea segment dst
#b000
))))))
1170 (define-instruction popa
(segment)
1171 (:printer byte
((op #b01100001
)))
1173 (emit-byte segment
#b01100001
)))
1175 (define-instruction xchg
(segment operand1 operand2
)
1176 ;; Register with accumulator.
1177 (:printer reg-no-width
((op #b10010
)) '(:name
:tab accum
", " reg
))
1178 ;; Register/Memory with Register.
1179 (:printer reg-reg
/mem
((op #b1000011
)))
1181 (let ((size (matching-operand-size operand1 operand2
)))
1182 (maybe-emit-operand-size-prefix segment size
)
1183 (labels ((xchg-acc-with-something (acc something
)
1184 (if (and (not (eq size
:byte
)) (register-p something
))
1185 (emit-byte-with-reg segment
1187 (reg-tn-encoding something
))
1188 (xchg-reg-with-something acc something
)))
1189 (xchg-reg-with-something (reg something
)
1190 (emit-byte segment
(if (eq size
:byte
) #b10000110
#b10000111
))
1191 (emit-ea segment something
(reg-tn-encoding reg
))))
1192 (cond ((accumulator-p operand1
)
1193 (xchg-acc-with-something operand1 operand2
))
1194 ((accumulator-p operand2
)
1195 (xchg-acc-with-something operand2 operand1
))
1196 ((register-p operand1
)
1197 (xchg-reg-with-something operand1 operand2
))
1198 ((register-p operand2
)
1199 (xchg-reg-with-something operand2 operand1
))
1201 (error "bogus args to XCHG: ~S ~S" operand1 operand2
)))))))
1203 (define-instruction lea
(segment dst src
)
1204 (:printer reg-reg
/mem
((op #b1000110
) (width 1)))
1206 (aver (dword-reg-p dst
))
1207 (emit-byte segment
#b10001101
)
1208 (emit-ea segment src
(reg-tn-encoding dst
))))
1210 (define-instruction cmpxchg
(segment dst src
&optional prefix
)
1211 ;; Register/Memory with Register.
1212 (:printer ext-reg-reg
/mem
((op #b1011000
)) '(:name
:tab reg
/mem
", " reg
))
1214 (aver (register-p src
))
1215 (emit-prefix segment prefix
)
1216 (let ((size (matching-operand-size src dst
)))
1217 (maybe-emit-operand-size-prefix segment size
)
1218 (emit-byte segment
#b00001111
)
1219 (emit-byte segment
(if (eq size
:byte
) #b10110000
#b10110001
))
1220 (emit-ea segment dst
(reg-tn-encoding src
)))))
1222 (define-instruction cmpxchg8b
(segment mem
&optional prefix
)
1223 (:printer ext-reg
/mem-no-width
((op '(#xC7
1))))
1225 (aver (not (register-p mem
)))
1226 (emit-prefix segment prefix
)
1227 (emit-byte segment
#x0F
)
1228 (emit-byte segment
#xC7
)
1229 (emit-ea segment mem
1)))
1231 (define-instruction rdrand
(segment dst
)
1232 (:printer ext-reg
/mem-no-width
1235 (aver (register-p dst
))
1236 (maybe-emit-operand-size-prefix segment
(operand-size dst
))
1237 (emit-byte segment
#x0F
)
1238 (emit-byte segment
#xC7
)
1239 (emit-ea segment dst
6)))
1241 (define-instruction pause
(segment)
1242 (:printer two-bytes
((op '(#xf3
#x90
))))
1244 (emit-byte segment
#xf3
)
1245 (emit-byte segment
#x90
)))
1247 ;;;; flag control instructions
1249 ;;; CLC -- Clear Carry Flag.
1250 (define-instruction clc
(segment)
1251 (:printer byte
((op #b11111000
)))
1253 (emit-byte segment
#b11111000
)))
1255 ;;; CLD -- Clear Direction Flag.
1256 (define-instruction cld
(segment)
1257 (:printer byte
((op #b11111100
)))
1259 (emit-byte segment
#b11111100
)))
1261 ;;; CLI -- Clear Iterrupt Enable Flag.
1262 (define-instruction cli
(segment)
1263 (:printer byte
((op #b11111010
)))
1265 (emit-byte segment
#b11111010
)))
1267 ;;; CMC -- Complement Carry Flag.
1268 (define-instruction cmc
(segment)
1269 (:printer byte
((op #b11110101
)))
1271 (emit-byte segment
#b11110101
)))
1273 ;;; LAHF -- Load AH into flags.
1274 (define-instruction lahf
(segment)
1275 (:printer byte
((op #b10011111
)))
1277 (emit-byte segment
#b10011111
)))
1279 ;;; POPF -- Pop flags.
1280 (define-instruction popf
(segment)
1281 (:printer byte
((op #b10011101
)))
1283 (emit-byte segment
#b10011101
)))
1285 ;;; PUSHF -- push flags.
1286 (define-instruction pushf
(segment)
1287 (:printer byte
((op #b10011100
)))
1289 (emit-byte segment
#b10011100
)))
1291 ;;; SAHF -- Store AH into flags.
1292 (define-instruction sahf
(segment)
1293 (:printer byte
((op #b10011110
)))
1295 (emit-byte segment
#b10011110
)))
1297 ;;; STC -- Set Carry Flag.
1298 (define-instruction stc
(segment)
1299 (:printer byte
((op #b11111001
)))
1301 (emit-byte segment
#b11111001
)))
1303 ;;; STD -- Set Direction Flag.
1304 (define-instruction std
(segment)
1305 (:printer byte
((op #b11111101
)))
1307 (emit-byte segment
#b11111101
)))
1309 ;;; STI -- Set Interrupt Enable Flag.
1310 (define-instruction sti
(segment)
1311 (:printer byte
((op #b11111011
)))
1313 (emit-byte segment
#b11111011
)))
1317 (defun emit-random-arith-inst (name segment dst src opcode
1318 &optional allow-constants
)
1319 (let ((size (matching-operand-size dst src
)))
1320 (maybe-emit-operand-size-prefix segment size
)
1323 (cond ((and (not (eq size
:byte
)) (<= -
128 src
127))
1324 (emit-byte segment
#b10000011
)
1325 (emit-ea segment dst opcode allow-constants
)
1326 (emit-byte segment src
))
1327 ((accumulator-p dst
)
1334 (emit-sized-immediate segment size src
))
1336 (emit-byte segment
(if (eq size
:byte
) #b10000000
#b10000001
))
1337 (emit-ea segment dst opcode allow-constants
)
1338 (emit-sized-immediate segment size src
))))
1343 (if (eq size
:byte
) #b00000000
#b00000001
)))
1344 (emit-ea segment dst
(reg-tn-encoding src
) allow-constants
))
1349 (if (eq size
:byte
) #b00000010
#b00000011
)))
1350 (emit-ea segment src
(reg-tn-encoding dst
) allow-constants
))
1352 (error "bogus operands to ~A" name
)))))
1354 (macrolet ((define (name subop
&optional allow-constants
)
1355 `(define-instruction ,name
(segment dst src
&optional prefix
)
1356 (:printer accum-imm
((op ,(dpb subop
(byte 3 2) #b0000010
))))
1357 (:printer reg
/mem-imm
((op '(#b1000000
,subop
))))
1358 (:printer reg
/mem-imm
((op '(#b1000001
,subop
))
1359 (imm nil
:type
'signed-imm-byte
)))
1360 (:printer reg-reg
/mem-dir
((op ,(dpb subop
(byte 3 1) #b000000
))))
1362 (emit-prefix segment prefix
)
1363 (emit-random-arith-inst ,(string name
) segment dst src
,subop
1364 ,allow-constants
)))))
1369 (define cmp
#b111 t
)
1374 (define-instruction inc
(segment dst
)
1376 (:printer reg-no-width
((op #b01000
)))
1378 (:printer reg
/mem
((op '(#b1111111
#b000
))))
1380 (let ((size (operand-size dst
)))
1381 (maybe-emit-operand-size-prefix segment size
)
1382 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1383 (emit-byte-with-reg segment
#b01000
(reg-tn-encoding dst
)))
1385 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1386 (emit-ea segment dst
#b000
))))))
1388 (define-instruction dec
(segment dst
)
1390 (:printer reg-no-width
((op #b01001
)))
1392 (:printer reg
/mem
((op '(#b1111111
#b001
))))
1394 (let ((size (operand-size dst
)))
1395 (maybe-emit-operand-size-prefix segment size
)
1396 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1397 (emit-byte-with-reg segment
#b01001
(reg-tn-encoding dst
)))
1399 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1400 (emit-ea segment dst
#b001
))))))
1402 (define-instruction neg
(segment dst
)
1403 (:printer reg
/mem
((op '(#b1111011
#b011
))))
1405 (let ((size (operand-size dst
)))
1406 (maybe-emit-operand-size-prefix segment size
)
1407 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1408 (emit-ea segment dst
#b011
))))
1410 (define-instruction aaa
(segment)
1411 (:printer byte
((op #b00110111
)))
1413 (emit-byte segment
#b00110111
)))
1415 (define-instruction aas
(segment)
1416 (:printer byte
((op #b00111111
)))
1418 (emit-byte segment
#b00111111
)))
1420 (define-instruction daa
(segment)
1421 (:printer byte
((op #b00100111
)))
1423 (emit-byte segment
#b00100111
)))
1425 (define-instruction das
(segment)
1426 (:printer byte
((op #b00101111
)))
1428 (emit-byte segment
#b00101111
)))
1430 (define-instruction mul
(segment dst src
)
1431 (:printer accum-reg
/mem
((op '(#b1111011
#b100
))))
1433 (let ((size (matching-operand-size dst src
)))
1434 (aver (accumulator-p dst
))
1435 (maybe-emit-operand-size-prefix segment size
)
1436 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1437 (emit-ea segment src
#b100
))))
1439 (define-instruction imul
(segment dst
&optional src1 src2
)
1440 (:printer accum-reg
/mem
((op '(#b1111011
#b101
))))
1441 (:printer ext-reg-reg
/mem
((op #b1010111
)))
1442 (:printer reg-reg
/mem
((op #b0110100
) (width 1)
1443 (imm nil
:type
'signed-imm-word
))
1444 '(:name
:tab reg
", " reg
/mem
", " imm
))
1445 (:printer reg-reg
/mem
((op #b0110101
) (width 1)
1446 (imm nil
:type
'signed-imm-byte
))
1447 '(:name
:tab reg
", " reg
/mem
", " imm
))
1449 (flet ((r/m-with-immed-to-reg
(reg r
/m immed
)
1450 (let* ((size (matching-operand-size reg r
/m
))
1451 (sx (and (not (eq size
:byte
)) (<= -
128 immed
127))))
1452 (maybe-emit-operand-size-prefix segment size
)
1453 (emit-byte segment
(if sx
#b01101011
#b01101001
))
1454 (emit-ea segment r
/m
(reg-tn-encoding reg
))
1456 (emit-byte segment immed
)
1457 (emit-sized-immediate segment size immed
)))))
1459 (r/m-with-immed-to-reg dst src1 src2
))
1462 (r/m-with-immed-to-reg dst dst src1
)
1463 (let ((size (matching-operand-size dst src1
)))
1464 (maybe-emit-operand-size-prefix segment size
)
1465 (emit-byte segment
#b00001111
)
1466 (emit-byte segment
#b10101111
)
1467 (emit-ea segment src1
(reg-tn-encoding dst
)))))
1469 (let ((size (operand-size dst
)))
1470 (maybe-emit-operand-size-prefix segment size
)
1471 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1472 (emit-ea segment dst
#b101
)))))))
1474 (define-instruction div
(segment dst src
)
1475 (:printer accum-reg
/mem
((op '(#b1111011
#b110
))))
1477 (let ((size (matching-operand-size dst src
)))
1478 (aver (accumulator-p dst
))
1479 (maybe-emit-operand-size-prefix segment size
)
1480 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1481 (emit-ea segment src
#b110
))))
1483 (define-instruction idiv
(segment dst src
)
1484 (:printer accum-reg
/mem
((op '(#b1111011
#b111
))))
1486 (let ((size (matching-operand-size dst src
)))
1487 (aver (accumulator-p dst
))
1488 (maybe-emit-operand-size-prefix segment size
)
1489 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1490 (emit-ea segment src
#b111
))))
1492 (define-instruction aad
(segment)
1493 (:printer two-bytes
((op '(#b11010101
#b00001010
))))
1495 (emit-byte segment
#b11010101
)
1496 (emit-byte segment
#b00001010
)))
1498 (define-instruction aam
(segment)
1499 (:printer two-bytes
((op '(#b11010100
#b00001010
))))
1501 (emit-byte segment
#b11010100
)
1502 (emit-byte segment
#b00001010
)))
1504 (define-instruction bswap
(segment dst
)
1505 (:printer ext-reg-no-width
((op #b11001
)))
1507 (emit-byte segment
#x0f
)
1508 (emit-byte-with-reg segment
#b11001
(reg-tn-encoding dst
))))
1510 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1511 (define-instruction cbw
(segment)
1512 (:printer two-bytes
((op '(#b01100110
#b10011000
))))
1514 (maybe-emit-operand-size-prefix segment
:word
)
1515 (emit-byte segment
#b10011000
)))
1517 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1518 (define-instruction cwde
(segment)
1519 (:printer byte
((op #b10011000
)))
1521 (maybe-emit-operand-size-prefix segment
:dword
)
1522 (emit-byte segment
#b10011000
)))
1524 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1525 (define-instruction cwd
(segment)
1526 (:printer two-bytes
((op '(#b01100110
#b10011001
))))
1528 (maybe-emit-operand-size-prefix segment
:word
)
1529 (emit-byte segment
#b10011001
)))
1531 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1532 (define-instruction cdq
(segment)
1533 (:printer byte
((op #b10011001
)))
1535 (maybe-emit-operand-size-prefix segment
:dword
)
1536 (emit-byte segment
#b10011001
)))
1538 (define-instruction xadd
(segment dst src
&optional prefix
)
1539 ;; Register/Memory with Register.
1540 (:printer ext-reg-reg
/mem
((op #b1100000
)) '(:name
:tab reg
/mem
", " reg
))
1542 (aver (register-p src
))
1543 (emit-prefix segment prefix
)
1544 (let ((size (matching-operand-size src dst
)))
1545 (maybe-emit-operand-size-prefix segment size
)
1546 (emit-byte segment
#b00001111
)
1547 (emit-byte segment
(if (eq size
:byte
) #b11000000
#b11000001
))
1548 (emit-ea segment dst
(reg-tn-encoding src
)))))
1553 (defun emit-shift-inst (segment dst amount opcode
)
1554 (let ((size (operand-size dst
)))
1555 (maybe-emit-operand-size-prefix segment size
)
1556 (multiple-value-bind (major-opcode immed
)
1558 (:cl
(values #b11010010 nil
))
1559 (1 (values #b11010000 nil
))
1560 (t (values #b11000000 t
)))
1562 (if (eq size
:byte
) major-opcode
(logior major-opcode
1)))
1563 (emit-ea segment dst opcode
)
1565 (emit-byte segment amount
)))))
1567 (define-instruction-format
1568 (shift-inst 16 :include reg
/mem
1569 :default-printer
'(:name
:tab reg
/mem
", " (:if
(varying :positive
) 'cl
1)))
1570 (op :fields
(list (byte 6 2) (byte 3 11)))
1571 (varying :field
(byte 1 1)))
1573 (macrolet ((define (name subop
)
1574 `(define-instruction ,name
(segment dst amount
)
1575 (:printer shift-inst
((op '(#b110100
,subop
)))) ; shift by CL or 1
1576 (:printer reg
/mem-imm
((op '(#b1100000
,subop
))
1577 (imm nil
:type
'imm-byte
)))
1578 (:emitter
(emit-shift-inst segment dst amount
,subop
)))))
1587 (defun emit-double-shift (segment opcode dst src amt
)
1588 (let ((size (matching-operand-size dst src
)))
1589 (when (eq size
:byte
)
1590 (error "Double shifts can only be used with words."))
1591 (maybe-emit-operand-size-prefix segment size
)
1592 (emit-byte segment
#b00001111
)
1593 (emit-byte segment
(dpb opcode
(byte 1 3)
1594 (if (eq amt
:cl
) #b10100101
#b10100100
)))
1596 (emit-ea segment dst src
)
1597 (emit-ea segment dst
(reg-tn-encoding src
)) ; pw tries this
1598 (unless (eq amt
:cl
)
1599 (emit-byte segment amt
))))
1601 (macrolet ((define (name direction-bit op
)
1602 `(define-instruction ,name
(segment dst src amt
)
1603 (:declare
(type (or (member :cl
) (mod 32)) amt
))
1604 (:printer ext-reg-reg
/mem-no-width
((op ,(logior op
#b100
))
1605 (imm nil
:type
'imm-byte
))
1606 '(:name
:tab reg
/mem
", " reg
", " imm
))
1607 (:printer ext-reg-reg
/mem
((op ,(logior op
#b10
)))
1608 '(:name
:tab reg
/mem
", " reg
", " 'cl
))
1610 (emit-double-shift segment
,direction-bit dst src amt
)))))
1611 (define shld
0 #b10100000
)
1612 (define shrd
1 #b10101000
))
1614 (define-instruction test
(segment this that
)
1615 (:printer accum-imm
((op #b1010100
)))
1616 (:printer reg
/mem-imm
((op '(#b1111011
#b000
))))
1617 (:printer reg-reg
/mem
((op #b1000010
)))
1619 (let ((size (matching-operand-size this that
)))
1620 (maybe-emit-operand-size-prefix segment size
)
1621 (flet ((test-immed-and-something (immed something
)
1622 (cond ((accumulator-p something
)
1624 (if (eq size
:byte
) #b10101000
#b10101001
))
1625 (emit-sized-immediate segment size immed
))
1628 (if (eq size
:byte
) #b11110110
#b11110111
))
1629 (emit-ea segment something
#b000
)
1630 (emit-sized-immediate segment size immed
))))
1631 (test-reg-and-something (reg something
)
1632 (emit-byte segment
(if (eq size
:byte
) #b10000100
#b10000101
))
1633 (emit-ea segment something
(reg-tn-encoding reg
))))
1634 (cond ((integerp that
)
1635 (test-immed-and-something that this
))
1637 (test-immed-and-something this that
))
1639 (test-reg-and-something this that
))
1641 (test-reg-and-something that this
))
1643 (error "bogus operands for TEST: ~S and ~S" this that
)))))))
1645 (define-instruction not
(segment dst
)
1646 (:printer reg
/mem
((op '(#b1111011
#b010
))))
1648 (let ((size (operand-size dst
)))
1649 (maybe-emit-operand-size-prefix segment size
)
1650 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1651 (emit-ea segment dst
#b010
))))
1653 ;;;; string manipulation
1655 (define-instruction cmps
(segment size
)
1656 (:printer string-op
((op #b1010011
)))
1658 (maybe-emit-operand-size-prefix segment size
)
1659 (emit-byte segment
(if (eq size
:byte
) #b10100110
#b10100111
))))
1661 (define-instruction ins
(segment acc
)
1662 (:printer string-op
((op #b0110110
)))
1664 (let ((size (operand-size acc
)))
1665 (aver (accumulator-p acc
))
1666 (maybe-emit-operand-size-prefix segment size
)
1667 (emit-byte segment
(if (eq size
:byte
) #b01101100
#b01101101
)))))
1669 (define-instruction lods
(segment acc
)
1670 (:printer string-op
((op #b1010110
)))
1672 (let ((size (operand-size acc
)))
1673 (aver (accumulator-p acc
))
1674 (maybe-emit-operand-size-prefix segment size
)
1675 (emit-byte segment
(if (eq size
:byte
) #b10101100
#b10101101
)))))
1677 (define-instruction movs
(segment size
)
1678 (:printer string-op
((op #b1010010
)))
1680 (maybe-emit-operand-size-prefix segment size
)
1681 (emit-byte segment
(if (eq size
:byte
) #b10100100
#b10100101
))))
1683 (define-instruction outs
(segment acc
)
1684 (:printer string-op
((op #b0110111
)))
1686 (let ((size (operand-size acc
)))
1687 (aver (accumulator-p acc
))
1688 (maybe-emit-operand-size-prefix segment size
)
1689 (emit-byte segment
(if (eq size
:byte
) #b01101110
#b01101111
)))))
1691 (define-instruction scas
(segment acc
)
1692 (:printer string-op
((op #b1010111
)))
1694 (let ((size (operand-size acc
)))
1695 (aver (accumulator-p acc
))
1696 (maybe-emit-operand-size-prefix segment size
)
1697 (emit-byte segment
(if (eq size
:byte
) #b10101110
#b10101111
)))))
1699 (define-instruction stos
(segment acc
)
1700 (:printer string-op
((op #b1010101
)))
1702 (let ((size (operand-size acc
)))
1703 (aver (accumulator-p acc
))
1704 (maybe-emit-operand-size-prefix segment size
)
1705 (emit-byte segment
(if (eq size
:byte
) #b10101010
#b10101011
)))))
1707 (define-instruction xlat
(segment)
1708 (:printer byte
((op #b11010111
)))
1710 (emit-byte segment
#b11010111
)))
1713 ;;;; bit manipulation
1715 (define-instruction bsf
(segment dst src
)
1716 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 0)))
1718 (let ((size (matching-operand-size dst src
)))
1719 (when (eq size
:byte
)
1720 (error "can't scan bytes: ~S" src
))
1721 (maybe-emit-operand-size-prefix segment size
)
1722 (emit-byte segment
#b00001111
)
1723 (emit-byte segment
#b10111100
)
1724 (emit-ea segment src
(reg-tn-encoding dst
)))))
1726 (define-instruction bsr
(segment dst src
)
1727 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 1)))
1729 (let ((size (matching-operand-size dst src
)))
1730 (when (eq size
:byte
)
1731 (error "can't scan bytes: ~S" src
))
1732 (maybe-emit-operand-size-prefix segment size
)
1733 (emit-byte segment
#b00001111
)
1734 (emit-byte segment
#b10111101
)
1735 (emit-ea segment src
(reg-tn-encoding dst
)))))
1737 (defun emit-bit-test-and-mumble (segment src index opcode
)
1738 (let ((size (operand-size src
)))
1739 (when (eq size
:byte
)
1740 (error "can't scan bytes: ~S" src
))
1741 (maybe-emit-operand-size-prefix segment size
)
1742 (emit-byte segment
#b00001111
)
1743 (cond ((integerp index
)
1744 (emit-byte segment
#b10111010
)
1745 (emit-ea segment src opcode
)
1746 (emit-byte segment index
))
1748 (emit-byte segment
(dpb opcode
(byte 3 3) #b10000011
))
1749 (emit-ea segment src
(reg-tn-encoding index
))))))
1751 (macrolet ((define (inst opcode-extension
)
1752 `(define-instruction ,inst
(segment src index
)
1753 (:printer ext-reg
/mem-no-width
+imm8
1754 ((op '(#xBA
,opcode-extension
))
1755 (reg/mem nil
:type
'sized-reg
/mem
)))
1756 (:printer ext-reg-reg
/mem-no-width
1757 ((op ,(dpb opcode-extension
(byte 3 3) #b10000011
))
1758 (reg/mem nil
:type
'sized-reg
/mem
))
1759 '(:name
:tab reg
/mem
", " reg
))
1760 (:emitter
(emit-bit-test-and-mumble segment src index
1761 ,opcode-extension
)))))
1768 ;;;; control transfer
1770 (define-instruction call
(segment where
)
1771 (:printer near-jump
((op #b11101000
)))
1772 (:printer reg
/mem
((op '(#b1111111
#b010
)) (width 1)))
1776 (emit-byte segment
#b11101000
)
1777 (emit-back-patch segment
1779 (lambda (segment posn
)
1781 (- (label-position where
)
1784 (emit-byte segment
#b11101000
)
1785 (emit-relative-fixup segment where
))
1787 (emit-byte segment
#b11111111
)
1788 (emit-ea segment where
#b010
)))))
1790 (defun emit-byte-displacement-backpatch (segment target
)
1791 (emit-back-patch segment
1793 (lambda (segment posn
)
1794 (let ((disp (- (label-position target
) (1+ posn
))))
1795 (aver (<= -
128 disp
127))
1796 (emit-byte segment disp
)))))
1798 (define-instruction jmp
(segment cond
&optional where
)
1799 ;; conditional jumps
1800 (:printer short-cond-jump
((op #b0111
)) '('j cc
:tab label
))
1801 (:printer near-cond-jump
() '('j cc
:tab label
))
1802 ;; unconditional jumps
1803 (:printer short-jump
((op #b1011
)))
1804 (:printer near-jump
((op #b11101001
)) )
1805 (:printer reg
/mem
((op '(#b1111111
#b100
)) (width 1)))
1810 (lambda (segment posn delta-if-after
)
1811 (let ((disp (- (label-position where posn delta-if-after
)
1813 (when (<= -
128 disp
127)
1815 (dpb (conditional-opcode cond
)
1818 (emit-byte-displacement-backpatch segment where
)
1820 (lambda (segment posn
)
1821 (let ((disp (- (label-position where
) (+ posn
6))))
1822 (emit-byte segment
#b00001111
)
1824 (dpb (conditional-opcode cond
)
1827 (emit-dword segment disp
)))))
1828 ((label-p (setq where cond
))
1831 (lambda (segment posn delta-if-after
)
1832 (let ((disp (- (label-position where posn delta-if-after
)
1834 (when (<= -
128 disp
127)
1835 (emit-byte segment
#b11101011
)
1836 (emit-byte-displacement-backpatch segment where
)
1838 (lambda (segment posn
)
1839 (let ((disp (- (label-position where
) (+ posn
5))))
1840 (emit-byte segment
#b11101001
)
1841 (emit-dword segment disp
)))))
1843 (emit-byte segment
#b11101001
)
1844 (emit-relative-fixup segment where
))
1846 (unless (or (ea-p where
) (tn-p where
))
1847 (error "don't know what to do with ~A" where
))
1848 (emit-byte segment
#b11111111
)
1849 (emit-ea segment where
#b100
)))))
1851 (define-instruction jmp-short
(segment label
)
1853 (emit-byte segment
#b11101011
)
1854 (emit-byte-displacement-backpatch segment label
)))
1856 (define-instruction ret
(segment &optional stack-delta
)
1857 (:printer byte
((op #b11000011
)))
1858 (:printer byte
((op #b11000010
) (imm nil
:type
'imm-word-16
))
1861 (cond ((and stack-delta
(not (zerop stack-delta
)))
1862 (emit-byte segment
#b11000010
)
1863 (emit-word segment stack-delta
))
1865 (emit-byte segment
#b11000011
)))))
1867 (define-instruction jecxz
(segment target
)
1868 (:printer short-jump
((op #b0011
)))
1870 (emit-byte segment
#b11100011
)
1871 (emit-byte-displacement-backpatch segment target
)))
1873 (define-instruction loop
(segment target
)
1874 (:printer short-jump
((op #b0010
)))
1876 (emit-byte segment
#b11100010
) ; pfw this was 11100011, or jecxz!!!!
1877 (emit-byte-displacement-backpatch segment target
)))
1879 (define-instruction loopz
(segment target
)
1880 (:printer short-jump
((op #b0001
)))
1882 (emit-byte segment
#b11100001
)
1883 (emit-byte-displacement-backpatch segment target
)))
1885 (define-instruction loopnz
(segment target
)
1886 (:printer short-jump
((op #b0000
)))
1888 (emit-byte segment
#b11100000
)
1889 (emit-byte-displacement-backpatch segment target
)))
1891 ;;;; conditional move
1892 (define-instruction cmov
(segment cond dst src
)
1893 (:printer cond-move
())
1895 (aver (register-p dst
))
1896 (let ((size (matching-operand-size dst src
)))
1897 (aver (or (eq size
:word
) (eq size
:dword
)))
1898 (maybe-emit-operand-size-prefix segment size
))
1899 (emit-byte segment
#b00001111
)
1900 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b01000000
))
1901 (emit-ea segment src
(reg-tn-encoding dst
))))
1903 ;;;; conditional byte set
1905 (define-instruction set
(segment dst cond
)
1906 (:printer cond-set
())
1908 (emit-byte segment
#b00001111
)
1909 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b10010000
))
1910 (emit-ea segment dst
#b000
)))
1914 (define-instruction enter
(segment disp
&optional
(level 0))
1915 (:declare
(type (unsigned-byte 16) disp
)
1916 (type (unsigned-byte 8) level
))
1917 (:printer enter-format
((op #b11001000
)))
1919 (emit-byte segment
#b11001000
)
1920 (emit-word segment disp
)
1921 (emit-byte segment level
)))
1923 (define-instruction leave
(segment)
1924 (:printer byte
((op #b11001001
)))
1926 (emit-byte segment
#b11001001
)))
1929 (define-instruction prefetchnta
(segment ea
)
1930 (:printer prefetch
((op #b00011000
) (reg #b000
)))
1932 (aver (typep ea
'ea
))
1933 (aver (eq :byte
(ea-size ea
)))
1934 (emit-byte segment
#b00001111
)
1935 (emit-byte segment
#b00011000
)
1936 (emit-ea segment ea
#b000
)))
1938 (define-instruction prefetcht0
(segment ea
)
1939 (:printer prefetch
((op #b00011000
) (reg #b001
)))
1941 (aver (typep ea
'ea
))
1942 (aver (eq :byte
(ea-size ea
)))
1943 (emit-byte segment
#b00001111
)
1944 (emit-byte segment
#b00011000
)
1945 (emit-ea segment ea
#b001
)))
1947 (define-instruction prefetcht1
(segment ea
)
1948 (:printer prefetch
((op #b00011000
) (reg #b010
)))
1950 (aver (typep ea
'ea
))
1951 (aver (eq :byte
(ea-size ea
)))
1952 (emit-byte segment
#b00001111
)
1953 (emit-byte segment
#b00011000
)
1954 (emit-ea segment ea
#b010
)))
1956 (define-instruction prefetcht2
(segment ea
)
1957 (:printer prefetch
((op #b00011000
) (reg #b011
)))
1959 (aver (typep ea
'ea
))
1960 (aver (eq :byte
(ea-size ea
)))
1961 (emit-byte segment
#b00001111
)
1962 (emit-byte segment
#b00011000
)
1963 (emit-ea segment ea
#b011
)))
1965 ;;;; interrupt instructions
1967 (defun snarf-error-junk (sap offset
&optional length-only
)
1968 (let* ((length (sap-ref-8 sap offset
))
1969 (vector (make-array length
:element-type
'(unsigned-byte 8))))
1970 (declare (type system-area-pointer sap
)
1971 (type (unsigned-byte 8) length
)
1972 (type (simple-array (unsigned-byte 8) (*)) vector
))
1974 (values 0 (1+ length
) nil nil
))
1976 (copy-ub8-from-system-area sap
(1+ offset
) vector
0 length
)
1977 (collect ((sc-offsets)
1979 (lengths 1) ; the length byte
1981 (error-number (read-var-integer vector index
)))
1984 (when (>= index length
)
1986 (let ((old-index index
))
1987 (sc-offsets (read-var-integer vector index
))
1988 (lengths (- index old-index
))))
1989 (values error-number
1995 (defmacro break-cases
(breaknum &body cases
)
1996 (let ((bn-temp (gensym)))
1997 (collect ((clauses))
1998 (dolist (case cases
)
1999 (clauses `((= ,bn-temp
,(car case
)) ,@(cdr case
))))
2000 `(let ((,bn-temp
,breaknum
))
2001 (cond ,@(clauses))))))
2004 (defun break-control (chunk inst stream dstate
)
2005 (declare (ignore inst
))
2006 (flet ((nt (x) (if stream
(note x dstate
))))
2007 (case #!-ud2-breakpoints
(byte-imm-code chunk dstate
)
2008 #!+ud2-breakpoints
(word-imm-code chunk dstate
)
2011 (handle-break-args #'snarf-error-junk stream dstate
))
2014 (handle-break-args #'snarf-error-junk stream dstate
))
2016 (nt "breakpoint trap"))
2017 (#.pending-interrupt-trap
2018 (nt "pending interrupt trap"))
2021 (#.fun-end-breakpoint-trap
2022 (nt "function end breakpoint trap")))))
2024 (define-instruction break
(segment code
)
2025 (:declare
(type (unsigned-byte 8) code
))
2026 #!-ud2-breakpoints
(:printer byte-imm
((op #b11001100
))
2027 '(:name
:tab code
) :control
#'break-control
)
2028 #!+ud2-breakpoints
(:printer word-imm
((op #b0000101100001111
))
2029 '(:name
:tab code
) :control
#'break-control
)
2031 #!-ud2-breakpoints
(emit-byte segment
#b11001100
)
2032 ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
2033 ;; throw a sigill with 0x0b0f instead and check for this in the
2034 ;; SIGILL handler and pass it on to the sigtrap handler if
2036 #!+ud2-breakpoints
(emit-word segment
#b0000101100001111
)
2037 (emit-byte segment code
)))
2039 (define-instruction int
(segment number
)
2040 (:declare
(type (unsigned-byte 8) number
))
2041 (:printer byte-imm
((op #b11001101
)))
2045 (emit-byte segment
#b11001100
))
2047 (emit-byte segment
#b11001101
)
2048 (emit-byte segment number
)))))
2050 (define-instruction into
(segment)
2051 (:printer byte
((op #b11001110
)))
2053 (emit-byte segment
#b11001110
)))
2055 (define-instruction bound
(segment reg bounds
)
2057 (let ((size (matching-operand-size reg bounds
)))
2058 (when (eq size
:byte
)
2059 (error "can't bounds-test bytes: ~S" reg
))
2060 (maybe-emit-operand-size-prefix segment size
)
2061 (emit-byte segment
#b01100010
)
2062 (emit-ea segment bounds
(reg-tn-encoding reg
)))))
2064 (define-instruction iret
(segment)
2065 (:printer byte
((op #b11001111
)))
2067 (emit-byte segment
#b11001111
)))
2069 ;;;; processor control
2071 (define-instruction hlt
(segment)
2072 (:printer byte
((op #b11110100
)))
2074 (emit-byte segment
#b11110100
)))
2076 (define-instruction nop
(segment)
2077 (:printer byte
((op #b10010000
)))
2079 (emit-byte segment
#b10010000
)))
2081 (define-instruction wait
(segment)
2082 (:printer byte
((op #b10011011
)))
2084 (emit-byte segment
#b10011011
)))
2086 ;;;; miscellaneous hackery
2088 (define-instruction byte
(segment byte
)
2090 (emit-byte segment byte
)))
2092 (define-instruction word
(segment word
)
2094 (emit-word segment word
)))
2096 (define-instruction dword
(segment dword
)
2098 (emit-dword segment dword
)))
2100 (defun emit-header-data (segment type
)
2101 (emit-back-patch segment
2103 (lambda (segment posn
)
2107 (component-header-length))
2111 (define-instruction simple-fun-header-word
(segment)
2113 (emit-header-data segment simple-fun-header-widetag
)))
2115 (define-instruction lra-header-word
(segment)
2117 (emit-header-data segment return-pc-header-widetag
)))
2119 ;;;; fp instructions
2121 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
2123 ;;;; Note: We treat the single-precision and double-precision variants
2124 ;;;; as separate instructions.
2126 ;;; Load single to st(0).
2127 (define-instruction fld
(segment source
)
2128 (:printer floating-point
((op '(#b001
#b000
))))
2130 (emit-byte segment
#b11011001
)
2131 (emit-fp-op segment source
#b000
)))
2133 ;;; Load double to st(0).
2134 (define-instruction fldd
(segment source
)
2135 (:printer floating-point
((op '(#b101
#b000
))))
2136 (:printer floating-point-fp
((op '(#b001
#b000
))))
2138 (if (fp-reg-tn-p source
)
2139 (emit-byte segment
#b11011001
)
2140 (emit-byte segment
#b11011101
))
2141 (emit-fp-op segment source
#b000
)))
2143 ;;; Load long to st(0).
2144 (define-instruction fldl
(segment source
)
2145 (:printer floating-point
((op '(#b011
#b101
))))
2147 (emit-byte segment
#b11011011
)
2148 (emit-fp-op segment source
#b101
)))
2150 ;;; Store single from st(0).
2151 (define-instruction fst
(segment dest
)
2152 (:printer floating-point
((op '(#b001
#b010
))))
2154 (cond ((fp-reg-tn-p dest
)
2155 (emit-byte segment
#b11011101
)
2156 (emit-fp-op segment dest
#b010
))
2158 (emit-byte segment
#b11011001
)
2159 (emit-fp-op segment dest
#b010
)))))
2161 ;;; Store double from st(0).
2162 (define-instruction fstd
(segment dest
)
2163 (:printer floating-point
((op '(#b101
#b010
))))
2164 (:printer floating-point-fp
((op '(#b101
#b010
))))
2166 (cond ((fp-reg-tn-p dest
)
2167 (emit-byte segment
#b11011101
)
2168 (emit-fp-op segment dest
#b010
))
2170 (emit-byte segment
#b11011101
)
2171 (emit-fp-op segment dest
#b010
)))))
2173 ;;; Arithmetic ops are all done with at least one operand at top of
2174 ;;; stack. The other operand is is another register or a 32/64 bit
2177 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2178 ;;; that these conflict with the Gdb conventions for binops. To reduce
2179 ;;; the confusion I've added comments showing the mathamatical
2180 ;;; operation and the two syntaxes. By the ASM386 convention the
2181 ;;; instruction syntax is:
2184 ;;; or Fop Destination, Source
2186 ;;; If only one operand is given then it is the source and the
2187 ;;; destination is ST(0). There are reversed forms of the fsub and
2188 ;;; fdiv instructions inducated by an 'R' suffix.
2190 ;;; The mathematical operation for the non-reverse form is always:
2191 ;;; destination = destination op source
2193 ;;; For the reversed form it is:
2194 ;;; destination = source op destination
2196 ;;; The instructions below only accept one operand at present which is
2197 ;;; usually the source. I've hack in extra instructions to implement
2198 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2199 ;;; the operand is the destination with the source being ST(0).
2202 ;;; st(0) = st(0) + memory or st(i).
2203 (define-instruction fadd
(segment source
)
2204 (:printer floating-point
((op '(#b000
#b000
))))
2206 (emit-byte segment
#b11011000
)
2207 (emit-fp-op segment source
#b000
)))
2210 ;;; st(0) = st(0) + memory or st(i).
2211 (define-instruction faddd
(segment source
)
2212 (:printer floating-point
((op '(#b100
#b000
))))
2213 (:printer floating-point-fp
((op '(#b000
#b000
))))
2215 (if (fp-reg-tn-p source
)
2216 (emit-byte segment
#b11011000
)
2217 (emit-byte segment
#b11011100
))
2218 (emit-fp-op segment source
#b000
)))
2220 ;;; Add double destination st(i):
2221 ;;; st(i) = st(0) + st(i).
2222 (define-instruction fadd-sti
(segment destination
)
2223 (:printer floating-point-fp
((op '(#b100
#b000
))))
2225 (aver (fp-reg-tn-p destination
))
2226 (emit-byte segment
#b11011100
)
2227 (emit-fp-op segment destination
#b000
)))
2229 (define-instruction faddp-sti
(segment destination
)
2230 (:printer floating-point-fp
((op '(#b110
#b000
))))
2232 (aver (fp-reg-tn-p destination
))
2233 (emit-byte segment
#b11011110
)
2234 (emit-fp-op segment destination
#b000
)))
2236 ;;; Subtract single:
2237 ;;; st(0) = st(0) - memory or st(i).
2238 (define-instruction fsub
(segment source
)
2239 (:printer floating-point
((op '(#b000
#b100
))))
2241 (emit-byte segment
#b11011000
)
2242 (emit-fp-op segment source
#b100
)))
2244 ;;; Subtract single, reverse:
2245 ;;; st(0) = memory or st(i) - st(0).
2246 (define-instruction fsubr
(segment source
)
2247 (:printer floating-point
((op '(#b000
#b101
))))
2249 (emit-byte segment
#b11011000
)
2250 (emit-fp-op segment source
#b101
)))
2252 ;;; Subtract double:
2253 ;;; st(0) = st(0) - memory or st(i).
2254 (define-instruction fsubd
(segment source
)
2255 (:printer floating-point
((op '(#b100
#b100
))))
2256 (:printer floating-point-fp
((op '(#b000
#b100
))))
2258 (if (fp-reg-tn-p source
)
2259 (emit-byte segment
#b11011000
)
2260 (emit-byte segment
#b11011100
))
2261 (emit-fp-op segment source
#b100
)))
2263 ;;; Subtract double, reverse:
2264 ;;; st(0) = memory or st(i) - st(0).
2265 (define-instruction fsubrd
(segment source
)
2266 (:printer floating-point
((op '(#b100
#b101
))))
2267 (:printer floating-point-fp
((op '(#b000
#b101
))))
2269 (if (fp-reg-tn-p source
)
2270 (emit-byte segment
#b11011000
)
2271 (emit-byte segment
#b11011100
))
2272 (emit-fp-op segment source
#b101
)))
2274 ;;; Subtract double, destination st(i):
2275 ;;; st(i) = st(i) - st(0).
2277 ;;; ASM386 syntax: FSUB ST(i), ST
2278 ;;; Gdb syntax: fsubr %st,%st(i)
2279 (define-instruction fsub-sti
(segment destination
)
2280 (:printer floating-point-fp
((op '(#b100
#b101
))))
2282 (aver (fp-reg-tn-p destination
))
2283 (emit-byte segment
#b11011100
)
2284 (emit-fp-op segment destination
#b101
)))
2286 (define-instruction fsubp-sti
(segment destination
)
2287 (:printer floating-point-fp
((op '(#b110
#b101
))))
2289 (aver (fp-reg-tn-p destination
))
2290 (emit-byte segment
#b11011110
)
2291 (emit-fp-op segment destination
#b101
)))
2293 ;;; Subtract double, reverse, destination st(i):
2294 ;;; st(i) = st(0) - st(i).
2296 ;;; ASM386 syntax: FSUBR ST(i), ST
2297 ;;; Gdb syntax: fsub %st,%st(i)
2298 (define-instruction fsubr-sti
(segment destination
)
2299 (:printer floating-point-fp
((op '(#b100
#b100
))))
2301 (aver (fp-reg-tn-p destination
))
2302 (emit-byte segment
#b11011100
)
2303 (emit-fp-op segment destination
#b100
)))
2305 (define-instruction fsubrp-sti
(segment destination
)
2306 (:printer floating-point-fp
((op '(#b110
#b100
))))
2308 (aver (fp-reg-tn-p destination
))
2309 (emit-byte segment
#b11011110
)
2310 (emit-fp-op segment destination
#b100
)))
2312 ;;; Multiply single:
2313 ;;; st(0) = st(0) * memory or st(i).
2314 (define-instruction fmul
(segment source
)
2315 (:printer floating-point
((op '(#b000
#b001
))))
2317 (emit-byte segment
#b11011000
)
2318 (emit-fp-op segment source
#b001
)))
2320 ;;; Multiply double:
2321 ;;; st(0) = st(0) * memory or st(i).
2322 (define-instruction fmuld
(segment source
)
2323 (:printer floating-point
((op '(#b100
#b001
))))
2324 (:printer floating-point-fp
((op '(#b000
#b001
))))
2326 (if (fp-reg-tn-p source
)
2327 (emit-byte segment
#b11011000
)
2328 (emit-byte segment
#b11011100
))
2329 (emit-fp-op segment source
#b001
)))
2331 ;;; Multiply double, destination st(i):
2332 ;;; st(i) = st(i) * st(0).
2333 (define-instruction fmul-sti
(segment destination
)
2334 (:printer floating-point-fp
((op '(#b100
#b001
))))
2336 (aver (fp-reg-tn-p destination
))
2337 (emit-byte segment
#b11011100
)
2338 (emit-fp-op segment destination
#b001
)))
2341 ;;; st(0) = st(0) / memory or st(i).
2342 (define-instruction fdiv
(segment source
)
2343 (:printer floating-point
((op '(#b000
#b110
))))
2345 (emit-byte segment
#b11011000
)
2346 (emit-fp-op segment source
#b110
)))
2348 ;;; Divide single, reverse:
2349 ;;; st(0) = memory or st(i) / st(0).
2350 (define-instruction fdivr
(segment source
)
2351 (:printer floating-point
((op '(#b000
#b111
))))
2353 (emit-byte segment
#b11011000
)
2354 (emit-fp-op segment source
#b111
)))
2357 ;;; st(0) = st(0) / memory or st(i).
2358 (define-instruction fdivd
(segment source
)
2359 (:printer floating-point
((op '(#b100
#b110
))))
2360 (:printer floating-point-fp
((op '(#b000
#b110
))))
2362 (if (fp-reg-tn-p source
)
2363 (emit-byte segment
#b11011000
)
2364 (emit-byte segment
#b11011100
))
2365 (emit-fp-op segment source
#b110
)))
2367 ;;; Divide double, reverse:
2368 ;;; st(0) = memory or st(i) / st(0).
2369 (define-instruction fdivrd
(segment source
)
2370 (:printer floating-point
((op '(#b100
#b111
))))
2371 (:printer floating-point-fp
((op '(#b000
#b111
))))
2373 (if (fp-reg-tn-p source
)
2374 (emit-byte segment
#b11011000
)
2375 (emit-byte segment
#b11011100
))
2376 (emit-fp-op segment source
#b111
)))
2378 ;;; Divide double, destination st(i):
2379 ;;; st(i) = st(i) / st(0).
2381 ;;; ASM386 syntax: FDIV ST(i), ST
2382 ;;; Gdb syntax: fdivr %st,%st(i)
2383 (define-instruction fdiv-sti
(segment destination
)
2384 (:printer floating-point-fp
((op '(#b100
#b111
))))
2386 (aver (fp-reg-tn-p destination
))
2387 (emit-byte segment
#b11011100
)
2388 (emit-fp-op segment destination
#b111
)))
2390 ;;; Divide double, reverse, destination st(i):
2391 ;;; st(i) = st(0) / st(i).
2393 ;;; ASM386 syntax: FDIVR ST(i), ST
2394 ;;; Gdb syntax: fdiv %st,%st(i)
2395 (define-instruction fdivr-sti
(segment destination
)
2396 (:printer floating-point-fp
((op '(#b100
#b110
))))
2398 (aver (fp-reg-tn-p destination
))
2399 (emit-byte segment
#b11011100
)
2400 (emit-fp-op segment destination
#b110
)))
2402 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2403 (define-instruction fxch
(segment source
)
2404 (:printer floating-point-fp
((op '(#b001
#b001
))))
2406 (aver (and (tn-p source
)
2407 (eq (sb-name (sc-sb (tn-sc source
))) 'float-registers
)))
2408 (emit-byte segment
#b11011001
)
2409 (emit-fp-op segment source
#b001
)))
2411 ;;; Push 32-bit integer to st0.
2412 (define-instruction fild
(segment source
)
2413 (:printer floating-point
((op '(#b011
#b000
))))
2415 (emit-byte segment
#b11011011
)
2416 (emit-fp-op segment source
#b000
)))
2418 ;;; Push 64-bit integer to st0.
2419 (define-instruction fildl
(segment source
)
2420 (:printer floating-point
((op '(#b111
#b101
))))
2422 (emit-byte segment
#b11011111
)
2423 (emit-fp-op segment source
#b101
)))
2425 ;;; Store 32-bit integer.
2426 (define-instruction fist
(segment dest
)
2427 (:printer floating-point
((op '(#b011
#b010
))))
2429 (emit-byte segment
#b11011011
)
2430 (emit-fp-op segment dest
#b010
)))
2432 ;;; Store and pop 32-bit integer.
2433 (define-instruction fistp
(segment dest
)
2434 (:printer floating-point
((op '(#b011
#b011
))))
2436 (emit-byte segment
#b11011011
)
2437 (emit-fp-op segment dest
#b011
)))
2439 ;;; Store and pop 64-bit integer.
2440 (define-instruction fistpl
(segment dest
)
2441 (:printer floating-point
((op '(#b111
#b111
))))
2443 (emit-byte segment
#b11011111
)
2444 (emit-fp-op segment dest
#b111
)))
2446 ;;; Store single from st(0) and pop.
2447 (define-instruction fstp
(segment dest
)
2448 (:printer floating-point
((op '(#b001
#b011
))))
2450 (cond ((fp-reg-tn-p dest
)
2451 (emit-byte segment
#b11011101
)
2452 (emit-fp-op segment dest
#b011
))
2454 (emit-byte segment
#b11011001
)
2455 (emit-fp-op segment dest
#b011
)))))
2457 ;;; Store double from st(0) and pop.
2458 (define-instruction fstpd
(segment dest
)
2459 (:printer floating-point
((op '(#b101
#b011
))))
2460 (:printer floating-point-fp
((op '(#b101
#b011
))))
2462 (cond ((fp-reg-tn-p dest
)
2463 (emit-byte segment
#b11011101
)
2464 (emit-fp-op segment dest
#b011
))
2466 (emit-byte segment
#b11011101
)
2467 (emit-fp-op segment dest
#b011
)))))
2469 ;;; Store long from st(0) and pop.
2470 (define-instruction fstpl
(segment dest
)
2471 (:printer floating-point
((op '(#b011
#b111
))))
2473 (emit-byte segment
#b11011011
)
2474 (emit-fp-op segment dest
#b111
)))
2476 ;;; Decrement stack-top pointer.
2477 (define-instruction fdecstp
(segment)
2478 (:printer floating-point-no
((op #b10110
)))
2480 (emit-byte segment
#b11011001
)
2481 (emit-byte segment
#b11110110
)))
2483 ;;; Increment stack-top pointer.
2484 (define-instruction fincstp
(segment)
2485 (:printer floating-point-no
((op #b10111
)))
2487 (emit-byte segment
#b11011001
)
2488 (emit-byte segment
#b11110111
)))
2490 ;;; Free fp register.
2491 (define-instruction ffree
(segment dest
)
2492 (:printer floating-point-fp
((op '(#b101
#b000
))))
2494 (emit-byte segment
#b11011101
)
2495 (emit-fp-op segment dest
#b000
)))
2497 (define-instruction fabs
(segment)
2498 (:printer floating-point-no
((op #b00001
)))
2500 (emit-byte segment
#b11011001
)
2501 (emit-byte segment
#b11100001
)))
2503 (define-instruction fchs
(segment)
2504 (:printer floating-point-no
((op #b00000
)))
2506 (emit-byte segment
#b11011001
)
2507 (emit-byte segment
#b11100000
)))
2509 (define-instruction frndint
(segment)
2510 (:printer floating-point-no
((op #b11100
)))
2512 (emit-byte segment
#b11011001
)
2513 (emit-byte segment
#b11111100
)))
2516 (define-instruction fninit
(segment)
2517 (:printer floating-point-5
((op #b00011
)))
2519 (emit-byte segment
#b11011011
)
2520 (emit-byte segment
#b11100011
)))
2522 ;;; Store Status Word to AX.
2523 (define-instruction fnstsw
(segment)
2524 (:printer floating-point-st
((op #b00000
)))
2526 (emit-byte segment
#b11011111
)
2527 (emit-byte segment
#b11100000
)))
2529 ;;; Load Control Word.
2531 ;;; src must be a memory location
2532 (define-instruction fldcw
(segment src
)
2533 (:printer floating-point
((op '(#b001
#b101
))))
2535 (emit-byte segment
#b11011001
)
2536 (emit-fp-op segment src
#b101
)))
2538 ;;; Store Control Word.
2539 (define-instruction fnstcw
(segment dst
)
2540 (:printer floating-point
((op '(#b001
#b111
))))
2542 (emit-byte segment
#b11011001
)
2543 (emit-fp-op segment dst
#b111
)))
2545 ;;; Store FP Environment.
2546 (define-instruction fstenv
(segment dst
)
2547 (:printer floating-point
((op '(#b001
#b110
))))
2549 (emit-byte segment
#b11011001
)
2550 (emit-fp-op segment dst
#b110
)))
2552 ;;; Restore FP Environment.
2553 (define-instruction fldenv
(segment src
)
2554 (:printer floating-point
((op '(#b001
#b100
))))
2556 (emit-byte segment
#b11011001
)
2557 (emit-fp-op segment src
#b100
)))
2560 (define-instruction fsave
(segment dst
)
2561 (:printer floating-point
((op '(#b101
#b110
))))
2563 (emit-byte segment
#b11011101
)
2564 (emit-fp-op segment dst
#b110
)))
2566 ;;; Restore FP State.
2567 (define-instruction frstor
(segment src
)
2568 (:printer floating-point
((op '(#b101
#b100
))))
2570 (emit-byte segment
#b11011101
)
2571 (emit-fp-op segment src
#b100
)))
2573 ;;; Clear exceptions.
2574 (define-instruction fnclex
(segment)
2575 (:printer floating-point-5
((op #b00010
)))
2577 (emit-byte segment
#b11011011
)
2578 (emit-byte segment
#b11100010
)))
2581 (define-instruction fcom
(segment src
)
2582 (:printer floating-point
((op '(#b000
#b010
))))
2584 (emit-byte segment
#b11011000
)
2585 (emit-fp-op segment src
#b010
)))
2587 (define-instruction fcomd
(segment src
)
2588 (:printer floating-point
((op '(#b100
#b010
))))
2589 (:printer floating-point-fp
((op '(#b000
#b010
))))
2591 (if (fp-reg-tn-p src
)
2592 (emit-byte segment
#b11011000
)
2593 (emit-byte segment
#b11011100
))
2594 (emit-fp-op segment src
#b010
)))
2596 ;;; Compare ST1 to ST0, popping the stack twice.
2597 (define-instruction fcompp
(segment)
2598 (:printer floating-point-3
((op '(#b110
#b011001
))))
2600 (emit-byte segment
#b11011110
)
2601 (emit-byte segment
#b11011001
)))
2603 ;;; unordered comparison
2604 (define-instruction fucom
(segment src
)
2605 (:printer floating-point-fp
((op '(#b101
#b100
))))
2607 (aver (fp-reg-tn-p src
))
2608 (emit-byte segment
#b11011101
)
2609 (emit-fp-op segment src
#b100
)))
2611 (define-instruction ftst
(segment)
2612 (:printer floating-point-no
((op #b00100
)))
2614 (emit-byte segment
#b11011001
)
2615 (emit-byte segment
#b11100100
)))
2619 (define-instruction fsqrt
(segment)
2620 (:printer floating-point-no
((op #b11010
)))
2622 (emit-byte segment
#b11011001
)
2623 (emit-byte segment
#b11111010
)))
2625 (define-instruction fscale
(segment)
2626 (:printer floating-point-no
((op #b11101
)))
2628 (emit-byte segment
#b11011001
)
2629 (emit-byte segment
#b11111101
)))
2631 (define-instruction fxtract
(segment)
2632 (:printer floating-point-no
((op #b10100
)))
2634 (emit-byte segment
#b11011001
)
2635 (emit-byte segment
#b11110100
)))
2637 (define-instruction fsin
(segment)
2638 (:printer floating-point-no
((op #b11110
)))
2640 (emit-byte segment
#b11011001
)
2641 (emit-byte segment
#b11111110
)))
2643 (define-instruction fcos
(segment)
2644 (:printer floating-point-no
((op #b11111
)))
2646 (emit-byte segment
#b11011001
)
2647 (emit-byte segment
#b11111111
)))
2649 (define-instruction fprem1
(segment)
2650 (:printer floating-point-no
((op #b10101
)))
2652 (emit-byte segment
#b11011001
)
2653 (emit-byte segment
#b11110101
)))
2655 (define-instruction fprem
(segment)
2656 (:printer floating-point-no
((op #b11000
)))
2658 (emit-byte segment
#b11011001
)
2659 (emit-byte segment
#b11111000
)))
2661 (define-instruction fxam
(segment)
2662 (:printer floating-point-no
((op #b00101
)))
2664 (emit-byte segment
#b11011001
)
2665 (emit-byte segment
#b11100101
)))
2667 ;;; These do push/pop to stack and need special handling
2668 ;;; in any VOPs that use them. See the book.
2670 ;;; st0 <- st1*log2(st0)
2671 (define-instruction fyl2x
(segment) ; pops stack
2672 (:printer floating-point-no
((op #b10001
)))
2674 (emit-byte segment
#b11011001
)
2675 (emit-byte segment
#b11110001
)))
2677 (define-instruction fyl2xp1
(segment)
2678 (:printer floating-point-no
((op #b11001
)))
2680 (emit-byte segment
#b11011001
)
2681 (emit-byte segment
#b11111001
)))
2683 (define-instruction f2xm1
(segment)
2684 (:printer floating-point-no
((op #b10000
)))
2686 (emit-byte segment
#b11011001
)
2687 (emit-byte segment
#b11110000
)))
2689 (define-instruction fptan
(segment) ; st(0) <- 1; st(1) <- tan
2690 (:printer floating-point-no
((op #b10010
)))
2692 (emit-byte segment
#b11011001
)
2693 (emit-byte segment
#b11110010
)))
2695 (define-instruction fpatan
(segment) ; POPS STACK
2696 (:printer floating-point-no
((op #b10011
)))
2698 (emit-byte segment
#b11011001
)
2699 (emit-byte segment
#b11110011
)))
2701 ;;;; loading constants
2703 (define-instruction fldz
(segment)
2704 (:printer floating-point-no
((op #b01110
)))
2706 (emit-byte segment
#b11011001
)
2707 (emit-byte segment
#b11101110
)))
2709 (define-instruction fld1
(segment)
2710 (:printer floating-point-no
((op #b01000
)))
2712 (emit-byte segment
#b11011001
)
2713 (emit-byte segment
#b11101000
)))
2715 (define-instruction fldpi
(segment)
2716 (:printer floating-point-no
((op #b01011
)))
2718 (emit-byte segment
#b11011001
)
2719 (emit-byte segment
#b11101011
)))
2721 (define-instruction fldl2t
(segment)
2722 (:printer floating-point-no
((op #b01001
)))
2724 (emit-byte segment
#b11011001
)
2725 (emit-byte segment
#b11101001
)))
2727 (define-instruction fldl2e
(segment)
2728 (:printer floating-point-no
((op #b01010
)))
2730 (emit-byte segment
#b11011001
)
2731 (emit-byte segment
#b11101010
)))
2733 (define-instruction fldlg2
(segment)
2734 (:printer floating-point-no
((op #b01100
)))
2736 (emit-byte segment
#b11011001
)
2737 (emit-byte segment
#b11101100
)))
2739 (define-instruction fldln2
(segment)
2740 (:printer floating-point-no
((op #b01101
)))
2742 (emit-byte segment
#b11011001
)
2743 (emit-byte segment
#b11101101
)))
2747 (define-instruction cpuid
(segment)
2748 (:printer two-bytes
((op '(#b00001111
#b10100010
))))
2750 (emit-byte segment
#b00001111
)
2751 (emit-byte segment
#b10100010
)))
2753 (define-instruction rdtsc
(segment)
2754 (:printer two-bytes
((op '(#b00001111
#b00110001
))))
2756 (emit-byte segment
#b00001111
)
2757 (emit-byte segment
#b00110001
)))
2759 ;;;; Late VM definitions
2760 (defun canonicalize-inline-constant (constant)
2761 (let ((first (car constant
)))
2763 (single-float (setf constant
(list :single-float first
)))
2764 (double-float (setf constant
(list :double-float first
)))))
2765 (destructuring-bind (type value
) constant
2767 ((:byte
:word
:dword
)
2768 (aver (integerp value
))
2771 #!+sb-unicode
(aver (typep value
'base-char
))
2772 (cons :byte
(char-code value
)))
2774 (aver (characterp value
))
2775 (cons :dword
(char-code value
)))
2777 (aver (typep value
'single-float
))
2778 (cons :dword
(ldb (byte 32 0) (single-float-bits value
))))
2779 ((:double-float-bits
)
2780 (aver (integerp value
))
2781 (cons :double-float
(ldb (byte 64 0) value
)))
2783 (aver (typep value
'double-float
))
2785 (ldb (byte 64 0) (logior (ash (double-float-high-bits value
) 32)
2786 (double-float-low-bits value
))))))))
2788 (defun inline-constant-value (constant)
2789 (let ((label (gen-label))
2790 (size (ecase (car constant
)
2791 ((:byte
:word
:dword
) (car constant
))
2792 (:double-float
:dword
))))
2793 (values label
(make-ea size
2794 :disp
(make-fixup nil
:code-object label
)))))
2796 (defun emit-constant-segment-header (segment constants optimize
)
2797 (declare (ignore segment constants
))
2798 (loop repeat
(if optimize
64 16) do
(inst byte
#x90
)))
2800 (defun size-nbyte (size)
2807 (defun sort-inline-constants (constants)
2808 (stable-sort constants
#'> :key
(lambda (constant)
2809 (size-nbyte (caar constant
)))))
2811 (defun emit-inline-constant (constant label
)
2812 (let ((size (size-nbyte (car constant
))))
2813 (emit-alignment (integer-length (1- size
)))
2815 (let ((val (cdr constant
)))
2817 do
(inst byte
(ldb (byte 8 0) val
))
2818 (setf val
(ash val -
8))))))