1 ;;;; target-only stuff from CMU CL's src/compiler/x86/insts.lisp
3 ;;;; i.e. stuff which was in CMU CL's insts.lisp file, but which in
4 ;;;; the SBCL build process can't be compiled into code for the
5 ;;;; cross-compilation host
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
16 (in-package "SB!X86-64-ASM")
18 (defstruct (machine-ea (:include sb
!disassem
::filtered-arg
)
21 (:constructor %make-machine-ea
))
22 base disp index scale
)
24 ;;; Print to STREAM the name of the general-purpose register encoded by
25 ;;; VALUE and of size WIDTH. For robustness, the high byte registers
26 ;;; (AH, BH, CH, DH) are correctly detected, too, although the compiler
27 ;;; does not use them.
28 (defun print-reg-with-width (value width stream dstate
)
29 (declare (type full-reg value
)
31 (type disassem-state dstate
))
32 (princ (if (and (eq width
:byte
)
34 (not (dstate-get-inst-prop dstate
+rex
+)))
35 (aref *high-byte-reg-names
* (- value
4))
37 (:byte
*byte-reg-names
*)
38 (:word
*word-reg-names
*)
39 (:dword
*dword-reg-names
*)
40 (:qword
*qword-reg-names
*))
43 ;; XXX plus should do some source-var notes
46 (defun print-reg (value stream dstate
)
47 (print-reg-with-width value
48 (inst-operand-size dstate
)
52 (defun print-reg-default-qword (value stream dstate
)
53 (print-reg-with-width value
54 (inst-operand-size-default-qword dstate
)
58 ;; Print a reg that can only be a :DWORD or :QWORD.
59 ;; Avoid use of INST-OPERAND-SIZE because it's wrong for this type of operand.
60 (defun print-d/q-word-reg
(value stream dstate
)
61 (print-reg-with-width value
62 (if (dstate-get-inst-prop dstate
+rex-w
+) :qword
:dword
)
66 (defun print-byte-reg (value stream dstate
)
67 (print-reg-with-width value
:byte stream dstate
))
69 (defun print-addr-reg (value stream dstate
)
70 (print-reg-with-width value
+default-address-size
+ stream dstate
))
72 ;;; Print a register or a memory reference of the given WIDTH.
73 ;;; If SIZED-P is true, add an explicit size indicator for memory
75 (defun print-reg/mem-with-width
(value width sized-p stream dstate
)
76 (declare (type (or machine-ea full-reg
) value
)
77 (type (member :byte
:word
:dword
:qword
) width
)
78 (type boolean sized-p
))
79 (if (typep value
'full-reg
)
80 (print-reg-with-width value width stream dstate
)
81 (print-mem-ref (if sized-p
:sized-ref
:ref
) value width stream dstate
)))
83 ;;; Print a register or a memory reference. The width is determined by
84 ;;; calling INST-OPERAND-SIZE.
85 (defun print-reg/mem
(value stream dstate
)
86 (print-reg/mem-with-width
87 value
(inst-operand-size dstate
) nil stream dstate
))
89 ;; Same as print-reg/mem, but prints an explicit size indicator for
91 (defun print-sized-reg/mem
(value stream dstate
)
92 (print-reg/mem-with-width
93 value
(inst-operand-size dstate
) t stream dstate
))
95 ;;; Same as print-sized-reg/mem, but with a default operand size of
97 (defun print-sized-reg/mem-default-qword
(value stream dstate
)
98 (print-reg/mem-with-width
99 value
(inst-operand-size-default-qword dstate
) t stream dstate
))
101 (defun print-sized-byte-reg/mem
(value stream dstate
)
102 (print-reg/mem-with-width value
:byte t stream dstate
))
104 (defun print-sized-word-reg/mem
(value stream dstate
)
105 (print-reg/mem-with-width value
:word t stream dstate
))
107 (defun print-sized-dword-reg/mem
(value stream dstate
)
108 (print-reg/mem-with-width value
:dword t stream dstate
))
110 (defun print-label (value stream dstate
)
111 (declare (ignore dstate
))
112 (princ16 value stream
))
114 (defun print-xmmreg (value stream dstate
)
115 (declare (type xmmreg value
) (type stream stream
) (ignore dstate
))
116 (format stream
"XMM~d" value
))
118 (defun print-xmmreg/mem
(value stream dstate
)
119 (if (typep value
'xmmreg
)
120 (print-xmmreg value stream dstate
)
121 (print-mem-ref :ref value nil stream dstate
)))
123 (defun print-imm/asm-routine
(value stream dstate
)
124 (maybe-note-assembler-routine value nil dstate
)
125 (maybe-note-static-symbol value dstate
)
126 (princ value stream
))
128 ;;; Return either a MACHINE-EA or a register (a fixnum).
129 ;;; VALUE is a list of the mod and r/m fields of the instruction's ModRM byte.
130 ;;; Depending on VALUE, a SIB byte and/or displacement may be read.
131 ;;; The REX.B and REX.X from dstate are appropriately consumed.
132 (defun prefilter-reg/mem
(dstate mod r
/m
)
133 (declare (type disassem-state dstate
)
134 (type (unsigned-byte 2) mod
)
135 (type (unsigned-byte 3) r
/m
))
136 (flet ((make-machine-ea (base &optional disp index scale
)
137 (let ((ea (the machine-ea
138 (sb!disassem
::new-filtered-arg dstate
#'%make-machine-ea
))))
139 (setf (machine-ea-base ea
) base
140 (machine-ea-disp ea
) disp
141 (machine-ea-index ea
) index
142 (machine-ea-scale ea
) scale
)
146 (#b01
(read-signed-suffix 8 dstate
))
147 (#b10
(read-signed-suffix 32 dstate
))))
148 (extend (bit-name reg
)
149 (logior (if (dstate-get-inst-prop dstate bit-name
) 8 0)
151 (declare (inline extend
))
152 (let ((full-reg (extend +rex-b
+ r
/m
)))
153 (cond ((= mod
#b11
) full-reg
) ; register direct mode
154 ((= r
/m
#b100
) ; SIB byte - rex.b is "don't care"
155 (let* ((sib (the (unsigned-byte 8) (read-suffix 8 dstate
)))
156 (index-reg (extend +rex-x
+ (ldb (byte 3 3) sib
)))
157 (base-reg (ldb (byte 3 0) sib
)))
158 ;; mod=0 and base=RBP means no base reg
159 (make-machine-ea (unless (and (= mod
#b00
) (= base-reg
#b101
))
160 (extend +rex-b
+ base-reg
))
161 (cond ((/= mod
#b00
) (displacement))
162 ((= base-reg
#b101
) (read-signed-suffix 32 dstate
)))
163 (unless (= index-reg
#b100
) index-reg
) ; index can't be RSP
164 (ash 1 (ldb (byte 2 6) sib
)))))
165 ((/= mod
#b00
) (make-machine-ea full-reg
(displacement)))
166 ;; rex.b is not decoded in determining RIP-relative mode
167 ((= r
/m
#b101
) (make-machine-ea :rip
(read-signed-suffix 32 dstate
)))
168 (t (make-machine-ea full-reg
))))))
170 ;;; Prints a memory reference to STREAM. VALUE is a list of
171 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component may be
172 ;;; missing or nil to indicate that it's not used or has the obvious
173 ;;; default value (e.g., 1 for the index-scale). BASE-REG can be the
174 ;;; symbol RIP or a full register, INDEX-REG a full register. If WIDTH
175 ;;; is non-nil it should be one of the symbols :BYTE, :WORD, :DWORD or
176 ;;; :QWORD; a corresponding size indicator is printed if MODE is :SIZED-REF.
177 ;;; The rationale for supplying WIDTH while eliding a pointer-size qualifier
178 ;;; is that proper dereferencing of RIP-relative constants requires a size,
179 ;;; but in other cases would only add clutter, since a source/destination
180 ;;; register implies a size.
182 (defun print-mem-ref (mode value width stream dstate
)
183 ;; :COMPUTE is used for the LEA instruction - it informs this function
184 ;; that we're not loading from the address and that the contents should not
185 ;; be printed. It'll usually be a reference to code within the disasembly
186 ;; segment, as LEA is employed to compute the entry point for local call.
187 (declare (type (member :ref
:sized-ref
:compute
) mode
)
188 (type machine-ea value
)
189 (type (member nil
:byte
:word
:dword
:qword
) width
)
191 (type disassem-state dstate
))
192 (let ((base-reg (machine-ea-base value
))
193 (disp (machine-ea-disp value
))
194 (index-reg (machine-ea-index value
))
196 (when (and width
(eq mode
:sized-ref
))
198 (princ '| PTR | stream
))
199 (write-char #\
[ stream
)
201 (if (eql :rip base-reg
)
202 (princ base-reg stream
)
203 (print-addr-reg base-reg stream dstate
))
206 (unless firstp
(write-char #\
+ stream
))
207 (print-addr-reg index-reg stream dstate
)
208 (let ((scale (machine-ea-scale value
)))
210 (write-char #\
* stream
)
211 (princ scale stream
)))
213 (when (and disp
(or firstp
(not (zerop disp
))))
214 (unless (or firstp
(minusp disp
))
215 (write-char #\
+ stream
))
216 (cond ((eq (machine-ea-base value
) :rip
)
218 (unless (eq mode
:compute
)
219 (let ((addr (+ disp
(dstate-next-addr dstate
))))
220 ;; The origin is zero when disassembling into a trace-file.
221 ;; Don't crash on account of it.
224 1 (note-code-constant-absolute addr dstate width
))
225 (maybe-note-assembler-routine addr nil dstate
)
226 ;; Show the absolute address and maybe the contents.
227 (note (format nil
"[#x~x]~@[ = ~x~]"
231 (unboxed-constant-ref
233 (+ (dstate-next-offs dstate
) disp
)))))
236 (princ16 disp stream
)
238 (nth-value 1 (note-code-constant-absolute disp dstate
))
239 (maybe-note-assembler-routine disp nil dstate
)
240 ;; Static symbols coming frorm CELL-REF
241 (maybe-note-static-symbol (+ disp
(- other-pointer-lowtag
245 (princ disp stream
))))
246 (write-char #\
] stream
)
248 (when (and (eql base-reg
#.
(ash (tn-offset sb
!vm
::thread-base-tn
) -
1))
249 (not index-reg
) ; no index
250 (typep disp
'(integer 0 *)) ; positive displacement
251 (seg-code (dstate-segment dstate
)))
252 ;; Try to reverse-engineer which thread-local binding this is
253 (let* ((code (seg-code (dstate-segment dstate
)))
254 (header-n-words (code-header-words code
))
255 (tls-index (ash disp
(- n-fixnum-tag-bits
))))
256 (loop for word-num from code-constants-offset below header-n-words
257 for obj
= (code-header-ref code word-num
)
258 when
(and (symbolp obj
) (= (symbol-tls-index obj
) tls-index
))
259 do
(return-from print-mem-ref
260 (note (lambda (stream) (format stream
"tls: ~S" obj
))
262 ;; Or maybe we're looking at the 'struct thread' itself
263 (when (< disp max-interrupts
)
266 (primitive-object-slots
267 (find 'sb
!vm
::thread
*primitive-objects
*
268 :key
#'primitive-object-name
)) t
))
269 (slot (find (ash disp
(- word-shift
)) thread-slots
270 :key
#'slot-offset
)))
272 (return-from print-mem-ref
273 (note (lambda (stream)
274 (format stream
"thread.~(~A~)" (slot-name slot
)))
277 (defun lea-compute-label (value dstate
)
278 ;; If VALUE should be regarded as a label, return the address.
279 ;; If not, just return VALUE.
280 (if (and (typep value
'machine-ea
) (eq (machine-ea-base value
) :rip
))
281 (+ (dstate-next-addr dstate
) (machine-ea-disp value
))
284 ;; Figure out whether LEA should print its EA with just the stuff in brackets,
285 ;; or additionally show the EA as either a label or a hex literal.
286 (defun lea-print-ea (value stream dstate
)
287 (let ((width (inst-operand-size dstate
))
292 ;; Indicate to PRINT-MEM-REF that this is not a memory access.
293 (print-mem-ref :compute value width stream dstate
)
294 (when (eq (machine-ea-base value
) :rip
)
295 (setq addr
(+ (dstate-next-addr dstate
) (machine-ea-disp value
)))))
297 ;; We're robust in allowing VALUE to be an integer (a register),
298 ;; though LEA Rx,Ry is an illegal instruction.
299 ;; Test this before INTEGER since the types overlap.
301 (print-reg-with-width value width stream dstate
))
304 ;; A label for the EA should not print as itself, but as the decomposed
305 ;; addressing mode so that [ADDR] and [RIP+disp] are unmistakable.
306 ;; We can see an INTEGER here because LEA-COMPUTE-LABEL is always called
307 ;; on the operand to LEA, and it will compute an absolute address based
308 ;; off RIP when possible. If :use-labels NIL was specified, there is
309 ;; no hashtable of address to string, so we get the address.
310 ;; But ordinarily we get the string. Either way, the r/m arg reveals the
311 ;; EA calculation. DCHUNK-ZERO is a meaningless value - any would do -
312 ;; because the EA was computed in a prefilter.
313 (print-mem-ref :compute
(reg-r/m-inst-r
/m-arg dchunk-zero dstate
)
316 (when (stringp value
) (setq fmt
"= ~A"))))
318 (note (lambda (s) (format s fmt addr
)) dstate
))))
320 (defun unboxed-constant-ref (dstate segment-offset
)
321 (let* ((seg (dstate-segment dstate
))
323 (sb!disassem
::segment-offs-to-code-offs segment-offset seg
))
324 (unboxed-range (sb!disassem
::seg-unboxed-data-range seg
)))
326 (<= (car unboxed-range
) code-offset
(cdr unboxed-range
))
327 (sap-ref-int (dstate-segment-sap dstate
)
328 segment-offset n-word-bytes
329 (dstate-byte-order dstate
)))))
331 ;;;; interrupt instructions
333 (defun break-control (chunk inst stream dstate
)
334 (declare (ignore inst
))
335 (flet ((nt (x) (if stream
(note x dstate
))))
336 (case #!-ud2-breakpoints
(byte-imm-code chunk dstate
)
337 #!+ud2-breakpoints
(word-imm-code chunk dstate
)
340 (handle-break-args #'snarf-error-junk stream dstate
))
343 (handle-break-args #'snarf-error-junk stream dstate
))
345 (nt "breakpoint trap"))
346 (#.pending-interrupt-trap
347 (nt "pending interrupt trap"))
350 (#.fun-end-breakpoint-trap
351 (nt "function end breakpoint trap"))
352 (#.single-step-around-trap
353 (nt "single-step trap (around)"))
354 (#.single-step-before-trap
355 (nt "single-step trap (before)"))
356 (#.invalid-arg-count-trap
357 (nt "Invalid argument count trap")))))
362 (defun sb!vm
::collect-immobile-code-relocs
()
363 (let ((code-components
364 (make-array 20000 :element-type
'(unsigned-byte 32)
365 :fill-pointer
0 :adjustable t
))
367 (make-array 100000 :element-type
'(unsigned-byte 32)
368 :fill-pointer
0 :adjustable t
))
369 ;; Look for these two instruction formats.
370 (jmp-inst (find-inst #b11101001
(get-inst-space)))
371 (call-inst (find-inst #b11101000
(get-inst-space)))
372 (seg (sb!disassem
::%make-segment
373 :sap-maker
#'error
:virtual-location
0))
374 (dstate (make-dstate)))
375 (flet ((scan-function (fun-entry-addr fun-end-addr predicate
)
376 (setf (seg-virtual-location seg
) fun-entry-addr
377 (seg-length seg
) (- fun-end-addr fun-entry-addr
)
379 (let ((sap (int-sap fun-entry-addr
))) (lambda () sap
)))
380 (map-segment-instructions
381 (lambda (dchunk inst
)
382 (when (and (or (eq inst jmp-inst
)
385 (+ (sb!disassem
::sign-extend
386 (ldb (byte 32 8) dchunk
) 32)
387 (dstate-next-addr dstate
))))
388 (vector-push-extend (dstate-cur-addr dstate
) relocs
)))
390 (finish-component (code start-relocs-index
)
391 (when (> (fill-pointer relocs
) start-relocs-index
)
392 (vector-push-extend (get-lisp-obj-address code
) code-components
)
393 (vector-push-extend start-relocs-index code-components
))))
395 ;; Assembler routines are in read-only space, and they can have
396 ;; relative jumps to immobile space.
397 ;; Since these code components do not contain simple-funs,
398 ;; we have to group the routines by looking at addresses.
400 (mapcar #'cdr
(%hash-table-alist sb
!fasl
:*assembler-routines
*)))
402 (sb!vm
::map-allocated-objects
(lambda (obj type size
)
403 (declare (ignore size
))
404 (when (= type sb
!vm
:code-header-widetag
)
405 (push obj code-components
)))
407 (dolist (code (nreverse code-components
))
408 (let* ((text-origin (sap-int (code-instructions code
)))
409 (text-end (+ text-origin
(%code-code-size code
)))
410 (relocs-index (fill-pointer relocs
)))
412 (scan-function (car list
)
413 (if (cdr list
) (cadr list
) text-end
)
414 ;; Look for transfers into immobile code
415 (lambda (jmp-targ-addr)
416 (<= sb
!vm
:immobile-space-start
417 jmp-targ-addr sb
!vm
:immobile-space-end
))))
418 (sort (remove-if-not (lambda (address)
419 (<= text-origin address text-end
))
421 (finish-component code relocs-index
))))
423 ;; Immobile space - code components can jump to immobile space,
424 ;; read-only space, and C runtime routines.
425 (sb!vm
::map-allocated-objects
426 (lambda (code type size
)
427 (declare (ignore size
))
428 (when (= type code-header-widetag
)
429 (let* ((text-origin (sap-int (code-instructions code
)))
430 (text-end (+ text-origin
(%code-code-size code
)))
431 (relocs-index (fill-pointer relocs
)))
432 (dotimes (i (code-n-entries code
) (finish-component code relocs-index
))
433 (let ((fun (%code-entry-point code i
)))
435 (+ (get-lisp-obj-address fun
) (- fun-pointer-lowtag
)
436 (ash simple-fun-code-offset word-shift
))
437 (if (< (1+ i
) (code-n-entries code
))
438 (- (get-lisp-obj-address (%code-entry-point code
(1+ i
)))
441 ;; Exclude transfers within this code component
442 (lambda (jmp-targ-addr)
443 (not (<= text-origin jmp-targ-addr text-end
)))))))))
446 ;; Write a delimiter into the array passed to C
447 (vector-push-extend 0 code-components
)
448 (vector-push-extend (fill-pointer relocs
) code-components
)
449 (values code-components relocs
)))