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 bytes-to-words
))
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 ;;; Convert a byte-offset NUM to a word-offset.
246 (defun bytes-to-words (num)
247 (declare (type offset num
))
248 (ash num
(- sb
!vm
:word-shift
)))
250 (defconstant lra-size
(words-to-bytes 1))
252 (defstruct (offs-hook (:copier nil
))
253 (offset 0 :type offset
)
254 (fun (missing-arg) :type function
)
255 (before-address nil
:type
(member t nil
)))
257 (defstruct (segment (:conc-name seg-
)
258 (:constructor %make-segment
)
260 (sap-maker (missing-arg)
261 :type
(function () sb
!sys
:system-area-pointer
))
262 ;; Length in bytes of the range of memory covered by this segment.
263 (length 0 :type disassem-length
)
264 ;; Length of the memory range excluding any trailing untagged data.
265 ;; Defaults to 'length' but could be shorter.
266 (opcodes-length 0 :type disassem-length
)
267 (virtual-location 0 :type address
)
268 (storage-info nil
:type
(or null storage-info
))
269 (code nil
:type
(or null sb
!kernel
:code-component
))
270 (unboxed-data-range nil
:type
(or null
(cons fixnum fixnum
)))
271 (hooks nil
:type list
))
272 (def!method print-object
((seg segment
) stream
)
273 (print-unreadable-object (seg stream
:type t
)
274 (let ((addr (sb!sys
:sap-int
(funcall (seg-sap-maker seg
)))))
275 (format stream
"#X~X..~X[~W]~:[ (#X~X)~;~*~]~@[ in ~S~]"
276 addr
(+ addr
(seg-length seg
)) (seg-length seg
)
277 (= (seg-virtual-location seg
) addr
)
278 (seg-virtual-location seg
)
283 (defun fun-self (fun)
284 (declare (type compiled-function fun
))
285 (sb!kernel
:%simple-fun-self
(sb!kernel
:%fun-fun fun
)))
287 (defun fun-code (fun)
288 (declare (type compiled-function fun
))
289 (sb!kernel
:fun-code-header
(fun-self fun
)))
291 (defun fun-next (fun)
292 (declare (type compiled-function fun
))
293 (sb!kernel
:%simple-fun-next
(sb!kernel
:%fun-fun fun
)))
295 (defun fun-address (fun)
296 (declare (type compiled-function fun
))
297 (- (sb!kernel
:get-lisp-obj-address
(sb!kernel
:%fun-fun fun
)) sb
!vm
:fun-pointer-lowtag
))
299 ;;; the offset of FUNCTION from the start of its code-component's
301 (defun fun-insts-offset (function)
302 (declare (type compiled-function function
))
303 (- (fun-address function
)
304 (sb!sys
:sap-int
(sb!kernel
:code-instructions
(fun-code function
)))))
306 ;;; the offset of FUNCTION from the start of its code-component
307 (defun fun-offset (function)
308 (declare (type compiled-function function
))
309 (words-to-bytes (sb!kernel
:get-closure-length function
)))
311 ;;;; operations on code-components (which hold the instructions for
312 ;;;; one or more functions)
314 ;;; Return the length of the instruction area in CODE-COMPONENT.
315 (defun code-inst-area-length (code-component)
316 (declare (type sb
!kernel
:code-component code-component
))
317 (sb!kernel
:%code-code-size code-component
))
319 ;;; Return the address of the instruction area in CODE-COMPONENT.
320 (defun code-inst-area-address (code-component)
321 (declare (type sb
!kernel
:code-component code-component
))
322 (sb!sys
:sap-int
(sb!kernel
:code-instructions code-component
)))
324 (defun segment-offs-to-code-offs (offset segment
)
325 (sb!sys
:without-gcing
326 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
328 (logandc1 sb
!vm
:lowtag-mask
329 (sb!kernel
:get-lisp-obj-address
(seg-code segment
))))
330 (addr (+ offset seg-base-addr
)))
331 (declare (type address seg-base-addr code-addr addr
))
332 (- addr code-addr
))))
334 (defun code-offs-to-segment-offs (offset segment
)
335 (sb!sys
:without-gcing
336 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
338 (logandc1 sb
!vm
:lowtag-mask
339 (sb!kernel
:get-lisp-obj-address
(seg-code segment
))))
340 (addr (+ offset code-addr
)))
341 (declare (type address seg-base-addr code-addr addr
))
342 (- addr seg-base-addr
))))
344 (defun code-insts-offs-to-segment-offs (offset segment
)
345 (sb!sys
:without-gcing
346 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
348 (sb!sys
:sap-int
(sb!kernel
:code-instructions
(seg-code segment
))))
349 (addr (+ offset code-insts-addr
)))
350 (declare (type address seg-base-addr code-insts-addr addr
))
351 (- addr seg-base-addr
))))
353 (defun lra-hook (chunk stream dstate
)
354 (declare (type dchunk chunk
)
356 (type (or null stream
) stream
)
357 (type disassem-state dstate
))
358 (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate
))
359 (dstate-cur-offs dstate
))
360 (* 2 sb
!vm
:n-word-bytes
))
362 (= (sb!sys
:sap-ref-8
(dstate-segment-sap dstate
)
363 (if (eq (dstate-byte-order dstate
)
365 (dstate-cur-offs dstate
)
366 (+ (dstate-cur-offs dstate
)
368 sb
!vm
:return-pc-header-widetag
))
369 (unless (null stream
)
370 (note "possible LRA header" dstate
)))
373 ;;; Print the fun-header (entry-point) pseudo-instruction at the
374 ;;; current location in DSTATE to STREAM.
375 (defun fun-header-hook (stream dstate
)
376 (declare (type (or null stream
) stream
)
377 (type disassem-state dstate
))
378 (unless (null stream
)
379 (let* ((seg (dstate-segment dstate
))
380 (code (seg-code seg
))
383 (segment-offs-to-code-offs (dstate-cur-offs dstate
) seg
)))
385 (sb!kernel
:code-header-ref code
387 sb
!vm
:simple-fun-name-slot
)))
389 (sb!kernel
:code-header-ref code
391 sb
!vm
:simple-fun-arglist-slot
)))
393 (sb!kernel
:code-header-ref code
395 sb
!vm
:simple-fun-type-slot
))))
396 ;; if the function's name conveys its args, don't show ARGS too
397 (format stream
".~A ~S~:[~:A~;~]" 'entry name
398 (and (typep name
'(cons (eql lambda
) (cons list
)))
399 (equal args
(second name
)))
401 (note (lambda (stream)
402 (format stream
"~:S" type
)) ; use format to print NIL as ()
404 (incf (dstate-next-offs dstate
)
405 (words-to-bytes sb
!vm
:simple-fun-code-offset
)))
407 (defun alignment-hook (chunk stream dstate
)
408 (declare (type dchunk chunk
)
410 (type (or null stream
) stream
)
411 (type disassem-state dstate
))
413 (+ (seg-virtual-location (dstate-segment dstate
))
414 (dstate-cur-offs dstate
)))
415 (alignment (dstate-alignment dstate
)))
416 (unless (aligned-p location alignment
)
418 (format stream
"~A~Vt~W~%" '.align
419 (dstate-argument-column dstate
)
421 (incf (dstate-next-offs dstate
)
422 (- (align location alignment
) location
)))
425 (defun rewind-current-segment (dstate segment
)
426 (declare (type disassem-state dstate
)
427 (type segment segment
))
428 (setf (dstate-segment dstate
) segment
)
429 (setf (dstate-inst-properties dstate
) nil
)
430 (setf (dstate-cur-offs-hooks dstate
)
431 (stable-sort (nreverse (copy-list (seg-hooks segment
)))
433 (or (< (offs-hook-offset oh1
) (offs-hook-offset oh2
))
434 (and (= (offs-hook-offset oh1
)
435 (offs-hook-offset oh2
))
436 (offs-hook-before-address oh1
)
437 (not (offs-hook-before-address oh2
)))))))
438 (setf (dstate-cur-offs dstate
) 0)
439 (setf (dstate-cur-labels dstate
) (dstate-labels dstate
)))
441 (defun call-offs-hooks (before-address stream dstate
)
442 (declare (type (or null stream
) stream
)
443 (type disassem-state dstate
))
444 (let ((cur-offs (dstate-cur-offs dstate
)))
445 (setf (dstate-next-offs dstate
) cur-offs
)
447 (let ((next-hook (car (dstate-cur-offs-hooks dstate
))))
448 (when (null next-hook
)
450 (let ((hook-offs (offs-hook-offset next-hook
)))
451 (when (or (> hook-offs cur-offs
)
452 (and (= hook-offs cur-offs
)
454 (not (offs-hook-before-address next-hook
))))
456 (unless (< hook-offs cur-offs
)
457 (funcall (offs-hook-fun next-hook
) stream dstate
))
458 (pop (dstate-cur-offs-hooks dstate
))
459 (unless (= (dstate-next-offs dstate
) cur-offs
)
462 (defun call-fun-hooks (chunk stream dstate
)
463 (let ((hooks (dstate-fun-hooks dstate
))
464 (cur-offs (dstate-cur-offs dstate
)))
465 (setf (dstate-next-offs dstate
) cur-offs
)
466 (dolist (hook hooks nil
)
467 (let ((prefix-p (funcall hook chunk stream dstate
)))
468 (unless (= (dstate-next-offs dstate
) cur-offs
)
469 (return prefix-p
))))))
471 ;;; Print enough spaces to fill the column used for instruction bytes,
472 ;;; assuming that N-BYTES many instruction bytes have already been
473 ;;; printed in it, then print an additional space as separator to the
475 (defun pad-inst-column (stream n-bytes
)
476 (declare (type stream stream
)
477 (type text-width n-bytes
))
478 (when (> *disassem-inst-column-width
* 0)
479 (dotimes (i (- *disassem-inst-column-width
* (* 2 n-bytes
)))
480 (write-char #\space stream
))
481 (write-char #\space stream
)))
483 (defun handle-bogus-instruction (stream dstate prefix-len
)
484 (let ((alignment (dstate-alignment dstate
)))
485 (unless (null stream
)
486 (multiple-value-bind (words bytes
)
487 (truncate alignment sb
!vm
:n-word-bytes
)
489 (print-inst (* words sb
!vm
:n-word-bytes
) stream dstate
490 :trailing-space nil
))
492 (print-inst bytes stream dstate
:trailing-space nil
)))
493 (pad-inst-column stream
(+ prefix-len alignment
))
494 (decf (dstate-cur-offs dstate
) prefix-len
)
495 (print-bytes (+ prefix-len alignment
) stream dstate
))
496 (incf (dstate-next-offs dstate
) alignment
)))
498 ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
499 ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE.
500 ;;; Additionally, unless STREAM is NIL, several items are output to it:
501 ;;; things printed from several hooks, for example labels, and instruction
502 ;;; bytes before FUNCTION is called, notes and a newline afterwards.
503 ;;; Instructions having an INST-PRINTER of NIL are treated as prefix
504 ;;; instructions which makes them print on the same line as the following
505 ;;; instruction, outputting their INST-PRINT-NAME (unless that is NIL)
506 ;;; before FUNCTION is called for the following instruction.
507 (defun map-segment-instructions (function segment dstate
&optional stream
)
508 (declare (type function function
)
509 (type segment segment
)
510 (type disassem-state dstate
)
511 (type (or null stream
) stream
))
513 (let ((ispace (get-inst-space))
515 ;; If the segment starts with unboxed data,
516 ;; dump some number of words using the .WORD pseudo-ops.
517 (if (and (seg-unboxed-data-range segment
)
518 (= (segment-offs-to-code-offs 0 segment
)
519 (car (seg-unboxed-data-range segment
))))
520 (code-offs-to-segment-offs (cdr (seg-unboxed-data-range segment
))
523 (prefix-p nil
) ; just processed a prefix inst
524 (prefix-len 0) ; sum of lengths of any prefix instruction(s)
525 (prefix-print-names nil
)) ; reverse list of prefixes seen
527 (rewind-current-segment dstate segment
)
530 (when (>= (dstate-cur-offs dstate
)
531 (seg-opcodes-length (dstate-segment dstate
)))
533 (when (and stream
(> prefix-len
0))
534 (pad-inst-column stream prefix-len
)
535 (decf (dstate-cur-offs dstate
) prefix-len
)
536 (print-bytes prefix-len stream dstate
)
537 (incf (dstate-cur-offs dstate
) prefix-len
))
540 (setf (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
542 (call-offs-hooks t stream dstate
)
543 (unless (or prefix-p
(null stream
))
544 (print-current-address stream dstate
))
545 (call-offs-hooks nil stream dstate
)
547 (when (< (dstate-cur-offs dstate
) data-end-offset
)
548 (sb!sys
:without-gcing
549 (format stream
"~A #x~v,'0x" '.word
550 (* 2 sb
!vm
:n-word-bytes
)
551 (sap-ref-int (funcall (seg-sap-maker segment
))
552 (dstate-cur-offs dstate
)
554 (dstate-byte-order dstate
))))
555 (setf (dstate-next-offs dstate
)
556 (+ (dstate-cur-offs dstate
) sb
!vm
:n-word-bytes
)))
558 (unless (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
559 (sb!sys
:without-gcing
560 (setf (dstate-segment-sap dstate
) (funcall (seg-sap-maker segment
)))
563 (sap-ref-dchunk (dstate-segment-sap dstate
)
564 (dstate-cur-offs dstate
)
565 (dstate-byte-order dstate
)))
566 (fun-prefix-p (call-fun-hooks chunk stream dstate
)))
567 (if (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
568 (setf prefix-p fun-prefix-p
)
569 (let ((inst (find-inst chunk ispace
)))
571 (handle-bogus-instruction stream dstate prefix-len
)
574 (setf (dstate-next-offs dstate
)
575 (+ (dstate-cur-offs dstate
)
577 (let ((orig-next (dstate-next-offs dstate
))
578 (prefilter (inst-prefilter inst
))
579 (control (inst-control inst
)))
580 (print-inst (inst-length inst
) stream dstate
583 (funcall prefilter chunk dstate
))
585 (setf prefix-p
(null (inst-printer inst
)))
588 ;; Print any instruction bytes recognized by
589 ;; the prefilter which calls read-suffix and
590 ;; updates next-offs.
591 (let ((suffix-len (- (dstate-next-offs dstate
)
593 (when (plusp suffix-len
)
594 (print-inst suffix-len stream dstate
595 :offset
(inst-length inst
)
596 :trailing-space nil
))
597 ;; Keep track of the number of bytes
599 (incf prefix-len
(+ (inst-length inst
)
602 (let ((name (inst-print-name inst
)))
604 (push name prefix-print-names
)))
606 ;; PREFIX-LEN includes the length of the
607 ;; current (non-prefix) instruction here.
608 (pad-inst-column stream prefix-len
)
609 (dolist (name (reverse prefix-print-names
))
611 (write-char #\space stream
)))))
613 (funcall function chunk inst
)
616 (funcall control chunk inst stream dstate
))))))))))
618 (setf (dstate-cur-offs dstate
) (dstate-next-offs dstate
))
623 prefix-print-names nil
)
624 (print-notes-and-newline stream dstate
))
625 (setf (dstate-output-state dstate
) nil
))
627 (setf (dstate-inst-properties dstate
) nil
)))))
630 ;;; Make an initial non-printing disassembly pass through DSTATE,
631 ;;; noting any addresses that are referenced by instructions in this
633 (defun add-segment-labels (segment dstate
)
634 ;; add labels at the beginning with a label-number of nil; we'll notice
635 ;; later and fill them in (and sort them)
636 (declare (type disassem-state dstate
))
637 (let ((labels (dstate-labels dstate
)))
638 (map-segment-instructions
640 (declare (type dchunk chunk
) (type instruction inst
))
641 (let ((labeller (inst-labeller inst
)))
643 (setf labels
(funcall labeller chunk labels dstate
)))))
646 (setf (dstate-labels dstate
) labels
)
647 ;; erase any notes that got there by accident
648 (setf (dstate-notes dstate
) nil
)))
650 ;;; If any labels in DSTATE have been added since the last call to
651 ;;; this function, give them label-numbers, enter them in the
652 ;;; hash-table, and make sure the label list is in sorted order.
653 (defun number-labels (dstate)
654 (let ((labels (dstate-labels dstate
)))
655 (when (and labels
(null (cdar labels
)))
656 ;; at least one label left un-numbered
657 (setf labels
(sort labels
#'< :key
#'car
))
659 (label-hash (dstate-label-hash dstate
)))
660 (dolist (label labels
)
661 (when (not (null (cdr label
)))
662 (setf max
(max max
(cdr label
)))))
663 (dolist (label labels
)
664 (when (null (cdr label
))
666 (setf (cdr label
) max
)
667 (setf (gethash (car label
) label-hash
)
668 (format nil
"L~W" max
)))))
669 (setf (dstate-labels dstate
) labels
))))
671 ;;; Get the instruction-space, creating it if necessary.
672 (defun get-inst-space (&key force
)
673 (let ((ispace *disassem-inst-space
*))
674 (when (or force
(null ispace
))
676 (maphash (lambda (name inst-flavs
)
677 (declare (ignore name
))
678 (dolist (flav inst-flavs
)
681 (setf ispace
(build-inst-space insts
)))
682 (setf *disassem-inst-space
* ispace
))
685 ;;;; Add global hooks.
687 (defun add-offs-hook (segment addr hook
)
688 (let ((entry (cons addr hook
)))
689 (if (null (seg-hooks segment
))
690 (setf (seg-hooks segment
) (list entry
))
691 (push entry
(cdr (last (seg-hooks segment
)))))))
693 (defun add-offs-note-hook (segment addr note
)
694 (add-offs-hook segment
696 (lambda (stream dstate
)
697 (declare (type (or null stream
) stream
)
698 (type disassem-state dstate
))
700 (note note dstate
)))))
702 (defun add-offs-comment-hook (segment addr comment
)
703 (add-offs-hook segment
705 (lambda (stream dstate
)
706 (declare (type (or null stream
) stream
)
709 (write-string ";;; " stream
)
712 (write-string comment stream
))
714 (funcall comment stream
)))
717 (defun add-fun-hook (dstate function
)
718 (push function
(dstate-fun-hooks dstate
)))
720 (defun set-location-printing-range (dstate from length
)
721 (setf (dstate-addr-print-len dstate
) ; in characters
722 ;; 4 bits per hex digit
723 (ceiling (integer-length (logxor from
(+ from length
))) 4)))
725 ;;; Print the current address in DSTATE to STREAM, plus any labels that
726 ;;; correspond to it, and leave the cursor in the instruction column.
727 (defun print-current-address (stream dstate
)
728 (declare (type stream stream
)
729 (type disassem-state dstate
))
731 (+ (seg-virtual-location (dstate-segment dstate
))
732 (dstate-cur-offs dstate
)))
733 (location-column-width *disassem-location-column-width
*)
734 (plen ; the number of rightmost hex chars of this address to print
735 (or (dstate-addr-print-len dstate
)
736 ;; Usually we've already set the width, but in case not...
737 (let ((seg (dstate-segment dstate
)))
738 (set-location-printing-range
739 dstate
(seg-virtual-location seg
) (seg-length seg
))))))
741 (if (eq (dstate-output-state dstate
) :beginning
) ; on the first line
742 (if location-column-width
743 ;; If there's a user-specified width, force that number of hex chars
744 ;; regardless of whether it's greater or smaller than PLEN.
745 (setq plen location-column-width
)
746 ;; No specified width. The PLEN of this line becomes the width.
747 ;; Adjust the DSTATE's argument column for it.
748 (incf (dstate-argument-column dstate
)
749 (setq location-column-width plen
)))
750 ;; not the first line
751 (if location-column-width
752 ;; A specified width smaller than that required clips significant
753 ;; digits, but larger should not cause leading zeros to appear.
754 (setq plen
(min plen location-column-width
))
755 ;; Otherwise use the previously computed addr-print-len
756 (setq location-column-width plen
)))
758 (incf location-column-width
2) ; account for leading "; "
762 ;; print the location
763 ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
764 ;; usually avoids any consing]
765 ;; FIXME: if this cruft is actually a speed win, the format-string compiler
766 ;; should be improved to obviate the obfuscation. If it is not a win,
767 ;; we should just replace it with the above format string already.
768 (tab0 (- location-column-width plen
) stream
)
769 (let* ((printed-bits (* 4 plen
))
770 (printed-value (ldb (byte printed-bits
0) location
))
772 (truncate (- printed-bits
(integer-length printed-value
)) 4)))
773 (dotimes (i leading-zeros
)
774 (write-char #\
0 stream
))
775 (unless (zerop printed-value
)
776 (write printed-value
:stream stream
:base
16 :radix nil
))
778 (write-char #\
: stream
)))
782 (let* ((next-label (car (dstate-cur-labels dstate
)))
783 (label-location (car next-label
)))
784 (when (or (null label-location
) (> label-location location
))
786 (unless (< label-location location
)
787 (format stream
" L~W:" (cdr next-label
)))
788 (pop (dstate-cur-labels dstate
))))
790 ;; move to the instruction column
791 (tab0 (+ location-column-width
1 label-column-width
) stream
)
794 (eval-when (:compile-toplevel
:execute
)
795 (sb!xc
:defmacro with-print-restrictions
(&rest body
)
796 `(let ((*print-pretty
* t
)
802 ;;; Print a newline to STREAM, inserting any pending notes in DSTATE
803 ;;; as end-of-line comments. If there is more than one note, a
804 ;;; separate line will be used for each one.
805 (defun print-notes-and-newline (stream dstate
)
806 (declare (type stream stream
)
807 (type disassem-state dstate
))
808 (with-print-restrictions
809 (dolist (note (dstate-notes dstate
))
810 (format stream
"~Vt " *disassem-note-column
*)
811 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
814 (write-string note stream
))
816 (funcall note stream
))))
819 (setf (dstate-notes dstate
) nil
)))
821 ;;; Print NUM instruction bytes to STREAM as hex values.
822 (defun print-inst (num stream dstate
&key
(offset 0) (trailing-space t
))
823 (when (> *disassem-inst-column-width
* 0)
824 (let ((sap (dstate-segment-sap dstate
))
825 (start-offs (+ offset
(dstate-cur-offs dstate
))))
827 (format stream
"~2,'0x" (sb!sys
:sap-ref-8 sap
(+ offs start-offs
))))
829 (pad-inst-column stream num
)))))
831 ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
832 (defun print-bytes (num stream dstate
)
833 (declare (type offset num
)
835 (type disassem-state dstate
))
836 (format stream
"~A~Vt" 'BYTE
(dstate-argument-column dstate
))
837 (let ((sap (dstate-segment-sap dstate
))
838 (start-offs (dstate-cur-offs dstate
)))
841 (write-string ", " stream
))
842 (format stream
"#X~2,'0x" (sb!sys
:sap-ref-8 sap
(+ offs start-offs
))))))
844 ;;; Disassemble NUM machine-words to STREAM as simple `WORD' instructions.
845 (defun print-words (num stream dstate
)
846 (declare (type offset num
)
848 (type disassem-state dstate
))
849 (format stream
"~A~Vt" 'WORD
(dstate-argument-column dstate
))
850 (let ((sap (dstate-segment-sap dstate
))
851 (start-offs (dstate-cur-offs dstate
))
852 (byte-order (dstate-byte-order dstate
)))
853 (dotimes (word-offs num
)
854 (unless (zerop word-offs
)
855 (write-string ", " stream
))
856 (let ((word 0) (bit-shift 0))
857 (dotimes (byte-offs sb
!vm
:n-word-bytes
)
862 (* word-offs sb
!vm
:n-word-bytes
)
865 (if (eq byte-order
:big-endian
)
866 (+ (ash word sb
!vm
:n-byte-bits
) byte
)
867 (+ word
(ash byte bit-shift
))))
868 (incf bit-shift sb
!vm
:n-byte-bits
)))
869 (format stream
"#X~V,'0X" (ash sb
!vm
:n-word-bits -
2) word
)))))
871 (defvar *default-dstate-hooks
* (list #'lra-hook
))
873 ;;; Make a disassembler-state object.
874 (defun make-dstate (&optional
(fun-hooks *default-dstate-hooks
*))
875 (let ((alignment *disassem-inst-alignment-bytes
*)
877 (+ 2 ; for the leading "; " on each line
878 (or *disassem-location-column-width
* 0)
881 *disassem-inst-column-width
*
882 (if (zerop *disassem-inst-column-width
*) 0 1)
883 *disassem-opcode-column-width
*)))
885 (when (> alignment
1)
886 (push #'alignment-hook fun-hooks
))
888 (%make-dstate
:fun-hooks fun-hooks
889 :argument-column arg-column
891 :byte-order sb
!c
:*backend-byte-order
*)))
893 (defun add-fun-header-hooks (segment)
894 (declare (type segment segment
))
895 (do ((fun (awhen (seg-code segment
) (sb!kernel
:%code-entry-points it
))
897 (length (seg-length segment
)))
899 (let ((offset (code-offs-to-segment-offs (fun-offset fun
) segment
)))
900 (when (<= 0 offset length
)
901 ;; Up to 2 words of zeros might be present to align the next
902 ;; simple-fun. Limit on OFFSET is to avoid incorrect triggering
903 ;; in case of unexpected weirdness. FIXME: verify all zero bytes
904 (when (< 0 offset
(* sb
!vm
:n-word-bytes
2))
905 (push (make-offs-hook
906 :fun
(lambda (stream dstate
)
908 (format stream
".SKIP ~D" offset
))
909 (incf (dstate-next-offs dstate
) offset
))
910 :offset
0) ; at 0 bytes into this seg, skip OFFSET bytes
911 (seg-hooks segment
)))
912 (push (make-offs-hook :offset offset
:fun
#'fun-header-hook
)
913 (seg-hooks segment
))))))
915 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
917 ;; FIXME: Are the objects we are taking saps for always pinned?
918 #!-sb-fluid
(declaim (inline sap-maker
))
919 (defun sap-maker (function input offset
)
920 (declare (optimize (speed 3))
921 (type (function (t) sb
!sys
:system-area-pointer
) function
)
922 (type offset offset
))
923 (let ((old-sap (sb!sys
:sap
+ (funcall function input
) offset
)))
924 (declare (type sb
!sys
:system-area-pointer old-sap
))
927 (+ (sb!sys
:sap-int
(funcall function input
)) offset
)))
928 ;; Saving the sap like this avoids consing except when the sap
929 ;; changes (because the sap-int, arith, etc., get inlined).
930 (declare (type address new-addr
))
931 (if (= (sb!sys
:sap-int old-sap
) new-addr
)
933 (setf old-sap
(sb!sys
:int-sap new-addr
)))))))
935 (defun vector-sap-maker (vector offset
)
936 (declare (optimize (speed 3))
937 (type offset offset
))
938 (sap-maker #'sb
!sys
:vector-sap vector offset
))
940 (defun code-sap-maker (code offset
)
941 (declare (optimize (speed 3))
942 (type sb
!kernel
:code-component code
)
943 (type offset offset
))
944 (sap-maker #'sb
!kernel
:code-instructions code offset
))
946 (defun memory-sap-maker (address)
947 (declare (optimize (speed 3))
948 (type address address
))
949 (let ((sap (sb!sys
:int-sap address
)))
952 ;;; Return a memory segment located at the system-area-pointer returned by
953 ;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
955 ;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
956 ;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a
957 ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
959 (defun make-segment (sap-maker length
961 code virtual-location
962 debug-fun source-form-cache
964 (declare (type (function () sb
!sys
:system-area-pointer
) sap-maker
)
965 (type disassem-length length
)
966 (type (or null address
) virtual-location
)
967 (type (or null sb
!di
:debug-fun
) debug-fun
)
968 (type (or null source-form-cache
) source-form-cache
))
973 :opcodes-length length
974 :virtual-location
(or virtual-location
975 (sb!sys
:sap-int
(funcall sap-maker
)))
980 (let ((n-words (sb!kernel
:code-n-unboxed-data-words code
))
981 (start (sb!kernel
:get-header-data code
)))
983 (cons (* sb
!vm
:n-word-bytes start
)
984 (* sb
!vm
:n-word-bytes
(+ start n-words
)))))))))
985 (add-debugging-hooks segment debug-fun source-form-cache
)
986 (add-fun-header-hooks segment
)
989 (defun make-vector-segment (vector offset
&rest args
)
990 (declare (type vector vector
)
992 (inline make-segment
))
993 (apply #'make-segment
(vector-sap-maker vector offset
) args
))
995 (defun make-code-segment (code offset length
&rest args
)
996 (declare (type sb
!kernel
:code-component code
)
998 (inline make-segment
))
999 (apply #'make-segment
(code-sap-maker code offset
) length
:code code args
))
1001 (defun make-memory-segment (address &rest args
)
1002 (declare (type address address
)
1003 (inline make-segment
))
1004 (apply #'make-segment
(memory-sap-maker address
) args
))
1007 (defun print-fun-headers (function)
1008 (declare (type compiled-function function
))
1009 (let* ((self (fun-self function
))
1010 (code (sb!kernel
:fun-code-header self
)))
1011 (format t
"Code-header ~S: size: ~S~%"
1013 (sb!kernel
:%code-code-size code
))
1014 (do ((fun (sb!kernel
:code-header-ref code sb
!vm
:code-entry-points-slot
)
1017 (let ((fun-offset (sb!kernel
:get-closure-length fun
)))
1018 ;; There is function header fun-offset words from the
1020 (format t
"Fun-header ~S at offset ~W (words): ~S~A => ~S~%"
1023 (sb!kernel
:code-header-ref
1024 code
(+ fun-offset sb
!vm
:simple-fun-name-slot
))
1025 (sb!kernel
:code-header-ref
1026 code
(+ fun-offset sb
!vm
:simple-fun-arglist-slot
))
1027 (sb!kernel
:code-header-ref
1028 code
(+ fun-offset sb
!vm
:simple-fun-type-slot
)))))))
1030 ;;; getting at the source code...
1032 (defstruct (source-form-cache (:conc-name sfcache-
)
1034 (debug-source nil
:type
(or null sb
!di
:debug-source
))
1035 (toplevel-form-index -
1 :type fixnum
)
1036 (last-location-retrieved nil
:type
(or null sb
!di
:code-location
))
1037 (last-form-retrieved -
1 :type fixnum
))
1039 (defun get-different-source-form (loc context
&optional cache
)
1041 (eq (sb!di
:code-location-debug-source loc
)
1042 (sfcache-debug-source cache
))
1043 (eq (sb!di
:code-location-toplevel-form-offset loc
)
1044 (sfcache-toplevel-form-index cache
))
1045 (or (eql (sb!di
:code-location-form-number loc
)
1046 (sfcache-last-form-retrieved cache
))
1047 (awhen (sfcache-last-location-retrieved cache
)
1048 (sb!di
:code-location
= loc it
))))
1050 (let ((form (sb!debug
::code-location-source-form loc context nil
)))
1052 (setf (sfcache-debug-source cache
)
1053 (sb!di
:code-location-debug-source loc
))
1054 (setf (sfcache-toplevel-form-index cache
)
1055 (sb!di
:code-location-toplevel-form-offset loc
))
1056 (setf (sfcache-last-form-retrieved cache
)
1057 (sb!di
:code-location-form-number loc
))
1058 (setf (sfcache-last-location-retrieved cache
) loc
))
1061 ;;;; stuff to use debugging info to augment the disassembly
1063 (defun code-fun-map (code)
1064 (declare (type sb
!kernel
:code-component code
))
1065 (sb!c
::compiled-debug-info-fun-map
(sb!kernel
:%code-debug-info code
)))
1067 (defstruct (location-group (:copier nil
))
1068 (locations #() :type
(vector (or list fixnum
))))
1070 (defstruct (storage-info (:copier nil
))
1071 (groups nil
:type list
) ; alist of (name . location-group)
1072 (debug-vars #() :type vector
))
1074 ;;; Return the vector of DEBUG-VARs currently associated with DSTATE.
1075 (defun dstate-debug-vars (dstate)
1076 (declare (type disassem-state dstate
))
1077 (storage-info-debug-vars (seg-storage-info (dstate-segment dstate
))))
1079 ;;; Given the OFFSET of a location within the location-group called
1080 ;;; LG-NAME, see whether there's a current mapping to a source
1081 ;;; variable in DSTATE, and if so, return the offset of that variable
1082 ;;; in the current debug-var vector.
1083 (defun find-valid-storage-location (offset lg-name dstate
)
1084 (declare (type offset offset
)
1085 (type symbol lg-name
)
1086 (type disassem-state dstate
))
1087 (let* ((storage-info
1088 (seg-storage-info (dstate-segment dstate
)))
1091 (cdr (assoc lg-name
(storage-info-groups storage-info
)))))
1093 (dstate-current-valid-locations dstate
)))
1095 (not (null currently-valid
))
1096 (let ((locations (location-group-locations location-group
)))
1097 (and (< offset
(length locations
))
1098 (let ((used-by (aref locations offset
)))
1100 (let ((debug-var-num
1104 (zerop (bit currently-valid used-by
)))
1110 (bit currently-valid num
)))
1115 ;; Found a valid storage reference!
1116 ;; can't use it again until it's revalidated...
1117 (setf (bit (dstate-current-valid-locations
1124 ;;; Return a new vector which has the same contents as the old one
1125 ;;; VEC, plus new cells (for a total size of NEW-LEN). The additional
1126 ;;; elements are initialized to INITIAL-ELEMENT.
1127 (defun grow-vector (vec new-len
&optional initial-element
)
1128 (declare (type vector vec
)
1129 (type fixnum new-len
))
1131 (make-sequence `(vector ,(array-element-type vec
) ,new-len
)
1133 :initial-element initial-element
)))
1134 (dotimes (i (length vec
))
1135 (setf (aref new i
) (aref vec i
)))
1138 ;;; Return a STORAGE-INFO struction describing the object-to-source
1139 ;;; variable mappings from DEBUG-FUN.
1140 (defun storage-info-for-debug-fun (debug-fun)
1141 (declare (type sb
!di
:debug-fun debug-fun
))
1142 (let ((sc-vec sb
!c
::*backend-sc-numbers
*)
1144 (debug-vars (sb!di
::debug-fun-debug-vars
1147 (dotimes (debug-var-offset
1149 (make-storage-info :groups groups
1150 :debug-vars debug-vars
))
1151 (let ((debug-var (aref debug-vars debug-var-offset
)))
1153 (format t
";;; At offset ~W: ~S~%" debug-var-offset debug-var
)
1155 (sb!di
::compiled-debug-var-sc-offset debug-var
))
1158 (sb!c
:sc-sb
(aref sc-vec
1159 (sb!c
:sc-offset-scn sc-offset
))))))
1161 (format t
";;; SET: ~S[~W]~%"
1162 sb-name
(sb!c
:sc-offset-offset sc-offset
))
1163 (unless (null sb-name
)
1164 (let ((group (cdr (assoc sb-name groups
))))
1166 (setf group
(make-location-group))
1167 (push `(,sb-name .
,group
) groups
))
1168 (let* ((locations (location-group-locations group
))
1169 (length (length locations
))
1170 (offset (sb!c
:sc-offset-offset sc-offset
)))
1171 (when (>= offset length
)
1173 (grow-vector locations
1177 (location-group-locations group
)
1179 (let ((already-there (aref locations offset
)))
1180 (cond ((null already-there
)
1181 (setf (aref locations offset
) debug-var-offset
))
1182 ((eql already-there debug-var-offset
))
1184 (if (listp already-there
)
1185 (pushnew debug-var-offset
1186 (aref locations offset
))
1187 (setf (aref locations offset
)
1188 (list debug-var-offset
1193 (defun source-available-p (debug-fun)
1195 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1196 (declare (ignore block
))
1198 (sb!di
:no-debug-blocks
() nil
)))
1200 (defun print-block-boundary (stream dstate
)
1201 (let ((os (dstate-output-state dstate
)))
1202 (when (not (eq os
:beginning
))
1203 (when (not (eq os
:block-boundary
))
1205 (setf (dstate-output-state dstate
)
1208 ;;; Add hooks to track the source code in SEGMENT during disassembly.
1209 ;;; SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
1210 ;;; structure, in which case it is used to cache forms from files.
1211 (defun add-source-tracking-hooks (segment debug-fun
&optional sfcache
)
1212 (declare (type segment segment
)
1213 (type (or null sb
!di
:debug-fun
) debug-fun
)
1214 (type (or null source-form-cache
) sfcache
))
1215 (let ((last-block-pc -
1))
1216 (flet ((add-hook (pc fun
&optional before-address
)
1217 (push (make-offs-hook
1218 :offset
(code-insts-offs-to-segment-offs pc segment
)
1220 :before-address before-address
)
1221 (seg-hooks segment
))))
1223 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1224 (let ((first-location-in-block-p t
))
1225 (sb!di
:do-debug-block-locations
(loc block
)
1226 (let ((pc (sb!di
::compiled-code-location-pc loc
)))
1228 ;; Put blank lines in at block boundaries
1229 (when (and first-location-in-block-p
1230 (/= pc last-block-pc
))
1231 (setf first-location-in-block-p nil
)
1233 (lambda (stream dstate
)
1234 (print-block-boundary stream dstate
))
1236 (setf last-block-pc pc
))
1238 ;; Print out corresponding source; this information is not
1239 ;; all that accurate, but it's better than nothing
1240 (unless (zerop (sb!di
:code-location-form-number loc
))
1241 (multiple-value-bind (form new
)
1242 (get-different-source-form loc
0 sfcache
)
1244 (let ((at-block-begin (= pc last-block-pc
)))
1247 (lambda (stream dstate
)
1248 (declare (ignore dstate
))
1250 (unless at-block-begin
1252 (format stream
";;; [~W] "
1253 (sb!di
:code-location-form-number
1255 (prin1-short form stream
)
1260 ;; Keep track of variable live-ness as best we can.
1262 (copy-seq (sb!di
::compiled-code-location-live-set
1266 (lambda (stream dstate
)
1267 (declare (ignore stream
))
1268 (setf (dstate-current-valid-locations dstate
)
1271 (note (lambda (stream)
1272 (let ((*print-length
* nil
))
1273 (format stream
"live set: ~S"
1277 (sb!di
:no-debug-blocks
() nil
)))))
1279 (defvar *disassemble-annotate
* t
1281 "Annotate DISASSEMBLE output with source code.")
1283 (defun add-debugging-hooks (segment debug-fun
&optional sfcache
)
1285 (setf (seg-storage-info segment
)
1286 (storage-info-for-debug-fun debug-fun
))
1287 (when *disassemble-annotate
*
1288 (add-source-tracking-hooks segment debug-fun sfcache
))
1289 (let ((kind (sb!di
:debug-fun-kind debug-fun
)))
1290 (flet ((add-new-hook (n)
1291 (push (make-offs-hook
1293 :fun
(lambda (stream dstate
)
1294 (declare (ignore stream
))
1296 (seg-hooks segment
))))
1300 (add-new-hook "no-arg-parsing entry point"))
1302 (add-new-hook (lambda (stream)
1303 (format stream
"~S entry point" kind
)))))))))
1305 ;;; Return a list of the segments of memory containing machine code
1306 ;;; instructions for FUNCTION.
1307 (defun get-fun-segments (function)
1308 (declare (type compiled-function function
))
1309 (let* ((function (fun-self function
))
1310 (code (fun-code function
))
1311 (fun-map (code-fun-map code
))
1312 (fname (sb!kernel
:%simple-fun-name function
))
1313 (sfcache (make-source-form-cache)))
1314 (let ((first-block-seen-p nil
)
1315 (nil-block-seen-p nil
)
1317 (last-debug-fun nil
)
1319 (flet ((add-seg (offs len df
)
1321 (push (make-code-segment code offs len
1323 :source-form-cache sfcache
)
1325 (dotimes (fmap-index (length fun-map
))
1326 (let ((fmap-entry (aref fun-map fmap-index
)))
1327 (etypecase fmap-entry
1329 (when first-block-seen-p
1330 (add-seg last-offset
1331 (- fmap-entry last-offset
)
1333 (setf last-debug-fun nil
))
1334 (setf last-offset fmap-entry
))
1335 (sb!c
::compiled-debug-fun
1336 (let ((name (sb!c
::compiled-debug-fun-name fmap-entry
))
1337 (kind (sb!c
::compiled-debug-fun-kind fmap-entry
)))
1339 (format t
";;; SAW ~S ~S ~S,~S ~W,~W~%"
1340 name kind first-block-seen-p nil-block-seen-p
1342 (sb!c
::compiled-debug-fun-start-pc fmap-entry
))
1343 (cond (#+nil
(eq last-offset fun-offset
)
1344 (and (equal name fname
) (not first-block-seen-p
))
1345 (setf first-block-seen-p t
))
1346 ((eq kind
:external
)
1347 (when first-block-seen-p
1350 (when nil-block-seen-p
1352 (when first-block-seen-p
1353 (setf nil-block-seen-p t
))))
1354 (setf last-debug-fun
1355 (sb!di
::make-compiled-debug-fun fmap-entry code
)))))))
1356 (let ((max-offset (code-inst-area-length code
)))
1357 (when (and first-block-seen-p last-debug-fun
)
1358 (add-seg last-offset
1359 (- max-offset last-offset
)
1362 (let ((offs (fun-insts-offset function
)))
1364 (make-code-segment code offs
(- max-offset offs
))))
1365 (nreverse segments
)))))))
1367 ;;; Return a list of the segments of memory containing machine code
1368 ;;; instructions for the code-component CODE. If START-OFFSET and/or
1369 ;;; LENGTH is supplied, only that part of the code-segment is used
1370 ;;; (but these are constrained to lie within the code-segment).
1371 (defun get-code-segments (code
1374 (length (code-inst-area-length code
)))
1375 (declare (type sb
!kernel
:code-component code
)
1376 (type offset start-offset
)
1377 (type disassem-length length
))
1378 (let ((segments nil
))
1379 (when (sb!kernel
:%code-debug-info code
)
1380 (let ((fun-map (code-fun-map code
))
1381 (sfcache (make-source-form-cache)))
1382 (let ((last-offset 0)
1383 (last-debug-fun nil
))
1384 (flet ((add-seg (offs len df
)
1385 (let* ((restricted-offs
1386 (min (max start-offset offs
)
1387 (+ start-offset length
)))
1389 (- (min (max start-offset
(+ offs len
))
1390 (+ start-offset length
))
1392 (when (> restricted-len
0)
1393 (push (make-code-segment code
1394 restricted-offs restricted-len
1396 :source-form-cache sfcache
)
1398 (dotimes (fun-map-index (length fun-map
))
1399 (let ((fun-map-entry (aref fun-map fun-map-index
)))
1400 (etypecase fun-map-entry
1402 (add-seg last-offset
(- fun-map-entry last-offset
)
1404 (setf last-debug-fun nil
)
1405 (setf last-offset fun-map-entry
))
1406 (sb!c
::compiled-debug-fun
1407 (setf last-debug-fun
1408 (sb!di
::make-compiled-debug-fun fun-map-entry
1410 (when last-debug-fun
1411 (add-seg last-offset
1412 (- (code-inst-area-length code
) last-offset
)
1413 last-debug-fun
))))))
1415 (list (make-code-segment code start-offset length
))
1416 (nreverse segments
))))
1418 ;;; Compute labels for all the memory segments in SEGLIST and adds
1419 ;;; them to DSTATE. It's important to call this function with all the
1420 ;;; segments you're interested in, so that it can find references from
1422 (defun label-segments (seglist dstate
)
1423 (declare (type list seglist
)
1424 (type disassem-state dstate
))
1425 (dolist (seg seglist
)
1426 (add-segment-labels seg dstate
))
1427 ;; Now remove any labels that don't point anywhere in the segments
1429 (setf (dstate-labels dstate
)
1430 (remove-if (lambda (lab)
1433 (let ((start (seg-virtual-location seg
)))
1436 (+ start
(seg-length seg
)))))
1438 (dstate-labels dstate
))))
1440 ;;; Disassemble the machine code instructions in SEGMENT to STREAM.
1441 (defun disassemble-segment (segment stream dstate
)
1442 (declare (type segment segment
)
1443 (type stream stream
)
1444 (type disassem-state dstate
))
1445 (let ((*print-pretty
* nil
)) ; otherwise the pp conses hugely
1446 (number-labels dstate
)
1447 (map-segment-instructions
1448 (lambda (chunk inst
)
1449 (declare (type dchunk chunk
) (type instruction inst
))
1450 (let ((printer (inst-printer inst
)))
1452 (funcall printer chunk inst stream dstate
))))
1457 ;;; Disassemble the machine code instructions in each memory segment
1458 ;;; in SEGMENTS in turn to STREAM.
1459 (defun disassemble-segments (segments stream dstate
)
1460 (declare (type list segments
)
1461 (type stream stream
)
1462 (type disassem-state dstate
))
1463 (unless (null segments
)
1464 (let ((n-segments (length segments
))
1465 (first (car segments
))
1466 (last (car (last segments
))))
1467 ;; One origin per segment is printed. As with the per-line display,
1468 ;; the segment is thought of as immovable for rendering of addresses,
1469 ;; though in fact the disassembler transiently allows movement.
1470 (format stream
"~&; Size: ~a bytes. Origin: #x~x~@[ (segment 1 of ~D)~]"
1471 (reduce #'+ segments
:key
#'seg-length
)
1472 (seg-virtual-location first
)
1473 (if (> n-segments
1) n-segments
))
1474 (set-location-printing-range dstate
1475 (seg-virtual-location first
)
1476 (- (+ (seg-virtual-location last
)
1478 (seg-virtual-location first
)))
1479 (setf (dstate-output-state dstate
) :beginning
)
1481 (dolist (seg segments
)
1482 (when (> (incf i
) 1)
1483 (format stream
"~&; Origin #x~x (segment ~D of ~D)"
1484 (seg-virtual-location seg
) i n-segments
))
1485 (disassemble-segment seg stream dstate
))))))
1488 ;;;; top level functions
1490 ;;; Disassemble the machine code instructions for FUNCTION.
1491 (defun disassemble-fun (fun &key
1492 (stream *standard-output
*)
1494 (declare (type compiled-function fun
)
1495 (type stream stream
)
1496 (type (member t nil
) use-labels
))
1497 (let* ((dstate (make-dstate))
1498 (segments (get-fun-segments fun
)))
1500 (label-segments segments dstate
))
1501 (disassemble-segments segments stream dstate
)))
1503 (defun valid-extended-function-designators-for-disassemble-p (thing)
1504 (cond ((legal-fun-name-p thing
)
1505 (compiled-funs-or-lose (fdefinition thing
) thing
))
1507 ((sb!eval
:interpreted-function-p thing
)
1508 (compile nil thing
))
1509 ((typep thing
'sb
!pcl
::%method-function
)
1510 ;; in a %METHOD-FUNCTION, the user code is in the fast function, so
1511 ;; we to disassemble both.
1512 ;; FIXME: interpreted methods need to be compiled as above.
1513 (list thing
(sb!pcl
::%method-function-fast-function thing
)))
1517 (eq (car thing
) 'lambda
))
1518 (compile nil thing
))
1521 (defun compiled-funs-or-lose (thing &optional
(name thing
))
1522 (let ((funs (valid-extended-function-designators-for-disassemble-p thing
)))
1525 (error 'simple-type-error
1527 :expected-type
'(satisfies valid-extended-function-designators-for-disassemble-p
)
1528 :format-control
"Can't make a compiled function from ~S"
1529 :format-arguments
(list name
)))))
1531 (defun disassemble (object &key
1532 (stream *standard-output
*)
1535 "Disassemble the compiled code associated with OBJECT, which can be a
1536 function, a lambda expression, or a symbol with a function definition. If
1537 it is not already compiled, the compiler is called to produce something to
1539 (declare (type (or function symbol cons
) object
)
1540 (type (or (member t
) stream
) stream
)
1541 (type (member t nil
) use-labels
))
1542 (flet ((disassemble1 (fun)
1543 (format stream
"~&; disassembly for ~S" (sb!kernel
:%fun-name fun
))
1544 (disassemble-fun fun
1546 :use-labels use-labels
)))
1547 (mapc #'disassemble1
(ensure-list (compiled-funs-or-lose object
))))
1550 ;;; Disassembles the given area of memory starting at ADDRESS and
1551 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
1552 ;;; could move during a GC, you'd better disable it around the call to
1554 (defun disassemble-memory (address
1557 (stream *standard-output
*)
1560 (declare (type (or address sb
!sys
:system-area-pointer
) address
)
1561 (type disassem-length length
)
1562 (type stream stream
)
1563 (type (or null sb
!kernel
:code-component
) code-component
)
1564 (type (member t nil
) use-labels
))
1566 (if (sb!sys
:system-area-pointer-p address
)
1567 (sb!sys
:sap-int address
)
1569 (dstate (make-dstate))
1575 (sb!kernel
:code-instructions code-component
)))))
1576 (when (or (< code-offs
0)
1577 (> code-offs
(code-inst-area-length code-component
)))
1578 (error "address ~X not in the code component ~S"
1579 address code-component
))
1580 (get-code-segments code-component code-offs length
))
1581 (list (make-memory-segment address length
)))))
1583 (label-segments segments dstate
))
1584 (disassemble-segments segments stream dstate
)))
1586 ;;; Disassemble the machine code instructions associated with
1587 ;;; CODE-COMPONENT (this may include multiple entry points).
1588 (defun disassemble-code-component (code-component &key
1589 (stream *standard-output
*)
1591 (declare (type (or sb
!kernel
:code-component compiled-function
)
1593 (type stream stream
)
1594 (type (member t nil
) use-labels
))
1595 (let* ((code-component
1596 (if (functionp code-component
)
1597 (fun-code code-component
)
1599 (dstate (make-dstate))
1600 (segments (get-code-segments code-component
)))
1602 (label-segments segments dstate
))
1603 (disassemble-segments segments stream dstate
)))
1605 ;;;; code to disassemble assembler segments
1607 (defun assem-segment-to-disassem-segment (assem-segment)
1608 (declare (type sb
!assem
:segment assem-segment
))
1609 (let ((contents (sb!assem
:segment-contents-as-vector assem-segment
)))
1610 (make-vector-segment contents
0 (length contents
) :virtual-location
0)))
1612 ;;; Disassemble the machine code instructions associated with
1613 ;;; ASSEM-SEGMENT (of type assem:segment).
1614 (defun disassemble-assem-segment (assem-segment stream
)
1615 (declare (type sb
!assem
:segment assem-segment
)
1616 (type stream stream
))
1617 (let ((dstate (make-dstate))
1619 (list (assem-segment-to-disassem-segment assem-segment
))))
1620 (label-segments disassem-segments dstate
)
1621 (disassemble-segments disassem-segments stream dstate
)))
1623 ;;; routines to find things in the Lisp environment
1625 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
1626 ;;; in a symbol object that we know about
1627 (defparameter *grokked-symbol-slots
*
1628 (sort (copy-list `((,sb
!vm
:symbol-value-slot . symbol-value
)
1629 (,sb
!vm
:symbol-info-slot . symbol-info
)
1630 (,sb
!vm
:symbol-name-slot . symbol-name
)
1631 (,sb
!vm
:symbol-package-slot . symbol-package
)))
1635 ;;; Given ADDRESS, try and figure out if which slot of which symbol is
1636 ;;; being referred to. Of course we can just give up, so it's not a
1637 ;;; big deal... Return two values, the symbol and the name of the
1638 ;;; access function of the slot.
1639 (defun grok-symbol-slot-ref (address)
1640 (declare (type address address
))
1641 (if (not (aligned-p address sb
!vm
:n-word-bytes
))
1643 (do ((slots-tail *grokked-symbol-slots
* (cdr slots-tail
)))
1646 (let* ((field (car slots-tail
))
1647 (slot-offset (words-to-bytes (car field
)))
1648 (maybe-symbol-addr (- address slot-offset
))
1650 (sb!kernel
:make-lisp-obj
1651 (+ maybe-symbol-addr sb
!vm
:other-pointer-lowtag
))))
1652 (when (symbolp maybe-symbol
)
1653 (return (values maybe-symbol
(cdr field
))))))))
1655 (defvar *address-of-nil-object
* (sb!kernel
:get-lisp-obj-address nil
))
1657 ;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
1658 ;;; which symbol is being referred to. Of course we can just give up,
1659 ;;; so it's not a big deal... Return two values, the symbol and the
1660 ;;; access function.
1661 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1662 (declare (type offset byte-offset
))
1663 (grok-symbol-slot-ref (+ *address-of-nil-object
* byte-offset
)))
1665 ;;; Return the Lisp object located BYTE-OFFSET from NIL.
1666 (defun get-nil-indexed-object (byte-offset)
1667 (declare (type offset byte-offset
))
1668 (sb!kernel
:make-lisp-obj
(+ *address-of-nil-object
* byte-offset
)))
1670 ;;; Return two values; the Lisp object located at BYTE-OFFSET in the
1671 ;;; constant area of the code-object in the current segment and T, or
1672 ;;; NIL and NIL if there is no code-object in the current segment.
1673 (defun get-code-constant (byte-offset dstate
)
1674 (declare (type offset byte-offset
)
1675 (type disassem-state dstate
))
1676 (let ((code (seg-code (dstate-segment dstate
))))
1679 (sb!kernel
:code-header-ref code
1681 sb
!vm
:other-pointer-lowtag
)
1682 (- sb
!vm
:word-shift
)))
1686 (defun get-code-constant-absolute (addr dstate
&optional width
)
1687 (declare (type address addr
))
1688 (declare (type disassem-state dstate
))
1689 (declare (ignore width
))
1690 (let ((code (seg-code (dstate-segment dstate
))))
1692 (return-from get-code-constant-absolute
(values nil nil
)))
1693 ;; This WITHOUT-GCING, while not technically broken, is extremely deceptive
1694 ;; because if it is really needed, then this function has a broken API.
1695 ;; Since ADDR comes in as absolute, CODE must not move between the caller's
1696 ;; computation and the comparison below. But we're already in WITHOUT-GCING
1697 ;; in MAP-SEGMENT-INSTRUCTIONS, so, who cares, I guess?
1698 (sb!sys
:without-gcing
1699 (let* ((n-header-bytes (* (sb!kernel
:get-header-data code
) sb
!vm
:n-word-bytes
))
1700 (header-addr (- (sb!kernel
:get-lisp-obj-address code
)
1701 sb
!vm
:other-pointer-lowtag
))
1702 (code-start (+ header-addr n-header-bytes
)))
1703 (cond ((< header-addr addr code-start
)
1704 (values (sb!sys
:sap-ref-lispobj
(sb!sys
:int-sap addr
) 0) t
))
1706 (values nil nil
)))))))
1708 (defvar *assembler-routines-by-addr
* nil
)
1710 (defvar *foreign-symbols-by-addr
* nil
)
1712 ;;; Build an address-name hash-table from the name-address hash
1713 (defun invert-address-hash (htable &optional
(addr-hash (make-hash-table)))
1714 (maphash (lambda (name address
)
1715 (setf (gethash address addr-hash
) name
))
1719 ;;; Return the name of the primitive Lisp assembler routine or foreign
1720 ;;; symbol located at ADDRESS, or NIL if there isn't one.
1721 (defun find-assembler-routine (address)
1722 (declare (type address address
))
1723 (when (null *assembler-routines-by-addr
*)
1724 (setf *assembler-routines-by-addr
*
1725 (invert-address-hash sb
!fasl
:*assembler-routines
*))
1727 (setf *assembler-routines-by-addr
*
1728 (invert-address-hash sb
!sys
:*static-foreign-symbols
*
1729 *assembler-routines-by-addr
*))
1730 (loop for static in sb
!vm
:*static-funs
*
1731 for address
= (+ sb
!vm
::nil-value
1732 (sb!vm
::static-fun-offset static
))
1734 (setf (gethash address
*assembler-routines-by-addr
*)
1736 ;; Not really a routine, but it uses the similar logic for annotations
1738 (setf (gethash sb
!vm
::gc-safepoint-page-addr
*assembler-routines-by-addr
*)
1740 (gethash address
*assembler-routines-by-addr
*))
1742 ;;;; some handy function for machine-dependent code to use...
1744 #!-sb-fluid
(declaim (maybe-inline sap-ref-int read-suffix
))
1746 (defun sap-ref-int (sap offset length byte-order
)
1747 (declare (type sb
!sys
:system-area-pointer sap
)
1748 (type (unsigned-byte 16) offset
)
1749 (type (member 1 2 4 8) length
)
1750 (type (member :little-endian
:big-endian
) byte-order
)
1751 (optimize (speed 3) (safety 0)))
1753 (1 (sb!sys
:sap-ref-8 sap offset
))
1754 (2 (if (eq byte-order
:big-endian
)
1755 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 8)
1756 (sb!sys
:sap-ref-8 sap
(+ offset
1)))
1757 (+ (ash (sb!sys
:sap-ref-8 sap
(+ offset
1)) 8)
1758 (sb!sys
:sap-ref-8 sap offset
))))
1759 (4 (if (eq byte-order
:big-endian
)
1760 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 24)
1761 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 16)
1762 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 8)
1763 (sb!sys
:sap-ref-8 sap
(+ 3 offset
)))
1764 (+ (sb!sys
:sap-ref-8 sap offset
)
1765 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 8)
1766 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 16)
1767 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 24))))
1768 (8 (if (eq byte-order
:big-endian
)
1769 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 56)
1770 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 48)
1771 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 40)
1772 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 32)
1773 (ash (sb!sys
:sap-ref-8 sap
(+ 4 offset
)) 24)
1774 (ash (sb!sys
:sap-ref-8 sap
(+ 5 offset
)) 16)
1775 (ash (sb!sys
:sap-ref-8 sap
(+ 6 offset
)) 8)
1776 (sb!sys
:sap-ref-8 sap
(+ 7 offset
)))
1777 (+ (sb!sys
:sap-ref-8 sap offset
)
1778 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 8)
1779 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 16)
1780 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 24)
1781 (ash (sb!sys
:sap-ref-8 sap
(+ 4 offset
)) 32)
1782 (ash (sb!sys
:sap-ref-8 sap
(+ 5 offset
)) 40)
1783 (ash (sb!sys
:sap-ref-8 sap
(+ 6 offset
)) 48)
1784 (ash (sb!sys
:sap-ref-8 sap
(+ 7 offset
)) 56))))))
1786 (defun read-suffix (length dstate
)
1787 (declare (type (member 8 16 32 64) length
)
1788 (type disassem-state dstate
)
1789 (optimize (speed 3) (safety 0)))
1790 (let ((length (ecase length
(8 1) (16 2) (32 4) (64 8))))
1791 (declare (type (unsigned-byte 4) length
))
1793 (sap-ref-int (dstate-segment-sap dstate
)
1794 (dstate-next-offs dstate
)
1796 (dstate-byte-order dstate
))
1797 (incf (dstate-next-offs dstate
) length
))))
1799 ;;;; optional routines to make notes about code
1801 ;;; Store NOTE (which can be either a string or a function with a
1802 ;;; single stream argument) to be printed as an end-of-line comment
1803 ;;; after the current instruction is disassembled.
1804 (defun note (note dstate
)
1805 (declare (type (or string function
) note
)
1806 (type disassem-state dstate
))
1807 (push note
(dstate-notes dstate
)))
1809 (defun prin1-short (thing stream
)
1810 (with-print-restrictions
1811 (prin1 thing stream
)))
1813 (defun prin1-quoted-short (thing stream
)
1814 (if (self-evaluating-p thing
)
1815 (prin1-short thing stream
)
1816 (prin1-short `',thing stream
)))
1818 ;;; Store a note about the lisp constant located BYTE-OFFSET bytes
1819 ;;; from the current code-component, to be printed as an end-of-line
1820 ;;; comment after the current instruction is disassembled.
1821 (defun note-code-constant (byte-offset dstate
)
1822 (declare (type offset byte-offset
)
1823 (type disassem-state dstate
))
1824 (multiple-value-bind (const valid
)
1825 (get-code-constant byte-offset dstate
)
1827 (note (lambda (stream)
1828 (prin1-quoted-short const stream
))
1832 ;;; Store a note about the lisp constant located at ADDR in the
1833 ;;; current code-component, to be printed as an end-of-line comment
1834 ;;; after the current instruction is disassembled.
1835 (defun note-code-constant-absolute (addr dstate
&optional width
)
1836 (declare (type address addr
)
1837 (type disassem-state dstate
))
1838 (multiple-value-bind (const valid
)
1839 (get-code-constant-absolute addr dstate width
)
1841 (note (lambda (stream)
1842 (prin1-quoted-short const stream
))
1844 (values const valid
)))
1846 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1847 ;;; constant NIL is a valid slot in a symbol, store a note describing
1848 ;;; which symbol and slot, to be printed as an end-of-line comment
1849 ;;; after the current instruction is disassembled. Returns non-NIL iff
1850 ;;; a note was recorded.
1851 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate
)
1852 (declare (type offset nil-byte-offset
)
1853 (type disassem-state dstate
))
1854 (multiple-value-bind (symbol access-fun
)
1855 (grok-nil-indexed-symbol-slot-ref nil-byte-offset
)
1857 (note (lambda (stream)
1858 (prin1 (if (eq access-fun
'symbol-value
)
1860 `(,access-fun
',symbol
))
1865 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1866 ;;; constant NIL is a valid lisp object, store a note describing which
1867 ;;; symbol and slot, to be printed as an end-of-line comment after the
1868 ;;; current instruction is disassembled. Returns non-NIL iff a note
1870 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate
)
1871 (declare (type offset nil-byte-offset
)
1872 (type disassem-state dstate
))
1873 (let ((obj (get-nil-indexed-object nil-byte-offset
)))
1874 (note (lambda (stream)
1875 (prin1-quoted-short obj stream
))
1879 ;;; If ADDRESS is the address of a primitive assembler routine or
1880 ;;; foreign symbol, store a note describing which one, to be printed
1881 ;;; as an end-of-line comment after the current instruction is
1882 ;;; disassembled. Returns non-NIL iff a note was recorded. If
1883 ;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made.
1884 (defun maybe-note-assembler-routine (address note-address-p dstate
)
1885 (declare (type disassem-state dstate
))
1886 (unless (typep address
'address
)
1887 (return-from maybe-note-assembler-routine nil
))
1889 (find-assembler-routine address
)
1891 (sb!sys
:sap-foreign-symbol
(sb!sys
:int-sap address
)))))
1893 (note (lambda (stream)
1895 (format stream
"#x~8,'0x: ~a" address name
)
1896 (princ name stream
)))
1900 ;;; If there's a valid mapping from OFFSET in the storage class
1901 ;;; SC-NAME to a source variable, make a note of the source-variable
1902 ;;; name, to be printed as an end-of-line comment after the current
1903 ;;; instruction is disassembled. Returns non-NIL iff a note was
1905 (defun maybe-note-single-storage-ref (offset sc-name dstate
)
1906 (declare (type offset offset
)
1907 (type symbol sc-name
)
1908 (type disassem-state dstate
))
1909 (let ((storage-location
1910 (find-valid-storage-location offset sc-name dstate
)))
1911 (when storage-location
1912 (note (lambda (stream)
1913 (princ (sb!di
:debug-var-symbol
1914 (aref (storage-info-debug-vars
1915 (seg-storage-info (dstate-segment dstate
)))
1921 ;;; If there's a valid mapping from OFFSET in the storage-base called
1922 ;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with
1923 ;;; the source-variable name, to be printed as an end-of-line comment
1924 ;;; after the current instruction is disassembled. Returns non-NIL iff
1925 ;;; a note was recorded.
1926 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate
)
1927 (declare (type offset offset
)
1928 (type symbol sb-name
)
1929 (type (or symbol string
) assoc-with
)
1930 (type disassem-state dstate
))
1931 (let ((storage-location
1932 (find-valid-storage-location offset sb-name dstate
)))
1933 (when storage-location
1934 (note (lambda (stream)
1935 (format stream
"~A = ~S"
1937 (sb!di
:debug-var-symbol
1938 (aref (dstate-debug-vars dstate
)
1939 storage-location
))))
1943 (defun maybe-note-static-symbol (offset dstate
)
1944 (dolist (symbol sb
!vm
:*static-symbols
*)
1945 (when (= (sb!kernel
:get-lisp-obj-address symbol
) offset
)
1946 (return (note (lambda (s) (prin1 symbol s
)) dstate
)))))
1948 (defun get-internal-error-name (errnum)
1949 (cdr (svref sb
!c
:*backend-internal-errors
* errnum
)))
1951 (defun get-sc-name (sc-offs)
1952 (sb!c
:location-print-name
1953 ;; FIXME: This seems like an awful lot of computation just to get a name.
1954 ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
1956 (sb!c
:make-random-tn
:kind
:normal
1957 :sc
(svref sb
!c
:*backend-sc-numbers
*
1958 (sb!c
:sc-offset-scn sc-offs
))
1959 :offset
(sb!c
:sc-offset-offset sc-offs
))))
1961 ;;; When called from an error break instruction's :DISASSEM-CONTROL (or
1962 ;;; :DISASSEM-PRINTER) function, will correctly deal with printing the
1963 ;;; arguments to the break.
1965 ;;; ERROR-PARSE-FUN should be a function that accepts:
1966 ;;; 1) a SYSTEM-AREA-POINTER
1967 ;;; 2) a BYTE-OFFSET from the SAP to begin at
1968 ;;; 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
1969 ;;; the byte length of the arguments (to avoid unnecessary consing)
1970 ;;; It should read information from the SAP starting at BYTE-OFFSET, and
1971 ;;; return four values:
1972 ;;; 1) the error number
1973 ;;; 2) the total length, in bytes, of the information
1974 ;;; 3) a list of SC-OFFSETs of the locations of the error parameters
1975 ;;; 4) a list of the length (as read from the SAP), in bytes, of each
1976 ;;; of the return values.
1977 (defun handle-break-args (error-parse-fun stream dstate
)
1978 (declare (type function error-parse-fun
)
1979 (type (or null stream
) stream
)
1980 (type disassem-state dstate
))
1981 (multiple-value-bind (errnum adjust sc-offsets lengths
)
1982 (funcall error-parse-fun
1983 (dstate-segment-sap dstate
)
1984 (dstate-next-offs dstate
)
1987 (setf (dstate-cur-offs dstate
)
1988 (dstate-next-offs dstate
))
1989 (flet ((emit-err-arg ()
1990 (let ((num (pop lengths
)))
1991 (print-notes-and-newline stream dstate
)
1992 (print-current-address stream dstate
)
1993 (print-inst num stream dstate
)
1994 (print-bytes num stream dstate
)
1995 (incf (dstate-cur-offs dstate
) num
)))
1998 (note note dstate
))))
2001 (emit-note (symbol-name (get-internal-error-name errnum
)))
2002 (dolist (sc-offs sc-offsets
)
2004 (if (= (sb!c
:sc-offset-scn sc-offs
)
2005 sb
!vm
:constant-sc-number
)
2006 (note-code-constant (* (1- (sb!c
:sc-offset-offset sc-offs
))
2009 (emit-note (get-sc-name sc-offs
))))))
2010 (incf (dstate-next-offs dstate
)