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 '(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 (setf *disassem-inst-alignment-bytes
* 1)
27 (deftype reg
() '(unsigned-byte 3))
29 (defconstant +default-operand-size
+ :dword
)
31 (defparameter *default-address-size
*
32 ;; Actually, :DWORD is the only one really supported.
35 ;;; Disassembling x86 code needs to take into account little things
36 ;;; like instructions that have a byte/word length bit in their
37 ;;; encoding, prefixes to change the default word length for a single
38 ;;; instruction, and so on. Unfortunately, there is no easy way with
39 ;;; this disassembler framework to handle prefixes that will work
40 ;;; correctly in all cases, so we copy the x86-64 version which at
41 ;;; least can handle the code output by the compiler.
43 ;;; Width information for an instruction and whether a segment
44 ;;; override prefix was seen is stored as an inst-prop on the dstate.
45 ;;; The inst-props are cleared automatically after each non-prefix
46 ;;; instruction, must be set by prefilters, and contain a single bit of
47 ;;; data each (presence/absence).
49 ;;; Return the operand size based on the prefixes and width bit from
51 (defun inst-operand-size (dstate)
52 (declare (type disassem-state dstate
))
53 (cond ((dstate-get-inst-prop dstate
'operand-size-8
) :byte
)
54 ((dstate-get-inst-prop dstate
'operand-size-16
) :word
)
55 (t +default-operand-size
+)))
57 ;;; Return the operand size for a "word-sized" operand based on the
58 ;;; prefixes from the dstate.
59 (defun inst-word-operand-size (dstate)
60 (declare (type disassem-state dstate
))
61 (if (dstate-get-inst-prop dstate
'operand-size-16
) :word
:dword
))
63 ;;; Returns either an integer, meaning a register, or a list of
64 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
65 ;;; may be missing or nil to indicate that it's not used or has the
66 ;;; obvious default value (e.g., 1 for the index-scale).
67 (defun prefilter-reg/mem
(dstate mod r
/m
)
68 (declare (type disassem-state dstate
)
69 (type (unsigned-byte 2) mod
)
70 (type (unsigned-byte 3) r
/m
))
76 (let ((sib (read-suffix 8 dstate
)))
77 (declare (type (unsigned-byte 8) sib
))
78 (let ((base-reg (ldb (byte 3 0) sib
))
79 (index-reg (ldb (byte 3 3) sib
))
80 (index-scale (ldb (byte 2 6) sib
)))
81 (declare (type (unsigned-byte 3) base-reg index-reg
)
82 (type (unsigned-byte 2) index-scale
))
86 (if (= base-reg
#b101
)
87 (read-signed-suffix 32 dstate
)
90 (read-signed-suffix 8 dstate
))
92 (read-signed-suffix 32 dstate
)))))
93 (list (if (and (= mod
#b00
) (= base-reg
#b101
)) nil base-reg
)
95 (if (= index-reg
#b100
) nil index-reg
)
96 (ash 1 index-scale
))))))
97 ((and (= mod
#b00
) (= r
/m
#b101
))
98 (list nil
(read-signed-suffix 32 dstate
)) )
102 (list r
/m
(read-signed-suffix 8 dstate
)))
104 (list r
/m
(read-signed-suffix 32 dstate
)))))
107 ;;; This is a sort of bogus prefilter that just stores the info globally for
108 ;;; other people to use; it probably never gets printed.
109 (defun prefilter-width (dstate value
)
110 (declare (type bit value
)
111 (type disassem-state dstate
))
113 (dstate-put-inst-prop dstate
'operand-size-8
))
116 (defun width-bits (width)
124 ;;;; disassembler argument types
126 (define-arg-type displacement
128 :use-label
(lambda (value dstate
) (+ (dstate-next-addr dstate
) value
))
129 :printer
(lambda (value stream dstate
)
130 (maybe-note-assembler-routine value nil dstate
)
131 (print-label value stream dstate
)))
133 (define-arg-type accum
134 :printer
(lambda (value stream dstate
)
135 (declare (ignore value
)
137 (type disassem-state dstate
))
138 (print-reg 0 stream dstate
)))
140 (define-arg-type word-accum
141 :printer
(lambda (value stream dstate
)
142 (declare (ignore value
)
144 (type disassem-state dstate
))
145 (print-word-reg 0 stream dstate
)))
147 (define-arg-type reg
:printer
#'print-reg
)
149 (define-arg-type addr-reg
:printer
#'print-addr-reg
)
151 (define-arg-type word-reg
:printer
#'print-word-reg
)
153 (define-arg-type imm-addr
154 :prefilter
(lambda (dstate)
155 (read-suffix (width-bits *default-address-size
*) dstate
))
156 :printer
#'print-label
)
158 (define-arg-type imm-data
159 :prefilter
(lambda (dstate)
160 (read-suffix (width-bits (inst-operand-size dstate
)) dstate
)))
162 (define-arg-type signed-imm-data
163 :prefilter
(lambda (dstate)
164 (let ((width (inst-operand-size dstate
)))
165 (read-signed-suffix (width-bits width
) dstate
))))
167 (define-arg-type imm-byte
168 :prefilter
(lambda (dstate)
169 (read-suffix 8 dstate
)))
171 (define-arg-type signed-imm-byte
172 :prefilter
(lambda (dstate)
173 (read-signed-suffix 8 dstate
)))
175 (define-arg-type signed-imm-dword
176 :prefilter
(lambda (dstate)
177 (read-signed-suffix 32 dstate
)))
179 (define-arg-type imm-word
180 :prefilter
(lambda (dstate)
181 (let ((width (inst-word-operand-size dstate
)))
182 (read-suffix (width-bits width
) dstate
))))
184 (define-arg-type signed-imm-word
185 :prefilter
(lambda (dstate)
186 (let ((width (inst-word-operand-size dstate
)))
187 (read-signed-suffix (width-bits width
) dstate
))))
189 ;;; needed for the ret imm16 instruction
190 (define-arg-type imm-word-16
191 :prefilter
(lambda (dstate)
192 (read-suffix 16 dstate
)))
194 (define-arg-type reg
/mem
195 :prefilter
#'prefilter-reg
/mem
196 :printer
#'print-reg
/mem
)
197 (define-arg-type sized-reg
/mem
198 ;; Same as reg/mem, but prints an explicit size indicator for
199 ;; memory references.
200 :prefilter
#'prefilter-reg
/mem
201 :printer
#'print-sized-reg
/mem
)
202 (define-arg-type byte-reg
/mem
203 :prefilter
#'prefilter-reg
/mem
204 :printer
#'print-byte-reg
/mem
)
205 (define-arg-type word-reg
/mem
206 :prefilter
#'prefilter-reg
/mem
207 :printer
#'print-word-reg
/mem
)
209 (define-arg-type fp-reg
211 (lambda (value stream dstate
)
212 (declare (ignore dstate
))
213 (format stream
"FR~D" value
)))
215 (define-arg-type width
216 :prefilter
#'prefilter-width
217 :printer
(lambda (value stream dstate
)
218 (declare (ignore value
))
219 (princ (schar (symbol-name (inst-operand-size dstate
)) 0)
222 ;;; Used to capture the effect of the #x66 operand size override prefix.
224 :prefilter
(lambda (dstate junk
)
225 (declare (ignore junk
))
226 (dstate-put-inst-prop dstate
'operand-size-16
)))
228 ;;; Used to capture the effect of the #x64 and #x65 segment override
231 :prefilter
(lambda (dstate value
)
232 (declare (type bit value
))
233 (dstate-put-inst-prop
234 dstate
(elt '(fs-segment-prefix gs-segment-prefix
) value
))))
236 (defconstant-eqx +conditions
+
239 (:b .
2) (:nae .
2) (:c .
2)
240 (:nb .
3) (:ae .
3) (:nc .
3)
241 (:eq .
4) (:e .
4) (:z .
4)
248 (:np .
11) (:po .
11)
249 (:l .
12) (:nge .
12)
250 (:nl .
13) (:ge .
13)
251 (:le .
14) (:ng .
14)
252 (:nle .
15) (:g .
15))
254 (defconstant-eqx sb
!vm
::+condition-name-vec
+
255 #.
(let ((vec (make-array 16 :initial-element nil
)))
256 (dolist (cond +conditions
+ vec
)
257 (when (null (aref vec
(cdr cond
)))
258 (setf (aref vec
(cdr cond
)) (car cond
)))))
261 ;;; Set assembler parameters. (In CMU CL, this was done with
262 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
263 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
264 (setf sb
!assem
:*assem-scheduler-p
* nil
))
266 (define-arg-type condition-code
:printer sb
!vm
::+condition-name-vec
+)
268 (defun conditional-opcode (condition)
269 (cdr (assoc condition
+conditions
+ :test
#'eq
)))
271 ;;;; disassembler instruction formats
273 (defun swap-if (direction field1 separator field2
)
274 `(:if
(,direction
:constant
0)
275 (,field1
,separator
,field2
)
276 (,field2
,separator
,field1
)))
278 (define-instruction-format (byte 8 :default-printer
'(:name
))
279 (op :field
(byte 8 0))
284 ;;; Prefix instructions
286 (define-instruction-format (x66 8)
287 (x66 :field
(byte 8 0) :type
'x66
:value
#x66
))
289 (define-instruction-format (seg 8)
290 (seg :field
(byte 7 1) :value
#x32
)
291 (fsgs :field
(byte 1 0) :type
'seg
))
293 (define-instruction-format (simple 8)
294 (op :field
(byte 7 1))
295 (width :field
(byte 1 0) :type
'width
)
300 (define-instruction-format (two-bytes 16 :default-printer
'(:name
))
301 (op :fields
(list (byte 8 0) (byte 8 8))))
303 (define-instruction-format (three-bytes 24 :default-printer
'(:name
))
304 (op :fields
(list (byte 8 0) (byte 8 8) (byte 8 16))))
306 ;;; Same as simple, but with direction bit
307 (define-instruction-format (simple-dir 8 :include simple
)
308 (op :field
(byte 6 2))
309 (dir :field
(byte 1 1)))
311 ;;; Same as simple, but with the immediate value occurring by default,
312 ;;; and with an appropiate printer.
313 (define-instruction-format (accum-imm 8
315 :default-printer
'(:name
316 :tab accum
", " imm
))
317 (imm :type
'imm-data
))
319 (define-instruction-format (reg-no-width 8 :default-printer
'(:name
:tab reg
))
320 (op :field
(byte 5 3))
321 (reg :field
(byte 3 0) :type
'word-reg
)
323 (accum :type
'word-accum
)
326 ;;; adds a width field to reg-no-width
327 (define-instruction-format (reg 8 :default-printer
'(:name
:tab reg
))
328 (op :field
(byte 4 4))
329 (width :field
(byte 1 3) :type
'width
)
330 (reg :field
(byte 3 0) :type
'reg
)
336 ;;; Same as reg, but with direction bit
337 (define-instruction-format (reg-dir 8 :include reg
)
338 (op :field
(byte 3 5))
339 (dir :field
(byte 1 4)))
341 (define-instruction-format (reg-reg/mem
16
343 `(:name
:tab reg
", " reg
/mem
))
344 (op :field
(byte 7 1))
345 (width :field
(byte 1 0) :type
'width
)
346 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
348 (reg :field
(byte 3 11) :type
'reg
)
352 ;;; same as reg-reg/mem, but with direction bit
353 (define-instruction-format (reg-reg/mem-dir
16
358 ,(swap-if 'dir
'reg
/mem
", " 'reg
)))
359 (op :field
(byte 6 2))
360 (dir :field
(byte 1 1)))
362 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
363 (define-instruction-format (reg/mem
16 :default-printer
'(:name
:tab reg
/mem
))
364 (op :fields
(list (byte 7 1) (byte 3 11)))
365 (width :field
(byte 1 0) :type
'width
)
366 (reg/mem
:fields
(list (byte 2 14) (byte 3 8))
367 :type
'sized-reg
/mem
)
371 ;;; Same as reg/mem, but with the immediate value occurring by default,
372 ;;; and with an appropiate printer.
373 (define-instruction-format (reg/mem-imm
16
376 '(:name
:tab reg
/mem
", " imm
))
377 (reg/mem
:type
'sized-reg
/mem
)
378 (imm :type
'imm-data
))
380 ;;; Same as reg/mem, but with using the accumulator in the default printer
381 (define-instruction-format
383 :include reg
/mem
:default-printer
'(:name
:tab accum
", " reg
/mem
))
384 (reg/mem
:type
'reg
/mem
) ; don't need a size
385 (accum :type
'accum
))
387 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
388 (define-instruction-format (ext-reg-reg/mem
24
390 `(:name
:tab reg
", " reg
/mem
))
391 (prefix :field
(byte 8 0) :value
#b00001111
)
392 (op :field
(byte 7 9))
393 (width :field
(byte 1 8) :type
'width
)
394 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
396 (reg :field
(byte 3 19) :type
'reg
)
400 (define-instruction-format (ext-reg-reg/mem-no-width
24
402 `(:name
:tab reg
", " reg
/mem
))
403 (prefix :field
(byte 8 0) :value
#b00001111
)
404 (op :field
(byte 8 8))
405 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
407 (reg :field
(byte 3 19) :type
'reg
)
411 (define-instruction-format (ext-reg/mem-no-width
24
413 `(:name
:tab reg
/mem
))
414 (prefix :field
(byte 8 0) :value
#b00001111
)
415 (op :fields
(list (byte 8 8) (byte 3 19)))
416 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
419 ;;; reg-no-width with #x0f prefix
420 (define-instruction-format (ext-reg-no-width 16
421 :default-printer
'(:name
:tab reg
))
422 (prefix :field
(byte 8 0) :value
#b00001111
)
423 (op :field
(byte 5 11))
424 (reg :field
(byte 3 8) :type
'reg
))
426 ;;; Same as reg/mem, but with a prefix of #b00001111
427 (define-instruction-format (ext-reg/mem
24
428 :default-printer
'(:name
:tab reg
/mem
))
429 (prefix :field
(byte 8 0) :value
#b00001111
)
430 (op :fields
(list (byte 7 9) (byte 3 19)))
431 (width :field
(byte 1 8) :type
'width
)
432 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
433 :type
'sized-reg
/mem
)
437 (define-instruction-format (ext-reg/mem-imm
24
440 '(:name
:tab reg
/mem
", " imm
))
441 (imm :type
'imm-data
))
443 (define-instruction-format (ext-reg/mem-no-width
+imm8
24
444 :include ext-reg
/mem-no-width
446 '(:name
:tab reg
/mem
", " imm
))
447 (imm :type
'imm-byte
))
449 ;;;; This section was added by jrd, for fp instructions.
451 ;;; regular fp inst to/from registers/memory
452 (define-instruction-format (floating-point 16
454 `(:name
:tab reg
/mem
))
455 (prefix :field
(byte 5 3) :value
#b11011
)
456 (op :fields
(list (byte 3 0) (byte 3 11)))
457 (reg/mem
:fields
(list (byte 2 14) (byte 3 8)) :type
'reg
/mem
))
459 ;;; fp insn to/from fp reg
460 (define-instruction-format (floating-point-fp 16
461 :default-printer
`(:name
:tab fp-reg
))
462 (prefix :field
(byte 5 3) :value
#b11011
)
463 (suffix :field
(byte 2 14) :value
#b11
)
464 (op :fields
(list (byte 3 0) (byte 3 11)))
465 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
467 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
468 (define-instruction-format (floating-point-fp-d 16
470 `(:name
:tab
,(swap-if 'd
"ST0" ", " 'fp-reg
)))
471 (prefix :field
(byte 5 3) :value
#b11011
)
472 (suffix :field
(byte 2 14) :value
#b11
)
473 (op :fields
(list (byte 2 0) (byte 3 11)))
474 (d :field
(byte 1 2))
475 (fp-reg :field
(byte 3 8) :type
'fp-reg
))
478 ;;; (added by (?) pfw)
479 ;;; fp no operand isns
480 (define-instruction-format (floating-point-no 16 :default-printer
'(:name
))
481 (prefix :field
(byte 8 0) :value
#b11011001
)
482 (suffix :field
(byte 3 13) :value
#b111
)
483 (op :field
(byte 5 8)))
485 (define-instruction-format (floating-point-3 16 :default-printer
'(:name
))
486 (prefix :field
(byte 5 3) :value
#b11011
)
487 (suffix :field
(byte 2 14) :value
#b11
)
488 (op :fields
(list (byte 3 0) (byte 6 8))))
490 (define-instruction-format (floating-point-5 16 :default-printer
'(:name
))
491 (prefix :field
(byte 8 0) :value
#b11011011
)
492 (suffix :field
(byte 3 13) :value
#b111
)
493 (op :field
(byte 5 8)))
495 (define-instruction-format (floating-point-st 16 :default-printer
'(:name
))
496 (prefix :field
(byte 8 0) :value
#b11011111
)
497 (suffix :field
(byte 3 13) :value
#b111
)
498 (op :field
(byte 5 8)))
500 (define-instruction-format (string-op 8
502 :default-printer
'(:name width
)))
504 (define-instruction-format (short-cond-jump 16)
505 (op :field
(byte 4 4))
506 (cc :field
(byte 4 0) :type
'condition-code
)
507 (label :field
(byte 8 8) :type
'displacement
))
509 (define-instruction-format (short-jump 16 :default-printer
'(:name
:tab label
))
510 (const :field
(byte 4 4) :value
#b1110
)
511 (op :field
(byte 4 0))
512 (label :field
(byte 8 8) :type
'displacement
))
514 (define-instruction-format (near-cond-jump 16)
515 (op :fields
(list (byte 8 0) (byte 4 12)) :value
'(#b00001111
#b1000
))
516 (cc :field
(byte 4 8) :type
'condition-code
)
517 ;; XXX: the following comment is bogus. x86-64 has 48-bit instructions.
518 ;; The disassembler currently doesn't let you have an instruction > 32 bits
519 ;; long, so we fake it by using a prefilter to read the offset.
520 (label :type
'displacement
521 :prefilter
(lambda (dstate)
522 (read-signed-suffix 32 dstate
))))
524 (define-instruction-format (near-jump 8 :default-printer
'(:name
:tab label
))
525 (op :field
(byte 8 0))
526 ;; XXX: the following comment is bogus. x86-64 has 48-bit instructions.
527 ;; The disassembler currently doesn't let you have an instruction > 32 bits
528 ;; long, so we fake it by using a prefilter to read the address.
529 (label :type
'displacement
530 :prefilter
(lambda (dstate)
531 (read-signed-suffix 32 dstate
))))
534 (define-instruction-format (cond-set 24
535 :default-printer
'('set cc
:tab reg
/mem
))
536 (prefix :field
(byte 8 0) :value
#b00001111
)
537 (op :field
(byte 4 12) :value
#b1001
)
538 (cc :field
(byte 4 8) :type
'condition-code
)
539 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
541 (reg :field
(byte 3 19) :value
#b000
))
543 (define-instruction-format (cond-move 24
545 '('cmov cc
:tab reg
", " reg
/mem
))
546 (prefix :field
(byte 8 0) :value
#b00001111
)
547 (op :field
(byte 4 12) :value
#b0100
)
548 (cc :field
(byte 4 8) :type
'condition-code
)
549 (reg/mem
:fields
(list (byte 2 22) (byte 3 16))
551 (reg :field
(byte 3 19) :type
'reg
))
553 (define-instruction-format (enter-format 32
554 :default-printer
'(:name
556 (:unless
(:constant
0)
558 (op :field
(byte 8 0))
559 (disp :field
(byte 16 8))
560 (level :field
(byte 8 24)))
562 (define-instruction-format (prefetch 24 :default-printer
'(:name
", " reg
/mem
))
563 (prefix :field
(byte 8 0) :value
#b00001111
)
564 (op :field
(byte 8 8) :value
#b00011000
)
565 (reg/mem
:fields
(list (byte 2 22) (byte 3 16)) :type
'byte-reg
/mem
)
566 (reg :field
(byte 3 19) :type
'reg
))
568 ;;; Single byte instruction with an immediate byte argument.
569 (define-instruction-format (byte-imm 16 :default-printer
'(:name
:tab code
))
570 (op :field
(byte 8 0))
571 (code :field
(byte 8 8) :reader byte-imm-code
))
573 ;;; Two byte instruction with an immediate byte argument.
575 (define-instruction-format (word-imm 24 :default-printer
'(:name
:tab code
))
576 (op :field
(byte 16 0))
577 (code :field
(byte 8 16) :reader word-imm-code
))
580 ;;;; primitive emitters
582 (define-bitfield-emitter emit-word
16
585 (define-bitfield-emitter emit-dword
32
588 (define-bitfield-emitter emit-mod-reg-r
/m-byte
8
589 (byte 2 6) (byte 3 3) (byte 3 0))
591 (define-bitfield-emitter emit-sib-byte
8
592 (byte 2 6) (byte 3 3) (byte 3 0))
596 (defun emit-absolute-fixup (segment fixup
)
597 (note-fixup segment
:absolute fixup
)
598 (let ((offset (fixup-offset fixup
)))
600 (emit-back-patch segment
601 4 ; FIXME: n-word-bytes
602 (lambda (segment posn
)
603 (declare (ignore posn
))
605 (- (+ (component-header-length)
606 (or (label-position offset
)
608 other-pointer-lowtag
))))
609 (emit-dword segment
(or offset
0)))))
611 (defun emit-relative-fixup (segment fixup
)
612 (note-fixup segment
:relative fixup
)
613 (emit-dword segment
(or (fixup-offset fixup
) 0)))
615 ;;;; the effective-address (ea) structure
617 (declaim (ftype (sfunction (tn) (mod 8)) reg-tn-encoding
))
618 (defun reg-tn-encoding (tn)
619 (declare (type tn tn
))
620 (aver (eq (sb-name (sc-sb (tn-sc tn
))) 'registers
))
621 (let ((offset (tn-offset tn
)))
622 (logior (ash (logand offset
1) 2)
625 (defun emit-byte+reg
(seg byte reg
)
626 (emit-byte seg
(+ byte
(reg-tn-encoding reg
))))
628 (defstruct (ea (:constructor make-ea
(size &key base index scale disp
))
630 (size nil
:type
(member :byte
:word
:dword
))
631 (base nil
:type
(or tn null
))
632 (index nil
:type
(or tn null
))
633 (scale 1 :type
(member 1 2 4 8))
634 (disp 0 :type
(or (unsigned-byte 32) (signed-byte 32) fixup
)))
635 (defmethod print-object ((ea ea
) stream
)
636 (cond ((or *print-escape
* *print-readably
*)
637 (print-unreadable-object (ea stream
:type t
)
639 "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
643 (let ((scale (ea-scale ea
)))
644 (if (= scale
1) nil scale
))
647 (format stream
"~A PTR [" (symbol-name (ea-size ea
)))
649 (write-string (sb!c
::location-print-name
(ea-base ea
)) stream
)
651 (write-string "+" stream
)))
653 (write-string (sb!c
::location-print-name
(ea-index ea
)) stream
))
654 (unless (= (ea-scale ea
) 1)
655 (format stream
"*~A" (ea-scale ea
)))
656 (typecase (ea-disp ea
)
659 (format stream
"~@D" (ea-disp ea
)))
661 (format stream
"+~A" (ea-disp ea
))))
662 (write-char #\
] stream
))))
664 (defun emit-ea (segment thing reg
&optional allow-constants
)
667 (ecase (sb-name (sc-sb (tn-sc thing
)))
669 (emit-mod-reg-r/m-byte segment
#b11 reg
(reg-tn-encoding thing
)))
671 ;; Convert stack tns into an index off of EBP.
672 (let ((disp (frame-byte-offset (tn-offset thing
))))
673 (cond ((<= -
128 disp
127)
674 (emit-mod-reg-r/m-byte segment
#b01 reg
#b101
)
675 (emit-byte segment disp
))
677 (emit-mod-reg-r/m-byte segment
#b10 reg
#b101
)
678 (emit-dword segment disp
)))))
680 (unless allow-constants
682 "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
683 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
684 (emit-absolute-fixup segment
687 (- (* (tn-offset thing
) n-word-bytes
)
688 other-pointer-lowtag
))))))
690 (let* ((base (ea-base thing
))
691 (index (ea-index thing
))
692 (scale (ea-scale thing
))
693 (disp (ea-disp thing
))
694 (mod (cond ((or (null base
)
696 (not (= (reg-tn-encoding base
) #b101
))))
698 ((and (fixnump disp
) (<= -
128 disp
127))
702 (r/m
(cond (index #b100
)
704 (t (reg-tn-encoding base
)))))
705 (when (and (fixup-p disp
)
706 (label-p (fixup-offset disp
)))
709 (return-from emit-ea
(emit-ea segment disp reg allow-constants
)))
710 (emit-mod-reg-r/m-byte segment mod reg r
/m
)
712 (let ((ss (1- (integer-length scale
)))
713 (index (if (null index
)
715 (let ((index (reg-tn-encoding index
)))
717 (error "can't index off of ESP")
719 (base (if (null base
)
721 (reg-tn-encoding base
))))
722 (emit-sib-byte segment ss index base
)))
724 (emit-byte segment disp
))
725 ((or (= mod
#b10
) (null base
))
727 (emit-absolute-fixup segment disp
)
728 (emit-dword segment disp
))))))
730 (emit-mod-reg-r/m-byte segment
#b00 reg
#b101
)
731 (emit-absolute-fixup segment thing
))))
733 (defun fp-reg-tn-p (thing)
735 (eq (sb-name (sc-sb (tn-sc thing
))) 'float-registers
)))
737 ;;; like the above, but for fp-instructions--jrd
738 (defun emit-fp-op (segment thing op
)
739 (if (fp-reg-tn-p thing
)
740 (emit-byte segment
(dpb op
(byte 3 3) (dpb (tn-offset thing
)
743 (emit-ea segment thing op
)))
745 (defun byte-reg-p (thing)
747 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
748 (member (sc-name (tn-sc thing
)) *byte-sc-names
*)
751 (defun byte-ea-p (thing)
753 (ea (eq (ea-size thing
) :byte
))
755 (and (member (sc-name (tn-sc thing
)) *byte-sc-names
*) t
))
758 (defun word-reg-p (thing)
760 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
761 (member (sc-name (tn-sc thing
)) *word-sc-names
*)
764 (defun word-ea-p (thing)
766 (ea (eq (ea-size thing
) :word
))
767 (tn (and (member (sc-name (tn-sc thing
)) *word-sc-names
*) t
))
770 (defun dword-reg-p (thing)
772 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)
773 (member (sc-name (tn-sc thing
)) *dword-sc-names
*)
776 (defun dword-ea-p (thing)
778 (ea (eq (ea-size thing
) :dword
))
780 (and (member (sc-name (tn-sc thing
)) *dword-sc-names
*) t
))
783 (defun register-p (thing)
785 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)))
787 (defun accumulator-p (thing)
788 (and (register-p thing
)
789 (= (tn-offset thing
) 0)))
793 (defconstant +operand-size-prefix-byte
+ #b01100110
)
795 (defun maybe-emit-operand-size-prefix (segment size
)
796 (unless (or (eq size
:byte
) (eq size
+default-operand-size
+))
797 (emit-byte segment
+operand-size-prefix-byte
+)))
799 (defun operand-size (thing)
802 ;; FIXME: might as well be COND instead of having to use #. readmacro
803 ;; to hack up the code
804 (case (sc-name (tn-sc thing
))
811 ;; added by jrd: float-registers is a separate size (?)
812 (#.sb
!vm
::*float-sc-names
*
814 (#.sb
!vm
::*double-sc-names
*
817 (error "can't tell the size of ~S ~S" thing
(sc-name (tn-sc thing
))))))
823 (defun matching-operand-size (dst src
)
824 (let ((dst-size (operand-size dst
))
825 (src-size (operand-size src
)))
828 (if (eq dst-size src-size
)
830 (error "size mismatch: ~S is a ~S and ~S is a ~S."
831 dst dst-size src src-size
))
835 (error "can't tell the size of either ~S or ~S" dst src
)))))
837 (defun emit-sized-immediate (segment size value
)
840 (emit-byte segment value
))
842 (emit-word segment value
))
844 (emit-dword segment value
))))
848 (define-instruction x66
(segment)
849 (:printer x66
() nil
:print-name nil
))
851 (defun emit-prefix (segment name
)
856 (emit-byte segment
#xf0
))
858 (emit-byte segment
#x64
))
860 (emit-byte segment
#x65
))))
862 (define-instruction fs
(segment)
863 (:printer seg
((fsgs #b0
)) nil
:print-name nil
))
865 (define-instruction gs
(segment)
866 (:printer seg
((fsgs #b1
)) nil
:print-name nil
))
868 (define-instruction lock
(segment)
869 (:printer byte
((op #b11110000
)) nil
))
871 (define-instruction rep
(segment)
873 (emit-byte segment
#b11110011
)))
875 (define-instruction repe
(segment)
876 (:printer byte
((op #b11110011
)) nil
)
878 (emit-byte segment
#b11110011
)))
880 (define-instruction repne
(segment)
881 (:printer byte
((op #b11110010
)) nil
)
883 (emit-byte segment
#b11110010
)))
885 ;;;; general data transfer
887 (define-instruction mov
(segment dst src
&optional prefix
)
888 ;; immediate to register
889 (:printer reg
((op #b1011
) (imm nil
:type
'imm-data
))
890 '(:name
:tab reg
", " imm
))
891 ;; absolute mem to/from accumulator
892 (:printer simple-dir
((op #b101000
) (imm nil
:type
'imm-addr
))
893 `(:name
:tab
,(swap-if 'dir
'accum
", " '("[" imm
"]"))))
894 ;; register to/from register/memory
895 (:printer reg-reg
/mem-dir
((op #b100010
)))
896 ;; immediate to register/memory
897 (:printer reg
/mem-imm
((op '(#b1100011
#b000
))))
900 (emit-prefix segment prefix
)
901 (let ((size (matching-operand-size dst src
)))
902 (maybe-emit-operand-size-prefix segment size
)
903 (cond ((register-p dst
)
904 (cond ((or (integerp src
)
906 (eq (fixup-flavor src
) :symbol-tls-index
)))
907 (emit-byte+reg segment
(if (eq size
:byte
) #xB0
#xB8
) dst
)
909 (emit-absolute-fixup segment src
)
910 (emit-sized-immediate segment size src
)))
911 ((and (fixup-p src
) (accumulator-p dst
))
916 (emit-absolute-fixup segment src
))
922 (emit-ea segment src
(reg-tn-encoding dst
) t
))))
923 ((and (fixup-p dst
) (accumulator-p src
))
924 (emit-byte segment
(if (eq size
:byte
) #b10100010
#b10100011
))
925 (emit-absolute-fixup segment dst
))
927 (emit-byte segment
(if (eq size
:byte
) #b11000110
#b11000111
))
928 (emit-ea segment dst
#b000
)
929 (emit-sized-immediate segment size src
))
931 (emit-byte segment
(if (eq size
:byte
) #b10001000
#b10001001
))
932 (emit-ea segment dst
(reg-tn-encoding src
)))
934 (aver (eq size
:dword
))
935 (emit-byte segment
#b11000111
)
936 (emit-ea segment dst
#b000
)
937 (emit-absolute-fixup segment src
))
939 (error "bogus arguments to MOV: ~S ~S" dst src
))))))
941 (defun emit-move-with-extension (segment dst src opcode
)
942 (aver (register-p dst
))
943 (let ((dst-size (operand-size dst
))
944 (src-size (operand-size src
)))
947 (aver (eq src-size
:byte
))
948 (maybe-emit-operand-size-prefix segment
:word
)
949 (emit-byte segment
#b00001111
)
950 (emit-byte segment opcode
)
951 (emit-ea segment src
(reg-tn-encoding dst
)))
955 (maybe-emit-operand-size-prefix segment
:dword
)
956 (emit-byte segment
#b00001111
)
957 (emit-byte segment opcode
)
958 (emit-ea segment src
(reg-tn-encoding dst
)))
960 (emit-byte segment
#b00001111
)
961 (emit-byte segment
(logior opcode
1))
962 (emit-ea segment src
(reg-tn-encoding dst
))))))))
964 (define-instruction movsx
(segment dst src
)
965 (:printer ext-reg-reg
/mem
((op #b1011111
)
966 (reg nil
:type
'word-reg
)
967 (reg/mem nil
:type
'sized-reg
/mem
)))
968 (:emitter
(emit-move-with-extension segment dst src
#b10111110
)))
970 (define-instruction movzx
(segment dst src
)
971 (:printer ext-reg-reg
/mem
((op #b1011011
)
972 (reg nil
:type
'word-reg
)
973 (reg/mem nil
:type
'sized-reg
/mem
)))
974 (:emitter
(emit-move-with-extension segment dst src
#b10110110
)))
976 (define-instruction push
(segment src
&optional prefix
)
978 (:printer reg-no-width
((op #b01010
)))
980 (:printer reg
/mem
((op '(#b1111111
#b110
)) (width 1)))
982 (:printer byte
((op #b01101010
) (imm nil
:type
'signed-imm-byte
))
984 (:printer byte
((op #b01101000
) (imm nil
:type
'imm-word
))
986 ;; ### segment registers?
989 (emit-prefix segment prefix
)
990 (cond ((integerp src
)
991 (cond ((<= -
128 src
127)
992 (emit-byte segment
#b01101010
)
993 (emit-byte segment src
))
995 (emit-byte segment
#b01101000
)
996 (emit-dword segment src
))))
998 ;; Interpret the fixup as an immediate dword to push.
999 (emit-byte segment
#b01101000
)
1000 (emit-absolute-fixup segment src
))
1002 (let ((size (operand-size src
)))
1003 (aver (not (eq size
:byte
)))
1004 (maybe-emit-operand-size-prefix segment size
)
1005 (cond ((register-p src
)
1006 (emit-byte+reg segment
#x50 src
))
1008 (emit-byte segment
#b11111111
)
1009 (emit-ea segment src
#b110 t
))))))))
1011 (define-instruction pusha
(segment)
1012 (:printer byte
((op #b01100000
)))
1014 (emit-byte segment
#b01100000
)))
1016 (define-instruction pop
(segment dst
)
1017 (:printer reg-no-width
((op #b01011
)))
1018 (:printer reg
/mem
((op '(#b1000111
#b000
)) (width 1)))
1020 (let ((size (operand-size dst
)))
1021 (aver (not (eq size
:byte
)))
1022 (maybe-emit-operand-size-prefix segment size
)
1023 (cond ((register-p dst
)
1024 (emit-byte+reg segment
#x58 dst
))
1026 (emit-byte segment
#b10001111
)
1027 (emit-ea segment dst
#b000
))))))
1029 (define-instruction popa
(segment)
1030 (:printer byte
((op #b01100001
)))
1032 (emit-byte segment
#b01100001
)))
1034 (define-instruction xchg
(segment operand1 operand2
)
1035 ;; Register with accumulator.
1036 (:printer reg-no-width
((op #b10010
)) '(:name
:tab accum
", " reg
))
1037 ;; Register/Memory with Register.
1038 (:printer reg-reg
/mem
((op #b1000011
)))
1040 (let ((size (matching-operand-size operand1 operand2
)))
1041 (maybe-emit-operand-size-prefix segment size
)
1042 (labels ((xchg-acc-with-something (acc something
)
1043 (if (and (not (eq size
:byte
)) (register-p something
))
1044 (emit-byte+reg segment
#x90 something
)
1045 (xchg-reg-with-something acc something
)))
1046 (xchg-reg-with-something (reg something
)
1047 (emit-byte segment
(if (eq size
:byte
) #b10000110
#b10000111
))
1048 (emit-ea segment something
(reg-tn-encoding reg
))))
1049 (cond ((accumulator-p operand1
)
1050 (xchg-acc-with-something operand1 operand2
))
1051 ((accumulator-p operand2
)
1052 (xchg-acc-with-something operand2 operand1
))
1053 ((register-p operand1
)
1054 (xchg-reg-with-something operand1 operand2
))
1055 ((register-p operand2
)
1056 (xchg-reg-with-something operand2 operand1
))
1058 (error "bogus args to XCHG: ~S ~S" operand1 operand2
)))))))
1060 (define-instruction lea
(segment dst src
)
1061 (:printer reg-reg
/mem
((op #b1000110
) (width 1)))
1063 (aver (dword-reg-p dst
))
1064 (emit-byte segment
#b10001101
)
1065 (emit-ea segment src
(reg-tn-encoding dst
))))
1067 (define-instruction cmpxchg
(segment dst src
&optional prefix
)
1068 ;; Register/Memory with Register.
1069 (:printer ext-reg-reg
/mem
((op #b1011000
)) '(:name
:tab reg
/mem
", " reg
))
1071 (aver (register-p src
))
1072 (emit-prefix segment prefix
)
1073 (let ((size (matching-operand-size src dst
)))
1074 (maybe-emit-operand-size-prefix segment size
)
1075 (emit-byte segment
#b00001111
)
1076 (emit-byte segment
(if (eq size
:byte
) #b10110000
#b10110001
))
1077 (emit-ea segment dst
(reg-tn-encoding src
)))))
1079 (define-instruction cmpxchg8b
(segment mem
&optional prefix
)
1080 (:printer ext-reg
/mem-no-width
((op '(#xC7
1))))
1082 (aver (not (register-p mem
)))
1083 (emit-prefix segment prefix
)
1084 (emit-byte segment
#x0F
)
1085 (emit-byte segment
#xC7
)
1086 (emit-ea segment mem
1)))
1088 (define-instruction rdrand
(segment dst
)
1089 (:printer ext-reg
/mem-no-width
1092 (aver (register-p dst
))
1093 (maybe-emit-operand-size-prefix segment
(operand-size dst
))
1094 (emit-byte segment
#x0F
)
1095 (emit-byte segment
#xC7
)
1096 (emit-ea segment dst
6)))
1098 (define-instruction pause
(segment)
1099 (:printer two-bytes
((op '(#xf3
#x90
))))
1101 (emit-byte segment
#xf3
)
1102 (emit-byte segment
#x90
)))
1104 ;;;; flag control instructions
1106 ;;; CLC -- Clear Carry Flag.
1107 (define-instruction clc
(segment)
1108 (:printer byte
((op #b11111000
)))
1110 (emit-byte segment
#b11111000
)))
1112 ;;; CLD -- Clear Direction Flag.
1113 (define-instruction cld
(segment)
1114 (:printer byte
((op #b11111100
)))
1116 (emit-byte segment
#b11111100
)))
1118 ;;; CLI -- Clear Iterrupt Enable Flag.
1119 (define-instruction cli
(segment)
1120 (:printer byte
((op #b11111010
)))
1122 (emit-byte segment
#b11111010
)))
1124 ;;; CMC -- Complement Carry Flag.
1125 (define-instruction cmc
(segment)
1126 (:printer byte
((op #b11110101
)))
1128 (emit-byte segment
#b11110101
)))
1130 ;;; LAHF -- Load AH into flags.
1131 (define-instruction lahf
(segment)
1132 (:printer byte
((op #b10011111
)))
1134 (emit-byte segment
#b10011111
)))
1136 ;;; POPF -- Pop flags.
1137 (define-instruction popf
(segment)
1138 (:printer byte
((op #b10011101
)))
1140 (emit-byte segment
#b10011101
)))
1142 ;;; PUSHF -- push flags.
1143 (define-instruction pushf
(segment)
1144 (:printer byte
((op #b10011100
)))
1146 (emit-byte segment
#b10011100
)))
1148 ;;; SAHF -- Store AH into flags.
1149 (define-instruction sahf
(segment)
1150 (:printer byte
((op #b10011110
)))
1152 (emit-byte segment
#b10011110
)))
1154 ;;; STC -- Set Carry Flag.
1155 (define-instruction stc
(segment)
1156 (:printer byte
((op #b11111001
)))
1158 (emit-byte segment
#b11111001
)))
1160 ;;; STD -- Set Direction Flag.
1161 (define-instruction std
(segment)
1162 (:printer byte
((op #b11111101
)))
1164 (emit-byte segment
#b11111101
)))
1166 ;;; STI -- Set Interrupt Enable Flag.
1167 (define-instruction sti
(segment)
1168 (:printer byte
((op #b11111011
)))
1170 (emit-byte segment
#b11111011
)))
1174 (defun emit-random-arith-inst (name segment dst src opcode
1175 &optional allow-constants
)
1176 (let ((size (matching-operand-size dst src
)))
1177 (maybe-emit-operand-size-prefix segment size
)
1180 (cond ((and (not (eq size
:byte
)) (<= -
128 src
127))
1181 (emit-byte segment
#b10000011
)
1182 (emit-ea segment dst opcode allow-constants
)
1183 (emit-byte segment src
))
1184 ((accumulator-p dst
)
1191 (emit-sized-immediate segment size src
))
1193 (emit-byte segment
(if (eq size
:byte
) #b10000000
#b10000001
))
1194 (emit-ea segment dst opcode allow-constants
)
1195 (emit-sized-immediate segment size src
))))
1200 (if (eq size
:byte
) #b00000000
#b00000001
)))
1201 (emit-ea segment dst
(reg-tn-encoding src
) allow-constants
))
1206 (if (eq size
:byte
) #b00000010
#b00000011
)))
1207 (emit-ea segment src
(reg-tn-encoding dst
) allow-constants
))
1209 (error "bogus operands to ~A" name
)))))
1211 (macrolet ((define (name subop
&optional allow-constants
)
1212 `(define-instruction ,name
(segment dst src
&optional prefix
)
1213 (:printer accum-imm
((op ,(dpb subop
(byte 3 2) #b0000010
))))
1214 (:printer reg
/mem-imm
((op '(#b1000000
,subop
))))
1215 (:printer reg
/mem-imm
((op '(#b1000001
,subop
))
1216 (imm nil
:type
'signed-imm-byte
)))
1217 (:printer reg-reg
/mem-dir
((op ,(dpb subop
(byte 3 1) #b000000
))))
1219 (emit-prefix segment prefix
)
1220 (emit-random-arith-inst ,(string name
) segment dst src
,subop
1221 ,allow-constants
)))))
1226 (define cmp
#b111 t
)
1231 (define-instruction inc
(segment dst
)
1233 (:printer reg-no-width
((op #b01000
)))
1235 (:printer reg
/mem
((op '(#b1111111
#b000
))))
1237 (let ((size (operand-size dst
)))
1238 (maybe-emit-operand-size-prefix segment size
)
1239 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1240 (emit-byte+reg segment
#x40 dst
))
1242 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1243 (emit-ea segment dst
#b000
))))))
1245 (define-instruction dec
(segment dst
)
1247 (:printer reg-no-width
((op #b01001
)))
1249 (:printer reg
/mem
((op '(#b1111111
#b001
))))
1251 (let ((size (operand-size dst
)))
1252 (maybe-emit-operand-size-prefix segment size
)
1253 (cond ((and (not (eq size
:byte
)) (register-p dst
))
1254 (emit-byte+reg segment
#x48 dst
))
1256 (emit-byte segment
(if (eq size
:byte
) #b11111110
#b11111111
))
1257 (emit-ea segment dst
#b001
))))))
1259 (define-instruction neg
(segment dst
)
1260 (:printer reg
/mem
((op '(#b1111011
#b011
))))
1262 (let ((size (operand-size dst
)))
1263 (maybe-emit-operand-size-prefix segment size
)
1264 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1265 (emit-ea segment dst
#b011
))))
1267 (define-instruction aaa
(segment)
1268 (:printer byte
((op #b00110111
)))
1270 (emit-byte segment
#b00110111
)))
1272 (define-instruction aas
(segment)
1273 (:printer byte
((op #b00111111
)))
1275 (emit-byte segment
#b00111111
)))
1277 (define-instruction daa
(segment)
1278 (:printer byte
((op #b00100111
)))
1280 (emit-byte segment
#b00100111
)))
1282 (define-instruction das
(segment)
1283 (:printer byte
((op #b00101111
)))
1285 (emit-byte segment
#b00101111
)))
1287 (define-instruction mul
(segment dst src
)
1288 (:printer accum-reg
/mem
((op '(#b1111011
#b100
))))
1290 (let ((size (matching-operand-size dst src
)))
1291 (aver (accumulator-p dst
))
1292 (maybe-emit-operand-size-prefix segment size
)
1293 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1294 (emit-ea segment src
#b100
))))
1296 (define-instruction imul
(segment dst
&optional src1 src2
)
1297 (:printer accum-reg
/mem
((op '(#b1111011
#b101
))))
1298 (:printer ext-reg-reg
/mem
((op #b1010111
)))
1299 (:printer reg-reg
/mem
((op #b0110100
) (width 1)
1300 (imm nil
:type
'signed-imm-word
))
1301 '(:name
:tab reg
", " reg
/mem
", " imm
))
1302 (:printer reg-reg
/mem
((op #b0110101
) (width 1)
1303 (imm nil
:type
'signed-imm-byte
))
1304 '(:name
:tab reg
", " reg
/mem
", " imm
))
1306 (flet ((r/m-with-immed-to-reg
(reg r
/m immed
)
1307 (let* ((size (matching-operand-size reg r
/m
))
1308 (sx (and (not (eq size
:byte
)) (<= -
128 immed
127))))
1309 (maybe-emit-operand-size-prefix segment size
)
1310 (emit-byte segment
(if sx
#b01101011
#b01101001
))
1311 (emit-ea segment r
/m
(reg-tn-encoding reg
))
1313 (emit-byte segment immed
)
1314 (emit-sized-immediate segment size immed
)))))
1316 (r/m-with-immed-to-reg dst src1 src2
))
1319 (r/m-with-immed-to-reg dst dst src1
)
1320 (let ((size (matching-operand-size dst src1
)))
1321 (maybe-emit-operand-size-prefix segment size
)
1322 (emit-byte segment
#b00001111
)
1323 (emit-byte segment
#b10101111
)
1324 (emit-ea segment src1
(reg-tn-encoding dst
)))))
1326 (let ((size (operand-size dst
)))
1327 (maybe-emit-operand-size-prefix segment size
)
1328 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1329 (emit-ea segment dst
#b101
)))))))
1331 (define-instruction div
(segment dst src
)
1332 (:printer accum-reg
/mem
((op '(#b1111011
#b110
))))
1334 (let ((size (matching-operand-size dst src
)))
1335 (aver (accumulator-p dst
))
1336 (maybe-emit-operand-size-prefix segment size
)
1337 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1338 (emit-ea segment src
#b110
))))
1340 (define-instruction idiv
(segment dst src
)
1341 (:printer accum-reg
/mem
((op '(#b1111011
#b111
))))
1343 (let ((size (matching-operand-size dst src
)))
1344 (aver (accumulator-p dst
))
1345 (maybe-emit-operand-size-prefix segment size
)
1346 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1347 (emit-ea segment src
#b111
))))
1349 (define-instruction aad
(segment)
1350 (:printer two-bytes
((op '(#b11010101
#b00001010
))))
1352 (emit-byte segment
#b11010101
)
1353 (emit-byte segment
#b00001010
)))
1355 (define-instruction aam
(segment)
1356 (:printer two-bytes
((op '(#b11010100
#b00001010
))))
1358 (emit-byte segment
#b11010100
)
1359 (emit-byte segment
#b00001010
)))
1361 (define-instruction bswap
(segment dst
)
1362 (:printer ext-reg-no-width
((op #b11001
)))
1364 (emit-byte segment
#x0f
)
1365 (emit-byte+reg segment
#xC8 dst
)))
1367 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1368 (define-instruction cbw
(segment)
1369 (:printer two-bytes
((op '(#b01100110
#b10011000
))))
1371 (maybe-emit-operand-size-prefix segment
:word
)
1372 (emit-byte segment
#b10011000
)))
1374 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1375 (define-instruction cwde
(segment)
1376 (:printer byte
((op #b10011000
)))
1378 (maybe-emit-operand-size-prefix segment
:dword
)
1379 (emit-byte segment
#b10011000
)))
1381 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1382 (define-instruction cwd
(segment)
1383 (:printer two-bytes
((op '(#b01100110
#b10011001
))))
1385 (maybe-emit-operand-size-prefix segment
:word
)
1386 (emit-byte segment
#b10011001
)))
1388 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1389 (define-instruction cdq
(segment)
1390 (:printer byte
((op #b10011001
)))
1392 (maybe-emit-operand-size-prefix segment
:dword
)
1393 (emit-byte segment
#b10011001
)))
1395 (define-instruction xadd
(segment dst src
&optional prefix
)
1396 ;; Register/Memory with Register.
1397 (:printer ext-reg-reg
/mem
((op #b1100000
)) '(:name
:tab reg
/mem
", " reg
))
1399 (aver (register-p src
))
1400 (emit-prefix segment prefix
)
1401 (let ((size (matching-operand-size src dst
)))
1402 (maybe-emit-operand-size-prefix segment size
)
1403 (emit-byte segment
#b00001111
)
1404 (emit-byte segment
(if (eq size
:byte
) #b11000000
#b11000001
))
1405 (emit-ea segment dst
(reg-tn-encoding src
)))))
1410 (defun emit-shift-inst (segment dst amount opcode
)
1411 (let ((size (operand-size dst
)))
1412 (maybe-emit-operand-size-prefix segment size
)
1413 (multiple-value-bind (major-opcode immed
)
1415 (:cl
(values #b11010010 nil
))
1416 (1 (values #b11010000 nil
))
1417 (t (values #b11000000 t
)))
1419 (if (eq size
:byte
) major-opcode
(logior major-opcode
1)))
1420 (emit-ea segment dst opcode
)
1422 (emit-byte segment amount
)))))
1424 (define-instruction-format
1425 (shift-inst 16 :include reg
/mem
1426 :default-printer
'(:name
:tab reg
/mem
", " (:if
(varying :positive
) 'cl
1)))
1427 (op :fields
(list (byte 6 2) (byte 3 11)))
1428 (varying :field
(byte 1 1)))
1430 (macrolet ((define (name subop
)
1431 `(define-instruction ,name
(segment dst amount
)
1432 (:printer shift-inst
((op '(#b110100
,subop
)))) ; shift by CL or 1
1433 (:printer reg
/mem-imm
((op '(#b1100000
,subop
))
1434 (imm nil
:type
'imm-byte
)))
1435 (:emitter
(emit-shift-inst segment dst amount
,subop
)))))
1444 (defun emit-double-shift (segment opcode dst src amt
)
1445 (let ((size (matching-operand-size dst src
)))
1446 (when (eq size
:byte
)
1447 (error "Double shifts can only be used with words."))
1448 (maybe-emit-operand-size-prefix segment size
)
1449 (emit-byte segment
#b00001111
)
1450 (emit-byte segment
(dpb opcode
(byte 1 3)
1451 (if (eq amt
:cl
) #b10100101
#b10100100
)))
1453 (emit-ea segment dst src
)
1454 (emit-ea segment dst
(reg-tn-encoding src
)) ; pw tries this
1455 (unless (eq amt
:cl
)
1456 (emit-byte segment amt
))))
1458 (macrolet ((define (name direction-bit op
)
1459 `(define-instruction ,name
(segment dst src amt
)
1460 (:declare
(type (or (member :cl
) (mod 32)) amt
))
1461 (:printer ext-reg-reg
/mem-no-width
((op ,(logior op
#b100
))
1462 (imm nil
:type
'imm-byte
))
1463 '(:name
:tab reg
/mem
", " reg
", " imm
))
1464 (:printer ext-reg-reg
/mem-no-width
((op ,(logior op
#b101
)))
1465 '(:name
:tab reg
/mem
", " reg
", " 'cl
))
1467 (emit-double-shift segment
,direction-bit dst src amt
)))))
1468 (define shld
0 #b10100000
)
1469 (define shrd
1 #b10101000
))
1471 (define-instruction test
(segment this that
)
1472 (:printer accum-imm
((op #b1010100
)))
1473 (:printer reg
/mem-imm
((op '(#b1111011
#b000
))))
1474 (:printer reg-reg
/mem
((op #b1000010
)))
1476 (let ((size (matching-operand-size this that
)))
1477 (maybe-emit-operand-size-prefix segment size
)
1478 (flet ((test-immed-and-something (immed something
)
1479 (cond ((accumulator-p something
)
1481 (if (eq size
:byte
) #b10101000
#b10101001
))
1482 (emit-sized-immediate segment size immed
))
1485 (if (eq size
:byte
) #b11110110
#b11110111
))
1486 (emit-ea segment something
#b000
)
1487 (emit-sized-immediate segment size immed
))))
1488 (test-reg-and-something (reg something
)
1489 (emit-byte segment
(if (eq size
:byte
) #b10000100
#b10000101
))
1490 (emit-ea segment something
(reg-tn-encoding reg
))))
1491 (cond ((integerp that
)
1492 (test-immed-and-something that this
))
1494 (test-immed-and-something this that
))
1496 (test-reg-and-something this that
))
1498 (test-reg-and-something that this
))
1500 (error "bogus operands for TEST: ~S and ~S" this that
)))))))
1502 (define-instruction not
(segment dst
)
1503 (:printer reg
/mem
((op '(#b1111011
#b010
))))
1505 (let ((size (operand-size dst
)))
1506 (maybe-emit-operand-size-prefix segment size
)
1507 (emit-byte segment
(if (eq size
:byte
) #b11110110
#b11110111
))
1508 (emit-ea segment dst
#b010
))))
1510 ;;;; string manipulation
1512 (define-instruction cmps
(segment size
)
1513 (:printer string-op
((op #b1010011
)))
1515 (maybe-emit-operand-size-prefix segment size
)
1516 (emit-byte segment
(if (eq size
:byte
) #b10100110
#b10100111
))))
1518 (define-instruction ins
(segment acc
)
1519 (:printer string-op
((op #b0110110
)))
1521 (let ((size (operand-size acc
)))
1522 (aver (accumulator-p acc
))
1523 (maybe-emit-operand-size-prefix segment size
)
1524 (emit-byte segment
(if (eq size
:byte
) #b01101100
#b01101101
)))))
1526 (define-instruction lods
(segment acc
)
1527 (:printer string-op
((op #b1010110
)))
1529 (let ((size (operand-size acc
)))
1530 (aver (accumulator-p acc
))
1531 (maybe-emit-operand-size-prefix segment size
)
1532 (emit-byte segment
(if (eq size
:byte
) #b10101100
#b10101101
)))))
1534 (define-instruction movs
(segment size
)
1535 (:printer string-op
((op #b1010010
)))
1537 (maybe-emit-operand-size-prefix segment size
)
1538 (emit-byte segment
(if (eq size
:byte
) #b10100100
#b10100101
))))
1540 (define-instruction outs
(segment acc
)
1541 (:printer string-op
((op #b0110111
)))
1543 (let ((size (operand-size acc
)))
1544 (aver (accumulator-p acc
))
1545 (maybe-emit-operand-size-prefix segment size
)
1546 (emit-byte segment
(if (eq size
:byte
) #b01101110
#b01101111
)))))
1548 (define-instruction scas
(segment acc
)
1549 (:printer string-op
((op #b1010111
)))
1551 (let ((size (operand-size acc
)))
1552 (aver (accumulator-p acc
))
1553 (maybe-emit-operand-size-prefix segment size
)
1554 (emit-byte segment
(if (eq size
:byte
) #b10101110
#b10101111
)))))
1556 (define-instruction stos
(segment acc
)
1557 (:printer string-op
((op #b1010101
)))
1559 (let ((size (operand-size acc
)))
1560 (aver (accumulator-p acc
))
1561 (maybe-emit-operand-size-prefix segment size
)
1562 (emit-byte segment
(if (eq size
:byte
) #b10101010
#b10101011
)))))
1564 (define-instruction xlat
(segment)
1565 (:printer byte
((op #b11010111
)))
1567 (emit-byte segment
#b11010111
)))
1570 ;;;; bit manipulation
1572 (define-instruction bsf
(segment dst src
)
1573 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 0)))
1575 (let ((size (matching-operand-size dst src
)))
1576 (when (eq size
:byte
)
1577 (error "can't scan bytes: ~S" src
))
1578 (maybe-emit-operand-size-prefix segment size
)
1579 (emit-byte segment
#b00001111
)
1580 (emit-byte segment
#b10111100
)
1581 (emit-ea segment src
(reg-tn-encoding dst
)))))
1583 (define-instruction bsr
(segment dst src
)
1584 (:printer ext-reg-reg
/mem
((op #b1011110
) (width 1)))
1586 (let ((size (matching-operand-size dst src
)))
1587 (when (eq size
:byte
)
1588 (error "can't scan bytes: ~S" src
))
1589 (maybe-emit-operand-size-prefix segment size
)
1590 (emit-byte segment
#b00001111
)
1591 (emit-byte segment
#b10111101
)
1592 (emit-ea segment src
(reg-tn-encoding dst
)))))
1594 (defun emit-bit-test-and-mumble (segment src index opcode
)
1595 (let ((size (operand-size src
)))
1596 (when (eq size
:byte
)
1597 (error "can't scan bytes: ~S" src
))
1598 (maybe-emit-operand-size-prefix segment size
)
1599 (emit-byte segment
#b00001111
)
1600 (cond ((integerp index
)
1601 (emit-byte segment
#b10111010
)
1602 (emit-ea segment src opcode
)
1603 (emit-byte segment index
))
1605 (emit-byte segment
(dpb opcode
(byte 3 3) #b10000011
))
1606 (emit-ea segment src
(reg-tn-encoding index
))))))
1608 (macrolet ((define (inst opcode-extension
)
1609 `(define-instruction ,inst
(segment src index
&optional prefix
)
1610 (:printer ext-reg
/mem-no-width
+imm8
1611 ((op '(#xBA
,opcode-extension
))
1612 (reg/mem nil
:type
'sized-reg
/mem
)))
1613 (:printer ext-reg-reg
/mem-no-width
1614 ((op ,(dpb opcode-extension
(byte 3 3) #b10000011
))
1615 (reg/mem nil
:type
'sized-reg
/mem
))
1616 '(:name
:tab reg
/mem
", " reg
))
1618 (emit-prefix segment prefix
)
1619 (emit-bit-test-and-mumble segment src index
1620 ,opcode-extension
)))))
1627 ;;;; control transfer
1629 (defun emit-byte-displacement-backpatch (segment target
)
1630 (emit-back-patch segment
1
1631 (lambda (segment posn
)
1633 (the (signed-byte 8)
1634 (- (label-position target
) (1+ posn
)))))))
1636 (defun emit-dword-displacement-backpatch (segment target
)
1637 (emit-back-patch segment
4
1638 (lambda (segment posn
)
1639 (emit-dword segment
(- (label-position target
)
1642 (define-instruction call
(segment where
)
1643 (:printer near-jump
((op #b11101000
)))
1644 (:printer reg
/mem
((op '(#b1111111
#b010
)) (width 1)))
1648 (emit-byte segment
#b11101000
)
1649 (emit-dword-displacement-backpatch segment where
))
1651 (emit-byte segment
#b11101000
)
1652 (emit-relative-fixup segment where
))
1654 (emit-byte segment
#b11111111
)
1655 (emit-ea segment where
#b010
)))))
1657 (define-instruction jmp
(segment cond
&optional where
)
1658 ;; conditional jumps
1659 (:printer short-cond-jump
((op #b0111
)) '('j cc
:tab label
))
1660 (:printer near-cond-jump
() '('j cc
:tab label
))
1661 ;; unconditional jumps
1662 (:printer short-jump
((op #b1011
)))
1663 (:printer near-jump
((op #b11101001
)) )
1664 (:printer reg
/mem
((op '(#b1111111
#b100
)) (width 1)))
1669 (lambda (segment posn delta-if-after
)
1670 (let ((disp (- (label-position where posn delta-if-after
)
1672 (when (<= -
128 disp
127)
1674 (dpb (conditional-opcode cond
)
1677 (emit-byte-displacement-backpatch segment where
)
1679 (lambda (segment posn
)
1680 (let ((disp (- (label-position where
) (+ posn
6))))
1681 (emit-byte segment
#b00001111
)
1683 (dpb (conditional-opcode cond
)
1686 (emit-dword segment disp
)))))
1687 ((label-p (setq where cond
))
1690 (lambda (segment posn delta-if-after
)
1691 (let ((disp (- (label-position where posn delta-if-after
)
1693 (when (<= -
128 disp
127)
1694 (emit-byte segment
#b11101011
)
1695 (emit-byte-displacement-backpatch segment where
)
1697 (lambda (segment posn
)
1698 (let ((disp (- (label-position where
) (+ posn
5))))
1699 (emit-byte segment
#b11101001
)
1700 (emit-dword segment disp
)))))
1702 (emit-byte segment
#b11101001
)
1703 (emit-relative-fixup segment where
))
1705 (unless (or (ea-p where
) (tn-p where
))
1706 (error "don't know what to do with ~A" where
))
1707 (emit-byte segment
#b11111111
)
1708 (emit-ea segment where
#b100
)))))
1710 (define-instruction jmp-short
(segment label
)
1712 (emit-byte segment
#b11101011
)
1713 (emit-byte-displacement-backpatch segment label
)))
1715 (define-instruction ret
(segment &optional stack-delta
)
1716 (:printer byte
((op #b11000011
)))
1717 (:printer byte
((op #b11000010
) (imm nil
:type
'imm-word-16
))
1720 (cond ((and stack-delta
(not (zerop stack-delta
)))
1721 (emit-byte segment
#b11000010
)
1722 (emit-word segment stack-delta
))
1724 (emit-byte segment
#b11000011
)))))
1726 (define-instruction jecxz
(segment target
)
1727 (:printer short-jump
((op #b0011
)))
1729 (emit-byte segment
#b11100011
)
1730 (emit-byte-displacement-backpatch segment target
)))
1732 (define-instruction loop
(segment target
)
1733 (:printer short-jump
((op #b0010
)))
1735 (emit-byte segment
#b11100010
) ; pfw this was 11100011, or jecxz!!!!
1736 (emit-byte-displacement-backpatch segment target
)))
1738 (define-instruction loopz
(segment target
)
1739 (:printer short-jump
((op #b0001
)))
1741 (emit-byte segment
#b11100001
)
1742 (emit-byte-displacement-backpatch segment target
)))
1744 (define-instruction loopnz
(segment target
)
1745 (:printer short-jump
((op #b0000
)))
1747 (emit-byte segment
#b11100000
)
1748 (emit-byte-displacement-backpatch segment target
)))
1750 ;;;; conditional move
1751 (define-instruction cmov
(segment cond dst src
)
1752 (:printer cond-move
())
1754 (aver (register-p dst
))
1755 (let ((size (matching-operand-size dst src
)))
1756 (aver (or (eq size
:word
) (eq size
:dword
)))
1757 (maybe-emit-operand-size-prefix segment size
))
1758 (emit-byte segment
#b00001111
)
1759 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b01000000
))
1760 (emit-ea segment src
(reg-tn-encoding dst
))))
1762 ;;;; conditional byte set
1764 (define-instruction set
(segment dst cond
)
1765 (:printer cond-set
())
1767 (emit-byte segment
#b00001111
)
1768 (emit-byte segment
(dpb (conditional-opcode cond
) (byte 4 0) #b10010000
))
1769 (emit-ea segment dst
#b000
)))
1773 (define-instruction enter
(segment disp
&optional
(level 0))
1774 (:declare
(type (unsigned-byte 16) disp
)
1775 (type (unsigned-byte 8) level
))
1776 (:printer enter-format
((op #b11001000
)))
1778 (emit-byte segment
#b11001000
)
1779 (emit-word segment disp
)
1780 (emit-byte segment level
)))
1782 (define-instruction leave
(segment)
1783 (:printer byte
((op #b11001001
)))
1785 (emit-byte segment
#b11001001
)))
1788 (define-instruction prefetchnta
(segment ea
)
1789 (:printer prefetch
((op #b00011000
) (reg #b000
)))
1791 (aver (typep ea
'ea
))
1792 (aver (eq :byte
(ea-size ea
)))
1793 (emit-byte segment
#b00001111
)
1794 (emit-byte segment
#b00011000
)
1795 (emit-ea segment ea
#b000
)))
1797 (define-instruction prefetcht0
(segment ea
)
1798 (:printer prefetch
((op #b00011000
) (reg #b001
)))
1800 (aver (typep ea
'ea
))
1801 (aver (eq :byte
(ea-size ea
)))
1802 (emit-byte segment
#b00001111
)
1803 (emit-byte segment
#b00011000
)
1804 (emit-ea segment ea
#b001
)))
1806 (define-instruction prefetcht1
(segment ea
)
1807 (:printer prefetch
((op #b00011000
) (reg #b010
)))
1809 (aver (typep ea
'ea
))
1810 (aver (eq :byte
(ea-size ea
)))
1811 (emit-byte segment
#b00001111
)
1812 (emit-byte segment
#b00011000
)
1813 (emit-ea segment ea
#b010
)))
1815 (define-instruction prefetcht2
(segment ea
)
1816 (:printer prefetch
((op #b00011000
) (reg #b011
)))
1818 (aver (typep ea
'ea
))
1819 (aver (eq :byte
(ea-size ea
)))
1820 (emit-byte segment
#b00001111
)
1821 (emit-byte segment
#b00011000
)
1822 (emit-ea segment ea
#b011
)))
1824 ;;;; interrupt instructions
1826 (define-instruction break
(segment code
)
1827 (:declare
(type (unsigned-byte 8) code
))
1828 #!-ud2-breakpoints
(:printer byte-imm
((op #b11001100
))
1829 '(:name
:tab code
) :control
#'break-control
)
1830 #!+ud2-breakpoints
(:printer word-imm
((op #b0000101100001111
))
1831 '(:name
:tab code
) :control
#'break-control
)
1833 #!-ud2-breakpoints
(emit-byte segment
#b11001100
)
1834 ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
1835 ;; throw a sigill with 0x0b0f instead and check for this in the
1836 ;; SIGILL handler and pass it on to the sigtrap handler if
1838 #!+ud2-breakpoints
(emit-word segment
#b0000101100001111
)
1839 (emit-byte segment code
)))
1841 (define-instruction int
(segment number
)
1842 (:declare
(type (unsigned-byte 8) number
))
1843 (:printer byte-imm
((op #b11001101
)))
1847 (emit-byte segment
#b11001100
))
1849 (emit-byte segment
#b11001101
)
1850 (emit-byte segment number
)))))
1852 (define-instruction into
(segment)
1853 (:printer byte
((op #b11001110
)))
1855 (emit-byte segment
#b11001110
)))
1857 (define-instruction bound
(segment reg bounds
)
1859 (let ((size (matching-operand-size reg bounds
)))
1860 (when (eq size
:byte
)
1861 (error "can't bounds-test bytes: ~S" reg
))
1862 (maybe-emit-operand-size-prefix segment size
)
1863 (emit-byte segment
#b01100010
)
1864 (emit-ea segment bounds
(reg-tn-encoding reg
)))))
1866 (define-instruction iret
(segment)
1867 (:printer byte
((op #b11001111
)))
1869 (emit-byte segment
#b11001111
)))
1871 ;;;; processor control
1873 (define-instruction hlt
(segment)
1874 (:printer byte
((op #b11110100
)))
1876 (emit-byte segment
#b11110100
)))
1878 (define-instruction nop
(segment)
1879 (:printer byte
((op #b10010000
)))
1880 (:printer ext-reg
/mem-no-width
((op '(#x1F
0))))
1882 (emit-byte segment
#b10010000
)))
1884 (define-instruction wait
(segment)
1885 (:printer byte
((op #b10011011
)))
1887 (emit-byte segment
#b10011011
)))
1889 ;;;; miscellaneous hackery
1891 (define-instruction byte
(segment byte
)
1893 (emit-byte segment byte
)))
1895 (define-instruction word
(segment word
)
1897 (emit-word segment word
)))
1899 (define-instruction dword
(segment dword
)
1901 (emit-dword segment dword
)))
1903 (defun emit-header-data (segment type
)
1904 (emit-back-patch segment
1906 (lambda (segment posn
)
1910 (component-header-length))
1914 (define-instruction simple-fun-header-word
(segment)
1916 (emit-header-data segment simple-fun-widetag
)))
1918 ;;;; fp instructions
1920 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
1922 ;;;; Note: We treat the single-precision and double-precision variants
1923 ;;;; as separate instructions.
1925 ;;; Load single to st(0).
1926 (define-instruction fld
(segment source
)
1927 (:printer floating-point
((op '(#b001
#b000
))))
1929 (emit-byte segment
#b11011001
)
1930 (emit-fp-op segment source
#b000
)))
1932 ;;; Load double to st(0).
1933 (define-instruction fldd
(segment source
)
1934 (:printer floating-point
((op '(#b101
#b000
))))
1935 (:printer floating-point-fp
((op '(#b001
#b000
))))
1937 (if (fp-reg-tn-p source
)
1938 (emit-byte segment
#b11011001
)
1939 (emit-byte segment
#b11011101
))
1940 (emit-fp-op segment source
#b000
)))
1942 ;;; Load long to st(0).
1943 (define-instruction fldl
(segment source
)
1944 (:printer floating-point
((op '(#b011
#b101
))))
1946 (emit-byte segment
#b11011011
)
1947 (emit-fp-op segment source
#b101
)))
1949 ;;; Store single from st(0).
1950 (define-instruction fst
(segment dest
)
1951 (:printer floating-point
((op '(#b001
#b010
))))
1953 (cond ((fp-reg-tn-p dest
)
1954 (emit-byte segment
#b11011101
)
1955 (emit-fp-op segment dest
#b010
))
1957 (emit-byte segment
#b11011001
)
1958 (emit-fp-op segment dest
#b010
)))))
1960 ;;; Store double from st(0).
1961 (define-instruction fstd
(segment dest
)
1962 (:printer floating-point
((op '(#b101
#b010
))))
1963 (:printer floating-point-fp
((op '(#b101
#b010
))))
1965 (cond ((fp-reg-tn-p dest
)
1966 (emit-byte segment
#b11011101
)
1967 (emit-fp-op segment dest
#b010
))
1969 (emit-byte segment
#b11011101
)
1970 (emit-fp-op segment dest
#b010
)))))
1972 ;;; Arithmetic ops are all done with at least one operand at top of
1973 ;;; stack. The other operand is is another register or a 32/64 bit
1976 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
1977 ;;; that these conflict with the Gdb conventions for binops. To reduce
1978 ;;; the confusion I've added comments showing the mathamatical
1979 ;;; operation and the two syntaxes. By the ASM386 convention the
1980 ;;; instruction syntax is:
1983 ;;; or Fop Destination, Source
1985 ;;; If only one operand is given then it is the source and the
1986 ;;; destination is ST(0). There are reversed forms of the fsub and
1987 ;;; fdiv instructions inducated by an 'R' suffix.
1989 ;;; The mathematical operation for the non-reverse form is always:
1990 ;;; destination = destination op source
1992 ;;; For the reversed form it is:
1993 ;;; destination = source op destination
1995 ;;; The instructions below only accept one operand at present which is
1996 ;;; usually the source. I've hack in extra instructions to implement
1997 ;;; the fops with a ST(i) destination, these have a -sti suffix and
1998 ;;; the operand is the destination with the source being ST(0).
2001 ;;; st(0) = st(0) + memory or st(i).
2002 (define-instruction fadd
(segment source
)
2003 (:printer floating-point
((op '(#b000
#b000
))))
2005 (emit-byte segment
#b11011000
)
2006 (emit-fp-op segment source
#b000
)))
2009 ;;; st(0) = st(0) + memory or st(i).
2010 (define-instruction faddd
(segment source
)
2011 (:printer floating-point
((op '(#b100
#b000
))))
2012 (:printer floating-point-fp
((op '(#b000
#b000
))))
2014 (if (fp-reg-tn-p source
)
2015 (emit-byte segment
#b11011000
)
2016 (emit-byte segment
#b11011100
))
2017 (emit-fp-op segment source
#b000
)))
2019 ;;; Add double destination st(i):
2020 ;;; st(i) = st(0) + st(i).
2021 (define-instruction fadd-sti
(segment destination
)
2022 (:printer floating-point-fp
((op '(#b100
#b000
))))
2024 (aver (fp-reg-tn-p destination
))
2025 (emit-byte segment
#b11011100
)
2026 (emit-fp-op segment destination
#b000
)))
2028 (define-instruction faddp-sti
(segment destination
)
2029 (:printer floating-point-fp
((op '(#b110
#b000
))))
2031 (aver (fp-reg-tn-p destination
))
2032 (emit-byte segment
#b11011110
)
2033 (emit-fp-op segment destination
#b000
)))
2035 ;;; Subtract single:
2036 ;;; st(0) = st(0) - memory or st(i).
2037 (define-instruction fsub
(segment source
)
2038 (:printer floating-point
((op '(#b000
#b100
))))
2040 (emit-byte segment
#b11011000
)
2041 (emit-fp-op segment source
#b100
)))
2043 ;;; Subtract single, reverse:
2044 ;;; st(0) = memory or st(i) - st(0).
2045 (define-instruction fsubr
(segment source
)
2046 (:printer floating-point
((op '(#b000
#b101
))))
2048 (emit-byte segment
#b11011000
)
2049 (emit-fp-op segment source
#b101
)))
2051 ;;; Subtract double:
2052 ;;; st(0) = st(0) - memory or st(i).
2053 (define-instruction fsubd
(segment source
)
2054 (:printer floating-point
((op '(#b100
#b100
))))
2055 (:printer floating-point-fp
((op '(#b000
#b100
))))
2057 (if (fp-reg-tn-p source
)
2058 (emit-byte segment
#b11011000
)
2059 (emit-byte segment
#b11011100
))
2060 (emit-fp-op segment source
#b100
)))
2062 ;;; Subtract double, reverse:
2063 ;;; st(0) = memory or st(i) - st(0).
2064 (define-instruction fsubrd
(segment source
)
2065 (:printer floating-point
((op '(#b100
#b101
))))
2066 (:printer floating-point-fp
((op '(#b000
#b101
))))
2068 (if (fp-reg-tn-p source
)
2069 (emit-byte segment
#b11011000
)
2070 (emit-byte segment
#b11011100
))
2071 (emit-fp-op segment source
#b101
)))
2073 ;;; Subtract double, destination st(i):
2074 ;;; st(i) = st(i) - st(0).
2076 ;;; ASM386 syntax: FSUB ST(i), ST
2077 ;;; Gdb syntax: fsubr %st,%st(i)
2078 (define-instruction fsub-sti
(segment destination
)
2079 (:printer floating-point-fp
((op '(#b100
#b101
))))
2081 (aver (fp-reg-tn-p destination
))
2082 (emit-byte segment
#b11011100
)
2083 (emit-fp-op segment destination
#b101
)))
2085 (define-instruction fsubp-sti
(segment destination
)
2086 (:printer floating-point-fp
((op '(#b110
#b101
))))
2088 (aver (fp-reg-tn-p destination
))
2089 (emit-byte segment
#b11011110
)
2090 (emit-fp-op segment destination
#b101
)))
2092 ;;; Subtract double, reverse, destination st(i):
2093 ;;; st(i) = st(0) - st(i).
2095 ;;; ASM386 syntax: FSUBR ST(i), ST
2096 ;;; Gdb syntax: fsub %st,%st(i)
2097 (define-instruction fsubr-sti
(segment destination
)
2098 (:printer floating-point-fp
((op '(#b100
#b100
))))
2100 (aver (fp-reg-tn-p destination
))
2101 (emit-byte segment
#b11011100
)
2102 (emit-fp-op segment destination
#b100
)))
2104 (define-instruction fsubrp-sti
(segment destination
)
2105 (:printer floating-point-fp
((op '(#b110
#b100
))))
2107 (aver (fp-reg-tn-p destination
))
2108 (emit-byte segment
#b11011110
)
2109 (emit-fp-op segment destination
#b100
)))
2111 ;;; Multiply single:
2112 ;;; st(0) = st(0) * memory or st(i).
2113 (define-instruction fmul
(segment source
)
2114 (:printer floating-point
((op '(#b000
#b001
))))
2116 (emit-byte segment
#b11011000
)
2117 (emit-fp-op segment source
#b001
)))
2119 ;;; Multiply double:
2120 ;;; st(0) = st(0) * memory or st(i).
2121 (define-instruction fmuld
(segment source
)
2122 (:printer floating-point
((op '(#b100
#b001
))))
2123 (:printer floating-point-fp
((op '(#b000
#b001
))))
2125 (if (fp-reg-tn-p source
)
2126 (emit-byte segment
#b11011000
)
2127 (emit-byte segment
#b11011100
))
2128 (emit-fp-op segment source
#b001
)))
2130 ;;; Multiply double, destination st(i):
2131 ;;; st(i) = st(i) * st(0).
2132 (define-instruction fmul-sti
(segment destination
)
2133 (:printer floating-point-fp
((op '(#b100
#b001
))))
2135 (aver (fp-reg-tn-p destination
))
2136 (emit-byte segment
#b11011100
)
2137 (emit-fp-op segment destination
#b001
)))
2140 ;;; st(0) = st(0) / memory or st(i).
2141 (define-instruction fdiv
(segment source
)
2142 (:printer floating-point
((op '(#b000
#b110
))))
2144 (emit-byte segment
#b11011000
)
2145 (emit-fp-op segment source
#b110
)))
2147 ;;; Divide single, reverse:
2148 ;;; st(0) = memory or st(i) / st(0).
2149 (define-instruction fdivr
(segment source
)
2150 (:printer floating-point
((op '(#b000
#b111
))))
2152 (emit-byte segment
#b11011000
)
2153 (emit-fp-op segment source
#b111
)))
2156 ;;; st(0) = st(0) / memory or st(i).
2157 (define-instruction fdivd
(segment source
)
2158 (:printer floating-point
((op '(#b100
#b110
))))
2159 (:printer floating-point-fp
((op '(#b000
#b110
))))
2161 (if (fp-reg-tn-p source
)
2162 (emit-byte segment
#b11011000
)
2163 (emit-byte segment
#b11011100
))
2164 (emit-fp-op segment source
#b110
)))
2166 ;;; Divide double, reverse:
2167 ;;; st(0) = memory or st(i) / st(0).
2168 (define-instruction fdivrd
(segment source
)
2169 (:printer floating-point
((op '(#b100
#b111
))))
2170 (:printer floating-point-fp
((op '(#b000
#b111
))))
2172 (if (fp-reg-tn-p source
)
2173 (emit-byte segment
#b11011000
)
2174 (emit-byte segment
#b11011100
))
2175 (emit-fp-op segment source
#b111
)))
2177 ;;; Divide double, destination st(i):
2178 ;;; st(i) = st(i) / st(0).
2180 ;;; ASM386 syntax: FDIV ST(i), ST
2181 ;;; Gdb syntax: fdivr %st,%st(i)
2182 (define-instruction fdiv-sti
(segment destination
)
2183 (:printer floating-point-fp
((op '(#b100
#b111
))))
2185 (aver (fp-reg-tn-p destination
))
2186 (emit-byte segment
#b11011100
)
2187 (emit-fp-op segment destination
#b111
)))
2189 ;;; Divide double, reverse, destination st(i):
2190 ;;; st(i) = st(0) / st(i).
2192 ;;; ASM386 syntax: FDIVR ST(i), ST
2193 ;;; Gdb syntax: fdiv %st,%st(i)
2194 (define-instruction fdivr-sti
(segment destination
)
2195 (:printer floating-point-fp
((op '(#b100
#b110
))))
2197 (aver (fp-reg-tn-p destination
))
2198 (emit-byte segment
#b11011100
)
2199 (emit-fp-op segment destination
#b110
)))
2201 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2202 (define-instruction fxch
(segment source
)
2203 (:printer floating-point-fp
((op '(#b001
#b001
))))
2205 (aver (and (tn-p source
)
2206 (eq (sb-name (sc-sb (tn-sc source
))) 'float-registers
)))
2207 (emit-byte segment
#b11011001
)
2208 (emit-fp-op segment source
#b001
)))
2210 ;;; Push 32-bit integer to st0.
2211 (define-instruction fild
(segment source
)
2212 (:printer floating-point
((op '(#b011
#b000
))))
2214 (emit-byte segment
#b11011011
)
2215 (emit-fp-op segment source
#b000
)))
2217 ;;; Push 64-bit integer to st0.
2218 (define-instruction fildl
(segment source
)
2219 (:printer floating-point
((op '(#b111
#b101
))))
2221 (emit-byte segment
#b11011111
)
2222 (emit-fp-op segment source
#b101
)))
2224 ;;; Store 32-bit integer.
2225 (define-instruction fist
(segment dest
)
2226 (:printer floating-point
((op '(#b011
#b010
))))
2228 (emit-byte segment
#b11011011
)
2229 (emit-fp-op segment dest
#b010
)))
2231 ;;; Store and pop 32-bit integer.
2232 (define-instruction fistp
(segment dest
)
2233 (:printer floating-point
((op '(#b011
#b011
))))
2235 (emit-byte segment
#b11011011
)
2236 (emit-fp-op segment dest
#b011
)))
2238 ;;; Store and pop 64-bit integer.
2239 (define-instruction fistpl
(segment dest
)
2240 (:printer floating-point
((op '(#b111
#b111
))))
2242 (emit-byte segment
#b11011111
)
2243 (emit-fp-op segment dest
#b111
)))
2245 ;;; Store single from st(0) and pop.
2246 (define-instruction fstp
(segment dest
)
2247 (:printer floating-point
((op '(#b001
#b011
))))
2249 (cond ((fp-reg-tn-p dest
)
2250 (emit-byte segment
#b11011101
)
2251 (emit-fp-op segment dest
#b011
))
2253 (emit-byte segment
#b11011001
)
2254 (emit-fp-op segment dest
#b011
)))))
2256 ;;; Store double from st(0) and pop.
2257 (define-instruction fstpd
(segment dest
)
2258 (:printer floating-point
((op '(#b101
#b011
))))
2259 (:printer floating-point-fp
((op '(#b101
#b011
))))
2261 (cond ((fp-reg-tn-p dest
)
2262 (emit-byte segment
#b11011101
)
2263 (emit-fp-op segment dest
#b011
))
2265 (emit-byte segment
#b11011101
)
2266 (emit-fp-op segment dest
#b011
)))))
2268 ;;; Store long from st(0) and pop.
2269 (define-instruction fstpl
(segment dest
)
2270 (:printer floating-point
((op '(#b011
#b111
))))
2272 (emit-byte segment
#b11011011
)
2273 (emit-fp-op segment dest
#b111
)))
2275 ;;; Decrement stack-top pointer.
2276 (define-instruction fdecstp
(segment)
2277 (:printer floating-point-no
((op #b10110
)))
2279 (emit-byte segment
#b11011001
)
2280 (emit-byte segment
#b11110110
)))
2282 ;;; Increment stack-top pointer.
2283 (define-instruction fincstp
(segment)
2284 (:printer floating-point-no
((op #b10111
)))
2286 (emit-byte segment
#b11011001
)
2287 (emit-byte segment
#b11110111
)))
2289 ;;; Free fp register.
2290 (define-instruction ffree
(segment dest
)
2291 (:printer floating-point-fp
((op '(#b101
#b000
))))
2293 (emit-byte segment
#b11011101
)
2294 (emit-fp-op segment dest
#b000
)))
2296 (define-instruction fabs
(segment)
2297 (:printer floating-point-no
((op #b00001
)))
2299 (emit-byte segment
#b11011001
)
2300 (emit-byte segment
#b11100001
)))
2302 (define-instruction fchs
(segment)
2303 (:printer floating-point-no
((op #b00000
)))
2305 (emit-byte segment
#b11011001
)
2306 (emit-byte segment
#b11100000
)))
2308 (define-instruction frndint
(segment)
2309 (:printer floating-point-no
((op #b11100
)))
2311 (emit-byte segment
#b11011001
)
2312 (emit-byte segment
#b11111100
)))
2315 (define-instruction fninit
(segment)
2316 (:printer floating-point-5
((op #b00011
)))
2318 (emit-byte segment
#b11011011
)
2319 (emit-byte segment
#b11100011
)))
2321 ;;; Store Status Word to AX.
2322 (define-instruction fnstsw
(segment)
2323 (:printer floating-point-st
((op #b00000
)))
2325 (emit-byte segment
#b11011111
)
2326 (emit-byte segment
#b11100000
)))
2328 ;;; Load Control Word.
2330 ;;; src must be a memory location
2331 (define-instruction fldcw
(segment src
)
2332 (:printer floating-point
((op '(#b001
#b101
))))
2334 (emit-byte segment
#b11011001
)
2335 (emit-fp-op segment src
#b101
)))
2337 ;;; Store Control Word.
2338 (define-instruction fnstcw
(segment dst
)
2339 (:printer floating-point
((op '(#b001
#b111
))))
2341 (emit-byte segment
#b11011001
)
2342 (emit-fp-op segment dst
#b111
)))
2344 ;;; Store FP Environment.
2345 (define-instruction fstenv
(segment dst
)
2346 (:printer floating-point
((op '(#b001
#b110
))))
2348 (emit-byte segment
#b11011001
)
2349 (emit-fp-op segment dst
#b110
)))
2351 ;;; Restore FP Environment.
2352 (define-instruction fldenv
(segment src
)
2353 (:printer floating-point
((op '(#b001
#b100
))))
2355 (emit-byte segment
#b11011001
)
2356 (emit-fp-op segment src
#b100
)))
2359 (define-instruction fsave
(segment dst
)
2360 (:printer floating-point
((op '(#b101
#b110
))))
2362 (emit-byte segment
#b11011101
)
2363 (emit-fp-op segment dst
#b110
)))
2365 ;;; Restore FP State.
2366 (define-instruction frstor
(segment src
)
2367 (:printer floating-point
((op '(#b101
#b100
))))
2369 (emit-byte segment
#b11011101
)
2370 (emit-fp-op segment src
#b100
)))
2372 ;;; Clear exceptions.
2373 (define-instruction fnclex
(segment)
2374 (:printer floating-point-5
((op #b00010
)))
2376 (emit-byte segment
#b11011011
)
2377 (emit-byte segment
#b11100010
)))
2380 (define-instruction fcom
(segment src
)
2381 (:printer floating-point
((op '(#b000
#b010
))))
2383 (emit-byte segment
#b11011000
)
2384 (emit-fp-op segment src
#b010
)))
2386 (define-instruction fcomd
(segment src
)
2387 (:printer floating-point
((op '(#b100
#b010
))))
2388 (:printer floating-point-fp
((op '(#b000
#b010
))))
2390 (if (fp-reg-tn-p src
)
2391 (emit-byte segment
#b11011000
)
2392 (emit-byte segment
#b11011100
))
2393 (emit-fp-op segment src
#b010
)))
2395 ;;; Compare ST1 to ST0, popping the stack twice.
2396 (define-instruction fcompp
(segment)
2397 (:printer floating-point-3
((op '(#b110
#b011001
))))
2399 (emit-byte segment
#b11011110
)
2400 (emit-byte segment
#b11011001
)))
2402 ;;; unordered comparison
2403 (define-instruction fucom
(segment src
)
2404 (:printer floating-point-fp
((op '(#b101
#b100
))))
2406 (aver (fp-reg-tn-p src
))
2407 (emit-byte segment
#b11011101
)
2408 (emit-fp-op segment src
#b100
)))
2410 (define-instruction ftst
(segment)
2411 (:printer floating-point-no
((op #b00100
)))
2413 (emit-byte segment
#b11011001
)
2414 (emit-byte segment
#b11100100
)))
2418 (define-instruction fsqrt
(segment)
2419 (:printer floating-point-no
((op #b11010
)))
2421 (emit-byte segment
#b11011001
)
2422 (emit-byte segment
#b11111010
)))
2424 (define-instruction fscale
(segment)
2425 (:printer floating-point-no
((op #b11101
)))
2427 (emit-byte segment
#b11011001
)
2428 (emit-byte segment
#b11111101
)))
2430 (define-instruction fxtract
(segment)
2431 (:printer floating-point-no
((op #b10100
)))
2433 (emit-byte segment
#b11011001
)
2434 (emit-byte segment
#b11110100
)))
2436 (define-instruction fsin
(segment)
2437 (:printer floating-point-no
((op #b11110
)))
2439 (emit-byte segment
#b11011001
)
2440 (emit-byte segment
#b11111110
)))
2442 (define-instruction fcos
(segment)
2443 (:printer floating-point-no
((op #b11111
)))
2445 (emit-byte segment
#b11011001
)
2446 (emit-byte segment
#b11111111
)))
2448 (define-instruction fprem1
(segment)
2449 (:printer floating-point-no
((op #b10101
)))
2451 (emit-byte segment
#b11011001
)
2452 (emit-byte segment
#b11110101
)))
2454 (define-instruction fprem
(segment)
2455 (:printer floating-point-no
((op #b11000
)))
2457 (emit-byte segment
#b11011001
)
2458 (emit-byte segment
#b11111000
)))
2460 (define-instruction fxam
(segment)
2461 (:printer floating-point-no
((op #b00101
)))
2463 (emit-byte segment
#b11011001
)
2464 (emit-byte segment
#b11100101
)))
2466 ;;; These do push/pop to stack and need special handling
2467 ;;; in any VOPs that use them. See the book.
2469 ;;; st0 <- st1*log2(st0)
2470 (define-instruction fyl2x
(segment) ; pops stack
2471 (:printer floating-point-no
((op #b10001
)))
2473 (emit-byte segment
#b11011001
)
2474 (emit-byte segment
#b11110001
)))
2476 (define-instruction fyl2xp1
(segment)
2477 (:printer floating-point-no
((op #b11001
)))
2479 (emit-byte segment
#b11011001
)
2480 (emit-byte segment
#b11111001
)))
2482 (define-instruction f2xm1
(segment)
2483 (:printer floating-point-no
((op #b10000
)))
2485 (emit-byte segment
#b11011001
)
2486 (emit-byte segment
#b11110000
)))
2488 (define-instruction fptan
(segment) ; st(0) <- 1; st(1) <- tan
2489 (:printer floating-point-no
((op #b10010
)))
2491 (emit-byte segment
#b11011001
)
2492 (emit-byte segment
#b11110010
)))
2494 (define-instruction fpatan
(segment) ; POPS STACK
2495 (:printer floating-point-no
((op #b10011
)))
2497 (emit-byte segment
#b11011001
)
2498 (emit-byte segment
#b11110011
)))
2500 ;;;; loading constants
2502 (define-instruction fldz
(segment)
2503 (:printer floating-point-no
((op #b01110
)))
2505 (emit-byte segment
#b11011001
)
2506 (emit-byte segment
#b11101110
)))
2508 (define-instruction fld1
(segment)
2509 (:printer floating-point-no
((op #b01000
)))
2511 (emit-byte segment
#b11011001
)
2512 (emit-byte segment
#b11101000
)))
2514 (define-instruction fldpi
(segment)
2515 (:printer floating-point-no
((op #b01011
)))
2517 (emit-byte segment
#b11011001
)
2518 (emit-byte segment
#b11101011
)))
2520 (define-instruction fldl2t
(segment)
2521 (:printer floating-point-no
((op #b01001
)))
2523 (emit-byte segment
#b11011001
)
2524 (emit-byte segment
#b11101001
)))
2526 (define-instruction fldl2e
(segment)
2527 (:printer floating-point-no
((op #b01010
)))
2529 (emit-byte segment
#b11011001
)
2530 (emit-byte segment
#b11101010
)))
2532 (define-instruction fldlg2
(segment)
2533 (:printer floating-point-no
((op #b01100
)))
2535 (emit-byte segment
#b11011001
)
2536 (emit-byte segment
#b11101100
)))
2538 (define-instruction fldln2
(segment)
2539 (:printer floating-point-no
((op #b01101
)))
2541 (emit-byte segment
#b11011001
)
2542 (emit-byte segment
#b11101101
)))
2546 (define-instruction cpuid
(segment)
2547 (:printer two-bytes
((op '(#b00001111
#b10100010
))))
2549 (emit-byte segment
#b00001111
)
2550 (emit-byte segment
#b10100010
)))
2552 (define-instruction rdtsc
(segment)
2553 (:printer two-bytes
((op '(#b00001111
#b00110001
))))
2555 (emit-byte segment
#b00001111
)
2556 (emit-byte segment
#b00110001
)))
2558 ;;;; Intel TSX - some user library (STMX) used to define these,
2559 ;;;; but it's not really supported and they actually belong here.
2561 (define-instruction-format
2562 (xbegin 48 :default-printer
'(:name
:tab label
))
2563 (op :fields
(list (byte 8 0) (byte 8 8)) :value
'(#xc7
#xf8
))
2564 (label :field
(byte 32 16) :type
'displacement
))
2566 (define-instruction-format
2567 (xabort 24 :default-printer
'(:name
:tab imm
))
2568 (op :fields
(list (byte 8 0) (byte 8 8)) :value
'(#xc6
#xf8
))
2569 (imm :field
(byte 8 16)))
2571 (define-instruction xbegin
(segment &optional where
)
2572 (:printer xbegin
())
2574 (emit-byte segment
#xc7
)
2575 (emit-byte segment
#xf8
)
2577 ;; emit 32-bit, signed relative offset for where
2578 (emit-dword-displacement-backpatch segment where
)
2579 ;; nowhere to jump: simply jump to the next instruction
2580 (emit-skip segment
4 0))))
2582 (define-instruction xend
(segment)
2583 (:printer three-bytes
((op '(#x0f
#x01
#xd5
))))
2585 (emit-byte segment
#x0f
)
2586 (emit-byte segment
#x01
)
2587 (emit-byte segment
#xd5
)))
2589 (define-instruction xabort
(segment reason
)
2590 (:printer xabort
())
2592 (aver (<= 0 reason
#xff
))
2593 (emit-byte segment
#xc6
)
2594 (emit-byte segment
#xf8
)
2595 (emit-byte segment reason
)))
2597 (define-instruction xtest
(segment)
2598 (:printer three-bytes
((op '(#x0f
#x01
#xd6
))))
2600 (emit-byte segment
#x0f
)
2601 (emit-byte segment
#x01
)
2602 (emit-byte segment
#xd6
)))
2604 (define-instruction xacquire
(segment) ;; same prefix byte as repne/repnz
2606 (emit-byte segment
#xf2
)))
2608 (define-instruction xrelease
(segment) ;; same prefix byte as rep/repe/repz
2610 (emit-byte segment
#xf3
)))
2612 ;;;; Late VM definitions
2613 (defun canonicalize-inline-constant (constant)
2614 (let ((first (car constant
)))
2616 (single-float (setf constant
(list :single-float first
)))
2617 (double-float (setf constant
(list :double-float first
)))))
2618 (destructuring-bind (type value
) constant
2620 ((:byte
:word
:dword
)
2621 (aver (integerp value
))
2624 #!+sb-unicode
(aver (typep value
'base-char
))
2625 (cons :byte
(char-code value
)))
2627 (aver (characterp value
))
2628 (cons :dword
(char-code value
)))
2630 (aver (typep value
'single-float
))
2631 (cons :dword
(ldb (byte 32 0) (single-float-bits value
))))
2632 ((:double-float-bits
)
2633 (aver (integerp value
))
2634 (cons :double-float
(ldb (byte 64 0) value
)))
2636 (aver (typep value
'double-float
))
2638 (ldb (byte 64 0) (logior (ash (double-float-high-bits value
) 32)
2639 (double-float-low-bits value
))))))))
2641 (defun inline-constant-value (constant)
2642 (let ((label (gen-label))
2643 (size (ecase (car constant
)
2644 ((:byte
:word
:dword
) (car constant
))
2645 (:double-float
:dword
))))
2646 (values label
(make-ea size
2647 :disp
(make-fixup nil
:code-object label
)))))
2649 (defun emit-constant-segment-header (segment constants optimize
)
2650 (declare (ignore segment constants
))
2651 (loop repeat
(if optimize
64 16) do
(inst byte
#x90
)))
2653 (defun size-nbyte (size)
2660 (defun sort-inline-constants (constants)
2661 (stable-sort constants
#'> :key
(lambda (constant)
2662 (size-nbyte (caar constant
)))))
2664 (defun emit-inline-constant (constant label
)
2665 (let ((size (size-nbyte (car constant
))))
2666 (emit-alignment (integer-length (1- size
)))
2668 (let ((val (cdr constant
)))
2670 do
(inst byte
(ldb (byte 8 0) val
))
2671 (setf val
(ash val -
8))))))