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 (defun offset-next (value dstate
)
34 (declare (type integer value
)
35 (type disassem-state dstate
))
36 (+ (dstate-next-addr dstate
) value
))
38 (defparameter *default-address-size
*
39 ;; Actually, :DWORD is the only one really supported.
42 (defparameter *byte-reg-names
*
43 #(al cl dl bl ah ch dh bh
))
44 (defparameter *word-reg-names
*
45 #(ax cx dx bx sp bp si di
))
46 (defparameter *dword-reg-names
*
47 #(eax ecx edx ebx esp ebp esi edi
))
49 ;;; Disassembling x86 code needs to take into account little things
50 ;;; like instructions that have a byte/word length bit in their
51 ;;; encoding, prefixes to change the default word length for a single
52 ;;; instruction, and so on. Unfortunately, there is no easy way with
53 ;;; this disassembler framework to handle prefixes that will work
54 ;;; correctly in all cases, so we copy the x86-64 version which at
55 ;;; least can handle the code output by the compiler.
57 ;;; Width information for an instruction and whether a segment
58 ;;; override prefix was seen is stored as an inst-prop on the dstate.
59 ;;; The inst-props are cleared automatically after each non-prefix
60 ;;; instruction, must be set by prefilters, and contain a single bit of
61 ;;; data each (presence/absence).
63 ;;; Return the operand size based on the prefixes and width bit from
65 (defun inst-operand-size (dstate)
66 (declare (type disassem-state dstate
))
67 (cond ((dstate-get-inst-prop dstate
'operand-size-8
) :byte
)
68 ((dstate-get-inst-prop dstate
'operand-size-16
) :word
)
69 (t +default-operand-size
+)))
71 ;;; Return the operand size for a "word-sized" operand based on the
72 ;;; prefixes from the dstate.
73 (defun inst-word-operand-size (dstate)
74 (declare (type disassem-state dstate
))
75 (if (dstate-get-inst-prop dstate
'operand-size-16
) :word
:dword
))
77 ;;; Returns either an integer, meaning a register, or a list of
78 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
79 ;;; may be missing or nil to indicate that it's not used or has the
80 ;;; obvious default value (e.g., 1 for the index-scale).
81 (defun prefilter-reg/mem
(value dstate
)
82 (declare (type list value
)
83 (type disassem-state dstate
))
84 (let ((mod (car value
))
86 (declare (type (unsigned-byte 2) mod
)
87 (type (unsigned-byte 3) r
/m
))
93 (let ((sib (read-suffix 8 dstate
)))
94 (declare (type (unsigned-byte 8) sib
))
95 (let ((base-reg (ldb (byte 3 0) sib
))
96 (index-reg (ldb (byte 3 3) sib
))
97 (index-scale (ldb (byte 2 6) sib
)))
98 (declare (type (unsigned-byte 3) base-reg index-reg
)
99 (type (unsigned-byte 2) index-scale
))
103 (if (= base-reg
#b101
)
104 (read-signed-suffix 32 dstate
)
107 (read-signed-suffix 8 dstate
))
109 (read-signed-suffix 32 dstate
)))))
110 (list (if (and (= mod
#b00
) (= base-reg
#b101
)) nil base-reg
)
112 (if (= index-reg
#b100
) nil index-reg
)
113 (ash 1 index-scale
))))))
114 ((and (= mod
#b00
) (= r
/m
#b101
))
115 (list nil
(read-signed-suffix 32 dstate
)) )
119 (list r
/m
(read-signed-suffix 8 dstate
)))
121 (list r
/m
(read-signed-suffix 32 dstate
))))))
124 ;;; This is a sort of bogus prefilter that just stores the info globally for
125 ;;; other people to use; it probably never gets printed.
126 (defun prefilter-width (value dstate
)
127 (declare (type bit value
)
128 (type disassem-state dstate
))
130 (dstate-put-inst-prop dstate
'operand-size-8
))
133 ;;; This prefilter is used solely for its side effect, namely to put
134 ;;; the property OPERAND-SIZE-16 into the DSTATE.
135 (defun prefilter-x66 (value dstate
)
136 (declare (type (eql #x66
) value
)
138 (type disassem-state dstate
))
139 (dstate-put-inst-prop dstate
'operand-size-16
))
141 ;;; This prefilter is used solely for its side effect, namely to put
142 ;;; one of the properties [FG]S-SEGMENT-PREFIX into the DSTATE.
143 ;;; Unlike PREFILTER-X66, this prefilter only catches the low bit of
145 (defun prefilter-seg (value dstate
)
146 (declare (type bit value
)
147 (type disassem-state dstate
))
148 (dstate-put-inst-prop
149 dstate
(elt '(fs-segment-prefix gs-segment-prefix
) value
)))
151 (defun read-address (value dstate
)
152 (declare (ignore value
)) ; always nil anyway
153 (read-suffix (width-bits *default-address-size
*) dstate
))
155 (defun width-bits (width)
163 ;;;; disassembler argument types
165 (define-arg-type displacement
167 :use-label
#'offset-next
168 :printer
(lambda (value stream dstate
)
169 (maybe-note-assembler-routine value nil dstate
)
170 (print-label value stream dstate
)))
172 (define-arg-type accum
173 :printer
(lambda (value stream dstate
)
174 (declare (ignore value
)
176 (type disassem-state dstate
))
177 (print-reg 0 stream dstate
)))
179 (define-arg-type word-accum
180 :printer
(lambda (value stream dstate
)
181 (declare (ignore value
)
183 (type disassem-state dstate
))
184 (print-word-reg 0 stream dstate
)))
186 (define-arg-type reg
:printer
#'print-reg
)
188 (define-arg-type addr-reg
:printer
#'print-addr-reg
)
190 (define-arg-type word-reg
:printer
#'print-word-reg
)
192 (define-arg-type imm-addr
193 :prefilter
#'read-address
194 :printer
#'print-label
)
196 (define-arg-type imm-data
197 :prefilter
(lambda (value dstate
)
198 (declare (ignore value
)) ; always nil anyway
199 (read-suffix (width-bits (inst-operand-size dstate
)) dstate
)))
201 (define-arg-type signed-imm-data
202 :prefilter
(lambda (value dstate
)
203 (declare (ignore value
)) ; always nil anyway
204 (let ((width (inst-operand-size dstate
)))
205 (read-signed-suffix (width-bits width
) dstate
))))
207 (define-arg-type imm-byte
208 :prefilter
(lambda (value dstate
)
209 (declare (ignore value
)) ; always nil anyway
210 (read-suffix 8 dstate
)))
212 (define-arg-type signed-imm-byte
213 :prefilter
(lambda (value dstate
)
214 (declare (ignore value
)) ; always nil anyway
215 (read-signed-suffix 8 dstate
)))
217 (define-arg-type signed-imm-dword
218 :prefilter
(lambda (value dstate
)
219 (declare (ignore value
)) ; always nil anyway
220 (read-signed-suffix 32 dstate
)))
222 (define-arg-type imm-word
223 :prefilter
(lambda (value dstate
)
224 (declare (ignore value
)) ; always nil anyway
225 (let ((width (inst-word-operand-size dstate
)))
226 (read-suffix (width-bits width
) dstate
))))
228 (define-arg-type signed-imm-word
229 :prefilter
(lambda (value dstate
)
230 (declare (ignore value
)) ; always nil anyway
231 (let ((width (inst-word-operand-size dstate
)))
232 (read-signed-suffix (width-bits width
) dstate
))))
234 ;;; needed for the ret imm16 instruction
235 (define-arg-type imm-word-16
236 :prefilter
(lambda (value dstate
)
237 (declare (ignore value
)) ; always nil anyway
238 (read-suffix 16 dstate
)))
240 (define-arg-type reg
/mem
241 :prefilter
#'prefilter-reg
/mem
242 :printer
#'print-reg
/mem
)
243 (define-arg-type sized-reg
/mem
244 ;; Same as reg/mem, but prints an explicit size indicator for
245 ;; memory references.
246 :prefilter
#'prefilter-reg
/mem
247 :printer
#'print-sized-reg
/mem
)
248 (define-arg-type byte-reg
/mem
249 :prefilter
#'prefilter-reg
/mem
250 :printer
#'print-byte-reg
/mem
)
251 (define-arg-type word-reg
/mem
252 :prefilter
#'prefilter-reg
/mem
253 :printer
#'print-word-reg
/mem
)
256 (defun print-fp-reg (value stream dstate
)
257 (declare (ignore dstate
))
258 (format stream
"FR~D" value
))
259 (defun prefilter-fp-reg (value dstate
)
261 (declare (ignore dstate
))
264 (define-arg-type fp-reg
:prefilter
#'prefilter-fp-reg
265 :printer
#'print-fp-reg
)
267 (define-arg-type width
268 :prefilter
#'prefilter-width
269 :printer
(lambda (value stream dstate
)
270 (declare (ignore value
))
271 (princ (schar (symbol-name (inst-operand-size dstate
)) 0)
274 ;;; Used to capture the effect of the #x66 operand size override prefix.
275 (define-arg-type x66
:prefilter
#'prefilter-x66
)
277 ;;; Used to capture the effect of the #x64 and #x65 segment override
279 (define-arg-type seg
:prefilter
#'prefilter-seg
)
281 (defparameter *conditions
*
284 (:b .
2) (:nae .
2) (:c .
2)
285 (:nb .
3) (:ae .
3) (:nc .
3)
286 (:eq .
4) (:e .
4) (:z .
4)
293 (:np .
11) (:po .
11)
294 (:l .
12) (:nge .
12)
295 (:nl .
13) (:ge .
13)
296 (:le .
14) (:ng .
14)
297 (:nle .
15) (:g .
15)))
298 (defparameter *condition-name-vec
*
299 (let ((vec (make-array 16 :initial-element nil
)))
300 (dolist (cond *conditions
*)
301 (when (null (aref vec
(cdr cond
)))
302 (setf (aref vec
(cdr cond
)) (car cond
))))
305 ;;; Set assembler parameters. (In CMU CL, this was done with
306 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
307 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
308 (setf sb
!assem
:*assem-scheduler-p
* nil
))
310 (define-arg-type condition-code
:printer
*condition-name-vec
*)
312 (defun conditional-opcode (condition)
313 (cdr (assoc condition
*conditions
* :test
#'eq
)))
315 ;;;; disassembler instruction formats
317 (defun swap-if (direction field1 separator field2
)
318 `(:if
(,direction
:constant
0)
319 (,field1
,separator
,field2
)
320 (,field2
,separator
,field1
)))
322 (define-instruction-format (byte 8 :default-printer
'(:name
))
323 (op :field
(byte 8 0))
328 ;;; Prefix instructions
330 (define-instruction-format (x66 8)
331 (x66 :field
(byte 8 0) :type
'x66
:value
#x66
))
333 (define-instruction-format (seg 8)
334 (seg :field
(byte 7 1) :value
#x32
)
335 (fsgs :field
(byte 1 0) :type
'seg
))
337 (define-instruction-format (simple 8)
338 (op :field
(byte 7 1))
339 (width :field
(byte 1 0) :type
'width
)
344 (define-instruction-format (two-bytes 16 :default-printer
'(:name
))
345 (op :fields
(list (byte 8 0) (byte 8 8))))
347 ;;; Same as simple, but with direction bit
348 (define-instruction-format (simple-dir 8 :include simple
)
349 (op :field
(byte 6 2))
350 (dir :field
(byte 1 1)))
352 ;;; Same as simple, but with the immediate value occurring by default,
353 ;;; and with an appropiate printer.
354 (define-instruction-format (accum-imm 8
356 :default-printer
'(:name
357 :tab accum
", " imm
))
358 (imm :type
'imm-data
))
360 (define-instruction-format (reg-no-width 8 :default-printer
'(:name
:tab reg
))
361 (op :field
(byte 5 3))
362 (reg :field
(byte 3 0) :type
'word-reg
)
364 (accum :type
'word-accum
)
367 ;;; adds a width field to reg-no-width
368 (define-instruction-format (reg 8 :default-printer
'(:name
:tab reg
))
369 (op :field
(byte 4 4))
370 (width :field
(byte 1 3) :type
'width
)
371 (reg :field
(byte 3 0) :type
'reg
)
377 ;;; Same as reg, but with direction bit
378 (define-instruction-format (reg-dir 8 :include reg
)
379 (op :field
(byte 3 5))
380 (dir :field
(byte 1 4)))
382 (define-instruction-format (reg-reg/mem
16
384 `(:name
:tab reg
", " reg
/mem
))
385 (op :field
(byte 7 1))
386 (width :field
(byte 1 0) :type
'width
)
387 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
389 (reg :field
(byte 3 11) :type
'reg
)
393 ;;; same as reg-reg/mem, but with direction bit
394 (define-instruction-format (reg-reg/mem-dir
16
399 ,(swap-if 'dir
'reg
/mem
", " 'reg
)))
400 (op :field
(byte 6 2))
401 (dir :field
(byte 1 1)))
403 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
404 (define-instruction-format (reg/mem
16 :default-printer
'(:name
:tab reg
/mem
))
405 (op :fields
(list (byte 7 1) (byte 3 11)))
406 (width :field
(byte 1 0) :type
'width
)
407 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
408 :type
'sized-reg
/mem
)
412 ;;; Same as reg/mem, but with the immediate value occurring by default,
413 ;;; and with an appropiate printer.
414 (define-instruction-format (reg/mem-imm
16
417 '(:name
:tab reg
/mem
", " imm
))
418 (reg/mem
:type
'sized-reg
/mem
)
419 (imm :type
'imm-data
))
421 ;;; Same as reg/mem, but with using the accumulator in the default printer
422 (define-instruction-format
424 :include reg
/mem
:default-printer
'(:name
:tab accum
", " reg
/mem
))
425 (reg/mem
:type
'reg
/mem
) ; don't need a size
426 (accum :type
'accum
))
428 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
429 (define-instruction-format (ext-reg-reg/mem
24
431 `(:name
:tab reg
", " reg
/mem
))
432 (prefix :field
(byte 8 0) :value
#b00001111
)
433 (op :field
(byte 7 9))
434 (width :field
(byte 1 8) :type
'width
)
435 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
437 (reg :field
(byte 3 19) :type
'reg
)
441 (define-instruction-format (ext-reg-reg/mem-no-width
24
443 `(:name
:tab reg
", " reg
/mem
))
444 (prefix :field
(byte 8 0) :value
#b00001111
)
445 (op :field
(byte 8 8))
446 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
448 (reg :field
(byte 3 19) :type
'reg
)
452 (define-instruction-format (ext-reg/mem-no-width
24
454 `(:name
:tab reg
/mem
))
455 (prefix :field
(byte 8 0) :value
#b00001111
)
456 (op :fields
(list (byte 8 8) (byte 3 19)))
457 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
460 ;;; reg-no-width with #x0f prefix
461 (define-instruction-format (ext-reg-no-width 16
462 :default-printer
'(:name
:tab reg
))
463 (prefix :field
(byte 8 0) :value
#b00001111
)
464 (op :field
(byte 5 11))
465 (reg :field
(byte 3 8) :type
'reg
))
467 ;;; Same as reg/mem, but with a prefix of #b00001111
468 (define-instruction-format (ext-reg/mem
24
469 :default-printer
'(:name
:tab reg
/mem
))
470 (prefix :field
(byte 8 0) :value
#b00001111
)
471 (op :fields
(list (byte 7 9) (byte 3 19)))
472 (width :field
(byte 1 8) :type
'width
)
473 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
474 :type
'sized-reg
/mem
)
478 (define-instruction-format (ext-reg/mem-imm
24
481 '(:name
:tab reg
/mem
", " imm
))
482 (imm :type
'imm-data
))
484 (define-instruction-format (ext-reg/mem-no-width
+imm8
24
485 :include ext-reg
/mem-no-width
487 '(:name
:tab reg
/mem
", " imm
))
488 (imm :type
'imm-byte
))
490 ;;;; This section was added by jrd, for fp instructions.
492 ;;; regular fp inst to/from registers/memory
493 (define-instruction-format (floating-point 16
495 `(:name
:tab reg
/mem
))
496 (prefix :field
(byte 5 3) :value
#b11011
)
497 (op :fields
(list (byte 3 0) (byte 3 11)))
498 (reg/mem
:fields
(list (byte 2 14) (byte 3 8)) :type
'reg
/mem
))
500 ;;; fp insn to/from fp reg
501 (define-instruction-format (floating-point-fp 16
502 :default-printer
`(:name
:tab fp-reg
))
503 (prefix :field
(byte 5 3) :value
#b11011
)
504 (suffix :field
(byte 2 14) :value
#b11
)
505 (op :fields
(list (byte 3 0) (byte 3 11)))
506 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
508 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
509 (define-instruction-format (floating-point-fp-d 16
511 `(:name
:tab
,(swap-if 'd
"ST0" ", " 'fp-reg
)))
512 (prefix :field
(byte 5 3) :value
#b11011
)
513 (suffix :field
(byte 2 14) :value
#b11
)
514 (op :fields
(list (byte 2 0) (byte 3 11)))
515 (d :field
(byte 1 2))
516 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
519 ;;; (added by (?) pfw)
520 ;;; fp no operand isns
521 (define-instruction-format (floating-point-no 16 :default-printer
'(:name
))
522 (prefix :field
(byte 8 0) :value
#b11011001
)
523 (suffix :field
(byte 3 13) :value
#b111
)
524 (op :field
(byte 5 8)))
526 (define-instruction-format (floating-point-3 16 :default-printer
'(:name
))
527 (prefix :field
(byte 5 3) :value
#b11011
)
528 (suffix :field
(byte 2 14) :value
#b11
)
529 (op :fields
(list (byte 3 0) (byte 6 8))))
531 (define-instruction-format (floating-point-5 16 :default-printer
'(:name
))
532 (prefix :field
(byte 8 0) :value
#b11011011
)
533 (suffix :field
(byte 3 13) :value
#b111
)
534 (op :field
(byte 5 8)))
536 (define-instruction-format (floating-point-st 16 :default-printer
'(:name
))
537 (prefix :field
(byte 8 0) :value
#b11011111
)
538 (suffix :field
(byte 3 13) :value
#b111
)
539 (op :field
(byte 5 8)))
541 (define-instruction-format (string-op 8
543 :default-printer
'(:name width
)))
545 (define-instruction-format (short-cond-jump 16)
546 (op :field
(byte 4 4))
547 (cc :field
(byte 4 0) :type
'condition-code
)
548 (label :field
(byte 8 8) :type
'displacement
))
550 (define-instruction-format (short-jump 16 :default-printer
'(:name
:tab label
))
551 (const :field
(byte 4 4) :value
#b1110
)
552 (op :field
(byte 4 0))
553 (label :field
(byte 8 8) :type
'displacement
))
555 (define-instruction-format (near-cond-jump 16)
556 (op :fields
(list (byte 8 0) (byte 4 12)) :value
'(#b00001111
#b1000
))
557 (cc :field
(byte 4 8) :type
'condition-code
)
558 ;; The disassembler currently doesn't let you have an instruction > 32 bits
559 ;; long, so we fake it by using a prefilter to read the offset.
560 (label :type
'displacement
561 :prefilter
(lambda (value dstate
)
562 (declare (ignore value
)) ; always nil anyway
563 (read-signed-suffix 32 dstate
))))
565 (define-instruction-format (near-jump 8 :default-printer
'(:name
:tab label
))
566 (op :field
(byte 8 0))
567 ;; The disassembler currently doesn't let you have an instruction > 32 bits
568 ;; long, so we fake it by using a prefilter to read the address.
569 (label :type
'displacement
570 :prefilter
(lambda (value dstate
)
571 (declare (ignore value
)) ; always nil anyway
572 (read-signed-suffix 32 dstate
))))
575 (define-instruction-format (cond-set 24
576 :default-printer
'('set cc
:tab reg
/mem
))
577 (prefix :field
(byte 8 0) :value
#b00001111
)
578 (op :field
(byte 4 12) :value
#b1001
)
579 (cc :field
(byte 4 8) :type
'condition-code
)
580 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
582 (reg :field
(byte 3 19) :value
#b000
))
584 (define-instruction-format (cond-move 24
586 '('cmov cc
:tab reg
", " reg
/mem
))
587 (prefix :field
(byte 8 0) :value
#b00001111
)
588 (op :field
(byte 4 12) :value
#b0100
)
589 (cc :field
(byte 4 8) :type
'condition-code
)
590 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
592 (reg :field
(byte 3 19) :type
'reg
))
594 (define-instruction-format (enter-format 32
595 :default-printer
'(:name
597 (:unless
(:constant
0)
599 (op :field
(byte 8 0))
600 (disp :field
(byte 16 8))
601 (level :field
(byte 8 24)))
603 (define-instruction-format (prefetch 24 :default-printer
'(:name
", " reg
/mem
))
604 (prefix :field
(byte 8 0) :value
#b00001111
)
605 (op :field
(byte 8 8) :value
#b00011000
)
606 (reg/mem
:fields
(list (byte 2 22) (byte 3 16)) :type
'byte-reg
/mem
)
607 (reg :field
(byte 3 19) :type
'reg
))
609 ;;; Single byte instruction with an immediate byte argument.
610 (define-instruction-format (byte-imm 16 :default-printer
'(:name
:tab code
))
611 (op :field
(byte 8 0))
612 (code :field
(byte 8 8) :reader byte-imm-code
))
614 ;;; Two byte instruction with an immediate byte argument.
616 (define-instruction-format (word-imm 24 :default-printer
'(:name
:tab code
))
617 (op :field
(byte 16 0))
618 (code :field
(byte 8 16) :reader word-imm-code
))
621 ;;;; primitive emitters
623 (define-bitfield-emitter emit-word
16
626 (define-bitfield-emitter emit-dword
32
629 (define-bitfield-emitter emit-byte-with-reg
8
630 (byte 5 3) (byte 3 0))
632 (define-bitfield-emitter emit-mod-reg-r
/m-byte
8
633 (byte 2 6) (byte 3 3) (byte 3 0))
635 (define-bitfield-emitter emit-sib-byte
8
636 (byte 2 6) (byte 3 3) (byte 3 0))
640 (defun emit-absolute-fixup (segment fixup
)
641 (note-fixup segment
:absolute fixup
)
642 (let ((offset (fixup-offset fixup
)))
644 (emit-back-patch segment
645 4 ; FIXME: n-word-bytes
646 (lambda (segment posn
)
647 (declare (ignore posn
))
649 (- (+ (component-header-length)
650 (or (label-position offset
)
652 other-pointer-lowtag
))))
653 (emit-dword segment
(or offset
0)))))
655 (defun emit-relative-fixup (segment fixup
)
656 (note-fixup segment
:relative fixup
)
657 (emit-dword segment
(or (fixup-offset fixup
) 0)))
659 ;;;; the effective-address (ea) structure
661 (defun reg-tn-encoding (tn)
662 (declare (type tn tn
))
663 (aver (eq (sb-name (sc-sb (tn-sc tn
))) 'registers
))
664 (let ((offset (tn-offset tn
)))
665 (logior (ash (logand offset
1) 2)
668 (defstruct (ea (:constructor make-ea
(size &key base index scale disp
))
670 (size nil
:type
(member :byte
:word
:dword
))
671 (base nil
:type
(or tn null
))
672 (index nil
:type
(or tn null
))
673 (scale 1 :type
(member 1 2 4 8))
674 (disp 0 :type
(or (unsigned-byte 32) (signed-byte 32) fixup
)))
675 (def!method print-object
((ea ea
) stream
)
676 (cond ((or *print-escape
* *print-readably
*)
677 (print-unreadable-object (ea stream
:type t
)
679 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
683 (let ((scale (ea-scale ea
)))
684 (if (= scale
1) nil scale
))
687 (format stream
"~A PTR [" (symbol-name (ea-size ea
)))
689 (write-string (sb!c
::location-print-name
(ea-base ea
)) stream
)
691 (write-string "+" stream
)))
693 (write-string (sb!c
::location-print-name
(ea-index ea
)) stream
))
694 (unless (= (ea-scale ea
) 1)
695 (format stream
"*~A" (ea-scale ea
)))
696 (typecase (ea-disp ea
)
699 (format stream
"~@D" (ea-disp ea
)))
701 (format stream
"+~A" (ea-disp ea
))))
702 (write-char #\
] stream
))))
704 (defun emit-ea (segment thing reg
&optional allow-constants
)
707 (ecase (sb-name (sc-sb (tn-sc thing
)))
709 (emit-mod-reg-r/m-byte segment
#b11 reg
(reg-tn-encoding thing
)))
711 ;; Convert stack tns into an index off of EBP.
712 (let ((disp (frame-byte-offset (tn-offset thing
))))
713 (cond ((<= -
128 disp
127)
714 (emit-mod-reg-r/m-byte segment
#b01 reg
#b101
)
715 (emit-byte segment disp
))
717 (emit-mod-reg-r/m-byte segment
#b10 reg
#b101
)
718 (emit-dword segment disp
)))))
720 (unless allow-constants
722 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
723 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
724 (emit-absolute-fixup segment
727 (- (* (tn-offset thing
) n-word-bytes
)
728 other-pointer-lowtag
))))))
730 (let* ((base (ea-base thing
))
731 (index (ea-index thing
))
732 (scale (ea-scale thing
))
733 (disp (ea-disp thing
))
734 (mod (cond ((or (null base
)
736 (not (= (reg-tn-encoding base
) #b101
))))
738 ((and (fixnump disp
) (<= -
128 disp
127))
742 (r/m
(cond (index #b100
)
744 (t (reg-tn-encoding base
)))))
745 (when (and (fixup-p disp
)
746 (label-p (fixup-offset disp
)))
749 (return-from emit-ea
(emit-ea segment disp reg allow-constants
)))
750 (emit-mod-reg-r/m-byte segment mod reg r
/m
)
752 (let ((ss (1- (integer-length scale
)))
753 (index (if (null index
)
755 (let ((index (reg-tn-encoding index
)))
757 (error "can't index off of ESP")
759 (base (if (null base
)
761 (reg-tn-encoding base
))))
762 (emit-sib-byte segment ss index base
)))
764 (emit-byte segment disp
))
765 ((or (= mod
#b10
) (null base
))
767 (emit-absolute-fixup segment disp
)
768 (emit-dword segment disp
))))))
770 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
771 (emit-absolute-fixup segment thing
))))
773 (defun fp-reg-tn-p (thing)
775 (eq (sb-name (sc-sb (tn-sc thing
))) 'float-registers
)))
777 ;;; like the above, but for fp-instructions--jrd
778 (defun emit-fp-op (segment thing op
)
779 (if (fp-reg-tn-p thing
)
780 (emit-byte segment
(dpb op
(byte 3 3) (dpb (tn-offset thing
)
783 (emit-ea segment thing op
)))
785 (defun byte-reg-p (thing)
787 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
788 (member (sc-name (tn-sc thing
)) *byte-sc-names
*)
791 (defun byte-ea-p (thing)
793 (ea (eq (ea-size thing
) :byte
))
795 (and (member (sc-name (tn-sc thing
)) *byte-sc-names
*) t
))
798 (defun word-reg-p (thing)
800 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
801 (member (sc-name (tn-sc thing
)) *word-sc-names
*)
804 (defun word-ea-p (thing)
806 (ea (eq (ea-size thing
) :word
))
807 (tn (and (member (sc-name (tn-sc thing
)) *word-sc-names
*) t
))
810 (defun dword-reg-p (thing)
812 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
813 (member (sc-name (tn-sc thing
)) *dword-sc-names
*)
816 (defun dword-ea-p (thing)
818 (ea (eq (ea-size thing
) :dword
))
820 (and (member (sc-name (tn-sc thing
)) *dword-sc-names
*) t
))
823 (defun register-p (thing)
825 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)))
827 (defun accumulator-p (thing)
828 (and (register-p thing
)
829 (= (tn-offset thing
) 0)))
833 (def!constant
+operand-size-prefix-byte
+ #b01100110
)
835 (defun maybe-emit-operand-size-prefix (segment size
)
836 (unless (or (eq size
:byte
) (eq size
+default-operand-size
+))
837 (emit-byte segment
+operand-size-prefix-byte
+)))
839 (defun operand-size (thing)
842 ;; FIXME: might as well be COND instead of having to use #. readmacro
843 ;; to hack up the code
844 (case (sc-name (tn-sc thing
))
851 ;; added by jrd: float-registers is a separate size (?)
852 (#.sb
!vm
::*float-sc-names
*
854 (#.sb
!vm
::*double-sc-names
*
857 (error "can't tell the size of ~S ~S" thing
(sc-name (tn-sc thing
))))))
863 (defun matching-operand-size (dst src
)
864 (let ((dst-size (operand-size dst
))
865 (src-size (operand-size src
)))
868 (if (eq dst-size src-size
)
870 (error "size mismatch: ~S is a ~S and ~S is a ~S."
871 dst dst-size src src-size
))
875 (error "can't tell the size of either ~S or ~S" dst src
)))))
877 (defun emit-sized-immediate (segment size value
)
880 (emit-byte segment value
))
882 (emit-word segment value
))
884 (emit-dword segment value
))))
888 (define-instruction x66
(segment)
889 (:printer x66
() nil
:print-name nil
)
891 (bug "#X66 prefix used as a standalone instruction")))
893 (defun emit-prefix (segment name
)
898 (emit-byte segment
#xf0
))
900 (emit-byte segment
#x64
))
902 (emit-byte segment
#x65
))))
904 (define-instruction fs
(segment)
905 (:printer seg
((fsgs #b0
)) nil
:print-name nil
)
907 (bug "FS prefix used as a standalone instruction")))
909 (define-instruction gs
(segment)
910 (:printer seg
((fsgs #b1
)) nil
:print-name nil
)
912 (bug "GS prefix used as a standalone instruction")))
914 (define-instruction lock
(segment)
915 (:printer byte
((op #b11110000
)) nil
)
917 (bug "LOCK prefix used as a standalone instruction")))
919 (define-instruction rep
(segment)
921 (emit-byte segment
#b11110011
)))
923 (define-instruction repe
(segment)
924 (:printer byte
((op #b11110011
)) nil
)
926 (emit-byte segment
#b11110011
)))
928 (define-instruction repne
(segment)
929 (:printer byte
((op #b11110010
)) nil
)
931 (emit-byte segment
#b11110010
)))
933 ;;;; general data transfer
935 (define-instruction mov
(segment dst src
&optional prefix
)
936 ;; immediate to register
937 (:printer reg
((op #b1011
) (imm nil
:type
'imm-data
))
938 '(:name
:tab reg
", " imm
))
939 ;; absolute mem to/from accumulator
940 (:printer simple-dir
((op #b101000
) (imm nil
:type
'imm-addr
))
941 `(:name
:tab
,(swap-if 'dir
'accum
", " '("[" imm
"]"))))
942 ;; register to/from register/memory
943 (:printer reg-reg
/mem-dir
((op #b100010
)))
944 ;; immediate to register/memory
945 (:printer reg
/mem-imm
((op '(#b1100011
#b000
))))
948 (emit-prefix segment prefix
)
949 (let ((size (matching-operand-size dst src
)))
950 (maybe-emit-operand-size-prefix segment size
)
951 (cond ((register-p dst
)
952 (cond ((integerp src
)
953 (emit-byte-with-reg segment
957 (reg-tn-encoding dst
))
958 (emit-sized-immediate segment size src
))
959 ((and (fixup-p src
) (accumulator-p dst
))
964 (emit-absolute-fixup segment src
))
970 (emit-ea segment src
(reg-tn-encoding dst
) t
))))
971 ((and (fixup-p dst
) (accumulator-p src
))
972 (emit-byte segment
(if (eq size
:byte
) #b10100010
#b10100011
))
973 (emit-absolute-fixup segment dst
))
975 (emit-byte segment
(if (eq size
:byte
) #b11000110
#b11000111
))
976 (emit-ea segment dst
#b000
)
977 (emit-sized-immediate segment size src
))
979 (emit-byte segment
(if (eq size
:byte
) #b10001000
#b10001001
))
980 (emit-ea segment dst
(reg-tn-encoding src
)))
982 (aver (eq size
:dword
))
983 (emit-byte segment
#b11000111
)
984 (emit-ea segment dst
#b000
)
985 (emit-absolute-fixup segment src
))
987 (error "bogus arguments to MOV: ~S ~S" dst src
))))))
989 (defun emit-move-with-extension (segment dst src opcode
)
990 (aver (register-p dst
))
991 (let ((dst-size (operand-size dst
))
992 (src-size (operand-size src
)))
995 (aver (eq src-size
:byte
))
996 (maybe-emit-operand-size-prefix segment
:word
)
997 (emit-byte segment
#b00001111
)
998 (emit-byte segment opcode
)
999 (emit-ea segment src
(reg-tn-encoding dst
)))
1003 (maybe-emit-operand-size-prefix segment
:dword
)
1004 (emit-byte segment
#b00001111
)
1005 (emit-byte segment opcode
)
1006 (emit-ea segment src
(reg-tn-encoding dst
)))
1008 (emit-byte segment
#b00001111
)
1009 (emit-byte segment
(logior opcode
1))
1010 (emit-ea segment src
(reg-tn-encoding dst
))))))))
1012 (define-instruction movsx
(segment dst src
)
1013 (:printer ext-reg-reg
/mem
((op #b1011111
)
1014 (reg nil
:type
'word-reg
)
1015 (reg/mem nil
:type
'sized-reg
/mem
)))
1016 (:emitter
(emit-move-with-extension segment dst src
#b10111110
)))
1018 (define-instruction movzx
(segment dst src
)
1019 (:printer ext-reg-reg
/mem
((op #b1011011
)
1020 (reg nil
:type
'word-reg
)
1021 (reg/mem nil
:type
'sized-reg
/mem
)))
1022 (:emitter
(emit-move-with-extension segment dst src
#b10110110
)))
1024 (define-instruction push
(segment src
&optional prefix
)
1026 (:printer reg-no-width
((op #b01010
)))
1028 (:printer reg
/mem
((op '(#b1111111
#b110
)) (width 1)))
1030 (:printer byte
((op #b01101010
) (imm nil
:type
'signed-imm-byte
))
1032 (:printer byte
((op #b01101000
) (imm nil
:type
'imm-word
))
1034 ;; ### segment registers?
1037 (emit-prefix segment prefix
)
1038 (cond ((integerp src
)
1039 (cond ((<= -
128 src
127)
1040 (emit-byte segment
#b01101010
)
1041 (emit-byte segment src
))
1043 (emit-byte segment
#b01101000
)
1044 (emit-dword segment src
))))
1046 ;; Interpret the fixup as an immediate dword to push.
1047 (emit-byte segment
#b01101000
)
1048 (emit-absolute-fixup segment src
))
1050 (let ((size (operand-size src
)))
1051 (aver (not (eq size
:byte
)))
1052 (maybe-emit-operand-size-prefix segment size
)
1053 (cond ((register-p src
)
1054 (emit-byte-with-reg segment
#b01010
(reg-tn-encoding src
)))
1056 (emit-byte segment
#b11111111
)
1057 (emit-ea segment src
#b110 t
))))))))
1059 (define-instruction pusha
(segment)
1060 (:printer byte
((op #b01100000
)))
1062 (emit-byte segment
#b01100000
)))
1064 (define-instruction pop
(segment dst
)
1065 (:printer reg-no-width
((op #b01011
)))
1066 (:printer reg
/mem
((op '(#b1000111
#b000
)) (width 1)))
1068 (let ((size (operand-size dst
)))
1069 (aver (not (eq size
:byte
)))
1070 (maybe-emit-operand-size-prefix segment size
)
1071 (cond ((register-p dst
)
1072 (emit-byte-with-reg segment
#b01011
(reg-tn-encoding dst
)))
1074 (emit-byte segment
#b10001111
)
1075 (emit-ea segment dst
#b000
))))))
1077 (define-instruction popa
(segment)
1078 (:printer byte
((op #b01100001
)))
1080 (emit-byte segment
#b01100001
)))
1082 (define-instruction xchg
(segment operand1 operand2
)
1083 ;; Register with accumulator.
1084 (:printer reg-no-width
((op #b10010
)) '(:name
:tab accum
", " reg
))
1085 ;; Register/Memory with Register.
1086 (:printer reg-reg
/mem
((op #b1000011
)))
1088 (let ((size (matching-operand-size operand1 operand2
)))
1089 (maybe-emit-operand-size-prefix segment size
)
1090 (labels ((xchg-acc-with-something (acc something
)
1091 (if (and (not (eq size
:byte
)) (register-p something
))
1092 (emit-byte-with-reg segment
1094 (reg-tn-encoding something
))
1095 (xchg-reg-with-something acc something
)))
1096 (xchg-reg-with-something (reg something
)
1097 (emit-byte segment
(if (eq size
:byte
) #b10000110
#b10000111
))
1098 (emit-ea segment something
(reg-tn-encoding reg
))))
1099 (cond ((accumulator-p operand1
)
1100 (xchg-acc-with-something operand1 operand2
))
1101 ((accumulator-p operand2
)
1102 (xchg-acc-with-something operand2 operand1
))
1103 ((register-p operand1
)
1104 (xchg-reg-with-something operand1 operand2
))
1105 ((register-p operand2
)
1106 (xchg-reg-with-something operand2 operand1
))
1108 (error "bogus args to XCHG: ~S ~S" operand1 operand2
)))))))
1110 (define-instruction lea
(segment dst src
)
1111 (:printer reg-reg
/mem
((op #b1000110
) (width 1)))
1113 (aver (dword-reg-p dst
))
1114 (emit-byte segment
#b10001101
)
1115 (emit-ea segment src
(reg-tn-encoding dst
))))
1117 (define-instruction cmpxchg
(segment dst src
&optional prefix
)
1118 ;; Register/Memory with Register.
1119 (:printer ext-reg-reg
/mem
((op #b1011000
)) '(:name
:tab reg
/mem
", " reg
))
1121 (aver (register-p src
))
1122 (emit-prefix segment prefix
)
1123 (let ((size (matching-operand-size src dst
)))
1124 (maybe-emit-operand-size-prefix segment size
)
1125 (emit-byte segment
#b00001111
)
1126 (emit-byte segment
(if (eq size
:byte
) #b10110000
#b10110001
))
1127 (emit-ea segment dst
(reg-tn-encoding src
)))))
1129 (define-instruction cmpxchg8b
(segment mem
&optional prefix
)
1130 (:printer ext-reg
/mem-no-width
((op '(#xC7
1))))
1132 (aver (not (register-p mem
)))
1133 (emit-prefix segment prefix
)
1134 (emit-byte segment
#x0F
)
1135 (emit-byte segment
#xC7
)
1136 (emit-ea segment mem
1)))
1138 (define-instruction rdrand
(segment dst
)
1139 (:printer ext-reg
/mem-no-width
1142 (aver (register-p dst
))
1143 (maybe-emit-operand-size-prefix segment
(operand-size dst
))
1144 (emit-byte segment
#x0F
)
1145 (emit-byte segment
#xC7
)
1146 (emit-ea segment dst
6)))
1148 (define-instruction pause
(segment)
1149 (:printer two-bytes
((op '(#xf3
#x90
))))
1151 (emit-byte segment
#xf3
)
1152 (emit-byte segment
#x90
)))
1154 ;;;; flag control instructions
1156 ;;; CLC -- Clear Carry Flag.
1157 (define-instruction clc
(segment)
1158 (:printer byte
((op #b11111000
)))
1160 (emit-byte segment
#b11111000
)))
1162 ;;; CLD -- Clear Direction Flag.
1163 (define-instruction cld
(segment)
1164 (:printer byte
((op #b11111100
)))
1166 (emit-byte segment
#b11111100
)))
1168 ;;; CLI -- Clear Iterrupt Enable Flag.
1169 (define-instruction cli
(segment)
1170 (:printer byte
((op #b11111010
)))
1172 (emit-byte segment
#b11111010
)))
1174 ;;; CMC -- Complement Carry Flag.
1175 (define-instruction cmc
(segment)
1176 (:printer byte
((op #b11110101
)))
1178 (emit-byte segment
#b11110101
)))
1180 ;;; LAHF -- Load AH into flags.
1181 (define-instruction lahf
(segment)
1182 (:printer byte
((op #b10011111
)))
1184 (emit-byte segment
#b10011111
)))
1186 ;;; POPF -- Pop flags.
1187 (define-instruction popf
(segment)
1188 (:printer byte
((op #b10011101
)))
1190 (emit-byte segment
#b10011101
)))
1192 ;;; PUSHF -- push flags.
1193 (define-instruction pushf
(segment)
1194 (:printer byte
((op #b10011100
)))
1196 (emit-byte segment
#b10011100
)))
1198 ;;; SAHF -- Store AH into flags.
1199 (define-instruction sahf
(segment)
1200 (:printer byte
((op #b10011110
)))
1202 (emit-byte segment
#b10011110
)))
1204 ;;; STC -- Set Carry Flag.
1205 (define-instruction stc
(segment)
1206 (:printer byte
((op #b11111001
)))
1208 (emit-byte segment
#b11111001
)))
1210 ;;; STD -- Set Direction Flag.
1211 (define-instruction std
(segment)
1212 (:printer byte
((op #b11111101
)))
1214 (emit-byte segment
#b11111101
)))
1216 ;;; STI -- Set Interrupt Enable Flag.
1217 (define-instruction sti
(segment)
1218 (:printer byte
((op #b11111011
)))
1220 (emit-byte segment
#b11111011
)))
1224 (defun emit-random-arith-inst (name segment dst src opcode
1225 &optional allow-constants
)
1226 (let ((size (matching-operand-size dst src
)))
1227 (maybe-emit-operand-size-prefix segment size
)
1230 (cond ((and (not (eq size
:byte
)) (<= -
128 src
127))
1231 (emit-byte segment
#b10000011
)
1232 (emit-ea segment dst opcode allow-constants
)
1233 (emit-byte segment src
))
1234 ((accumulator-p dst
)
1241 (emit-sized-immediate segment size src
))
1243 (emit-byte segment
(if (eq size
:byte
) #b10000000
#b10000001
))
1244 (emit-ea segment dst opcode allow-constants
)
1245 (emit-sized-immediate segment size src
))))
1250 (if (eq size
:byte
) #b00000000
#b00000001
)))
1251 (emit-ea segment dst
(reg-tn-encoding src
) allow-constants
))
1256 (if (eq size
:byte
) #b00000010
#b00000011
)))
1257 (emit-ea segment src
(reg-tn-encoding dst
) allow-constants
))
1259 (error "bogus operands to ~A" name
)))))
1261 (macrolet ((define (name subop
&optional allow-constants
)
1262 `(define-instruction ,name
(segment dst src
&optional prefix
)
1263 (:printer accum-imm
((op ,(dpb subop
(byte 3 2) #b0000010
))))
1264 (:printer reg
/mem-imm
((op '(#b1000000
,subop
))))
1265 (:printer reg
/mem-imm
((op '(#b1000001
,subop
))
1266 (imm nil
:type
'signed-imm-byte
)))
1267 (:printer reg-reg
/mem-dir
((op ,(dpb subop
(byte 3 1) #b000000
))))
1269 (emit-prefix segment prefix
)
1270 (emit-random-arith-inst ,(string name
) segment dst src
,subop
1271 ,allow-constants
)))))
1276 (define cmp
#b111 t
)
1281 (define-instruction inc
(segment dst
)
1283 (:printer reg-no-width
((op #b01000
)))
1285 (:printer reg
/mem
((op '(#b1111111
#b000
))))
1287 (let ((size (operand-size dst
)))
1288 (maybe-emit-operand-size-prefix segment size
)
1289 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1290 (emit-byte-with-reg segment
#b01000
(reg-tn-encoding dst
)))
1292 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1293 (emit-ea segment dst
#b000
))))))
1295 (define-instruction dec
(segment dst
)
1297 (:printer reg-no-width
((op #b01001
)))
1299 (:printer reg
/mem
((op '(#b1111111
#b001
))))
1301 (let ((size (operand-size dst
)))
1302 (maybe-emit-operand-size-prefix segment size
)
1303 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1304 (emit-byte-with-reg segment
#b01001
(reg-tn-encoding dst
)))
1306 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1307 (emit-ea segment dst
#b001
))))))
1309 (define-instruction neg
(segment dst
)
1310 (:printer reg
/mem
((op '(#b1111011
#b011
))))
1312 (let ((size (operand-size dst
)))
1313 (maybe-emit-operand-size-prefix segment size
)
1314 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1315 (emit-ea segment dst
#b011
))))
1317 (define-instruction aaa
(segment)
1318 (:printer byte
((op #b00110111
)))
1320 (emit-byte segment
#b00110111
)))
1322 (define-instruction aas
(segment)
1323 (:printer byte
((op #b00111111
)))
1325 (emit-byte segment
#b00111111
)))
1327 (define-instruction daa
(segment)
1328 (:printer byte
((op #b00100111
)))
1330 (emit-byte segment
#b00100111
)))
1332 (define-instruction das
(segment)
1333 (:printer byte
((op #b00101111
)))
1335 (emit-byte segment
#b00101111
)))
1337 (define-instruction mul
(segment dst src
)
1338 (:printer accum-reg
/mem
((op '(#b1111011
#b100
))))
1340 (let ((size (matching-operand-size dst src
)))
1341 (aver (accumulator-p dst
))
1342 (maybe-emit-operand-size-prefix segment size
)
1343 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1344 (emit-ea segment src
#b100
))))
1346 (define-instruction imul
(segment dst
&optional src1 src2
)
1347 (:printer accum-reg
/mem
((op '(#b1111011
#b101
))))
1348 (:printer ext-reg-reg
/mem
((op #b1010111
)))
1349 (:printer reg-reg
/mem
((op #b0110100
) (width 1)
1350 (imm nil
:type
'signed-imm-word
))
1351 '(:name
:tab reg
", " reg
/mem
", " imm
))
1352 (:printer reg-reg
/mem
((op #b0110101
) (width 1)
1353 (imm nil
:type
'signed-imm-byte
))
1354 '(:name
:tab reg
", " reg
/mem
", " imm
))
1356 (flet ((r/m-with-immed-to-reg
(reg r
/m immed
)
1357 (let* ((size (matching-operand-size reg r
/m
))
1358 (sx (and (not (eq size
:byte
)) (<= -
128 immed
127))))
1359 (maybe-emit-operand-size-prefix segment size
)
1360 (emit-byte segment
(if sx
#b01101011
#b01101001
))
1361 (emit-ea segment r
/m
(reg-tn-encoding reg
))
1363 (emit-byte segment immed
)
1364 (emit-sized-immediate segment size immed
)))))
1366 (r/m-with-immed-to-reg dst src1 src2
))
1369 (r/m-with-immed-to-reg dst dst src1
)
1370 (let ((size (matching-operand-size dst src1
)))
1371 (maybe-emit-operand-size-prefix segment size
)
1372 (emit-byte segment
#b00001111
)
1373 (emit-byte segment
#b10101111
)
1374 (emit-ea segment src1
(reg-tn-encoding dst
)))))
1376 (let ((size (operand-size dst
)))
1377 (maybe-emit-operand-size-prefix segment size
)
1378 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1379 (emit-ea segment dst
#b101
)))))))
1381 (define-instruction div
(segment dst src
)
1382 (:printer accum-reg
/mem
((op '(#b1111011
#b110
))))
1384 (let ((size (matching-operand-size dst src
)))
1385 (aver (accumulator-p dst
))
1386 (maybe-emit-operand-size-prefix segment size
)
1387 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1388 (emit-ea segment src
#b110
))))
1390 (define-instruction idiv
(segment dst src
)
1391 (:printer accum-reg
/mem
((op '(#b1111011
#b111
))))
1393 (let ((size (matching-operand-size dst src
)))
1394 (aver (accumulator-p dst
))
1395 (maybe-emit-operand-size-prefix segment size
)
1396 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1397 (emit-ea segment src
#b111
))))
1399 (define-instruction aad
(segment)
1400 (:printer two-bytes
((op '(#b11010101
#b00001010
))))
1402 (emit-byte segment
#b11010101
)
1403 (emit-byte segment
#b00001010
)))
1405 (define-instruction aam
(segment)
1406 (:printer two-bytes
((op '(#b11010100
#b00001010
))))
1408 (emit-byte segment
#b11010100
)
1409 (emit-byte segment
#b00001010
)))
1411 (define-instruction bswap
(segment dst
)
1412 (:printer ext-reg-no-width
((op #b11001
)))
1414 (emit-byte segment
#x0f
)
1415 (emit-byte-with-reg segment
#b11001
(reg-tn-encoding dst
))))
1417 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1418 (define-instruction cbw
(segment)
1419 (:printer two-bytes
((op '(#b01100110
#b10011000
))))
1421 (maybe-emit-operand-size-prefix segment
:word
)
1422 (emit-byte segment
#b10011000
)))
1424 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1425 (define-instruction cwde
(segment)
1426 (:printer byte
((op #b10011000
)))
1428 (maybe-emit-operand-size-prefix segment
:dword
)
1429 (emit-byte segment
#b10011000
)))
1431 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1432 (define-instruction cwd
(segment)
1433 (:printer two-bytes
((op '(#b01100110
#b10011001
))))
1435 (maybe-emit-operand-size-prefix segment
:word
)
1436 (emit-byte segment
#b10011001
)))
1438 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1439 (define-instruction cdq
(segment)
1440 (:printer byte
((op #b10011001
)))
1442 (maybe-emit-operand-size-prefix segment
:dword
)
1443 (emit-byte segment
#b10011001
)))
1445 (define-instruction xadd
(segment dst src
&optional prefix
)
1446 ;; Register/Memory with Register.
1447 (:printer ext-reg-reg
/mem
((op #b1100000
)) '(:name
:tab reg
/mem
", " reg
))
1449 (aver (register-p src
))
1450 (emit-prefix segment prefix
)
1451 (let ((size (matching-operand-size src dst
)))
1452 (maybe-emit-operand-size-prefix segment size
)
1453 (emit-byte segment
#b00001111
)
1454 (emit-byte segment
(if (eq size
:byte
) #b11000000
#b11000001
))
1455 (emit-ea segment dst
(reg-tn-encoding src
)))))
1460 (defun emit-shift-inst (segment dst amount opcode
)
1461 (let ((size (operand-size dst
)))
1462 (maybe-emit-operand-size-prefix segment size
)
1463 (multiple-value-bind (major-opcode immed
)
1465 (:cl
(values #b11010010 nil
))
1466 (1 (values #b11010000 nil
))
1467 (t (values #b11000000 t
)))
1469 (if (eq size
:byte
) major-opcode
(logior major-opcode
1)))
1470 (emit-ea segment dst opcode
)
1472 (emit-byte segment amount
)))))
1474 (define-instruction-format
1475 (shift-inst 16 :include reg
/mem
1476 :default-printer
'(:name
:tab reg
/mem
", " (:if
(varying :positive
) 'cl
1)))
1477 (op :fields
(list (byte 6 2) (byte 3 11)))
1478 (varying :field
(byte 1 1)))
1480 (macrolet ((define (name subop
)
1481 `(define-instruction ,name
(segment dst amount
)
1482 (:printer shift-inst
((op '(#b110100
,subop
)))) ; shift by CL or 1
1483 (:printer reg
/mem-imm
((op '(#b1100000
,subop
))
1484 (imm nil
:type
'imm-byte
)))
1485 (:emitter
(emit-shift-inst segment dst amount
,subop
)))))
1494 (defun emit-double-shift (segment opcode dst src amt
)
1495 (let ((size (matching-operand-size dst src
)))
1496 (when (eq size
:byte
)
1497 (error "Double shifts can only be used with words."))
1498 (maybe-emit-operand-size-prefix segment size
)
1499 (emit-byte segment
#b00001111
)
1500 (emit-byte segment
(dpb opcode
(byte 1 3)
1501 (if (eq amt
:cl
) #b10100101
#b10100100
)))
1503 (emit-ea segment dst src
)
1504 (emit-ea segment dst
(reg-tn-encoding src
)) ; pw tries this
1505 (unless (eq amt
:cl
)
1506 (emit-byte segment amt
))))
1508 (macrolet ((define (name direction-bit op
)
1509 `(define-instruction ,name
(segment dst src amt
)
1510 (:declare
(type (or (member :cl
) (mod 32)) amt
))
1511 (:printer ext-reg-reg
/mem-no-width
((op ,(logior op
#b100
))
1512 (imm nil
:type
'imm-byte
))
1513 '(:name
:tab reg
/mem
", " reg
", " imm
))
1514 (:printer ext-reg-reg
/mem-no-width
((op ,(logior op
#b101
)))
1515 '(:name
:tab reg
/mem
", " reg
", " 'cl
))
1517 (emit-double-shift segment
,direction-bit dst src amt
)))))
1518 (define shld
0 #b10100000
)
1519 (define shrd
1 #b10101000
))
1521 (define-instruction test
(segment this that
)
1522 (:printer accum-imm
((op #b1010100
)))
1523 (:printer reg
/mem-imm
((op '(#b1111011
#b000
))))
1524 (:printer reg-reg
/mem
((op #b1000010
)))
1526 (let ((size (matching-operand-size this that
)))
1527 (maybe-emit-operand-size-prefix segment size
)
1528 (flet ((test-immed-and-something (immed something
)
1529 (cond ((accumulator-p something
)
1531 (if (eq size
:byte
) #b10101000
#b10101001
))
1532 (emit-sized-immediate segment size immed
))
1535 (if (eq size
:byte
) #b11110110
#b11110111
))
1536 (emit-ea segment something
#b000
)
1537 (emit-sized-immediate segment size immed
))))
1538 (test-reg-and-something (reg something
)
1539 (emit-byte segment
(if (eq size
:byte
) #b10000100
#b10000101
))
1540 (emit-ea segment something
(reg-tn-encoding reg
))))
1541 (cond ((integerp that
)
1542 (test-immed-and-something that this
))
1544 (test-immed-and-something this that
))
1546 (test-reg-and-something this that
))
1548 (test-reg-and-something that this
))
1550 (error "bogus operands for TEST: ~S and ~S" this that
)))))))
1552 (define-instruction not
(segment dst
)
1553 (:printer reg
/mem
((op '(#b1111011
#b010
))))
1555 (let ((size (operand-size dst
)))
1556 (maybe-emit-operand-size-prefix segment size
)
1557 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1558 (emit-ea segment dst
#b010
))))
1560 ;;;; string manipulation
1562 (define-instruction cmps
(segment size
)
1563 (:printer string-op
((op #b1010011
)))
1565 (maybe-emit-operand-size-prefix segment size
)
1566 (emit-byte segment
(if (eq size
:byte
) #b10100110
#b10100111
))))
1568 (define-instruction ins
(segment acc
)
1569 (:printer string-op
((op #b0110110
)))
1571 (let ((size (operand-size acc
)))
1572 (aver (accumulator-p acc
))
1573 (maybe-emit-operand-size-prefix segment size
)
1574 (emit-byte segment
(if (eq size
:byte
) #b01101100
#b01101101
)))))
1576 (define-instruction lods
(segment acc
)
1577 (:printer string-op
((op #b1010110
)))
1579 (let ((size (operand-size acc
)))
1580 (aver (accumulator-p acc
))
1581 (maybe-emit-operand-size-prefix segment size
)
1582 (emit-byte segment
(if (eq size
:byte
) #b10101100
#b10101101
)))))
1584 (define-instruction movs
(segment size
)
1585 (:printer string-op
((op #b1010010
)))
1587 (maybe-emit-operand-size-prefix segment size
)
1588 (emit-byte segment
(if (eq size
:byte
) #b10100100
#b10100101
))))
1590 (define-instruction outs
(segment acc
)
1591 (:printer string-op
((op #b0110111
)))
1593 (let ((size (operand-size acc
)))
1594 (aver (accumulator-p acc
))
1595 (maybe-emit-operand-size-prefix segment size
)
1596 (emit-byte segment
(if (eq size
:byte
) #b01101110
#b01101111
)))))
1598 (define-instruction scas
(segment acc
)
1599 (:printer string-op
((op #b1010111
)))
1601 (let ((size (operand-size acc
)))
1602 (aver (accumulator-p acc
))
1603 (maybe-emit-operand-size-prefix segment size
)
1604 (emit-byte segment
(if (eq size
:byte
) #b10101110
#b10101111
)))))
1606 (define-instruction stos
(segment acc
)
1607 (:printer string-op
((op #b1010101
)))
1609 (let ((size (operand-size acc
)))
1610 (aver (accumulator-p acc
))
1611 (maybe-emit-operand-size-prefix segment size
)
1612 (emit-byte segment
(if (eq size
:byte
) #b10101010
#b10101011
)))))
1614 (define-instruction xlat
(segment)
1615 (:printer byte
((op #b11010111
)))
1617 (emit-byte segment
#b11010111
)))
1620 ;;;; bit manipulation
1622 (define-instruction bsf
(segment dst src
)
1623 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 0)))
1625 (let ((size (matching-operand-size dst src
)))
1626 (when (eq size
:byte
)
1627 (error "can't scan bytes: ~S" src
))
1628 (maybe-emit-operand-size-prefix segment size
)
1629 (emit-byte segment
#b00001111
)
1630 (emit-byte segment
#b10111100
)
1631 (emit-ea segment src
(reg-tn-encoding dst
)))))
1633 (define-instruction bsr
(segment dst src
)
1634 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 1)))
1636 (let ((size (matching-operand-size dst src
)))
1637 (when (eq size
:byte
)
1638 (error "can't scan bytes: ~S" src
))
1639 (maybe-emit-operand-size-prefix segment size
)
1640 (emit-byte segment
#b00001111
)
1641 (emit-byte segment
#b10111101
)
1642 (emit-ea segment src
(reg-tn-encoding dst
)))))
1644 (defun emit-bit-test-and-mumble (segment src index opcode
)
1645 (let ((size (operand-size src
)))
1646 (when (eq size
:byte
)
1647 (error "can't scan bytes: ~S" src
))
1648 (maybe-emit-operand-size-prefix segment size
)
1649 (emit-byte segment
#b00001111
)
1650 (cond ((integerp index
)
1651 (emit-byte segment
#b10111010
)
1652 (emit-ea segment src opcode
)
1653 (emit-byte segment index
))
1655 (emit-byte segment
(dpb opcode
(byte 3 3) #b10000011
))
1656 (emit-ea segment src
(reg-tn-encoding index
))))))
1658 (macrolet ((define (inst opcode-extension
)
1659 `(define-instruction ,inst
(segment src index
&optional prefix
)
1660 (:printer ext-reg
/mem-no-width
+imm8
1661 ((op '(#xBA
,opcode-extension
))
1662 (reg/mem nil
:type
'sized-reg
/mem
)))
1663 (:printer ext-reg-reg
/mem-no-width
1664 ((op ,(dpb opcode-extension
(byte 3 3) #b10000011
))
1665 (reg/mem nil
:type
'sized-reg
/mem
))
1666 '(:name
:tab reg
/mem
", " reg
))
1668 (emit-prefix segment prefix
)
1669 (emit-bit-test-and-mumble segment src index
1670 ,opcode-extension
)))))
1677 ;;;; control transfer
1679 (define-instruction call
(segment where
)
1680 (:printer near-jump
((op #b11101000
)))
1681 (:printer reg
/mem
((op '(#b1111111
#b010
)) (width 1)))
1685 (emit-byte segment
#b11101000
)
1686 (emit-back-patch segment
1688 (lambda (segment posn
)
1690 (- (label-position where
)
1693 (emit-byte segment
#b11101000
)
1694 (emit-relative-fixup segment where
))
1696 (emit-byte segment
#b11111111
)
1697 (emit-ea segment where
#b010
)))))
1699 (defun emit-byte-displacement-backpatch (segment target
)
1700 (emit-back-patch segment
1702 (lambda (segment posn
)
1703 (let ((disp (- (label-position target
) (1+ posn
))))
1704 (aver (<= -
128 disp
127))
1705 (emit-byte segment disp
)))))
1707 (define-instruction jmp
(segment cond
&optional where
)
1708 ;; conditional jumps
1709 (:printer short-cond-jump
((op #b0111
)) '('j cc
:tab label
))
1710 (:printer near-cond-jump
() '('j cc
:tab label
))
1711 ;; unconditional jumps
1712 (:printer short-jump
((op #b1011
)))
1713 (:printer near-jump
((op #b11101001
)) )
1714 (:printer reg
/mem
((op '(#b1111111
#b100
)) (width 1)))
1719 (lambda (segment posn delta-if-after
)
1720 (let ((disp (- (label-position where posn delta-if-after
)
1722 (when (<= -
128 disp
127)
1724 (dpb (conditional-opcode cond
)
1727 (emit-byte-displacement-backpatch segment where
)
1729 (lambda (segment posn
)
1730 (let ((disp (- (label-position where
) (+ posn
6))))
1731 (emit-byte segment
#b00001111
)
1733 (dpb (conditional-opcode cond
)
1736 (emit-dword segment disp
)))))
1737 ((label-p (setq where cond
))
1740 (lambda (segment posn delta-if-after
)
1741 (let ((disp (- (label-position where posn delta-if-after
)
1743 (when (<= -
128 disp
127)
1744 (emit-byte segment
#b11101011
)
1745 (emit-byte-displacement-backpatch segment where
)
1747 (lambda (segment posn
)
1748 (let ((disp (- (label-position where
) (+ posn
5))))
1749 (emit-byte segment
#b11101001
)
1750 (emit-dword segment disp
)))))
1752 (emit-byte segment
#b11101001
)
1753 (emit-relative-fixup segment where
))
1755 (unless (or (ea-p where
) (tn-p where
))
1756 (error "don't know what to do with ~A" where
))
1757 (emit-byte segment
#b11111111
)
1758 (emit-ea segment where
#b100
)))))
1760 (define-instruction jmp-short
(segment label
)
1762 (emit-byte segment
#b11101011
)
1763 (emit-byte-displacement-backpatch segment label
)))
1765 (define-instruction ret
(segment &optional stack-delta
)
1766 (:printer byte
((op #b11000011
)))
1767 (:printer byte
((op #b11000010
) (imm nil
:type
'imm-word-16
))
1770 (cond ((and stack-delta
(not (zerop stack-delta
)))
1771 (emit-byte segment
#b11000010
)
1772 (emit-word segment stack-delta
))
1774 (emit-byte segment
#b11000011
)))))
1776 (define-instruction jecxz
(segment target
)
1777 (:printer short-jump
((op #b0011
)))
1779 (emit-byte segment
#b11100011
)
1780 (emit-byte-displacement-backpatch segment target
)))
1782 (define-instruction loop
(segment target
)
1783 (:printer short-jump
((op #b0010
)))
1785 (emit-byte segment
#b11100010
) ; pfw this was 11100011, or jecxz!!!!
1786 (emit-byte-displacement-backpatch segment target
)))
1788 (define-instruction loopz
(segment target
)
1789 (:printer short-jump
((op #b0001
)))
1791 (emit-byte segment
#b11100001
)
1792 (emit-byte-displacement-backpatch segment target
)))
1794 (define-instruction loopnz
(segment target
)
1795 (:printer short-jump
((op #b0000
)))
1797 (emit-byte segment
#b11100000
)
1798 (emit-byte-displacement-backpatch segment target
)))
1800 ;;;; conditional move
1801 (define-instruction cmov
(segment cond dst src
)
1802 (:printer cond-move
())
1804 (aver (register-p dst
))
1805 (let ((size (matching-operand-size dst src
)))
1806 (aver (or (eq size
:word
) (eq size
:dword
)))
1807 (maybe-emit-operand-size-prefix segment size
))
1808 (emit-byte segment
#b00001111
)
1809 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b01000000
))
1810 (emit-ea segment src
(reg-tn-encoding dst
))))
1812 ;;;; conditional byte set
1814 (define-instruction set
(segment dst cond
)
1815 (:printer cond-set
())
1817 (emit-byte segment
#b00001111
)
1818 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b10010000
))
1819 (emit-ea segment dst
#b000
)))
1823 (define-instruction enter
(segment disp
&optional
(level 0))
1824 (:declare
(type (unsigned-byte 16) disp
)
1825 (type (unsigned-byte 8) level
))
1826 (:printer enter-format
((op #b11001000
)))
1828 (emit-byte segment
#b11001000
)
1829 (emit-word segment disp
)
1830 (emit-byte segment level
)))
1832 (define-instruction leave
(segment)
1833 (:printer byte
((op #b11001001
)))
1835 (emit-byte segment
#b11001001
)))
1838 (define-instruction prefetchnta
(segment ea
)
1839 (:printer prefetch
((op #b00011000
) (reg #b000
)))
1841 (aver (typep ea
'ea
))
1842 (aver (eq :byte
(ea-size ea
)))
1843 (emit-byte segment
#b00001111
)
1844 (emit-byte segment
#b00011000
)
1845 (emit-ea segment ea
#b000
)))
1847 (define-instruction prefetcht0
(segment ea
)
1848 (:printer prefetch
((op #b00011000
) (reg #b001
)))
1850 (aver (typep ea
'ea
))
1851 (aver (eq :byte
(ea-size ea
)))
1852 (emit-byte segment
#b00001111
)
1853 (emit-byte segment
#b00011000
)
1854 (emit-ea segment ea
#b001
)))
1856 (define-instruction prefetcht1
(segment ea
)
1857 (:printer prefetch
((op #b00011000
) (reg #b010
)))
1859 (aver (typep ea
'ea
))
1860 (aver (eq :byte
(ea-size ea
)))
1861 (emit-byte segment
#b00001111
)
1862 (emit-byte segment
#b00011000
)
1863 (emit-ea segment ea
#b010
)))
1865 (define-instruction prefetcht2
(segment ea
)
1866 (:printer prefetch
((op #b00011000
) (reg #b011
)))
1868 (aver (typep ea
'ea
))
1869 (aver (eq :byte
(ea-size ea
)))
1870 (emit-byte segment
#b00001111
)
1871 (emit-byte segment
#b00011000
)
1872 (emit-ea segment ea
#b011
)))
1874 ;;;; interrupt instructions
1876 (define-instruction break
(segment code
)
1877 (:declare
(type (unsigned-byte 8) code
))
1878 #!-ud2-breakpoints
(:printer byte-imm
((op #b11001100
))
1879 '(:name
:tab code
) :control
#'break-control
)
1880 #!+ud2-breakpoints
(:printer word-imm
((op #b0000101100001111
))
1881 '(:name
:tab code
) :control
#'break-control
)
1883 #!-ud2-breakpoints
(emit-byte segment
#b11001100
)
1884 ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
1885 ;; throw a sigill with 0x0b0f instead and check for this in the
1886 ;; SIGILL handler and pass it on to the sigtrap handler if
1888 #!+ud2-breakpoints
(emit-word segment
#b0000101100001111
)
1889 (emit-byte segment code
)))
1891 (define-instruction int
(segment number
)
1892 (:declare
(type (unsigned-byte 8) number
))
1893 (:printer byte-imm
((op #b11001101
)))
1897 (emit-byte segment
#b11001100
))
1899 (emit-byte segment
#b11001101
)
1900 (emit-byte segment number
)))))
1902 (define-instruction into
(segment)
1903 (:printer byte
((op #b11001110
)))
1905 (emit-byte segment
#b11001110
)))
1907 (define-instruction bound
(segment reg bounds
)
1909 (let ((size (matching-operand-size reg bounds
)))
1910 (when (eq size
:byte
)
1911 (error "can't bounds-test bytes: ~S" reg
))
1912 (maybe-emit-operand-size-prefix segment size
)
1913 (emit-byte segment
#b01100010
)
1914 (emit-ea segment bounds
(reg-tn-encoding reg
)))))
1916 (define-instruction iret
(segment)
1917 (:printer byte
((op #b11001111
)))
1919 (emit-byte segment
#b11001111
)))
1921 ;;;; processor control
1923 (define-instruction hlt
(segment)
1924 (:printer byte
((op #b11110100
)))
1926 (emit-byte segment
#b11110100
)))
1928 (define-instruction nop
(segment)
1929 (:printer byte
((op #b10010000
)))
1931 (emit-byte segment
#b10010000
)))
1933 (define-instruction wait
(segment)
1934 (:printer byte
((op #b10011011
)))
1936 (emit-byte segment
#b10011011
)))
1938 ;;;; miscellaneous hackery
1940 (define-instruction byte
(segment byte
)
1942 (emit-byte segment byte
)))
1944 (define-instruction word
(segment word
)
1946 (emit-word segment word
)))
1948 (define-instruction dword
(segment dword
)
1950 (emit-dword segment dword
)))
1952 (defun emit-header-data (segment type
)
1953 (emit-back-patch segment
1955 (lambda (segment posn
)
1959 (component-header-length))
1963 (define-instruction simple-fun-header-word
(segment)
1965 (emit-header-data segment simple-fun-header-widetag
)))
1967 (define-instruction lra-header-word
(segment)
1969 (emit-header-data segment return-pc-header-widetag
)))
1971 ;;;; fp instructions
1973 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
1975 ;;;; Note: We treat the single-precision and double-precision variants
1976 ;;;; as separate instructions.
1978 ;;; Load single to st(0).
1979 (define-instruction fld
(segment source
)
1980 (:printer floating-point
((op '(#b001
#b000
))))
1982 (emit-byte segment
#b11011001
)
1983 (emit-fp-op segment source
#b000
)))
1985 ;;; Load double to st(0).
1986 (define-instruction fldd
(segment source
)
1987 (:printer floating-point
((op '(#b101
#b000
))))
1988 (:printer floating-point-fp
((op '(#b001
#b000
))))
1990 (if (fp-reg-tn-p source
)
1991 (emit-byte segment
#b11011001
)
1992 (emit-byte segment
#b11011101
))
1993 (emit-fp-op segment source
#b000
)))
1995 ;;; Load long to st(0).
1996 (define-instruction fldl
(segment source
)
1997 (:printer floating-point
((op '(#b011
#b101
))))
1999 (emit-byte segment
#b11011011
)
2000 (emit-fp-op segment source
#b101
)))
2002 ;;; Store single from st(0).
2003 (define-instruction fst
(segment dest
)
2004 (:printer floating-point
((op '(#b001
#b010
))))
2006 (cond ((fp-reg-tn-p dest
)
2007 (emit-byte segment
#b11011101
)
2008 (emit-fp-op segment dest
#b010
))
2010 (emit-byte segment
#b11011001
)
2011 (emit-fp-op segment dest
#b010
)))))
2013 ;;; Store double from st(0).
2014 (define-instruction fstd
(segment dest
)
2015 (:printer floating-point
((op '(#b101
#b010
))))
2016 (:printer floating-point-fp
((op '(#b101
#b010
))))
2018 (cond ((fp-reg-tn-p dest
)
2019 (emit-byte segment
#b11011101
)
2020 (emit-fp-op segment dest
#b010
))
2022 (emit-byte segment
#b11011101
)
2023 (emit-fp-op segment dest
#b010
)))))
2025 ;;; Arithmetic ops are all done with at least one operand at top of
2026 ;;; stack. The other operand is is another register or a 32/64 bit
2029 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2030 ;;; that these conflict with the Gdb conventions for binops. To reduce
2031 ;;; the confusion I've added comments showing the mathamatical
2032 ;;; operation and the two syntaxes. By the ASM386 convention the
2033 ;;; instruction syntax is:
2036 ;;; or Fop Destination, Source
2038 ;;; If only one operand is given then it is the source and the
2039 ;;; destination is ST(0). There are reversed forms of the fsub and
2040 ;;; fdiv instructions inducated by an 'R' suffix.
2042 ;;; The mathematical operation for the non-reverse form is always:
2043 ;;; destination = destination op source
2045 ;;; For the reversed form it is:
2046 ;;; destination = source op destination
2048 ;;; The instructions below only accept one operand at present which is
2049 ;;; usually the source. I've hack in extra instructions to implement
2050 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2051 ;;; the operand is the destination with the source being ST(0).
2054 ;;; st(0) = st(0) + memory or st(i).
2055 (define-instruction fadd
(segment source
)
2056 (:printer floating-point
((op '(#b000
#b000
))))
2058 (emit-byte segment
#b11011000
)
2059 (emit-fp-op segment source
#b000
)))
2062 ;;; st(0) = st(0) + memory or st(i).
2063 (define-instruction faddd
(segment source
)
2064 (:printer floating-point
((op '(#b100
#b000
))))
2065 (:printer floating-point-fp
((op '(#b000
#b000
))))
2067 (if (fp-reg-tn-p source
)
2068 (emit-byte segment
#b11011000
)
2069 (emit-byte segment
#b11011100
))
2070 (emit-fp-op segment source
#b000
)))
2072 ;;; Add double destination st(i):
2073 ;;; st(i) = st(0) + st(i).
2074 (define-instruction fadd-sti
(segment destination
)
2075 (:printer floating-point-fp
((op '(#b100
#b000
))))
2077 (aver (fp-reg-tn-p destination
))
2078 (emit-byte segment
#b11011100
)
2079 (emit-fp-op segment destination
#b000
)))
2081 (define-instruction faddp-sti
(segment destination
)
2082 (:printer floating-point-fp
((op '(#b110
#b000
))))
2084 (aver (fp-reg-tn-p destination
))
2085 (emit-byte segment
#b11011110
)
2086 (emit-fp-op segment destination
#b000
)))
2088 ;;; Subtract single:
2089 ;;; st(0) = st(0) - memory or st(i).
2090 (define-instruction fsub
(segment source
)
2091 (:printer floating-point
((op '(#b000
#b100
))))
2093 (emit-byte segment
#b11011000
)
2094 (emit-fp-op segment source
#b100
)))
2096 ;;; Subtract single, reverse:
2097 ;;; st(0) = memory or st(i) - st(0).
2098 (define-instruction fsubr
(segment source
)
2099 (:printer floating-point
((op '(#b000
#b101
))))
2101 (emit-byte segment
#b11011000
)
2102 (emit-fp-op segment source
#b101
)))
2104 ;;; Subtract double:
2105 ;;; st(0) = st(0) - memory or st(i).
2106 (define-instruction fsubd
(segment source
)
2107 (:printer floating-point
((op '(#b100
#b100
))))
2108 (:printer floating-point-fp
((op '(#b000
#b100
))))
2110 (if (fp-reg-tn-p source
)
2111 (emit-byte segment
#b11011000
)
2112 (emit-byte segment
#b11011100
))
2113 (emit-fp-op segment source
#b100
)))
2115 ;;; Subtract double, reverse:
2116 ;;; st(0) = memory or st(i) - st(0).
2117 (define-instruction fsubrd
(segment source
)
2118 (:printer floating-point
((op '(#b100
#b101
))))
2119 (:printer floating-point-fp
((op '(#b000
#b101
))))
2121 (if (fp-reg-tn-p source
)
2122 (emit-byte segment
#b11011000
)
2123 (emit-byte segment
#b11011100
))
2124 (emit-fp-op segment source
#b101
)))
2126 ;;; Subtract double, destination st(i):
2127 ;;; st(i) = st(i) - st(0).
2129 ;;; ASM386 syntax: FSUB ST(i), ST
2130 ;;; Gdb syntax: fsubr %st,%st(i)
2131 (define-instruction fsub-sti
(segment destination
)
2132 (:printer floating-point-fp
((op '(#b100
#b101
))))
2134 (aver (fp-reg-tn-p destination
))
2135 (emit-byte segment
#b11011100
)
2136 (emit-fp-op segment destination
#b101
)))
2138 (define-instruction fsubp-sti
(segment destination
)
2139 (:printer floating-point-fp
((op '(#b110
#b101
))))
2141 (aver (fp-reg-tn-p destination
))
2142 (emit-byte segment
#b11011110
)
2143 (emit-fp-op segment destination
#b101
)))
2145 ;;; Subtract double, reverse, destination st(i):
2146 ;;; st(i) = st(0) - st(i).
2148 ;;; ASM386 syntax: FSUBR ST(i), ST
2149 ;;; Gdb syntax: fsub %st,%st(i)
2150 (define-instruction fsubr-sti
(segment destination
)
2151 (:printer floating-point-fp
((op '(#b100
#b100
))))
2153 (aver (fp-reg-tn-p destination
))
2154 (emit-byte segment
#b11011100
)
2155 (emit-fp-op segment destination
#b100
)))
2157 (define-instruction fsubrp-sti
(segment destination
)
2158 (:printer floating-point-fp
((op '(#b110
#b100
))))
2160 (aver (fp-reg-tn-p destination
))
2161 (emit-byte segment
#b11011110
)
2162 (emit-fp-op segment destination
#b100
)))
2164 ;;; Multiply single:
2165 ;;; st(0) = st(0) * memory or st(i).
2166 (define-instruction fmul
(segment source
)
2167 (:printer floating-point
((op '(#b000
#b001
))))
2169 (emit-byte segment
#b11011000
)
2170 (emit-fp-op segment source
#b001
)))
2172 ;;; Multiply double:
2173 ;;; st(0) = st(0) * memory or st(i).
2174 (define-instruction fmuld
(segment source
)
2175 (:printer floating-point
((op '(#b100
#b001
))))
2176 (:printer floating-point-fp
((op '(#b000
#b001
))))
2178 (if (fp-reg-tn-p source
)
2179 (emit-byte segment
#b11011000
)
2180 (emit-byte segment
#b11011100
))
2181 (emit-fp-op segment source
#b001
)))
2183 ;;; Multiply double, destination st(i):
2184 ;;; st(i) = st(i) * st(0).
2185 (define-instruction fmul-sti
(segment destination
)
2186 (:printer floating-point-fp
((op '(#b100
#b001
))))
2188 (aver (fp-reg-tn-p destination
))
2189 (emit-byte segment
#b11011100
)
2190 (emit-fp-op segment destination
#b001
)))
2193 ;;; st(0) = st(0) / memory or st(i).
2194 (define-instruction fdiv
(segment source
)
2195 (:printer floating-point
((op '(#b000
#b110
))))
2197 (emit-byte segment
#b11011000
)
2198 (emit-fp-op segment source
#b110
)))
2200 ;;; Divide single, reverse:
2201 ;;; st(0) = memory or st(i) / st(0).
2202 (define-instruction fdivr
(segment source
)
2203 (:printer floating-point
((op '(#b000
#b111
))))
2205 (emit-byte segment
#b11011000
)
2206 (emit-fp-op segment source
#b111
)))
2209 ;;; st(0) = st(0) / memory or st(i).
2210 (define-instruction fdivd
(segment source
)
2211 (:printer floating-point
((op '(#b100
#b110
))))
2212 (:printer floating-point-fp
((op '(#b000
#b110
))))
2214 (if (fp-reg-tn-p source
)
2215 (emit-byte segment
#b11011000
)
2216 (emit-byte segment
#b11011100
))
2217 (emit-fp-op segment source
#b110
)))
2219 ;;; Divide double, reverse:
2220 ;;; st(0) = memory or st(i) / st(0).
2221 (define-instruction fdivrd
(segment source
)
2222 (:printer floating-point
((op '(#b100
#b111
))))
2223 (:printer floating-point-fp
((op '(#b000
#b111
))))
2225 (if (fp-reg-tn-p source
)
2226 (emit-byte segment
#b11011000
)
2227 (emit-byte segment
#b11011100
))
2228 (emit-fp-op segment source
#b111
)))
2230 ;;; Divide double, destination st(i):
2231 ;;; st(i) = st(i) / st(0).
2233 ;;; ASM386 syntax: FDIV ST(i), ST
2234 ;;; Gdb syntax: fdivr %st,%st(i)
2235 (define-instruction fdiv-sti
(segment destination
)
2236 (:printer floating-point-fp
((op '(#b100
#b111
))))
2238 (aver (fp-reg-tn-p destination
))
2239 (emit-byte segment
#b11011100
)
2240 (emit-fp-op segment destination
#b111
)))
2242 ;;; Divide double, reverse, destination st(i):
2243 ;;; st(i) = st(0) / st(i).
2245 ;;; ASM386 syntax: FDIVR ST(i), ST
2246 ;;; Gdb syntax: fdiv %st,%st(i)
2247 (define-instruction fdivr-sti
(segment destination
)
2248 (:printer floating-point-fp
((op '(#b100
#b110
))))
2250 (aver (fp-reg-tn-p destination
))
2251 (emit-byte segment
#b11011100
)
2252 (emit-fp-op segment destination
#b110
)))
2254 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2255 (define-instruction fxch
(segment source
)
2256 (:printer floating-point-fp
((op '(#b001
#b001
))))
2258 (aver (and (tn-p source
)
2259 (eq (sb-name (sc-sb (tn-sc source
))) 'float-registers
)))
2260 (emit-byte segment
#b11011001
)
2261 (emit-fp-op segment source
#b001
)))
2263 ;;; Push 32-bit integer to st0.
2264 (define-instruction fild
(segment source
)
2265 (:printer floating-point
((op '(#b011
#b000
))))
2267 (emit-byte segment
#b11011011
)
2268 (emit-fp-op segment source
#b000
)))
2270 ;;; Push 64-bit integer to st0.
2271 (define-instruction fildl
(segment source
)
2272 (:printer floating-point
((op '(#b111
#b101
))))
2274 (emit-byte segment
#b11011111
)
2275 (emit-fp-op segment source
#b101
)))
2277 ;;; Store 32-bit integer.
2278 (define-instruction fist
(segment dest
)
2279 (:printer floating-point
((op '(#b011
#b010
))))
2281 (emit-byte segment
#b11011011
)
2282 (emit-fp-op segment dest
#b010
)))
2284 ;;; Store and pop 32-bit integer.
2285 (define-instruction fistp
(segment dest
)
2286 (:printer floating-point
((op '(#b011
#b011
))))
2288 (emit-byte segment
#b11011011
)
2289 (emit-fp-op segment dest
#b011
)))
2291 ;;; Store and pop 64-bit integer.
2292 (define-instruction fistpl
(segment dest
)
2293 (:printer floating-point
((op '(#b111
#b111
))))
2295 (emit-byte segment
#b11011111
)
2296 (emit-fp-op segment dest
#b111
)))
2298 ;;; Store single from st(0) and pop.
2299 (define-instruction fstp
(segment dest
)
2300 (:printer floating-point
((op '(#b001
#b011
))))
2302 (cond ((fp-reg-tn-p dest
)
2303 (emit-byte segment
#b11011101
)
2304 (emit-fp-op segment dest
#b011
))
2306 (emit-byte segment
#b11011001
)
2307 (emit-fp-op segment dest
#b011
)))))
2309 ;;; Store double from st(0) and pop.
2310 (define-instruction fstpd
(segment dest
)
2311 (:printer floating-point
((op '(#b101
#b011
))))
2312 (:printer floating-point-fp
((op '(#b101
#b011
))))
2314 (cond ((fp-reg-tn-p dest
)
2315 (emit-byte segment
#b11011101
)
2316 (emit-fp-op segment dest
#b011
))
2318 (emit-byte segment
#b11011101
)
2319 (emit-fp-op segment dest
#b011
)))))
2321 ;;; Store long from st(0) and pop.
2322 (define-instruction fstpl
(segment dest
)
2323 (:printer floating-point
((op '(#b011
#b111
))))
2325 (emit-byte segment
#b11011011
)
2326 (emit-fp-op segment dest
#b111
)))
2328 ;;; Decrement stack-top pointer.
2329 (define-instruction fdecstp
(segment)
2330 (:printer floating-point-no
((op #b10110
)))
2332 (emit-byte segment
#b11011001
)
2333 (emit-byte segment
#b11110110
)))
2335 ;;; Increment stack-top pointer.
2336 (define-instruction fincstp
(segment)
2337 (:printer floating-point-no
((op #b10111
)))
2339 (emit-byte segment
#b11011001
)
2340 (emit-byte segment
#b11110111
)))
2342 ;;; Free fp register.
2343 (define-instruction ffree
(segment dest
)
2344 (:printer floating-point-fp
((op '(#b101
#b000
))))
2346 (emit-byte segment
#b11011101
)
2347 (emit-fp-op segment dest
#b000
)))
2349 (define-instruction fabs
(segment)
2350 (:printer floating-point-no
((op #b00001
)))
2352 (emit-byte segment
#b11011001
)
2353 (emit-byte segment
#b11100001
)))
2355 (define-instruction fchs
(segment)
2356 (:printer floating-point-no
((op #b00000
)))
2358 (emit-byte segment
#b11011001
)
2359 (emit-byte segment
#b11100000
)))
2361 (define-instruction frndint
(segment)
2362 (:printer floating-point-no
((op #b11100
)))
2364 (emit-byte segment
#b11011001
)
2365 (emit-byte segment
#b11111100
)))
2368 (define-instruction fninit
(segment)
2369 (:printer floating-point-5
((op #b00011
)))
2371 (emit-byte segment
#b11011011
)
2372 (emit-byte segment
#b11100011
)))
2374 ;;; Store Status Word to AX.
2375 (define-instruction fnstsw
(segment)
2376 (:printer floating-point-st
((op #b00000
)))
2378 (emit-byte segment
#b11011111
)
2379 (emit-byte segment
#b11100000
)))
2381 ;;; Load Control Word.
2383 ;;; src must be a memory location
2384 (define-instruction fldcw
(segment src
)
2385 (:printer floating-point
((op '(#b001
#b101
))))
2387 (emit-byte segment
#b11011001
)
2388 (emit-fp-op segment src
#b101
)))
2390 ;;; Store Control Word.
2391 (define-instruction fnstcw
(segment dst
)
2392 (:printer floating-point
((op '(#b001
#b111
))))
2394 (emit-byte segment
#b11011001
)
2395 (emit-fp-op segment dst
#b111
)))
2397 ;;; Store FP Environment.
2398 (define-instruction fstenv
(segment dst
)
2399 (:printer floating-point
((op '(#b001
#b110
))))
2401 (emit-byte segment
#b11011001
)
2402 (emit-fp-op segment dst
#b110
)))
2404 ;;; Restore FP Environment.
2405 (define-instruction fldenv
(segment src
)
2406 (:printer floating-point
((op '(#b001
#b100
))))
2408 (emit-byte segment
#b11011001
)
2409 (emit-fp-op segment src
#b100
)))
2412 (define-instruction fsave
(segment dst
)
2413 (:printer floating-point
((op '(#b101
#b110
))))
2415 (emit-byte segment
#b11011101
)
2416 (emit-fp-op segment dst
#b110
)))
2418 ;;; Restore FP State.
2419 (define-instruction frstor
(segment src
)
2420 (:printer floating-point
((op '(#b101
#b100
))))
2422 (emit-byte segment
#b11011101
)
2423 (emit-fp-op segment src
#b100
)))
2425 ;;; Clear exceptions.
2426 (define-instruction fnclex
(segment)
2427 (:printer floating-point-5
((op #b00010
)))
2429 (emit-byte segment
#b11011011
)
2430 (emit-byte segment
#b11100010
)))
2433 (define-instruction fcom
(segment src
)
2434 (:printer floating-point
((op '(#b000
#b010
))))
2436 (emit-byte segment
#b11011000
)
2437 (emit-fp-op segment src
#b010
)))
2439 (define-instruction fcomd
(segment src
)
2440 (:printer floating-point
((op '(#b100
#b010
))))
2441 (:printer floating-point-fp
((op '(#b000
#b010
))))
2443 (if (fp-reg-tn-p src
)
2444 (emit-byte segment
#b11011000
)
2445 (emit-byte segment
#b11011100
))
2446 (emit-fp-op segment src
#b010
)))
2448 ;;; Compare ST1 to ST0, popping the stack twice.
2449 (define-instruction fcompp
(segment)
2450 (:printer floating-point-3
((op '(#b110
#b011001
))))
2452 (emit-byte segment
#b11011110
)
2453 (emit-byte segment
#b11011001
)))
2455 ;;; unordered comparison
2456 (define-instruction fucom
(segment src
)
2457 (:printer floating-point-fp
((op '(#b101
#b100
))))
2459 (aver (fp-reg-tn-p src
))
2460 (emit-byte segment
#b11011101
)
2461 (emit-fp-op segment src
#b100
)))
2463 (define-instruction ftst
(segment)
2464 (:printer floating-point-no
((op #b00100
)))
2466 (emit-byte segment
#b11011001
)
2467 (emit-byte segment
#b11100100
)))
2471 (define-instruction fsqrt
(segment)
2472 (:printer floating-point-no
((op #b11010
)))
2474 (emit-byte segment
#b11011001
)
2475 (emit-byte segment
#b11111010
)))
2477 (define-instruction fscale
(segment)
2478 (:printer floating-point-no
((op #b11101
)))
2480 (emit-byte segment
#b11011001
)
2481 (emit-byte segment
#b11111101
)))
2483 (define-instruction fxtract
(segment)
2484 (:printer floating-point-no
((op #b10100
)))
2486 (emit-byte segment
#b11011001
)
2487 (emit-byte segment
#b11110100
)))
2489 (define-instruction fsin
(segment)
2490 (:printer floating-point-no
((op #b11110
)))
2492 (emit-byte segment
#b11011001
)
2493 (emit-byte segment
#b11111110
)))
2495 (define-instruction fcos
(segment)
2496 (:printer floating-point-no
((op #b11111
)))
2498 (emit-byte segment
#b11011001
)
2499 (emit-byte segment
#b11111111
)))
2501 (define-instruction fprem1
(segment)
2502 (:printer floating-point-no
((op #b10101
)))
2504 (emit-byte segment
#b11011001
)
2505 (emit-byte segment
#b11110101
)))
2507 (define-instruction fprem
(segment)
2508 (:printer floating-point-no
((op #b11000
)))
2510 (emit-byte segment
#b11011001
)
2511 (emit-byte segment
#b11111000
)))
2513 (define-instruction fxam
(segment)
2514 (:printer floating-point-no
((op #b00101
)))
2516 (emit-byte segment
#b11011001
)
2517 (emit-byte segment
#b11100101
)))
2519 ;;; These do push/pop to stack and need special handling
2520 ;;; in any VOPs that use them. See the book.
2522 ;;; st0 <- st1*log2(st0)
2523 (define-instruction fyl2x
(segment) ; pops stack
2524 (:printer floating-point-no
((op #b10001
)))
2526 (emit-byte segment
#b11011001
)
2527 (emit-byte segment
#b11110001
)))
2529 (define-instruction fyl2xp1
(segment)
2530 (:printer floating-point-no
((op #b11001
)))
2532 (emit-byte segment
#b11011001
)
2533 (emit-byte segment
#b11111001
)))
2535 (define-instruction f2xm1
(segment)
2536 (:printer floating-point-no
((op #b10000
)))
2538 (emit-byte segment
#b11011001
)
2539 (emit-byte segment
#b11110000
)))
2541 (define-instruction fptan
(segment) ; st(0) <- 1; st(1) <- tan
2542 (:printer floating-point-no
((op #b10010
)))
2544 (emit-byte segment
#b11011001
)
2545 (emit-byte segment
#b11110010
)))
2547 (define-instruction fpatan
(segment) ; POPS STACK
2548 (:printer floating-point-no
((op #b10011
)))
2550 (emit-byte segment
#b11011001
)
2551 (emit-byte segment
#b11110011
)))
2553 ;;;; loading constants
2555 (define-instruction fldz
(segment)
2556 (:printer floating-point-no
((op #b01110
)))
2558 (emit-byte segment
#b11011001
)
2559 (emit-byte segment
#b11101110
)))
2561 (define-instruction fld1
(segment)
2562 (:printer floating-point-no
((op #b01000
)))
2564 (emit-byte segment
#b11011001
)
2565 (emit-byte segment
#b11101000
)))
2567 (define-instruction fldpi
(segment)
2568 (:printer floating-point-no
((op #b01011
)))
2570 (emit-byte segment
#b11011001
)
2571 (emit-byte segment
#b11101011
)))
2573 (define-instruction fldl2t
(segment)
2574 (:printer floating-point-no
((op #b01001
)))
2576 (emit-byte segment
#b11011001
)
2577 (emit-byte segment
#b11101001
)))
2579 (define-instruction fldl2e
(segment)
2580 (:printer floating-point-no
((op #b01010
)))
2582 (emit-byte segment
#b11011001
)
2583 (emit-byte segment
#b11101010
)))
2585 (define-instruction fldlg2
(segment)
2586 (:printer floating-point-no
((op #b01100
)))
2588 (emit-byte segment
#b11011001
)
2589 (emit-byte segment
#b11101100
)))
2591 (define-instruction fldln2
(segment)
2592 (:printer floating-point-no
((op #b01101
)))
2594 (emit-byte segment
#b11011001
)
2595 (emit-byte segment
#b11101101
)))
2599 (define-instruction cpuid
(segment)
2600 (:printer two-bytes
((op '(#b00001111
#b10100010
))))
2602 (emit-byte segment
#b00001111
)
2603 (emit-byte segment
#b10100010
)))
2605 (define-instruction rdtsc
(segment)
2606 (:printer two-bytes
((op '(#b00001111
#b00110001
))))
2608 (emit-byte segment
#b00001111
)
2609 (emit-byte segment
#b00110001
)))
2611 ;;;; Late VM definitions
2612 (defun canonicalize-inline-constant (constant)
2613 (let ((first (car constant
)))
2615 (single-float (setf constant
(list :single-float first
)))
2616 (double-float (setf constant
(list :double-float first
)))))
2617 (destructuring-bind (type value
) constant
2619 ((:byte
:word
:dword
)
2620 (aver (integerp value
))
2623 #!+sb-unicode
(aver (typep value
'base-char
))
2624 (cons :byte
(char-code value
)))
2626 (aver (characterp value
))
2627 (cons :dword
(char-code value
)))
2629 (aver (typep value
'single-float
))
2630 (cons :dword
(ldb (byte 32 0) (single-float-bits value
))))
2631 ((:double-float-bits
)
2632 (aver (integerp value
))
2633 (cons :double-float
(ldb (byte 64 0) value
)))
2635 (aver (typep value
'double-float
))
2637 (ldb (byte 64 0) (logior (ash (double-float-high-bits value
) 32)
2638 (double-float-low-bits value
))))))))
2640 (defun inline-constant-value (constant)
2641 (let ((label (gen-label))
2642 (size (ecase (car constant
)
2643 ((:byte
:word
:dword
) (car constant
))
2644 (:double-float
:dword
))))
2645 (values label
(make-ea size
2646 :disp
(make-fixup nil
:code-object label
)))))
2648 (defun emit-constant-segment-header (segment constants optimize
)
2649 (declare (ignore segment constants
))
2650 (loop repeat
(if optimize
64 16) do
(inst byte
#x90
)))
2652 (defun size-nbyte (size)
2659 (defun sort-inline-constants (constants)
2660 (stable-sort constants
#'> :key
(lambda (constant)
2661 (size-nbyte (caar constant
)))))
2663 (defun emit-inline-constant (constant label
)
2664 (let ((size (size-nbyte (car constant
))))
2665 (emit-alignment (integer-length (1- size
)))
2667 (let ((val (cdr constant
)))
2669 do
(inst byte
(ldb (byte 8 0) val
))
2670 (setf val
(ash val -
8))))))