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 ;;; Print enough spaces to fill the column used for instruction bytes,
475 ;;; assuming that N-BYTES many instruction bytes have already been
476 ;;; printed in it, then print an additional space as separator to the
478 (defun pad-inst-column (stream n-bytes
)
479 (declare (type stream stream
)
480 (type text-width n-bytes
))
481 (when (> *disassem-inst-column-width
* 0)
482 (dotimes (i (- *disassem-inst-column-width
* (* 2 n-bytes
)))
483 (write-char #\space stream
))
484 (write-char #\space stream
)))
486 (defun handle-bogus-instruction (stream dstate prefix-len
)
487 (let ((alignment (dstate-alignment dstate
)))
488 (unless (null stream
)
489 (multiple-value-bind (words bytes
)
490 (truncate alignment sb
!vm
:n-word-bytes
)
492 (print-inst (* words sb
!vm
:n-word-bytes
) stream dstate
493 :trailing-space nil
))
495 (print-inst bytes stream dstate
:trailing-space nil
)))
496 (pad-inst-column stream
(+ prefix-len alignment
))
497 (decf (dstate-cur-offs dstate
) prefix-len
)
498 (print-bytes (+ prefix-len alignment
) stream dstate
))
499 (incf (dstate-next-offs dstate
) alignment
)))
501 ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
502 ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE.
503 ;;; Additionally, unless STREAM is NIL, several items are output to it:
504 ;;; things printed from several hooks, for example labels, and instruction
505 ;;; bytes before FUNCTION is called, notes and a newline afterwards.
506 ;;; Instructions having an INST-PRINTER of NIL are treated as prefix
507 ;;; instructions which makes them print on the same line as the following
508 ;;; instruction, outputting their INST-PRINT-NAME (unless that is NIL)
509 ;;; before FUNCTION is called for the following instruction.
510 (defun map-segment-instructions (function segment dstate
&optional stream
)
511 (declare (type function function
)
512 (type segment segment
)
513 (type disassem-state dstate
)
514 (type (or null stream
) stream
))
516 (let ((ispace (get-inst-space))
517 (prefix-p nil
) ; just processed a prefix inst
518 (prefix-len 0) ; sum of lengths of any prefix instruction(s)
519 (prefix-print-names nil
)) ; reverse list of prefixes seen
521 (rewind-current-segment dstate segment
)
524 (when (>= (dstate-cur-offs dstate
)
525 (seg-length (dstate-segment dstate
)))
527 (when (and stream
(> prefix-len
0))
528 (pad-inst-column stream prefix-len
)
529 (decf (dstate-cur-offs dstate
) prefix-len
)
530 (print-bytes prefix-len stream dstate
)
531 (incf (dstate-cur-offs dstate
) prefix-len
))
534 (setf (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
536 (call-offs-hooks t stream dstate
)
537 (unless (or prefix-p
(null stream
))
538 (print-current-address stream dstate
))
539 (call-offs-hooks nil stream dstate
)
541 (unless (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
542 (sb!sys
:without-gcing
543 (setf (dstate-segment-sap dstate
) (funcall (seg-sap-maker segment
)))
546 (sap-ref-dchunk (dstate-segment-sap dstate
)
547 (dstate-cur-offs dstate
)
548 (dstate-byte-order dstate
)))
549 (fun-prefix-p (call-fun-hooks chunk stream dstate
)))
550 (if (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
551 (setf prefix-p fun-prefix-p
)
552 (let ((inst (find-inst chunk ispace
)))
554 (handle-bogus-instruction stream dstate prefix-len
)
557 (setf (dstate-next-offs dstate
)
558 (+ (dstate-cur-offs dstate
)
560 (let ((orig-next (dstate-next-offs dstate
))
561 (prefilter (inst-prefilter inst
))
562 (control (inst-control inst
)))
563 (print-inst (inst-length inst
) stream dstate
566 (funcall prefilter chunk dstate
))
568 (setf prefix-p
(null (inst-printer inst
)))
571 ;; Print any instruction bytes recognized by
572 ;; the prefilter which calls read-suffix and
573 ;; updates next-offs.
574 (let ((suffix-len (- (dstate-next-offs dstate
)
576 (when (plusp suffix-len
)
577 (print-inst suffix-len stream dstate
578 :offset
(inst-length inst
)
579 :trailing-space nil
))
580 ;; Keep track of the number of bytes
582 (incf prefix-len
(+ (inst-length inst
)
585 (let ((name (inst-print-name inst
)))
587 (push name prefix-print-names
)))
589 ;; PREFIX-LEN includes the length of the
590 ;; current (non-prefix) instruction here.
591 (pad-inst-column stream prefix-len
)
592 (dolist (name (reverse prefix-print-names
))
594 (write-char #\space stream
)))))
596 (funcall function chunk inst
)
599 (funcall control chunk inst stream dstate
))))))))))
601 (setf (dstate-cur-offs dstate
) (dstate-next-offs dstate
))
606 prefix-print-names nil
)
607 (print-notes-and-newline stream dstate
))
608 (setf (dstate-output-state dstate
) nil
))
610 (setf (dstate-inst-properties dstate
) nil
)))))
613 ;;; Make an initial non-printing disassembly pass through DSTATE,
614 ;;; noting any addresses that are referenced by instructions in this
616 (defun add-segment-labels (segment dstate
)
617 ;; add labels at the beginning with a label-number of nil; we'll notice
618 ;; later and fill them in (and sort them)
619 (declare (type disassem-state dstate
))
620 (let ((labels (dstate-labels dstate
)))
621 (map-segment-instructions
623 (declare (type dchunk chunk
) (type instruction inst
))
624 (let ((labeller (inst-labeller inst
)))
626 (setf labels
(funcall labeller chunk labels dstate
)))))
629 (setf (dstate-labels dstate
) labels
)
630 ;; erase any notes that got there by accident
631 (setf (dstate-notes dstate
) nil
)))
633 ;;; If any labels in DSTATE have been added since the last call to
634 ;;; this function, give them label-numbers, enter them in the
635 ;;; hash-table, and make sure the label list is in sorted order.
636 (defun number-labels (dstate)
637 (let ((labels (dstate-labels dstate
)))
638 (when (and labels
(null (cdar labels
)))
639 ;; at least one label left un-numbered
640 (setf labels
(sort labels
#'< :key
#'car
))
642 (label-hash (dstate-label-hash dstate
)))
643 (dolist (label labels
)
644 (when (not (null (cdr label
)))
645 (setf max
(max max
(cdr label
)))))
646 (dolist (label labels
)
647 (when (null (cdr label
))
649 (setf (cdr label
) max
)
650 (setf (gethash (car label
) label-hash
)
651 (format nil
"L~W" max
)))))
652 (setf (dstate-labels dstate
) labels
))))
654 ;;; Get the instruction-space, creating it if necessary.
655 (defun get-inst-space ()
656 (let ((ispace *disassem-inst-space
*))
659 (maphash (lambda (name inst-flavs
)
660 (declare (ignore name
))
661 (dolist (flav inst-flavs
)
664 (setf ispace
(build-inst-space insts
)))
665 (setf *disassem-inst-space
* ispace
))
668 ;;;; Add global hooks.
670 (defun add-offs-hook (segment addr hook
)
671 (let ((entry (cons addr hook
)))
672 (if (null (seg-hooks segment
))
673 (setf (seg-hooks segment
) (list entry
))
674 (push entry
(cdr (last (seg-hooks segment
)))))))
676 (defun add-offs-note-hook (segment addr note
)
677 (add-offs-hook segment
679 (lambda (stream dstate
)
680 (declare (type (or null stream
) stream
)
681 (type disassem-state dstate
))
683 (note note dstate
)))))
685 (defun add-offs-comment-hook (segment addr comment
)
686 (add-offs-hook segment
688 (lambda (stream dstate
)
689 (declare (type (or null stream
) stream
)
692 (write-string ";;; " stream
)
695 (write-string comment stream
))
697 (funcall comment stream
)))
700 (defun add-fun-hook (dstate function
)
701 (push function
(dstate-fun-hooks dstate
)))
703 (defun set-location-printing-range (dstate from length
)
704 (setf (dstate-addr-print-len dstate
)
705 ;; 4 bits per hex digit
706 (ceiling (integer-length (logxor from
(+ from length
))) 4)))
708 ;;; Print the current address in DSTATE to STREAM, plus any labels that
709 ;;; correspond to it, and leave the cursor in the instruction column.
710 (defun print-current-address (stream dstate
)
711 (declare (type stream stream
)
712 (type disassem-state dstate
))
714 (+ (seg-virtual-location (dstate-segment dstate
))
715 (dstate-cur-offs dstate
)))
716 (location-column-width *disassem-location-column-width
*)
717 (plen (dstate-addr-print-len dstate
)))
720 (setf plen location-column-width
)
721 (let ((seg (dstate-segment dstate
)))
722 (set-location-printing-range dstate
723 (seg-virtual-location seg
)
725 (when (eq (dstate-output-state dstate
) :beginning
)
726 (setf plen location-column-width
))
730 (setf location-column-width
(+ 2 location-column-width
))
733 ;; print the location
734 ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
735 ;; usually avoids any consing]
736 (tab0 (- location-column-width plen
) stream
)
737 (let* ((printed-bits (* 4 plen
))
738 (printed-value (ldb (byte printed-bits
0) location
))
740 (truncate (- printed-bits
(integer-length printed-value
)) 4)))
741 (dotimes (i leading-zeros
)
742 (write-char #\
0 stream
))
743 (unless (zerop printed-value
)
744 (write printed-value
:stream stream
:base
16 :radix nil
))
745 (write-char #\
: stream
))
749 (let* ((next-label (car (dstate-cur-labels dstate
)))
750 (label-location (car next-label
)))
751 (when (or (null label-location
) (> label-location location
))
753 (unless (< label-location location
)
754 (format stream
" L~W:" (cdr next-label
)))
755 (pop (dstate-cur-labels dstate
))))
757 ;; move to the instruction column
758 (tab0 (+ location-column-width
1 label-column-width
) stream
)
761 (eval-when (:compile-toplevel
:execute
)
762 (sb!xc
:defmacro with-print-restrictions
(&rest body
)
763 `(let ((*print-pretty
* t
)
769 ;;; Print a newline to STREAM, inserting any pending notes in DSTATE
770 ;;; as end-of-line comments. If there is more than one note, a
771 ;;; separate line will be used for each one.
772 (defun print-notes-and-newline (stream dstate
)
773 (declare (type stream stream
)
774 (type disassem-state dstate
))
775 (with-print-restrictions
776 (dolist (note (dstate-notes dstate
))
777 (format stream
"~Vt " *disassem-note-column
*)
778 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
781 (write-string note stream
))
783 (funcall note stream
))))
786 (setf (dstate-notes dstate
) nil
)))
788 ;;; Print NUM instruction bytes to STREAM as hex values.
789 (defun print-inst (num stream dstate
&key
(offset 0) (trailing-space t
))
790 (when (> *disassem-inst-column-width
* 0)
791 (let ((sap (dstate-segment-sap dstate
))
792 (start-offs (+ offset
(dstate-cur-offs dstate
))))
794 (format stream
"~2,'0x" (sb!sys
:sap-ref-8 sap
(+ offs start-offs
))))
796 (pad-inst-column stream num
)))))
798 ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
799 (defun print-bytes (num stream dstate
)
800 (declare (type offset num
)
802 (type disassem-state dstate
))
803 (format stream
"~A~Vt" 'BYTE
(dstate-argument-column dstate
))
804 (let ((sap (dstate-segment-sap dstate
))
805 (start-offs (dstate-cur-offs dstate
)))
808 (write-string ", " stream
))
809 (format stream
"#X~2,'0x" (sb!sys
:sap-ref-8 sap
(+ offs start-offs
))))))
811 ;;; Disassemble NUM machine-words to STREAM as simple `WORD' instructions.
812 (defun print-words (num stream dstate
)
813 (declare (type offset num
)
815 (type disassem-state dstate
))
816 (format stream
"~A~Vt" 'WORD
(dstate-argument-column dstate
))
817 (let ((sap (dstate-segment-sap dstate
))
818 (start-offs (dstate-cur-offs dstate
))
819 (byte-order (dstate-byte-order dstate
)))
820 (dotimes (word-offs num
)
821 (unless (zerop word-offs
)
822 (write-string ", " stream
))
823 (let ((word 0) (bit-shift 0))
824 (dotimes (byte-offs sb
!vm
:n-word-bytes
)
829 (* word-offs sb
!vm
:n-word-bytes
)
832 (if (eq byte-order
:big-endian
)
833 (+ (ash word sb
!vm
:n-byte-bits
) byte
)
834 (+ word
(ash byte bit-shift
))))
835 (incf bit-shift sb
!vm
:n-byte-bits
)))
836 (format stream
"#X~V,'0X" (ash sb
!vm
:n-word-bits -
2) word
)))))
838 (defvar *default-dstate-hooks
* (list #'lra-hook
))
840 ;;; Make a disassembler-state object.
841 (defun make-dstate (&optional
(fun-hooks *default-dstate-hooks
*))
842 (let ((alignment *disassem-inst-alignment-bytes
*)
845 *disassem-location-column-width
*
848 *disassem-inst-column-width
*
849 (if (zerop *disassem-inst-column-width
*) 0 1)
850 *disassem-opcode-column-width
*)))
852 (when (> alignment
1)
853 (push #'alignment-hook fun-hooks
))
855 (%make-dstate
:fun-hooks fun-hooks
856 :argument-column arg-column
858 :byte-order sb
!c
:*backend-byte-order
*)))
860 (defun add-fun-header-hooks (segment)
861 (declare (type segment segment
))
862 (do ((fun (sb!kernel
:code-header-ref
(seg-code segment
)
863 sb
!vm
:code-entry-points-slot
)
865 (length (seg-length segment
)))
867 (let ((offset (code-offs-to-segment-offs (fun-offset fun
) segment
)))
868 (when (<= 0 offset length
)
869 (push (make-offs-hook :offset offset
:fun
#'fun-header-hook
)
870 (seg-hooks segment
))))))
872 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
874 ;; FIXME: Are the objects we are taking saps for always pinned?
875 #!-sb-fluid
(declaim (inline sap-maker
))
876 (defun sap-maker (function input offset
)
877 (declare (optimize (speed 3))
878 (type (function (t) sb
!sys
:system-area-pointer
) function
)
879 (type offset offset
))
880 (let ((old-sap (sb!sys
:sap
+ (funcall function input
) offset
)))
881 (declare (type sb
!sys
:system-area-pointer old-sap
))
884 (+ (sb!sys
:sap-int
(funcall function input
)) offset
)))
885 ;; Saving the sap like this avoids consing except when the sap
886 ;; changes (because the sap-int, arith, etc., get inlined).
887 (declare (type address new-addr
))
888 (if (= (sb!sys
:sap-int old-sap
) new-addr
)
890 (setf old-sap
(sb!sys
:int-sap new-addr
)))))))
892 (defun vector-sap-maker (vector offset
)
893 (declare (optimize (speed 3))
894 (type offset offset
))
895 (sap-maker #'sb
!sys
:vector-sap vector offset
))
897 (defun code-sap-maker (code offset
)
898 (declare (optimize (speed 3))
899 (type sb
!kernel
:code-component code
)
900 (type offset offset
))
901 (sap-maker #'sb
!kernel
:code-instructions code offset
))
903 (defun memory-sap-maker (address)
904 (declare (optimize (speed 3))
905 (type address address
))
906 (let ((sap (sb!sys
:int-sap address
)))
909 ;;; Return a memory segment located at the system-area-pointer returned by
910 ;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
912 ;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
913 ;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a
914 ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
916 (defun make-segment (sap-maker length
918 code virtual-location
919 debug-fun source-form-cache
921 (declare (type (function () sb
!sys
:system-area-pointer
) sap-maker
)
922 (type disassem-length length
)
923 (type (or null address
) virtual-location
)
924 (type (or null sb
!di
:debug-fun
) debug-fun
)
925 (type (or null source-form-cache
) source-form-cache
))
930 :virtual-location
(or virtual-location
931 (sb!sys
:sap-int
(funcall sap-maker
)))
934 (add-debugging-hooks segment debug-fun source-form-cache
)
935 (add-fun-header-hooks segment
)
938 (defun make-vector-segment (vector offset
&rest args
)
939 (declare (type vector vector
)
941 (inline make-segment
))
942 (apply #'make-segment
(vector-sap-maker vector offset
) args
))
944 (defun make-code-segment (code offset length
&rest args
)
945 (declare (type sb
!kernel
:code-component code
)
947 (inline make-segment
))
948 (apply #'make-segment
(code-sap-maker code offset
) length
:code code args
))
950 (defun make-memory-segment (address &rest args
)
951 (declare (type address address
)
952 (inline make-segment
))
953 (apply #'make-segment
(memory-sap-maker address
) args
))
956 (defun print-fun-headers (function)
957 (declare (type compiled-function function
))
958 (let* ((self (fun-self function
))
959 (code (sb!kernel
:fun-code-header self
)))
960 (format t
"Code-header ~S: size: ~S, trace-table-offset: ~S~%"
962 (sb!kernel
:code-header-ref code
963 sb
!vm
:code-code-size-slot
)
964 (sb!kernel
:code-header-ref code
965 sb
!vm
:code-trace-table-offset-slot
))
966 (do ((fun (sb!kernel
:code-header-ref code sb
!vm
:code-entry-points-slot
)
969 (let ((fun-offset (sb!kernel
:get-closure-length fun
)))
970 ;; There is function header fun-offset words from the
972 (format t
"Fun-header ~S at offset ~W (words): ~S~A => ~S~%"
975 (sb!kernel
:code-header-ref
976 code
(+ fun-offset sb
!vm
:simple-fun-name-slot
))
977 (sb!kernel
:code-header-ref
978 code
(+ fun-offset sb
!vm
:simple-fun-arglist-slot
))
979 (sb!kernel
:code-header-ref
980 code
(+ fun-offset sb
!vm
:simple-fun-type-slot
)))))))
982 ;;; getting at the source code...
984 (defstruct (source-form-cache (:conc-name sfcache-
)
986 (debug-source nil
:type
(or null sb
!di
:debug-source
))
987 (toplevel-form-index -
1 :type fixnum
)
988 (last-location-retrieved nil
:type
(or null sb
!di
:code-location
))
989 (last-form-retrieved -
1 :type fixnum
))
991 (defun get-different-source-form (loc context
&optional cache
)
993 (eq (sb!di
:code-location-debug-source loc
)
994 (sfcache-debug-source cache
))
995 (eq (sb!di
:code-location-toplevel-form-offset loc
)
996 (sfcache-toplevel-form-index cache
))
997 (or (eql (sb!di
:code-location-form-number loc
)
998 (sfcache-last-form-retrieved cache
))
999 (awhen (sfcache-last-location-retrieved cache
)
1000 (sb!di
:code-location
= loc it
))))
1002 (let ((form (sb!debug
::code-location-source-form loc context nil
)))
1004 (setf (sfcache-debug-source cache
)
1005 (sb!di
:code-location-debug-source loc
))
1006 (setf (sfcache-toplevel-form-index cache
)
1007 (sb!di
:code-location-toplevel-form-offset loc
))
1008 (setf (sfcache-last-form-retrieved cache
)
1009 (sb!di
:code-location-form-number loc
))
1010 (setf (sfcache-last-location-retrieved cache
) loc
))
1013 ;;;; stuff to use debugging info to augment the disassembly
1015 (defun code-fun-map (code)
1016 (declare (type sb
!kernel
:code-component code
))
1017 (sb!c
::compiled-debug-info-fun-map
(sb!kernel
:%code-debug-info code
)))
1019 (defstruct (location-group (:copier nil
))
1020 (locations #() :type
(vector (or list fixnum
))))
1022 (defstruct (storage-info (:copier nil
))
1023 (groups nil
:type list
) ; alist of (name . location-group)
1024 (debug-vars #() :type vector
))
1026 ;;; Return the vector of DEBUG-VARs currently associated with DSTATE.
1027 (defun dstate-debug-vars (dstate)
1028 (declare (type disassem-state dstate
))
1029 (storage-info-debug-vars (seg-storage-info (dstate-segment dstate
))))
1031 ;;; Given the OFFSET of a location within the location-group called
1032 ;;; LG-NAME, see whether there's a current mapping to a source
1033 ;;; variable in DSTATE, and if so, return the offset of that variable
1034 ;;; in the current debug-var vector.
1035 (defun find-valid-storage-location (offset lg-name dstate
)
1036 (declare (type offset offset
)
1037 (type symbol lg-name
)
1038 (type disassem-state dstate
))
1039 (let* ((storage-info
1040 (seg-storage-info (dstate-segment dstate
)))
1043 (cdr (assoc lg-name
(storage-info-groups storage-info
)))))
1045 (dstate-current-valid-locations dstate
)))
1047 (not (null currently-valid
))
1048 (let ((locations (location-group-locations location-group
)))
1049 (and (< offset
(length locations
))
1050 (let ((used-by (aref locations offset
)))
1052 (let ((debug-var-num
1056 (zerop (bit currently-valid used-by
)))
1062 (bit currently-valid num
)))
1067 ;; Found a valid storage reference!
1068 ;; can't use it again until it's revalidated...
1069 (setf (bit (dstate-current-valid-locations
1076 ;;; Return a new vector which has the same contents as the old one
1077 ;;; VEC, plus new cells (for a total size of NEW-LEN). The additional
1078 ;;; elements are initialized to INITIAL-ELEMENT.
1079 (defun grow-vector (vec new-len
&optional initial-element
)
1080 (declare (type vector vec
)
1081 (type fixnum new-len
))
1083 (make-sequence `(vector ,(array-element-type vec
) ,new-len
)
1085 :initial-element initial-element
)))
1086 (dotimes (i (length vec
))
1087 (setf (aref new i
) (aref vec i
)))
1090 ;;; Return a STORAGE-INFO struction describing the object-to-source
1091 ;;; variable mappings from DEBUG-FUN.
1092 (defun storage-info-for-debug-fun (debug-fun)
1093 (declare (type sb
!di
:debug-fun debug-fun
))
1094 (let ((sc-vec sb
!c
::*backend-sc-numbers
*)
1096 (debug-vars (sb!di
::debug-fun-debug-vars
1099 (dotimes (debug-var-offset
1101 (make-storage-info :groups groups
1102 :debug-vars debug-vars
))
1103 (let ((debug-var (aref debug-vars debug-var-offset
)))
1105 (format t
";;; At offset ~W: ~S~%" debug-var-offset debug-var
)
1107 (sb!di
::compiled-debug-var-sc-offset debug-var
))
1110 (sb!c
:sc-sb
(aref sc-vec
1111 (sb!c
:sc-offset-scn sc-offset
))))))
1113 (format t
";;; SET: ~S[~W]~%"
1114 sb-name
(sb!c
:sc-offset-offset sc-offset
))
1115 (unless (null sb-name
)
1116 (let ((group (cdr (assoc sb-name groups
))))
1118 (setf group
(make-location-group))
1119 (push `(,sb-name .
,group
) groups
))
1120 (let* ((locations (location-group-locations group
))
1121 (length (length locations
))
1122 (offset (sb!c
:sc-offset-offset sc-offset
)))
1123 (when (>= offset length
)
1125 (grow-vector locations
1129 (location-group-locations group
)
1131 (let ((already-there (aref locations offset
)))
1132 (cond ((null already-there
)
1133 (setf (aref locations offset
) debug-var-offset
))
1134 ((eql already-there debug-var-offset
))
1136 (if (listp already-there
)
1137 (pushnew debug-var-offset
1138 (aref locations offset
))
1139 (setf (aref locations offset
)
1140 (list debug-var-offset
1145 (defun source-available-p (debug-fun)
1147 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1148 (declare (ignore block
))
1150 (sb!di
:no-debug-blocks
() nil
)))
1152 (defun print-block-boundary (stream dstate
)
1153 (let ((os (dstate-output-state dstate
)))
1154 (when (not (eq os
:beginning
))
1155 (when (not (eq os
:block-boundary
))
1157 (setf (dstate-output-state dstate
)
1160 ;;; Add hooks to track the source code in SEGMENT during disassembly.
1161 ;;; SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
1162 ;;; structure, in which case it is used to cache forms from files.
1163 (defun add-source-tracking-hooks (segment debug-fun
&optional sfcache
)
1164 (declare (type segment segment
)
1165 (type (or null sb
!di
:debug-fun
) debug-fun
)
1166 (type (or null source-form-cache
) sfcache
))
1167 (let ((last-block-pc -
1))
1168 (flet ((add-hook (pc fun
&optional before-address
)
1169 (push (make-offs-hook
1170 :offset pc
;; ### FIX to account for non-zero offs in code
1172 :before-address before-address
)
1173 (seg-hooks segment
))))
1175 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1176 (let ((first-location-in-block-p t
))
1177 (sb!di
:do-debug-block-locations
(loc block
)
1178 (let ((pc (sb!di
::compiled-code-location-pc loc
)))
1180 ;; Put blank lines in at block boundaries
1181 (when (and first-location-in-block-p
1182 (/= pc last-block-pc
))
1183 (setf first-location-in-block-p nil
)
1185 (lambda (stream dstate
)
1186 (print-block-boundary stream dstate
))
1188 (setf last-block-pc pc
))
1190 ;; Print out corresponding source; this information is not
1191 ;; all that accurate, but it's better than nothing
1192 (unless (zerop (sb!di
:code-location-form-number loc
))
1193 (multiple-value-bind (form new
)
1194 (get-different-source-form loc
0 sfcache
)
1196 (let ((at-block-begin (= pc last-block-pc
)))
1199 (lambda (stream dstate
)
1200 (declare (ignore dstate
))
1202 (unless at-block-begin
1204 (format stream
";;; [~W] "
1205 (sb!di
:code-location-form-number
1207 (prin1-short form stream
)
1212 ;; Keep track of variable live-ness as best we can.
1214 (copy-seq (sb!di
::compiled-code-location-live-set
1218 (lambda (stream dstate
)
1219 (declare (ignore stream
))
1220 (setf (dstate-current-valid-locations dstate
)
1223 (note (lambda (stream)
1224 (let ((*print-length
* nil
))
1225 (format stream
"live set: ~S"
1229 (sb!di
:no-debug-blocks
() nil
)))))
1231 (defvar *disassemble-annotate
* t
1232 "Annotate DISASSEMBLE output with source code.")
1234 (defun add-debugging-hooks (segment debug-fun
&optional sfcache
)
1236 (setf (seg-storage-info segment
)
1237 (storage-info-for-debug-fun debug-fun
))
1238 (when *disassemble-annotate
*
1239 (add-source-tracking-hooks segment debug-fun sfcache
))
1240 (let ((kind (sb!di
:debug-fun-kind debug-fun
)))
1241 (flet ((add-new-hook (n)
1242 (push (make-offs-hook
1244 :fun
(lambda (stream dstate
)
1245 (declare (ignore stream
))
1247 (seg-hooks segment
))))
1251 (add-new-hook "no-arg-parsing entry point"))
1253 (add-new-hook (lambda (stream)
1254 (format stream
"~S entry point" kind
)))))))))
1256 ;;; Return a list of the segments of memory containing machine code
1257 ;;; instructions for FUNCTION.
1258 (defun get-fun-segments (function)
1259 (declare (type compiled-function function
))
1260 (let* ((code (fun-code function
))
1261 (fun-map (code-fun-map code
))
1262 (fname (sb!kernel
:%simple-fun-name function
))
1263 (sfcache (make-source-form-cache)))
1264 (let ((first-block-seen-p nil
)
1265 (nil-block-seen-p nil
)
1267 (last-debug-fun nil
)
1269 (flet ((add-seg (offs len df
)
1271 (push (make-code-segment code offs len
1273 :source-form-cache sfcache
)
1275 (dotimes (fmap-index (length fun-map
))
1276 (let ((fmap-entry (aref fun-map fmap-index
)))
1277 (etypecase fmap-entry
1279 (when first-block-seen-p
1280 (add-seg last-offset
1281 (- fmap-entry last-offset
)
1283 (setf last-debug-fun nil
))
1284 (setf last-offset fmap-entry
))
1285 (sb!c
::compiled-debug-fun
1286 (let ((name (sb!c
::compiled-debug-fun-name fmap-entry
))
1287 (kind (sb!c
::compiled-debug-fun-kind fmap-entry
)))
1289 (format t
";;; SAW ~S ~S ~S,~S ~W,~W~%"
1290 name kind first-block-seen-p nil-block-seen-p
1292 (sb!c
::compiled-debug-fun-start-pc fmap-entry
))
1293 (cond (#+nil
(eq last-offset fun-offset
)
1294 (and (equal name fname
) (not first-block-seen-p
))
1295 (setf first-block-seen-p t
))
1296 ((eq kind
:external
)
1297 (when first-block-seen-p
1300 (when nil-block-seen-p
1302 (when first-block-seen-p
1303 (setf nil-block-seen-p t
))))
1304 (setf last-debug-fun
1305 (sb!di
::make-compiled-debug-fun fmap-entry code
)))))))
1306 (let ((max-offset (code-inst-area-length code
)))
1307 (when (and first-block-seen-p last-debug-fun
)
1308 (add-seg last-offset
1309 (- max-offset last-offset
)
1312 (let ((offs (fun-insts-offset function
)))
1314 (make-code-segment code offs
(- max-offset offs
))))
1315 (nreverse segments
)))))))
1317 ;;; Return a list of the segments of memory containing machine code
1318 ;;; instructions for the code-component CODE. If START-OFFSET and/or
1319 ;;; LENGTH is supplied, only that part of the code-segment is used
1320 ;;; (but these are constrained to lie within the code-segment).
1321 (defun get-code-segments (code
1324 (length (code-inst-area-length code
)))
1325 (declare (type sb
!kernel
:code-component code
)
1326 (type offset start-offset
)
1327 (type disassem-length length
))
1328 (let ((segments nil
))
1330 (let ((fun-map (code-fun-map code
))
1331 (sfcache (make-source-form-cache)))
1332 (let ((last-offset 0)
1333 (last-debug-fun nil
))
1334 (flet ((add-seg (offs len df
)
1335 (let* ((restricted-offs
1336 (min (max start-offset offs
)
1337 (+ start-offset length
)))
1339 (- (min (max start-offset
(+ offs len
))
1340 (+ start-offset length
))
1342 (when (> restricted-len
0)
1343 (push (make-code-segment code
1344 restricted-offs restricted-len
1346 :source-form-cache sfcache
)
1348 (dotimes (fun-map-index (length fun-map
))
1349 (let ((fun-map-entry (aref fun-map fun-map-index
)))
1350 (etypecase fun-map-entry
1352 (add-seg last-offset
(- fun-map-entry last-offset
)
1354 (setf last-debug-fun nil
)
1355 (setf last-offset fun-map-entry
))
1356 (sb!c
::compiled-debug-fun
1357 (setf last-debug-fun
1358 (sb!di
::make-compiled-debug-fun fun-map-entry
1360 (when last-debug-fun
1361 (add-seg last-offset
1362 (- (code-inst-area-length code
) last-offset
)
1363 last-debug-fun
))))))
1365 (make-code-segment code start-offset length
)
1366 (nreverse segments
))))
1368 ;;; Compute labels for all the memory segments in SEGLIST and adds
1369 ;;; them to DSTATE. It's important to call this function with all the
1370 ;;; segments you're interested in, so that it can find references from
1372 (defun label-segments (seglist dstate
)
1373 (declare (type list seglist
)
1374 (type disassem-state dstate
))
1375 (dolist (seg seglist
)
1376 (add-segment-labels seg dstate
))
1377 ;; Now remove any labels that don't point anywhere in the segments
1379 (setf (dstate-labels dstate
)
1380 (remove-if (lambda (lab)
1383 (let ((start (seg-virtual-location seg
)))
1386 (+ start
(seg-length seg
)))))
1388 (dstate-labels dstate
))))
1390 ;;; Disassemble the machine code instructions in SEGMENT to STREAM.
1391 (defun disassemble-segment (segment stream dstate
)
1392 (declare (type segment segment
)
1393 (type stream stream
)
1394 (type disassem-state dstate
))
1395 (let ((*print-pretty
* nil
)) ; otherwise the pp conses hugely
1396 (number-labels dstate
)
1397 (map-segment-instructions
1398 (lambda (chunk inst
)
1399 (declare (type dchunk chunk
) (type instruction inst
))
1400 (let ((printer (inst-printer inst
)))
1402 (funcall printer chunk inst stream dstate
))))
1407 ;;; Disassemble the machine code instructions in each memory segment
1408 ;;; in SEGMENTS in turn to STREAM.
1409 (defun disassemble-segments (segments stream dstate
)
1410 (declare (type list segments
)
1411 (type stream stream
)
1412 (type disassem-state dstate
))
1413 (unless (null segments
)
1414 (format stream
"~&; Size: ~a bytes"
1415 (reduce #'+ segments
:key
#'seg-length
))
1416 (let ((first (car segments
))
1417 (last (car (last segments
))))
1418 (set-location-printing-range dstate
1419 (seg-virtual-location first
)
1420 (- (+ (seg-virtual-location last
)
1422 (seg-virtual-location first
)))
1423 (setf (dstate-output-state dstate
) :beginning
)
1424 (dolist (seg segments
)
1425 (disassemble-segment seg stream dstate
)))))
1427 ;;;; top level functions
1429 ;;; Disassemble the machine code instructions for FUNCTION.
1430 (defun disassemble-fun (fun &key
1431 (stream *standard-output
*)
1433 (declare (type compiled-function fun
)
1434 (type stream stream
)
1435 (type (member t nil
) use-labels
))
1436 (let* ((dstate (make-dstate))
1437 (segments (get-fun-segments fun
)))
1439 (label-segments segments dstate
))
1440 (disassemble-segments segments stream dstate
)))
1442 (defun valid-extended-function-designators-for-disassemble-p (thing)
1443 (cond ((legal-fun-name-p thing
)
1444 (compiled-funs-or-lose (fdefinition thing
) thing
))
1446 ((sb!eval
:interpreted-function-p thing
)
1447 (compile nil thing
))
1448 ((typep thing
'sb
!pcl
::%method-function
)
1449 ;; in a %METHOD-FUNCTION, the user code is in the fast function, so
1450 ;; we to disassemble both.
1451 (list thing
(sb!pcl
::%method-function-fast-function thing
)))
1455 (eq (car thing
) 'lambda
))
1456 (compile nil thing
))
1459 (defun compiled-funs-or-lose (thing &optional
(name thing
))
1460 (let ((funs (valid-extended-function-designators-for-disassemble-p thing
)))
1463 (error 'simple-type-error
1465 :expected-type
'(satisfies valid-extended-function-designators-for-disassemble-p
)
1466 :format-control
"Can't make a compiled function from ~S"
1467 :format-arguments
(list name
)))))
1469 (defun disassemble (object &key
1470 (stream *standard-output
*)
1473 "Disassemble the compiled code associated with OBJECT, which can be a
1474 function, a lambda expression, or a symbol with a function definition. If
1475 it is not already compiled, the compiler is called to produce something to
1477 (declare (type (or function symbol cons
) object
)
1478 (type (or (member t
) stream
) stream
)
1479 (type (member t nil
) use-labels
))
1480 (flet ((disassemble1 (fun)
1481 (format stream
"~&; disassembly for ~S" (sb!kernel
:%fun-name fun
))
1482 (disassemble-fun fun
1484 :use-labels use-labels
)))
1485 (let ((funs (compiled-funs-or-lose object
)))
1487 (dolist (fun funs
) (disassemble1 fun
))
1488 (disassemble1 funs
))))
1491 ;;; Disassembles the given area of memory starting at ADDRESS and
1492 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
1493 ;;; could move during a GC, you'd better disable it around the call to
1495 (defun disassemble-memory (address
1498 (stream *standard-output
*)
1501 (declare (type (or address sb
!sys
:system-area-pointer
) address
)
1502 (type disassem-length length
)
1503 (type stream stream
)
1504 (type (or null sb
!kernel
:code-component
) code-component
)
1505 (type (member t nil
) use-labels
))
1507 (if (sb!sys
:system-area-pointer-p address
)
1508 (sb!sys
:sap-int address
)
1510 (dstate (make-dstate))
1516 (sb!kernel
:code-instructions code-component
)))))
1517 (when (or (< code-offs
0)
1518 (> code-offs
(code-inst-area-length code-component
)))
1519 (error "address ~X not in the code component ~S"
1520 address code-component
))
1521 (get-code-segments code-component code-offs length
))
1522 (list (make-memory-segment address length
)))))
1524 (label-segments segments dstate
))
1525 (disassemble-segments segments stream dstate
)))
1527 ;;; Disassemble the machine code instructions associated with
1528 ;;; CODE-COMPONENT (this may include multiple entry points).
1529 (defun disassemble-code-component (code-component &key
1530 (stream *standard-output
*)
1532 (declare (type (or null sb
!kernel
:code-component compiled-function
)
1534 (type stream stream
)
1535 (type (member t nil
) use-labels
))
1536 (let* ((code-component
1537 (if (functionp code-component
)
1538 (fun-code code-component
)
1540 (dstate (make-dstate))
1541 (segments (get-code-segments code-component
)))
1543 (label-segments segments dstate
))
1544 (disassemble-segments segments stream dstate
)))
1546 ;;;; code to disassemble assembler segments
1548 (defun assem-segment-to-disassem-segment (assem-segment)
1549 (declare (type sb
!assem
:segment assem-segment
))
1550 (let ((contents (sb!assem
:segment-contents-as-vector assem-segment
)))
1551 (make-vector-segment contents
0 (length contents
) :virtual-location
0)))
1553 ;;; Disassemble the machine code instructions associated with
1554 ;;; ASSEM-SEGMENT (of type assem:segment).
1555 (defun disassemble-assem-segment (assem-segment stream
)
1556 (declare (type sb
!assem
:segment assem-segment
)
1557 (type stream stream
))
1558 (let ((dstate (make-dstate))
1560 (list (assem-segment-to-disassem-segment assem-segment
))))
1561 (label-segments disassem-segments dstate
)
1562 (disassemble-segments disassem-segments stream dstate
)))
1564 ;;; routines to find things in the Lisp environment
1566 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
1567 ;;; in a symbol object that we know about
1568 (defparameter *grokked-symbol-slots
*
1569 (sort (copy-list `((,sb
!vm
:symbol-value-slot . symbol-value
)
1570 (,sb
!vm
:symbol-plist-slot . symbol-plist
)
1571 (,sb
!vm
:symbol-name-slot . symbol-name
)
1572 (,sb
!vm
:symbol-package-slot . symbol-package
)))
1576 ;;; Given ADDRESS, try and figure out if which slot of which symbol is
1577 ;;; being referred to. Of course we can just give up, so it's not a
1578 ;;; big deal... Return two values, the symbol and the name of the
1579 ;;; access function of the slot.
1580 (defun grok-symbol-slot-ref (address)
1581 (declare (type address address
))
1582 (if (not (aligned-p address sb
!vm
:n-word-bytes
))
1584 (do ((slots-tail *grokked-symbol-slots
* (cdr slots-tail
)))
1587 (let* ((field (car slots-tail
))
1588 (slot-offset (words-to-bytes (car field
)))
1589 (maybe-symbol-addr (- address slot-offset
))
1591 (sb!kernel
:make-lisp-obj
1592 (+ maybe-symbol-addr sb
!vm
:other-pointer-lowtag
))))
1593 (when (symbolp maybe-symbol
)
1594 (return (values maybe-symbol
(cdr field
))))))))
1596 (defvar *address-of-nil-object
* (sb!kernel
:get-lisp-obj-address nil
))
1598 ;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
1599 ;;; which symbol is being referred to. Of course we can just give up,
1600 ;;; so it's not a big deal... Return two values, the symbol and the
1601 ;;; access function.
1602 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1603 (declare (type offset byte-offset
))
1604 (grok-symbol-slot-ref (+ *address-of-nil-object
* byte-offset
)))
1606 ;;; Return the Lisp object located BYTE-OFFSET from NIL.
1607 (defun get-nil-indexed-object (byte-offset)
1608 (declare (type offset byte-offset
))
1609 (sb!kernel
:make-lisp-obj
(+ *address-of-nil-object
* byte-offset
)))
1611 ;;; Return two values; the Lisp object located at BYTE-OFFSET in the
1612 ;;; constant area of the code-object in the current segment and T, or
1613 ;;; NIL and NIL if there is no code-object in the current segment.
1614 (defun get-code-constant (byte-offset dstate
)
1616 (declare (type offset byte-offset
)
1617 (type disassem-state dstate
))
1618 (let ((code (seg-code (dstate-segment dstate
))))
1621 (sb!kernel
:code-header-ref code
1623 sb
!vm
:other-pointer-lowtag
)
1624 (- sb
!vm
:word-shift
)))
1628 (defstruct code-constant-raw value
)
1629 (def!method print-object
((self code-constant-raw
) stream
)
1630 (format stream
"#x~8,'0x" (code-constant-raw-value self
)))
1632 (defun get-code-constant-absolute (addr dstate
&optional width
)
1633 (declare (type address addr
))
1634 (declare (type disassem-state dstate
))
1635 (let ((code (seg-code (dstate-segment dstate
))))
1637 (return-from get-code-constant-absolute
(values nil nil
)))
1638 (sb!sys
:without-gcing
1639 (let* ((n-header-words (sb!kernel
:get-header-data code
))
1640 (n-code-words (sb!kernel
:%code-code-size code
))
1641 (header-addr (- (sb!kernel
:get-lisp-obj-address code
)
1642 sb
!vm
:other-pointer-lowtag
)))
1643 (cond ((<= header-addr addr
(+ header-addr
(ash (1- n-header-words
)
1645 (values (sb!sys
:sap-ref-lispobj
(sb!sys
:int-sap addr
) 0) t
))
1646 ;; guess it's a non-descriptor constant from the instructions
1647 ((and (eq width
:qword
)
1649 ;; convert ADDR to header-relative Nth word
1650 (ash (- addr header-addr
) (- sb
!vm
:word-shift
))
1651 (+ n-header-words n-code-words
)))
1652 (values (make-code-constant-raw
1653 :value
(sb!sys
:sap-ref-64
(sb!sys
:int-sap addr
) 0))
1656 (values nil nil
)))))))
1658 (defvar *assembler-routines-by-addr
* nil
)
1660 (defvar *foreign-symbols-by-addr
* nil
)
1662 ;;; Build an address-name hash-table from the name-address hash
1663 (defun invert-address-hash (htable &optional
(addr-hash (make-hash-table)))
1664 (maphash (lambda (name address
)
1665 (setf (gethash address addr-hash
) name
))
1669 ;;; Return the name of the primitive Lisp assembler routine or foreign
1670 ;;; symbol located at ADDRESS, or NIL if there isn't one.
1671 (defun find-assembler-routine (address)
1672 (declare (type address address
))
1673 (when (null *assembler-routines-by-addr
*)
1674 (setf *assembler-routines-by-addr
*
1675 (invert-address-hash sb
!fasl
:*assembler-routines
*))
1676 (setf *assembler-routines-by-addr
*
1677 (invert-address-hash sb
!sys
:*static-foreign-symbols
*
1678 *assembler-routines-by-addr
*))
1679 (loop for static in sb
!vm
:*static-funs
*
1680 for address
= (+ sb
!vm
::nil-value
1681 (sb!vm
::static-fun-offset static
))
1683 (setf (gethash address
*assembler-routines-by-addr
*)
1685 ;; Not really a routine, but it uses the similar logic for annotations
1687 (setf (gethash sb
!vm
::gc-safepoint-page-addr
*assembler-routines-by-addr
*)
1689 (gethash address
*assembler-routines-by-addr
*))
1691 ;;;; some handy function for machine-dependent code to use...
1693 #!-sb-fluid
(declaim (maybe-inline sap-ref-int read-suffix
))
1695 (defun sap-ref-int (sap offset length byte-order
)
1696 (declare (type sb
!sys
:system-area-pointer sap
)
1697 (type (unsigned-byte 16) offset
)
1698 (type (member 1 2 4 8) length
)
1699 (type (member :little-endian
:big-endian
) byte-order
)
1700 (optimize (speed 3) (safety 0)))
1702 (1 (sb!sys
:sap-ref-8 sap offset
))
1703 (2 (if (eq byte-order
:big-endian
)
1704 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 8)
1705 (sb!sys
:sap-ref-8 sap
(+ offset
1)))
1706 (+ (ash (sb!sys
:sap-ref-8 sap
(+ offset
1)) 8)
1707 (sb!sys
:sap-ref-8 sap offset
))))
1708 (4 (if (eq byte-order
:big-endian
)
1709 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 24)
1710 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 16)
1711 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 8)
1712 (sb!sys
:sap-ref-8 sap
(+ 3 offset
)))
1713 (+ (sb!sys
:sap-ref-8 sap offset
)
1714 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 8)
1715 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 16)
1716 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 24))))
1717 (8 (if (eq byte-order
:big-endian
)
1718 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 56)
1719 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 48)
1720 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 40)
1721 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 32)
1722 (ash (sb!sys
:sap-ref-8 sap
(+ 4 offset
)) 24)
1723 (ash (sb!sys
:sap-ref-8 sap
(+ 5 offset
)) 16)
1724 (ash (sb!sys
:sap-ref-8 sap
(+ 6 offset
)) 8)
1725 (sb!sys
:sap-ref-8 sap
(+ 7 offset
)))
1726 (+ (sb!sys
:sap-ref-8 sap offset
)
1727 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 8)
1728 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 16)
1729 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 24)
1730 (ash (sb!sys
:sap-ref-8 sap
(+ 4 offset
)) 32)
1731 (ash (sb!sys
:sap-ref-8 sap
(+ 5 offset
)) 40)
1732 (ash (sb!sys
:sap-ref-8 sap
(+ 6 offset
)) 48)
1733 (ash (sb!sys
:sap-ref-8 sap
(+ 7 offset
)) 56))))))
1735 (defun read-suffix (length dstate
)
1736 (declare (type (member 8 16 32 64) length
)
1737 (type disassem-state dstate
)
1738 (optimize (speed 3) (safety 0)))
1739 (let ((length (ecase length
(8 1) (16 2) (32 4) (64 8))))
1740 (declare (type (unsigned-byte 4) length
))
1742 (sap-ref-int (dstate-segment-sap dstate
)
1743 (dstate-next-offs dstate
)
1745 (dstate-byte-order dstate
))
1746 (incf (dstate-next-offs dstate
) length
))))
1748 ;;;; optional routines to make notes about code
1750 ;;; Store NOTE (which can be either a string or a function with a
1751 ;;; single stream argument) to be printed as an end-of-line comment
1752 ;;; after the current instruction is disassembled.
1753 (defun note (note dstate
)
1754 (declare (type (or string function
) note
)
1755 (type disassem-state dstate
))
1756 (push note
(dstate-notes dstate
)))
1758 (defun prin1-short (thing stream
)
1759 (with-print-restrictions
1760 (prin1 thing stream
)))
1762 (defun prin1-quoted-short (thing stream
)
1763 (if (self-evaluating-p thing
)
1764 (prin1-short thing stream
)
1765 (prin1-short `',thing stream
)))
1767 ;;; Store a note about the lisp constant located BYTE-OFFSET bytes
1768 ;;; from the current code-component, to be printed as an end-of-line
1769 ;;; comment after the current instruction is disassembled.
1770 (defun note-code-constant (byte-offset dstate
)
1771 (declare (type offset byte-offset
)
1772 (type disassem-state dstate
))
1773 (multiple-value-bind (const valid
)
1774 (get-code-constant byte-offset dstate
)
1776 (note (lambda (stream)
1777 (prin1-quoted-short const stream
))
1781 ;;; Store a note about the lisp constant located at ADDR in the
1782 ;;; current code-component, to be printed as an end-of-line comment
1783 ;;; after the current instruction is disassembled.
1784 (defun note-code-constant-absolute (addr dstate
&optional width
)
1785 (declare (type address addr
)
1786 (type disassem-state dstate
))
1787 (multiple-value-bind (const valid
)
1788 (get-code-constant-absolute addr dstate width
)
1790 (note (lambda (stream)
1791 (prin1-quoted-short const stream
))
1793 (values const valid
)))
1795 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1796 ;;; constant NIL is a valid slot in a symbol, store a note describing
1797 ;;; which symbol and slot, to be printed as an end-of-line comment
1798 ;;; after the current instruction is disassembled. Returns non-NIL iff
1799 ;;; a note was recorded.
1800 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate
)
1801 (declare (type offset nil-byte-offset
)
1802 (type disassem-state dstate
))
1803 (multiple-value-bind (symbol access-fun
)
1804 (grok-nil-indexed-symbol-slot-ref nil-byte-offset
)
1806 (note (lambda (stream)
1807 (prin1 (if (eq access-fun
'symbol-value
)
1809 `(,access-fun
',symbol
))
1814 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1815 ;;; constant NIL is a valid lisp object, store a note describing which
1816 ;;; symbol and slot, to be printed as an end-of-line comment after the
1817 ;;; current instruction is disassembled. Returns non-NIL iff a note
1819 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate
)
1820 (declare (type offset nil-byte-offset
)
1821 (type disassem-state dstate
))
1822 (let ((obj (get-nil-indexed-object nil-byte-offset
)))
1823 (note (lambda (stream)
1824 (prin1-quoted-short obj stream
))
1828 ;;; If ADDRESS is the address of a primitive assembler routine or
1829 ;;; foreign symbol, store a note describing which one, to be printed
1830 ;;; as an end-of-line comment after the current instruction is
1831 ;;; disassembled. Returns non-NIL iff a note was recorded. If
1832 ;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made.
1833 (defun maybe-note-assembler-routine (address note-address-p dstate
)
1834 (declare (type disassem-state dstate
))
1835 (unless (typep address
'address
)
1836 (return-from maybe-note-assembler-routine nil
))
1838 (find-assembler-routine address
)
1840 (sb!sys
:sap-foreign-symbol
(sb!sys
:int-sap address
)))))
1842 (note (lambda (stream)
1844 (format stream
"#x~8,'0x: ~a" address name
)
1845 (princ name stream
)))
1849 ;;; If there's a valid mapping from OFFSET in the storage class
1850 ;;; SC-NAME to a source variable, make a note of the source-variable
1851 ;;; name, to be printed as an end-of-line comment after the current
1852 ;;; instruction is disassembled. Returns non-NIL iff a note was
1854 (defun maybe-note-single-storage-ref (offset sc-name dstate
)
1855 (declare (type offset offset
)
1856 (type symbol sc-name
)
1857 (type disassem-state dstate
))
1858 (let ((storage-location
1859 (find-valid-storage-location offset sc-name dstate
)))
1860 (when storage-location
1861 (note (lambda (stream)
1862 (princ (sb!di
:debug-var-symbol
1863 (aref (storage-info-debug-vars
1864 (seg-storage-info (dstate-segment dstate
)))
1870 ;;; If there's a valid mapping from OFFSET in the storage-base called
1871 ;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with
1872 ;;; the source-variable name, to be printed as an end-of-line comment
1873 ;;; after the current instruction is disassembled. Returns non-NIL iff
1874 ;;; a note was recorded.
1875 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate
)
1876 (declare (type offset offset
)
1877 (type symbol sb-name
)
1878 (type (or symbol string
) assoc-with
)
1879 (type disassem-state dstate
))
1880 (let ((storage-location
1881 (find-valid-storage-location offset sb-name dstate
)))
1882 (when storage-location
1883 (note (lambda (stream)
1884 (format stream
"~A = ~S"
1886 (sb!di
:debug-var-symbol
1887 (aref (dstate-debug-vars dstate
)
1888 storage-location
))))
1892 (defun get-internal-error-name (errnum)
1893 (car (svref sb
!c
:*backend-internal-errors
* errnum
)))
1895 (defun get-sc-name (sc-offs)
1896 (sb!c
:location-print-name
1897 ;; FIXME: This seems like an awful lot of computation just to get a name.
1898 ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
1900 (sb!c
:make-random-tn
:kind
:normal
1901 :sc
(svref sb
!c
:*backend-sc-numbers
*
1902 (sb!c
:sc-offset-scn sc-offs
))
1903 :offset
(sb!c
:sc-offset-offset sc-offs
))))
1905 ;;; When called from an error break instruction's :DISASSEM-CONTROL (or
1906 ;;; :DISASSEM-PRINTER) function, will correctly deal with printing the
1907 ;;; arguments to the break.
1909 ;;; ERROR-PARSE-FUN should be a function that accepts:
1910 ;;; 1) a SYSTEM-AREA-POINTER
1911 ;;; 2) a BYTE-OFFSET from the SAP to begin at
1912 ;;; 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
1913 ;;; the byte length of the arguments (to avoid unnecessary consing)
1914 ;;; It should read information from the SAP starting at BYTE-OFFSET, and
1915 ;;; return four values:
1916 ;;; 1) the error number
1917 ;;; 2) the total length, in bytes, of the information
1918 ;;; 3) a list of SC-OFFSETs of the locations of the error parameters
1919 ;;; 4) a list of the length (as read from the SAP), in bytes, of each
1920 ;;; of the return values.
1921 (defun handle-break-args (error-parse-fun stream dstate
)
1922 (declare (type function error-parse-fun
)
1923 (type (or null stream
) stream
)
1924 (type disassem-state dstate
))
1925 (multiple-value-bind (errnum adjust sc-offsets lengths
)
1926 (funcall error-parse-fun
1927 (dstate-segment-sap dstate
)
1928 (dstate-next-offs dstate
)
1931 (setf (dstate-cur-offs dstate
)
1932 (dstate-next-offs dstate
))
1933 (flet ((emit-err-arg (note)
1934 (let ((num (pop lengths
)))
1935 (print-notes-and-newline stream dstate
)
1936 (print-current-address stream dstate
)
1937 (print-inst num stream dstate
)
1938 (print-bytes num stream dstate
)
1939 (incf (dstate-cur-offs dstate
) num
)
1941 (note note dstate
)))))
1943 (emit-err-arg (symbol-name (get-internal-error-name errnum
)))
1944 (dolist (sc-offs sc-offsets
)
1945 (emit-err-arg (get-sc-name sc-offs
)))))
1946 (incf (dstate-next-offs dstate
)