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 words)
213 ;;; entry-points (points to first function header)
215 ;;; trace-table-offset (starting from first inst, in bytes)
219 ;;; <padding to dual-word boundary>
220 ;;; start of instructions
222 ;;; fun-headers and lra's buried in here randomly
224 ;;; start of trace-table
225 ;;; <padding to dual-word boundary>
227 ;;; Function header layout (dual word aligned):
230 ;;; next pointer (next function header)
235 ;;; LRA layout (dual word aligned):
238 #!-sb-fluid
(declaim (inline words-to-bytes bytes-to-words
))
240 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
241 ;;; Convert a word-offset NUM to a byte-offset.
242 (defun words-to-bytes (num)
243 (declare (type offset num
))
244 (ash num sb
!vm
:word-shift
))
247 ;;; Convert a byte-offset NUM to a word-offset.
248 (defun bytes-to-words (num)
249 (declare (type offset num
))
250 (ash num
(- sb
!vm
:word-shift
)))
252 (defconstant lra-size
(words-to-bytes 1))
254 (defstruct (offs-hook (:copier nil
))
255 (offset 0 :type offset
)
256 (fun (missing-arg) :type function
)
257 (before-address nil
:type
(member t nil
)))
259 (defstruct (segment (:conc-name seg-
)
260 (:constructor %make-segment
)
262 (sap-maker (missing-arg)
263 :type
(function () sb
!sys
:system-area-pointer
))
264 (length 0 :type disassem-length
)
265 (virtual-location 0 :type address
)
266 (storage-info nil
:type
(or null storage-info
))
267 (code nil
:type
(or null sb
!kernel
:code-component
))
268 (hooks nil
:type list
))
269 (def!method print-object
((seg segment
) stream
)
270 (print-unreadable-object (seg stream
:type t
)
271 (let ((addr (sb!sys
:sap-int
(funcall (seg-sap-maker seg
)))))
272 (format stream
"#X~X[~W]~:[ (#X~X)~;~*~]~@[ in ~S~]"
275 (= (seg-virtual-location seg
) addr
)
276 (seg-virtual-location seg
)
281 (defun fun-self (fun)
282 (declare (type compiled-function fun
))
283 (sb!kernel
:%simple-fun-self
(sb!kernel
:%fun-fun fun
)))
285 (defun fun-code (fun)
286 (declare (type compiled-function fun
))
287 (sb!kernel
:fun-code-header
(fun-self fun
)))
289 (defun fun-next (fun)
290 (declare (type compiled-function fun
))
291 (sb!kernel
:%simple-fun-next
(sb!kernel
:%fun-fun fun
)))
293 (defun fun-address (fun)
294 (declare (type compiled-function fun
))
295 (- (sb!kernel
:get-lisp-obj-address
(sb!kernel
:%fun-fun fun
)) sb
!vm
:fun-pointer-lowtag
))
297 ;;; the offset of FUNCTION from the start of its code-component's
299 (defun fun-insts-offset (function)
300 (declare (type compiled-function function
))
301 (- (fun-address function
)
302 (sb!sys
:sap-int
(sb!kernel
:code-instructions
(fun-code function
)))))
304 ;;; the offset of FUNCTION from the start of its code-component
305 (defun fun-offset (function)
306 (declare (type compiled-function function
))
307 (words-to-bytes (sb!kernel
:get-closure-length function
)))
309 ;;;; operations on code-components (which hold the instructions for
310 ;;;; one or more functions)
312 ;;; Return the length of the instruction area in CODE-COMPONENT.
313 (defun code-inst-area-length (code-component)
314 (declare (type sb
!kernel
:code-component code-component
))
315 (sb!kernel
:code-header-ref code-component
316 sb
!vm
:code-trace-table-offset-slot
))
318 ;;; Return the address of the instruction area in CODE-COMPONENT.
319 (defun code-inst-area-address (code-component)
320 (declare (type sb
!kernel
:code-component code-component
))
321 (sb!sys
:sap-int
(sb!kernel
:code-instructions code-component
)))
323 ;;; unused as of sbcl-0.pre7.129
325 ;;; Return the first function in CODE-COMPONENT.
326 (defun code-first-function (code-component)
327 (declare (type sb
!kernel
:code-component code-component
))
328 (sb!kernel
:code-header-ref code-component
329 sb
!vm
:code-trace-table-offset-slot
))
332 (defun segment-offs-to-code-offs (offset segment
)
333 (sb!sys
:without-gcing
334 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
336 (logandc1 sb
!vm
:lowtag-mask
337 (sb!kernel
:get-lisp-obj-address
(seg-code segment
))))
338 (addr (+ offset seg-base-addr
)))
339 (declare (type address seg-base-addr code-addr addr
))
340 (- addr code-addr
))))
342 (defun code-offs-to-segment-offs (offset segment
)
343 (sb!sys
:without-gcing
344 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
346 (logandc1 sb
!vm
:lowtag-mask
347 (sb!kernel
:get-lisp-obj-address
(seg-code segment
))))
348 (addr (+ offset code-addr
)))
349 (declare (type address seg-base-addr code-addr addr
))
350 (- addr seg-base-addr
))))
352 (defun code-insts-offs-to-segment-offs (offset segment
)
353 (sb!sys
:without-gcing
354 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
356 (sb!sys
:sap-int
(sb!kernel
:code-instructions
(seg-code segment
))))
357 (addr (+ offset code-insts-addr
)))
358 (declare (type address seg-base-addr code-insts-addr addr
))
359 (- addr seg-base-addr
))))
361 (defun lra-hook (chunk stream dstate
)
362 (declare (type dchunk chunk
)
364 (type (or null stream
) stream
)
365 (type disassem-state dstate
))
366 (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate
))
367 (dstate-cur-offs dstate
))
368 (* 2 sb
!vm
:n-word-bytes
))
370 (= (sb!sys
:sap-ref-8
(dstate-segment-sap dstate
)
371 (if (eq (dstate-byte-order dstate
)
373 (dstate-cur-offs dstate
)
374 (+ (dstate-cur-offs dstate
)
376 sb
!vm
:return-pc-header-widetag
))
377 (unless (null stream
)
378 (note "possible LRA header" dstate
)))
381 ;;; Print the fun-header (entry-point) pseudo-instruction at the
382 ;;; current location in DSTATE to STREAM.
383 (defun fun-header-hook (stream dstate
)
384 (declare (type (or null stream
) stream
)
385 (type disassem-state dstate
))
386 (unless (null stream
)
387 (let* ((seg (dstate-segment dstate
))
388 (code (seg-code seg
))
391 (segment-offs-to-code-offs (dstate-cur-offs dstate
) seg
)))
393 (sb!kernel
:code-header-ref code
395 sb
!vm
:simple-fun-name-slot
)))
397 (sb!kernel
:code-header-ref code
399 sb
!vm
:simple-fun-arglist-slot
)))
401 (sb!kernel
:code-header-ref code
403 sb
!vm
:simple-fun-type-slot
))))
404 (format stream
".~A ~S~:A" 'entry name args
)
405 (note (lambda (stream)
406 (format stream
"~:S" type
)) ; use format to print NIL as ()
408 (incf (dstate-next-offs dstate
)
409 (words-to-bytes sb
!vm
:simple-fun-code-offset
)))
411 (defun alignment-hook (chunk stream dstate
)
412 (declare (type dchunk chunk
)
414 (type (or null stream
) stream
)
415 (type disassem-state dstate
))
417 (+ (seg-virtual-location (dstate-segment dstate
))
418 (dstate-cur-offs dstate
)))
419 (alignment (dstate-alignment dstate
)))
420 (unless (aligned-p location alignment
)
422 (format stream
"~A~Vt~W~%" '.align
423 (dstate-argument-column dstate
)
425 (incf(dstate-next-offs dstate
)
426 (- (align location alignment
) location
)))
429 (defun rewind-current-segment (dstate segment
)
430 (declare (type disassem-state dstate
)
431 (type segment segment
))
432 (setf (dstate-segment dstate
) segment
)
433 (setf (dstate-cur-offs-hooks dstate
)
434 (stable-sort (nreverse (copy-list (seg-hooks segment
)))
436 (or (< (offs-hook-offset oh1
) (offs-hook-offset oh2
))
437 (and (= (offs-hook-offset oh1
)
438 (offs-hook-offset oh2
))
439 (offs-hook-before-address oh1
)
440 (not (offs-hook-before-address oh2
)))))))
441 (setf (dstate-cur-offs dstate
) 0)
442 (setf (dstate-cur-labels dstate
) (dstate-labels dstate
)))
444 (defun call-offs-hooks (before-address stream dstate
)
445 (declare (type (or null stream
) stream
)
446 (type disassem-state dstate
))
447 (let ((cur-offs (dstate-cur-offs dstate
)))
448 (setf (dstate-next-offs dstate
) cur-offs
)
450 (let ((next-hook (car (dstate-cur-offs-hooks dstate
))))
451 (when (null next-hook
)
453 (let ((hook-offs (offs-hook-offset next-hook
)))
454 (when (or (> hook-offs cur-offs
)
455 (and (= hook-offs cur-offs
)
457 (not (offs-hook-before-address next-hook
))))
459 (unless (< hook-offs cur-offs
)
460 (funcall (offs-hook-fun next-hook
) stream dstate
))
461 (pop (dstate-cur-offs-hooks dstate
))
462 (unless (= (dstate-next-offs dstate
) cur-offs
)
465 (defun call-fun-hooks (chunk stream dstate
)
466 (let ((hooks (dstate-fun-hooks dstate
))
467 (cur-offs (dstate-cur-offs dstate
)))
468 (setf (dstate-next-offs dstate
) cur-offs
)
469 (dolist (hook hooks nil
)
470 (let ((prefix-p (funcall hook chunk stream dstate
)))
471 (unless (= (dstate-next-offs dstate
) cur-offs
)
472 (return prefix-p
))))))
474 (defun handle-bogus-instruction (stream dstate
)
475 (let ((alignment (dstate-alignment dstate
)))
476 (unless (null stream
)
477 (multiple-value-bind (words bytes
)
478 (truncate alignment sb
!vm
:n-word-bytes
)
480 (print-inst (* words sb
!vm
:n-word-bytes
) stream dstate
))
482 (print-inst bytes stream dstate
)))
483 (print-bytes alignment stream dstate
))
484 (incf (dstate-next-offs dstate
) alignment
)))
486 ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
487 ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE.
488 (defun map-segment-instructions (function segment dstate
&optional stream
)
489 (declare (type function function
)
490 (type segment segment
)
491 (type disassem-state dstate
)
492 (type (or null stream
) stream
))
494 (let ((ispace (get-inst-space))
495 (prefix-p nil
) ; just processed a prefix inst
496 (prefix-len 0)) ; length of any prefix instruction(s)
498 (rewind-current-segment dstate segment
)
501 (when (>= (dstate-cur-offs dstate
)
502 (seg-length (dstate-segment dstate
)))
506 (setf (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
508 (call-offs-hooks t stream dstate
)
509 (unless (or prefix-p
(null stream
))
510 (print-current-address stream dstate
))
511 (call-offs-hooks nil stream dstate
)
513 (unless (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
514 (sb!sys
:without-gcing
515 (setf (dstate-segment-sap dstate
) (funcall (seg-sap-maker segment
)))
518 (sap-ref-dchunk (dstate-segment-sap dstate
)
519 (dstate-cur-offs dstate
)
520 (dstate-byte-order dstate
))))
521 (let ((fun-prefix-p (call-fun-hooks chunk stream dstate
)))
522 (if (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
523 (setf prefix-p fun-prefix-p
)
524 (let ((inst (find-inst chunk ispace
)))
526 (handle-bogus-instruction stream dstate
))
528 (setf (dstate-inst-properties dstate
) nil
)
529 (setf (dstate-next-offs dstate
)
530 (+ (dstate-cur-offs dstate
)
532 (let ((orig-next (dstate-next-offs dstate
)))
533 (print-inst (inst-length inst
) stream dstate
:trailing-space nil
)
534 (let ((prefilter (inst-prefilter inst
))
535 (control (inst-control inst
)))
537 (funcall prefilter chunk dstate
))
539 (setf prefix-p
(null (inst-printer inst
)))
541 ;; print any instruction bytes recognized by the prefilter which calls read-suffix
542 ;; and updates next-offs
544 (let ((suffix-len (- (dstate-next-offs dstate
) orig-next
)))
545 (when (plusp suffix-len
)
546 (print-inst suffix-len stream dstate
:offset
(inst-length inst
) :trailing-space nil
))
548 (dotimes (i (- *disassem-inst-column-width
* (* 2 (+ (inst-length inst
) suffix-len prefix-len
))))
549 (write-char #\space stream
))
550 (write-char #\space stream
))
552 (setf prefix-len
(+ (inst-length inst
) suffix-len
))))
554 (funcall function chunk inst
)
557 (funcall control chunk inst stream dstate
))
560 (setf (dstate-cur-offs dstate
) (dstate-next-offs dstate
))
562 (unless (null stream
)
565 (print-notes-and-newline stream dstate
))
566 (setf (dstate-output-state dstate
) nil
)))))
568 ;;; Make an initial non-printing disassembly pass through DSTATE,
569 ;;; noting any addresses that are referenced by instructions in this
571 (defun add-segment-labels (segment dstate
)
572 ;; add labels at the beginning with a label-number of nil; we'll notice
573 ;; later and fill them in (and sort them)
574 (declare (type disassem-state dstate
))
575 (let ((labels (dstate-labels dstate
)))
576 (map-segment-instructions
578 (declare (type dchunk chunk
) (type instruction inst
))
579 (let ((labeller (inst-labeller inst
)))
581 (setf labels
(funcall labeller chunk labels dstate
)))))
584 (setf (dstate-labels dstate
) labels
)
585 ;; erase any notes that got there by accident
586 (setf (dstate-notes dstate
) nil
)))
588 ;;; If any labels in DSTATE have been added since the last call to
589 ;;; this function, give them label-numbers, enter them in the
590 ;;; hash-table, and make sure the label list is in sorted order.
591 (defun number-labels (dstate)
592 (let ((labels (dstate-labels dstate
)))
593 (when (and labels
(null (cdar labels
)))
594 ;; at least one label left un-numbered
595 (setf labels
(sort labels
#'< :key
#'car
))
597 (label-hash (dstate-label-hash dstate
)))
598 (dolist (label labels
)
599 (when (not (null (cdr label
)))
600 (setf max
(max max
(cdr label
)))))
601 (dolist (label labels
)
602 (when (null (cdr label
))
604 (setf (cdr label
) max
)
605 (setf (gethash (car label
) label-hash
)
606 (format nil
"L~W" max
)))))
607 (setf (dstate-labels dstate
) labels
))))
609 ;;; Get the instruction-space, creating it if necessary.
610 (defun get-inst-space ()
611 (let ((ispace *disassem-inst-space
*))
614 (maphash (lambda (name inst-flavs
)
615 (declare (ignore name
))
616 (dolist (flav inst-flavs
)
619 (setf ispace
(build-inst-space insts
)))
620 (setf *disassem-inst-space
* ispace
))
623 ;;;; Add global hooks.
625 (defun add-offs-hook (segment addr hook
)
626 (let ((entry (cons addr hook
)))
627 (if (null (seg-hooks segment
))
628 (setf (seg-hooks segment
) (list entry
))
629 (push entry
(cdr (last (seg-hooks segment
)))))))
631 (defun add-offs-note-hook (segment addr note
)
632 (add-offs-hook segment
634 (lambda (stream dstate
)
635 (declare (type (or null stream
) stream
)
636 (type disassem-state dstate
))
638 (note note dstate
)))))
640 (defun add-offs-comment-hook (segment addr comment
)
641 (add-offs-hook segment
643 (lambda (stream dstate
)
644 (declare (type (or null stream
) stream
)
647 (write-string ";;; " stream
)
650 (write-string comment stream
))
652 (funcall comment stream
)))
655 (defun add-fun-hook (dstate function
)
656 (push function
(dstate-fun-hooks dstate
)))
658 (defun set-location-printing-range (dstate from length
)
659 (setf (dstate-addr-print-len dstate
)
660 ;; 4 bits per hex digit
661 (ceiling (integer-length (logxor from
(+ from length
))) 4)))
663 ;;; Print the current address in DSTATE to STREAM, plus any labels that
664 ;;; correspond to it, and leave the cursor in the instruction column.
665 (defun print-current-address (stream dstate
)
666 (declare (type stream stream
)
667 (type disassem-state dstate
))
669 (+ (seg-virtual-location (dstate-segment dstate
))
670 (dstate-cur-offs dstate
)))
671 (location-column-width *disassem-location-column-width
*)
672 (plen (dstate-addr-print-len dstate
)))
675 (setf plen location-column-width
)
676 (let ((seg (dstate-segment dstate
)))
677 (set-location-printing-range dstate
678 (seg-virtual-location seg
)
680 (when (eq (dstate-output-state dstate
) :beginning
)
681 (setf plen location-column-width
))
685 (setf location-column-width
(+ 2 location-column-width
))
688 ;; print the location
689 ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
690 ;; usually avoids any consing]
691 (tab0 (- location-column-width plen
) stream
)
692 (let* ((printed-bits (* 4 plen
))
693 (printed-value (ldb (byte printed-bits
0) location
))
695 (truncate (- printed-bits
(integer-length printed-value
)) 4)))
696 (dotimes (i leading-zeros
)
697 (write-char #\
0 stream
))
698 (unless (zerop printed-value
)
699 (write printed-value
:stream stream
:base
16 :radix nil
))
700 (write-char #\
: stream
))
704 (let* ((next-label (car (dstate-cur-labels dstate
)))
705 (label-location (car next-label
)))
706 (when (or (null label-location
) (> label-location location
))
708 (unless (< label-location location
)
709 (format stream
" L~W:" (cdr next-label
)))
710 (pop (dstate-cur-labels dstate
))))
712 ;; move to the instruction column
713 (tab0 (+ location-column-width
1 label-column-width
) stream
)
716 (eval-when (:compile-toplevel
:execute
)
717 (sb!xc
:defmacro with-print-restrictions
(&rest body
)
718 `(let ((*print-pretty
* t
)
724 ;;; Print a newline to STREAM, inserting any pending notes in DSTATE
725 ;;; as end-of-line comments. If there is more than one note, a
726 ;;; separate line will be used for each one.
727 (defun print-notes-and-newline (stream dstate
)
728 (declare (type stream stream
)
729 (type disassem-state dstate
))
730 (with-print-restrictions
731 (dolist (note (dstate-notes dstate
))
732 (format stream
"~Vt " *disassem-note-column
*)
733 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
736 (write-string note stream
))
738 (funcall note stream
))))
741 (setf (dstate-notes dstate
) nil
)))
743 ;;; Print NUM instruction bytes to STREAM as hex values.
744 (defun print-inst (num stream dstate
&key
(offset 0) (trailing-space t
))
745 (let ((sap (dstate-segment-sap dstate
))
746 (start-offs (+ offset
(dstate-cur-offs dstate
))))
748 (format stream
"~2,'0x" (sb!sys
:sap-ref-8 sap
(+ offs start-offs
))))
750 (dotimes (i (- *disassem-inst-column-width
* (* 2 num
)))
751 (write-char #\space stream
))
752 (write-char #\space stream
))))
754 ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
755 (defun print-bytes (num stream dstate
)
756 (declare (type offset num
)
758 (type disassem-state dstate
))
759 (format stream
"~A~Vt" 'BYTE
(dstate-argument-column dstate
))
760 (let ((sap (dstate-segment-sap dstate
))
761 (start-offs (dstate-cur-offs dstate
)))
764 (write-string ", " stream
))
765 (format stream
"#X~2,'0x" (sb!sys
:sap-ref-8 sap
(+ offs start-offs
))))))
767 ;;; Disassemble NUM machine-words to STREAM as simple `WORD' instructions.
768 (defun print-words (num stream dstate
)
769 (declare (type offset num
)
771 (type disassem-state dstate
))
772 (format stream
"~A~Vt" 'WORD
(dstate-argument-column dstate
))
773 (let ((sap (dstate-segment-sap dstate
))
774 (start-offs (dstate-cur-offs dstate
))
775 (byte-order (dstate-byte-order dstate
)))
776 (dotimes (word-offs num
)
777 (unless (zerop word-offs
)
778 (write-string ", " stream
))
779 (let ((word 0) (bit-shift 0))
780 (dotimes (byte-offs sb
!vm
:n-word-bytes
)
785 (* word-offs sb
!vm
:n-word-bytes
)
788 (if (eq byte-order
:big-endian
)
789 (+ (ash word sb
!vm
:n-byte-bits
) byte
)
790 (+ word
(ash byte bit-shift
))))
791 (incf bit-shift sb
!vm
:n-byte-bits
)))
792 (format stream
"#X~V,'0X" (ash sb
!vm
:n-word-bits -
2) word
)))))
794 (defvar *default-dstate-hooks
* (list #'lra-hook
))
796 ;;; Make a disassembler-state object.
797 (defun make-dstate (&optional
(fun-hooks *default-dstate-hooks
*))
799 ;; FIXME: What is this for? This cannot be safe!
800 (sb!sys
:vector-sap
(coerce #() '(vector (unsigned-byte 8)))))
801 (alignment *disassem-inst-alignment-bytes
*)
803 (+ (or *disassem-opcode-column-width
* 0)
804 *disassem-location-column-width
*
806 label-column-width
)))
808 (when (> alignment
1)
809 (push #'alignment-hook fun-hooks
))
811 (%make-dstate
:segment-sap sap
813 :argument-column arg-column
815 :byte-order sb
!c
:*backend-byte-order
*)))
817 (defun add-fun-header-hooks (segment)
818 (declare (type segment segment
))
819 (do ((fun (sb!kernel
:code-header-ref
(seg-code segment
)
820 sb
!vm
:code-entry-points-slot
)
822 (length (seg-length segment
)))
824 (let ((offset (code-offs-to-segment-offs (fun-offset fun
) segment
)))
825 (when (<= 0 offset length
)
826 (push (make-offs-hook :offset offset
:fun
#'fun-header-hook
)
827 (seg-hooks segment
))))))
829 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
831 ;; FIXME: Are the objects we are taking saps for always pinned?
832 #!-sb-fluid
(declaim (inline sap-maker
))
833 (defun sap-maker (function input offset
)
834 (declare (optimize (speed 3))
835 (type (function (t) sb
!sys
:system-area-pointer
) function
)
836 (type offset offset
))
837 (let ((old-sap (sb!sys
:sap
+ (funcall function input
) offset
)))
838 (declare (type sb
!sys
:system-area-pointer old-sap
))
841 (+ (sb!sys
:sap-int
(funcall function input
)) offset
)))
842 ;; Saving the sap like this avoids consing except when the sap
843 ;; changes (because the sap-int, arith, etc., get inlined).
844 (declare (type address new-addr
))
845 (if (= (sb!sys
:sap-int old-sap
) new-addr
)
847 (setf old-sap
(sb!sys
:int-sap new-addr
)))))))
849 (defun vector-sap-maker (vector offset
)
850 (declare (optimize (speed 3))
851 (type offset offset
))
852 (sap-maker #'sb
!sys
:vector-sap vector offset
))
854 (defun code-sap-maker (code offset
)
855 (declare (optimize (speed 3))
856 (type sb
!kernel
:code-component code
)
857 (type offset offset
))
858 (sap-maker #'sb
!kernel
:code-instructions code offset
))
860 (defun memory-sap-maker (address)
861 (declare (optimize (speed 3))
862 (type address address
))
863 (let ((sap (sb!sys
:int-sap address
)))
866 ;;; Return a memory segment located at the system-area-pointer returned by
867 ;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
869 ;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
870 ;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a
871 ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
873 (defun make-segment (sap-maker length
875 code virtual-location
876 debug-fun source-form-cache
878 (declare (type (function () sb
!sys
:system-area-pointer
) sap-maker
)
879 (type disassem-length length
)
880 (type (or null address
) virtual-location
)
881 (type (or null sb
!di
:debug-fun
) debug-fun
)
882 (type (or null source-form-cache
) source-form-cache
))
887 :virtual-location
(or virtual-location
888 (sb!sys
:sap-int
(funcall sap-maker
)))
891 (add-debugging-hooks segment debug-fun source-form-cache
)
892 (add-fun-header-hooks segment
)
895 (defun make-vector-segment (vector offset
&rest args
)
896 (declare (type vector vector
)
898 (inline make-segment
))
899 (apply #'make-segment
(vector-sap-maker vector offset
) args
))
901 (defun make-code-segment (code offset length
&rest args
)
902 (declare (type sb
!kernel
:code-component code
)
904 (inline make-segment
))
905 (apply #'make-segment
(code-sap-maker code offset
) length
:code code args
))
907 (defun make-memory-segment (address &rest args
)
908 (declare (type address address
)
909 (inline make-segment
))
910 (apply #'make-segment
(memory-sap-maker address
) args
))
913 (defun print-fun-headers (function)
914 (declare (type compiled-function function
))
915 (let* ((self (fun-self function
))
916 (code (sb!kernel
:fun-code-header self
)))
917 (format t
"Code-header ~S: size: ~S, trace-table-offset: ~S~%"
919 (sb!kernel
:code-header-ref code
920 sb
!vm
:code-code-size-slot
)
921 (sb!kernel
:code-header-ref code
922 sb
!vm
:code-trace-table-offset-slot
))
923 (do ((fun (sb!kernel
:code-header-ref code sb
!vm
:code-entry-points-slot
)
926 (let ((fun-offset (sb!kernel
:get-closure-length fun
)))
927 ;; There is function header fun-offset words from the
929 (format t
"Fun-header ~S at offset ~W (words): ~S~A => ~S~%"
932 (sb!kernel
:code-header-ref
933 code
(+ fun-offset sb
!vm
:simple-fun-name-slot
))
934 (sb!kernel
:code-header-ref
935 code
(+ fun-offset sb
!vm
:simple-fun-arglist-slot
))
936 (sb!kernel
:code-header-ref
937 code
(+ fun-offset sb
!vm
:simple-fun-type-slot
)))))))
939 ;;; getting at the source code...
941 (defstruct (source-form-cache (:conc-name sfcache-
)
943 (debug-source nil
:type
(or null sb
!di
:debug-source
))
944 (toplevel-form-index -
1 :type fixnum
)
945 (toplevel-form nil
:type list
)
946 (form-number-mapping-table nil
:type
(or null
(vector list
)))
947 (last-location-retrieved nil
:type
(or null sb
!di
:code-location
))
948 (last-form-retrieved -
1 :type fixnum
))
950 (defun get-toplevel-form (debug-source tlf-index
)
951 (let ((name (sb!di
:debug-source-name debug-source
)))
952 (ecase (sb!di
:debug-source-from debug-source
)
954 (cond ((not (probe-file name
))
955 (warn "The source file ~S no longer seems to exist." name
)
958 (let ((start-positions
959 (sb!di
:debug-source-start-positions debug-source
)))
960 (cond ((null start-positions
)
961 (warn "There is no start positions map.")
964 (let* ((local-tlf-index
966 (sb!di
:debug-source-root-number
969 (aref start-positions local-tlf-index
)))
970 (with-open-file (f name
)
971 (cond ((= (sb!di
:debug-source-created debug-source
)
972 (file-write-date name
))
973 (file-position f char-offset
))
975 (warn "Source file ~S has been modified; ~@
976 using form offset instead of ~
979 (let ((*read-suppress
* t
))
980 (dotimes (i local-tlf-index
) (read f
)))))
981 (let ((*readtable
* (copy-readtable)))
982 (set-dispatch-macro-character
984 (lambda (stream sub-char
&rest rest
)
985 (declare (ignore rest sub-char
))
986 (let ((token (read stream t nil t
)))
987 (format nil
"#.~S" token
))))
991 (aref name tlf-index
)))))
993 (defun cache-valid (loc cache
)
995 (and (eq (sb!di
:code-location-debug-source loc
)
996 (sfcache-debug-source cache
))
997 (eq (sb!di
:code-location-toplevel-form-offset loc
)
998 (sfcache-toplevel-form-index cache
)))))
1000 (defun get-source-form (loc context
&optional cache
)
1001 (let* ((cache-valid (cache-valid loc cache
))
1002 (tlf-index (sb!di
:code-location-toplevel-form-offset loc
))
1003 (form-number (sb!di
:code-location-form-number loc
))
1006 (sfcache-toplevel-form cache
)
1007 (get-toplevel-form (sb!di
:code-location-debug-source loc
)
1011 (sfcache-form-number-mapping-table cache
)
1012 (sb!di
:form-number-translations toplevel-form tlf-index
))))
1013 (when (and (not cache-valid
) cache
)
1014 (setf (sfcache-debug-source cache
) (sb!di
:code-location-debug-source loc
)
1015 (sfcache-toplevel-form-index cache
) tlf-index
1016 (sfcache-toplevel-form cache
) toplevel-form
1017 (sfcache-form-number-mapping-table cache
) mapping-table
))
1018 (cond ((null toplevel-form
)
1020 ((>= form-number
(length mapping-table
))
1021 (warn "bogus form-number in form! The source file has probably ~@
1022 been changed too much to cope with.")
1024 ;; Disable future warnings.
1025 (setf (sfcache-toplevel-form cache
) nil
))
1029 (setf (sfcache-last-location-retrieved cache
) loc
)
1030 (setf (sfcache-last-form-retrieved cache
) form-number
))
1031 (sb!di
:source-path-context toplevel-form
1032 (aref mapping-table form-number
)
1035 (defun get-different-source-form (loc context
&optional cache
)
1036 (if (and (cache-valid loc cache
)
1037 (or (= (sb!di
:code-location-form-number loc
)
1038 (sfcache-last-form-retrieved cache
))
1039 (and (sfcache-last-location-retrieved cache
)
1040 (sb!di
:code-location
=
1042 (sfcache-last-location-retrieved cache
)))))
1044 (values (get-source-form loc context cache
) t
)))
1046 ;;;; stuff to use debugging info to augment the disassembly
1048 (defun code-fun-map (code)
1049 (declare (type sb
!kernel
:code-component code
))
1050 (sb!c
::compiled-debug-info-fun-map
(sb!kernel
:%code-debug-info code
)))
1052 (defstruct (location-group (:copier nil
))
1053 (locations #() :type
(vector (or list fixnum
))))
1055 (defstruct (storage-info (:copier nil
))
1056 (groups nil
:type list
) ; alist of (name . location-group)
1057 (debug-vars #() :type vector
))
1059 ;;; Return the vector of DEBUG-VARs currently associated with DSTATE.
1060 (defun dstate-debug-vars (dstate)
1061 (declare (type disassem-state dstate
))
1062 (storage-info-debug-vars (seg-storage-info (dstate-segment dstate
))))
1064 ;;; Given the OFFSET of a location within the location-group called
1065 ;;; LG-NAME, see whether there's a current mapping to a source
1066 ;;; variable in DSTATE, and if so, return the offset of that variable
1067 ;;; in the current debug-var vector.
1068 (defun find-valid-storage-location (offset lg-name dstate
)
1069 (declare (type offset offset
)
1070 (type symbol lg-name
)
1071 (type disassem-state dstate
))
1072 (let* ((storage-info
1073 (seg-storage-info (dstate-segment dstate
)))
1076 (cdr (assoc lg-name
(storage-info-groups storage-info
)))))
1078 (dstate-current-valid-locations dstate
)))
1080 (not (null currently-valid
))
1081 (let ((locations (location-group-locations location-group
)))
1082 (and (< offset
(length locations
))
1083 (let ((used-by (aref locations offset
)))
1085 (let ((debug-var-num
1089 (zerop (bit currently-valid used-by
)))
1095 (bit currently-valid num
)))
1100 ;; Found a valid storage reference!
1101 ;; can't use it again until it's revalidated...
1102 (setf (bit (dstate-current-valid-locations
1109 ;;; Return a new vector which has the same contents as the old one
1110 ;;; VEC, plus new cells (for a total size of NEW-LEN). The additional
1111 ;;; elements are initialized to INITIAL-ELEMENT.
1112 (defun grow-vector (vec new-len
&optional initial-element
)
1113 (declare (type vector vec
)
1114 (type fixnum new-len
))
1116 (make-sequence `(vector ,(array-element-type vec
) ,new-len
)
1118 :initial-element initial-element
)))
1119 (dotimes (i (length vec
))
1120 (setf (aref new i
) (aref vec i
)))
1123 ;;; Return a STORAGE-INFO struction describing the object-to-source
1124 ;;; variable mappings from DEBUG-FUN.
1125 (defun storage-info-for-debug-fun (debug-fun)
1126 (declare (type sb
!di
:debug-fun debug-fun
))
1127 (let ((sc-vec sb
!c
::*backend-sc-numbers
*)
1129 (debug-vars (sb!di
::debug-fun-debug-vars
1132 (dotimes (debug-var-offset
1134 (make-storage-info :groups groups
1135 :debug-vars debug-vars
))
1136 (let ((debug-var (aref debug-vars debug-var-offset
)))
1138 (format t
";;; At offset ~W: ~S~%" debug-var-offset debug-var
)
1140 (sb!di
::compiled-debug-var-sc-offset debug-var
))
1143 (sb!c
:sc-sb
(aref sc-vec
1144 (sb!c
:sc-offset-scn sc-offset
))))))
1146 (format t
";;; SET: ~S[~W]~%"
1147 sb-name
(sb!c
:sc-offset-offset sc-offset
))
1148 (unless (null sb-name
)
1149 (let ((group (cdr (assoc sb-name groups
))))
1151 (setf group
(make-location-group))
1152 (push `(,sb-name .
,group
) groups
))
1153 (let* ((locations (location-group-locations group
))
1154 (length (length locations
))
1155 (offset (sb!c
:sc-offset-offset sc-offset
)))
1156 (when (>= offset length
)
1158 (grow-vector locations
1162 (location-group-locations group
)
1164 (let ((already-there (aref locations offset
)))
1165 (cond ((null already-there
)
1166 (setf (aref locations offset
) debug-var-offset
))
1167 ((eql already-there debug-var-offset
))
1169 (if (listp already-there
)
1170 (pushnew debug-var-offset
1171 (aref locations offset
))
1172 (setf (aref locations offset
)
1173 (list debug-var-offset
1178 (defun source-available-p (debug-fun)
1180 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1181 (declare (ignore block
))
1183 (sb!di
:no-debug-blocks
() nil
)))
1185 (defun print-block-boundary (stream dstate
)
1186 (let ((os (dstate-output-state dstate
)))
1187 (when (not (eq os
:beginning
))
1188 (when (not (eq os
:block-boundary
))
1190 (setf (dstate-output-state dstate
)
1193 ;;; Add hooks to track the source code in SEGMENT during disassembly.
1194 ;;; SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
1195 ;;; structure, in which case it is used to cache forms from files.
1196 (defun add-source-tracking-hooks (segment debug-fun
&optional sfcache
)
1197 (declare (type segment segment
)
1198 (type (or null sb
!di
:debug-fun
) debug-fun
)
1199 (type (or null source-form-cache
) sfcache
))
1200 (let ((last-block-pc -
1))
1201 (flet ((add-hook (pc fun
&optional before-address
)
1202 (push (make-offs-hook
1203 :offset pc
;; ### FIX to account for non-zero offs in code
1205 :before-address before-address
)
1206 (seg-hooks segment
))))
1208 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1209 (let ((first-location-in-block-p t
))
1210 (sb!di
:do-debug-block-locations
(loc block
)
1211 (let ((pc (sb!di
::compiled-code-location-pc loc
)))
1213 ;; Put blank lines in at block boundaries
1214 (when (and first-location-in-block-p
1215 (/= pc last-block-pc
))
1216 (setf first-location-in-block-p nil
)
1218 (lambda (stream dstate
)
1219 (print-block-boundary stream dstate
))
1221 (setf last-block-pc pc
))
1223 ;; Print out corresponding source; this information is not
1224 ;; all that accurate, but it's better than nothing
1225 (unless (zerop (sb!di
:code-location-form-number loc
))
1226 (multiple-value-bind (form new
)
1227 (get-different-source-form loc
0 sfcache
)
1229 (let ((at-block-begin (= pc last-block-pc
)))
1232 (lambda (stream dstate
)
1233 (declare (ignore dstate
))
1235 (unless at-block-begin
1237 (format stream
";;; [~W] "
1238 (sb!di
:code-location-form-number
1240 (prin1-short form stream
)
1245 ;; Keep track of variable live-ness as best we can.
1247 (copy-seq (sb!di
::compiled-code-location-live-set
1251 (lambda (stream dstate
)
1252 (declare (ignore stream
))
1253 (setf (dstate-current-valid-locations dstate
)
1256 (note (lambda (stream)
1257 (let ((*print-length
* nil
))
1258 (format stream
"live set: ~S"
1262 (sb!di
:no-debug-blocks
() nil
)))))
1264 (defun add-debugging-hooks (segment debug-fun
&optional sfcache
)
1266 (setf (seg-storage-info segment
)
1267 (storage-info-for-debug-fun debug-fun
))
1268 (add-source-tracking-hooks segment debug-fun sfcache
)
1269 (let ((kind (sb!di
:debug-fun-kind debug-fun
)))
1270 (flet ((add-new-hook (n)
1271 (push (make-offs-hook
1273 :fun
(lambda (stream dstate
)
1274 (declare (ignore stream
))
1276 (seg-hooks segment
))))
1280 (add-new-hook "no-arg-parsing entry point"))
1282 (add-new-hook (lambda (stream)
1283 (format stream
"~S entry point" kind
)))))))))
1285 ;;; Return a list of the segments of memory containing machine code
1286 ;;; instructions for FUNCTION.
1287 (defun get-fun-segments (function)
1288 (declare (type compiled-function function
))
1289 (let* ((code (fun-code function
))
1290 (fun-map (code-fun-map code
))
1291 (fname (sb!kernel
:%simple-fun-name function
))
1292 (sfcache (make-source-form-cache)))
1293 (let ((first-block-seen-p nil
)
1294 (nil-block-seen-p nil
)
1296 (last-debug-fun nil
)
1298 (flet ((add-seg (offs len df
)
1300 (push (make-code-segment code offs len
1302 :source-form-cache sfcache
)
1304 (dotimes (fmap-index (length fun-map
))
1305 (let ((fmap-entry (aref fun-map fmap-index
)))
1306 (etypecase fmap-entry
1308 (when first-block-seen-p
1309 (add-seg last-offset
1310 (- fmap-entry last-offset
)
1312 (setf last-debug-fun nil
))
1313 (setf last-offset fmap-entry
))
1314 (sb!c
::compiled-debug-fun
1315 (let ((name (sb!c
::compiled-debug-fun-name fmap-entry
))
1316 (kind (sb!c
::compiled-debug-fun-kind fmap-entry
)))
1318 (format t
";;; SAW ~S ~S ~S,~S ~W,~W~%"
1319 name kind first-block-seen-p nil-block-seen-p
1321 (sb!c
::compiled-debug-fun-start-pc fmap-entry
))
1322 (cond (#+nil
(eq last-offset fun-offset
)
1323 (and (equal name fname
) (not first-block-seen-p
))
1324 (setf first-block-seen-p t
))
1325 ((eq kind
:external
)
1326 (when first-block-seen-p
1329 (when nil-block-seen-p
1331 (when first-block-seen-p
1332 (setf nil-block-seen-p t
))))
1333 (setf last-debug-fun
1334 (sb!di
::make-compiled-debug-fun fmap-entry code
)))))))
1335 (let ((max-offset (code-inst-area-length code
)))
1336 (when (and first-block-seen-p last-debug-fun
)
1337 (add-seg last-offset
1338 (- max-offset last-offset
)
1341 (let ((offs (fun-insts-offset function
)))
1343 (make-code-segment code offs
(- max-offset offs
))))
1344 (nreverse segments
)))))))
1346 ;;; Return a list of the segments of memory containing machine code
1347 ;;; instructions for the code-component CODE. If START-OFFSET and/or
1348 ;;; LENGTH is supplied, only that part of the code-segment is used
1349 ;;; (but these are constrained to lie within the code-segment).
1350 (defun get-code-segments (code
1353 (length (code-inst-area-length code
)))
1354 (declare (type sb
!kernel
:code-component code
)
1355 (type offset start-offset
)
1356 (type disassem-length length
))
1357 (let ((segments nil
))
1359 (let ((fun-map (code-fun-map code
))
1360 (sfcache (make-source-form-cache)))
1361 (let ((last-offset 0)
1362 (last-debug-fun nil
))
1363 (flet ((add-seg (offs len df
)
1364 (let* ((restricted-offs
1365 (min (max start-offset offs
)
1366 (+ start-offset length
)))
1368 (- (min (max start-offset
(+ offs len
))
1369 (+ start-offset length
))
1371 (when (> restricted-len
0)
1372 (push (make-code-segment code
1373 restricted-offs restricted-len
1375 :source-form-cache sfcache
)
1377 (dotimes (fun-map-index (length fun-map
))
1378 (let ((fun-map-entry (aref fun-map fun-map-index
)))
1379 (etypecase fun-map-entry
1381 (add-seg last-offset
(- fun-map-entry last-offset
)
1383 (setf last-debug-fun nil
)
1384 (setf last-offset fun-map-entry
))
1385 (sb!c
::compiled-debug-fun
1386 (setf last-debug-fun
1387 (sb!di
::make-compiled-debug-fun fun-map-entry
1389 (when last-debug-fun
1390 (add-seg last-offset
1391 (- (code-inst-area-length code
) last-offset
)
1392 last-debug-fun
))))))
1394 (make-code-segment code start-offset length
)
1395 (nreverse segments
))))
1397 ;;; Return two values: the amount by which the last instruction in the
1398 ;;; segment goes past the end of the segment, and the offset of the
1399 ;;; end of the segment from the beginning of that instruction. If all
1400 ;;; instructions fit perfectly, return 0 and 0.
1401 (defun segment-overflow (segment dstate
)
1402 (declare (type segment segment
)
1403 (type disassem-state dstate
))
1404 (let ((seglen (seg-length segment
))
1406 (map-segment-instructions (lambda (chunk inst
)
1407 (declare (ignore chunk inst
))
1408 (setf last-start
(dstate-cur-offs dstate
)))
1411 (values (- (dstate-cur-offs dstate
) seglen
)
1412 (- seglen last-start
))))
1414 ;;; Compute labels for all the memory segments in SEGLIST and adds
1415 ;;; them to DSTATE. It's important to call this function with all the
1416 ;;; segments you're interested in, so that it can find references from
1418 (defun label-segments (seglist dstate
)
1419 (declare (type list seglist
)
1420 (type disassem-state dstate
))
1421 (dolist (seg seglist
)
1422 (add-segment-labels seg dstate
))
1423 ;; Now remove any labels that don't point anywhere in the segments
1425 (setf (dstate-labels dstate
)
1426 (remove-if (lambda (lab)
1429 (let ((start (seg-virtual-location seg
)))
1432 (+ start
(seg-length seg
)))))
1434 (dstate-labels dstate
))))
1436 ;;; Disassemble the machine code instructions in SEGMENT to STREAM.
1437 (defun disassemble-segment (segment stream dstate
)
1438 (declare (type segment segment
)
1439 (type stream stream
)
1440 (type disassem-state dstate
))
1441 (let ((*print-pretty
* nil
)) ; otherwise the pp conses hugely
1442 (number-labels dstate
)
1443 (map-segment-instructions
1444 (lambda (chunk inst
)
1445 (declare (type dchunk chunk
) (type instruction inst
))
1446 (let ((printer (inst-printer inst
)))
1448 (funcall printer chunk inst stream dstate
))))
1453 ;;; Disassemble the machine code instructions in each memory segment
1454 ;;; in SEGMENTS in turn to STREAM.
1455 (defun disassemble-segments (segments stream dstate
)
1456 (declare (type list segments
)
1457 (type stream stream
)
1458 (type disassem-state dstate
))
1459 (unless (null segments
)
1460 (let ((first (car segments
))
1461 (last (car (last segments
))))
1462 (set-location-printing-range dstate
1463 (seg-virtual-location first
)
1464 (- (+ (seg-virtual-location last
)
1466 (seg-virtual-location first
)))
1467 (setf (dstate-output-state dstate
) :beginning
)
1468 (dolist (seg segments
)
1469 (disassemble-segment seg stream dstate
)))))
1471 ;;;; top level functions
1473 ;;; Disassemble the machine code instructions for FUNCTION.
1474 (defun disassemble-fun (fun &key
1475 (stream *standard-output
*)
1477 (declare (type compiled-function fun
)
1478 (type stream stream
)
1479 (type (member t nil
) use-labels
))
1480 (let* ((dstate (make-dstate))
1481 (segments (get-fun-segments fun
)))
1483 (label-segments segments dstate
))
1484 (disassemble-segments segments stream dstate
)))
1486 ;;; FIXME: We probably don't need this any more now that there are
1487 ;;; no interpreted functions, only compiled ones.
1488 (defun compile-function-lambda-expr (function)
1489 (declare (type function function
))
1490 (multiple-value-bind (lambda closurep name
)
1491 (function-lambda-expression function
)
1492 (declare (ignore name
))
1494 (error "can't compile a lexical closure"))
1495 (compile nil lambda
)))
1497 (defun valid-extended-function-designator-for-disassemble-p (thing)
1498 (cond ((legal-fun-name-p thing
)
1499 (compiled-fun-or-lose (fdefinition thing
) thing
))
1501 ((sb!eval
:interpreted-function-p thing
)
1502 (compile nil thing
))
1506 (eq (car thing
) 'lambda
))
1507 (compile nil thing
))
1510 (defun compiled-fun-or-lose (thing &optional
(name thing
))
1511 (let ((fun (valid-extended-function-designator-for-disassemble-p thing
)))
1514 (error 'simple-type-error
1516 :expected-type
'(satisfies valid-extended-function-designator-for-disassemble-p
)
1517 :format-control
"can't make a compiled function from ~S"
1518 :format-arguments
(list name
)))))
1520 (defun disassemble (object &key
1521 (stream *standard-output
*)
1524 "Disassemble the compiled code associated with OBJECT, which can be a
1525 function, a lambda expression, or a symbol with a function definition. If
1526 it is not already compiled, the compiler is called to produce something to
1528 (declare (type (or function symbol cons
) object
)
1529 (type (or (member t
) stream
) stream
)
1530 (type (member t nil
) use-labels
))
1531 (pprint-logical-block (*standard-output
* nil
:per-line-prefix
"; ")
1532 (disassemble-fun (compiled-fun-or-lose object
)
1534 :use-labels use-labels
)
1537 ;;; Disassembles the given area of memory starting at ADDRESS and
1538 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
1539 ;;; could move during a GC, you'd better disable it around the call to
1541 (defun disassemble-memory (address
1544 (stream *standard-output
*)
1547 (declare (type (or address sb
!sys
:system-area-pointer
) address
)
1548 (type disassem-length length
)
1549 (type stream stream
)
1550 (type (or null sb
!kernel
:code-component
) code-component
)
1551 (type (member t nil
) use-labels
))
1553 (if (sb!sys
:system-area-pointer-p address
)
1554 (sb!sys
:sap-int address
)
1556 (dstate (make-dstate))
1562 (sb!kernel
:code-instructions code-component
)))))
1563 (when (or (< code-offs
0)
1564 (> code-offs
(code-inst-area-length code-component
)))
1565 (error "address ~X not in the code component ~S"
1566 address code-component
))
1567 (get-code-segments code-component code-offs length
))
1568 (list (make-memory-segment address length
)))))
1570 (label-segments segments dstate
))
1571 (disassemble-segments segments stream dstate
)))
1573 ;;; Disassemble the machine code instructions associated with
1574 ;;; CODE-COMPONENT (this may include multiple entry points).
1575 (defun disassemble-code-component (code-component &key
1576 (stream *standard-output
*)
1578 (declare (type (or null sb
!kernel
:code-component compiled-function
)
1580 (type stream stream
)
1581 (type (member t nil
) use-labels
))
1582 (let* ((code-component
1583 (if (functionp code-component
)
1584 (fun-code code-component
)
1586 (dstate (make-dstate))
1587 (segments (get-code-segments code-component
)))
1589 (label-segments segments dstate
))
1590 (disassemble-segments segments stream dstate
)))
1592 ;;; code for making useful segments from arbitrary lists of code-blocks
1594 ;;; the maximum size of an instruction. Note that this includes
1595 ;;; pseudo-instructions like error traps with their associated
1596 ;;; operands, so it should be big enough to include them, i.e. it's
1597 ;;; not just 4 on a risc machine!
1598 (defconstant max-instruction-size
16)
1600 (defun add-block-segments (seg-code-block
1605 (declare (type list seglist
)
1606 (type integer location
)
1607 (type (or null
(vector (unsigned-byte 8))) connecting-vec
)
1608 (type disassem-state dstate
))
1609 (flet ((addit (seg overflow
)
1610 (let ((length (+ (seg-length seg
) overflow
)))
1612 (setf (seg-length seg
) length
)
1613 (incf location length
)
1614 (push seg seglist
)))))
1615 (let ((connecting-overflow 0)
1616 (amount (length seg-code-block
)))
1617 (when connecting-vec
1618 ;; Tack on some of the new block to the old overflow vector.
1619 (let* ((beginning-of-block-amount
1620 (if seg-code-block
(min max-instruction-size amount
) 0))
1624 '(vector (unsigned-byte 8))
1626 (subseq seg-code-block
0 beginning-of-block-amount
))
1628 (when (and (< (length connecting-vec
) max-instruction-size
)
1629 (not (null seg-code-block
)))
1630 (return-from add-block-segments
1631 ;; We want connecting vectors to be large enough to hold
1632 ;; any instruction, and since the current seg-code-block
1633 ;; wasn't large enough to do this (and is now entirely
1634 ;; on the end of the overflow-vector), just save it for
1636 (values seglist location connecting-vec
)))
1637 (when (> (length connecting-vec
) 0)
1639 (make-vector-segment connecting-vec
1641 (- (length connecting-vec
)
1642 beginning-of-block-amount
)
1643 :virtual-location location
)))
1644 (setf connecting-overflow
(segment-overflow seg dstate
))
1645 (addit seg connecting-overflow
)))))
1646 (cond ((null seg-code-block
)
1647 ;; nothing more to add
1648 (values seglist location nil
))
1649 ((< (- amount connecting-overflow
) max-instruction-size
)
1650 ;; We can't create a segment with the minimum size
1651 ;; required for an instruction, so just keep on accumulating
1652 ;; in the overflow vector for the time-being.
1655 (subseq seg-code-block connecting-overflow amount
)))
1657 ;; Put as much as we can into a new segment, and the rest
1658 ;; into the overflow-vector.
1659 (let* ((initial-length
1660 (- amount connecting-overflow max-instruction-size
))
1662 (make-vector-segment seg-code-block
1665 :virtual-location location
))
1667 (segment-overflow seg dstate
)))
1668 (addit seg overflow
)
1671 (subseq seg-code-block
1672 (+ connecting-overflow
(seg-length seg
))
1675 ;;;; code to disassemble assembler segments
1677 (defun assem-segment-to-disassem-segments (assem-segment dstate
)
1678 (declare (type sb
!assem
:segment assem-segment
)
1679 (type disassem-state dstate
))
1681 (disassem-segments nil
)
1682 (connecting-vec nil
))
1683 (sb!assem
:on-segment-contents-vectorly
1685 (lambda (seg-code-block)
1686 (multiple-value-setq (disassem-segments location connecting-vec
)
1687 (add-block-segments seg-code-block
1692 (when connecting-vec
1693 (setf disassem-segments
1694 (add-block-segments nil
1699 (sort disassem-segments
#'< :key
#'seg-virtual-location
)))
1701 ;;; Disassemble the machine code instructions associated with
1702 ;;; ASSEM-SEGMENT (of type assem:segment).
1703 (defun disassemble-assem-segment (assem-segment stream
)
1704 (declare (type sb
!assem
:segment assem-segment
)
1705 (type stream stream
))
1706 (let* ((dstate (make-dstate))
1708 (assem-segment-to-disassem-segments assem-segment dstate
)))
1709 (label-segments disassem-segments dstate
)
1710 (disassemble-segments disassem-segments stream dstate
)))
1712 ;;; routines to find things in the Lisp environment
1714 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
1715 ;;; in a symbol object that we know about
1716 (defparameter *grokked-symbol-slots
*
1717 (sort `((,sb
!vm
:symbol-value-slot . symbol-value
)
1718 (,sb
!vm
:symbol-plist-slot . symbol-plist
)
1719 (,sb
!vm
:symbol-name-slot . symbol-name
)
1720 (,sb
!vm
:symbol-package-slot . symbol-package
))
1724 ;;; Given ADDRESS, try and figure out if which slot of which symbol is
1725 ;;; being referred to. Of course we can just give up, so it's not a
1726 ;;; big deal... Return two values, the symbol and the name of the
1727 ;;; access function of the slot.
1728 (defun grok-symbol-slot-ref (address)
1729 (declare (type address address
))
1730 (if (not (aligned-p address sb
!vm
:n-word-bytes
))
1732 (do ((slots-tail *grokked-symbol-slots
* (cdr slots-tail
)))
1735 (let* ((field (car slots-tail
))
1736 (slot-offset (words-to-bytes (car field
)))
1737 (maybe-symbol-addr (- address slot-offset
))
1739 (sb!kernel
:make-lisp-obj
1740 (+ maybe-symbol-addr sb
!vm
:other-pointer-lowtag
))))
1741 (when (symbolp maybe-symbol
)
1742 (return (values maybe-symbol
(cdr field
))))))))
1744 (defvar *address-of-nil-object
* (sb!kernel
:get-lisp-obj-address nil
))
1746 ;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
1747 ;;; which symbol is being referred to. Of course we can just give up,
1748 ;;; so it's not a big deal... Return two values, the symbol and the
1749 ;;; access function.
1750 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1751 (declare (type offset byte-offset
))
1752 (grok-symbol-slot-ref (+ *address-of-nil-object
* byte-offset
)))
1754 ;;; Return the Lisp object located BYTE-OFFSET from NIL.
1755 (defun get-nil-indexed-object (byte-offset)
1756 (declare (type offset byte-offset
))
1757 (sb!kernel
:make-lisp-obj
(+ *address-of-nil-object
* byte-offset
)))
1759 ;;; Return two values; the Lisp object located at BYTE-OFFSET in the
1760 ;;; constant area of the code-object in the current segment and T, or
1761 ;;; NIL and NIL if there is no code-object in the current segment.
1762 (defun get-code-constant (byte-offset dstate
)
1764 (declare (type offset byte-offset
)
1765 (type disassem-state dstate
))
1766 (let ((code (seg-code (dstate-segment dstate
))))
1769 (sb!kernel
:code-header-ref code
1771 sb
!vm
:other-pointer-lowtag
)
1772 (- sb
!vm
:word-shift
)))
1776 (defun get-code-constant-absolute (addr dstate
)
1777 (declare (type address addr
))
1778 (declare (type disassem-state dstate
))
1779 (let ((code (seg-code (dstate-segment dstate
))))
1781 (return-from get-code-constant-absolute
(values nil nil
)))
1782 (let ((code-size (ash (sb!kernel
:get-header-data code
) sb
!vm
:word-shift
)))
1783 (sb!sys
:without-gcing
1784 (let ((code-addr (- (sb!kernel
:get-lisp-obj-address code
)
1785 sb
!vm
:other-pointer-lowtag
)))
1786 (if (or (< addr code-addr
) (>= addr
(+ code-addr code-size
)))
1788 (values (sb!kernel
:code-header-ref
1790 (ash (- addr code-addr
) (- sb
!vm
:word-shift
)))
1793 (defvar *assembler-routines-by-addr
* nil
)
1795 (defvar *foreign-symbols-by-addr
* nil
)
1797 ;;; Build an address-name hash-table from the name-address hash
1798 (defun invert-address-hash (htable &optional
(addr-hash (make-hash-table)))
1799 (maphash (lambda (name address
)
1800 (setf (gethash address addr-hash
) name
))
1804 ;;; Return the name of the primitive Lisp assembler routine or foreign
1805 ;;; symbol located at ADDRESS, or NIL if there isn't one.
1806 (defun find-assembler-routine (address)
1807 (declare (type address address
))
1808 (when (null *assembler-routines-by-addr
*)
1809 (setf *assembler-routines-by-addr
*
1810 (invert-address-hash sb
!fasl
:*assembler-routines
*))
1811 (setf *assembler-routines-by-addr
*
1812 (invert-address-hash sb
!sys
:*static-foreign-symbols
*
1813 *assembler-routines-by-addr
*)))
1814 (gethash address
*assembler-routines-by-addr
*))
1816 ;;;; some handy function for machine-dependent code to use...
1818 #!-sb-fluid
(declaim (maybe-inline sap-ref-int read-suffix
))
1820 (defun sap-ref-int (sap offset length byte-order
)
1821 (declare (type sb
!sys
:system-area-pointer sap
)
1822 (type (unsigned-byte 16) offset
)
1823 (type (member 1 2 4 8) length
)
1824 (type (member :little-endian
:big-endian
) byte-order
)
1825 (optimize (speed 3) (safety 0)))
1827 (1 (sb!sys
:sap-ref-8 sap offset
))
1828 (2 (if (eq byte-order
:big-endian
)
1829 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 8)
1830 (sb!sys
:sap-ref-8 sap
(+ offset
1)))
1831 (+ (ash (sb!sys
:sap-ref-8 sap
(+ offset
1)) 8)
1832 (sb!sys
:sap-ref-8 sap offset
))))
1833 (4 (if (eq byte-order
:big-endian
)
1834 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 24)
1835 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 16)
1836 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 8)
1837 (sb!sys
:sap-ref-8 sap
(+ 3 offset
)))
1838 (+ (sb!sys
:sap-ref-8 sap offset
)
1839 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 8)
1840 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 16)
1841 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 24))))
1842 (8 (if (eq byte-order
:big-endian
)
1843 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 56)
1844 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 48)
1845 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 40)
1846 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 32)
1847 (ash (sb!sys
:sap-ref-8 sap
(+ 4 offset
)) 24)
1848 (ash (sb!sys
:sap-ref-8 sap
(+ 5 offset
)) 16)
1849 (ash (sb!sys
:sap-ref-8 sap
(+ 6 offset
)) 8)
1850 (sb!sys
:sap-ref-8 sap
(+ 7 offset
)))
1851 (+ (sb!sys
:sap-ref-8 sap offset
)
1852 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 8)
1853 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 16)
1854 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 24)
1855 (ash (sb!sys
:sap-ref-8 sap
(+ 4 offset
)) 32)
1856 (ash (sb!sys
:sap-ref-8 sap
(+ 5 offset
)) 40)
1857 (ash (sb!sys
:sap-ref-8 sap
(+ 6 offset
)) 48)
1858 (ash (sb!sys
:sap-ref-8 sap
(+ 7 offset
)) 56))))))
1860 (defun read-suffix (length dstate
)
1861 (declare (type (member 8 16 32 64) length
)
1862 (type disassem-state dstate
)
1863 (optimize (speed 3) (safety 0)))
1864 (let ((length (ecase length
(8 1) (16 2) (32 4) (64 8))))
1865 (declare (type (unsigned-byte 4) length
))
1867 (sap-ref-int (dstate-segment-sap dstate
)
1868 (dstate-next-offs dstate
)
1870 (dstate-byte-order dstate
))
1871 (incf (dstate-next-offs dstate
) length
))))
1873 ;;;; optional routines to make notes about code
1875 ;;; Store NOTE (which can be either a string or a function with a
1876 ;;; single stream argument) to be printed as an end-of-line comment
1877 ;;; after the current instruction is disassembled.
1878 (defun note (note dstate
)
1879 (declare (type (or string function
) note
)
1880 (type disassem-state dstate
))
1881 (push note
(dstate-notes dstate
)))
1883 (defun prin1-short (thing stream
)
1884 (with-print-restrictions
1885 (prin1 thing stream
)))
1887 (defun prin1-quoted-short (thing stream
)
1888 (if (self-evaluating-p thing
)
1889 (prin1-short thing stream
)
1890 (prin1-short `',thing stream
)))
1892 ;;; Store a note about the lisp constant located BYTE-OFFSET bytes
1893 ;;; from the current code-component, to be printed as an end-of-line
1894 ;;; comment after the current instruction is disassembled.
1895 (defun note-code-constant (byte-offset dstate
)
1896 (declare (type offset byte-offset
)
1897 (type disassem-state dstate
))
1898 (multiple-value-bind (const valid
)
1899 (get-code-constant byte-offset dstate
)
1901 (note (lambda (stream)
1902 (prin1-quoted-short const stream
))
1906 ;;; Store a note about the lisp constant located at ADDR in the
1907 ;;; current code-component, to be printed as an end-of-line comment
1908 ;;; after the current instruction is disassembled.
1909 (defun note-code-constant-absolute (addr dstate
)
1910 (declare (type address addr
)
1911 (type disassem-state dstate
))
1912 (multiple-value-bind (const valid
)
1913 (get-code-constant-absolute addr dstate
)
1915 (note (lambda (stream)
1916 (prin1-quoted-short const stream
))
1918 (values const valid
)))
1920 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1921 ;;; constant NIL is a valid slot in a symbol, store a note describing
1922 ;;; which symbol and slot, to be printed as an end-of-line comment
1923 ;;; after the current instruction is disassembled. Returns non-NIL iff
1924 ;;; a note was recorded.
1925 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate
)
1926 (declare (type offset nil-byte-offset
)
1927 (type disassem-state dstate
))
1928 (multiple-value-bind (symbol access-fun
)
1929 (grok-nil-indexed-symbol-slot-ref nil-byte-offset
)
1931 (note (lambda (stream)
1932 (prin1 (if (eq access-fun
'symbol-value
)
1934 `(,access-fun
',symbol
))
1939 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1940 ;;; constant NIL is a valid lisp object, store a note describing which
1941 ;;; symbol and slot, to be printed as an end-of-line comment after the
1942 ;;; current instruction is disassembled. Returns non-NIL iff a note
1944 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate
)
1945 (declare (type offset nil-byte-offset
)
1946 (type disassem-state dstate
))
1947 (let ((obj (get-nil-indexed-object nil-byte-offset
)))
1948 (note (lambda (stream)
1949 (prin1-quoted-short obj stream
))
1953 ;;; If ADDRESS is the address of a primitive assembler routine or
1954 ;;; foreign symbol, store a note describing which one, to be printed
1955 ;;; as an end-of-line comment after the current instruction is
1956 ;;; disassembled. Returns non-NIL iff a note was recorded. If
1957 ;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made.
1958 (defun maybe-note-assembler-routine (address note-address-p dstate
)
1959 (declare (type disassem-state dstate
))
1960 (unless (typep address
'address
)
1961 (return-from maybe-note-assembler-routine nil
))
1963 (find-assembler-routine address
)
1965 (sb!sys
:sap-foreign-symbol
(sb!sys
:int-sap address
)))))
1967 (note (lambda (stream)
1969 (format stream
"#x~8,'0x: ~a" address name
)
1970 (princ name stream
)))
1974 ;;; If there's a valid mapping from OFFSET in the storage class
1975 ;;; SC-NAME to a source variable, make a note of the source-variable
1976 ;;; name, to be printed as an end-of-line comment after the current
1977 ;;; instruction is disassembled. Returns non-NIL iff a note was
1979 (defun maybe-note-single-storage-ref (offset sc-name dstate
)
1980 (declare (type offset offset
)
1981 (type symbol sc-name
)
1982 (type disassem-state dstate
))
1983 (let ((storage-location
1984 (find-valid-storage-location offset sc-name dstate
)))
1985 (when storage-location
1986 (note (lambda (stream)
1987 (princ (sb!di
:debug-var-symbol
1988 (aref (storage-info-debug-vars
1989 (seg-storage-info (dstate-segment dstate
)))
1995 ;;; If there's a valid mapping from OFFSET in the storage-base called
1996 ;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with
1997 ;;; the source-variable name, to be printed as an end-of-line comment
1998 ;;; after the current instruction is disassembled. Returns non-NIL iff
1999 ;;; a note was recorded.
2000 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate
)
2001 (declare (type offset offset
)
2002 (type symbol sb-name
)
2003 (type (or symbol string
) assoc-with
)
2004 (type disassem-state dstate
))
2005 (let ((storage-location
2006 (find-valid-storage-location offset sb-name dstate
)))
2007 (when storage-location
2008 (note (lambda (stream)
2009 (format stream
"~A = ~S"
2011 (sb!di
:debug-var-symbol
2012 (aref (dstate-debug-vars dstate
)
2013 storage-location
))))
2017 (defun get-internal-error-name (errnum)
2018 (car (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 ;;; 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
2038 ;;; the byte length of the arguments (to avoid unnecessary consing)
2039 ;;; It should read information from the SAP starting at BYTE-OFFSET, and
2040 ;;; return four values:
2041 ;;; 1) the error number
2042 ;;; 2) the total length, in bytes, of the information
2043 ;;; 3) a list of SC-OFFSETs of the locations of the error parameters
2044 ;;; 4) a list of the length (as read from the SAP), in bytes, of each
2045 ;;; of the return values.
2046 (defun handle-break-args (error-parse-fun stream dstate
)
2047 (declare (type function error-parse-fun
)
2048 (type (or null stream
) stream
)
2049 (type disassem-state dstate
))
2050 (multiple-value-bind (errnum adjust sc-offsets lengths
)
2051 (funcall error-parse-fun
2052 (dstate-segment-sap dstate
)
2053 (dstate-next-offs dstate
)
2056 (setf (dstate-cur-offs dstate
)
2057 (dstate-next-offs dstate
))
2058 (flet ((emit-err-arg (note)
2059 (let ((num (pop lengths
)))
2060 (print-notes-and-newline stream dstate
)
2061 (print-current-address stream dstate
)
2062 (print-inst num stream dstate
)
2063 (print-bytes num stream dstate
)
2064 (incf (dstate-cur-offs dstate
) num
)
2066 (note note dstate
)))))
2068 (emit-err-arg (symbol-name (get-internal-error-name errnum
)))
2069 (dolist (sc-offs sc-offsets
)
2070 (emit-err-arg (get-sc-name sc-offs
)))))
2071 (incf (dstate-next-offs dstate
)