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 ;;; the offset of FUNCTION from the start of its code-component's
265 (defun fun-insts-offset (function) ; FUNCTION *must* be pinned
266 (declare (type compiled-function function
))
267 (let ((simple-fun (%fun-fun function
)))
268 (- (get-lisp-obj-address simple-fun
)
269 sb
!vm
:fun-pointer-lowtag
270 (sap-int (code-instructions (fun-code-header simple-fun
))))))
272 ;;; the offset of FUNCTION from the start of its code-component
273 (defun fun-offset (function)
274 (declare (type compiled-function function
))
275 (words-to-bytes (get-closure-length function
)))
277 ;;;; operations on code-components (which hold the instructions for
278 ;;;; one or more functions)
280 (defun segment-offs-to-code-offs (offset segment
)
282 (let* ((seg-base-addr (sap-int (funcall (seg-sap-maker segment
))))
284 (logandc1 sb
!vm
:lowtag-mask
285 (get-lisp-obj-address (seg-code segment
))))
286 (addr (+ offset seg-base-addr
)))
287 (declare (type address seg-base-addr code-addr addr
))
288 (- addr code-addr
))))
290 (defun code-offs-to-segment-offs (offset segment
)
292 (let* ((seg-base-addr (sap-int (funcall (seg-sap-maker segment
))))
294 (logandc1 sb
!vm
:lowtag-mask
295 (get-lisp-obj-address (seg-code segment
))))
296 (addr (+ offset code-addr
)))
297 (declare (type address seg-base-addr code-addr addr
))
298 (- addr seg-base-addr
))))
300 (defun code-insts-offs-to-segment-offs (offset segment
)
302 (let* ((seg-base-addr (sap-int (funcall (seg-sap-maker segment
))))
304 (sap-int (code-instructions (seg-code segment
))))
305 (addr (+ offset code-insts-addr
)))
306 (declare (type address seg-base-addr code-insts-addr addr
))
307 (- addr seg-base-addr
))))
310 (defun lra-hook (chunk stream dstate
)
311 (declare (type dchunk chunk
)
313 (type (or null stream
) stream
)
314 (type disassem-state dstate
))
315 (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate
))
316 (dstate-cur-offs dstate
))
317 (* 2 sb
!vm
:n-word-bytes
))
319 (= (sap-ref-8 (dstate-segment-sap dstate
)
320 (if (eq (dstate-byte-order dstate
)
322 (dstate-cur-offs dstate
)
323 (+ (dstate-cur-offs dstate
)
325 sb
!vm
:return-pc-widetag
))
326 (unless (null stream
)
327 (note "possible LRA header" dstate
)))
330 ;;; Print the fun-header (entry-point) pseudo-instruction at the
331 ;;; current location in DSTATE to STREAM.
332 (defun fun-header-hook (stream dstate
)
333 (declare (type (or null stream
) stream
)
334 (type disassem-state dstate
))
335 (unless (null stream
)
336 (let* ((seg (dstate-segment dstate
))
337 (code (seg-code seg
))
338 (woffs (ash (segment-offs-to-code-offs (dstate-cur-offs dstate
) seg
)
339 (- sb
!vm
:word-shift
))) ; bytes -> words
340 (name (code-header-ref code
(+ woffs sb
!vm
:simple-fun-name-slot
)))
341 (args (code-header-ref code
(+ woffs sb
!vm
:simple-fun-arglist-slot
)))
342 (type (code-header-ref code
(+ woffs sb
!vm
:simple-fun-type-slot
))))
343 ;; if the function's name conveys its args, don't show ARGS too
344 (format stream
".~A ~S~:[~:A~;~]" 'entry name
345 (and (typep name
'(cons (eql lambda
) (cons list
)))
346 (equal args
(second name
)))
348 (note (lambda (stream)
349 (format stream
"~:S" type
)) ; use format to print NIL as ()
351 (incf (dstate-next-offs dstate
)
352 (words-to-bytes sb
!vm
:simple-fun-code-offset
)))
354 (defun alignment-hook (chunk stream dstate
)
355 (declare (type dchunk chunk
)
357 (type (or null stream
) stream
)
358 (type disassem-state dstate
))
360 (+ (seg-virtual-location (dstate-segment dstate
))
361 (dstate-cur-offs dstate
)))
362 (alignment (dstate-alignment dstate
)))
363 (unless (aligned-p location alignment
)
365 (format stream
"~A~Vt~W~%" '.align
366 (dstate-argument-column dstate
)
368 (incf (dstate-next-offs dstate
)
369 (- (align location alignment
) location
)))
372 (defun rewind-current-segment (dstate segment
)
373 (declare (type disassem-state dstate
)
374 (type segment segment
))
375 (setf (dstate-segment dstate
) segment
)
376 (setf (dstate-inst-properties dstate
) nil
)
377 (setf (dstate-cur-offs-hooks dstate
)
378 (stable-sort (nreverse (copy-list (seg-hooks segment
)))
380 (or (< (offs-hook-offset oh1
) (offs-hook-offset oh2
))
381 (and (= (offs-hook-offset oh1
)
382 (offs-hook-offset oh2
))
383 (offs-hook-before-address oh1
)
384 (not (offs-hook-before-address oh2
)))))))
385 (setf (dstate-cur-offs dstate
) 0)
386 (setf (dstate-cur-labels dstate
) (dstate-labels dstate
)))
388 (defun call-offs-hooks (before-address stream dstate
)
389 (declare (type (or null stream
) stream
)
390 (type disassem-state dstate
))
391 (let ((cur-offs (dstate-cur-offs dstate
)))
392 (setf (dstate-next-offs dstate
) cur-offs
)
394 (let ((next-hook (car (dstate-cur-offs-hooks dstate
))))
395 (when (null next-hook
)
397 (let ((hook-offs (offs-hook-offset next-hook
)))
398 (when (or (> hook-offs cur-offs
)
399 (and (= hook-offs cur-offs
)
401 (not (offs-hook-before-address next-hook
))))
403 (unless (< hook-offs cur-offs
)
404 (funcall (offs-hook-fun next-hook
) stream dstate
))
405 (pop (dstate-cur-offs-hooks dstate
))
406 (unless (= (dstate-next-offs dstate
) cur-offs
)
409 (defun call-fun-hooks (chunk stream dstate
)
410 (let ((hooks (dstate-fun-hooks dstate
))
411 (cur-offs (dstate-cur-offs dstate
)))
412 (setf (dstate-next-offs dstate
) cur-offs
)
413 (dolist (hook hooks nil
)
414 (let ((prefix-p (funcall hook chunk stream dstate
)))
415 (unless (= (dstate-next-offs dstate
) cur-offs
)
416 (return prefix-p
))))))
418 ;;; Print enough spaces to fill the column used for instruction bytes,
419 ;;; assuming that N-BYTES many instruction bytes have already been
420 ;;; printed in it, then print an additional space as separator to the
422 (defun pad-inst-column (stream n-bytes
)
423 (declare (type stream stream
)
424 (type text-width n-bytes
))
425 (when (> *disassem-inst-column-width
* 0)
426 (dotimes (i (- *disassem-inst-column-width
* (* 2 n-bytes
)))
427 (write-char #\space stream
))
428 (write-char #\space stream
)))
430 (defun handle-bogus-instruction (stream dstate prefix-len
)
431 (let ((alignment (dstate-alignment dstate
)))
432 (unless (null stream
)
433 (multiple-value-bind (words bytes
)
434 (truncate alignment sb
!vm
:n-word-bytes
)
436 (print-inst (* words sb
!vm
:n-word-bytes
) stream dstate
437 :trailing-space nil
))
439 (print-inst bytes stream dstate
:trailing-space nil
)))
440 (pad-inst-column stream
(+ prefix-len alignment
))
441 (decf (dstate-cur-offs dstate
) prefix-len
)
442 (print-bytes (+ prefix-len alignment
) stream dstate
))
443 (incf (dstate-next-offs dstate
) alignment
)))
445 (defstruct (filtered-arg (:copier nil
) (:predicate nil
) (:constructor nil
))
447 ;;; Return an arbitrary object (one that is a subtype of FILTERED-ARG)
448 ;;; that is automatically returned to the dstate's filtered-arg-pool
449 ;;; after disassembly of the current instruction.
450 ;;; Any given disassembler backend must use the same constructor for
451 ;;; its filtered args that participate in the pool.
452 (defun new-filtered-arg (dstate constructor
)
453 (let ((arg (dstate-filtered-arg-pool-free dstate
)))
455 (setf (dstate-filtered-arg-pool-free dstate
) (filtered-arg-next arg
))
456 (setf arg
(funcall constructor
)))
457 (sb!c
::push-in filtered-arg-next arg
(dstate-filtered-arg-pool-in-use dstate
))
460 ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
461 ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE.
462 ;;; Additionally, unless STREAM is NIL, several items are output to it:
463 ;;; things printed from several hooks, for example labels, and instruction
464 ;;; bytes before FUNCTION is called, notes and a newline afterwards.
465 ;;; Instructions having an INST-PRINTER of NIL are treated as prefix
466 ;;; instructions which makes them print on the same line as the following
467 ;;; instruction, outputting their INST-PRINT-NAME (unless that is NIL)
468 ;;; before FUNCTION is called for the following instruction.
469 (defun map-segment-instructions (function segment dstate
&optional stream
)
470 (declare (type function function
)
471 (type segment segment
)
472 (type disassem-state dstate
)
473 (type (or null stream
) stream
))
475 (let ((ispace (get-inst-space))
477 ;; If the segment starts with unboxed data,
478 ;; dump some number of words using the .WORD pseudo-ops.
479 (if (and (seg-unboxed-data-range segment
)
480 (= (segment-offs-to-code-offs 0 segment
)
481 (car (seg-unboxed-data-range segment
))))
482 (code-offs-to-segment-offs (cdr (seg-unboxed-data-range segment
))
485 (prefix-p nil
) ; just processed a prefix inst
486 (prefix-len 0) ; sum of lengths of any prefix instruction(s)
487 (prefix-print-names nil
)) ; reverse list of prefixes seen
489 (rewind-current-segment dstate segment
)
492 (when (>= (dstate-cur-offs dstate
) (seg-length (dstate-segment dstate
)))
494 (when (and stream
(> prefix-len
0))
495 (pad-inst-column stream prefix-len
)
496 (decf (dstate-cur-offs dstate
) prefix-len
)
497 (print-bytes prefix-len stream dstate
)
498 (incf (dstate-cur-offs dstate
) prefix-len
))
501 (setf (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
503 (call-offs-hooks t stream dstate
)
504 (unless (or prefix-p
(null stream
))
505 (print-current-address stream dstate
))
506 (call-offs-hooks nil stream dstate
)
508 (when (< (dstate-cur-offs dstate
) data-end-offset
)
511 (format stream
"~A #x~v,'0x" '.word
512 (* 2 sb
!vm
:n-word-bytes
)
513 (sap-ref-int (funcall (seg-sap-maker segment
))
514 (dstate-cur-offs dstate
)
516 (dstate-byte-order dstate
)))))
517 (setf (dstate-next-offs dstate
)
518 (+ (dstate-cur-offs dstate
) sb
!vm
:n-word-bytes
)))
520 (unless (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
521 ;; FIXME: this can probably be WITH-PINNED-OBJECTS. For octet vectors and code
522 ;; there is something to pin, whereas if you are passing a memory address then
523 ;; you are either inside without-gcing anyway for this to be sensible at all,
524 ;; or are disassembling foreign code.
526 (setf (dstate-segment-sap dstate
) (funcall (seg-sap-maker segment
)))
528 (let* ((bytes-remaining (- (seg-length (dstate-segment dstate
))
529 (dstate-cur-offs dstate
)))
531 (multiple-value-bind (sap offset
)
532 ;; Don't read beyond the segment. This can occur with DISASSEMBLE-MEMORY
533 ;; on a function whose code ends in pad bytes that are not an integral
534 ;; number of instructions, and maybe you're so unlucky as to be
535 ;; on the exact last page of your heap.
536 (if (< bytes-remaining
(/ dchunk-bits
8))
537 (let* ((scratch-buf (dstate-scratch-buf dstate
))
538 (sap (vector-sap scratch-buf
)))
539 ;; We're inside a WITHOUT-GCING (up above).
540 ;; Otherwise, put (dstate-scratch-buf dstate) in WPO
542 (system-area-ub8-copy
543 (dstate-segment-sap dstate
)
544 (dstate-cur-offs dstate
)
545 sap
0 bytes-remaining
)
547 (values (dstate-segment-sap dstate
)
548 (dstate-cur-offs dstate
)))
549 #!+x86-64
; a dchunk is 56 bits, making it a fixnum.
550 ;; No instruction needs more bits than that to locate it
551 ;; in the inst-space. An optional displacement and/or immediate
552 ;; operand can extend the overall length, but those aren't
553 ;; part of the dchunk. We can't use SAP-REF-INT because that
554 ;; would return a word-sized bignum which is the very thing
555 ;; this special case tries to avoid.
556 (logand (sap-ref-word sap offset
) dchunk-one
)
560 (sap-ref-int sap offset
561 (ecase dchunk-bits
(32 4) (64 8))
562 (dstate-byte-order dstate
)))))
564 (fun-prefix-p (call-fun-hooks chunk stream dstate
)))
565 (if (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
566 (setf prefix-p fun-prefix-p
)
567 (let ((inst (find-inst chunk ispace
)))
569 (handle-bogus-instruction stream dstate prefix-len
)
571 ;; On x86, the pad bytes at the end of a simple-fun
572 ;; decode as "ADD [RAX], AL" if there are 2 bytes,
573 ;; but if there's only 1 byte, it should show "BYTE 0".
574 ;; There's really nothing we can do about the former.
575 ((> (inst-length inst
) bytes-remaining
)
577 (print-inst bytes-remaining stream dstate
)
578 (print-bytes bytes-remaining stream dstate
)
582 (setf (dstate-next-offs dstate
)
583 (+ (dstate-cur-offs dstate
)
585 (let ((orig-next (dstate-next-offs dstate
))
586 (control (inst-control inst
)))
588 (print-inst (inst-length inst
) stream dstate
589 :trailing-space nil
))
591 (dolist (item (inst-prefilters inst
))
592 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
593 ;; item = #(INDEX FUNCTION SIGN-EXTEND-P BYTE-SPEC ...).
594 (flet ((extract-byte (spec-index)
595 (let* ((byte-spec (svref item spec-index
))
596 (integer (dchunk-extract chunk byte-spec
)))
597 (if (svref item
2) ; SIGN-EXTEND-P
598 (sign-extend integer
(byte-size byte-spec
))
600 (let ((item-length (length item
))
601 (fun (svref item
1)))
602 (setf (svref (dstate-filtered-values dstate
) (svref item
0))
604 (2 (funcall fun dstate
)) ; no subfields
605 (3 (bug "Bogus prefilter"))
606 (4 (funcall fun dstate
(extract-byte 3))) ; one subfield
607 (5 (funcall fun dstate
; two subfields
608 (extract-byte 3) (extract-byte 4)))
609 (t (apply fun dstate
; > 2 subfields
610 (loop for i from
3 below item-length
611 collect
(extract-byte i
)))))))))
613 (setf prefix-p
(null (inst-printer inst
)))
616 ;; Print any instruction bytes recognized by
617 ;; the prefilter which calls read-suffix and
618 ;; updates next-offs.
619 (let ((suffix-len (- (dstate-next-offs dstate
)
621 (when (plusp suffix-len
)
622 (print-inst suffix-len stream dstate
623 :offset
(inst-length inst
)
624 :trailing-space nil
))
625 ;; Keep track of the number of bytes
627 (incf prefix-len
(+ (inst-length inst
)
630 (let ((name (inst-print-name inst
)))
632 (push name prefix-print-names
)))
634 ;; PREFIX-LEN includes the length of the
635 ;; current (non-prefix) instruction here.
636 (pad-inst-column stream prefix-len
)
637 (dolist (name (reverse prefix-print-names
))
639 (write-char #\space stream
)))))
641 (funcall function chunk inst
)
644 (funcall control chunk inst stream dstate
))))))))))
646 (setf (dstate-cur-offs dstate
) (dstate-next-offs dstate
))
651 prefix-print-names nil
)
652 (print-notes-and-newline stream dstate
))
653 (setf (dstate-output-state dstate
) nil
))
655 (let ((arg (dstate-filtered-arg-pool-in-use dstate
)))
656 (loop (unless arg
(return))
657 (let ((saved-next (filtered-arg-next arg
)))
658 (sb!c
::push-in filtered-arg-next arg
659 (dstate-filtered-arg-pool-free dstate
))
660 (setq arg saved-next
))))
661 (setf (dstate-filtered-arg-pool-in-use dstate
) nil
)
662 (setf (dstate-inst-properties dstate
) nil
)))))
665 (defun collect-labelish-operands (args cache
)
666 (awhen (remove-if-not #'arg-use-label args
)
667 (let* ((list (mapcar (lambda (arg &aux
(fun (arg-use-label arg
))
668 (prefilter (arg-prefilter arg
))
669 (bytes (arg-fields arg
)))
670 ;; Require byte specs or a prefilter (or both).
671 ;; Prefilter alone is ok - it can use READ-SUFFIX.
672 ;; Additionally, you can't have :use-label T
673 ;; if multiple fields exist with no prefilter.
675 (if (eq fun t
) (singleton-p bytes
) bytes
)))
676 ;; If arg has a prefilter, just compute its index,
677 ;; otherwise keep the byte specs for extraction.
678 (coerce (cons (if (eq fun t
) #'identity fun
)
680 (list (posq arg args
))
681 (cons (arg-sign-extend-p arg
) bytes
)))
684 (repr (if (cdr list
) list
(car list
))) ; usually just 1 item
685 (table (assq :labeller cache
)))
686 (or (find repr
(cdr table
) :test
'equalp
)
687 (car (push repr
(cdr table
)))))))
689 ;;; Make an initial non-printing disassembly pass through DSTATE,
690 ;;; noting any addresses that are referenced by instructions in this
692 (defun add-segment-labels (segment dstate
)
693 ;; add labels at the beginning with a label-number of nil; we'll notice
694 ;; later and fill them in (and sort them)
695 (declare (type disassem-state dstate
))
696 (let ((labels (dstate-labels dstate
)))
697 (map-segment-instructions
699 (declare (type dchunk chunk
) (type instruction inst
))
700 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
701 (loop with list
= (inst-labeller inst
)
703 ;; item = #(FUNCTION PREFILTERED-VALUE-INDEX)
704 ;; | #(FUNCTION SIGN-EXTEND-P BYTE-SPEC ...)
705 for item
= (if (listp list
) (pop list
) (prog1 list
(setq list nil
)))
707 do
(let* ((item-length (length item
))
708 (index/signedp
(svref item
1))
712 (flet ((extract-byte (spec-index)
713 (let* ((byte-spec (svref item spec-index
))
714 (integer (dchunk-extract chunk byte-spec
)))
716 (sign-extend integer
(byte-size byte-spec
))
719 (2 (svref (dstate-filtered-values dstate
) index
/signedp
))
720 (3 (extract-byte 2)) ; extract exactly one byte
721 (t ; extract >1 byte.
722 ;; FIXME: this is strictly redundant.
723 ;; You should combine fields in the prefilter
724 ;; so that the labeller receives a single byte.
725 ;; AARCH64 and HPPA make use of this though.
726 (loop for i from
2 below item-length
727 collect
(extract-byte i
)))))
729 ;; If non-integer, the value is not a label.
730 (when (and (integerp adjusted-value
)
731 (not (assoc adjusted-value labels
)))
732 (push (cons adjusted-value nil
) labels
)))))
735 (setf (dstate-labels dstate
) labels
)
736 ;; erase any notes that got there by accident
737 (setf (dstate-notes dstate
) nil
)))
739 ;;; If any labels in DSTATE have been added since the last call to
740 ;;; this function, give them label-numbers, enter them in the
741 ;;; hash-table, and make sure the label list is in sorted order.
742 (defun number-labels (dstate)
743 (let ((labels (dstate-labels dstate
)))
744 (when (and labels
(null (cdar labels
)))
745 ;; at least one label left un-numbered
746 (setf labels
(sort labels
#'< :key
#'car
))
748 (label-hash (dstate-label-hash dstate
)))
749 (dolist (label labels
)
750 (when (not (null (cdr label
)))
751 (setf max
(max max
(cdr label
)))))
752 (dolist (label labels
)
753 (when (null (cdr label
))
755 (setf (cdr label
) max
)
756 (setf (gethash (car label
) label-hash
)
757 (format nil
"L~W" max
)))))
758 (setf (dstate-labels dstate
) labels
))))
760 (defun collect-inst-variants (base-name package variants cache
)
761 (loop for printer in variants
764 (destructuring-bind (format-name
765 (&rest arg-constraints
)
766 &optional
(printer :default
)
768 (without-package-locks (intern base-name package
)))
771 (declare (type (or symbol string
) print-name
))
772 (let* ((format (format-or-lose format-name
))
773 (args (copy-list (format-args format
)))
774 (format-length (bytes-to-bits (format-length format
))))
775 (dolist (constraint arg-constraints
)
776 (destructuring-bind (name . props
) constraint
777 (let ((cell (member name args
:key
#'arg-name
))
780 (setf (car cell
) (setf arg
(copy-structure (car cell
))))
781 (setf args
(nconc args
(list (setf arg
(%make-arg name
))))))
783 arg format-length
(and props
(cons :value props
))))))
784 (multiple-value-bind (mask id
) (compute-mask-id args
)
786 base-name format-name print-name
787 (format-length format
) mask id
788 (awhen (if (eq printer
:default
)
789 (format-default-printer format
)
791 (find-printer-fun it args cache
(list base-name index
)))
792 (collect-labelish-operands args cache
)
793 (collect-prefiltering-args args cache
)
796 (defun !compile-inst-printers
()
797 (let ((package sb
!assem
::*backend-instruction-set-package
*)
798 (cache (list (list :printer
) (list :prefilter
) (list :labeller
))))
799 (do-symbols (symbol package
)
800 (awhen (get symbol
'instruction-flavors
)
801 (setf (get symbol
'instruction-flavors
)
802 (collect-inst-variants
803 (logically-readonlyize (string-upcase symbol
))
806 "~&Disassembler: ~D printers, ~D prefilters, ~D labelers~%"
807 (mapcar (lambda (x) (length (cdr x
))) cache
))))
809 ;;; Get the instruction-space, creating it if necessary.
810 (defun get-inst-space (&key
(package sb
!assem
::*backend-instruction-set-package
*)
812 (let ((ispace *disassem-inst-space
*))
813 (when (or force
(null ispace
))
815 (do-symbols (symbol package
)
816 (setq insts
(nconc (copy-list (get symbol
'instruction-flavors
))
818 (setf ispace
(build-inst-space insts
)))
819 (setf *disassem-inst-space
* ispace
))
822 ;;;; Add global hooks.
824 (defun add-offs-hook (segment addr hook
)
825 (let ((entry (cons addr hook
)))
826 (if (null (seg-hooks segment
))
827 (setf (seg-hooks segment
) (list entry
))
828 (push entry
(cdr (last (seg-hooks segment
)))))))
830 (defun add-offs-note-hook (segment addr note
)
831 (add-offs-hook segment
833 (lambda (stream dstate
)
834 (declare (type (or null stream
) stream
)
835 (type disassem-state dstate
))
837 (note note dstate
)))))
839 (defun add-offs-comment-hook (segment addr comment
)
840 (add-offs-hook segment
842 (lambda (stream dstate
)
843 (declare (type (or null stream
) stream
)
846 (write-string ";;; " stream
)
849 (write-string comment stream
))
851 (funcall comment stream
)))
854 (defun add-fun-hook (dstate function
)
855 (push function
(dstate-fun-hooks dstate
)))
857 (defun set-location-printing-range (dstate from length
)
858 (setf (dstate-addr-print-len dstate
) ; in characters
859 ;; 4 bits per hex digit
860 (ceiling (integer-length (logxor from
(+ from length
))) 4)))
862 ;;; Print the current address in DSTATE to STREAM, plus any labels that
863 ;;; correspond to it, and leave the cursor in the instruction column.
864 (defun print-current-address (stream dstate
)
865 (declare (type stream stream
)
866 (type disassem-state dstate
))
868 (+ (seg-virtual-location (dstate-segment dstate
))
869 (dstate-cur-offs dstate
)))
870 (location-column-width *disassem-location-column-width
*)
871 (plen ; the number of rightmost hex chars of this address to print
872 (or (dstate-addr-print-len dstate
)
873 ;; Usually we've already set the width, but in case not...
874 (let ((seg (dstate-segment dstate
)))
875 (set-location-printing-range
876 dstate
(seg-virtual-location seg
) (seg-length seg
))))))
878 (if (eq (dstate-output-state dstate
) :beginning
) ; on the first line
879 (if location-column-width
880 ;; If there's a user-specified width, force that number of hex chars
881 ;; regardless of whether it's greater or smaller than PLEN.
882 (setq plen location-column-width
)
883 ;; No specified width. The PLEN of this line becomes the width.
884 ;; Adjust the DSTATE's argument column for it.
885 (incf (dstate-argument-column dstate
)
886 (setq location-column-width plen
)))
887 ;; not the first line
888 (if location-column-width
889 ;; A specified width smaller than that required clips significant
890 ;; digits, but larger should not cause leading zeros to appear.
891 (setq plen
(min plen location-column-width
))
892 ;; Otherwise use the previously computed addr-print-len
893 (setq location-column-width plen
)))
895 (incf location-column-width
2) ; account for leading "; "
899 ;; print the location
900 ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
901 ;; usually avoids any consing]
902 ;; FIXME: if this cruft is actually a speed win, the format-string compiler
903 ;; should be improved to obviate the obfuscation. If it is not a win,
904 ;; we should just replace it with the above format string already.
905 (tab0 (- location-column-width plen
) stream
)
906 (let* ((printed-bits (* 4 plen
))
907 (printed-value (ldb (byte printed-bits
0) location
))
909 (truncate (- printed-bits
(integer-length printed-value
)) 4)))
910 (dotimes (i leading-zeros
)
911 (write-char #\
0 stream
))
912 (unless (zerop printed-value
)
913 (write printed-value
:stream stream
:base
16 :radix nil
))
915 (write-char #\
: stream
)))
919 (let* ((next-label (car (dstate-cur-labels dstate
)))
920 (label-location (car next-label
)))
921 (when (or (null label-location
) (> label-location location
))
923 (unless (< label-location location
)
924 (format stream
" L~W:" (cdr next-label
)))
925 (pop (dstate-cur-labels dstate
))))
927 ;; move to the instruction column
928 (tab0 (+ location-column-width
1 label-column-width
) stream
)
931 (eval-when (:compile-toplevel
:execute
)
932 (sb!xc
:defmacro with-print-restrictions
(&rest body
)
933 `(let ((*print-pretty
* t
)
939 ;;; Print a newline to STREAM, inserting any pending notes in DSTATE
940 ;;; as end-of-line comments. If there is more than one note, a
941 ;;; separate line will be used for each one.
942 (defun print-notes-and-newline (stream dstate
)
943 (declare (type stream stream
)
944 (type disassem-state dstate
))
945 (with-print-restrictions
946 (dolist (note (dstate-notes dstate
))
947 (format stream
"~Vt " *disassem-note-column
*)
948 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
951 (write-string note stream
))
953 (funcall note stream
))))
956 (setf (dstate-notes dstate
) nil
)))
958 ;;; Print NUM instruction bytes to STREAM as hex values.
959 (defun print-inst (num stream dstate
&key
(offset 0) (trailing-space t
))
960 (when (> *disassem-inst-column-width
* 0)
961 (let ((sap (dstate-segment-sap dstate
))
962 (start-offs (+ offset
(dstate-cur-offs dstate
))))
964 (format stream
"~2,'0x" (sap-ref-8 sap
(+ offs start-offs
))))
966 (pad-inst-column stream num
)))))
968 ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
969 (defun print-bytes (num stream dstate
)
970 (declare (type offset num
)
972 (type disassem-state dstate
))
973 (format stream
"~A~Vt" 'BYTE
(dstate-argument-column dstate
))
974 (let ((sap (dstate-segment-sap dstate
))
975 (start-offs (dstate-cur-offs dstate
)))
978 (write-string ", " stream
))
979 (format stream
"#X~2,'0x" (sap-ref-8 sap
(+ offs start-offs
))))))
981 (defvar *default-dstate-hooks
*
982 (list* #!-
(or x86 x86-64
) #'lra-hook nil
))
984 ;;; Make a disassembler-state object.
985 (defun make-dstate (&optional
(fun-hooks *default-dstate-hooks
*))
986 (let ((alignment *disassem-inst-alignment-bytes
*)
988 (+ 2 ; for the leading "; " on each line
989 (or *disassem-location-column-width
* 0)
992 *disassem-inst-column-width
*
993 (if (zerop *disassem-inst-column-width
*) 0 1)
994 *disassem-opcode-column-width
*)))
996 (when (> alignment
1)
997 (push #'alignment-hook fun-hooks
))
999 (%make-dstate
:fun-hooks fun-hooks
1000 :argument-column arg-column
1001 :alignment alignment
1002 :byte-order sb
!c
:*backend-byte-order
*)))
1004 (defun add-fun-header-hooks (segment)
1005 (declare (type segment segment
))
1006 (dotimes (i (or (awhen (seg-code segment
) (code-n-entries it
)) 0))
1007 (let* ((fun (%code-entry-point
(seg-code segment
) i
))
1008 (length (seg-length segment
))
1009 (offset (code-offs-to-segment-offs (fun-offset fun
) segment
)))
1010 (when (<= 0 offset length
)
1011 ;; Up to 2 words of zeros might be present to align the next
1012 ;; simple-fun. Limit on OFFSET is to avoid incorrect triggering
1013 ;; in case of unexpected weirdness. FIXME: verify all zero bytes
1014 (when (< 0 offset
(* sb
!vm
:n-word-bytes
2))
1015 (push (make-offs-hook
1016 :fun
(lambda (stream dstate
)
1018 (format stream
".SKIP ~D" offset
))
1019 (incf (dstate-next-offs dstate
) offset
))
1020 :offset
0) ; at 0 bytes into this seg, skip OFFSET bytes
1021 (seg-hooks segment
)))
1022 (push (make-offs-hook :offset offset
:fun
#'fun-header-hook
)
1023 (seg-hooks segment
))))))
1025 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
1027 ;; FIXME: Are the objects we are taking saps for always pinned?
1028 #!-sb-fluid
(declaim (inline sap-maker
))
1029 (defun sap-maker (function input offset
)
1030 (declare (optimize (speed 3))
1031 (muffle-conditions compiler-note
)
1032 (type (function (t) system-area-pointer
) function
)
1033 (type offset offset
))
1034 (let ((old-sap (sap+ (funcall function input
) offset
)))
1035 (declare (type system-area-pointer old-sap
))
1038 (+ (sap-int (funcall function input
)) offset
)))
1039 ;; Saving the sap like this avoids consing except when the sap
1040 ;; changes (because the sap-int, arith, etc., get inlined).
1041 (declare (type address new-addr
))
1042 (if (= (sap-int old-sap
) new-addr
)
1044 (setf old-sap
(int-sap new-addr
)))))))
1046 (defun vector-sap-maker (vector offset
)
1047 (declare (optimize (speed 3))
1048 (type offset offset
))
1049 (sap-maker #'vector-sap vector offset
))
1051 (defun code-sap-maker (code offset
)
1052 (declare (optimize (speed 3))
1053 (type code-component code
)
1054 (type offset offset
))
1055 (sap-maker #'code-instructions code offset
))
1057 (defun memory-sap-maker (address)
1058 (declare (optimize (speed 3))
1059 (muffle-conditions compiler-note
)
1060 (type address address
))
1061 (let ((sap (int-sap address
)))
1064 (defstruct (source-form-cache (:conc-name sfcache-
)
1066 (debug-source nil
:type
(or null sb
!di
:debug-source
))
1067 (toplevel-form-index -
1 :type fixnum
)
1068 (last-location-retrieved nil
:type
(or null sb
!di
:code-location
))
1069 (last-form-retrieved -
1 :type fixnum
))
1071 ;;; Return a memory segment located at the system-area-pointer returned by
1072 ;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
1074 ;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
1075 ;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a
1076 ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
1078 (defun make-segment (sap-maker length
1080 code virtual-location
1081 debug-fun source-form-cache
1083 (declare (type (function () system-area-pointer
) sap-maker
)
1084 (type disassem-length length
)
1085 (type (or null address
) virtual-location
)
1086 (type (or null sb
!di
:debug-fun
) debug-fun
)
1087 (type (or null source-form-cache
) source-form-cache
))
1090 :sap-maker sap-maker
1092 :virtual-location
(or virtual-location
1093 (sap-int (funcall sap-maker
)))
1098 (let ((n-words (code-n-unboxed-data-words code
))
1099 (start (code-header-words code
)))
1100 (and (plusp n-words
)
1101 (cons (* sb
!vm
:n-word-bytes start
)
1102 (* sb
!vm
:n-word-bytes
(+ start n-words
)))))))))
1103 (add-debugging-hooks segment debug-fun source-form-cache
)
1104 (add-fun-header-hooks segment
)
1107 (defun make-vector-segment (vector offset
&rest args
)
1108 (declare (type vector vector
)
1109 (type offset offset
)
1110 (inline make-segment
))
1111 (apply #'make-segment
(vector-sap-maker vector offset
) args
))
1113 (defun make-code-segment (code offset length
&rest args
)
1114 (declare (type code-component code
)
1115 (type offset offset
)
1116 (inline make-segment
))
1117 (apply #'make-segment
(code-sap-maker code offset
) length
:code code args
))
1119 (defun make-memory-segment (address &rest args
)
1120 (declare (type address address
)
1121 (inline make-segment
))
1122 (apply #'make-segment
(memory-sap-maker address
) args
))
1125 (defun print-fun-headers (function)
1126 (declare (type compiled-function function
))
1127 (let* ((self (%fun-fun function
))
1128 (code (fun-code-header self
)))
1129 (format t
"Code-header ~S: size: ~S~%" code
(%code-code-size code
))
1130 (loop for i below
(code-n-entries code
)
1131 for fun
= (%code-entry-point code i
)
1133 ;; There is function header fun-offset words from the
1135 (format t
"Fun-header ~S at offset ~W (words):~% ~S ~A => ~S~%"
1137 (get-closure-length fun
)
1138 (%simple-fun-name fun
)
1139 (%simple-fun-arglist fun
)
1140 (%simple-fun-type fun
)))))
1142 ;;; getting at the source code...
1144 (defun get-different-source-form (loc context
&optional cache
)
1146 (eq (sb!di
:code-location-debug-source loc
)
1147 (sfcache-debug-source cache
))
1148 (eq (sb!di
:code-location-toplevel-form-offset loc
)
1149 (sfcache-toplevel-form-index cache
))
1150 (or (eql (sb!di
:code-location-form-number loc
)
1151 (sfcache-last-form-retrieved cache
))
1152 (awhen (sfcache-last-location-retrieved cache
)
1153 (sb!di
:code-location
= loc it
))))
1155 (let ((form (sb!debug
::code-location-source-form loc context nil
)))
1157 (setf (sfcache-debug-source cache
)
1158 (sb!di
:code-location-debug-source loc
))
1159 (setf (sfcache-toplevel-form-index cache
)
1160 (sb!di
:code-location-toplevel-form-offset loc
))
1161 (setf (sfcache-last-form-retrieved cache
)
1162 (sb!di
:code-location-form-number loc
))
1163 (setf (sfcache-last-location-retrieved cache
) loc
))
1166 ;;;; stuff to use debugging info to augment the disassembly
1168 (defun code-fun-map (code)
1169 (declare (type code-component code
))
1170 (sb!c
::compiled-debug-info-fun-map
(%code-debug-info code
)))
1172 (defstruct (location-group (:copier nil
) (:predicate nil
))
1173 ;; This was (VECTOR (OR LIST FIXNUM)) but that doesn't have any
1174 ;; specialization other than T, and the cross-compiler has trouble
1175 ;; with (SB!XC:TYPEP #() '(VECTOR (OR LIST FIXNUM)))
1176 (locations #() :type simple-vector
))
1178 ;;; Return the vector of DEBUG-VARs currently associated with DSTATE.
1179 (defun dstate-debug-vars (dstate)
1180 (declare (type disassem-state dstate
))
1181 (storage-info-debug-vars (seg-storage-info (dstate-segment dstate
))))
1183 ;;; Given the OFFSET of a location within the location-group called
1184 ;;; LG-NAME, see whether there's a current mapping to a source
1185 ;;; variable in DSTATE, and if so, return the offset of that variable
1186 ;;; in the current debug-var vector.
1187 (defun find-valid-storage-location (offset lg-name dstate
)
1188 (declare (type offset offset
)
1189 (type symbol lg-name
)
1190 (type disassem-state dstate
))
1191 (let* ((storage-info
1192 (seg-storage-info (dstate-segment dstate
)))
1195 (cdr (assoc lg-name
(storage-info-groups storage-info
)))))
1197 (dstate-current-valid-locations dstate
)))
1199 (not (null currently-valid
))
1200 (let ((locations (location-group-locations location-group
)))
1201 (and (< offset
(length locations
))
1202 (let ((used-by (aref locations offset
)))
1204 (let ((debug-var-num
1208 (zerop (bit currently-valid used-by
)))
1214 (bit currently-valid num
)))
1219 ;; Found a valid storage reference!
1220 ;; can't use it again until it's revalidated...
1221 (setf (bit (dstate-current-valid-locations
1228 ;;; Return a STORAGE-INFO struction describing the object-to-source
1229 ;;; variable mappings from DEBUG-FUN.
1230 (defun storage-info-for-debug-fun (debug-fun)
1231 (declare (type sb
!di
:debug-fun debug-fun
))
1232 (let ((sc-vec sb
!c
::*backend-sc-numbers
*)
1234 (debug-vars (sb!di
::debug-fun-debug-vars debug-fun
)))
1236 (dotimes (debug-var-offset
1238 (make-storage-info :groups groups
1239 :debug-vars debug-vars
))
1240 (let ((debug-var (aref debug-vars debug-var-offset
)))
1242 (format t
";;; At offset ~W: ~S~%" debug-var-offset debug-var
)
1244 (sb!di
::compiled-debug-var-sc-offset debug-var
))
1247 (sb!c
:sc-sb
(aref sc-vec
1248 (sb!c
:sc-offset-scn sc-offset
))))))
1250 (format t
";;; SET: ~S[~W]~%"
1251 sb-name
(sb!c
:sc-offset-offset sc-offset
))
1252 (unless (null sb-name
)
1253 (let ((group (cdr (assoc sb-name groups
))))
1255 (setf group
(make-location-group))
1256 (push `(,sb-name .
,group
) groups
))
1257 (let* ((locations (location-group-locations group
))
1258 (length (length locations
))
1259 (offset (sb!c
:sc-offset-offset sc-offset
)))
1260 (when (>= offset length
)
1261 (setf locations
(adjust-array locations
1262 (max (* 2 length
) (1+ offset
)))
1263 (location-group-locations group
) locations
))
1264 (let ((already-there (aref locations offset
)))
1265 (cond ((null already-there
)
1266 (setf (aref locations offset
) debug-var-offset
))
1267 ((eql already-there debug-var-offset
))
1269 (if (listp already-there
)
1270 (pushnew debug-var-offset
1271 (aref locations offset
))
1272 (setf (aref locations offset
)
1273 (list debug-var-offset
1278 (defun source-available-p (debug-fun)
1280 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1281 (declare (ignore block
))
1283 (sb!di
:no-debug-blocks
() nil
)))
1285 (defun print-block-boundary (stream dstate
)
1286 (let ((os (dstate-output-state dstate
)))
1287 (when (not (eq os
:beginning
))
1288 (when (not (eq os
:block-boundary
))
1290 (setf (dstate-output-state dstate
)
1293 ;;; Add hooks to track the source code in SEGMENT during disassembly.
1294 ;;; SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
1295 ;;; structure, in which case it is used to cache forms from files.
1296 (defun add-source-tracking-hooks (segment debug-fun
&optional sfcache
)
1297 (declare (type segment segment
)
1298 (type (or null sb
!di
:debug-fun
) debug-fun
)
1299 (type (or null source-form-cache
) sfcache
))
1300 (let ((last-block-pc -
1))
1301 (flet ((add-hook (pc fun
&optional before-address
)
1302 (push (make-offs-hook
1303 :offset
(code-insts-offs-to-segment-offs pc segment
)
1305 :before-address before-address
)
1306 (seg-hooks segment
))))
1308 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1309 (let ((first-location-in-block-p t
))
1310 (sb!di
:do-debug-block-locations
(loc block
)
1311 (let ((pc (sb!di
::compiled-code-location-pc loc
)))
1313 ;; Put blank lines in at block boundaries
1314 (when (and first-location-in-block-p
1315 (/= pc last-block-pc
))
1316 (setf first-location-in-block-p nil
)
1318 (lambda (stream dstate
)
1319 (print-block-boundary stream dstate
))
1321 (setf last-block-pc pc
))
1323 ;; Print out corresponding source; this information is not
1324 ;; all that accurate, but it's better than nothing
1325 (unless (zerop (sb!di
:code-location-form-number loc
))
1326 (multiple-value-bind (form new
)
1327 (get-different-source-form loc
0 sfcache
)
1329 (let ((at-block-begin (= pc last-block-pc
)))
1332 (lambda (stream dstate
)
1333 (declare (ignore dstate
))
1335 (unless at-block-begin
1337 (format stream
";;; [~W] "
1338 (sb!di
:code-location-form-number
1340 (prin1-short form stream
)
1345 ;; Keep track of variable live-ness as best we can.
1347 (copy-seq (sb!di
::compiled-code-location-live-set
1351 (lambda (stream dstate
)
1352 (declare (ignore stream
))
1353 (setf (dstate-current-valid-locations dstate
)
1356 (note (lambda (stream)
1357 (let ((*print-length
* nil
))
1358 (format stream
"live set: ~S"
1362 (sb!di
:no-debug-blocks
() nil
)))))
1364 (defvar *disassemble-annotate
* nil
1365 "Annotate DISASSEMBLE output with source code.")
1367 (defun add-debugging-hooks (segment debug-fun
&optional sfcache
)
1369 (setf (seg-storage-info segment
)
1370 (storage-info-for-debug-fun debug-fun
))
1371 (when *disassemble-annotate
*
1372 (add-source-tracking-hooks segment debug-fun sfcache
))
1373 (let ((kind (sb!di
:debug-fun-kind debug-fun
)))
1374 (flet ((add-new-hook (n)
1375 (push (make-offs-hook
1377 :fun
(lambda (stream dstate
)
1378 (declare (ignore stream
))
1380 (seg-hooks segment
))))
1384 (add-new-hook "no-arg-parsing entry point"))
1386 (add-new-hook (lambda (stream)
1387 (format stream
"~S entry point" kind
)))))))))
1389 ;;; Return a list of the segments of memory containing machine code
1390 ;;; instructions for FUNCTION.
1391 (defun get-fun-segments (function)
1392 (declare (type compiled-function function
))
1393 (let* ((function (%fun-fun function
))
1394 (code (fun-code-header function
))
1395 (fun-map (code-fun-map code
))
1396 (fname (%simple-fun-name function
))
1397 (sfcache (make-source-form-cache)))
1398 (let ((first-block-seen-p nil
)
1399 (nil-block-seen-p nil
)
1401 (last-debug-fun nil
)
1403 (flet ((add-seg (offs len df
)
1405 (push (make-code-segment code offs len
1407 :source-form-cache sfcache
)
1409 (dotimes (fmap-index (length fun-map
))
1410 (let ((fmap-entry (aref fun-map fmap-index
)))
1411 (etypecase fmap-entry
1413 (when first-block-seen-p
1414 (add-seg last-offset
1415 (- fmap-entry last-offset
)
1417 (setf last-debug-fun nil
))
1418 (setf last-offset fmap-entry
))
1419 (sb!c
::compiled-debug-fun
1420 (let ((name (sb!c
::compiled-debug-fun-name fmap-entry
))
1421 (kind (sb!c
::compiled-debug-fun-kind fmap-entry
)))
1423 (format t
";;; SAW ~S ~S ~S,~S ~W,~W~%"
1424 name kind first-block-seen-p nil-block-seen-p
1426 (sb!c
::compiled-debug-fun-start-pc fmap-entry
))
1427 (cond (#+nil
(eq last-offset fun-offset
)
1428 (and (equal name fname
)
1430 (not first-block-seen-p
))
1431 (setf first-block-seen-p t
))
1432 ((eq kind
:external
)
1433 (when first-block-seen-p
1436 (when nil-block-seen-p
1438 (when first-block-seen-p
1439 (setf nil-block-seen-p t
))))
1440 (setf last-debug-fun
1441 (sb!di
::make-compiled-debug-fun fmap-entry code
)))))))
1442 (let ((max-offset (%code-code-size code
)))
1443 (when (and first-block-seen-p last-debug-fun
)
1444 (add-seg last-offset
1445 (- max-offset last-offset
)
1447 (if (null segments
) ; FIXME: when does this happen? Comment PLEASE
1448 (let ((offs (fun-insts-offset function
)))
1450 (make-code-segment code offs
(- max-offset offs
))))
1451 (nreverse segments
)))))))
1453 ;;; Return a list of the segments of memory containing machine code
1454 ;;; instructions for the code-component CODE. If START-OFFSET and/or
1455 ;;; LENGTH is supplied, only that part of the code-segment is used
1456 ;;; (but these are constrained to lie within the code-segment).
1457 (defun get-code-segments (code
1460 (length (%code-code-size code
)))
1461 (declare (type code-component code
)
1462 (type offset start-offset
)
1463 (type disassem-length length
))
1464 (let ((segments nil
))
1465 (when (sb!c
::compiled-debug-info-p
(%code-debug-info code
))
1466 (let ((fun-map (code-fun-map code
))
1467 (sfcache (make-source-form-cache)))
1468 (let ((last-offset 0)
1469 (last-debug-fun nil
))
1470 (flet ((add-seg (offs len df
)
1471 (let* ((restricted-offs
1472 (min (max start-offset offs
)
1473 (+ start-offset length
)))
1475 (- (min (max start-offset
(+ offs len
))
1476 (+ start-offset length
))
1478 (when (> restricted-len
0)
1479 (push (make-code-segment code
1480 restricted-offs restricted-len
1482 :source-form-cache sfcache
)
1484 (dotimes (fun-map-index (length fun-map
))
1485 (let ((fun-map-entry (aref fun-map fun-map-index
)))
1486 (etypecase fun-map-entry
1488 (add-seg last-offset
(- fun-map-entry last-offset
)
1490 (setf last-debug-fun nil
)
1491 (setf last-offset fun-map-entry
))
1492 (sb!c
::compiled-debug-fun
1493 (setf last-debug-fun
1494 (sb!di
::make-compiled-debug-fun fun-map-entry
1496 (when last-debug-fun
1497 (add-seg last-offset
1498 (- (%code-code-size code
) last-offset
)
1499 last-debug-fun
))))))
1501 (list (make-code-segment code start-offset length
))
1502 (nreverse segments
))))
1504 ;;; Compute labels for all the memory segments in SEGLIST and adds
1505 ;;; them to DSTATE. It's important to call this function with all the
1506 ;;; segments you're interested in, so that it can find references from
1508 (defun label-segments (seglist dstate
)
1509 (declare (type list seglist
)
1510 (type disassem-state dstate
))
1511 (dolist (seg seglist
)
1512 (add-segment-labels seg dstate
))
1513 ;; Now remove any labels that don't point anywhere in the segments
1515 (setf (dstate-labels dstate
)
1516 (remove-if (lambda (lab)
1519 (let ((start (seg-virtual-location seg
)))
1522 (+ start
(seg-length seg
)))))
1524 (dstate-labels dstate
))))
1526 ;;; Disassemble the machine code instructions in SEGMENT to STREAM.
1527 (defun disassemble-segment (segment stream dstate
)
1528 (declare (type segment segment
)
1529 (type stream stream
)
1530 (type disassem-state dstate
))
1531 (let ((*print-pretty
* nil
)) ; otherwise the pp conses hugely
1532 (number-labels dstate
)
1533 (map-segment-instructions
1534 (lambda (chunk inst
)
1535 (declare (type dchunk chunk
) (type instruction inst
))
1536 (awhen (inst-printer inst
)
1537 (funcall it chunk inst stream dstate
)))
1542 ;;; Disassemble the machine code instructions in each memory segment
1543 ;;; in SEGMENTS in turn to STREAM.
1544 (defun disassemble-segments (segments stream dstate
)
1545 (declare (type list segments
)
1546 (type stream stream
)
1547 (type disassem-state dstate
))
1548 (unless (null segments
)
1549 (let ((n-segments (length segments
))
1550 (first (car segments
))
1551 (last (car (last segments
))))
1552 ;; One origin per segment is printed. As with the per-line display,
1553 ;; the segment is thought of as immovable for rendering of addresses,
1554 ;; though in fact the disassembler transiently allows movement.
1555 (format stream
"~&; Size: ~a bytes. Origin: #x~x~@[ (segment 1 of ~D)~]"
1556 (reduce #'+ segments
:key
#'seg-length
)
1557 (seg-virtual-location first
)
1558 (if (> n-segments
1) n-segments
))
1559 (set-location-printing-range dstate
1560 (seg-virtual-location first
)
1561 (- (+ (seg-virtual-location last
)
1563 (seg-virtual-location first
)))
1564 (setf (dstate-output-state dstate
) :beginning
)
1566 (dolist (seg segments
)
1567 (when (> (incf i
) 1)
1568 (format stream
"~&; Origin #x~x (segment ~D of ~D)"
1569 (seg-virtual-location seg
) i n-segments
))
1570 (disassemble-segment seg stream dstate
))))))
1573 ;;;; top level functions
1575 ;;; Disassemble the machine code instructions for FUNCTION.
1576 (defun disassemble-fun (fun &key
1577 (stream *standard-output
*)
1579 (declare (type compiled-function fun
)
1580 (type stream stream
)
1581 (type (member t nil
) use-labels
))
1582 (let* ((dstate (make-dstate))
1583 (segments (get-fun-segments fun
)))
1585 (label-segments segments dstate
))
1586 (disassemble-segments segments stream dstate
)))
1588 (defun valid-extended-function-designators-for-disassemble-p (thing)
1590 ((satisfies legal-fun-name-p
)
1591 (compiled-funs-or-lose (fdefinition thing
) thing
))
1592 (sb!pcl
::%method-function
1593 ;; in a %METHOD-FUNCTION, the user code is in the fast function, so
1594 ;; we to disassemble both.
1595 ;; FIXME: interpreted methods need to be compiled as above.
1596 (list thing
(sb!pcl
::%method-function-fast-function thing
)))
1597 ((or (cons (eql lambda
))
1598 #!+sb-fasteval sb
!interpreter
:interpreted-function
1599 #!+sb-eval sb
!eval
:interpreted-function
)
1600 (compile nil thing
))
1604 (defun compiled-funs-or-lose (thing &optional
(name thing
))
1605 (let ((funs (valid-extended-function-designators-for-disassemble-p thing
)))
1608 (error 'simple-type-error
1610 :expected-type
'(satisfies valid-extended-function-designators-for-disassemble-p
)
1611 :format-control
"Can't make a compiled function from ~S"
1612 :format-arguments
(list name
)))))
1614 (defun disassemble (object &key
1615 (stream *standard-output
*)
1617 "Disassemble the compiled code associated with OBJECT, which can be a
1618 function, a lambda expression, or a symbol with a function definition. If
1619 it is not already compiled, the compiler is called to produce something to
1621 (declare (type (or function symbol cons
) object
)
1622 (type (or (member t
) stream
) stream
)
1623 (type (member t nil
) use-labels
))
1624 (flet ((disassemble1 (fun)
1625 (format stream
"~&; disassembly for ~S" (%fun-name fun
))
1626 (disassemble-fun fun
1628 :use-labels use-labels
)))
1629 (mapc #'disassemble1
(ensure-list (compiled-funs-or-lose object
))))
1632 ;;; Disassembles the given area of memory starting at ADDRESS and
1633 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
1634 ;;; could move during a GC, you'd better disable it around the call to
1636 (defun disassemble-memory (address
1639 (stream *standard-output
*)
1642 (declare (type (or address system-area-pointer
) address
)
1643 (type disassem-length length
)
1644 (type stream stream
)
1645 (type (or null code-component
) code-component
)
1646 (type (member t nil
) use-labels
))
1648 (if (system-area-pointer-p address
)
1651 (dstate (make-dstate))
1657 (code-instructions code-component
)))))
1658 (when (or (< code-offs
0)
1659 (> code-offs
(%code-code-size code-component
)))
1660 (error "address ~X not in the code component ~S"
1661 address code-component
))
1662 (get-code-segments code-component code-offs length
))
1663 (list (make-memory-segment address length
)))))
1665 (label-segments segments dstate
))
1666 (disassemble-segments segments stream dstate
)))
1668 ;;; Disassemble the machine code instructions associated with
1669 ;;; CODE-COMPONENT (this may include multiple entry points).
1670 (defun disassemble-code-component (code-component &key
1671 (stream *standard-output
*)
1673 (declare (type (or code-component compiled-function
)
1675 (type stream stream
)
1676 (type (member t nil
) use-labels
))
1677 (let* ((code-component
1678 (if (functionp code-component
)
1679 (fun-code-header code-component
)
1681 (dstate (make-dstate))
1682 (segments (get-code-segments code-component
)))
1684 (label-segments segments dstate
))
1685 (disassemble-segments segments stream dstate
)))
1687 ;;;; code to disassemble assembler segments
1689 (defun assem-segment-to-disassem-segment (assem-segment)
1690 (declare (type sb
!assem
:segment assem-segment
))
1691 (let ((contents (sb!assem
:segment-contents-as-vector assem-segment
)))
1692 (make-vector-segment contents
0 (length contents
) :virtual-location
0)))
1694 ;;; Disassemble the machine code instructions associated with
1695 ;;; ASSEM-SEGMENT (of type assem:segment).
1696 (defun disassemble-assem-segment (assem-segment stream
)
1697 (declare (type sb
!assem
:segment assem-segment
)
1698 (type stream stream
))
1699 (let ((dstate (make-dstate))
1701 (list (assem-segment-to-disassem-segment assem-segment
))))
1702 (label-segments disassem-segments dstate
)
1703 (disassemble-segments disassem-segments stream dstate
)))
1705 ;;; routines to find things in the Lisp environment
1707 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
1708 ;;; in a symbol object that we know about
1709 (defparameter *grokked-symbol-slots
*
1710 (sort (copy-list `((,sb
!vm
:symbol-value-slot . symbol-value
)
1711 (,sb
!vm
:symbol-info-slot . symbol-info
)
1712 (,sb
!vm
:symbol-name-slot . symbol-name
)
1713 (,sb
!vm
:symbol-package-slot . symbol-package
)))
1717 ;;; Given ADDRESS, try and figure out if which slot of which symbol is
1718 ;;; being referred to. Of course we can just give up, so it's not a
1719 ;;; big deal... Return two values, the symbol and the name of the
1720 ;;; access function of the slot.
1721 (defun grok-symbol-slot-ref (address)
1722 (declare (type address address
))
1723 (if (not (aligned-p address sb
!vm
:n-word-bytes
))
1725 (do ((slots-tail *grokked-symbol-slots
* (cdr slots-tail
)))
1728 (let* ((field (car slots-tail
))
1729 (slot-offset (words-to-bytes (car field
)))
1730 (maybe-symbol-addr (- address slot-offset
))
1732 (make-lisp-obj (+ maybe-symbol-addr sb
!vm
:other-pointer-lowtag
)
1734 (when (symbolp maybe-symbol
)
1735 (return (values maybe-symbol
(cdr field
))))))))
1737 ;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
1738 ;;; which symbol is being referred to. Of course we can just give up,
1739 ;;; so it's not a big deal... Return two values, the symbol and the
1740 ;;; access function.
1741 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1742 (declare (type offset byte-offset
))
1743 (grok-symbol-slot-ref (+ sb
!vm
::nil-value byte-offset
)))
1745 ;;; Return the Lisp object located BYTE-OFFSET from NIL.
1746 (defun get-nil-indexed-object (byte-offset)
1747 (declare (type offset byte-offset
))
1748 (make-lisp-obj (+ sb
!vm
::nil-value byte-offset
)))
1750 ;;; Return two values; the Lisp object located at BYTE-OFFSET in the
1751 ;;; constant area of the code-object in the current segment and T, or
1752 ;;; NIL and NIL if there is no code-object in the current segment.
1753 (defun get-code-constant (byte-offset dstate
)
1754 (declare (type offset byte-offset
)
1755 (type disassem-state dstate
))
1756 (let ((code (seg-code (dstate-segment dstate
))))
1758 (values (code-header-ref code
1759 (ash (+ byte-offset sb
!vm
:other-pointer-lowtag
)
1760 (- sb
!vm
:word-shift
)))
1764 (defun get-code-constant-absolute (addr dstate
&optional width
)
1765 (declare (type address addr
))
1766 (declare (type disassem-state dstate
))
1767 (declare (ignore width
))
1768 (let ((code (seg-code (dstate-segment dstate
))))
1770 (return-from get-code-constant-absolute
(values nil nil
)))
1771 ;; This WITHOUT-GCING, while not technically broken, is extremely deceptive
1772 ;; because if it is really needed, then this function has a broken API.
1773 ;; Since ADDR comes in as absolute, CODE must not move between the caller's
1774 ;; computation and the comparison below. But we're already in WITHOUT-GCING
1775 ;; in MAP-SEGMENT-INSTRUCTIONS, so, who cares, I guess?
1777 (let* ((n-header-bytes (* (code-header-words code
) sb
!vm
:n-word-bytes
))
1778 (header-addr (- (get-lisp-obj-address code
)
1779 sb
!vm
:other-pointer-lowtag
))
1780 (code-start (+ header-addr n-header-bytes
)))
1781 (cond ((< header-addr addr code-start
)
1782 (values (sap-ref-lispobj (int-sap addr
) 0) t
))
1784 (values nil nil
)))))))
1786 (defvar *assembler-routines-by-addr
* nil
)
1788 ;;; Build an address-name hash-table from the name-address hash
1789 (defun invert-address-hash (htable &optional
(addr-hash (make-hash-table)))
1790 (maphash (lambda (name address
)
1791 (setf (gethash address addr-hash
) name
))
1795 ;;; Return the name of the primitive Lisp assembler routine or foreign
1796 ;;; symbol located at ADDRESS, or NIL if there isn't one.
1797 (defun find-assembler-routine (address)
1798 (declare (type address address
))
1799 (when (null *assembler-routines-by-addr
*)
1800 (setf *assembler-routines-by-addr
*
1801 (invert-address-hash sb
!fasl
:*assembler-routines
*))
1803 (setf *assembler-routines-by-addr
*
1804 (invert-address-hash *static-foreign-symbols
*
1805 *assembler-routines-by-addr
*))
1806 (loop for name across sb
!vm
:+static-fdefns
+
1808 #!+immobile-code
(sb!vm
::function-raw-address name
)
1809 #!-immobile-code
(+ sb
!vm
::nil-value
(sb!vm
::static-fun-offset name
))
1810 do
(setf (gethash address
*assembler-routines-by-addr
*) name
))
1811 ;; Not really a routine, but it uses the similar logic for annotations
1813 (setf (gethash sb
!vm
::gc-safepoint-page-addr
*assembler-routines-by-addr
*)
1815 (gethash address
*assembler-routines-by-addr
*))
1817 ;;;; some handy function for machine-dependent code to use...
1819 (defun sap-ref-int (sap offset length byte-order
)
1820 (declare (type system-area-pointer sap
)
1821 (type (member 1 2 4 8) length
)
1822 (type (member :little-endian
:big-endian
) byte-order
))
1823 (if (or (eq length
1)
1824 (and (eq byte-order
#!+big-endian
:big-endian
#!+little-endian
:little-endian
)
1825 #!-
(or arm arm64 ppc x86 x86-64
) ; unaligned loads are ok for these
1826 (not (logtest (1- length
) (sap-int (sap+ sap offset
))))))
1827 (funcall (case length
; native byte order and acceptable alignment
1831 (t #'sap-ref-8
)) sap offset
)
1832 (binding* (((offset increment
)
1833 (cond ((eq byte-order
:big-endian
) (values offset
+1))
1834 (t (values (+ offset
(1- length
)) -
1))))
1836 (dotimes (i length val
)
1838 (setq val
(logior (ash val
8) (sap-ref-8 sap offset
)))
1839 (incf offset increment
)))))
1841 (defun read-suffix (length dstate
)
1842 (declare (type (member 8 16 32 64) length
)
1843 (type disassem-state dstate
)
1844 (optimize (speed 3) (safety 0)))
1845 (let ((length (ecase length
(8 1) (16 2) (32 4) (64 8))))
1846 (declare (type (unsigned-byte 4) length
))
1848 (sap-ref-int (dstate-segment-sap dstate
)
1849 (dstate-next-offs dstate
)
1851 (dstate-byte-order dstate
))
1852 (incf (dstate-next-offs dstate
) length
))))
1854 ;;;; optional routines to make notes about code
1856 ;;; Store NOTE (which can be either a string or a function with a
1857 ;;; single stream argument) to be printed as an end-of-line comment
1858 ;;; after the current instruction is disassembled.
1859 (defun note (note dstate
)
1860 (declare (type (or string function
) note
)
1861 (type disassem-state dstate
))
1862 (setf (dstate-notes dstate
) (nconc (dstate-notes dstate
) (list note
))))
1864 (defun prin1-short (thing stream
)
1865 (with-print-restrictions
1866 (prin1 thing stream
)))
1868 (defun prin1-quoted-short (thing stream
)
1869 (if (self-evaluating-p thing
)
1870 (prin1-short thing stream
)
1871 (prin1-short `',thing stream
)))
1873 ;;; Store a note about the lisp constant located BYTE-OFFSET bytes
1874 ;;; from the current code-component, to be printed as an end-of-line
1875 ;;; comment after the current instruction is disassembled.
1876 (defun note-code-constant (byte-offset dstate
)
1877 (declare (type offset byte-offset
)
1878 (type disassem-state dstate
))
1879 (multiple-value-bind (const valid
)
1880 (get-code-constant byte-offset dstate
)
1882 (note (lambda (stream)
1883 (prin1-quoted-short const stream
))
1887 ;;; Store a note about the lisp constant located at ADDR in the
1888 ;;; current code-component, to be printed as an end-of-line comment
1889 ;;; after the current instruction is disassembled.
1890 (defun note-code-constant-absolute (addr dstate
&optional width
)
1891 (declare (type address addr
)
1892 (type disassem-state dstate
))
1893 (multiple-value-bind (const valid
)
1894 (get-code-constant-absolute addr dstate width
)
1896 (note (lambda (stream)
1897 (prin1-quoted-short const stream
))
1899 (values const valid
)))
1901 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1902 ;;; constant NIL is a valid slot in a symbol, store a note describing
1903 ;;; which symbol and slot, to be printed as an end-of-line comment
1904 ;;; after the current instruction is disassembled. Returns non-NIL iff
1905 ;;; a note was recorded.
1906 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate
)
1907 (declare (type offset nil-byte-offset
)
1908 (type disassem-state dstate
))
1909 (multiple-value-bind (symbol access-fun
)
1910 (grok-nil-indexed-symbol-slot-ref nil-byte-offset
)
1912 (note (lambda (stream)
1913 (prin1 (if (eq access-fun
'symbol-value
)
1915 `(,access-fun
',symbol
))
1920 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1921 ;;; constant NIL is a valid lisp object, store a note describing which
1922 ;;; symbol and slot, to be printed as an end-of-line comment after the
1923 ;;; current instruction is disassembled. Returns non-NIL iff a note
1925 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate
)
1926 (declare (type offset nil-byte-offset
)
1927 (type disassem-state dstate
))
1928 (let ((obj (get-nil-indexed-object nil-byte-offset
)))
1929 (note (lambda (stream)
1930 (prin1-quoted-short obj stream
))
1934 ;;; If ADDRESS is the address of a primitive assembler routine or
1935 ;;; foreign symbol, store a note describing which one, to be printed
1936 ;;; as an end-of-line comment after the current instruction is
1937 ;;; disassembled. Returns non-NIL iff a note was recorded. If
1938 ;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made.
1939 (defun maybe-note-assembler-routine (address note-address-p dstate
)
1940 (declare (type disassem-state dstate
))
1941 (unless (typep address
'address
)
1942 (return-from maybe-note-assembler-routine nil
))
1944 (find-assembler-routine address
)
1946 (sap-foreign-symbol (int-sap address
)))))
1948 (note (lambda (stream)
1950 (format stream
"#x~8,'0x: ~a" address name
)
1951 (princ name stream
)))
1955 ;;; If there's a valid mapping from OFFSET in the storage class
1956 ;;; SC-NAME to a source variable, make a note of the source-variable
1957 ;;; name, to be printed as an end-of-line comment after the current
1958 ;;; instruction is disassembled. Returns non-NIL iff a note was
1960 (defun maybe-note-single-storage-ref (offset sc-name dstate
)
1961 (declare (type offset offset
)
1962 (type symbol sc-name
)
1963 (type disassem-state dstate
))
1964 (let ((storage-location
1965 (find-valid-storage-location offset sc-name dstate
)))
1966 (when storage-location
1967 (note (lambda (stream)
1968 (princ (sb!di
:debug-var-symbol
1969 (aref (storage-info-debug-vars
1970 (seg-storage-info (dstate-segment dstate
)))
1976 ;;; If there's a valid mapping from OFFSET in the storage-base called
1977 ;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with
1978 ;;; the source-variable name, to be printed as an end-of-line comment
1979 ;;; after the current instruction is disassembled. Returns non-NIL iff
1980 ;;; a note was recorded.
1981 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate
)
1982 (declare (type offset offset
)
1983 (type symbol sb-name
)
1984 (type (or symbol string
) assoc-with
)
1985 (type disassem-state dstate
))
1986 (let ((storage-location
1987 (find-valid-storage-location offset sb-name dstate
)))
1988 (when storage-location
1989 (note (lambda (stream)
1990 (format stream
"~A = ~S"
1992 (sb!di
:debug-var-symbol
1993 (aref (dstate-debug-vars dstate
)
1994 storage-location
))))
1998 (defun maybe-note-static-symbol (address dstate
)
1999 (dovector (symbol sb
!vm
:+static-symbols
+)
2000 (when (= (get-lisp-obj-address symbol
) address
)
2001 (return (note (lambda (s) (prin1 symbol s
)) dstate
))))
2002 ;; Guess whether 'address' is an immobile-space symbol by looking at
2003 ;; code header constants. If it matches any constant, assume that it
2004 ;; is a use of the constant. This has false positives of course,
2005 ;; as does MAYBE-NOTE-STATIC-SYMBOL in general - any random immediate
2006 ;; used in an unboxed context, such as an ADD instruction,
2007 ;; might be seen as an address.
2009 (unless (eql address
0)
2010 (let ((code (seg-code (dstate-segment dstate
))))
2012 (loop for i downfrom
(1- (code-header-words code
)) to sb
!vm
:code-constants-offset
2013 for const
= (code-header-ref code i
)
2014 when
(eql (get-lisp-obj-address const
) address
)
2015 return
(note (lambda (s) (prin1-quoted-short const s
)) dstate
))))))
2017 (defun get-internal-error-name (errnum)
2018 (cadr (svref sb
!c
:+backend-internal-errors
+ errnum
)))
2020 (defun get-sc-name (sc-offs)
2021 (sb!c
:location-print-name
2022 ;; FIXME: This seems like an awful lot of computation just to get a name.
2023 ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
2025 (sb!c
:make-random-tn
:kind
:normal
2026 :sc
(svref sb
!c
:*backend-sc-numbers
*
2027 (sb!c
:sc-offset-scn sc-offs
))
2028 :offset
(sb!c
:sc-offset-offset sc-offs
))))
2030 ;;; When called from an error break instruction's :DISASSEM-CONTROL (or
2031 ;;; :DISASSEM-PRINTER) function, will correctly deal with printing the
2032 ;;; arguments to the break.
2034 ;;; ERROR-PARSE-FUN should be a function that accepts:
2035 ;;; 1) a SYSTEM-AREA-POINTER
2036 ;;; 2) a BYTE-OFFSET from the SAP to begin at
2037 ;;; It should read information from the SAP starting at BYTE-OFFSET, and
2038 ;;; return four values:
2039 ;;; 1) the error number
2040 ;;; 2) the total length, in bytes, of the information
2041 ;;; 3) a list of SC-OFFSETs of the locations of the error parameters
2042 ;;; 4) a list of the length (as read from the SAP), in bytes, of each
2043 ;;; of the return values.
2044 (defun handle-break-args (error-parse-fun stream dstate
)
2045 (declare (type function error-parse-fun
)
2046 (type (or null stream
) stream
)
2047 (type disassem-state dstate
))
2048 (multiple-value-bind (errnum adjust sc-offsets lengths
)
2049 (funcall error-parse-fun
2050 (dstate-segment-sap dstate
)
2051 (dstate-next-offs dstate
)
2054 (setf (dstate-cur-offs dstate
)
2055 (dstate-next-offs dstate
))
2056 (flet ((emit-err-arg ()
2057 (let ((num (pop lengths
)))
2058 (print-notes-and-newline stream dstate
)
2059 (print-current-address stream dstate
)
2060 (print-inst num stream dstate
)
2061 (print-bytes num stream dstate
)
2062 (incf (dstate-cur-offs dstate
) num
)))
2065 (note note dstate
))))
2066 ;; ARM64 encodes the error number in BRK instruction itself
2069 (emit-note (symbol-name (get-internal-error-name errnum
)))
2070 (dolist (sc-offs sc-offsets
)
2072 (if (= (sb!c
:sc-offset-scn sc-offs
)
2073 sb
!vm
:constant-sc-number
)
2074 (note-code-constant (* (1- (sb!c
:sc-offset-offset sc-offs
))
2077 (emit-note (get-sc-name sc-offs
))))))
2078 (incf (dstate-next-offs dstate
) adjust
)))
2080 ;;; arm64 stores an error-number in the instruction bytes,
2081 ;;; so can't easily share this code.
2082 ;;; But probably we should just add the conditionalization in here.
2084 (defun snarf-error-junk (sap offset
&optional length-only
)
2085 (let* ((error-number (sap-ref-8 sap offset
))
2086 (length (sb!kernel
::error-length error-number
))
2087 (index (1+ offset
)))
2088 (declare (type system-area-pointer sap
)
2089 (type (unsigned-byte 8) length
))
2091 (loop repeat length do
(sb!c
:sap-read-var-integerf sap index
))
2092 (values 0 (- index offset
) nil nil
))
2094 (collect ((sc-offsets)
2096 (lengths 1) ;; error-number
2097 (loop repeat length do
2098 (let ((old-index index
))
2099 (sc-offsets (sb!c
:sap-read-var-integerf sap index
))
2100 (lengths (- index old-index
))))
2101 (values error-number
2106 ;; A prefilter set is a list of vectors specifying bytes to extract
2107 ;; and a function to call on the extracted value(s).
2108 ;; EQUALP lists of vectors can be coalesced, since they're immutable.
2109 (defun collect-prefiltering-args (args cache
)
2110 (awhen (remove-if-not #'arg-prefilter args
)
2112 (mapcar (lambda (arg &aux
(bytes (arg-fields arg
)))
2113 (coerce (list* (posq arg args
)
2115 (and bytes
(cons (arg-sign-extend-p arg
) bytes
)))
2118 (table (assq :prefilter cache
)))
2119 (or (find repr
(cdr table
) :test
'equalp
)
2120 (car (push repr
(cdr table
)))))))
2122 (defun !unintern-symbols
()
2123 ;; Remove compile-time-only metadata. This preserves compatibility with the
2124 ;; older disassembler macros which wrapped GEN-ARG-TYPE-DEF-FORM and such
2125 ;; in (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE)), which in turn required that
2126 ;; all prefilters, labellers, and printers be defined at cross-compile-time.
2127 ;; A consequence of :LOAD-TOPLEVEL not being there was that was not possible
2128 ;; to add instruction definitions to an image without also recompiling
2129 ;; the backend's "insts" file. It also was not possible to incrementally
2130 ;; recompile and/or use slam.sh because of a bunch of mostly harmless bugs
2131 ;; in the function cache (a/k/a identical-code-folding) logic that was only
2132 ;; guaranteed to do the right thing from a clean compile. Additionally,
2133 ;; you had to use (GET-INST-SPACE :FORCE T) to pick up new definitions.
2134 ;; Given those considerations which made extending a running disassembler
2135 ;; nontrivial, the code-generating code is not so useful after the
2136 ;; initial instruction space is built, so it can all be removed.
2137 ;; But if you need all these macros to exist for some reason,
2138 ;; then define one of the two following features to keep them:
2139 #!+(or sb-fluid sb-retain-assembler-macros
)
2140 (return-from !unintern-symbols nil
)
2142 (do-symbols (symbol sb
!assem
::*backend-instruction-set-package
*)
2143 (remf (symbol-plist symbol
) 'arg-type
)
2144 (remf (symbol-plist symbol
) 'inst-format
))
2146 ;; Get rid of functions that only make sense with metadata available.
2148 %def-arg-type %def-inst-format %gen-arg-forms
2149 all-arg-refs-relevant-p arg-or-lose arg-position arg-value-form
2150 collect-labelish-operands collect-prefiltering-args
2151 compare-fields-form compile-inst-printer compile-print
2152 compile-printer-body compile-printer-list compile-test
2153 correct-dchunk-bytespec-for-endianness
2154 define-arg-type define-instruction-format
2155 find-first-field-name find-printer-fun format-or-lose
2156 gen-arg-forms make-arg-temp-bindings make-funstate massage-arg
2157 maybe-listify modify-arg pd-error pick-printer-choice
2158 preprocess-chooses preprocess-conditionals preprocess-printer
2159 preprocess-test sharing-cons sharing-mapcar
))