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
(reg-reg/mem
16
486 `(:name
:tab reg
", " reg
/mem
))
487 (op :field
(byte 7 1))
488 (width :field
(byte 1 0) :type
'width
)
489 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
491 (reg :field
(byte 3 11) :type
'reg
)
495 ;;; same as reg-reg/mem, but with direction bit
496 (sb!disassem
:define-instruction-format
(reg-reg/mem-dir
16
497 :include
'reg-reg
/mem
501 ,(swap-if 'dir
'reg
/mem
", " 'reg
)))
502 (op :field
(byte 6 2))
503 (dir :field
(byte 1 1)))
505 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
506 (sb!disassem
:define-instruction-format
(reg/mem
16
507 :default-printer
'(:name
:tab reg
/mem
))
508 (op :fields
(list (byte 7 1) (byte 3 11)))
509 (width :field
(byte 1 0) :type
'width
)
510 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
511 :type
'sized-reg
/mem
)
515 ;;; Same as reg/mem, but with the immediate value occurring by default,
516 ;;; and with an appropiate printer.
517 (sb!disassem
:define-instruction-format
(reg/mem-imm
16
520 '(:name
:tab reg
/mem
", " imm
))
521 (reg/mem
:type
'sized-reg
/mem
)
522 (imm :type
'imm-data
))
524 ;;; Same as reg/mem, but with using the accumulator in the default printer
525 (sb!disassem
:define-instruction-format
527 :include
'reg
/mem
:default-printer
'(:name
:tab accum
", " reg
/mem
))
528 (reg/mem
:type
'reg
/mem
) ; don't need a size
529 (accum :type
'accum
))
531 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
532 (sb!disassem
:define-instruction-format
(ext-reg-reg/mem
24
534 `(:name
:tab reg
", " reg
/mem
))
535 (prefix :field
(byte 8 0) :value
#b00001111
)
536 (op :field
(byte 7 9))
537 (width :field
(byte 1 8) :type
'width
)
538 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
540 (reg :field
(byte 3 19) :type
'reg
)
544 (sb!disassem
:define-instruction-format
(ext-reg-reg/mem-no-width
24
546 `(:name
:tab reg
", " reg
/mem
))
547 (prefix :field
(byte 8 0) :value
#b00001111
)
548 (op :field
(byte 8 8))
549 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
551 (reg :field
(byte 3 19) :type
'reg
)
555 (sb!disassem
:define-instruction-format
(ext-reg/mem-no-width
24
557 `(:name
:tab reg
/mem
))
558 (prefix :field
(byte 8 0) :value
#b00001111
)
559 (op :fields
(list (byte 8 8) (byte 3 19)))
560 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
563 ;;; reg-no-width with #x0f prefix
564 (sb!disassem
:define-instruction-format
(ext-reg-no-width 16
565 :default-printer
'(:name
:tab reg
))
566 (prefix :field
(byte 8 0) :value
#b00001111
)
567 (op :field
(byte 5 11))
568 (reg :field
(byte 3 8) :type
'reg
))
570 ;;; Same as reg/mem, but with a prefix of #b00001111
571 (sb!disassem
:define-instruction-format
(ext-reg/mem
24
572 :default-printer
'(:name
:tab reg
/mem
))
573 (prefix :field
(byte 8 0) :value
#b00001111
)
574 (op :fields
(list (byte 7 9) (byte 3 19)))
575 (width :field
(byte 1 8) :type
'width
)
576 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
577 :type
'sized-reg
/mem
)
581 (sb!disassem
:define-instruction-format
(ext-reg/mem-imm
24
582 :include
'ext-reg
/mem
584 '(:name
:tab reg
/mem
", " imm
))
585 (imm :type
'imm-data
))
587 (sb!disassem
:define-instruction-format
(ext-reg/mem-no-width
+imm8
24
588 :include
'ext-reg
/mem-no-width
590 '(:name
:tab reg
/mem
", " imm
))
591 (imm :type
'imm-byte
))
593 ;;;; This section was added by jrd, for fp instructions.
595 ;;; regular fp inst to/from registers/memory
596 (sb!disassem
:define-instruction-format
(floating-point 16
598 `(:name
:tab reg
/mem
))
599 (prefix :field
(byte 5 3) :value
#b11011
)
600 (op :fields
(list (byte 3 0) (byte 3 11)))
601 (reg/mem
:fields
(list (byte 2 14) (byte 3 8)) :type
'reg
/mem
))
603 ;;; fp insn to/from fp reg
604 (sb!disassem
:define-instruction-format
(floating-point-fp 16
605 :default-printer
`(:name
:tab fp-reg
))
606 (prefix :field
(byte 5 3) :value
#b11011
)
607 (suffix :field
(byte 2 14) :value
#b11
)
608 (op :fields
(list (byte 3 0) (byte 3 11)))
609 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
611 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
612 (sb!disassem
:define-instruction-format
613 (floating-point-fp-d 16
614 :default-printer
`(:name
:tab
,(swap-if 'd
"ST0" ", " 'fp-reg
)))
615 (prefix :field
(byte 5 3) :value
#b11011
)
616 (suffix :field
(byte 2 14) :value
#b11
)
617 (op :fields
(list (byte 2 0) (byte 3 11)))
618 (d :field
(byte 1 2))
619 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
622 ;;; (added by (?) pfw)
623 ;;; fp no operand isns
624 (sb!disassem
:define-instruction-format
(floating-point-no 16
625 :default-printer
'(:name
))
626 (prefix :field
(byte 8 0) :value
#b11011001
)
627 (suffix :field
(byte 3 13) :value
#b111
)
628 (op :field
(byte 5 8)))
630 (sb!disassem
:define-instruction-format
(floating-point-3 16
631 :default-printer
'(:name
))
632 (prefix :field
(byte 5 3) :value
#b11011
)
633 (suffix :field
(byte 2 14) :value
#b11
)
634 (op :fields
(list (byte 3 0) (byte 6 8))))
636 (sb!disassem
:define-instruction-format
(floating-point-5 16
637 :default-printer
'(:name
))
638 (prefix :field
(byte 8 0) :value
#b11011011
)
639 (suffix :field
(byte 3 13) :value
#b111
)
640 (op :field
(byte 5 8)))
642 (sb!disassem
:define-instruction-format
(floating-point-st 16
643 :default-printer
'(:name
))
644 (prefix :field
(byte 8 0) :value
#b11011111
)
645 (suffix :field
(byte 3 13) :value
#b111
)
646 (op :field
(byte 5 8)))
648 (sb!disassem
:define-instruction-format
(string-op 8
650 :default-printer
'(:name width
)))
652 (sb!disassem
:define-instruction-format
(short-cond-jump 16)
653 (op :field
(byte 4 4))
654 (cc :field
(byte 4 0) :type
'condition-code
)
655 (label :field
(byte 8 8) :type
'displacement
))
657 (sb!disassem
:define-instruction-format
(short-jump 16
658 :default-printer
'(:name
:tab label
))
659 (const :field
(byte 4 4) :value
#b1110
)
660 (op :field
(byte 4 0))
661 (label :field
(byte 8 8) :type
'displacement
))
663 (sb!disassem
:define-instruction-format
(near-cond-jump 16)
664 (op :fields
(list (byte 8 0) (byte 4 12)) :value
'(#b00001111
#b1000
))
665 (cc :field
(byte 4 8) :type
'condition-code
)
666 ;; The disassembler currently doesn't let you have an instruction > 32 bits
667 ;; long, so we fake it by using a prefilter to read the offset.
668 (label :type
'displacement
669 :prefilter
(lambda (value dstate
)
670 (declare (ignore value
)) ; always nil anyway
671 (sb!disassem
:read-signed-suffix
32 dstate
))))
673 (sb!disassem
:define-instruction-format
(near-jump 8
674 :default-printer
'(:name
:tab label
))
675 (op :field
(byte 8 0))
676 ;; The disassembler currently doesn't let you have an instruction > 32 bits
677 ;; long, so we fake it by using a prefilter to read the address.
678 (label :type
'displacement
679 :prefilter
(lambda (value dstate
)
680 (declare (ignore value
)) ; always nil anyway
681 (sb!disassem
:read-signed-suffix
32 dstate
))))
684 (sb!disassem
:define-instruction-format
(cond-set 24
685 :default-printer
'('set cc
:tab reg
/mem
))
686 (prefix :field
(byte 8 0) :value
#b00001111
)
687 (op :field
(byte 4 12) :value
#b1001
)
688 (cc :field
(byte 4 8) :type
'condition-code
)
689 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
691 (reg :field
(byte 3 19) :value
#b000
))
693 (sb!disassem
:define-instruction-format
(cond-move 24
695 '('cmov cc
:tab reg
", " reg
/mem
))
696 (prefix :field
(byte 8 0) :value
#b00001111
)
697 (op :field
(byte 4 12) :value
#b0100
)
698 (cc :field
(byte 4 8) :type
'condition-code
)
699 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
701 (reg :field
(byte 3 19) :type
'reg
))
703 (sb!disassem
:define-instruction-format
(enter-format 32
704 :default-printer
'(:name
706 (:unless
(:constant
0)
708 (op :field
(byte 8 0))
709 (disp :field
(byte 16 8))
710 (level :field
(byte 8 24)))
712 (sb!disassem
:define-instruction-format
(prefetch 24
714 '(:name
", " reg
/mem
))
715 (prefix :field
(byte 8 0) :value
#b00001111
)
716 (op :field
(byte 8 8) :value
#b00011000
)
717 (reg/mem
:fields
(list (byte 2 22) (byte 3 16)) :type
'byte-reg
/mem
)
718 (reg :field
(byte 3 19) :type
'reg
))
720 ;;; Single byte instruction with an immediate byte argument.
721 (sb!disassem
:define-instruction-format
(byte-imm 16
722 :default-printer
'(:name
:tab code
))
723 (op :field
(byte 8 0))
724 (code :field
(byte 8 8)))
726 ;;; Two byte instruction with an immediate byte argument.
728 (sb!disassem
:define-instruction-format
(word-imm 24
729 :default-printer
'(:name
:tab code
))
730 (op :field
(byte 16 0))
731 (code :field
(byte 8 16)))
734 ;;;; primitive emitters
736 (define-bitfield-emitter emit-word
16
739 (define-bitfield-emitter emit-dword
32
742 (define-bitfield-emitter emit-byte-with-reg
8
743 (byte 5 3) (byte 3 0))
745 (define-bitfield-emitter emit-mod-reg-r
/m-byte
8
746 (byte 2 6) (byte 3 3) (byte 3 0))
748 (define-bitfield-emitter emit-sib-byte
8
749 (byte 2 6) (byte 3 3) (byte 3 0))
753 (defun emit-absolute-fixup (segment fixup
)
754 (note-fixup segment
:absolute fixup
)
755 (let ((offset (fixup-offset fixup
)))
757 (emit-back-patch segment
758 4 ; FIXME: n-word-bytes
759 (lambda (segment posn
)
760 (declare (ignore posn
))
762 (- (+ (component-header-length)
763 (or (label-position offset
)
765 other-pointer-lowtag
))))
766 (emit-dword segment
(or offset
0)))))
768 (defun emit-relative-fixup (segment fixup
)
769 (note-fixup segment
:relative fixup
)
770 (emit-dword segment
(or (fixup-offset fixup
) 0)))
772 ;;;; the effective-address (ea) structure
774 (defun reg-tn-encoding (tn)
775 (declare (type tn tn
))
776 (aver (eq (sb-name (sc-sb (tn-sc tn
))) 'registers
))
777 (let ((offset (tn-offset tn
)))
778 (logior (ash (logand offset
1) 2)
781 (defstruct (ea (:constructor make-ea
(size &key base index scale disp
))
783 (size nil
:type
(member :byte
:word
:dword
))
784 (base nil
:type
(or tn null
))
785 (index nil
:type
(or tn null
))
786 (scale 1 :type
(member 1 2 4 8))
787 (disp 0 :type
(or (unsigned-byte 32) (signed-byte 32) fixup
)))
788 (def!method print-object
((ea ea
) stream
)
789 (cond ((or *print-escape
* *print-readably
*)
790 (print-unreadable-object (ea stream
:type t
)
792 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
796 (let ((scale (ea-scale ea
)))
797 (if (= scale
1) nil scale
))
800 (format stream
"~A PTR [" (symbol-name (ea-size ea
)))
802 (write-string (sb!c
::location-print-name
(ea-base ea
)) stream
)
804 (write-string "+" stream
)))
806 (write-string (sb!c
::location-print-name
(ea-index ea
)) stream
))
807 (unless (= (ea-scale ea
) 1)
808 (format stream
"*~A" (ea-scale ea
)))
809 (typecase (ea-disp ea
)
812 (format stream
"~@D" (ea-disp ea
)))
814 (format stream
"+~A" (ea-disp ea
))))
815 (write-char #\
] stream
))))
817 (defun emit-ea (segment thing reg
&optional allow-constants
)
820 (ecase (sb-name (sc-sb (tn-sc thing
)))
822 (emit-mod-reg-r/m-byte segment
#b11 reg
(reg-tn-encoding thing
)))
824 ;; Convert stack tns into an index off of EBP.
825 (let ((disp (frame-byte-offset (tn-offset thing
))))
826 (cond ((<= -
128 disp
127)
827 (emit-mod-reg-r/m-byte segment
#b01 reg
#b101
)
828 (emit-byte segment disp
))
830 (emit-mod-reg-r/m-byte segment
#b10 reg
#b101
)
831 (emit-dword segment disp
)))))
833 (unless allow-constants
835 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
836 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
837 (emit-absolute-fixup segment
840 (- (* (tn-offset thing
) n-word-bytes
)
841 other-pointer-lowtag
))))))
843 (let* ((base (ea-base thing
))
844 (index (ea-index thing
))
845 (scale (ea-scale thing
))
846 (disp (ea-disp thing
))
847 (mod (cond ((or (null base
)
849 (not (= (reg-tn-encoding base
) #b101
))))
851 ((and (fixnump disp
) (<= -
128 disp
127))
855 (r/m
(cond (index #b100
)
857 (t (reg-tn-encoding base
)))))
858 (when (and (fixup-p disp
)
859 (label-p (fixup-offset disp
)))
862 (return-from emit-ea
(emit-ea segment disp reg allow-constants
)))
863 (emit-mod-reg-r/m-byte segment mod reg r
/m
)
865 (let ((ss (1- (integer-length scale
)))
866 (index (if (null index
)
868 (let ((index (reg-tn-encoding index
)))
870 (error "can't index off of ESP")
872 (base (if (null base
)
874 (reg-tn-encoding base
))))
875 (emit-sib-byte segment ss index base
)))
877 (emit-byte segment disp
))
878 ((or (= mod
#b10
) (null base
))
880 (emit-absolute-fixup segment disp
)
881 (emit-dword segment disp
))))))
883 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
884 (emit-absolute-fixup segment thing
))))
886 (defun fp-reg-tn-p (thing)
888 (eq (sb-name (sc-sb (tn-sc thing
))) 'float-registers
)))
890 ;;; like the above, but for fp-instructions--jrd
891 (defun emit-fp-op (segment thing op
)
892 (if (fp-reg-tn-p thing
)
893 (emit-byte segment
(dpb op
(byte 3 3) (dpb (tn-offset thing
)
896 (emit-ea segment thing op
)))
898 (defun byte-reg-p (thing)
900 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
901 (member (sc-name (tn-sc thing
)) *byte-sc-names
*)
904 (defun byte-ea-p (thing)
906 (ea (eq (ea-size thing
) :byte
))
908 (and (member (sc-name (tn-sc thing
)) *byte-sc-names
*) t
))
911 (defun word-reg-p (thing)
913 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
914 (member (sc-name (tn-sc thing
)) *word-sc-names
*)
917 (defun word-ea-p (thing)
919 (ea (eq (ea-size thing
) :word
))
920 (tn (and (member (sc-name (tn-sc thing
)) *word-sc-names
*) t
))
923 (defun dword-reg-p (thing)
925 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
926 (member (sc-name (tn-sc thing
)) *dword-sc-names
*)
929 (defun dword-ea-p (thing)
931 (ea (eq (ea-size thing
) :dword
))
933 (and (member (sc-name (tn-sc thing
)) *dword-sc-names
*) t
))
936 (defun register-p (thing)
938 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)))
940 (defun accumulator-p (thing)
941 (and (register-p thing
)
942 (= (tn-offset thing
) 0)))
946 (def!constant
+operand-size-prefix-byte
+ #b01100110
)
948 (defun maybe-emit-operand-size-prefix (segment size
)
949 (unless (or (eq size
:byte
) (eq size
+default-operand-size
+))
950 (emit-byte segment
+operand-size-prefix-byte
+)))
952 (defun operand-size (thing)
955 ;; FIXME: might as well be COND instead of having to use #. readmacro
956 ;; to hack up the code
957 (case (sc-name (tn-sc thing
))
964 ;; added by jrd: float-registers is a separate size (?)
970 (error "can't tell the size of ~S ~S" thing
(sc-name (tn-sc thing
))))))
976 (defun matching-operand-size (dst src
)
977 (let ((dst-size (operand-size dst
))
978 (src-size (operand-size src
)))
981 (if (eq dst-size src-size
)
983 (error "size mismatch: ~S is a ~S and ~S is a ~S."
984 dst dst-size src src-size
))
988 (error "can't tell the size of either ~S or ~S" dst src
)))))
990 (defun emit-sized-immediate (segment size value
)
993 (emit-byte segment value
))
995 (emit-word segment value
))
997 (emit-dword segment value
))))
1001 (define-instruction x66
(segment)
1002 (:printer x66
() nil
:print-name nil
)
1004 (bug "#X66 prefix used as a standalone instruction")))
1006 (defun emit-prefix (segment name
)
1011 (emit-byte segment
#xf0
))
1013 (emit-byte segment
#x64
))
1015 (emit-byte segment
#x65
))))
1017 (define-instruction fs
(segment)
1018 (:printer seg
((fsgs #b0
)) nil
:print-name nil
)
1020 (bug "FS prefix used as a standalone instruction")))
1022 (define-instruction gs
(segment)
1023 (:printer seg
((fsgs #b1
)) nil
:print-name nil
)
1025 (bug "GS prefix used as a standalone instruction")))
1027 (define-instruction lock
(segment)
1028 (:printer byte
((op #b11110000
)) nil
)
1030 (bug "LOCK prefix used as a standalone instruction")))
1032 (define-instruction rep
(segment)
1034 (emit-byte segment
#b11110011
)))
1036 (define-instruction repe
(segment)
1037 (:printer byte
((op #b11110011
)) nil
)
1039 (emit-byte segment
#b11110011
)))
1041 (define-instruction repne
(segment)
1042 (:printer byte
((op #b11110010
)) nil
)
1044 (emit-byte segment
#b11110010
)))
1046 ;;;; general data transfer
1048 (define-instruction mov
(segment dst src
&optional prefix
)
1049 ;; immediate to register
1050 (:printer reg
((op #b1011
) (imm nil
:type
'imm-data
))
1051 '(:name
:tab reg
", " imm
))
1052 ;; absolute mem to/from accumulator
1053 (:printer simple-dir
((op #b101000
) (imm nil
:type
'imm-addr
))
1054 `(:name
:tab
,(swap-if 'dir
'accum
", " '("[" imm
"]"))))
1055 ;; register to/from register/memory
1056 (:printer reg-reg
/mem-dir
((op #b100010
)))
1057 ;; immediate to register/memory
1058 (:printer reg
/mem-imm
((op '(#b1100011
#b000
))))
1061 (emit-prefix segment prefix
)
1062 (let ((size (matching-operand-size dst src
)))
1063 (maybe-emit-operand-size-prefix segment size
)
1064 (cond ((register-p dst
)
1065 (cond ((integerp src
)
1066 (emit-byte-with-reg segment
1070 (reg-tn-encoding dst
))
1071 (emit-sized-immediate segment size src
))
1072 ((and (fixup-p src
) (accumulator-p dst
))
1077 (emit-absolute-fixup segment src
))
1083 (emit-ea segment src
(reg-tn-encoding dst
) t
))))
1084 ((and (fixup-p dst
) (accumulator-p src
))
1085 (emit-byte segment
(if (eq size
:byte
) #b10100010
#b10100011
))
1086 (emit-absolute-fixup segment dst
))
1088 (emit-byte segment
(if (eq size
:byte
) #b11000110
#b11000111
))
1089 (emit-ea segment dst
#b000
)
1090 (emit-sized-immediate segment size src
))
1092 (emit-byte segment
(if (eq size
:byte
) #b10001000
#b10001001
))
1093 (emit-ea segment dst
(reg-tn-encoding src
)))
1095 (aver (eq size
:dword
))
1096 (emit-byte segment
#b11000111
)
1097 (emit-ea segment dst
#b000
)
1098 (emit-absolute-fixup segment src
))
1100 (error "bogus arguments to MOV: ~S ~S" dst src
))))))
1102 (defun emit-move-with-extension (segment dst src opcode
)
1103 (aver (register-p dst
))
1104 (let ((dst-size (operand-size dst
))
1105 (src-size (operand-size src
)))
1108 (aver (eq src-size
:byte
))
1109 (maybe-emit-operand-size-prefix segment
:word
)
1110 (emit-byte segment
#b00001111
)
1111 (emit-byte segment opcode
)
1112 (emit-ea segment src
(reg-tn-encoding dst
)))
1116 (maybe-emit-operand-size-prefix segment
:dword
)
1117 (emit-byte segment
#b00001111
)
1118 (emit-byte segment opcode
)
1119 (emit-ea segment src
(reg-tn-encoding dst
)))
1121 (emit-byte segment
#b00001111
)
1122 (emit-byte segment
(logior opcode
1))
1123 (emit-ea segment src
(reg-tn-encoding dst
))))))))
1125 (define-instruction movsx
(segment dst src
)
1126 (:printer ext-reg-reg
/mem
((op #b1011111
)
1127 (reg nil
:type
'word-reg
)
1128 (reg/mem nil
:type
'sized-reg
/mem
)))
1129 (:emitter
(emit-move-with-extension segment dst src
#b10111110
)))
1131 (define-instruction movzx
(segment dst src
)
1132 (:printer ext-reg-reg
/mem
((op #b1011011
)
1133 (reg nil
:type
'word-reg
)
1134 (reg/mem nil
:type
'sized-reg
/mem
)))
1135 (:emitter
(emit-move-with-extension segment dst src
#b10110110
)))
1137 (define-instruction push
(segment src
&optional prefix
)
1139 (:printer reg-no-width
((op #b01010
)))
1141 (:printer reg
/mem
((op '(#b1111111
#b110
)) (width 1)))
1143 (:printer byte
((op #b01101010
) (imm nil
:type
'signed-imm-byte
))
1145 (:printer byte
((op #b01101000
) (imm nil
:type
'imm-word
))
1147 ;; ### segment registers?
1150 (emit-prefix segment prefix
)
1151 (cond ((integerp src
)
1152 (cond ((<= -
128 src
127)
1153 (emit-byte segment
#b01101010
)
1154 (emit-byte segment src
))
1156 (emit-byte segment
#b01101000
)
1157 (emit-dword segment src
))))
1159 ;; Interpret the fixup as an immediate dword to push.
1160 (emit-byte segment
#b01101000
)
1161 (emit-absolute-fixup segment src
))
1163 (let ((size (operand-size src
)))
1164 (aver (not (eq size
:byte
)))
1165 (maybe-emit-operand-size-prefix segment size
)
1166 (cond ((register-p src
)
1167 (emit-byte-with-reg segment
#b01010
(reg-tn-encoding src
)))
1169 (emit-byte segment
#b11111111
)
1170 (emit-ea segment src
#b110 t
))))))))
1172 (define-instruction pusha
(segment)
1173 (:printer byte
((op #b01100000
)))
1175 (emit-byte segment
#b01100000
)))
1177 (define-instruction pop
(segment dst
)
1178 (:printer reg-no-width
((op #b01011
)))
1179 (:printer reg
/mem
((op '(#b1000111
#b000
)) (width 1)))
1181 (let ((size (operand-size dst
)))
1182 (aver (not (eq size
:byte
)))
1183 (maybe-emit-operand-size-prefix segment size
)
1184 (cond ((register-p dst
)
1185 (emit-byte-with-reg segment
#b01011
(reg-tn-encoding dst
)))
1187 (emit-byte segment
#b10001111
)
1188 (emit-ea segment dst
#b000
))))))
1190 (define-instruction popa
(segment)
1191 (:printer byte
((op #b01100001
)))
1193 (emit-byte segment
#b01100001
)))
1195 (define-instruction xchg
(segment operand1 operand2
)
1196 ;; Register with accumulator.
1197 (:printer reg-no-width
((op #b10010
)) '(:name
:tab accum
", " reg
))
1198 ;; Register/Memory with Register.
1199 (:printer reg-reg
/mem
((op #b1000011
)))
1201 (let ((size (matching-operand-size operand1 operand2
)))
1202 (maybe-emit-operand-size-prefix segment size
)
1203 (labels ((xchg-acc-with-something (acc something
)
1204 (if (and (not (eq size
:byte
)) (register-p something
))
1205 (emit-byte-with-reg segment
1207 (reg-tn-encoding something
))
1208 (xchg-reg-with-something acc something
)))
1209 (xchg-reg-with-something (reg something
)
1210 (emit-byte segment
(if (eq size
:byte
) #b10000110
#b10000111
))
1211 (emit-ea segment something
(reg-tn-encoding reg
))))
1212 (cond ((accumulator-p operand1
)
1213 (xchg-acc-with-something operand1 operand2
))
1214 ((accumulator-p operand2
)
1215 (xchg-acc-with-something operand2 operand1
))
1216 ((register-p operand1
)
1217 (xchg-reg-with-something operand1 operand2
))
1218 ((register-p operand2
)
1219 (xchg-reg-with-something operand2 operand1
))
1221 (error "bogus args to XCHG: ~S ~S" operand1 operand2
)))))))
1223 (define-instruction lea
(segment dst src
)
1224 (:printer reg-reg
/mem
((op #b1000110
) (width 1)))
1226 (aver (dword-reg-p dst
))
1227 (emit-byte segment
#b10001101
)
1228 (emit-ea segment src
(reg-tn-encoding dst
))))
1230 (define-instruction cmpxchg
(segment dst src
&optional prefix
)
1231 ;; Register/Memory with Register.
1232 (:printer ext-reg-reg
/mem
((op #b1011000
)) '(:name
:tab reg
/mem
", " reg
))
1234 (aver (register-p src
))
1235 (emit-prefix segment prefix
)
1236 (let ((size (matching-operand-size src dst
)))
1237 (maybe-emit-operand-size-prefix segment size
)
1238 (emit-byte segment
#b00001111
)
1239 (emit-byte segment
(if (eq size
:byte
) #b10110000
#b10110001
))
1240 (emit-ea segment dst
(reg-tn-encoding src
)))))
1242 (define-instruction cmpxchg8b
(segment mem
&optional prefix
)
1243 (:printer ext-reg-reg
/mem-no-width
((op #xC7
)) '(:name
:tab reg
/mem
))
1245 (aver (not (register-p mem
)))
1246 (emit-prefix segment prefix
)
1247 (emit-byte segment
#x0F
)
1248 (emit-byte segment
#xC7
)
1249 (emit-ea segment mem
1)))
1251 (define-instruction pause
(segment)
1252 (:printer two-bytes
((op '(#xf3
#x90
))))
1254 (emit-byte segment
#xf3
)
1255 (emit-byte segment
#x90
)))
1257 ;;;; flag control instructions
1259 ;;; CLC -- Clear Carry Flag.
1260 (define-instruction clc
(segment)
1261 (:printer byte
((op #b11111000
)))
1263 (emit-byte segment
#b11111000
)))
1265 ;;; CLD -- Clear Direction Flag.
1266 (define-instruction cld
(segment)
1267 (:printer byte
((op #b11111100
)))
1269 (emit-byte segment
#b11111100
)))
1271 ;;; CLI -- Clear Iterrupt Enable Flag.
1272 (define-instruction cli
(segment)
1273 (:printer byte
((op #b11111010
)))
1275 (emit-byte segment
#b11111010
)))
1277 ;;; CMC -- Complement Carry Flag.
1278 (define-instruction cmc
(segment)
1279 (:printer byte
((op #b11110101
)))
1281 (emit-byte segment
#b11110101
)))
1283 ;;; LAHF -- Load AH into flags.
1284 (define-instruction lahf
(segment)
1285 (:printer byte
((op #b10011111
)))
1287 (emit-byte segment
#b10011111
)))
1289 ;;; POPF -- Pop flags.
1290 (define-instruction popf
(segment)
1291 (:printer byte
((op #b10011101
)))
1293 (emit-byte segment
#b10011101
)))
1295 ;;; PUSHF -- push flags.
1296 (define-instruction pushf
(segment)
1297 (:printer byte
((op #b10011100
)))
1299 (emit-byte segment
#b10011100
)))
1301 ;;; SAHF -- Store AH into flags.
1302 (define-instruction sahf
(segment)
1303 (:printer byte
((op #b10011110
)))
1305 (emit-byte segment
#b10011110
)))
1307 ;;; STC -- Set Carry Flag.
1308 (define-instruction stc
(segment)
1309 (:printer byte
((op #b11111001
)))
1311 (emit-byte segment
#b11111001
)))
1313 ;;; STD -- Set Direction Flag.
1314 (define-instruction std
(segment)
1315 (:printer byte
((op #b11111101
)))
1317 (emit-byte segment
#b11111101
)))
1319 ;;; STI -- Set Interrupt Enable Flag.
1320 (define-instruction sti
(segment)
1321 (:printer byte
((op #b11111011
)))
1323 (emit-byte segment
#b11111011
)))
1327 (defun emit-random-arith-inst (name segment dst src opcode
1328 &optional allow-constants
)
1329 (let ((size (matching-operand-size dst src
)))
1330 (maybe-emit-operand-size-prefix segment size
)
1333 (cond ((and (not (eq size
:byte
)) (<= -
128 src
127))
1334 (emit-byte segment
#b10000011
)
1335 (emit-ea segment dst opcode allow-constants
)
1336 (emit-byte segment src
))
1337 ((accumulator-p dst
)
1344 (emit-sized-immediate segment size src
))
1346 (emit-byte segment
(if (eq size
:byte
) #b10000000
#b10000001
))
1347 (emit-ea segment dst opcode allow-constants
)
1348 (emit-sized-immediate segment size src
))))
1353 (if (eq size
:byte
) #b00000000
#b00000001
)))
1354 (emit-ea segment dst
(reg-tn-encoding src
) allow-constants
))
1359 (if (eq size
:byte
) #b00000010
#b00000011
)))
1360 (emit-ea segment src
(reg-tn-encoding dst
) allow-constants
))
1362 (error "bogus operands to ~A" name
)))))
1364 (eval-when (:compile-toplevel
:execute
)
1365 (defun arith-inst-printer-list (subop)
1366 `((accum-imm ((op ,(dpb subop
(byte 3 2) #b0000010
))))
1367 (reg/mem-imm
((op (#b1000000
,subop
))))
1368 (reg/mem-imm
((op (#b1000001
,subop
))
1369 (imm nil
:type signed-imm-byte
)))
1370 (reg-reg/mem-dir
((op ,(dpb subop
(byte 3 1) #b000000
)))))))
1372 (define-instruction add
(segment dst src
&optional prefix
)
1373 (:printer-list
(arith-inst-printer-list #b000
))
1375 (emit-prefix segment prefix
)
1376 (emit-random-arith-inst "ADD" segment dst src
#b000
)))
1378 (define-instruction adc
(segment dst src
)
1379 (:printer-list
(arith-inst-printer-list #b010
))
1380 (:emitter
(emit-random-arith-inst "ADC" segment dst src
#b010
)))
1382 (define-instruction sub
(segment dst src
&optional prefix
)
1383 (:printer-list
(arith-inst-printer-list #b101
))
1385 (emit-prefix segment prefix
)
1386 (emit-random-arith-inst "SUB" segment dst src
#b101
)))
1388 (define-instruction sbb
(segment dst src
)
1389 (:printer-list
(arith-inst-printer-list #b011
))
1390 (:emitter
(emit-random-arith-inst "SBB" segment dst src
#b011
)))
1392 (define-instruction cmp
(segment dst src
&optional prefix
)
1393 (:printer-list
(arith-inst-printer-list #b111
))
1395 (emit-prefix segment prefix
)
1396 (emit-random-arith-inst "CMP" segment dst src
#b111 t
)))
1398 (define-instruction inc
(segment dst
)
1400 (:printer reg-no-width
((op #b01000
)))
1402 (:printer reg
/mem
((op '(#b1111111
#b000
))))
1404 (let ((size (operand-size dst
)))
1405 (maybe-emit-operand-size-prefix segment size
)
1406 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1407 (emit-byte-with-reg segment
#b01000
(reg-tn-encoding dst
)))
1409 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1410 (emit-ea segment dst
#b000
))))))
1412 (define-instruction dec
(segment dst
)
1414 (:printer reg-no-width
((op #b01001
)))
1416 (:printer reg
/mem
((op '(#b1111111
#b001
))))
1418 (let ((size (operand-size dst
)))
1419 (maybe-emit-operand-size-prefix segment size
)
1420 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1421 (emit-byte-with-reg segment
#b01001
(reg-tn-encoding dst
)))
1423 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1424 (emit-ea segment dst
#b001
))))))
1426 (define-instruction neg
(segment dst
)
1427 (:printer reg
/mem
((op '(#b1111011
#b011
))))
1429 (let ((size (operand-size dst
)))
1430 (maybe-emit-operand-size-prefix segment size
)
1431 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1432 (emit-ea segment dst
#b011
))))
1434 (define-instruction aaa
(segment)
1435 (:printer byte
((op #b00110111
)))
1437 (emit-byte segment
#b00110111
)))
1439 (define-instruction aas
(segment)
1440 (:printer byte
((op #b00111111
)))
1442 (emit-byte segment
#b00111111
)))
1444 (define-instruction daa
(segment)
1445 (:printer byte
((op #b00100111
)))
1447 (emit-byte segment
#b00100111
)))
1449 (define-instruction das
(segment)
1450 (:printer byte
((op #b00101111
)))
1452 (emit-byte segment
#b00101111
)))
1454 (define-instruction mul
(segment dst src
)
1455 (:printer accum-reg
/mem
((op '(#b1111011
#b100
))))
1457 (let ((size (matching-operand-size dst src
)))
1458 (aver (accumulator-p dst
))
1459 (maybe-emit-operand-size-prefix segment size
)
1460 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1461 (emit-ea segment src
#b100
))))
1463 (define-instruction imul
(segment dst
&optional src1 src2
)
1464 (:printer accum-reg
/mem
((op '(#b1111011
#b101
))))
1465 (:printer ext-reg-reg
/mem
((op #b1010111
)))
1466 (:printer reg-reg
/mem
((op #b0110100
) (width 1)
1467 (imm nil
:type
'signed-imm-word
))
1468 '(:name
:tab reg
", " reg
/mem
", " imm
))
1469 (:printer reg-reg
/mem
((op #b0110101
) (width 1)
1470 (imm nil
:type
'signed-imm-byte
))
1471 '(:name
:tab reg
", " reg
/mem
", " imm
))
1473 (flet ((r/m-with-immed-to-reg
(reg r
/m immed
)
1474 (let* ((size (matching-operand-size reg r
/m
))
1475 (sx (and (not (eq size
:byte
)) (<= -
128 immed
127))))
1476 (maybe-emit-operand-size-prefix segment size
)
1477 (emit-byte segment
(if sx
#b01101011
#b01101001
))
1478 (emit-ea segment r
/m
(reg-tn-encoding reg
))
1480 (emit-byte segment immed
)
1481 (emit-sized-immediate segment size immed
)))))
1483 (r/m-with-immed-to-reg dst src1 src2
))
1486 (r/m-with-immed-to-reg dst dst src1
)
1487 (let ((size (matching-operand-size dst src1
)))
1488 (maybe-emit-operand-size-prefix segment size
)
1489 (emit-byte segment
#b00001111
)
1490 (emit-byte segment
#b10101111
)
1491 (emit-ea segment src1
(reg-tn-encoding dst
)))))
1493 (let ((size (operand-size dst
)))
1494 (maybe-emit-operand-size-prefix segment size
)
1495 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1496 (emit-ea segment dst
#b101
)))))))
1498 (define-instruction div
(segment dst src
)
1499 (:printer accum-reg
/mem
((op '(#b1111011
#b110
))))
1501 (let ((size (matching-operand-size dst src
)))
1502 (aver (accumulator-p dst
))
1503 (maybe-emit-operand-size-prefix segment size
)
1504 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1505 (emit-ea segment src
#b110
))))
1507 (define-instruction idiv
(segment dst src
)
1508 (:printer accum-reg
/mem
((op '(#b1111011
#b111
))))
1510 (let ((size (matching-operand-size dst src
)))
1511 (aver (accumulator-p dst
))
1512 (maybe-emit-operand-size-prefix segment size
)
1513 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1514 (emit-ea segment src
#b111
))))
1516 (define-instruction aad
(segment)
1517 (:printer two-bytes
((op '(#b11010101
#b00001010
))))
1519 (emit-byte segment
#b11010101
)
1520 (emit-byte segment
#b00001010
)))
1522 (define-instruction aam
(segment)
1523 (:printer two-bytes
((op '(#b11010100
#b00001010
))))
1525 (emit-byte segment
#b11010100
)
1526 (emit-byte segment
#b00001010
)))
1528 (define-instruction bswap
(segment dst
)
1529 (:printer ext-reg-no-width
((op #b11001
)))
1531 (emit-byte segment
#x0f
)
1532 (emit-byte-with-reg segment
#b11001
(reg-tn-encoding dst
))))
1534 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1535 (define-instruction cbw
(segment)
1536 (:printer two-bytes
((op '(#b01100110
#b10011000
))))
1538 (maybe-emit-operand-size-prefix segment
:word
)
1539 (emit-byte segment
#b10011000
)))
1541 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1542 (define-instruction cwde
(segment)
1543 (:printer byte
((op #b10011000
)))
1545 (maybe-emit-operand-size-prefix segment
:dword
)
1546 (emit-byte segment
#b10011000
)))
1548 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1549 (define-instruction cwd
(segment)
1550 (:printer two-bytes
((op '(#b01100110
#b10011001
))))
1552 (maybe-emit-operand-size-prefix segment
:word
)
1553 (emit-byte segment
#b10011001
)))
1555 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1556 (define-instruction cdq
(segment)
1557 (:printer byte
((op #b10011001
)))
1559 (maybe-emit-operand-size-prefix segment
:dword
)
1560 (emit-byte segment
#b10011001
)))
1562 (define-instruction xadd
(segment dst src
&optional prefix
)
1563 ;; Register/Memory with Register.
1564 (:printer ext-reg-reg
/mem
((op #b1100000
)) '(:name
:tab reg
/mem
", " reg
))
1566 (aver (register-p src
))
1567 (emit-prefix segment prefix
)
1568 (let ((size (matching-operand-size src dst
)))
1569 (maybe-emit-operand-size-prefix segment size
)
1570 (emit-byte segment
#b00001111
)
1571 (emit-byte segment
(if (eq size
:byte
) #b11000000
#b11000001
))
1572 (emit-ea segment dst
(reg-tn-encoding src
)))))
1577 (defun emit-shift-inst (segment dst amount opcode
)
1578 (let ((size (operand-size dst
)))
1579 (maybe-emit-operand-size-prefix segment size
)
1580 (multiple-value-bind (major-opcode immed
)
1582 (:cl
(values #b11010010 nil
))
1583 (1 (values #b11010000 nil
))
1584 (t (values #b11000000 t
)))
1586 (if (eq size
:byte
) major-opcode
(logior major-opcode
1)))
1587 (emit-ea segment dst opcode
)
1589 (emit-byte segment amount
)))))
1591 (sb!disassem
:define-instruction-format
1592 (shift-inst 16 :include
'reg
/mem
1593 :default-printer
'(:name
:tab reg
/mem
", " (:if
(varying :positive
) 'cl
1)))
1594 (op :fields
(list (byte 6 2) (byte 3 11)))
1595 (varying :field
(byte 1 1)))
1597 (macrolet ((define (name subop
)
1598 `(define-instruction ,name
(segment dst amount
)
1599 (:printer shift-inst
((op '(#b110100
,subop
)))) ; shift by CL or 1
1600 (:printer reg
/mem-imm
((op '(#b1100000
,subop
))
1601 (imm nil
:type
'imm-byte
)))
1602 (:emitter
(emit-shift-inst segment dst amount
,subop
)))))
1611 (defun emit-double-shift (segment opcode dst src amt
)
1612 (let ((size (matching-operand-size dst src
)))
1613 (when (eq size
:byte
)
1614 (error "Double shifts can only be used with words."))
1615 (maybe-emit-operand-size-prefix segment size
)
1616 (emit-byte segment
#b00001111
)
1617 (emit-byte segment
(dpb opcode
(byte 1 3)
1618 (if (eq amt
:cl
) #b10100101
#b10100100
)))
1620 (emit-ea segment dst src
)
1621 (emit-ea segment dst
(reg-tn-encoding src
)) ; pw tries this
1622 (unless (eq amt
:cl
)
1623 (emit-byte segment amt
))))
1625 (eval-when (:compile-toplevel
:execute
)
1626 (defun double-shift-inst-printer-list (op)
1627 `((ext-reg-reg/mem
((op ,(logior op
#b10
)) (width 0)
1628 (imm nil
:type signed-imm-byte
))
1629 (:name
:tab reg
/mem
", " reg
", " imm
))
1630 (ext-reg-reg/mem
((op ,(logior op
#b10
)) (width 1))
1631 (:name
:tab reg
/mem
", " reg
", " 'cl
)))))
1633 (define-instruction shld
(segment dst src amt
)
1634 (:declare
(type (or (member :cl
) (mod 32)) amt
))
1635 (:printer-list
(double-shift-inst-printer-list #b1010000
))
1637 (emit-double-shift segment
#b0 dst src amt
)))
1639 (define-instruction shrd
(segment dst src amt
)
1640 (:declare
(type (or (member :cl
) (mod 32)) amt
))
1641 (:printer-list
(double-shift-inst-printer-list #b1010100
))
1643 (emit-double-shift segment
#b1 dst src amt
)))
1645 (define-instruction and
(segment dst src
)
1647 (arith-inst-printer-list #b100
))
1649 (emit-random-arith-inst "AND" segment dst src
#b100
)))
1651 (define-instruction test
(segment this that
)
1652 (:printer accum-imm
((op #b1010100
)))
1653 (:printer reg
/mem-imm
((op '(#b1111011
#b000
))))
1654 (:printer reg-reg
/mem
((op #b1000010
)))
1656 (let ((size (matching-operand-size this that
)))
1657 (maybe-emit-operand-size-prefix segment size
)
1658 (flet ((test-immed-and-something (immed something
)
1659 (cond ((accumulator-p something
)
1661 (if (eq size
:byte
) #b10101000
#b10101001
))
1662 (emit-sized-immediate segment size immed
))
1665 (if (eq size
:byte
) #b11110110
#b11110111
))
1666 (emit-ea segment something
#b000
)
1667 (emit-sized-immediate segment size immed
))))
1668 (test-reg-and-something (reg something
)
1669 (emit-byte segment
(if (eq size
:byte
) #b10000100
#b10000101
))
1670 (emit-ea segment something
(reg-tn-encoding reg
))))
1671 (cond ((integerp that
)
1672 (test-immed-and-something that this
))
1674 (test-immed-and-something this that
))
1676 (test-reg-and-something this that
))
1678 (test-reg-and-something that this
))
1680 (error "bogus operands for TEST: ~S and ~S" this that
)))))))
1682 ;;; Emit the most compact form of the test immediate instruction,
1683 ;;; using an 8 bit test when the immediate is only 8 bits and the
1684 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
1686 (defun emit-optimized-test-inst (x y
)
1689 (let ((offset (tn-offset x
)))
1690 (cond ((and (sc-is x any-reg descriptor-reg
)
1691 (or (= offset eax-offset
) (= offset ebx-offset
)
1692 (= offset ecx-offset
) (= offset edx-offset
)))
1693 (inst test
(make-random-tn :kind
:normal
1694 :sc
(sc-or-lose 'byte-reg
)
1697 ((sc-is x control-stack
)
1698 (inst test
(make-ea :byte
:base ebp-tn
1699 :disp
(frame-byte-offset offset
))
1706 (define-instruction or
(segment dst src
&optional prefix
)
1708 (arith-inst-printer-list #b001
))
1710 (emit-prefix segment prefix
)
1711 (emit-random-arith-inst "OR" segment dst src
#b001
)))
1713 (define-instruction xor
(segment dst src
&optional prefix
)
1715 (arith-inst-printer-list #b110
))
1717 (emit-prefix segment prefix
)
1718 (emit-random-arith-inst "XOR" segment dst src
#b110
)))
1720 (define-instruction not
(segment dst
)
1721 (:printer reg
/mem
((op '(#b1111011
#b010
))))
1723 (let ((size (operand-size dst
)))
1724 (maybe-emit-operand-size-prefix segment size
)
1725 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1726 (emit-ea segment dst
#b010
))))
1728 ;;;; string manipulation
1730 (define-instruction cmps
(segment size
)
1731 (:printer string-op
((op #b1010011
)))
1733 (maybe-emit-operand-size-prefix segment size
)
1734 (emit-byte segment
(if (eq size
:byte
) #b10100110
#b10100111
))))
1736 (define-instruction ins
(segment acc
)
1737 (:printer string-op
((op #b0110110
)))
1739 (let ((size (operand-size acc
)))
1740 (aver (accumulator-p acc
))
1741 (maybe-emit-operand-size-prefix segment size
)
1742 (emit-byte segment
(if (eq size
:byte
) #b01101100
#b01101101
)))))
1744 (define-instruction lods
(segment acc
)
1745 (:printer string-op
((op #b1010110
)))
1747 (let ((size (operand-size acc
)))
1748 (aver (accumulator-p acc
))
1749 (maybe-emit-operand-size-prefix segment size
)
1750 (emit-byte segment
(if (eq size
:byte
) #b10101100
#b10101101
)))))
1752 (define-instruction movs
(segment size
)
1753 (:printer string-op
((op #b1010010
)))
1755 (maybe-emit-operand-size-prefix segment size
)
1756 (emit-byte segment
(if (eq size
:byte
) #b10100100
#b10100101
))))
1758 (define-instruction outs
(segment acc
)
1759 (:printer string-op
((op #b0110111
)))
1761 (let ((size (operand-size acc
)))
1762 (aver (accumulator-p acc
))
1763 (maybe-emit-operand-size-prefix segment size
)
1764 (emit-byte segment
(if (eq size
:byte
) #b01101110
#b01101111
)))))
1766 (define-instruction scas
(segment acc
)
1767 (:printer string-op
((op #b1010111
)))
1769 (let ((size (operand-size acc
)))
1770 (aver (accumulator-p acc
))
1771 (maybe-emit-operand-size-prefix segment size
)
1772 (emit-byte segment
(if (eq size
:byte
) #b10101110
#b10101111
)))))
1774 (define-instruction stos
(segment acc
)
1775 (:printer string-op
((op #b1010101
)))
1777 (let ((size (operand-size acc
)))
1778 (aver (accumulator-p acc
))
1779 (maybe-emit-operand-size-prefix segment size
)
1780 (emit-byte segment
(if (eq size
:byte
) #b10101010
#b10101011
)))))
1782 (define-instruction xlat
(segment)
1783 (:printer byte
((op #b11010111
)))
1785 (emit-byte segment
#b11010111
)))
1788 ;;;; bit manipulation
1790 (define-instruction bsf
(segment dst src
)
1791 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 0)))
1793 (let ((size (matching-operand-size dst src
)))
1794 (when (eq size
:byte
)
1795 (error "can't scan bytes: ~S" src
))
1796 (maybe-emit-operand-size-prefix segment size
)
1797 (emit-byte segment
#b00001111
)
1798 (emit-byte segment
#b10111100
)
1799 (emit-ea segment src
(reg-tn-encoding dst
)))))
1801 (define-instruction bsr
(segment dst src
)
1802 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 1)))
1804 (let ((size (matching-operand-size dst src
)))
1805 (when (eq size
:byte
)
1806 (error "can't scan bytes: ~S" src
))
1807 (maybe-emit-operand-size-prefix segment size
)
1808 (emit-byte segment
#b00001111
)
1809 (emit-byte segment
#b10111101
)
1810 (emit-ea segment src
(reg-tn-encoding dst
)))))
1812 (defun emit-bit-test-and-mumble (segment src index opcode
)
1813 (let ((size (operand-size src
)))
1814 (when (eq size
:byte
)
1815 (error "can't scan bytes: ~S" src
))
1816 (maybe-emit-operand-size-prefix segment size
)
1817 (emit-byte segment
#b00001111
)
1818 (cond ((integerp index
)
1819 (emit-byte segment
#b10111010
)
1820 (emit-ea segment src opcode
)
1821 (emit-byte segment index
))
1823 (emit-byte segment
(dpb opcode
(byte 3 3) #b10000011
))
1824 (emit-ea segment src
(reg-tn-encoding index
))))))
1826 (eval-when (:compile-toplevel
:execute
)
1827 (defun bit-test-inst-printer-list (subop)
1828 `((ext-reg/mem-no-width
+imm8
((op (#xBA
,subop
))))
1829 (ext-reg-reg/mem-no-width
((op ,(dpb subop
(byte 3 3) #b10000011
))
1830 (reg/mem nil
:type sized-reg
/mem
))
1831 (:name
:tab reg
/mem
", " reg
)))))
1833 (macrolet ((define (inst opcode-extension
)
1834 `(define-instruction ,inst
(segment src index
)
1835 (:printer-list
(bit-test-inst-printer-list ,opcode-extension
))
1836 (:emitter
(emit-bit-test-and-mumble segment src index
1837 ,opcode-extension
)))))
1844 ;;;; control transfer
1846 (define-instruction call
(segment where
)
1847 (:printer near-jump
((op #b11101000
)))
1848 (:printer reg
/mem
((op '(#b1111111
#b010
)) (width 1)))
1852 (emit-byte segment
#b11101000
)
1853 (emit-back-patch segment
1855 (lambda (segment posn
)
1857 (- (label-position where
)
1860 (emit-byte segment
#b11101000
)
1861 (emit-relative-fixup segment where
))
1863 (emit-byte segment
#b11111111
)
1864 (emit-ea segment where
#b010
)))))
1866 (defun emit-byte-displacement-backpatch (segment target
)
1867 (emit-back-patch segment
1869 (lambda (segment posn
)
1870 (let ((disp (- (label-position target
) (1+ posn
))))
1871 (aver (<= -
128 disp
127))
1872 (emit-byte segment disp
)))))
1874 (define-instruction jmp
(segment cond
&optional where
)
1875 ;; conditional jumps
1876 (:printer short-cond-jump
((op #b0111
)) '('j cc
:tab label
))
1877 (:printer near-cond-jump
() '('j cc
:tab label
))
1878 ;; unconditional jumps
1879 (:printer short-jump
((op #b1011
)))
1880 (:printer near-jump
((op #b11101001
)) )
1881 (:printer reg
/mem
((op '(#b1111111
#b100
)) (width 1)))
1886 (lambda (segment posn delta-if-after
)
1887 (let ((disp (- (label-position where posn delta-if-after
)
1889 (when (<= -
128 disp
127)
1891 (dpb (conditional-opcode cond
)
1894 (emit-byte-displacement-backpatch segment where
)
1896 (lambda (segment posn
)
1897 (let ((disp (- (label-position where
) (+ posn
6))))
1898 (emit-byte segment
#b00001111
)
1900 (dpb (conditional-opcode cond
)
1903 (emit-dword segment disp
)))))
1904 ((label-p (setq where cond
))
1907 (lambda (segment posn delta-if-after
)
1908 (let ((disp (- (label-position where posn delta-if-after
)
1910 (when (<= -
128 disp
127)
1911 (emit-byte segment
#b11101011
)
1912 (emit-byte-displacement-backpatch segment where
)
1914 (lambda (segment posn
)
1915 (let ((disp (- (label-position where
) (+ posn
5))))
1916 (emit-byte segment
#b11101001
)
1917 (emit-dword segment disp
)))))
1919 (emit-byte segment
#b11101001
)
1920 (emit-relative-fixup segment where
))
1922 (unless (or (ea-p where
) (tn-p where
))
1923 (error "don't know what to do with ~A" where
))
1924 (emit-byte segment
#b11111111
)
1925 (emit-ea segment where
#b100
)))))
1927 (define-instruction jmp-short
(segment label
)
1929 (emit-byte segment
#b11101011
)
1930 (emit-byte-displacement-backpatch segment label
)))
1932 (define-instruction ret
(segment &optional stack-delta
)
1933 (:printer byte
((op #b11000011
)))
1934 (:printer byte
((op #b11000010
) (imm nil
:type
'imm-word-16
))
1937 (cond ((and stack-delta
(not (zerop stack-delta
)))
1938 (emit-byte segment
#b11000010
)
1939 (emit-word segment stack-delta
))
1941 (emit-byte segment
#b11000011
)))))
1943 (define-instruction jecxz
(segment target
)
1944 (:printer short-jump
((op #b0011
)))
1946 (emit-byte segment
#b11100011
)
1947 (emit-byte-displacement-backpatch segment target
)))
1949 (define-instruction loop
(segment target
)
1950 (:printer short-jump
((op #b0010
)))
1952 (emit-byte segment
#b11100010
) ; pfw this was 11100011, or jecxz!!!!
1953 (emit-byte-displacement-backpatch segment target
)))
1955 (define-instruction loopz
(segment target
)
1956 (:printer short-jump
((op #b0001
)))
1958 (emit-byte segment
#b11100001
)
1959 (emit-byte-displacement-backpatch segment target
)))
1961 (define-instruction loopnz
(segment target
)
1962 (:printer short-jump
((op #b0000
)))
1964 (emit-byte segment
#b11100000
)
1965 (emit-byte-displacement-backpatch segment target
)))
1967 ;;;; conditional move
1968 (define-instruction cmov
(segment cond dst src
)
1969 (:printer cond-move
())
1971 (aver (register-p dst
))
1972 (let ((size (matching-operand-size dst src
)))
1973 (aver (or (eq size
:word
) (eq size
:dword
)))
1974 (maybe-emit-operand-size-prefix segment size
))
1975 (emit-byte segment
#b00001111
)
1976 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b01000000
))
1977 (emit-ea segment src
(reg-tn-encoding dst
))))
1979 ;;;; conditional byte set
1981 (define-instruction set
(segment dst cond
)
1982 (:printer cond-set
())
1984 (emit-byte segment
#b00001111
)
1985 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b10010000
))
1986 (emit-ea segment dst
#b000
)))
1990 (define-instruction enter
(segment disp
&optional
(level 0))
1991 (:declare
(type (unsigned-byte 16) disp
)
1992 (type (unsigned-byte 8) level
))
1993 (:printer enter-format
((op #b11001000
)))
1995 (emit-byte segment
#b11001000
)
1996 (emit-word segment disp
)
1997 (emit-byte segment level
)))
1999 (define-instruction leave
(segment)
2000 (:printer byte
((op #b11001001
)))
2002 (emit-byte segment
#b11001001
)))
2005 (define-instruction prefetchnta
(segment ea
)
2006 (:printer prefetch
((op #b00011000
) (reg #b000
)))
2008 (aver (typep ea
'ea
))
2009 (aver (eq :byte
(ea-size ea
)))
2010 (emit-byte segment
#b00001111
)
2011 (emit-byte segment
#b00011000
)
2012 (emit-ea segment ea
#b000
)))
2014 (define-instruction prefetcht0
(segment ea
)
2015 (:printer prefetch
((op #b00011000
) (reg #b001
)))
2017 (aver (typep ea
'ea
))
2018 (aver (eq :byte
(ea-size ea
)))
2019 (emit-byte segment
#b00001111
)
2020 (emit-byte segment
#b00011000
)
2021 (emit-ea segment ea
#b001
)))
2023 (define-instruction prefetcht1
(segment ea
)
2024 (:printer prefetch
((op #b00011000
) (reg #b010
)))
2026 (aver (typep ea
'ea
))
2027 (aver (eq :byte
(ea-size ea
)))
2028 (emit-byte segment
#b00001111
)
2029 (emit-byte segment
#b00011000
)
2030 (emit-ea segment ea
#b010
)))
2032 (define-instruction prefetcht2
(segment ea
)
2033 (:printer prefetch
((op #b00011000
) (reg #b011
)))
2035 (aver (typep ea
'ea
))
2036 (aver (eq :byte
(ea-size ea
)))
2037 (emit-byte segment
#b00001111
)
2038 (emit-byte segment
#b00011000
)
2039 (emit-ea segment ea
#b011
)))
2041 ;;;; interrupt instructions
2043 (defun snarf-error-junk (sap offset
&optional length-only
)
2044 (let* ((length (sb!sys
:sap-ref-8 sap offset
))
2045 (vector (make-array length
:element-type
'(unsigned-byte 8))))
2046 (declare (type sb
!sys
:system-area-pointer sap
)
2047 (type (unsigned-byte 8) length
)
2048 (type (simple-array (unsigned-byte 8) (*)) vector
))
2050 (values 0 (1+ length
) nil nil
))
2052 (sb!kernel
:copy-ub8-from-system-area sap
(1+ offset
)
2054 (collect ((sc-offsets)
2056 (lengths 1) ; the length byte
2058 (error-number (sb!c
:read-var-integer vector index
)))
2061 (when (>= index length
)
2063 (let ((old-index index
))
2064 (sc-offsets (sb!c
:read-var-integer vector index
))
2065 (lengths (- index old-index
))))
2066 (values error-number
2072 (defmacro break-cases
(breaknum &body cases
)
2073 (let ((bn-temp (gensym)))
2074 (collect ((clauses))
2075 (dolist (case cases
)
2076 (clauses `((= ,bn-temp
,(car case
)) ,@(cdr case
))))
2077 `(let ((,bn-temp
,breaknum
))
2078 (cond ,@(clauses))))))
2081 (defun break-control (chunk inst stream dstate
)
2082 (declare (ignore inst
))
2083 (flet ((nt (x) (if stream
(sb!disassem
:note x dstate
))))
2084 ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
2085 ;; map has it undefined; and it should be easier to look in the target
2086 ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
2087 ;; from first principles whether it's defined in some way that genesis
2089 (case #!-ud2-breakpoints
(byte-imm-code chunk dstate
)
2090 #!+ud2-breakpoints
(word-imm-code chunk dstate
)
2093 (sb!disassem
:handle-break-args
#'snarf-error-junk stream dstate
))
2096 (sb!disassem
:handle-break-args
#'snarf-error-junk stream dstate
))
2098 (nt "breakpoint trap"))
2099 (#.pending-interrupt-trap
2100 (nt "pending interrupt trap"))
2103 (#.fun-end-breakpoint-trap
2104 (nt "function end breakpoint trap")))))
2106 (define-instruction break
(segment code
)
2107 (:declare
(type (unsigned-byte 8) code
))
2108 #!-ud2-breakpoints
(:printer byte-imm
((op #b11001100
))
2109 '(:name
:tab code
) :control
#'break-control
)
2110 #!+ud2-breakpoints
(:printer word-imm
((op #b0000101100001111
))
2111 '(:name
:tab code
) :control
#'break-control
)
2113 #!-ud2-breakpoints
(emit-byte segment
#b11001100
)
2114 ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
2115 ;; throw a sigill with 0x0b0f instead and check for this in the
2116 ;; SIGILL handler and pass it on to the sigtrap handler if
2118 #!+ud2-breakpoints
(emit-word segment
#b0000101100001111
)
2119 (emit-byte segment code
)))
2121 (define-instruction int
(segment number
)
2122 (:declare
(type (unsigned-byte 8) number
))
2123 (:printer byte-imm
((op #b11001101
)))
2127 (emit-byte segment
#b11001100
))
2129 (emit-byte segment
#b11001101
)
2130 (emit-byte segment number
)))))
2132 (define-instruction into
(segment)
2133 (:printer byte
((op #b11001110
)))
2135 (emit-byte segment
#b11001110
)))
2137 (define-instruction bound
(segment reg bounds
)
2139 (let ((size (matching-operand-size reg bounds
)))
2140 (when (eq size
:byte
)
2141 (error "can't bounds-test bytes: ~S" reg
))
2142 (maybe-emit-operand-size-prefix segment size
)
2143 (emit-byte segment
#b01100010
)
2144 (emit-ea segment bounds
(reg-tn-encoding reg
)))))
2146 (define-instruction iret
(segment)
2147 (:printer byte
((op #b11001111
)))
2149 (emit-byte segment
#b11001111
)))
2151 ;;;; processor control
2153 (define-instruction hlt
(segment)
2154 (:printer byte
((op #b11110100
)))
2156 (emit-byte segment
#b11110100
)))
2158 (define-instruction nop
(segment)
2159 (:printer byte
((op #b10010000
)))
2161 (emit-byte segment
#b10010000
)))
2163 (define-instruction wait
(segment)
2164 (:printer byte
((op #b10011011
)))
2166 (emit-byte segment
#b10011011
)))
2168 ;;;; miscellaneous hackery
2170 (define-instruction byte
(segment byte
)
2172 (emit-byte segment byte
)))
2174 (define-instruction word
(segment word
)
2176 (emit-word segment word
)))
2178 (define-instruction dword
(segment dword
)
2180 (emit-dword segment dword
)))
2182 (defun emit-header-data (segment type
)
2183 (emit-back-patch segment
2185 (lambda (segment posn
)
2189 (component-header-length))
2193 (define-instruction simple-fun-header-word
(segment)
2195 (emit-header-data segment simple-fun-header-widetag
)))
2197 (define-instruction lra-header-word
(segment)
2199 (emit-header-data segment return-pc-header-widetag
)))
2201 ;;;; fp instructions
2203 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
2205 ;;;; Note: We treat the single-precision and double-precision variants
2206 ;;;; as separate instructions.
2208 ;;; Load single to st(0).
2209 (define-instruction fld
(segment source
)
2210 (:printer floating-point
((op '(#b001
#b000
))))
2212 (emit-byte segment
#b11011001
)
2213 (emit-fp-op segment source
#b000
)))
2215 ;;; Load double to st(0).
2216 (define-instruction fldd
(segment source
)
2217 (:printer floating-point
((op '(#b101
#b000
))))
2218 (:printer floating-point-fp
((op '(#b001
#b000
))))
2220 (if (fp-reg-tn-p source
)
2221 (emit-byte segment
#b11011001
)
2222 (emit-byte segment
#b11011101
))
2223 (emit-fp-op segment source
#b000
)))
2225 ;;; Load long to st(0).
2226 (define-instruction fldl
(segment source
)
2227 (:printer floating-point
((op '(#b011
#b101
))))
2229 (emit-byte segment
#b11011011
)
2230 (emit-fp-op segment source
#b101
)))
2232 ;;; Store single from st(0).
2233 (define-instruction fst
(segment dest
)
2234 (:printer floating-point
((op '(#b001
#b010
))))
2236 (cond ((fp-reg-tn-p dest
)
2237 (emit-byte segment
#b11011101
)
2238 (emit-fp-op segment dest
#b010
))
2240 (emit-byte segment
#b11011001
)
2241 (emit-fp-op segment dest
#b010
)))))
2243 ;;; Store double from st(0).
2244 (define-instruction fstd
(segment dest
)
2245 (:printer floating-point
((op '(#b101
#b010
))))
2246 (:printer floating-point-fp
((op '(#b101
#b010
))))
2248 (cond ((fp-reg-tn-p dest
)
2249 (emit-byte segment
#b11011101
)
2250 (emit-fp-op segment dest
#b010
))
2252 (emit-byte segment
#b11011101
)
2253 (emit-fp-op segment dest
#b010
)))))
2255 ;;; Arithmetic ops are all done with at least one operand at top of
2256 ;;; stack. The other operand is is another register or a 32/64 bit
2259 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2260 ;;; that these conflict with the Gdb conventions for binops. To reduce
2261 ;;; the confusion I've added comments showing the mathamatical
2262 ;;; operation and the two syntaxes. By the ASM386 convention the
2263 ;;; instruction syntax is:
2266 ;;; or Fop Destination, Source
2268 ;;; If only one operand is given then it is the source and the
2269 ;;; destination is ST(0). There are reversed forms of the fsub and
2270 ;;; fdiv instructions inducated by an 'R' suffix.
2272 ;;; The mathematical operation for the non-reverse form is always:
2273 ;;; destination = destination op source
2275 ;;; For the reversed form it is:
2276 ;;; destination = source op destination
2278 ;;; The instructions below only accept one operand at present which is
2279 ;;; usually the source. I've hack in extra instructions to implement
2280 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2281 ;;; the operand is the destination with the source being ST(0).
2284 ;;; st(0) = st(0) + memory or st(i).
2285 (define-instruction fadd
(segment source
)
2286 (:printer floating-point
((op '(#b000
#b000
))))
2288 (emit-byte segment
#b11011000
)
2289 (emit-fp-op segment source
#b000
)))
2292 ;;; st(0) = st(0) + memory or st(i).
2293 (define-instruction faddd
(segment source
)
2294 (:printer floating-point
((op '(#b100
#b000
))))
2295 (:printer floating-point-fp
((op '(#b000
#b000
))))
2297 (if (fp-reg-tn-p source
)
2298 (emit-byte segment
#b11011000
)
2299 (emit-byte segment
#b11011100
))
2300 (emit-fp-op segment source
#b000
)))
2302 ;;; Add double destination st(i):
2303 ;;; st(i) = st(0) + st(i).
2304 (define-instruction fadd-sti
(segment destination
)
2305 (:printer floating-point-fp
((op '(#b100
#b000
))))
2307 (aver (fp-reg-tn-p destination
))
2308 (emit-byte segment
#b11011100
)
2309 (emit-fp-op segment destination
#b000
)))
2311 (define-instruction faddp-sti
(segment destination
)
2312 (:printer floating-point-fp
((op '(#b110
#b000
))))
2314 (aver (fp-reg-tn-p destination
))
2315 (emit-byte segment
#b11011110
)
2316 (emit-fp-op segment destination
#b000
)))
2318 ;;; Subtract single:
2319 ;;; st(0) = st(0) - memory or st(i).
2320 (define-instruction fsub
(segment source
)
2321 (:printer floating-point
((op '(#b000
#b100
))))
2323 (emit-byte segment
#b11011000
)
2324 (emit-fp-op segment source
#b100
)))
2326 ;;; Subtract single, reverse:
2327 ;;; st(0) = memory or st(i) - st(0).
2328 (define-instruction fsubr
(segment source
)
2329 (:printer floating-point
((op '(#b000
#b101
))))
2331 (emit-byte segment
#b11011000
)
2332 (emit-fp-op segment source
#b101
)))
2334 ;;; Subtract double:
2335 ;;; st(0) = st(0) - memory or st(i).
2336 (define-instruction fsubd
(segment source
)
2337 (:printer floating-point
((op '(#b100
#b100
))))
2338 (:printer floating-point-fp
((op '(#b000
#b100
))))
2340 (if (fp-reg-tn-p source
)
2341 (emit-byte segment
#b11011000
)
2342 (emit-byte segment
#b11011100
))
2343 (emit-fp-op segment source
#b100
)))
2345 ;;; Subtract double, reverse:
2346 ;;; st(0) = memory or st(i) - st(0).
2347 (define-instruction fsubrd
(segment source
)
2348 (:printer floating-point
((op '(#b100
#b101
))))
2349 (:printer floating-point-fp
((op '(#b000
#b101
))))
2351 (if (fp-reg-tn-p source
)
2352 (emit-byte segment
#b11011000
)
2353 (emit-byte segment
#b11011100
))
2354 (emit-fp-op segment source
#b101
)))
2356 ;;; Subtract double, destination st(i):
2357 ;;; st(i) = st(i) - st(0).
2359 ;;; ASM386 syntax: FSUB ST(i), ST
2360 ;;; Gdb syntax: fsubr %st,%st(i)
2361 (define-instruction fsub-sti
(segment destination
)
2362 (:printer floating-point-fp
((op '(#b100
#b101
))))
2364 (aver (fp-reg-tn-p destination
))
2365 (emit-byte segment
#b11011100
)
2366 (emit-fp-op segment destination
#b101
)))
2368 (define-instruction fsubp-sti
(segment destination
)
2369 (:printer floating-point-fp
((op '(#b110
#b101
))))
2371 (aver (fp-reg-tn-p destination
))
2372 (emit-byte segment
#b11011110
)
2373 (emit-fp-op segment destination
#b101
)))
2375 ;;; Subtract double, reverse, destination st(i):
2376 ;;; st(i) = st(0) - st(i).
2378 ;;; ASM386 syntax: FSUBR ST(i), ST
2379 ;;; Gdb syntax: fsub %st,%st(i)
2380 (define-instruction fsubr-sti
(segment destination
)
2381 (:printer floating-point-fp
((op '(#b100
#b100
))))
2383 (aver (fp-reg-tn-p destination
))
2384 (emit-byte segment
#b11011100
)
2385 (emit-fp-op segment destination
#b100
)))
2387 (define-instruction fsubrp-sti
(segment destination
)
2388 (:printer floating-point-fp
((op '(#b110
#b100
))))
2390 (aver (fp-reg-tn-p destination
))
2391 (emit-byte segment
#b11011110
)
2392 (emit-fp-op segment destination
#b100
)))
2394 ;;; Multiply single:
2395 ;;; st(0) = st(0) * memory or st(i).
2396 (define-instruction fmul
(segment source
)
2397 (:printer floating-point
((op '(#b000
#b001
))))
2399 (emit-byte segment
#b11011000
)
2400 (emit-fp-op segment source
#b001
)))
2402 ;;; Multiply double:
2403 ;;; st(0) = st(0) * memory or st(i).
2404 (define-instruction fmuld
(segment source
)
2405 (:printer floating-point
((op '(#b100
#b001
))))
2406 (:printer floating-point-fp
((op '(#b000
#b001
))))
2408 (if (fp-reg-tn-p source
)
2409 (emit-byte segment
#b11011000
)
2410 (emit-byte segment
#b11011100
))
2411 (emit-fp-op segment source
#b001
)))
2413 ;;; Multiply double, destination st(i):
2414 ;;; st(i) = st(i) * st(0).
2415 (define-instruction fmul-sti
(segment destination
)
2416 (:printer floating-point-fp
((op '(#b100
#b001
))))
2418 (aver (fp-reg-tn-p destination
))
2419 (emit-byte segment
#b11011100
)
2420 (emit-fp-op segment destination
#b001
)))
2423 ;;; st(0) = st(0) / memory or st(i).
2424 (define-instruction fdiv
(segment source
)
2425 (:printer floating-point
((op '(#b000
#b110
))))
2427 (emit-byte segment
#b11011000
)
2428 (emit-fp-op segment source
#b110
)))
2430 ;;; Divide single, reverse:
2431 ;;; st(0) = memory or st(i) / st(0).
2432 (define-instruction fdivr
(segment source
)
2433 (:printer floating-point
((op '(#b000
#b111
))))
2435 (emit-byte segment
#b11011000
)
2436 (emit-fp-op segment source
#b111
)))
2439 ;;; st(0) = st(0) / memory or st(i).
2440 (define-instruction fdivd
(segment source
)
2441 (:printer floating-point
((op '(#b100
#b110
))))
2442 (:printer floating-point-fp
((op '(#b000
#b110
))))
2444 (if (fp-reg-tn-p source
)
2445 (emit-byte segment
#b11011000
)
2446 (emit-byte segment
#b11011100
))
2447 (emit-fp-op segment source
#b110
)))
2449 ;;; Divide double, reverse:
2450 ;;; st(0) = memory or st(i) / st(0).
2451 (define-instruction fdivrd
(segment source
)
2452 (:printer floating-point
((op '(#b100
#b111
))))
2453 (:printer floating-point-fp
((op '(#b000
#b111
))))
2455 (if (fp-reg-tn-p source
)
2456 (emit-byte segment
#b11011000
)
2457 (emit-byte segment
#b11011100
))
2458 (emit-fp-op segment source
#b111
)))
2460 ;;; Divide double, destination st(i):
2461 ;;; st(i) = st(i) / st(0).
2463 ;;; ASM386 syntax: FDIV ST(i), ST
2464 ;;; Gdb syntax: fdivr %st,%st(i)
2465 (define-instruction fdiv-sti
(segment destination
)
2466 (:printer floating-point-fp
((op '(#b100
#b111
))))
2468 (aver (fp-reg-tn-p destination
))
2469 (emit-byte segment
#b11011100
)
2470 (emit-fp-op segment destination
#b111
)))
2472 ;;; Divide double, reverse, destination st(i):
2473 ;;; st(i) = st(0) / st(i).
2475 ;;; ASM386 syntax: FDIVR ST(i), ST
2476 ;;; Gdb syntax: fdiv %st,%st(i)
2477 (define-instruction fdivr-sti
(segment destination
)
2478 (:printer floating-point-fp
((op '(#b100
#b110
))))
2480 (aver (fp-reg-tn-p destination
))
2481 (emit-byte segment
#b11011100
)
2482 (emit-fp-op segment destination
#b110
)))
2484 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2485 (define-instruction fxch
(segment source
)
2486 (:printer floating-point-fp
((op '(#b001
#b001
))))
2488 (aver (and (tn-p source
)
2489 (eq (sb-name (sc-sb (tn-sc source
))) 'float-registers
)))
2490 (emit-byte segment
#b11011001
)
2491 (emit-fp-op segment source
#b001
)))
2493 ;;; Push 32-bit integer to st0.
2494 (define-instruction fild
(segment source
)
2495 (:printer floating-point
((op '(#b011
#b000
))))
2497 (emit-byte segment
#b11011011
)
2498 (emit-fp-op segment source
#b000
)))
2500 ;;; Push 64-bit integer to st0.
2501 (define-instruction fildl
(segment source
)
2502 (:printer floating-point
((op '(#b111
#b101
))))
2504 (emit-byte segment
#b11011111
)
2505 (emit-fp-op segment source
#b101
)))
2507 ;;; Store 32-bit integer.
2508 (define-instruction fist
(segment dest
)
2509 (:printer floating-point
((op '(#b011
#b010
))))
2511 (emit-byte segment
#b11011011
)
2512 (emit-fp-op segment dest
#b010
)))
2514 ;;; Store and pop 32-bit integer.
2515 (define-instruction fistp
(segment dest
)
2516 (:printer floating-point
((op '(#b011
#b011
))))
2518 (emit-byte segment
#b11011011
)
2519 (emit-fp-op segment dest
#b011
)))
2521 ;;; Store and pop 64-bit integer.
2522 (define-instruction fistpl
(segment dest
)
2523 (:printer floating-point
((op '(#b111
#b111
))))
2525 (emit-byte segment
#b11011111
)
2526 (emit-fp-op segment dest
#b111
)))
2528 ;;; Store single from st(0) and pop.
2529 (define-instruction fstp
(segment dest
)
2530 (:printer floating-point
((op '(#b001
#b011
))))
2532 (cond ((fp-reg-tn-p dest
)
2533 (emit-byte segment
#b11011101
)
2534 (emit-fp-op segment dest
#b011
))
2536 (emit-byte segment
#b11011001
)
2537 (emit-fp-op segment dest
#b011
)))))
2539 ;;; Store double from st(0) and pop.
2540 (define-instruction fstpd
(segment dest
)
2541 (:printer floating-point
((op '(#b101
#b011
))))
2542 (:printer floating-point-fp
((op '(#b101
#b011
))))
2544 (cond ((fp-reg-tn-p dest
)
2545 (emit-byte segment
#b11011101
)
2546 (emit-fp-op segment dest
#b011
))
2548 (emit-byte segment
#b11011101
)
2549 (emit-fp-op segment dest
#b011
)))))
2551 ;;; Store long from st(0) and pop.
2552 (define-instruction fstpl
(segment dest
)
2553 (:printer floating-point
((op '(#b011
#b111
))))
2555 (emit-byte segment
#b11011011
)
2556 (emit-fp-op segment dest
#b111
)))
2558 ;;; Decrement stack-top pointer.
2559 (define-instruction fdecstp
(segment)
2560 (:printer floating-point-no
((op #b10110
)))
2562 (emit-byte segment
#b11011001
)
2563 (emit-byte segment
#b11110110
)))
2565 ;;; Increment stack-top pointer.
2566 (define-instruction fincstp
(segment)
2567 (:printer floating-point-no
((op #b10111
)))
2569 (emit-byte segment
#b11011001
)
2570 (emit-byte segment
#b11110111
)))
2572 ;;; Free fp register.
2573 (define-instruction ffree
(segment dest
)
2574 (:printer floating-point-fp
((op '(#b101
#b000
))))
2576 (emit-byte segment
#b11011101
)
2577 (emit-fp-op segment dest
#b000
)))
2579 (define-instruction fabs
(segment)
2580 (:printer floating-point-no
((op #b00001
)))
2582 (emit-byte segment
#b11011001
)
2583 (emit-byte segment
#b11100001
)))
2585 (define-instruction fchs
(segment)
2586 (:printer floating-point-no
((op #b00000
)))
2588 (emit-byte segment
#b11011001
)
2589 (emit-byte segment
#b11100000
)))
2591 (define-instruction frndint
(segment)
2592 (:printer floating-point-no
((op #b11100
)))
2594 (emit-byte segment
#b11011001
)
2595 (emit-byte segment
#b11111100
)))
2598 (define-instruction fninit
(segment)
2599 (:printer floating-point-5
((op #b00011
)))
2601 (emit-byte segment
#b11011011
)
2602 (emit-byte segment
#b11100011
)))
2604 ;;; Store Status Word to AX.
2605 (define-instruction fnstsw
(segment)
2606 (:printer floating-point-st
((op #b00000
)))
2608 (emit-byte segment
#b11011111
)
2609 (emit-byte segment
#b11100000
)))
2611 ;;; Load Control Word.
2613 ;;; src must be a memory location
2614 (define-instruction fldcw
(segment src
)
2615 (:printer floating-point
((op '(#b001
#b101
))))
2617 (emit-byte segment
#b11011001
)
2618 (emit-fp-op segment src
#b101
)))
2620 ;;; Store Control Word.
2621 (define-instruction fnstcw
(segment dst
)
2622 (:printer floating-point
((op '(#b001
#b111
))))
2624 (emit-byte segment
#b11011001
)
2625 (emit-fp-op segment dst
#b111
)))
2627 ;;; Store FP Environment.
2628 (define-instruction fstenv
(segment dst
)
2629 (:printer floating-point
((op '(#b001
#b110
))))
2631 (emit-byte segment
#b11011001
)
2632 (emit-fp-op segment dst
#b110
)))
2634 ;;; Restore FP Environment.
2635 (define-instruction fldenv
(segment src
)
2636 (:printer floating-point
((op '(#b001
#b100
))))
2638 (emit-byte segment
#b11011001
)
2639 (emit-fp-op segment src
#b100
)))
2642 (define-instruction fsave
(segment dst
)
2643 (:printer floating-point
((op '(#b101
#b110
))))
2645 (emit-byte segment
#b11011101
)
2646 (emit-fp-op segment dst
#b110
)))
2648 ;;; Restore FP State.
2649 (define-instruction frstor
(segment src
)
2650 (:printer floating-point
((op '(#b101
#b100
))))
2652 (emit-byte segment
#b11011101
)
2653 (emit-fp-op segment src
#b100
)))
2655 ;;; Clear exceptions.
2656 (define-instruction fnclex
(segment)
2657 (:printer floating-point-5
((op #b00010
)))
2659 (emit-byte segment
#b11011011
)
2660 (emit-byte segment
#b11100010
)))
2663 (define-instruction fcom
(segment src
)
2664 (:printer floating-point
((op '(#b000
#b010
))))
2666 (emit-byte segment
#b11011000
)
2667 (emit-fp-op segment src
#b010
)))
2669 (define-instruction fcomd
(segment src
)
2670 (:printer floating-point
((op '(#b100
#b010
))))
2671 (:printer floating-point-fp
((op '(#b000
#b010
))))
2673 (if (fp-reg-tn-p src
)
2674 (emit-byte segment
#b11011000
)
2675 (emit-byte segment
#b11011100
))
2676 (emit-fp-op segment src
#b010
)))
2678 ;;; Compare ST1 to ST0, popping the stack twice.
2679 (define-instruction fcompp
(segment)
2680 (:printer floating-point-3
((op '(#b110
#b011001
))))
2682 (emit-byte segment
#b11011110
)
2683 (emit-byte segment
#b11011001
)))
2685 ;;; unordered comparison
2686 (define-instruction fucom
(segment src
)
2687 (:printer floating-point-fp
((op '(#b101
#b100
))))
2689 (aver (fp-reg-tn-p src
))
2690 (emit-byte segment
#b11011101
)
2691 (emit-fp-op segment src
#b100
)))
2693 (define-instruction ftst
(segment)
2694 (:printer floating-point-no
((op #b00100
)))
2696 (emit-byte segment
#b11011001
)
2697 (emit-byte segment
#b11100100
)))
2701 (define-instruction fsqrt
(segment)
2702 (:printer floating-point-no
((op #b11010
)))
2704 (emit-byte segment
#b11011001
)
2705 (emit-byte segment
#b11111010
)))
2707 (define-instruction fscale
(segment)
2708 (:printer floating-point-no
((op #b11101
)))
2710 (emit-byte segment
#b11011001
)
2711 (emit-byte segment
#b11111101
)))
2713 (define-instruction fxtract
(segment)
2714 (:printer floating-point-no
((op #b10100
)))
2716 (emit-byte segment
#b11011001
)
2717 (emit-byte segment
#b11110100
)))
2719 (define-instruction fsin
(segment)
2720 (:printer floating-point-no
((op #b11110
)))
2722 (emit-byte segment
#b11011001
)
2723 (emit-byte segment
#b11111110
)))
2725 (define-instruction fcos
(segment)
2726 (:printer floating-point-no
((op #b11111
)))
2728 (emit-byte segment
#b11011001
)
2729 (emit-byte segment
#b11111111
)))
2731 (define-instruction fprem1
(segment)
2732 (:printer floating-point-no
((op #b10101
)))
2734 (emit-byte segment
#b11011001
)
2735 (emit-byte segment
#b11110101
)))
2737 (define-instruction fprem
(segment)
2738 (:printer floating-point-no
((op #b11000
)))
2740 (emit-byte segment
#b11011001
)
2741 (emit-byte segment
#b11111000
)))
2743 (define-instruction fxam
(segment)
2744 (:printer floating-point-no
((op #b00101
)))
2746 (emit-byte segment
#b11011001
)
2747 (emit-byte segment
#b11100101
)))
2749 ;;; These do push/pop to stack and need special handling
2750 ;;; in any VOPs that use them. See the book.
2752 ;;; st0 <- st1*log2(st0)
2753 (define-instruction fyl2x
(segment) ; pops stack
2754 (:printer floating-point-no
((op #b10001
)))
2756 (emit-byte segment
#b11011001
)
2757 (emit-byte segment
#b11110001
)))
2759 (define-instruction fyl2xp1
(segment)
2760 (:printer floating-point-no
((op #b11001
)))
2762 (emit-byte segment
#b11011001
)
2763 (emit-byte segment
#b11111001
)))
2765 (define-instruction f2xm1
(segment)
2766 (:printer floating-point-no
((op #b10000
)))
2768 (emit-byte segment
#b11011001
)
2769 (emit-byte segment
#b11110000
)))
2771 (define-instruction fptan
(segment) ; st(0) <- 1; st(1) <- tan
2772 (:printer floating-point-no
((op #b10010
)))
2774 (emit-byte segment
#b11011001
)
2775 (emit-byte segment
#b11110010
)))
2777 (define-instruction fpatan
(segment) ; POPS STACK
2778 (:printer floating-point-no
((op #b10011
)))
2780 (emit-byte segment
#b11011001
)
2781 (emit-byte segment
#b11110011
)))
2783 ;;;; loading constants
2785 (define-instruction fldz
(segment)
2786 (:printer floating-point-no
((op #b01110
)))
2788 (emit-byte segment
#b11011001
)
2789 (emit-byte segment
#b11101110
)))
2791 (define-instruction fld1
(segment)
2792 (:printer floating-point-no
((op #b01000
)))
2794 (emit-byte segment
#b11011001
)
2795 (emit-byte segment
#b11101000
)))
2797 (define-instruction fldpi
(segment)
2798 (:printer floating-point-no
((op #b01011
)))
2800 (emit-byte segment
#b11011001
)
2801 (emit-byte segment
#b11101011
)))
2803 (define-instruction fldl2t
(segment)
2804 (:printer floating-point-no
((op #b01001
)))
2806 (emit-byte segment
#b11011001
)
2807 (emit-byte segment
#b11101001
)))
2809 (define-instruction fldl2e
(segment)
2810 (:printer floating-point-no
((op #b01010
)))
2812 (emit-byte segment
#b11011001
)
2813 (emit-byte segment
#b11101010
)))
2815 (define-instruction fldlg2
(segment)
2816 (:printer floating-point-no
((op #b01100
)))
2818 (emit-byte segment
#b11011001
)
2819 (emit-byte segment
#b11101100
)))
2821 (define-instruction fldln2
(segment)
2822 (:printer floating-point-no
((op #b01101
)))
2824 (emit-byte segment
#b11011001
)
2825 (emit-byte segment
#b11101101
)))
2829 (define-instruction cpuid
(segment)
2830 (:printer two-bytes
((op '(#b00001111
#b10100010
))))
2832 (emit-byte segment
#b00001111
)
2833 (emit-byte segment
#b10100010
)))
2835 (define-instruction rdtsc
(segment)
2836 (:printer two-bytes
((op '(#b00001111
#b00110001
))))
2838 (emit-byte segment
#b00001111
)
2839 (emit-byte segment
#b00110001
)))
2841 ;;;; Late VM definitions
2842 (defun canonicalize-inline-constant (constant)
2843 (let ((first (car constant
)))
2845 (single-float (setf constant
(list :single-float first
)))
2846 (double-float (setf constant
(list :double-float first
)))))
2847 (destructuring-bind (type value
) constant
2849 ((:byte
:word
:dword
)
2850 (aver (integerp value
))
2853 #!+sb-unicode
(aver (base-char-p value
))
2854 (cons :byte
(char-code value
)))
2856 (aver (characterp value
))
2857 (cons :dword
(char-code value
)))
2859 (aver (typep value
'single-float
))
2860 (cons :dword
(ldb (byte 32 0) (single-float-bits value
))))
2861 ((:double-float-bits
)
2862 (aver (integerp value
))
2863 (cons :double-float
(ldb (byte 64 0) value
)))
2865 (aver (typep value
'double-float
))
2867 (ldb (byte 64 0) (logior (ash (double-float-high-bits value
) 32)
2868 (double-float-low-bits value
))))))))
2870 (defun inline-constant-value (constant)
2871 (let ((label (gen-label))
2872 (size (ecase (car constant
)
2873 ((:byte
:word
:dword
) (car constant
))
2874 (:double-float
:dword
))))
2875 (values label
(make-ea size
2876 :disp
(make-fixup nil
:code-object label
)))))
2878 (defun emit-constant-segment-header (segment constants optimize
)
2879 (declare (ignore segment constants
))
2880 (loop repeat
(if optimize
64 16) do
(inst byte
#x90
)))
2882 (defun size-nbyte (size)
2889 (defun sort-inline-constants (constants)
2890 (stable-sort constants
#'> :key
(lambda (constant)
2891 (size-nbyte (caar constant
)))))
2893 (defun emit-inline-constant (constant label
)
2894 (let ((size (size-nbyte (car constant
))))
2895 (emit-alignment (integer-length (1- size
)))
2897 (let ((val (cdr constant
)))
2899 do
(inst byte
(ldb (byte 8 0) val
))
2900 (setf val
(ash val -
8))))))