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 (defun inst-specializes-p (special general)
22 "Returns non-NIL if the instruction SPECIAL is a more specific version of
23 GENERAL (i.e., the same instruction, but with more constraints)."
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...
32 (defun specializer-rank (inst)
34 "Returns an integer corresponding to the specificity of the instruction INST."
35 (declare (type instruction inst))
36 (* (dchunk-count-bits (inst-mask inst)) 4))
38 (defun order-specializers (insts)
40 "Order the list of instructions INSTS with more specific (more constant
41 bits, or same-as argument constains) ones first. Returns the ordered list."
42 (declare (type list insts))
45 (> (specializer-rank i1) (specializer-rank i2)))))
47 (defun specialization-error (insts)
48 (error "Instructions either aren't related or conflict in some way:~% ~S"
51 (defun try-specializing (insts)
53 "Given a list of instructions INSTS, Sees if one of these instructions is a
54 more general form of all the others, in which case they are put into its
55 specializers list, and it is returned. Otherwise an error is signaled."
56 (declare (type list insts))
57 (let ((masters (copy-list insts)))
58 (dolist (possible-master insts)
59 (dolist (possible-specializer insts)
60 (unless (or (eq possible-specializer possible-master)
61 (inst-specializes-p possible-specializer possible-master))
62 (setf masters (delete possible-master masters))
63 (return) ; exit the inner loop
66 (specialization-error insts))
68 (error "multiple specializing masters: ~S" masters))
70 (let ((master (car masters)))
71 (setf (inst-specializers master)
72 (order-specializers (remove master insts)))
75 ;;;; choosing an instruction
77 #!-sb-fluid (declaim (inline inst-matches-p choose-inst-specialization))
79 (defun inst-matches-p (inst chunk)
81 "Returns non-NIL if all constant-bits in INST match CHUNK."
82 (declare (type instruction inst)
84 (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst)))
86 (defun choose-inst-specialization (inst chunk)
88 "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the
89 most specific instruction on INST's specializer list whose constraints are
90 met by CHUNK. If none do, then INST is returned."
91 (declare (type instruction inst)
93 (or (dolist (spec (inst-specializers inst) nil)
94 (declare (type instruction spec))
95 (when (inst-matches-p spec chunk)
99 ;;;; searching for an instruction in instruction space
101 (defun find-inst (chunk inst-space)
103 "Returns the instruction object within INST-SPACE corresponding to the
104 bit-pattern CHUNK, or NIL if there isn't one."
105 (declare (type dchunk chunk)
106 (type (or null inst-space instruction) inst-space))
107 (etypecase inst-space
110 (if (inst-matches-p inst-space chunk)
111 (choose-inst-specialization inst-space chunk)
114 (let* ((mask (ispace-valid-mask inst-space))
115 (id (dchunk-and mask chunk)))
116 (declare (type dchunk id mask))
117 (dolist (choice (ispace-choices inst-space))
118 (declare (type inst-space-choice choice))
119 (when (dchunk= id (ischoice-common-id choice))
120 (return (find-inst chunk (ischoice-subspace choice)))))))))
122 ;;;; building the instruction space
124 (defun build-inst-space (insts &optional (initial-mask dchunk-one))
126 "Returns an instruction-space object corresponding to the list of
127 instructions INSTS. If the optional parameter INITIAL-MASK is supplied, only
128 bits it has set are used."
129 ;; This is done by finding any set of bits that's common to
130 ;; all instructions, building an instruction-space node that selects on those
131 ;; bits, and recursively handle sets of instructions with a common value for
132 ;; these bits (which, since there should be fewer instructions than in INSTS,
133 ;; should have some additional set of bits to select on, etc). If there
134 ;; are no common bits, or all instructions have the same value within those
135 ;; bits, TRY-SPECIALIZING is called, which handles the cases of many
136 ;; variations on a single instruction.
137 (declare (type list insts)
138 (type dchunk initial-mask))
144 (let ((vmask (dchunk-copy initial-mask)))
146 (dchunk-andf vmask (inst-mask inst)))
147 (if (dchunk-zerop vmask)
148 (try-specializing insts)
151 (let* ((common-id (dchunk-and (inst-id inst) vmask))
152 (bucket (assoc common-id buckets :test #'dchunk=)))
154 (push (list common-id inst) buckets))
156 (push inst (cdr bucket))))))
157 (let ((submask (dchunk-clear initial-mask vmask)))
158 (if (= (length buckets) 1)
159 (try-specializing insts)
162 :choices (mapcar #'(lambda (bucket)
163 (make-inst-space-choice
164 :subspace (build-inst-space
167 :common-id (car bucket)))
170 ;;;; an inst-space printer for debugging purposes
172 (defun print-masked-binary (num mask word-size &optional (show word-size))
173 (do ((bit (1- word-size) (1- bit)))
175 (write-char (cond ((logbitp bit mask)
176 (if (logbitp bit num) #\1 #\0))
180 (defun print-inst-bits (inst)
181 (print-masked-binary (inst-id inst)
184 (bytes-to-bits (inst-length inst))))
186 (defun print-inst-space (inst-space &optional (indent 0))
188 "Prints a nicely formatted version of INST-SPACE."
189 (etypecase inst-space
192 (format t "~Vt[~A(~A)~40T" indent
193 (inst-name inst-space)
194 (inst-format-name inst-space))
195 (print-inst-bits inst-space)
196 (dolist (inst (inst-specializers inst-space))
197 (format t "~%~Vt:~A~40T" indent (inst-name inst))
198 (print-inst-bits inst))
202 (format t "~Vt---- ~8,'0X ----~%"
204 (ispace-valid-mask inst-space))
207 (format t "~Vt~8,'0X ==>~%"
209 (ischoice-common-id choice))
210 (print-inst-space (ischoice-subspace choice)
212 (ispace-choices inst-space)))))
214 ;;;; (The actual disassembly part follows.)
216 ;;; Code object layout:
218 ;;; code-size (starting from first inst, in words)
219 ;;; entry-points (points to first function header)
221 ;;; trace-table-offset (starting from first inst, in bytes)
225 ;;; <padding to dual-word boundary>
226 ;;; start of instructions
228 ;;; function-headers and lra's buried in here randomly
230 ;;; start of trace-table
231 ;;; <padding to dual-word boundary>
233 ;;; Function header layout (dual word aligned):
236 ;;; next pointer (next function header)
241 ;;; LRA layout (dual word aligned):
244 #!-sb-fluid (declaim (inline words-to-bytes bytes-to-words))
246 (eval-when (:compile-toplevel :load-toplevel :execute)
247 (defun words-to-bytes (num)
248 "Converts a word-offset NUM to a byte-offset."
249 (declare (type offset num))
250 (ash num sb!vm:word-shift))
253 (defun bytes-to-words (num)
255 "Converts a byte-offset NUM to a word-offset."
256 (declare (type offset num))
257 (ash num (- sb!vm:word-shift)))
259 (defconstant lra-size (words-to-bytes 1))
262 (offset 0 :type offset)
263 (function (required-argument) :type function)
264 (before-address nil :type (member t nil)))
266 (defstruct (segment (:conc-name seg-)
267 (:constructor %make-segment))
268 (sap-maker (required-argument)
269 :type (function () sb!sys:system-area-pointer))
270 (length 0 :type length)
271 (virtual-location 0 :type address)
272 (storage-info nil :type (or null storage-info))
273 (code nil :type (or null sb!kernel:code-component))
274 (hooks nil :type list))
275 (def!method print-object ((seg segment) stream)
276 (print-unreadable-object (seg stream :type t)
277 (let ((addr (sb!sys:sap-int (funcall (seg-sap-maker seg)))))
278 (format stream "#X~X[~D]~:[ (#X~X)~;~*~]~@[ in ~S~]"
281 (= (seg-virtual-location seg) addr)
282 (seg-virtual-location seg)
285 ;;; All state during disassembly. We store some seemingly redundant
286 ;;; information so that we can allow garbage collect during disassembly and
287 ;;; not get tripped up by a code block being moved...
288 (defstruct (disassem-state (:conc-name dstate-)
289 (:constructor %make-dstate))
290 (cur-offs 0 :type offset) ; offset of current pos in segment
291 (next-offs 0 :type offset) ; offset of next position
293 (segment-sap (required-argument) :type sb!sys:system-area-pointer)
294 ; a sap pointing to our segment
295 (segment nil :type (or null segment)) ; the current segment
297 (alignment sb!vm:word-bytes :type alignment) ; what to align to in most cases
298 (byte-order :little-endian
299 :type (member :big-endian :little-endian))
301 (properties nil :type list) ; for user code to hang stuff off of
302 (filtered-values (make-array max-filtered-value-index)
303 :type filtered-value-vector)
305 (addr-print-len nil :type ; used for prettifying printing
306 (or null (integer 0 20)))
307 (argument-column 0 :type column)
308 (output-state :beginning ; to make output look nicer
309 :type (member :beginning
313 (labels nil :type list) ; alist of (address . label-number)
314 (label-hash (make-hash-table) ; same thing in a different form
317 (fun-hooks nil :type list) ; list of function
319 ;; these next two are popped as they are used
320 (cur-labels nil :type list) ; alist of (address . label-number)
321 (cur-offs-hooks nil :type list) ; list of offs-hook
323 (notes nil :type list) ; for the current location
325 (current-valid-locations nil ; currently active source variables
326 :type (or null (vector bit))))
327 (def!method print-object ((dstate disassem-state) stream)
328 (print-unreadable-object (dstate stream :type t)
331 (dstate-cur-offs dstate)
332 (dstate-segment dstate))))
334 (defun dstate-cur-addr (dstate)
336 "Returns the absolute address of the current instruction in DSTATE."
337 (the address (+ (seg-virtual-location (dstate-segment dstate))
338 (dstate-cur-offs dstate))))
340 (defun dstate-next-addr (dstate)
342 "Returns the absolute address of the next instruction in DSTATE."
343 (the address (+ (seg-virtual-location (dstate-segment dstate))
344 (dstate-next-offs dstate))))
348 (defun fun-self (fun)
349 (declare (type compiled-function fun))
350 (sb!kernel:%function-self fun))
352 (defun fun-code (fun)
353 (declare (type compiled-function fun))
354 (sb!kernel:function-code-header (fun-self fun)))
356 (defun fun-next (fun)
357 (declare (type compiled-function fun))
358 (sb!kernel:%function-next fun))
360 (defun fun-address (function)
361 (declare (type compiled-function function))
362 (- (sb!kernel:get-lisp-obj-address function) sb!vm:function-pointer-type))
364 (defun fun-insts-offset (function)
366 "Offset of FUNCTION from the start of its code-component's instruction area."
367 (declare (type compiled-function function))
368 (- (fun-address function)
369 (sb!sys:sap-int (sb!kernel:code-instructions (fun-code function)))))
371 (defun fun-offset (function)
373 "Offset of FUNCTION from the start of its code-component."
374 (declare (type compiled-function function))
375 (words-to-bytes (sb!kernel:get-closure-length function)))
377 ;;;; operations on code-components (which hold the instructions for
378 ;;;; one or more functions)
380 (defun code-inst-area-length (code-component)
382 "Returns the length of the instruction area in CODE-COMPONENT."
383 (declare (type sb!kernel:code-component code-component))
384 (sb!kernel:code-header-ref code-component
385 sb!vm:code-trace-table-offset-slot))
387 (defun code-inst-area-address (code-component)
389 "Returns the address of the instruction area in CODE-COMPONENT."
390 (declare (type sb!kernel:code-component code-component))
391 (sb!sys:sap-int (sb!kernel:code-instructions code-component)))
393 (defun code-first-function (code-component)
395 "Returns the first function in CODE-COMPONENT."
396 (declare (type sb!kernel:code-component code-component))
397 (sb!kernel:code-header-ref code-component
398 sb!vm:code-trace-table-offset-slot))
400 (defun segment-offs-to-code-offs (offset segment)
401 (sb!sys:without-gcing
402 (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
404 (logandc1 sb!vm:lowtag-mask
405 (sb!kernel:get-lisp-obj-address (seg-code segment))))
406 (addr (+ offset seg-base-addr)))
407 (declare (type address seg-base-addr code-addr addr))
408 (- addr code-addr))))
410 (defun code-offs-to-segment-offs (offset segment)
411 (sb!sys:without-gcing
412 (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
414 (logandc1 sb!vm:lowtag-mask
415 (sb!kernel:get-lisp-obj-address (seg-code segment))))
416 (addr (+ offset code-addr)))
417 (declare (type address seg-base-addr code-addr addr))
418 (- addr seg-base-addr))))
420 (defun code-insts-offs-to-segment-offs (offset segment)
421 (sb!sys:without-gcing
422 (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
424 (sb!sys:sap-int (sb!kernel:code-instructions (seg-code segment))))
425 (addr (+ offset code-insts-addr)))
426 (declare (type address seg-base-addr code-insts-addr addr))
427 (- addr seg-base-addr))))
429 (defun lra-hook (chunk stream dstate)
430 (declare (type dchunk chunk)
432 (type (or null stream) stream)
433 (type disassem-state dstate))
434 (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate))
435 (dstate-cur-offs dstate))
436 (* 2 sb!vm:word-bytes))
438 (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate)
439 (if (eq (dstate-byte-order dstate)
441 (dstate-cur-offs dstate)
442 (+ (dstate-cur-offs dstate)
444 sb!vm:return-pc-header-type))
445 (unless (null stream)
446 (princ '.lra stream))
447 (incf (dstate-next-offs dstate) lra-size))
450 (defun fun-header-hook (stream dstate)
452 "Print the function-header (entry-point) pseudo-instruction at the current
453 location in DSTATE to STREAM."
454 (declare (type (or null stream) stream)
455 (type disassem-state dstate))
456 (unless (null stream)
457 (let* ((seg (dstate-segment dstate))
458 (code (seg-code seg))
461 (segment-offs-to-code-offs (dstate-cur-offs dstate) seg)))
463 (sb!kernel:code-header-ref code
464 (+ woffs sb!vm:function-name-slot)))
466 (sb!kernel:code-header-ref code
467 (+ woffs sb!vm:function-arglist-slot)))
469 (sb!kernel:code-header-ref code
470 (+ woffs sb!vm:function-type-slot))))
471 (format stream ".~A ~S~:A" 'entry name args)
472 (note #'(lambda (stream)
473 (format stream "~:S" type)) ; use format to print NIL as ()
475 (incf (dstate-next-offs dstate)
476 (words-to-bytes sb!vm:function-code-offset)))
478 (defun alignment-hook (chunk stream dstate)
479 (declare (type dchunk chunk)
481 (type (or null stream) stream)
482 (type disassem-state dstate))
484 (+ (seg-virtual-location (dstate-segment dstate))
485 (dstate-cur-offs dstate)))
486 (alignment (dstate-alignment dstate)))
487 (unless (aligned-p location alignment)
489 (format stream "~A~Vt~D~%" '.align
490 (dstate-argument-column dstate)
492 (incf(dstate-next-offs dstate)
493 (- (align location alignment) location)))
496 (defun rewind-current-segment (dstate segment)
497 (declare (type disassem-state dstate)
498 (type segment segment))
499 (setf (dstate-segment dstate) segment)
500 (setf (dstate-cur-offs-hooks dstate)
501 (stable-sort (nreverse (copy-list (seg-hooks segment)))
503 (or (< (offs-hook-offset oh1) (offs-hook-offset oh2))
504 (and (= (offs-hook-offset oh1)
505 (offs-hook-offset oh2))
506 (offs-hook-before-address oh1)
507 (not (offs-hook-before-address oh2)))))))
508 (setf (dstate-cur-offs dstate) 0)
509 (setf (dstate-cur-labels dstate) (dstate-labels dstate)))
511 (defun do-offs-hooks (before-address stream dstate)
512 (declare (type (or null stream) stream)
513 (type disassem-state dstate))
514 (let ((cur-offs (dstate-cur-offs dstate)))
515 (setf (dstate-next-offs dstate) cur-offs)
517 (let ((next-hook (car (dstate-cur-offs-hooks dstate))))
518 (when (null next-hook)
520 (let ((hook-offs (offs-hook-offset next-hook)))
521 (when (or (> hook-offs cur-offs)
522 (and (= hook-offs cur-offs)
524 (not (offs-hook-before-address next-hook))))
526 (unless (< hook-offs cur-offs)
527 (funcall (offs-hook-function next-hook) stream dstate))
528 (pop (dstate-cur-offs-hooks dstate))
529 (unless (= (dstate-next-offs dstate) cur-offs)
532 (defun do-fun-hooks (chunk stream dstate)
533 (let ((hooks (dstate-fun-hooks dstate))
534 (cur-offs (dstate-cur-offs dstate)))
535 (setf (dstate-next-offs dstate) cur-offs)
536 (dolist (hook hooks nil)
537 (let ((prefix-p (funcall hook chunk stream dstate)))
538 (unless (= (dstate-next-offs dstate) cur-offs)
539 (return prefix-p))))))
541 (defun handle-bogus-instruction (stream dstate)
542 (let ((alignment (dstate-alignment dstate)))
543 (unless (null stream)
544 (multiple-value-bind (words bytes)
545 (truncate alignment sb!vm:word-bytes)
547 (print-words words stream dstate))
549 (print-bytes bytes stream dstate))))
550 (incf (dstate-next-offs dstate) alignment)))
552 (defun map-segment-instructions (function segment dstate &optional stream)
554 "Iterate through the instructions in SEGMENT, calling FUNCTION
555 for each instruction, with arguments of CHUNK, STREAM, and DSTATE."
556 (declare (type function function)
557 (type segment segment)
558 (type disassem-state dstate)
559 (type (or null stream) stream))
561 (let ((ispace (get-inst-space))
562 (prefix-p nil)) ; just processed a prefix inst
564 (rewind-current-segment dstate segment)
567 (when (>= (dstate-cur-offs dstate)
568 (seg-length (dstate-segment dstate)))
572 (setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
574 (do-offs-hooks t stream dstate)
575 (unless (or prefix-p (null stream))
576 (print-current-address stream dstate))
577 (do-offs-hooks nil stream dstate)
579 (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
580 (sb!sys:without-gcing
581 (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment)))
584 (sap-ref-dchunk (dstate-segment-sap dstate)
585 (dstate-cur-offs dstate)
586 (dstate-byte-order dstate))))
587 (let ((fun-prefix-p (do-fun-hooks chunk stream dstate)))
588 (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
589 (setf prefix-p fun-prefix-p)
590 (let ((inst (find-inst chunk ispace)))
592 (handle-bogus-instruction stream dstate))
594 (setf (dstate-next-offs dstate)
595 (+ (dstate-cur-offs dstate)
598 (let ((prefilter (inst-prefilter inst))
599 (control (inst-control inst)))
601 (funcall prefilter chunk dstate))
603 (funcall function chunk inst)
605 (setf prefix-p (null (inst-printer inst)))
608 (funcall control chunk inst stream dstate))))))
611 (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
613 (unless (null stream)
615 (print-notes-and-newline stream dstate))
616 (setf (dstate-output-state dstate) nil)))))
618 (defun add-segment-labels (segment dstate)
620 "Make an initial non-printing disassembly pass through DSTATE, noting any
621 addresses that are referenced by instructions in this segment."
622 ;; add labels at the beginning with a label-number of nil; we'll notice
623 ;; later and fill them in (and sort them)
624 (declare (type disassem-state dstate))
625 (let ((labels (dstate-labels dstate)))
626 (map-segment-instructions
627 #'(lambda (chunk inst)
628 (declare (type dchunk chunk) (type instruction inst))
629 (let ((labeller (inst-labeller inst)))
631 (setf labels (funcall labeller chunk labels dstate)))))
634 (setf (dstate-labels dstate) labels)
635 ;; erase any notes that got there by accident
636 (setf (dstate-notes dstate) nil)))
638 (defun number-labels (dstate)
640 "If any labels in DSTATE have been added since the last call to this
641 function, give them label-numbers, enter them in the hash-table, and make
642 sure the label list is in sorted order."
643 (let ((labels (dstate-labels dstate)))
644 (when (and labels (null (cdar labels)))
645 ;; at least one label left un-numbered
646 (setf labels (sort labels #'< :key #'car))
648 (label-hash (dstate-label-hash dstate)))
649 (dolist (label labels)
650 (when (not (null (cdr label)))
651 (setf max (max max (cdr label)))))
652 (dolist (label labels)
653 (when (null (cdr label))
655 (setf (cdr label) max)
656 (setf (gethash (car label) label-hash)
657 (format nil "L~D" max)))))
658 (setf (dstate-labels dstate) labels))))
660 (defun get-inst-space ()
662 "Get the instruction-space, creating it if necessary."
663 (let ((ispace *disassem-inst-space*))
666 (maphash #'(lambda (name inst-flavs)
667 (declare (ignore name))
668 (dolist (flav inst-flavs)
671 (setf ispace (build-inst-space insts)))
672 (setf *disassem-inst-space* ispace))
675 ;;;; Add global hooks.
677 (defun add-offs-hook (segment addr hook)
678 (let ((entry (cons addr hook)))
679 (if (null (seg-hooks segment))
680 (setf (seg-hooks segment) (list entry))
681 (push entry (cdr (last (seg-hooks segment)))))))
683 (defun add-offs-note-hook (segment addr note)
684 (add-offs-hook segment
686 #'(lambda (stream dstate)
687 (declare (type (or null stream) stream)
688 (type disassem-state dstate))
690 (note note dstate)))))
692 (defun add-offs-comment-hook (segment addr comment)
693 (add-offs-hook segment
695 #'(lambda (stream dstate)
696 (declare (type (or null stream) stream)
699 (write-string ";;; " stream)
702 (write-string comment stream))
704 (funcall comment stream)))
707 (defun add-fun-hook (dstate function)
708 (push function (dstate-fun-hooks dstate)))
710 (defun set-location-printing-range (dstate from length)
711 (setf (dstate-addr-print-len dstate)
712 ;; 4 bits per hex digit
713 (ceiling (integer-length (logxor from (+ from length))) 4)))
715 (defun print-current-address (stream dstate)
717 "Print the current address in DSTATE to STREAM, plus any labels that
718 correspond to it, and leave the cursor in the instruction column."
719 (declare (type stream stream)
720 (type disassem-state dstate))
722 (+ (seg-virtual-location (dstate-segment dstate))
723 (dstate-cur-offs dstate)))
724 (location-column-width *disassem-location-column-width*)
725 (plen (dstate-addr-print-len dstate)))
728 (setf plen location-column-width)
729 (set-location-printing-range dstate
730 (seg-virtual-location (dstate-segment dstate))
731 (seg-length (dstate-segment dstate))))
732 (when (eq (dstate-output-state dstate) :beginning)
733 (setf plen location-column-width))
737 ;; print the location
738 ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
739 ;; usually avoids any consing]
740 (tab0 (- location-column-width plen) stream)
741 (let* ((printed-bits (* 4 plen))
742 (printed-value (ldb (byte printed-bits 0) location))
744 (truncate (- printed-bits (integer-length printed-value)) 4)))
745 (dotimes (i leading-zeros)
746 (write-char #\0 stream))
747 (unless (zerop printed-value)
748 (write printed-value :stream stream :base 16 :radix nil))
749 (write-char #\: stream))
753 (let* ((next-label (car (dstate-cur-labels dstate)))
754 (label-location (car next-label)))
755 (when (or (null label-location) (> label-location location))
757 (unless (< label-location location)
758 (format stream " L~D:" (cdr next-label)))
759 (pop (dstate-cur-labels dstate))))
761 ;; move to the instruction column
762 (tab0 (+ location-column-width 1 label-column-width) stream)
765 (eval-when (:compile-toplevel :execute)
766 (sb!xc:defmacro with-print-restrictions (&rest body)
767 `(let ((*print-pretty* t)
773 (defun print-notes-and-newline (stream dstate)
775 "Print a newline to STREAM, inserting any pending notes in DSTATE as
776 end-of-line comments. If there is more than one note, a separate line
777 will be used for each one."
778 (declare (type stream stream)
779 (type disassem-state dstate))
780 (with-print-restrictions
781 (dolist (note (dstate-notes dstate))
782 (format stream "~Vt; " *disassem-note-column*)
785 (write-string note stream))
787 (funcall note stream)))
790 (setf (dstate-notes dstate) nil)))
792 (defun print-bytes (num stream dstate)
794 "Disassemble NUM bytes to STREAM as simple `BYTE' instructions"
795 (declare (type offset num)
797 (type disassem-state dstate))
798 (format stream "~A~Vt" 'BYTE (dstate-argument-column dstate))
799 (let ((sap (dstate-segment-sap dstate))
800 (start-offs (dstate-cur-offs dstate)))
803 (write-string ", " stream))
804 (format stream "#X~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs))))))
806 (defun print-words (num stream dstate)
808 "Disassemble NUM machine-words to STREAM as simple `WORD' instructions"
809 (declare (type offset num)
811 (type disassem-state dstate))
812 (format stream "~A~Vt" 'WORD (dstate-argument-column dstate))
813 (let ((sap (dstate-segment-sap dstate))
814 (start-offs (dstate-cur-offs dstate))
815 (byte-order (dstate-byte-order dstate)))
816 (dotimes (word-offs num)
817 (unless (zerop word-offs)
818 (write-string ", " stream))
819 (let ((word 0) (bit-shift 0))
820 (dotimes (byte-offs sb!vm:word-bytes)
825 (* word-offs sb!vm:word-bytes)
828 (if (eq byte-order :big-endian)
829 (+ (ash word sb!vm:byte-bits) byte)
830 (+ word (ash byte bit-shift))))
831 (incf bit-shift sb!vm:byte-bits)))
832 (format stream "#X~V,'0X" (ash sb!vm:word-bits -2) word)))))
834 (defvar *default-dstate-hooks* (list #'lra-hook))
836 (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
838 "Make a disassembler-state object."
840 (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
841 (alignment *disassem-inst-alignment-bytes*)
843 (+ (or *disassem-opcode-column-width* 0)
844 *disassem-location-column-width*
846 label-column-width)))
848 (when (> alignment 1)
849 (push #'alignment-hook fun-hooks))
851 (%make-dstate :segment-sap sap
853 :argument-column arg-column
855 :byte-order sb!c:*backend-byte-order*)))
857 (defun add-fun-header-hooks (segment)
858 (declare (type segment segment))
859 (do ((fun (sb!kernel:code-header-ref (seg-code segment)
860 sb!vm:code-entry-points-slot)
862 (length (seg-length segment)))
864 (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment)))
865 (when (<= 0 offset length)
866 (push (make-offs-hook :offset offset :function #'fun-header-hook)
867 (seg-hooks segment))))))
869 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
871 #!-sb-fluid (declaim (inline sap-maker))
873 (defun sap-maker (function input offset)
874 (declare (optimize (speed 3))
875 (type (function (t) sb!sys:system-area-pointer) function)
876 (type offset offset))
877 (let ((old-sap (sb!sys:sap+ (funcall function input) offset)))
878 (declare (type sb!sys:system-area-pointer old-sap))
881 (+ (sb!sys:sap-int (funcall function input)) offset)))
882 ;; Saving the sap like this avoids consing except when the sap
883 ;; changes (because the sap-int, arith, etc., get inlined).
884 (declare (type address new-addr))
885 (if (= (sb!sys:sap-int old-sap) new-addr)
887 (setf old-sap (sb!sys:int-sap new-addr)))))))
889 (defun vector-sap-maker (vector offset)
890 (declare (optimize (speed 3))
891 (type offset offset))
892 (sap-maker #'sb!sys:vector-sap vector offset))
894 (defun code-sap-maker (code offset)
895 (declare (optimize (speed 3))
896 (type sb!kernel:code-component code)
897 (type offset offset))
898 (sap-maker #'sb!kernel:code-instructions code offset))
900 (defun memory-sap-maker (address)
901 (declare (optimize (speed 3))
902 (type address address))
903 (let ((sap (sb!sys:int-sap address)))
906 (defun make-segment (sap-maker length
908 code virtual-location
909 debug-function source-form-cache
912 "Return a memory segment located at the system-area-pointer returned by
913 SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
914 Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as
915 the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache
916 object), and :HOOKS (a list of offs-hook objects)."
917 (declare (type (function () sb!sys:system-area-pointer) sap-maker)
919 (type (or null address) virtual-location)
920 (type (or null sb!di:debug-function) debug-function)
921 (type (or null source-form-cache) source-form-cache))
926 :virtual-location (or virtual-location
927 (sb!sys:sap-int (funcall sap-maker)))
930 (add-debugging-hooks segment debug-function source-form-cache)
931 (add-fun-header-hooks segment)
934 (defun make-vector-segment (vector offset &rest args)
935 (declare (type vector vector)
937 (inline make-segment))
938 (apply #'make-segment (vector-sap-maker vector offset) args))
940 (defun make-code-segment (code offset length &rest args)
941 (declare (type sb!kernel:code-component code)
943 (inline make-segment))
944 (apply #'make-segment (code-sap-maker code offset) length :code code args))
946 (defun make-memory-segment (address &rest args)
947 (declare (type address address)
948 (inline make-segment))
949 (apply #'make-segment (memory-sap-maker address) args))
952 (defun print-fun-headers (function)
953 (declare (type compiled-function function))
954 (let* ((self (fun-self function))
955 (code (sb!kernel:function-code-header self)))
956 (format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%"
958 (sb!kernel:code-header-ref code
959 sb!vm:code-code-size-slot)
960 (sb!kernel:code-header-ref code
961 sb!vm:code-trace-table-offset-slot))
962 (do ((fun (sb!kernel:code-header-ref code sb!vm:code-entry-points-slot)
965 (let ((fun-offset (sb!kernel:get-closure-length fun)))
966 ;; There is function header fun-offset words from the
968 (format t "Fun-header ~S at offset ~D (words): ~S~A => ~S~%"
971 (sb!kernel:code-header-ref
972 code (+ fun-offset sb!vm:function-name-slot))
973 (sb!kernel:code-header-ref
974 code (+ fun-offset sb!vm:function-arglist-slot))
975 (sb!kernel:code-header-ref
976 code (+ fun-offset sb!vm:function-type-slot)))))))
978 ;;; getting at the source code...
980 (defstruct (source-form-cache (:conc-name sfcache-))
981 (debug-source nil :type (or null sb!di:debug-source))
982 (top-level-form-index -1 :type fixnum)
983 (top-level-form nil :type list)
984 (form-number-mapping-table nil :type (or null (vector list)))
985 (last-location-retrieved nil :type (or null sb!di:code-location))
986 (last-form-retrieved -1 :type fixnum)
989 (defun get-top-level-form (debug-source tlf-index)
990 (let ((name (sb!di:debug-source-name debug-source)))
991 (ecase (sb!di:debug-source-from debug-source)
993 (cond ((not (probe-file name))
994 (warn "The source file ~S no longer seems to exist." name)
997 (let ((start-positions
998 (sb!di:debug-source-start-positions debug-source)))
999 (cond ((null start-positions)
1000 (warn "There is no start positions map.")
1003 (let* ((local-tlf-index
1005 (sb!di:debug-source-root-number
1008 (aref start-positions local-tlf-index)))
1009 (with-open-file (f name)
1010 (cond ((= (sb!di:debug-source-created debug-source)
1011 (file-write-date name))
1012 (file-position f char-offset))
1014 (warn "Source file ~S has been modified; ~@
1015 using form offset instead of file index."
1017 (let ((*read-suppress* t))
1018 (dotimes (i local-tlf-index) (read f)))))
1019 (let ((*readtable* (copy-readtable)))
1020 (set-dispatch-macro-character
1022 #'(lambda (stream sub-char &rest rest)
1023 (declare (ignore rest sub-char))
1024 (let ((token (read stream t nil t)))
1025 (format nil "#.~S" token))))
1029 (aref name tlf-index)))))
1031 (defun cache-valid (loc cache)
1033 (and (eq (sb!di:code-location-debug-source loc)
1034 (sfcache-debug-source cache))
1035 (eq (sb!di:code-location-top-level-form-offset loc)
1036 (sfcache-top-level-form-index cache)))))
1038 (defun get-source-form (loc context &optional cache)
1039 (let* ((cache-valid (cache-valid loc cache))
1040 (tlf-index (sb!di:code-location-top-level-form-offset loc))
1041 (form-number (sb!di:code-location-form-number loc))
1044 (sfcache-top-level-form cache)
1045 (get-top-level-form (sb!di:code-location-debug-source loc)
1049 (sfcache-form-number-mapping-table cache)
1050 (sb!di:form-number-translations top-level-form tlf-index))))
1051 (when (and (not cache-valid) cache)
1052 (setf (sfcache-debug-source cache) (sb!di:code-location-debug-source loc)
1053 (sfcache-top-level-form-index cache) tlf-index
1054 (sfcache-top-level-form cache) top-level-form
1055 (sfcache-form-number-mapping-table cache) mapping-table))
1056 (cond ((null top-level-form)
1058 ((> form-number (length mapping-table))
1059 (warn "bogus form-number in form! The source file has probably ~@
1060 been changed too much to cope with.")
1062 ;; Disable future warnings.
1063 (setf (sfcache-top-level-form cache) nil))
1067 (setf (sfcache-last-location-retrieved cache) loc)
1068 (setf (sfcache-last-form-retrieved cache) form-number))
1069 (sb!di:source-path-context top-level-form
1070 (aref mapping-table form-number)
1073 (defun get-different-source-form (loc context &optional cache)
1074 (if (and (cache-valid loc cache)
1075 (or (= (sb!di:code-location-form-number loc)
1076 (sfcache-last-form-retrieved cache))
1077 (and (sfcache-last-location-retrieved cache)
1078 (sb!di:code-location=
1080 (sfcache-last-location-retrieved cache)))))
1082 (values (get-source-form loc context cache) t)))
1084 ;;;; stuff to use debugging-info to augment the disassembly
1086 (defun code-function-map (code)
1087 (declare (type sb!kernel:code-component code))
1088 (sb!di::get-debug-info-function-map (sb!kernel:%code-debug-info code)))
1090 (defstruct location-group
1091 (locations #() :type (vector (or list fixnum)))
1094 (defstruct storage-info
1095 (groups nil :type list) ; alist of (name . location-group)
1096 (debug-vars #() :type vector))
1098 (defun dstate-debug-vars (dstate)
1100 "Return the vector of DEBUG-VARs currently associated with DSTATE."
1101 (declare (type disassem-state dstate))
1102 (storage-info-debug-vars (seg-storage-info (dstate-segment dstate))))
1104 (defun find-valid-storage-location (offset lg-name dstate)
1106 "Given the OFFSET of a location within the location-group called LG-NAME,
1107 see whether there's a current mapping to a source variable in DSTATE, and
1108 if so, return the offset of that variable in the current debug-var vector."
1109 (declare (type offset offset)
1110 (type symbol lg-name)
1111 (type disassem-state dstate))
1112 (let* ((storage-info
1113 (seg-storage-info (dstate-segment dstate)))
1116 (cdr (assoc lg-name (storage-info-groups storage-info)))))
1118 (dstate-current-valid-locations dstate)))
1120 (not (null currently-valid))
1121 (let ((locations (location-group-locations location-group)))
1122 (and (< offset (length locations))
1123 (let ((used-by (aref locations offset)))
1125 (let ((debug-var-num
1129 (zerop (bit currently-valid used-by)))
1132 (some #'(lambda (num)
1135 (bit currently-valid num)))
1140 ;; Found a valid storage reference!
1141 ;; can't use it again until it's revalidated...
1142 (setf (bit (dstate-current-valid-locations
1149 (defun grow-vector (vec new-len &optional initial-element)
1151 "Return a new vector which has the same contents as the old one VEC, plus
1152 new cells (for a total size of NEW-LEN). The additional elements are
1153 initialized to INITIAL-ELEMENT."
1154 (declare (type vector vec)
1155 (type fixnum new-len))
1157 (make-sequence `(vector ,(array-element-type vec) ,new-len)
1159 :initial-element initial-element)))
1160 (dotimes (i (length vec))
1161 (setf (aref new i) (aref vec i)))
1164 (defun storage-info-for-debug-function (debug-function)
1166 "Returns a STORAGE-INFO struction describing the object-to-source
1167 variable mappings from DEBUG-FUNCTION."
1168 (declare (type sb!di:debug-function debug-function))
1169 (let ((sc-vec sb!c::*backend-sc-numbers*)
1171 (debug-vars (sb!di::debug-function-debug-vars
1174 (dotimes (debug-var-offset
1176 (make-storage-info :groups groups
1177 :debug-vars debug-vars))
1178 (let ((debug-var (aref debug-vars debug-var-offset)))
1180 (format t ";;; At offset ~D: ~S~%" debug-var-offset debug-var)
1182 (sb!di::compiled-debug-var-sc-offset debug-var))
1185 (sb!c:sc-sb (aref sc-vec
1186 (sb!c:sc-offset-scn sc-offset))))))
1188 (format t ";;; SET: ~S[~D]~%"
1189 sb-name (sb!c:sc-offset-offset sc-offset))
1190 (unless (null sb-name)
1191 (let ((group (cdr (assoc sb-name groups))))
1193 (setf group (make-location-group))
1194 (push `(,sb-name . ,group) groups))
1195 (let* ((locations (location-group-locations group))
1196 (length (length locations))
1197 (offset (sb!c:sc-offset-offset sc-offset)))
1198 (when (>= offset length)
1200 (grow-vector locations
1204 (location-group-locations group)
1206 (let ((already-there (aref locations offset)))
1207 (cond ((null already-there)
1208 (setf (aref locations offset) debug-var-offset))
1209 ((eql already-there debug-var-offset))
1211 (if (listp already-there)
1212 (pushnew debug-var-offset
1213 (aref locations offset))
1214 (setf (aref locations offset)
1215 (list debug-var-offset
1220 (defun source-available-p (debug-function)
1222 (sb!di:do-debug-function-blocks (block debug-function)
1223 (declare (ignore block))
1225 (sb!di:no-debug-blocks () nil)))
1227 (defun print-block-boundary (stream dstate)
1228 (let ((os (dstate-output-state dstate)))
1229 (when (not (eq os :beginning))
1230 (when (not (eq os :block-boundary))
1232 (setf (dstate-output-state dstate)
1235 (defun add-source-tracking-hooks (segment debug-function &optional sfcache)
1237 "Add hooks to track to track the source code in SEGMENT during
1238 disassembly. SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
1239 structure, in which case it is used to cache forms from files."
1240 (declare (type segment segment)
1241 (type (or null sb!di:debug-function) debug-function)
1242 (type (or null source-form-cache) sfcache))
1243 (let ((last-block-pc -1))
1244 (flet ((add-hook (pc fun &optional before-address)
1245 (push (make-offs-hook
1246 :offset pc ;; ##### FIX to account for non-zero offs in code
1248 :before-address before-address)
1249 (seg-hooks segment))))
1251 (sb!di:do-debug-function-blocks (block debug-function)
1252 (let ((first-location-in-block-p t))
1253 (sb!di:do-debug-block-locations (loc block)
1254 (let ((pc (sb!di::compiled-code-location-pc loc)))
1256 ;; Put blank lines in at block boundaries
1257 (when (and first-location-in-block-p
1258 (/= pc last-block-pc))
1259 (setf first-location-in-block-p nil)
1261 #'(lambda (stream dstate)
1262 (print-block-boundary stream dstate))
1264 (setf last-block-pc pc))
1266 ;; Print out corresponding source; this information is not
1267 ;; all that accurate, but it's better than nothing
1268 (unless (zerop (sb!di:code-location-form-number loc))
1269 (multiple-value-bind (form new)
1270 (get-different-source-form loc 0 sfcache)
1272 (let ((at-block-begin (= pc last-block-pc)))
1275 #'(lambda (stream dstate)
1276 (declare (ignore dstate))
1278 (unless at-block-begin
1280 (format stream ";;; [~D] "
1281 (sb!di:code-location-form-number
1283 (prin1-short form stream)
1288 ;; Keep track of variable live-ness as best we can.
1290 (copy-seq (sb!di::compiled-code-location-live-set
1294 #'(lambda (stream dstate)
1295 (declare (ignore stream))
1296 (setf (dstate-current-valid-locations dstate)
1299 (note #'(lambda (stream)
1300 (let ((*print-length* nil))
1301 (format stream "live set: ~S"
1305 (sb!di:no-debug-blocks () nil)))))
1307 (defun add-debugging-hooks (segment debug-function &optional sfcache)
1308 (when debug-function
1309 (setf (seg-storage-info segment)
1310 (storage-info-for-debug-function debug-function))
1311 (add-source-tracking-hooks segment debug-function sfcache)
1312 (let ((kind (sb!di:debug-function-kind debug-function)))
1314 (push (make-offs-hook
1316 :function #'(lambda (stream dstate)
1317 (declare (ignore stream))
1319 (seg-hooks segment))))
1323 (anh "No-arg-parsing entry point"))
1325 (anh #'(lambda (stream)
1326 (format stream "~S entry point" kind)))))))))
1328 (defun get-function-segments (function)
1330 "Returns a list of the segments of memory containing machine code
1331 instructions for FUNCTION."
1332 (declare (type compiled-function function))
1333 (let* ((code (fun-code function))
1334 (function-map (code-function-map code))
1335 (fname (sb!kernel:%function-name function))
1336 (sfcache (make-source-form-cache)))
1337 (let ((first-block-seen-p nil)
1338 (nil-block-seen-p nil)
1340 (last-debug-function nil)
1342 (flet ((add-seg (offs len df)
1344 (push (make-code-segment code offs len
1346 :source-form-cache sfcache)
1348 (dotimes (fmap-index (length function-map))
1349 (let ((fmap-entry (aref function-map fmap-index)))
1350 (etypecase fmap-entry
1352 (when first-block-seen-p
1353 (add-seg last-offset
1354 (- fmap-entry last-offset)
1355 last-debug-function)
1356 (setf last-debug-function nil))
1357 (setf last-offset fmap-entry))
1358 (sb!c::compiled-debug-function
1359 (let ((name (sb!c::compiled-debug-function-name fmap-entry))
1360 (kind (sb!c::compiled-debug-function-kind fmap-entry)))
1362 (format t ";;; SAW ~S ~S ~S,~S ~D,~D~%"
1363 name kind first-block-seen-p nil-block-seen-p
1365 (sb!c::compiled-debug-function-start-pc fmap-entry))
1366 (cond (#+nil (eq last-offset fun-offset)
1367 (and (equal name fname) (not first-block-seen-p))
1368 (setf first-block-seen-p t))
1369 ((eq kind :external)
1370 (when first-block-seen-p
1373 (when nil-block-seen-p
1375 (when first-block-seen-p
1376 (setf nil-block-seen-p t))))
1377 (setf last-debug-function
1378 (sb!di::make-compiled-debug-function fmap-entry code))
1380 (let ((max-offset (code-inst-area-length code)))
1381 (when (and first-block-seen-p last-debug-function)
1382 (add-seg last-offset
1383 (- max-offset last-offset)
1384 last-debug-function))
1386 (let ((offs (fun-insts-offset function)))
1387 (make-code-segment code offs (- max-offset offs)))
1388 (nreverse segments)))))))
1390 (defun get-code-segments (code
1393 (length (code-inst-area-length code)))
1395 "Returns a list of the segments of memory containing machine code
1396 instructions for the code-component CODE. If START-OFFS and/or LENGTH is
1397 supplied, only that part of the code-segment is used (but these are
1398 constrained to lie within the code-segment)."
1399 (declare (type sb!kernel:code-component code)
1400 (type offset start-offs)
1401 (type length length))
1402 (let ((segments nil))
1404 (let ((function-map (code-function-map code))
1405 (sfcache (make-source-form-cache)))
1406 (let ((last-offset 0)
1407 (last-debug-function nil))
1408 (flet ((add-seg (offs len df)
1409 (let* ((restricted-offs
1410 (min (max start-offs offs) (+ start-offs length)))
1412 (- (min (max start-offs (+ offs len))
1413 (+ start-offs length))
1415 (when (> restricted-len 0)
1416 (push (make-code-segment code
1417 restricted-offs restricted-len
1419 :source-form-cache sfcache)
1421 (dotimes (fmap-index (length function-map))
1422 (let ((fmap-entry (aref function-map fmap-index)))
1423 (etypecase fmap-entry
1425 (add-seg last-offset (- fmap-entry last-offset)
1426 last-debug-function)
1427 (setf last-debug-function nil)
1428 (setf last-offset fmap-entry))
1429 (sb!c::compiled-debug-function
1430 (setf last-debug-function
1431 (sb!di::make-compiled-debug-function fmap-entry
1433 (when last-debug-function
1434 (add-seg last-offset
1435 (- (code-inst-area-length code) last-offset)
1436 last-debug-function))))))
1438 (make-code-segment code start-offs length)
1439 (nreverse segments))))
1442 (defun find-function-segment (fun)
1444 "Return the address of the instructions for function and its length.
1445 The length is computed using a heuristic, and so may not be accurate."
1446 (declare (type compiled-function fun))
1450 (- (sb!kernel:get-lisp-obj-address fun) sb!vm:function-pointer-type))
1452 (code-inst-area-length code))
1454 (+ (code-inst-area-address code) max-length)))
1455 (do ((some-fun (code-first-function code)
1456 (fun-next some-fun)))
1458 (values fun-addr (- upper-bound fun-addr)))
1459 (let ((some-addr (fun-address some-fun)))
1460 (when (and (> some-addr fun-addr)
1461 (< some-addr upper-bound))
1462 (setf upper-bound some-addr))))))
1464 (defun segment-overflow (segment dstate)
1466 "Returns two values: the amount by which the last instruction in the
1467 segment goes past the end of the segment, and the offset of the end of the
1468 segment from the beginning of that instruction. If all instructions fit
1469 perfectly, this will return 0 and 0."
1470 (declare (type segment segment)
1471 (type disassem-state dstate))
1472 (let ((seglen (seg-length segment))
1474 (map-segment-instructions #'(lambda (chunk inst)
1475 (declare (ignore chunk inst))
1476 (setf last-start (dstate-cur-offs dstate)))
1479 (values (- (dstate-cur-offs dstate) seglen)
1480 (- seglen last-start))))
1482 (defun label-segments (seglist dstate)
1484 "Computes labels for all the memory segments in SEGLIST and adds them to
1485 DSTATE. It's important to call this function with all the segments you're
1486 interested in, so it can find references from one to another."
1487 (declare (type list seglist)
1488 (type disassem-state dstate))
1489 (dolist (seg seglist)
1490 (add-segment-labels seg dstate))
1491 ;; now remove any labels that don't point anywhere in the segments we have
1492 (setf (dstate-labels dstate)
1493 (remove-if #'(lambda (lab)
1495 (some #'(lambda (seg)
1496 (let ((start (seg-virtual-location seg)))
1499 (+ start (seg-length seg)))))
1501 (dstate-labels dstate))))
1503 (defun disassemble-segment (segment stream dstate)
1505 "Disassemble the machine code instructions in SEGMENT to STREAM."
1506 (declare (type segment segment)
1507 (type stream stream)
1508 (type disassem-state dstate))
1509 (let ((*print-pretty* nil)) ; otherwise the pp conses hugely
1510 (number-labels dstate)
1511 (map-segment-instructions
1512 #'(lambda (chunk inst)
1513 (declare (type dchunk chunk) (type instruction inst))
1514 (let ((printer (inst-printer inst)))
1516 (funcall printer chunk inst stream dstate))))
1521 (defun disassemble-segments (segments stream dstate)
1523 "Disassemble the machine code instructions in each memory segment in
1524 SEGMENTS in turn to STREAM."
1525 (declare (type list segments)
1526 (type stream stream)
1527 (type disassem-state dstate))
1528 (unless (null segments)
1529 (let ((first (car segments))
1530 (last (car (last segments))))
1531 (set-location-printing-range dstate
1532 (seg-virtual-location first)
1533 (- (+ (seg-virtual-location last)
1535 (seg-virtual-location first)))
1536 (setf (dstate-output-state dstate) :beginning)
1537 (dolist (seg segments)
1538 (disassemble-segment seg stream dstate)))))
1540 ;;;; top-level functions
1542 (defun disassemble-function (function &key
1543 (stream *standard-output*)
1546 "Disassemble the machine code instructions for FUNCTION."
1547 (declare (type compiled-function function)
1548 (type stream stream)
1549 (type (member t nil) use-labels))
1550 (let* ((dstate (make-dstate))
1551 (segments (get-function-segments function)))
1553 (label-segments segments dstate))
1554 (disassemble-segments segments stream dstate)))
1556 (defun compile-function-lambda-expr (function)
1557 (declare (type function function))
1558 (multiple-value-bind (lambda closurep name)
1559 (function-lambda-expression function)
1560 (declare (ignore name))
1562 (error "cannot compile a lexical closure"))
1563 (compile nil lambda)))
1565 (defun compiled-function-or-lose (thing &optional (name thing))
1566 (cond ((or (symbolp thing)
1568 (eq (car thing) 'setf)))
1569 (compiled-function-or-lose (fdefinition thing) thing))
1570 ((sb!eval:interpreted-function-p thing)
1571 (compile-function-lambda-expr thing))
1575 (eq (car thing) 'sb!impl::lambda))
1576 (compile nil thing))
1578 (error "can't make a compiled function from ~S" name))))
1580 (defun disassemble (object &key
1581 (stream *standard-output*)
1584 "Disassemble the machine code associated with OBJECT, which can be a
1585 function, a lambda expression, or a symbol with a function definition. If
1586 it is not already compiled, the compiler is called to produce something to
1588 (declare (type (or function symbol cons) object)
1589 (type (or (member t) stream) stream)
1590 (type (member t nil) use-labels))
1591 (let ((fun (compiled-function-or-lose object)))
1592 (if (typep fun 'sb!kernel:byte-function)
1593 (sb!c:disassem-byte-fun fun)
1594 ;; we can't detect closures, so be careful
1595 (disassemble-function (fun-self fun)
1597 :use-labels use-labels)))
1600 (defun disassemble-memory (address
1603 (stream *standard-output*)
1607 "Disassembles the given area of memory starting at ADDRESS and LENGTH long.
1608 Note that if CODE-COMPONENT is NIL and this memory could move during a GC,
1609 you'd better disable it around the call to this function."
1610 (declare (type (or address sb!sys:system-area-pointer) address)
1611 (type length length)
1612 (type stream stream)
1613 (type (or null sb!kernel:code-component) code-component)
1614 (type (member t nil) use-labels))
1616 (if (sb!sys:system-area-pointer-p address)
1617 (sb!sys:sap-int address)
1619 (dstate (make-dstate))
1625 (sb!kernel:code-instructions code-component)))))
1626 (when (or (< code-offs 0)
1627 (> code-offs (code-inst-area-length code-component)))
1628 (error "address ~X not in the code component ~S"
1629 address code-component))
1630 (get-code-segments code-component code-offs length))
1631 (list (make-memory-segment address length)))))
1633 (label-segments segments dstate))
1634 (disassemble-segments segments stream dstate)))
1636 (defun disassemble-code-component (code-component &key
1637 (stream *standard-output*)
1640 "Disassemble the machine code instructions associated with
1641 CODE-COMPONENT (this may include multiple entry points)."
1642 (declare (type (or null sb!kernel:code-component compiled-function)
1644 (type stream stream)
1645 (type (member t nil) use-labels))
1646 (let* ((code-component
1647 (if (functionp code-component)
1648 (fun-code code-component)
1650 (dstate (make-dstate))
1651 (segments (get-code-segments code-component)))
1653 (label-segments segments dstate))
1654 (disassemble-segments segments stream dstate)))
1656 ;;; Code for making useful segments from arbitrary lists of code-blocks
1658 ;;; The maximum size of an instruction -- this includes pseudo-instructions
1659 ;;; like error traps with their associated operands, so it should be big enough
1660 ;;; to include them (i.e. it's not just 4 on a risc machine!).
1661 (defconstant max-instruction-size 16)
1663 (defun sap-to-vector (sap start end)
1664 (let* ((length (- end start))
1665 (result (make-array length :element-type '(unsigned-byte 8)))
1666 (sap (sb!sys:sap+ sap start)))
1668 (setf (aref result i) (sb!sys:sap-ref-8 sap i)))
1671 (defun add-block-segments (sap amount seglist location connecting-vec dstate)
1672 (declare (type list seglist)
1673 (type integer location)
1674 (type (or null (vector (unsigned-byte 8))) connecting-vec)
1675 (type disassem-state dstate))
1676 (flet ((addit (seg overflow)
1677 (let ((length (+ (seg-length seg) overflow)))
1679 (setf (seg-length seg) length)
1680 (incf location length)
1681 (push seg seglist)))))
1682 (let ((connecting-overflow 0))
1683 (when connecting-vec
1684 ;; tack on some of the new block to the old overflow vector
1685 (let* ((beginning-of-block-amount
1686 (if sap (min max-instruction-size amount) 0))
1690 '(vector (unsigned-byte 8))
1692 (sap-to-vector sap 0 beginning-of-block-amount))
1694 (when (and (< (length connecting-vec) max-instruction-size)
1696 (return-from add-block-segments
1697 ;; We want connecting vectors to be large enough to hold
1698 ;; any instruction, and since the current sap wasn't large
1699 ;; enough to do this (and is now entirely on the end of the
1700 ;; overflow-vector), just save it for next time.
1701 (values seglist location connecting-vec)))
1702 (when (> (length connecting-vec) 0)
1704 (make-vector-segment connecting-vec
1706 (- (length connecting-vec)
1707 beginning-of-block-amount)
1708 :virtual-location location)))
1709 (setf connecting-overflow (segment-overflow seg dstate))
1710 (addit seg connecting-overflow)))))
1712 ;; Nothing more to add.
1713 (values seglist location nil))
1714 ((< (- amount connecting-overflow) max-instruction-size)
1715 ;; We can't create a segment with the minimum size
1716 ;; required for an instruction, so just keep on accumulating
1717 ;; in the overflow vector for the time-being.
1720 (sap-to-vector sap connecting-overflow amount)))
1722 ;; Put as much as we can into a new segment, and the rest
1723 ;; into the overflow-vector.
1724 (let* ((initial-length
1725 (- amount connecting-overflow max-instruction-size))
1727 (make-segment #'(lambda ()
1728 (sb!sys:sap+ sap connecting-overflow))
1730 :virtual-location location))
1732 (segment-overflow seg dstate)))
1733 (addit seg overflow)
1737 (+ connecting-overflow (seg-length seg))
1740 ;;;; code to disassemble assembler segments
1742 (defun assem-segment-to-disassem-segments (assem-segment dstate)
1743 (declare (type sb!assem:segment assem-segment)
1744 (type disassem-state dstate))
1746 (disassem-segments nil)
1747 (connecting-vec nil))
1748 (error "stub: code not converted to new SEGMENT WHN 19990322" ; KLUDGE
1749 assem-segment) ; (to avoid "ASSEM-SEGMENT defined but never used")
1750 ;; old code, needs to be converted to use less-SAPpy ASSEM-SEGMENTs:
1751 #|(sb!assem:segment-map-output
1753 #'(lambda (sap amount)
1754 (multiple-value-setq (disassem-segments location connecting-vec)
1755 (add-block-segments sap amount
1756 disassem-segments location
1759 (when connecting-vec
1760 (setf disassem-segments
1761 (add-block-segments nil nil
1762 disassem-segments location
1765 (sort disassem-segments #'< :key #'seg-virtual-location)))
1767 ;;; FIXME: I noticed that this is only called by #!+SB-SHOW code. It would
1768 ;;; be good to see whether this is the only caller of any other functions.
1770 (defun disassemble-assem-segment (assem-segment stream)
1772 "Disassemble the machine code instructions associated with
1773 ASSEM-SEGMENT (of type assem:segment)."
1774 (declare (type sb!assem:segment assem-segment)
1775 (type stream stream))
1776 (let* ((dstate (make-dstate))
1778 (assem-segment-to-disassem-segments assem-segment dstate)))
1779 (label-segments disassem-segments dstate)
1780 (disassemble-segments disassem-segments stream dstate)))
1782 ;;; routines to find things in the Lisp environment
1784 (defconstant groked-symbol-slots
1785 (sort `((,sb!vm:symbol-value-slot . symbol-value)
1786 (,sb!vm:symbol-plist-slot . symbol-plist)
1787 (,sb!vm:symbol-name-slot . symbol-name)
1788 (,sb!vm:symbol-package-slot . symbol-package))
1792 "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a
1793 symbol object that we know about.")
1795 (defun grok-symbol-slot-ref (address)
1797 "Given ADDRESS, try and figure out if which slot of which symbol is being
1798 refered to. Of course we can just give up, so it's not a big deal...
1799 Returns two values, the symbol and the name of the access function of the
1801 (declare (type address address))
1802 (if (not (aligned-p address sb!vm:word-bytes))
1804 (do ((slots-tail groked-symbol-slots (cdr slots-tail)))
1807 (let* ((field (car slots-tail))
1808 (slot-offset (words-to-bytes (car field)))
1809 (maybe-symbol-addr (- address slot-offset))
1811 (sb!kernel:make-lisp-obj
1812 (+ maybe-symbol-addr sb!vm:other-pointer-type))))
1813 (when (symbolp maybe-symbol)
1814 (return (values maybe-symbol (cdr field))))))))
1816 (defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil))
1818 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1820 "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which
1821 symbol is being refered to. Of course we can just give up, so it's not a big
1822 deal... Returns two values, the symbol and the access function."
1823 (declare (type offset byte-offset))
1824 (grok-symbol-slot-ref (+ *address-of-nil-object* byte-offset)))
1826 (defun get-nil-indexed-object (byte-offset)
1828 "Returns the lisp object located BYTE-OFFSET from NIL."
1829 (declare (type offset byte-offset))
1830 (sb!kernel:make-lisp-obj (+ *address-of-nil-object* byte-offset)))
1832 (defun get-code-constant (byte-offset dstate)
1834 "Returns two values; the lisp-object located at BYTE-OFFSET in the constant
1835 area of the code-object in the current segment and T, or NIL and NIL if
1836 there is no code-object in the current segment."
1837 (declare (type offset byte-offset)
1838 (type disassem-state dstate))
1839 (let ((code (seg-code (dstate-segment dstate))))
1842 (sb!kernel:code-header-ref code
1844 sb!vm:other-pointer-type)
1845 (- sb!vm:word-shift)))
1849 (defvar *assembler-routines-by-addr* nil)
1851 (defun find-assembler-routine (address)
1853 "Returns the name of the primitive lisp assembler routine located at
1854 ADDRESS, or NIL if there isn't one."
1855 (declare (type address address))
1856 (when (null *assembler-routines-by-addr*)
1857 (setf *assembler-routines-by-addr* (make-hash-table))
1858 (maphash #'(lambda (name address)
1859 (setf (gethash address *assembler-routines-by-addr*) name))
1860 sb!kernel:*assembler-routines*))
1861 (gethash address *assembler-routines-by-addr*))
1863 ;;;; some handy function for machine-dependent code to use...
1865 #!-sb-fluid (declaim (maybe-inline sap-ref-int read-suffix))
1867 (defun sap-ref-int (sap offset length byte-order)
1868 (declare (type sb!sys:system-area-pointer sap)
1869 (type (unsigned-byte 16) offset)
1870 (type (member 1 2 4) length)
1871 (type (member :little-endian :big-endian) byte-order)
1872 (optimize (speed 3) (safety 0)))
1874 (1 (sb!sys:sap-ref-8 sap offset))
1875 (2 (if (eq byte-order :big-endian)
1876 (+ (ash (sb!sys:sap-ref-8 sap offset) 8)
1877 (sb!sys:sap-ref-8 sap (+ offset 1)))
1878 (+ (ash (sb!sys:sap-ref-8 sap (+ offset 1)) 8)
1879 (sb!sys:sap-ref-8 sap offset))))
1880 (4 (if (eq byte-order :big-endian)
1881 (+ (ash (sb!sys:sap-ref-8 sap offset) 24)
1882 (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 16)
1883 (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 8)
1884 (sb!sys:sap-ref-8 sap (+ 3 offset)))
1885 (+ (sb!sys:sap-ref-8 sap offset)
1886 (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8)
1887 (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16)
1888 (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24))))))
1890 (defun read-suffix (length dstate)
1891 (declare (type (member 8 16 32) length)
1892 (type disassem-state dstate)
1893 (optimize (speed 3) (safety 0)))
1894 (let ((length (ecase length (8 1) (16 2) (32 4))))
1895 (declare (type (unsigned-byte 3) length))
1897 (sap-ref-int (dstate-segment-sap dstate)
1898 (dstate-next-offs dstate)
1900 (dstate-byte-order dstate))
1901 (incf (dstate-next-offs dstate) length))))
1903 ;;;; optional routines to make notes about code
1905 (defun note (note dstate)
1907 "Store NOTE (which can be either a string or a function with a single
1908 stream argument) to be printed as an end-of-line comment after the current
1909 instruction is disassembled."
1910 (declare (type (or string function) note)
1911 (type disassem-state dstate))
1912 (push note (dstate-notes dstate)))
1914 (defun prin1-short (thing stream)
1915 (with-print-restrictions
1916 (prin1 thing stream)))
1918 (defun prin1-quoted-short (thing stream)
1919 (if (self-evaluating-p thing)
1920 (prin1-short thing stream)
1921 (prin1-short `',thing stream)))
1923 (defun note-code-constant (byte-offset dstate)
1925 "Store a note about the lisp constant located BYTE-OFFSET bytes from the
1926 current code-component, to be printed as an end-of-line comment after the
1927 current instruction is disassembled."
1928 (declare (type offset byte-offset)
1929 (type disassem-state dstate))
1930 (multiple-value-bind (const valid)
1931 (get-code-constant byte-offset dstate)
1933 (note #'(lambda (stream)
1934 (prin1-quoted-short const stream))
1938 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate)
1940 "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
1941 is a valid slot in a symbol, store a note describing which symbol and slot,
1942 to be printed as an end-of-line comment after the current instruction is
1943 disassembled. Returns non-NIL iff a note was recorded."
1944 (declare (type offset nil-byte-offset)
1945 (type disassem-state dstate))
1946 (multiple-value-bind (symbol access-fun)
1947 (grok-nil-indexed-symbol-slot-ref nil-byte-offset)
1949 (note #'(lambda (stream)
1950 (prin1 (if (eq access-fun 'symbol-value)
1952 `(,access-fun ',symbol))
1957 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate)
1959 "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
1960 is a valid lisp object, store a note describing which symbol and slot, to
1961 be printed as an end-of-line comment after the current instruction is
1962 disassembled. Returns non-NIL iff a note was recorded."
1963 (declare (type offset nil-byte-offset)
1964 (type disassem-state dstate))
1965 (let ((obj (get-nil-indexed-object nil-byte-offset)))
1966 (note #'(lambda (stream)
1967 (prin1-quoted-short obj stream))
1971 (defun maybe-note-assembler-routine (address note-address-p dstate)
1973 "If ADDRESS is the address of a primitive assembler routine, store a note
1974 describing which one, to be printed as an end-of-line comment after the
1975 current instruction is disassembled. Returns non-NIL iff a note was
1976 recorded. If NOTE-ADDRESS-P is non-NIL, a note of the address is also made."
1977 (declare (type address address)
1978 (type disassem-state dstate))
1979 (let ((name (find-assembler-routine address)))
1981 (note #'(lambda (stream)
1983 (format stream "#X~8,'0x: ~S" address name)
1984 (prin1 name stream)))
1988 (defun maybe-note-single-storage-ref (offset sc-name dstate)
1990 "If there's a valid mapping from OFFSET in the storage class SC-NAME to a
1991 source variable, make a note of the source-variable name, to be printed as
1992 an end-of-line comment after the current instruction is disassembled.
1993 Returns non-NIL iff a note was recorded."
1994 (declare (type offset offset)
1995 (type symbol sc-name)
1996 (type disassem-state dstate))
1997 (let ((storage-location
1998 (find-valid-storage-location offset sc-name dstate)))
1999 (when storage-location
2000 (note #'(lambda (stream)
2001 (princ (sb!di:debug-var-symbol
2002 (aref (storage-info-debug-vars
2003 (seg-storage-info (dstate-segment dstate)))
2009 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate)
2011 "If there's a valid mapping from OFFSET in the storage-base called SB-NAME
2012 to a source variable, make a note equating ASSOC-WITH with the
2013 source-variable name, to be printed as an end-of-line comment after the
2014 current instruction is disassembled. Returns non-NIL iff a note was
2016 (declare (type offset offset)
2017 (type symbol sb-name)
2018 (type (or symbol string) assoc-with)
2019 (type disassem-state dstate))
2020 (let ((storage-location
2021 (find-valid-storage-location offset sb-name dstate)))
2022 (when storage-location
2023 (note #'(lambda (stream)
2024 (format stream "~A = ~S"
2026 (sb!di:debug-var-symbol
2027 (aref (dstate-debug-vars dstate)
2033 (defun get-internal-error-name (errnum)
2034 (car (svref sb!c:*backend-internal-errors* errnum)))
2036 (defun get-sc-name (sc-offs)
2037 (sb!c::location-print-name
2038 ;; FIXME: This seems like an awful lot of computation just to get a name.
2039 ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
2041 (sb!c:make-random-tn :kind :normal
2042 :sc (svref sb!c:*backend-sc-numbers*
2043 (sb!c:sc-offset-scn sc-offs))
2044 :offset (sb!c:sc-offset-offset sc-offs))))
2046 (defun handle-break-args (error-parse-fun stream dstate)
2048 "When called from an error break instruction's :DISASSEM-CONTROL (or
2049 :DISASSEM-PRINTER) function, will correctly deal with printing the
2050 arguments to the break.
2052 ERROR-PARSE-FUN should be a function that accepts:
2053 1) a SYSTEM-AREA-POINTER
2054 2) a BYTE-OFFSET from the SAP to begin at
2055 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
2056 the byte length of the arguments (to avoid unnecessary consing)
2057 It should read information from the SAP starting at BYTE-OFFSET, and return
2060 2) the total length, in bytes, of the information
2061 3) a list of SC-OFFSETs of the locations of the error parameters
2062 4) a list of the length (as read from the SAP), in bytes, of each of the
2064 (declare (type function error-parse-fun)
2065 (type (or null stream) stream)
2066 (type disassem-state dstate))
2067 (multiple-value-bind (errnum adjust sc-offsets lengths)
2068 (funcall error-parse-fun
2069 (dstate-segment-sap dstate)
2070 (dstate-next-offs dstate)
2073 (setf (dstate-cur-offs dstate)
2074 (dstate-next-offs dstate))
2075 (flet ((emit-err-arg (note)
2076 (let ((num (pop lengths)))
2077 (print-notes-and-newline stream dstate)
2078 (print-current-address stream dstate)
2079 (print-bytes num stream dstate)
2080 (incf (dstate-cur-offs dstate) num)
2082 (note note dstate)))))
2084 (emit-err-arg (symbol-name (get-internal-error-name errnum)))
2085 (dolist (sc-offs sc-offsets)
2086 (emit-err-arg (get-sc-name sc-offs)))))
2087 (incf (dstate-next-offs dstate)