1 ;;;; disassembler-related stuff not needed in cross-compilation host
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!DISASSEM")
14 ;;;; FIXME: A lot of stupid package prefixes would go away if DISASSEM
15 ;;;; would use the SB!DI package. And some more would go away if it would
16 ;;;; use SB!SYS (in order to get to the SAP-FOO operators).
18 ;;;; combining instructions where one specializes another
20 ;;; Return non-NIL if the instruction SPECIAL is a more specific
21 ;;; version of GENERAL (i.e., the same instruction, but with more
23 (defun inst-specializes-p (special general
)
24 (declare (type instruction special general
))
25 (let ((smask (inst-mask special
))
26 (gmask (inst-mask general
)))
27 (and (dchunk= (inst-id general
)
28 (dchunk-and (inst-id special
) gmask
))
29 (dchunk-strict-superset-p smask gmask
))))
31 ;;; a bit arbitrary, but should work ok...
33 ;;; Return an integer corresponding to the specificity of the
35 (defun specializer-rank (inst)
36 (declare (type instruction inst
))
37 (* (dchunk-count-bits (inst-mask inst
)) 4))
39 ;;; Order the list of instructions INSTS with more specific (more
40 ;;; constant bits, or same-as argument constains) ones first. Returns
42 (defun order-specializers (insts)
43 (declare (type list insts
))
44 (sort insts
#'> :key
#'specializer-rank
))
46 (defun specialization-error (insts)
48 "~@<Instructions either aren't related or conflict in some way: ~4I~_~S~:>"
51 ;;; Given a list of instructions INSTS, Sees if one of these instructions is a
52 ;;; more general form of all the others, in which case they are put into its
53 ;;; specializers list, and it is returned. Otherwise an error is signaled.
54 (defun try-specializing (insts)
55 (declare (type list insts
))
56 (let ((masters (copy-list insts
)))
57 (dolist (possible-master insts
)
58 (dolist (possible-specializer insts
)
59 (unless (or (eq possible-specializer possible-master
)
60 (inst-specializes-p possible-specializer possible-master
))
61 (setf masters
(delete possible-master masters
))
62 (return) ; exit the inner loop
65 (specialization-error insts
))
67 (error "multiple specializing masters: ~S" masters
))
69 (let ((master (car masters
)))
70 (setf (inst-specializers master
)
71 (order-specializers (remove master insts
)))
74 ;;;; choosing an instruction
76 #!-sb-fluid
(declaim (inline inst-matches-p choose-inst-specialization
))
78 ;;; Return non-NIL if all constant-bits in INST match CHUNK.
79 (defun inst-matches-p (inst chunk
)
80 (declare (type instruction inst
)
82 (dchunk= (dchunk-and (inst-mask inst
) chunk
) (inst-id inst
)))
84 ;;; Given an instruction object, INST, and a bit-pattern, CHUNK, pick
85 ;;; the most specific instruction on INST's specializer list whose
86 ;;; constraints are met by CHUNK. If none do, then return INST.
87 (defun choose-inst-specialization (inst chunk
)
88 (declare (type instruction inst
)
90 (or (dolist (spec (inst-specializers inst
) nil
)
91 (declare (type instruction spec
))
92 (when (inst-matches-p spec chunk
)
96 ;;;; searching for an instruction in instruction space
98 ;;; Return the instruction object within INST-SPACE corresponding to the
99 ;;; bit-pattern CHUNK, or NIL if there isn't one.
100 (defun find-inst (chunk inst-space
)
101 (declare (type dchunk chunk
)
102 (type (or null inst-space instruction
) inst-space
))
103 (etypecase inst-space
106 (if (inst-matches-p inst-space chunk
)
107 (choose-inst-specialization inst-space chunk
)
110 (let* ((mask (ispace-valid-mask inst-space
))
111 (id (dchunk-and mask chunk
)))
112 (declare (type dchunk id mask
))
113 (dolist (choice (ispace-choices inst-space
))
114 (declare (type inst-space-choice choice
))
115 (when (dchunk= id
(ischoice-common-id choice
))
116 (return (find-inst chunk
(ischoice-subspace choice
)))))))))
118 ;;;; building the instruction space
120 ;;; Returns an instruction-space object corresponding to the list of
121 ;;; instructions INSTS. If the optional parameter INITIAL-MASK is
122 ;;; supplied, only bits it has set are used.
123 (defun build-inst-space (insts &optional
(initial-mask dchunk-one
))
124 ;; This is done by finding any set of bits that's common to
125 ;; all instructions, building an instruction-space node that selects on those
126 ;; bits, and recursively handle sets of instructions with a common value for
127 ;; these bits (which, since there should be fewer instructions than in INSTS,
128 ;; should have some additional set of bits to select on, etc). If there
129 ;; are no common bits, or all instructions have the same value within those
130 ;; bits, TRY-SPECIALIZING is called, which handles the cases of many
131 ;; variations on a single instruction.
132 (declare (type list insts
)
133 (type dchunk initial-mask
))
139 (let ((vmask (dchunk-copy initial-mask
)))
141 (dchunk-andf vmask
(inst-mask inst
)))
142 (if (dchunk-zerop vmask
)
143 (try-specializing insts
)
146 (let* ((common-id (dchunk-and (inst-id inst
) vmask
))
147 (bucket (assoc common-id buckets
:test
#'dchunk
=)))
149 (push (list common-id inst
) buckets
))
151 (push inst
(cdr bucket
))))))
152 (let ((submask (dchunk-clear initial-mask vmask
)))
153 (if (= (length buckets
) 1)
154 (try-specializing insts
)
157 :choices
(mapcar (lambda (bucket)
158 (make-inst-space-choice
159 :subspace
(build-inst-space
162 :common-id
(car bucket
)))
165 ;;;; an inst-space printer for debugging purposes
167 (defun print-masked-binary (num mask word-size
&optional
(show word-size
))
168 (do ((bit (1- word-size
) (1- bit
)))
170 (write-char (cond ((logbitp bit mask
)
171 (if (logbitp bit num
) #\
1 #\
0))
175 (defun print-inst-bits (inst)
176 (print-masked-binary (inst-id inst
)
179 (bytes-to-bits (inst-length inst
))))
181 ;;; Print a nicely-formatted version of INST-SPACE.
182 (defun print-inst-space (inst-space &optional
(indent 0))
183 (etypecase inst-space
186 (format t
"~Vt[~A(~A)~40T" indent
187 (inst-name inst-space
)
188 (inst-format-name inst-space
))
189 (print-inst-bits inst-space
)
190 (dolist (inst (inst-specializers inst-space
))
191 (format t
"~%~Vt:~A~40T" indent
(inst-name inst
))
192 (print-inst-bits inst
))
196 (format t
"~Vt---- ~8,'0X ----~%"
198 (ispace-valid-mask inst-space
))
201 (format t
"~Vt~8,'0X ==>~%"
203 (ischoice-common-id choice
))
204 (print-inst-space (ischoice-subspace choice
)
206 (ispace-choices inst-space
)))))
208 ;;;; (The actual disassembly part follows.)
210 ;;; Code object layout:
212 ;;; code-size (starting from first inst, in bytes)
213 ;;; entry-points (points to first function header)
218 ;;; <padding to dual-word boundary>
219 ;;; start of instructions
221 ;;; fun-headers and lra's buried in here randomly
223 ;;; <padding to dual-word boundary>
225 ;;; Function header layout (dual word aligned):
228 ;;; next pointer (next function header)
233 ;;; LRA layout (dual word aligned):
236 #!-sb-fluid
(declaim (inline words-to-bytes
))
238 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
239 ;;; Convert a word-offset NUM to a byte-offset.
240 (defun words-to-bytes (num)
241 (declare (type offset num
))
242 (ash num sb
!vm
:word-shift
))
245 (defconstant lra-size
(words-to-bytes 1))
247 (defstruct (offs-hook (:copier nil
))
248 (offset 0 :type offset
)
249 (fun (missing-arg) :type function
)
250 (before-address nil
:type
(member t nil
)))
252 (defmethod print-object ((seg segment
) stream
)
253 (print-unreadable-object (seg stream
:type t
)
254 (let ((addr (sap-int (funcall (seg-sap-maker seg
)))))
255 (format stream
"#X~X..~X[~W]~:[ (#X~X)~;~*~]~@[ in ~S~]"
256 addr
(+ addr
(seg-length seg
)) (seg-length seg
)
257 (= (seg-virtual-location seg
) addr
)
258 (seg-virtual-location seg
)
263 (defun fun-self (fun)
264 (declare (type compiled-function fun
))
265 (%simple-fun-self
(%fun-fun fun
)))
267 (defun fun-code (fun)
268 (declare (type compiled-function fun
))
269 (fun-code-header (fun-self fun
)))
271 (defun fun-next (fun)
272 (declare (type compiled-function fun
))
273 (%simple-fun-next
(%fun-fun fun
)))
275 (defun fun-address (fun)
276 (declare (type compiled-function fun
))
277 (- (get-lisp-obj-address (%fun-fun fun
)) sb
!vm
:fun-pointer-lowtag
))
279 ;;; the offset of FUNCTION from the start of its code-component's
281 (defun fun-insts-offset (function)
282 (declare (type compiled-function function
))
283 (- (fun-address function
)
284 (sap-int (code-instructions (fun-code function
)))))
286 ;;; the offset of FUNCTION from the start of its code-component
287 (defun fun-offset (function)
288 (declare (type compiled-function function
))
289 (words-to-bytes (get-closure-length function
)))
291 ;;;; operations on code-components (which hold the instructions for
292 ;;;; one or more functions)
294 ;;; Return the length of the instruction area in CODE-COMPONENT.
295 (defun code-inst-area-length (code-component)
296 (declare (type code-component code-component
))
297 (%code-code-size code-component
))
299 (defun segment-offs-to-code-offs (offset segment
)
301 (let* ((seg-base-addr (sap-int (funcall (seg-sap-maker segment
))))
303 (logandc1 sb
!vm
:lowtag-mask
304 (get-lisp-obj-address (seg-code segment
))))
305 (addr (+ offset seg-base-addr
)))
306 (declare (type address seg-base-addr code-addr addr
))
307 (- addr code-addr
))))
309 (defun code-offs-to-segment-offs (offset segment
)
311 (let* ((seg-base-addr (sap-int (funcall (seg-sap-maker segment
))))
313 (logandc1 sb
!vm
:lowtag-mask
314 (get-lisp-obj-address (seg-code segment
))))
315 (addr (+ offset code-addr
)))
316 (declare (type address seg-base-addr code-addr addr
))
317 (- addr seg-base-addr
))))
319 (defun code-insts-offs-to-segment-offs (offset segment
)
321 (let* ((seg-base-addr (sap-int (funcall (seg-sap-maker segment
))))
323 (sap-int (code-instructions (seg-code segment
))))
324 (addr (+ offset code-insts-addr
)))
325 (declare (type address seg-base-addr code-insts-addr addr
))
326 (- addr seg-base-addr
))))
329 (defun lra-hook (chunk stream dstate
)
330 (declare (type dchunk chunk
)
332 (type (or null stream
) stream
)
333 (type disassem-state dstate
))
334 (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate
))
335 (dstate-cur-offs dstate
))
336 (* 2 sb
!vm
:n-word-bytes
))
338 (= (sap-ref-8 (dstate-segment-sap dstate
)
339 (if (eq (dstate-byte-order dstate
)
341 (dstate-cur-offs dstate
)
342 (+ (dstate-cur-offs dstate
)
344 sb
!vm
:return-pc-header-widetag
))
345 (unless (null stream
)
346 (note "possible LRA header" dstate
)))
349 ;;; Print the fun-header (entry-point) pseudo-instruction at the
350 ;;; current location in DSTATE to STREAM.
351 (defun fun-header-hook (stream dstate
)
352 (declare (type (or null stream
) stream
)
353 (type disassem-state dstate
))
354 (unless (null stream
)
355 (let* ((seg (dstate-segment dstate
))
356 (code (seg-code seg
))
357 (woffs (ash (segment-offs-to-code-offs (dstate-cur-offs dstate
) seg
)
358 (- sb
!vm
:word-shift
))) ; bytes -> words
359 (name (code-header-ref code
(+ woffs sb
!vm
:simple-fun-name-slot
)))
360 (args (code-header-ref code
(+ woffs sb
!vm
:simple-fun-arglist-slot
)))
361 (type (code-header-ref code
(+ woffs sb
!vm
:simple-fun-type-slot
))))
362 ;; if the function's name conveys its args, don't show ARGS too
363 (format stream
".~A ~S~:[~:A~;~]" 'entry name
364 (and (typep name
'(cons (eql lambda
) (cons list
)))
365 (equal args
(second name
)))
367 (note (lambda (stream)
368 (format stream
"~:S" type
)) ; use format to print NIL as ()
370 (incf (dstate-next-offs dstate
)
371 (words-to-bytes sb
!vm
:simple-fun-code-offset
)))
373 (defun alignment-hook (chunk stream dstate
)
374 (declare (type dchunk chunk
)
376 (type (or null stream
) stream
)
377 (type disassem-state dstate
))
379 (+ (seg-virtual-location (dstate-segment dstate
))
380 (dstate-cur-offs dstate
)))
381 (alignment (dstate-alignment dstate
)))
382 (unless (aligned-p location alignment
)
384 (format stream
"~A~Vt~W~%" '.align
385 (dstate-argument-column dstate
)
387 (incf (dstate-next-offs dstate
)
388 (- (align location alignment
) location
)))
391 (defun rewind-current-segment (dstate segment
)
392 (declare (type disassem-state dstate
)
393 (type segment segment
))
394 (setf (dstate-segment dstate
) segment
)
395 (setf (dstate-inst-properties dstate
) nil
)
396 (setf (dstate-cur-offs-hooks dstate
)
397 (stable-sort (nreverse (copy-list (seg-hooks segment
)))
399 (or (< (offs-hook-offset oh1
) (offs-hook-offset oh2
))
400 (and (= (offs-hook-offset oh1
)
401 (offs-hook-offset oh2
))
402 (offs-hook-before-address oh1
)
403 (not (offs-hook-before-address oh2
)))))))
404 (setf (dstate-cur-offs dstate
) 0)
405 (setf (dstate-cur-labels dstate
) (dstate-labels dstate
)))
407 (defun call-offs-hooks (before-address stream dstate
)
408 (declare (type (or null stream
) stream
)
409 (type disassem-state dstate
))
410 (let ((cur-offs (dstate-cur-offs dstate
)))
411 (setf (dstate-next-offs dstate
) cur-offs
)
413 (let ((next-hook (car (dstate-cur-offs-hooks dstate
))))
414 (when (null next-hook
)
416 (let ((hook-offs (offs-hook-offset next-hook
)))
417 (when (or (> hook-offs cur-offs
)
418 (and (= hook-offs cur-offs
)
420 (not (offs-hook-before-address next-hook
))))
422 (unless (< hook-offs cur-offs
)
423 (funcall (offs-hook-fun next-hook
) stream dstate
))
424 (pop (dstate-cur-offs-hooks dstate
))
425 (unless (= (dstate-next-offs dstate
) cur-offs
)
428 (defun call-fun-hooks (chunk stream dstate
)
429 (let ((hooks (dstate-fun-hooks dstate
))
430 (cur-offs (dstate-cur-offs dstate
)))
431 (setf (dstate-next-offs dstate
) cur-offs
)
432 (dolist (hook hooks nil
)
433 (let ((prefix-p (funcall hook chunk stream dstate
)))
434 (unless (= (dstate-next-offs dstate
) cur-offs
)
435 (return prefix-p
))))))
437 ;;; Print enough spaces to fill the column used for instruction bytes,
438 ;;; assuming that N-BYTES many instruction bytes have already been
439 ;;; printed in it, then print an additional space as separator to the
441 (defun pad-inst-column (stream n-bytes
)
442 (declare (type stream stream
)
443 (type text-width n-bytes
))
444 (when (> *disassem-inst-column-width
* 0)
445 (dotimes (i (- *disassem-inst-column-width
* (* 2 n-bytes
)))
446 (write-char #\space stream
))
447 (write-char #\space stream
)))
449 (defun handle-bogus-instruction (stream dstate prefix-len
)
450 (let ((alignment (dstate-alignment dstate
)))
451 (unless (null stream
)
452 (multiple-value-bind (words bytes
)
453 (truncate alignment sb
!vm
:n-word-bytes
)
455 (print-inst (* words sb
!vm
:n-word-bytes
) stream dstate
456 :trailing-space nil
))
458 (print-inst bytes stream dstate
:trailing-space nil
)))
459 (pad-inst-column stream
(+ prefix-len alignment
))
460 (decf (dstate-cur-offs dstate
) prefix-len
)
461 (print-bytes (+ prefix-len alignment
) stream dstate
))
462 (incf (dstate-next-offs dstate
) alignment
)))
464 ;;; FIXME: This should be an FLET but it's too big to look at comfortably.
465 (declaim (inline !sap-ref-dchunk
))
466 (defun !sap-ref-dchunk
(sap byte-offset byte-order
)
467 (declare (type system-area-pointer sap
)
468 (type offset byte-offset
)
469 (muffle-conditions compiler-note
) ; returns possible bignum
470 ;; Not all backends can actually disassemble for either byte order.
471 (ignorable byte-order
)
472 (optimize (speed 3) (safety 0)))
474 (logand (sap-ref-word sap byte-offset
) dchunk-one
)
477 ;; Why all the noise with hand addition? I have no idea.
478 ;; The target can only disassemble its own instruction set + byte order,
479 ;; so probably this should just be SAP-REF-WORD.
481 (32 (if (eq byte-order
:big-endian
)
482 (+ (ash (sap-ref-8 sap byte-offset
) 24)
483 (ash (sap-ref-8 sap
(+ 1 byte-offset
)) 16)
484 (ash (sap-ref-8 sap
(+ 2 byte-offset
)) 8)
485 (sap-ref-8 sap
(+ 3 byte-offset
)))
486 (+ (sap-ref-8 sap byte-offset
)
487 (ash (sap-ref-8 sap
(+ 1 byte-offset
)) 8)
488 (ash (sap-ref-8 sap
(+ 2 byte-offset
)) 16)
489 (ash (sap-ref-8 sap
(+ 3 byte-offset
)) 24))))
490 (64 (if (eq byte-order
:big-endian
)
491 (+ (ash (sap-ref-8 sap byte-offset
) 56)
492 (ash (sap-ref-8 sap
(+ 1 byte-offset
)) 48)
493 (ash (sap-ref-8 sap
(+ 2 byte-offset
)) 40)
494 (ash (sap-ref-8 sap
(+ 3 byte-offset
)) 32)
495 (ash (sap-ref-8 sap
(+ 4 byte-offset
)) 24)
496 (ash (sap-ref-8 sap
(+ 5 byte-offset
)) 16)
497 (ash (sap-ref-8 sap
(+ 6 byte-offset
)) 8)
498 (sap-ref-8 sap
(+ 7 byte-offset
)))
499 (+ (sap-ref-8 sap byte-offset
)
500 (ash (sap-ref-8 sap
(+ 1 byte-offset
)) 8)
501 (ash (sap-ref-8 sap
(+ 2 byte-offset
)) 16)
502 (ash (sap-ref-8 sap
(+ 3 byte-offset
)) 24)
503 (ash (sap-ref-8 sap
(+ 4 byte-offset
)) 32)
504 (ash (sap-ref-8 sap
(+ 5 byte-offset
)) 40)
505 (ash (sap-ref-8 sap
(+ 6 byte-offset
)) 48)
506 (ash (sap-ref-8 sap
(+ 7 byte-offset
)) 56)))))))
508 (defstruct (filtered-arg (:copier nil
) (:predicate nil
) (:constructor nil
))
510 ;;; Return an arbitrary object (one that is a subtype of FILTERED-ARG)
511 ;;; that is automatically returned to the dstate's filtered-arg-pool
512 ;;; after disassembly of the current instruction.
513 ;;; Any given disassembler backend must use the same constructor for
514 ;;; its filtered args that participate in the pool.
515 (defun new-filtered-arg (dstate constructor
)
516 (let ((arg (dstate-filtered-arg-pool-free dstate
)))
518 (setf (dstate-filtered-arg-pool-free dstate
) (filtered-arg-next arg
))
519 (setf arg
(funcall constructor
)))
520 (sb!c
::push-in filtered-arg-next arg
(dstate-filtered-arg-pool-in-use dstate
))
523 ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
524 ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE.
525 ;;; Additionally, unless STREAM is NIL, several items are output to it:
526 ;;; things printed from several hooks, for example labels, and instruction
527 ;;; bytes before FUNCTION is called, notes and a newline afterwards.
528 ;;; Instructions having an INST-PRINTER of NIL are treated as prefix
529 ;;; instructions which makes them print on the same line as the following
530 ;;; instruction, outputting their INST-PRINT-NAME (unless that is NIL)
531 ;;; before FUNCTION is called for the following instruction.
532 (defun map-segment-instructions (function segment dstate
&optional stream
)
533 (declare (type function function
)
534 (type segment segment
)
535 (type disassem-state dstate
)
536 (type (or null stream
) stream
))
538 (let ((ispace (get-inst-space))
540 ;; If the segment starts with unboxed data,
541 ;; dump some number of words using the .WORD pseudo-ops.
542 (if (and (seg-unboxed-data-range segment
)
543 (= (segment-offs-to-code-offs 0 segment
)
544 (car (seg-unboxed-data-range segment
))))
545 (code-offs-to-segment-offs (cdr (seg-unboxed-data-range segment
))
548 (prefix-p nil
) ; just processed a prefix inst
549 (prefix-len 0) ; sum of lengths of any prefix instruction(s)
550 (prefix-print-names nil
)) ; reverse list of prefixes seen
552 (rewind-current-segment dstate segment
)
555 (when (>= (dstate-cur-offs dstate
) (seg-length (dstate-segment dstate
)))
557 (when (and stream
(> prefix-len
0))
558 (pad-inst-column stream prefix-len
)
559 (decf (dstate-cur-offs dstate
) prefix-len
)
560 (print-bytes prefix-len stream dstate
)
561 (incf (dstate-cur-offs dstate
) prefix-len
))
564 (setf (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
566 (call-offs-hooks t stream dstate
)
567 (unless (or prefix-p
(null stream
))
568 (print-current-address stream dstate
))
569 (call-offs-hooks nil stream dstate
)
571 (when (< (dstate-cur-offs dstate
) data-end-offset
)
574 (format stream
"~A #x~v,'0x" '.word
575 (* 2 sb
!vm
:n-word-bytes
)
576 (sap-ref-int (funcall (seg-sap-maker segment
))
577 (dstate-cur-offs dstate
)
579 (dstate-byte-order dstate
)))))
580 (setf (dstate-next-offs dstate
)
581 (+ (dstate-cur-offs dstate
) sb
!vm
:n-word-bytes
)))
583 (unless (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
584 ;; FIXME: this can probably be WITH-PINNED-OBJECTS. For octet vectors and code
585 ;; there is something to pin, whereas if you are passing a memory address then
586 ;; you are either inside without-gcing anyway for this to be sensible at all,
587 ;; or are disassembling foreign code.
589 (setf (dstate-segment-sap dstate
) (funcall (seg-sap-maker segment
)))
591 (let* ((bytes-remaining (- (seg-length (dstate-segment dstate
))
592 (dstate-cur-offs dstate
)))
594 (multiple-value-bind (sap offset
)
595 ;; Don't read beyond the segment. This can occur with DISASSEMBLE-MEMORY
596 ;; on a function whose code ends in pad bytes that are not an integral
597 ;; number of instructions, and maybe you're so unlucky as to be
598 ;; on the exact last page of your heap.
599 (if (< bytes-remaining
(/ dchunk-bits
8))
600 (let* ((scratch-buf (dstate-scratch-buf dstate
))
601 (sap (vector-sap scratch-buf
)))
602 ;; We're inside a WITHOUT-GCING (up above).
603 ;; Otherwise, put (dstate-scratch-buf dstate) in WPO
605 (system-area-ub8-copy
606 (dstate-segment-sap dstate
)
607 (dstate-cur-offs dstate
)
608 sap
0 bytes-remaining
)
610 (values (dstate-segment-sap dstate
)
611 (dstate-cur-offs dstate
)))
612 (!sap-ref-dchunk sap offset
(dstate-byte-order dstate
))))
613 (fun-prefix-p (call-fun-hooks chunk stream dstate
)))
614 (if (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
615 (setf prefix-p fun-prefix-p
)
616 (let ((inst (find-inst chunk ispace
)))
618 (handle-bogus-instruction stream dstate prefix-len
)
620 ;; On x86, the pad bytes at the end of a simple-fun
621 ;; decode as "ADD [RAX], AL" if there are 2 bytes,
622 ;; but if there's only 1 byte, it should show "BYTE 0".
623 ;; There's really nothing we can do about the former.
624 ((> (inst-length inst
) bytes-remaining
)
626 (print-inst bytes-remaining stream dstate
)
627 (print-bytes bytes-remaining stream dstate
)
631 (setf (dstate-next-offs dstate
)
632 (+ (dstate-cur-offs dstate
)
634 (let ((orig-next (dstate-next-offs dstate
))
635 (control (inst-control inst
)))
637 (print-inst (inst-length inst
) stream dstate
638 :trailing-space nil
))
640 (dolist (item (inst-prefilters inst
))
641 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
642 ;; item = #(INDEX FUNCTION SIGN-EXTEND-P BYTE-SPEC ...).
643 (flet ((extract-byte (spec-index)
644 (let* ((byte-spec (svref item spec-index
))
645 (integer (dchunk-extract chunk byte-spec
)))
646 (if (svref item
2) ; SIGN-EXTEND-P
647 (sign-extend integer
(byte-size byte-spec
))
649 (let ((item-length (length item
))
650 (fun (svref item
1)))
651 (setf (svref (dstate-filtered-values dstate
) (svref item
0))
653 (2 (funcall fun dstate
)) ; no subfields
654 (3 (bug "Bogus prefilter"))
655 (4 (funcall fun dstate
(extract-byte 3))) ; one subfield
656 (5 (funcall fun dstate
; two subfields
657 (extract-byte 3) (extract-byte 4)))
658 (t (apply fun dstate
; > 2 subfields
659 (loop for i from
3 below item-length
660 collect
(extract-byte i
)))))))))
662 (setf prefix-p
(null (inst-printer inst
)))
665 ;; Print any instruction bytes recognized by
666 ;; the prefilter which calls read-suffix and
667 ;; updates next-offs.
668 (let ((suffix-len (- (dstate-next-offs dstate
)
670 (when (plusp suffix-len
)
671 (print-inst suffix-len stream dstate
672 :offset
(inst-length inst
)
673 :trailing-space nil
))
674 ;; Keep track of the number of bytes
676 (incf prefix-len
(+ (inst-length inst
)
679 (let ((name (inst-print-name inst
)))
681 (push name prefix-print-names
)))
683 ;; PREFIX-LEN includes the length of the
684 ;; current (non-prefix) instruction here.
685 (pad-inst-column stream prefix-len
)
686 (dolist (name (reverse prefix-print-names
))
688 (write-char #\space stream
)))))
690 (funcall function chunk inst
)
693 (funcall control chunk inst stream dstate
))))))))))
695 (setf (dstate-cur-offs dstate
) (dstate-next-offs dstate
))
700 prefix-print-names nil
)
701 (print-notes-and-newline stream dstate
))
702 (setf (dstate-output-state dstate
) nil
))
704 (let ((arg (dstate-filtered-arg-pool-in-use dstate
)))
705 (loop (unless arg
(return))
706 (let ((saved-next (filtered-arg-next arg
)))
707 (sb!c
::push-in filtered-arg-next arg
708 (dstate-filtered-arg-pool-free dstate
))
709 (setq arg saved-next
))))
710 (setf (dstate-filtered-arg-pool-in-use dstate
) nil
)
711 (setf (dstate-inst-properties dstate
) nil
)))))
714 (defun collect-labelish-operands (args cache
)
715 (awhen (remove-if-not #'arg-use-label args
)
716 (let* ((list (mapcar (lambda (arg &aux
(fun (arg-use-label arg
))
717 (prefilter (arg-prefilter arg
))
718 (bytes (arg-fields arg
)))
719 ;; Require byte specs or a prefilter (or both).
720 ;; Prefilter alone is ok - it can use READ-SUFFIX.
721 ;; Additionally, you can't have :use-label T
722 ;; if multiple fields exist with no prefilter.
724 (if (eq fun t
) (singleton-p bytes
) bytes
)))
725 ;; If arg has a prefilter, just compute its index,
726 ;; otherwise keep the byte specs for extraction.
727 (coerce (cons (if (eq fun t
) #'identity fun
)
729 (list (posq arg args
))
730 (cons (arg-sign-extend-p arg
) bytes
)))
733 (repr (if (cdr list
) list
(car list
))) ; usually just 1 item
734 (table (assq :labeller cache
)))
735 (or (find repr
(cdr table
) :test
'equalp
)
736 (car (push repr
(cdr table
)))))))
738 ;;; Make an initial non-printing disassembly pass through DSTATE,
739 ;;; noting any addresses that are referenced by instructions in this
741 (defun add-segment-labels (segment dstate
)
742 ;; add labels at the beginning with a label-number of nil; we'll notice
743 ;; later and fill them in (and sort them)
744 (declare (type disassem-state dstate
))
745 (let ((labels (dstate-labels dstate
)))
746 (map-segment-instructions
748 (declare (type dchunk chunk
) (type instruction inst
))
749 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
750 (loop with list
= (inst-labeller inst
)
752 ;; item = #(FUNCTION PREFILTERED-VALUE-INDEX)
753 ;; | #(FUNCTION SIGN-EXTEND-P BYTE-SPEC ...)
754 for item
= (if (listp list
) (pop list
) (prog1 list
(setq list nil
)))
756 do
(let* ((item-length (length item
))
757 (index/signedp
(svref item
1))
761 (flet ((extract-byte (spec-index)
762 (let* ((byte-spec (svref item spec-index
))
763 (integer (dchunk-extract chunk byte-spec
)))
765 (sign-extend integer
(byte-size byte-spec
))
768 (2 (svref (dstate-filtered-values dstate
) index
/signedp
))
769 (3 (extract-byte 2)) ; extract exactly one byte
770 (t ; extract >1 byte.
771 ;; FIXME: this is strictly redundant.
772 ;; You should combine fields in the prefilter
773 ;; so that the labeller receives a single byte.
774 ;; AARCH64 and HPPA make use of this though.
775 (loop for i from
2 below item-length
776 collect
(extract-byte i
)))))
778 ;; If non-integer, the value is not a label.
779 (when (and (integerp adjusted-value
)
780 (not (assoc adjusted-value labels
)))
781 (push (cons adjusted-value nil
) labels
)))))
784 (setf (dstate-labels dstate
) labels
)
785 ;; erase any notes that got there by accident
786 (setf (dstate-notes dstate
) nil
)))
788 ;;; If any labels in DSTATE have been added since the last call to
789 ;;; this function, give them label-numbers, enter them in the
790 ;;; hash-table, and make sure the label list is in sorted order.
791 (defun number-labels (dstate)
792 (let ((labels (dstate-labels dstate
)))
793 (when (and labels
(null (cdar labels
)))
794 ;; at least one label left un-numbered
795 (setf labels
(sort labels
#'< :key
#'car
))
797 (label-hash (dstate-label-hash dstate
)))
798 (dolist (label labels
)
799 (when (not (null (cdr label
)))
800 (setf max
(max max
(cdr label
)))))
801 (dolist (label labels
)
802 (when (null (cdr label
))
804 (setf (cdr label
) max
)
805 (setf (gethash (car label
) label-hash
)
806 (format nil
"L~W" max
)))))
807 (setf (dstate-labels dstate
) labels
))))
809 (defun collect-inst-variants (base-name package variants cache
)
810 (loop for printer in variants
813 (destructuring-bind (format-name
814 (&rest arg-constraints
)
815 &optional
(printer :default
)
817 (without-package-locks (intern base-name package
)))
820 (declare (type (or symbol string
) print-name
))
821 (let* ((format (format-or-lose format-name
))
822 (args (copy-list (format-args format
)))
823 (format-length (bytes-to-bits (format-length format
))))
824 (dolist (constraint arg-constraints
)
825 (destructuring-bind (name . props
) constraint
826 (let ((cell (member name args
:key
#'arg-name
))
829 (setf (car cell
) (setf arg
(copy-structure (car cell
))))
830 (setf args
(nconc args
(list (setf arg
(%make-arg name
))))))
832 arg format-length
(and props
(cons :value props
))))))
833 (multiple-value-bind (mask id
) (compute-mask-id args
)
835 base-name format-name print-name
836 (format-length format
) mask id
837 (awhen (if (eq printer
:default
)
838 (format-default-printer format
)
840 (find-printer-fun it args cache
(list base-name index
)))
841 (collect-labelish-operands args cache
)
842 (collect-prefiltering-args args cache
)
845 (defun !compile-inst-printers
()
846 (let ((package sb
!assem
::*backend-instruction-set-package
*)
847 (cache (list (list :printer
) (list :prefilter
) (list :labeller
))))
848 (do-symbols (symbol package
)
849 (awhen (get symbol
'instruction-flavors
)
850 (setf (get symbol
'instruction-flavors
)
851 (collect-inst-variants
852 (string-upcase symbol
) package it cache
))))
854 "~&Disassembler: ~D printers, ~D prefilters, ~D labelers~%"
855 (mapcar (lambda (x) (length (cdr x
))) cache
))))
857 ;;; Get the instruction-space, creating it if necessary.
858 (defun get-inst-space (&key
(package sb
!assem
::*backend-instruction-set-package
*)
860 (let ((ispace *disassem-inst-space
*))
861 (when (or force
(null ispace
))
863 (do-symbols (symbol package
)
864 (setq insts
(nconc (copy-list (get symbol
'instruction-flavors
))
866 (setf ispace
(build-inst-space insts
)))
867 (setf *disassem-inst-space
* ispace
))
870 ;;;; Add global hooks.
872 (defun add-offs-hook (segment addr hook
)
873 (let ((entry (cons addr hook
)))
874 (if (null (seg-hooks segment
))
875 (setf (seg-hooks segment
) (list entry
))
876 (push entry
(cdr (last (seg-hooks segment
)))))))
878 (defun add-offs-note-hook (segment addr note
)
879 (add-offs-hook segment
881 (lambda (stream dstate
)
882 (declare (type (or null stream
) stream
)
883 (type disassem-state dstate
))
885 (note note dstate
)))))
887 (defun add-offs-comment-hook (segment addr comment
)
888 (add-offs-hook segment
890 (lambda (stream dstate
)
891 (declare (type (or null stream
) stream
)
894 (write-string ";;; " stream
)
897 (write-string comment stream
))
899 (funcall comment stream
)))
902 (defun add-fun-hook (dstate function
)
903 (push function
(dstate-fun-hooks dstate
)))
905 (defun set-location-printing-range (dstate from length
)
906 (setf (dstate-addr-print-len dstate
) ; in characters
907 ;; 4 bits per hex digit
908 (ceiling (integer-length (logxor from
(+ from length
))) 4)))
910 ;;; Print the current address in DSTATE to STREAM, plus any labels that
911 ;;; correspond to it, and leave the cursor in the instruction column.
912 (defun print-current-address (stream dstate
)
913 (declare (type stream stream
)
914 (type disassem-state dstate
))
916 (+ (seg-virtual-location (dstate-segment dstate
))
917 (dstate-cur-offs dstate
)))
918 (location-column-width *disassem-location-column-width
*)
919 (plen ; the number of rightmost hex chars of this address to print
920 (or (dstate-addr-print-len dstate
)
921 ;; Usually we've already set the width, but in case not...
922 (let ((seg (dstate-segment dstate
)))
923 (set-location-printing-range
924 dstate
(seg-virtual-location seg
) (seg-length seg
))))))
926 (if (eq (dstate-output-state dstate
) :beginning
) ; on the first line
927 (if location-column-width
928 ;; If there's a user-specified width, force that number of hex chars
929 ;; regardless of whether it's greater or smaller than PLEN.
930 (setq plen location-column-width
)
931 ;; No specified width. The PLEN of this line becomes the width.
932 ;; Adjust the DSTATE's argument column for it.
933 (incf (dstate-argument-column dstate
)
934 (setq location-column-width plen
)))
935 ;; not the first line
936 (if location-column-width
937 ;; A specified width smaller than that required clips significant
938 ;; digits, but larger should not cause leading zeros to appear.
939 (setq plen
(min plen location-column-width
))
940 ;; Otherwise use the previously computed addr-print-len
941 (setq location-column-width plen
)))
943 (incf location-column-width
2) ; account for leading "; "
947 ;; print the location
948 ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
949 ;; usually avoids any consing]
950 ;; FIXME: if this cruft is actually a speed win, the format-string compiler
951 ;; should be improved to obviate the obfuscation. If it is not a win,
952 ;; we should just replace it with the above format string already.
953 (tab0 (- location-column-width plen
) stream
)
954 (let* ((printed-bits (* 4 plen
))
955 (printed-value (ldb (byte printed-bits
0) location
))
957 (truncate (- printed-bits
(integer-length printed-value
)) 4)))
958 (dotimes (i leading-zeros
)
959 (write-char #\
0 stream
))
960 (unless (zerop printed-value
)
961 (write printed-value
:stream stream
:base
16 :radix nil
))
963 (write-char #\
: stream
)))
967 (let* ((next-label (car (dstate-cur-labels dstate
)))
968 (label-location (car next-label
)))
969 (when (or (null label-location
) (> label-location location
))
971 (unless (< label-location location
)
972 (format stream
" L~W:" (cdr next-label
)))
973 (pop (dstate-cur-labels dstate
))))
975 ;; move to the instruction column
976 (tab0 (+ location-column-width
1 label-column-width
) stream
)
979 (eval-when (:compile-toplevel
:execute
)
980 (sb!xc
:defmacro with-print-restrictions
(&rest body
)
981 `(let ((*print-pretty
* t
)
987 ;;; Print a newline to STREAM, inserting any pending notes in DSTATE
988 ;;; as end-of-line comments. If there is more than one note, a
989 ;;; separate line will be used for each one.
990 (defun print-notes-and-newline (stream dstate
)
991 (declare (type stream stream
)
992 (type disassem-state dstate
))
993 (with-print-restrictions
994 (dolist (note (dstate-notes dstate
))
995 (format stream
"~Vt " *disassem-note-column
*)
996 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
999 (write-string note stream
))
1001 (funcall note stream
))))
1004 (setf (dstate-notes dstate
) nil
)))
1006 ;;; Print NUM instruction bytes to STREAM as hex values.
1007 (defun print-inst (num stream dstate
&key
(offset 0) (trailing-space t
))
1008 (when (> *disassem-inst-column-width
* 0)
1009 (let ((sap (dstate-segment-sap dstate
))
1010 (start-offs (+ offset
(dstate-cur-offs dstate
))))
1012 (format stream
"~2,'0x" (sap-ref-8 sap
(+ offs start-offs
))))
1013 (when trailing-space
1014 (pad-inst-column stream num
)))))
1016 ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
1017 (defun print-bytes (num stream dstate
)
1018 (declare (type offset num
)
1019 (type stream stream
)
1020 (type disassem-state dstate
))
1021 (format stream
"~A~Vt" 'BYTE
(dstate-argument-column dstate
))
1022 (let ((sap (dstate-segment-sap dstate
))
1023 (start-offs (dstate-cur-offs dstate
)))
1025 (unless (zerop offs
)
1026 (write-string ", " stream
))
1027 (format stream
"#X~2,'0x" (sap-ref-8 sap
(+ offs start-offs
))))))
1029 (defvar *default-dstate-hooks
*
1030 (list* #!-
(or x86 x86-64
) #'lra-hook nil
))
1032 ;;; Make a disassembler-state object.
1033 (defun make-dstate (&optional
(fun-hooks *default-dstate-hooks
*))
1034 (let ((alignment *disassem-inst-alignment-bytes
*)
1036 (+ 2 ; for the leading "; " on each line
1037 (or *disassem-location-column-width
* 0)
1040 *disassem-inst-column-width
*
1041 (if (zerop *disassem-inst-column-width
*) 0 1)
1042 *disassem-opcode-column-width
*)))
1044 (when (> alignment
1)
1045 (push #'alignment-hook fun-hooks
))
1047 (%make-dstate
:fun-hooks fun-hooks
1048 :argument-column arg-column
1049 :alignment alignment
1050 :byte-order sb
!c
:*backend-byte-order
*)))
1052 (defun add-fun-header-hooks (segment)
1053 (declare (type segment segment
))
1054 (do ((fun (awhen (seg-code segment
) (%code-entry-points it
))
1056 (length (seg-length segment
)))
1058 (let ((offset (code-offs-to-segment-offs (fun-offset fun
) segment
)))
1059 (when (<= 0 offset length
)
1060 ;; Up to 2 words of zeros might be present to align the next
1061 ;; simple-fun. Limit on OFFSET is to avoid incorrect triggering
1062 ;; in case of unexpected weirdness. FIXME: verify all zero bytes
1063 (when (< 0 offset
(* sb
!vm
:n-word-bytes
2))
1064 (push (make-offs-hook
1065 :fun
(lambda (stream dstate
)
1067 (format stream
".SKIP ~D" offset
))
1068 (incf (dstate-next-offs dstate
) offset
))
1069 :offset
0) ; at 0 bytes into this seg, skip OFFSET bytes
1070 (seg-hooks segment
)))
1071 (push (make-offs-hook :offset offset
:fun
#'fun-header-hook
)
1072 (seg-hooks segment
))))))
1074 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
1076 ;; FIXME: Are the objects we are taking saps for always pinned?
1077 #!-sb-fluid
(declaim (inline sap-maker
))
1078 (defun sap-maker (function input offset
)
1079 (declare (optimize (speed 3))
1080 (muffle-conditions compiler-note
)
1081 (type (function (t) system-area-pointer
) function
)
1082 (type offset offset
))
1083 (let ((old-sap (sap+ (funcall function input
) offset
)))
1084 (declare (type system-area-pointer old-sap
))
1087 (+ (sap-int (funcall function input
)) offset
)))
1088 ;; Saving the sap like this avoids consing except when the sap
1089 ;; changes (because the sap-int, arith, etc., get inlined).
1090 (declare (type address new-addr
))
1091 (if (= (sap-int old-sap
) new-addr
)
1093 (setf old-sap
(int-sap new-addr
)))))))
1095 (defun vector-sap-maker (vector offset
)
1096 (declare (optimize (speed 3))
1097 (type offset offset
))
1098 (sap-maker #'vector-sap vector offset
))
1100 (defun code-sap-maker (code offset
)
1101 (declare (optimize (speed 3))
1102 (type code-component code
)
1103 (type offset offset
))
1104 (sap-maker #'code-instructions code offset
))
1106 (defun memory-sap-maker (address)
1107 (declare (optimize (speed 3))
1108 (muffle-conditions compiler-note
)
1109 (type address address
))
1110 (let ((sap (int-sap address
)))
1113 (defstruct (source-form-cache (:conc-name sfcache-
)
1115 (debug-source nil
:type
(or null sb
!di
:debug-source
))
1116 (toplevel-form-index -
1 :type fixnum
)
1117 (last-location-retrieved nil
:type
(or null sb
!di
:code-location
))
1118 (last-form-retrieved -
1 :type fixnum
))
1120 ;;; Return a memory segment located at the system-area-pointer returned by
1121 ;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
1123 ;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
1124 ;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a
1125 ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
1127 (defun make-segment (sap-maker length
1129 code virtual-location
1130 debug-fun source-form-cache
1132 (declare (type (function () system-area-pointer
) sap-maker
)
1133 (type disassem-length length
)
1134 (type (or null address
) virtual-location
)
1135 (type (or null sb
!di
:debug-fun
) debug-fun
)
1136 (type (or null source-form-cache
) source-form-cache
))
1139 :sap-maker sap-maker
1141 :virtual-location
(or virtual-location
1142 (sap-int (funcall sap-maker
)))
1147 (let ((n-words (code-n-unboxed-data-words code
))
1148 (start (code-header-words code
)))
1149 (and (plusp n-words
)
1150 (cons (* sb
!vm
:n-word-bytes start
)
1151 (* sb
!vm
:n-word-bytes
(+ start n-words
)))))))))
1152 (add-debugging-hooks segment debug-fun source-form-cache
)
1153 (add-fun-header-hooks segment
)
1156 (defun make-vector-segment (vector offset
&rest args
)
1157 (declare (type vector vector
)
1158 (type offset offset
)
1159 (inline make-segment
))
1160 (apply #'make-segment
(vector-sap-maker vector offset
) args
))
1162 (defun make-code-segment (code offset length
&rest args
)
1163 (declare (type code-component code
)
1164 (type offset offset
)
1165 (inline make-segment
))
1166 (apply #'make-segment
(code-sap-maker code offset
) length
:code code args
))
1168 (defun make-memory-segment (address &rest args
)
1169 (declare (type address address
)
1170 (inline make-segment
))
1171 (apply #'make-segment
(memory-sap-maker address
) args
))
1174 (defun print-fun-headers (function)
1175 (declare (type compiled-function function
))
1176 (let* ((self (fun-self function
))
1177 (code (fun-code-header self
)))
1178 (format t
"Code-header ~S: size: ~S~%" code
(%code-code-size code
))
1179 (do ((fun (%code-entry-points code
) (%simple-fun-next fun
)))
1181 ;; There is function header fun-offset words from the
1183 (format t
"Fun-header ~S at offset ~W (words):~% ~S ~A => ~S~%"
1185 (get-closure-length fun
)
1186 (%simple-fun-name fun
)
1187 (%simple-fun-arglist fun
)
1188 (%simple-fun-type fun
)))))
1190 ;;; getting at the source code...
1192 (defun get-different-source-form (loc context
&optional cache
)
1194 (eq (sb!di
:code-location-debug-source loc
)
1195 (sfcache-debug-source cache
))
1196 (eq (sb!di
:code-location-toplevel-form-offset loc
)
1197 (sfcache-toplevel-form-index cache
))
1198 (or (eql (sb!di
:code-location-form-number loc
)
1199 (sfcache-last-form-retrieved cache
))
1200 (awhen (sfcache-last-location-retrieved cache
)
1201 (sb!di
:code-location
= loc it
))))
1203 (let ((form (sb!debug
::code-location-source-form loc context nil
)))
1205 (setf (sfcache-debug-source cache
)
1206 (sb!di
:code-location-debug-source loc
))
1207 (setf (sfcache-toplevel-form-index cache
)
1208 (sb!di
:code-location-toplevel-form-offset loc
))
1209 (setf (sfcache-last-form-retrieved cache
)
1210 (sb!di
:code-location-form-number loc
))
1211 (setf (sfcache-last-location-retrieved cache
) loc
))
1214 ;;;; stuff to use debugging info to augment the disassembly
1216 (defun code-fun-map (code)
1217 (declare (type code-component code
))
1218 (sb!c
::compiled-debug-info-fun-map
(%code-debug-info code
)))
1220 (defstruct (location-group (:copier nil
) (:predicate nil
))
1221 ;; This was (VECTOR (OR LIST FIXNUM)) but that doesn't have any
1222 ;; specialization other than T, and the cross-compiler has trouble
1223 ;; with (SB!XC:TYPEP #() '(VECTOR (OR LIST FIXNUM)))
1224 (locations #() :type simple-vector
))
1226 ;;; Return the vector of DEBUG-VARs currently associated with DSTATE.
1227 (defun dstate-debug-vars (dstate)
1228 (declare (type disassem-state dstate
))
1229 (storage-info-debug-vars (seg-storage-info (dstate-segment dstate
))))
1231 ;;; Given the OFFSET of a location within the location-group called
1232 ;;; LG-NAME, see whether there's a current mapping to a source
1233 ;;; variable in DSTATE, and if so, return the offset of that variable
1234 ;;; in the current debug-var vector.
1235 (defun find-valid-storage-location (offset lg-name dstate
)
1236 (declare (type offset offset
)
1237 (type symbol lg-name
)
1238 (type disassem-state dstate
))
1239 (let* ((storage-info
1240 (seg-storage-info (dstate-segment dstate
)))
1243 (cdr (assoc lg-name
(storage-info-groups storage-info
)))))
1245 (dstate-current-valid-locations dstate
)))
1247 (not (null currently-valid
))
1248 (let ((locations (location-group-locations location-group
)))
1249 (and (< offset
(length locations
))
1250 (let ((used-by (aref locations offset
)))
1252 (let ((debug-var-num
1256 (zerop (bit currently-valid used-by
)))
1262 (bit currently-valid num
)))
1267 ;; Found a valid storage reference!
1268 ;; can't use it again until it's revalidated...
1269 (setf (bit (dstate-current-valid-locations
1276 ;;; Return a new vector which has the same contents as the old one
1277 ;;; VEC, plus new cells (for a total size of NEW-LEN). The additional
1278 ;;; elements are initialized to INITIAL-ELEMENT.
1279 (defun grow-vector (vec new-len
&optional initial-element
)
1280 (declare (type vector vec
)
1281 (type fixnum new-len
))
1283 (make-sequence `(vector ,(array-element-type vec
) ,new-len
)
1285 :initial-element initial-element
)))
1286 (dotimes (i (length vec
))
1287 (setf (aref new i
) (aref vec i
)))
1290 ;;; Return a STORAGE-INFO struction describing the object-to-source
1291 ;;; variable mappings from DEBUG-FUN.
1292 (defun storage-info-for-debug-fun (debug-fun)
1293 (declare (type sb
!di
:debug-fun debug-fun
))
1294 (let ((sc-vec sb
!c
::*backend-sc-numbers
*)
1296 (debug-vars (sb!di
::debug-fun-debug-vars
1299 (dotimes (debug-var-offset
1301 (make-storage-info :groups groups
1302 :debug-vars debug-vars
))
1303 (let ((debug-var (aref debug-vars debug-var-offset
)))
1305 (format t
";;; At offset ~W: ~S~%" debug-var-offset debug-var
)
1307 (sb!di
::compiled-debug-var-sc-offset debug-var
))
1310 (sb!c
:sc-sb
(aref sc-vec
1311 (sb!c
:sc-offset-scn sc-offset
))))))
1313 (format t
";;; SET: ~S[~W]~%"
1314 sb-name
(sb!c
:sc-offset-offset sc-offset
))
1315 (unless (null sb-name
)
1316 (let ((group (cdr (assoc sb-name groups
))))
1318 (setf group
(make-location-group))
1319 (push `(,sb-name .
,group
) groups
))
1320 (let* ((locations (location-group-locations group
))
1321 (length (length locations
))
1322 (offset (sb!c
:sc-offset-offset sc-offset
)))
1323 (when (>= offset length
)
1325 (grow-vector locations
1329 (location-group-locations group
)
1331 (let ((already-there (aref locations offset
)))
1332 (cond ((null already-there
)
1333 (setf (aref locations offset
) debug-var-offset
))
1334 ((eql already-there debug-var-offset
))
1336 (if (listp already-there
)
1337 (pushnew debug-var-offset
1338 (aref locations offset
))
1339 (setf (aref locations offset
)
1340 (list debug-var-offset
1345 (defun source-available-p (debug-fun)
1347 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1348 (declare (ignore block
))
1350 (sb!di
:no-debug-blocks
() nil
)))
1352 (defun print-block-boundary (stream dstate
)
1353 (let ((os (dstate-output-state dstate
)))
1354 (when (not (eq os
:beginning
))
1355 (when (not (eq os
:block-boundary
))
1357 (setf (dstate-output-state dstate
)
1360 ;;; Add hooks to track the source code in SEGMENT during disassembly.
1361 ;;; SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
1362 ;;; structure, in which case it is used to cache forms from files.
1363 (defun add-source-tracking-hooks (segment debug-fun
&optional sfcache
)
1364 (declare (type segment segment
)
1365 (type (or null sb
!di
:debug-fun
) debug-fun
)
1366 (type (or null source-form-cache
) sfcache
))
1367 (let ((last-block-pc -
1))
1368 (flet ((add-hook (pc fun
&optional before-address
)
1369 (push (make-offs-hook
1370 :offset
(code-insts-offs-to-segment-offs pc segment
)
1372 :before-address before-address
)
1373 (seg-hooks segment
))))
1375 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1376 (let ((first-location-in-block-p t
))
1377 (sb!di
:do-debug-block-locations
(loc block
)
1378 (let ((pc (sb!di
::compiled-code-location-pc loc
)))
1380 ;; Put blank lines in at block boundaries
1381 (when (and first-location-in-block-p
1382 (/= pc last-block-pc
))
1383 (setf first-location-in-block-p nil
)
1385 (lambda (stream dstate
)
1386 (print-block-boundary stream dstate
))
1388 (setf last-block-pc pc
))
1390 ;; Print out corresponding source; this information is not
1391 ;; all that accurate, but it's better than nothing
1392 (unless (zerop (sb!di
:code-location-form-number loc
))
1393 (multiple-value-bind (form new
)
1394 (get-different-source-form loc
0 sfcache
)
1396 (let ((at-block-begin (= pc last-block-pc
)))
1399 (lambda (stream dstate
)
1400 (declare (ignore dstate
))
1402 (unless at-block-begin
1404 (format stream
";;; [~W] "
1405 (sb!di
:code-location-form-number
1407 (prin1-short form stream
)
1412 ;; Keep track of variable live-ness as best we can.
1414 (copy-seq (sb!di
::compiled-code-location-live-set
1418 (lambda (stream dstate
)
1419 (declare (ignore stream
))
1420 (setf (dstate-current-valid-locations dstate
)
1423 (note (lambda (stream)
1424 (let ((*print-length
* nil
))
1425 (format stream
"live set: ~S"
1429 (sb!di
:no-debug-blocks
() nil
)))))
1431 (defvar *disassemble-annotate
* t
1433 "Annotate DISASSEMBLE output with source code.")
1435 (defun add-debugging-hooks (segment debug-fun
&optional sfcache
)
1437 (setf (seg-storage-info segment
)
1438 (storage-info-for-debug-fun debug-fun
))
1439 (when *disassemble-annotate
*
1440 (add-source-tracking-hooks segment debug-fun sfcache
))
1441 (let ((kind (sb!di
:debug-fun-kind debug-fun
)))
1442 (flet ((add-new-hook (n)
1443 (push (make-offs-hook
1445 :fun
(lambda (stream dstate
)
1446 (declare (ignore stream
))
1448 (seg-hooks segment
))))
1452 (add-new-hook "no-arg-parsing entry point"))
1454 (add-new-hook (lambda (stream)
1455 (format stream
"~S entry point" kind
)))))))))
1457 ;;; Return a list of the segments of memory containing machine code
1458 ;;; instructions for FUNCTION.
1459 (defun get-fun-segments (function)
1460 (declare (type compiled-function function
))
1461 (let* ((function (fun-self function
))
1462 (code (fun-code function
))
1463 (fun-map (code-fun-map code
))
1464 (fname (%simple-fun-name function
))
1465 (sfcache (make-source-form-cache)))
1466 (let ((first-block-seen-p nil
)
1467 (nil-block-seen-p nil
)
1469 (last-debug-fun nil
)
1471 (flet ((add-seg (offs len df
)
1473 (push (make-code-segment code offs len
1475 :source-form-cache sfcache
)
1477 (dotimes (fmap-index (length fun-map
))
1478 (let ((fmap-entry (aref fun-map fmap-index
)))
1479 (etypecase fmap-entry
1481 (when first-block-seen-p
1482 (add-seg last-offset
1483 (- fmap-entry last-offset
)
1485 (setf last-debug-fun nil
))
1486 (setf last-offset fmap-entry
))
1487 (sb!c
::compiled-debug-fun
1488 (let ((name (sb!c
::compiled-debug-fun-name fmap-entry
))
1489 (kind (sb!c
::compiled-debug-fun-kind fmap-entry
)))
1491 (format t
";;; SAW ~S ~S ~S,~S ~W,~W~%"
1492 name kind first-block-seen-p nil-block-seen-p
1494 (sb!c
::compiled-debug-fun-start-pc fmap-entry
))
1495 (cond (#+nil
(eq last-offset fun-offset
)
1496 (and (equal name fname
) (not first-block-seen-p
))
1497 (setf first-block-seen-p t
))
1498 ((eq kind
:external
)
1499 (when first-block-seen-p
1502 (when nil-block-seen-p
1504 (when first-block-seen-p
1505 (setf nil-block-seen-p t
))))
1506 (setf last-debug-fun
1507 (sb!di
::make-compiled-debug-fun fmap-entry code
)))))))
1508 (let ((max-offset (code-inst-area-length code
)))
1509 (when (and first-block-seen-p last-debug-fun
)
1510 (add-seg last-offset
1511 (- max-offset last-offset
)
1514 (let ((offs (fun-insts-offset function
)))
1516 (make-code-segment code offs
(- max-offset offs
))))
1517 (nreverse segments
)))))))
1519 ;;; Return a list of the segments of memory containing machine code
1520 ;;; instructions for the code-component CODE. If START-OFFSET and/or
1521 ;;; LENGTH is supplied, only that part of the code-segment is used
1522 ;;; (but these are constrained to lie within the code-segment).
1523 (defun get-code-segments (code
1526 (length (code-inst-area-length code
)))
1527 (declare (type code-component code
)
1528 (type offset start-offset
)
1529 (type disassem-length length
))
1530 (let ((segments nil
))
1531 (when (%code-debug-info code
)
1532 (let ((fun-map (code-fun-map code
))
1533 (sfcache (make-source-form-cache)))
1534 (let ((last-offset 0)
1535 (last-debug-fun nil
))
1536 (flet ((add-seg (offs len df
)
1537 (let* ((restricted-offs
1538 (min (max start-offset offs
)
1539 (+ start-offset length
)))
1541 (- (min (max start-offset
(+ offs len
))
1542 (+ start-offset length
))
1544 (when (> restricted-len
0)
1545 (push (make-code-segment code
1546 restricted-offs restricted-len
1548 :source-form-cache sfcache
)
1550 (dotimes (fun-map-index (length fun-map
))
1551 (let ((fun-map-entry (aref fun-map fun-map-index
)))
1552 (etypecase fun-map-entry
1554 (add-seg last-offset
(- fun-map-entry last-offset
)
1556 (setf last-debug-fun nil
)
1557 (setf last-offset fun-map-entry
))
1558 (sb!c
::compiled-debug-fun
1559 (setf last-debug-fun
1560 (sb!di
::make-compiled-debug-fun fun-map-entry
1562 (when last-debug-fun
1563 (add-seg last-offset
1564 (- (code-inst-area-length code
) last-offset
)
1565 last-debug-fun
))))))
1567 (list (make-code-segment code start-offset length
))
1568 (nreverse segments
))))
1570 ;;; Compute labels for all the memory segments in SEGLIST and adds
1571 ;;; them to DSTATE. It's important to call this function with all the
1572 ;;; segments you're interested in, so that it can find references from
1574 (defun label-segments (seglist dstate
)
1575 (declare (type list seglist
)
1576 (type disassem-state dstate
))
1577 (dolist (seg seglist
)
1578 (add-segment-labels seg dstate
))
1579 ;; Now remove any labels that don't point anywhere in the segments
1581 (setf (dstate-labels dstate
)
1582 (remove-if (lambda (lab)
1585 (let ((start (seg-virtual-location seg
)))
1588 (+ start
(seg-length seg
)))))
1590 (dstate-labels dstate
))))
1592 ;;; Disassemble the machine code instructions in SEGMENT to STREAM.
1593 (defun disassemble-segment (segment stream dstate
)
1594 (declare (type segment segment
)
1595 (type stream stream
)
1596 (type disassem-state dstate
))
1597 (let ((*print-pretty
* nil
)) ; otherwise the pp conses hugely
1598 (number-labels dstate
)
1599 (map-segment-instructions
1600 (lambda (chunk inst
)
1601 (declare (type dchunk chunk
) (type instruction inst
))
1602 (awhen (inst-printer inst
)
1603 (funcall it chunk inst stream dstate
)))
1608 ;;; Disassemble the machine code instructions in each memory segment
1609 ;;; in SEGMENTS in turn to STREAM.
1610 (defun disassemble-segments (segments stream dstate
)
1611 (declare (type list segments
)
1612 (type stream stream
)
1613 (type disassem-state dstate
))
1614 (unless (null segments
)
1615 (let ((n-segments (length segments
))
1616 (first (car segments
))
1617 (last (car (last segments
))))
1618 ;; One origin per segment is printed. As with the per-line display,
1619 ;; the segment is thought of as immovable for rendering of addresses,
1620 ;; though in fact the disassembler transiently allows movement.
1621 (format stream
"~&; Size: ~a bytes. Origin: #x~x~@[ (segment 1 of ~D)~]"
1622 (reduce #'+ segments
:key
#'seg-length
)
1623 (seg-virtual-location first
)
1624 (if (> n-segments
1) n-segments
))
1625 (set-location-printing-range dstate
1626 (seg-virtual-location first
)
1627 (- (+ (seg-virtual-location last
)
1629 (seg-virtual-location first
)))
1630 (setf (dstate-output-state dstate
) :beginning
)
1632 (dolist (seg segments
)
1633 (when (> (incf i
) 1)
1634 (format stream
"~&; Origin #x~x (segment ~D of ~D)"
1635 (seg-virtual-location seg
) i n-segments
))
1636 (disassemble-segment seg stream dstate
))))))
1639 ;;;; top level functions
1641 ;;; Disassemble the machine code instructions for FUNCTION.
1642 (defun disassemble-fun (fun &key
1643 (stream *standard-output
*)
1645 (declare (type compiled-function fun
)
1646 (type stream stream
)
1647 (type (member t nil
) use-labels
))
1648 (let* ((dstate (make-dstate))
1649 (segments (get-fun-segments fun
)))
1651 (label-segments segments dstate
))
1652 (disassemble-segments segments stream dstate
)))
1654 (defun valid-extended-function-designators-for-disassemble-p (thing)
1656 ((satisfies legal-fun-name-p
)
1657 (compiled-funs-or-lose (fdefinition thing
) thing
))
1658 (sb!pcl
::%method-function
1659 ;; in a %METHOD-FUNCTION, the user code is in the fast function, so
1660 ;; we to disassemble both.
1661 ;; FIXME: interpreted methods need to be compiled as above.
1662 (list thing
(sb!pcl
::%method-function-fast-function thing
)))
1663 ((or (cons (eql lambda
))
1664 #!+sb-fasteval sb
!interpreter
:interpreted-function
1665 #!+sb-eval sb
!eval
:interpreted-function
)
1666 (compile nil thing
))
1670 (defun compiled-funs-or-lose (thing &optional
(name thing
))
1671 (let ((funs (valid-extended-function-designators-for-disassemble-p thing
)))
1674 (error 'simple-type-error
1676 :expected-type
'(satisfies valid-extended-function-designators-for-disassemble-p
)
1677 :format-control
"Can't make a compiled function from ~S"
1678 :format-arguments
(list name
)))))
1680 (defun disassemble (object &key
1681 (stream *standard-output
*)
1684 "Disassemble the compiled code associated with OBJECT, which can be a
1685 function, a lambda expression, or a symbol with a function definition. If
1686 it is not already compiled, the compiler is called to produce something to
1688 (declare (type (or function symbol cons
) object
)
1689 (type (or (member t
) stream
) stream
)
1690 (type (member t nil
) use-labels
))
1691 (flet ((disassemble1 (fun)
1692 (format stream
"~&; disassembly for ~S" (%fun-name fun
))
1693 (disassemble-fun fun
1695 :use-labels use-labels
)))
1696 (mapc #'disassemble1
(ensure-list (compiled-funs-or-lose object
))))
1699 ;;; Disassembles the given area of memory starting at ADDRESS and
1700 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
1701 ;;; could move during a GC, you'd better disable it around the call to
1703 (defun disassemble-memory (address
1706 (stream *standard-output
*)
1709 (declare (type (or address system-area-pointer
) address
)
1710 (type disassem-length length
)
1711 (type stream stream
)
1712 (type (or null code-component
) code-component
)
1713 (type (member t nil
) use-labels
))
1715 (if (system-area-pointer-p address
)
1718 (dstate (make-dstate))
1724 (code-instructions code-component
)))))
1725 (when (or (< code-offs
0)
1726 (> code-offs
(code-inst-area-length code-component
)))
1727 (error "address ~X not in the code component ~S"
1728 address code-component
))
1729 (get-code-segments code-component code-offs length
))
1730 (list (make-memory-segment address length
)))))
1732 (label-segments segments dstate
))
1733 (disassemble-segments segments stream dstate
)))
1735 ;;; Disassemble the machine code instructions associated with
1736 ;;; CODE-COMPONENT (this may include multiple entry points).
1737 (defun disassemble-code-component (code-component &key
1738 (stream *standard-output
*)
1740 (declare (type (or code-component compiled-function
)
1742 (type stream stream
)
1743 (type (member t nil
) use-labels
))
1744 (let* ((code-component
1745 (if (functionp code-component
)
1746 (fun-code code-component
)
1748 (dstate (make-dstate))
1749 (segments (get-code-segments code-component
)))
1751 (label-segments segments dstate
))
1752 (disassemble-segments segments stream dstate
)))
1754 ;;;; code to disassemble assembler segments
1756 (defun assem-segment-to-disassem-segment (assem-segment)
1757 (declare (type sb
!assem
:segment assem-segment
))
1758 (let ((contents (sb!assem
:segment-contents-as-vector assem-segment
)))
1759 (make-vector-segment contents
0 (length contents
) :virtual-location
0)))
1761 ;;; Disassemble the machine code instructions associated with
1762 ;;; ASSEM-SEGMENT (of type assem:segment).
1763 (defun disassemble-assem-segment (assem-segment stream
)
1764 (declare (type sb
!assem
:segment assem-segment
)
1765 (type stream stream
))
1766 (let ((dstate (make-dstate))
1768 (list (assem-segment-to-disassem-segment assem-segment
))))
1769 (label-segments disassem-segments dstate
)
1770 (disassemble-segments disassem-segments stream dstate
)))
1772 ;;; routines to find things in the Lisp environment
1774 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
1775 ;;; in a symbol object that we know about
1776 (defparameter *grokked-symbol-slots
*
1777 (sort (copy-list `((,sb
!vm
:symbol-value-slot . symbol-value
)
1778 (,sb
!vm
:symbol-info-slot . symbol-info
)
1779 (,sb
!vm
:symbol-name-slot . symbol-name
)
1780 (,sb
!vm
:symbol-package-slot . symbol-package
)))
1784 ;;; Given ADDRESS, try and figure out if which slot of which symbol is
1785 ;;; being referred to. Of course we can just give up, so it's not a
1786 ;;; big deal... Return two values, the symbol and the name of the
1787 ;;; access function of the slot.
1788 (defun grok-symbol-slot-ref (address)
1789 (declare (type address address
))
1790 (if (not (aligned-p address sb
!vm
:n-word-bytes
))
1792 (do ((slots-tail *grokked-symbol-slots
* (cdr slots-tail
)))
1795 (let* ((field (car slots-tail
))
1796 (slot-offset (words-to-bytes (car field
)))
1797 (maybe-symbol-addr (- address slot-offset
))
1800 (+ maybe-symbol-addr sb
!vm
:other-pointer-lowtag
))))
1801 (when (symbolp maybe-symbol
)
1802 (return (values maybe-symbol
(cdr field
))))))))
1804 ;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
1805 ;;; which symbol is being referred to. Of course we can just give up,
1806 ;;; so it's not a big deal... Return two values, the symbol and the
1807 ;;; access function.
1808 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1809 (declare (type offset byte-offset
))
1810 (grok-symbol-slot-ref (+ sb
!vm
::nil-value byte-offset
)))
1812 ;;; Return the Lisp object located BYTE-OFFSET from NIL.
1813 (defun get-nil-indexed-object (byte-offset)
1814 (declare (type offset byte-offset
))
1815 (make-lisp-obj (+ sb
!vm
::nil-value byte-offset
)))
1817 ;;; Return two values; the Lisp object located at BYTE-OFFSET in the
1818 ;;; constant area of the code-object in the current segment and T, or
1819 ;;; NIL and NIL if there is no code-object in the current segment.
1820 (defun get-code-constant (byte-offset dstate
)
1821 (declare (type offset byte-offset
)
1822 (type disassem-state dstate
))
1823 (let ((code (seg-code (dstate-segment dstate
))))
1825 (values (code-header-ref code
1826 (ash (+ byte-offset sb
!vm
:other-pointer-lowtag
)
1827 (- sb
!vm
:word-shift
)))
1831 (defun get-code-constant-absolute (addr dstate
&optional width
)
1832 (declare (type address addr
))
1833 (declare (type disassem-state dstate
))
1834 (declare (ignore width
))
1835 (let ((code (seg-code (dstate-segment dstate
))))
1837 (return-from get-code-constant-absolute
(values nil nil
)))
1838 ;; This WITHOUT-GCING, while not technically broken, is extremely deceptive
1839 ;; because if it is really needed, then this function has a broken API.
1840 ;; Since ADDR comes in as absolute, CODE must not move between the caller's
1841 ;; computation and the comparison below. But we're already in WITHOUT-GCING
1842 ;; in MAP-SEGMENT-INSTRUCTIONS, so, who cares, I guess?
1844 (let* ((n-header-bytes (* (code-header-words code
) sb
!vm
:n-word-bytes
))
1845 (header-addr (- (get-lisp-obj-address code
)
1846 sb
!vm
:other-pointer-lowtag
))
1847 (code-start (+ header-addr n-header-bytes
)))
1848 (cond ((< header-addr addr code-start
)
1849 (values (sap-ref-lispobj (int-sap addr
) 0) t
))
1851 (values nil nil
)))))))
1853 (defvar *assembler-routines-by-addr
* nil
)
1855 ;;; Build an address-name hash-table from the name-address hash
1856 (defun invert-address-hash (htable &optional
(addr-hash (make-hash-table)))
1857 (maphash (lambda (name address
)
1858 (setf (gethash address addr-hash
) name
))
1862 ;;; Return the name of the primitive Lisp assembler routine or foreign
1863 ;;; symbol located at ADDRESS, or NIL if there isn't one.
1864 (defun find-assembler-routine (address)
1865 (declare (type address address
))
1866 (when (null *assembler-routines-by-addr
*)
1867 (setf *assembler-routines-by-addr
*
1868 (invert-address-hash sb
!fasl
:*assembler-routines
*))
1870 (setf *assembler-routines-by-addr
*
1871 (invert-address-hash *static-foreign-symbols
*
1872 *assembler-routines-by-addr
*))
1873 (loop for static in sb
!vm
:*static-funs
*
1874 for address
= (+ sb
!vm
::nil-value
1875 (sb!vm
::static-fun-offset static
))
1877 (setf (gethash address
*assembler-routines-by-addr
*)
1879 ;; Not really a routine, but it uses the similar logic for annotations
1881 (setf (gethash sb
!vm
::gc-safepoint-page-addr
*assembler-routines-by-addr
*)
1883 (gethash address
*assembler-routines-by-addr
*))
1885 ;;;; some handy function for machine-dependent code to use...
1887 (defun sap-ref-int (sap offset length byte-order
)
1888 (declare (type system-area-pointer sap
)
1889 (type (member 1 2 4 8) length
)
1890 (type (member :little-endian
:big-endian
) byte-order
))
1891 (if (or (eq length
1)
1892 (and (eq byte-order
#!+big-endian
:big-endian
#!+little-endian
:little-endian
)
1893 #!-
(or arm arm64 ppc x86 x86-64
) ; unaligned loads are ok for these
1894 (not (logtest (1- size
) (sap-int (sap+ sap offset
))))))
1895 (funcall (case length
; native byte order and acceptable alignment
1899 (t #'sap-ref-8
)) sap offset
)
1900 (binding* (((offset increment
)
1901 (cond ((eq byte-order
:big-endian
) (values offset
+1))
1902 (t (values (+ offset
(1- length
)) -
1))))
1904 (dotimes (i length val
)
1906 (setq val
(logior (ash val
8) (sap-ref-8 sap offset
)))
1907 (incf offset increment
)))))
1909 (defun read-suffix (length dstate
)
1910 (declare (type (member 8 16 32 64) length
)
1911 (type disassem-state dstate
)
1912 (optimize (speed 3) (safety 0)))
1913 (let ((length (ecase length
(8 1) (16 2) (32 4) (64 8))))
1914 (declare (type (unsigned-byte 4) length
))
1916 (sap-ref-int (dstate-segment-sap dstate
)
1917 (dstate-next-offs dstate
)
1919 (dstate-byte-order dstate
))
1920 (incf (dstate-next-offs dstate
) length
))))
1922 ;;;; optional routines to make notes about code
1924 ;;; Store NOTE (which can be either a string or a function with a
1925 ;;; single stream argument) to be printed as an end-of-line comment
1926 ;;; after the current instruction is disassembled.
1927 (defun note (note dstate
)
1928 (declare (type (or string function
) note
)
1929 (type disassem-state dstate
))
1930 (push note
(dstate-notes dstate
)))
1932 (defun prin1-short (thing stream
)
1933 (with-print-restrictions
1934 (prin1 thing stream
)))
1936 (defun prin1-quoted-short (thing stream
)
1937 (if (self-evaluating-p thing
)
1938 (prin1-short thing stream
)
1939 (prin1-short `',thing stream
)))
1941 ;;; Store a note about the lisp constant located BYTE-OFFSET bytes
1942 ;;; from the current code-component, to be printed as an end-of-line
1943 ;;; comment after the current instruction is disassembled.
1944 (defun note-code-constant (byte-offset dstate
)
1945 (declare (type offset byte-offset
)
1946 (type disassem-state dstate
))
1947 (multiple-value-bind (const valid
)
1948 (get-code-constant byte-offset dstate
)
1950 (note (lambda (stream)
1951 (prin1-quoted-short const stream
))
1955 ;;; Store a note about the lisp constant located at ADDR in the
1956 ;;; current code-component, to be printed as an end-of-line comment
1957 ;;; after the current instruction is disassembled.
1958 (defun note-code-constant-absolute (addr dstate
&optional width
)
1959 (declare (type address addr
)
1960 (type disassem-state dstate
))
1961 (multiple-value-bind (const valid
)
1962 (get-code-constant-absolute addr dstate width
)
1964 (note (lambda (stream)
1965 (prin1-quoted-short const stream
))
1967 (values const valid
)))
1969 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1970 ;;; constant NIL is a valid slot in a symbol, store a note describing
1971 ;;; which symbol and slot, to be printed as an end-of-line comment
1972 ;;; after the current instruction is disassembled. Returns non-NIL iff
1973 ;;; a note was recorded.
1974 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate
)
1975 (declare (type offset nil-byte-offset
)
1976 (type disassem-state dstate
))
1977 (multiple-value-bind (symbol access-fun
)
1978 (grok-nil-indexed-symbol-slot-ref nil-byte-offset
)
1980 (note (lambda (stream)
1981 (prin1 (if (eq access-fun
'symbol-value
)
1983 `(,access-fun
',symbol
))
1988 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1989 ;;; constant NIL is a valid lisp object, store a note describing which
1990 ;;; symbol and slot, to be printed as an end-of-line comment after the
1991 ;;; current instruction is disassembled. Returns non-NIL iff a note
1993 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate
)
1994 (declare (type offset nil-byte-offset
)
1995 (type disassem-state dstate
))
1996 (let ((obj (get-nil-indexed-object nil-byte-offset
)))
1997 (note (lambda (stream)
1998 (prin1-quoted-short obj stream
))
2002 ;;; If ADDRESS is the address of a primitive assembler routine or
2003 ;;; foreign symbol, store a note describing which one, to be printed
2004 ;;; as an end-of-line comment after the current instruction is
2005 ;;; disassembled. Returns non-NIL iff a note was recorded. If
2006 ;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made.
2007 (defun maybe-note-assembler-routine (address note-address-p dstate
)
2008 (declare (type disassem-state dstate
))
2009 (unless (typep address
'address
)
2010 (return-from maybe-note-assembler-routine nil
))
2012 (find-assembler-routine address
)
2014 (sap-foreign-symbol (int-sap address
)))))
2016 (note (lambda (stream)
2018 (format stream
"#x~8,'0x: ~a" address name
)
2019 (princ name stream
)))
2023 ;;; If there's a valid mapping from OFFSET in the storage class
2024 ;;; SC-NAME to a source variable, make a note of the source-variable
2025 ;;; name, to be printed as an end-of-line comment after the current
2026 ;;; instruction is disassembled. Returns non-NIL iff a note was
2028 (defun maybe-note-single-storage-ref (offset sc-name dstate
)
2029 (declare (type offset offset
)
2030 (type symbol sc-name
)
2031 (type disassem-state dstate
))
2032 (let ((storage-location
2033 (find-valid-storage-location offset sc-name dstate
)))
2034 (when storage-location
2035 (note (lambda (stream)
2036 (princ (sb!di
:debug-var-symbol
2037 (aref (storage-info-debug-vars
2038 (seg-storage-info (dstate-segment dstate
)))
2044 ;;; If there's a valid mapping from OFFSET in the storage-base called
2045 ;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with
2046 ;;; the source-variable name, to be printed as an end-of-line comment
2047 ;;; after the current instruction is disassembled. Returns non-NIL iff
2048 ;;; a note was recorded.
2049 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate
)
2050 (declare (type offset offset
)
2051 (type symbol sb-name
)
2052 (type (or symbol string
) assoc-with
)
2053 (type disassem-state dstate
))
2054 (let ((storage-location
2055 (find-valid-storage-location offset sb-name dstate
)))
2056 (when storage-location
2057 (note (lambda (stream)
2058 (format stream
"~A = ~S"
2060 (sb!di
:debug-var-symbol
2061 (aref (dstate-debug-vars dstate
)
2062 storage-location
))))
2066 (defun maybe-note-static-symbol (offset dstate
)
2067 (dolist (symbol sb
!vm
:*static-symbols
*)
2068 (when (= (get-lisp-obj-address symbol
) offset
)
2069 (return (note (lambda (s) (prin1 symbol s
)) dstate
)))))
2071 (defun get-internal-error-name (errnum)
2072 (cadr (svref sb
!c
:+backend-internal-errors
+ errnum
)))
2074 (defun get-sc-name (sc-offs)
2075 (sb!c
:location-print-name
2076 ;; FIXME: This seems like an awful lot of computation just to get a name.
2077 ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
2079 (sb!c
:make-random-tn
:kind
:normal
2080 :sc
(svref sb
!c
:*backend-sc-numbers
*
2081 (sb!c
:sc-offset-scn sc-offs
))
2082 :offset
(sb!c
:sc-offset-offset sc-offs
))))
2084 ;;; When called from an error break instruction's :DISASSEM-CONTROL (or
2085 ;;; :DISASSEM-PRINTER) function, will correctly deal with printing the
2086 ;;; arguments to the break.
2088 ;;; ERROR-PARSE-FUN should be a function that accepts:
2089 ;;; 1) a SYSTEM-AREA-POINTER
2090 ;;; 2) a BYTE-OFFSET from the SAP to begin at
2091 ;;; It should read information from the SAP starting at BYTE-OFFSET, and
2092 ;;; return four values:
2093 ;;; 1) the error number
2094 ;;; 2) the total length, in bytes, of the information
2095 ;;; 3) a list of SC-OFFSETs of the locations of the error parameters
2096 ;;; 4) a list of the length (as read from the SAP), in bytes, of each
2097 ;;; of the return values.
2098 (defun handle-break-args (error-parse-fun stream dstate
)
2099 (declare (type function error-parse-fun
)
2100 (type (or null stream
) stream
)
2101 (type disassem-state dstate
))
2102 (multiple-value-bind (errnum adjust sc-offsets lengths
)
2103 (funcall error-parse-fun
2104 (dstate-segment-sap dstate
)
2105 (dstate-next-offs dstate
)
2108 (setf (dstate-cur-offs dstate
)
2109 (dstate-next-offs dstate
))
2110 (flet ((emit-err-arg ()
2111 (let ((num (pop lengths
)))
2112 (print-notes-and-newline stream dstate
)
2113 (print-current-address stream dstate
)
2114 (print-inst num stream dstate
)
2115 (print-bytes num stream dstate
)
2116 (incf (dstate-cur-offs dstate
) num
)))
2119 (note note dstate
))))
2120 ;; ARM64 encodes the error number in BRK instruction itself
2123 (emit-note (symbol-name (get-internal-error-name errnum
)))
2124 (dolist (sc-offs sc-offsets
)
2126 (if (= (sb!c
:sc-offset-scn sc-offs
)
2127 sb
!vm
:constant-sc-number
)
2128 (note-code-constant (* (1- (sb!c
:sc-offset-offset sc-offs
))
2131 (emit-note (get-sc-name sc-offs
))))))
2132 (incf (dstate-next-offs dstate
) adjust
)))
2134 ;;; arm64 stores an error-number in the instruction bytes,
2135 ;;; so can't easily share this code.
2136 ;;; But probably we should just add the conditionalization in here.
2138 (defun snarf-error-junk (sap offset
&optional length-only
)
2139 (let* ((error-number (sap-ref-8 sap offset
))
2140 (length (sb!kernel
::error-length error-number
))
2141 (index (1+ offset
)))
2142 (declare (type system-area-pointer sap
)
2143 (type (unsigned-byte 8) length
))
2145 (loop repeat length do
(sb!c
:sap-read-var-integerf sap index
))
2146 (values 0 (- index offset
) nil nil
))
2148 (collect ((sc-offsets)
2150 (lengths 1) ;; error-number
2151 (loop repeat length do
2152 (let ((old-index index
))
2153 (sc-offsets (sb!c
:sap-read-var-integerf sap index
))
2154 (lengths (- index old-index
))))
2155 (values error-number
2160 ;; A prefilter set is a list of vectors specifying bytes to extract
2161 ;; and a function to call on the extracted value(s).
2162 ;; EQUALP lists of vectors can be coalesced, since they're immutable.
2163 (defun collect-prefiltering-args (args cache
)
2164 (awhen (remove-if-not #'arg-prefilter args
)
2166 (mapcar (lambda (arg &aux
(bytes (arg-fields arg
)))
2167 (coerce (list* (posq arg args
)
2169 (and bytes
(cons (arg-sign-extend-p arg
) bytes
)))
2172 (table (assq :prefilter cache
)))
2173 (or (find repr
(cdr table
) :test
'equalp
)
2174 (car (push repr
(cdr table
)))))))
2176 (defun unintern-init-only-stuff ()
2177 ;; Remove compile-time-only metadata. This preserves compatibility with the
2178 ;; older disassembler macros which wrapped GEN-ARG-TYPE-DEF-FORM and such
2179 ;; in (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE)), which in turn required that
2180 ;; all prefilters, labellers, and printers be defined at cross-compile-time.
2181 ;; A consequence of :LOAD-TOPLEVEL not being there was that was not possible
2182 ;; to add instruction definitions to an image without also recompiling
2183 ;; the backend's "insts" file. It also was not possible to incrementally
2184 ;; recompile and/or use slam.sh because of a bunch of mostly harmless bugs
2185 ;; in the function cache (a/k/a identical-code-folding) logic that was only
2186 ;; guaranteed to do the right thing from a clean compile. Additionally,
2187 ;; you had to use (GET-INST-SPACE :FORCE T) to pick up new definitions.
2188 ;; Given those considerations which made extending a running disassembler
2189 ;; nontrivial, the code-generating code is not so useful after the
2190 ;; initial instruction space is built, so it can all be removed.
2191 ;; But if you need all these macros to exist for some reason,
2192 ;; then define one of the two following features to keep them:
2193 #!+(or sb-fluid sb-retain-assembler-macros
)
2194 (return-from unintern-init-only-stuff
)
2196 (do-symbols (symbol sb
!assem
::*backend-instruction-set-package
*)
2197 (remf (symbol-plist symbol
) 'arg-type
)
2198 (remf (symbol-plist symbol
) 'inst-format
))
2200 ;; Get rid of functions that only make sense with metadata available.
2201 (dolist (s '(%def-arg-type %def-inst-format %gen-arg-forms
2202 all-arg-refs-relevant-p arg-or-lose arg-position arg-value-form
2203 collect-labelish-operands collect-prefiltering-args
2204 compare-fields-form compile-inst-printer compile-print
2205 compile-printer-body compile-printer-list compile-test
2206 correct-dchunk-bytespec-for-endianness
2207 define-arg-type define-instruction-format
2208 find-first-field-name find-printer-fun format-or-lose
2209 gen-arg-forms make-arg-temp-bindings make-funstate massage-arg
2210 maybe-listify modify-arg pd-error pick-printer-choice
2211 preprocess-chooses preprocess-conditionals preprocess-printer
2212 preprocess-test sharing-cons sharing-mapcar
))
2214 (unintern s
'sb-disassem
)))