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 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 fun
))
293 (defun fun-address (fun)
294 (declare (type compiled-function fun
))
295 (ecase (sb!kernel
:widetag-of fun
)
296 (#.sb
!vm
:simple-fun-header-widetag
297 (- (sb!kernel
:get-lisp-obj-address fun
) sb
!vm
:fun-pointer-lowtag
))
298 (#.sb
!vm
:closure-header-widetag
299 (fun-address (sb!kernel
:%closure-fun fun
)))
300 (#.sb
!vm
:funcallable-instance-header-widetag
301 (fun-address (sb!kernel
:funcallable-instance-fun fun
)))))
303 ;;; the offset of FUNCTION from the start of its code-component's
305 (defun fun-insts-offset (function)
306 (declare (type compiled-function function
))
307 (- (fun-address function
)
308 (sb!sys
:sap-int
(sb!kernel
:code-instructions
(fun-code function
)))))
310 ;;; the offset of FUNCTION from the start of its code-component
311 (defun fun-offset (function)
312 (declare (type compiled-function function
))
313 (words-to-bytes (sb!kernel
:get-closure-length function
)))
315 ;;;; operations on code-components (which hold the instructions for
316 ;;;; one or more functions)
318 ;;; Return the length of the instruction area in CODE-COMPONENT.
319 (defun code-inst-area-length (code-component)
320 (declare (type sb
!kernel
:code-component code-component
))
321 (sb!kernel
:code-header-ref code-component
322 sb
!vm
:code-trace-table-offset-slot
))
324 ;;; Return the address of the instruction area in CODE-COMPONENT.
325 (defun code-inst-area-address (code-component)
326 (declare (type sb
!kernel
:code-component code-component
))
327 (sb!sys
:sap-int
(sb!kernel
:code-instructions code-component
)))
329 ;;; unused as of sbcl-0.pre7.129
331 ;;; Return the first function in CODE-COMPONENT.
332 (defun code-first-function (code-component)
333 (declare (type sb
!kernel
:code-component code-component
))
334 (sb!kernel
:code-header-ref code-component
335 sb
!vm
:code-trace-table-offset-slot
))
338 (defun segment-offs-to-code-offs (offset segment
)
339 (sb!sys
:without-gcing
340 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
342 (logandc1 sb
!vm
:lowtag-mask
343 (sb!kernel
:get-lisp-obj-address
(seg-code segment
))))
344 (addr (+ offset seg-base-addr
)))
345 (declare (type address seg-base-addr code-addr addr
))
346 (- addr code-addr
))))
348 (defun code-offs-to-segment-offs (offset segment
)
349 (sb!sys
:without-gcing
350 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
352 (logandc1 sb
!vm
:lowtag-mask
353 (sb!kernel
:get-lisp-obj-address
(seg-code segment
))))
354 (addr (+ offset code-addr
)))
355 (declare (type address seg-base-addr code-addr addr
))
356 (- addr seg-base-addr
))))
358 (defun code-insts-offs-to-segment-offs (offset segment
)
359 (sb!sys
:without-gcing
360 (let* ((seg-base-addr (sb!sys
:sap-int
(funcall (seg-sap-maker segment
))))
362 (sb!sys
:sap-int
(sb!kernel
:code-instructions
(seg-code segment
))))
363 (addr (+ offset code-insts-addr
)))
364 (declare (type address seg-base-addr code-insts-addr addr
))
365 (- addr seg-base-addr
))))
367 (defun lra-hook (chunk stream dstate
)
368 (declare (type dchunk chunk
)
370 (type (or null stream
) stream
)
371 (type disassem-state dstate
))
372 (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate
))
373 (dstate-cur-offs dstate
))
374 (* 2 sb
!vm
:n-word-bytes
))
376 (= (sb!sys
:sap-ref-8
(dstate-segment-sap dstate
)
377 (if (eq (dstate-byte-order dstate
)
379 (dstate-cur-offs dstate
)
380 (+ (dstate-cur-offs dstate
)
382 sb
!vm
:return-pc-header-widetag
))
383 (unless (null stream
)
384 (note "possible LRA header" dstate
)))
387 ;;; Print the fun-header (entry-point) pseudo-instruction at the
388 ;;; current location in DSTATE to STREAM.
389 (defun fun-header-hook (stream dstate
)
390 (declare (type (or null stream
) stream
)
391 (type disassem-state dstate
))
392 (unless (null stream
)
393 (let* ((seg (dstate-segment dstate
))
394 (code (seg-code seg
))
397 (segment-offs-to-code-offs (dstate-cur-offs dstate
) seg
)))
399 (sb!kernel
:code-header-ref code
401 sb
!vm
:simple-fun-name-slot
)))
403 (sb!kernel
:code-header-ref code
405 sb
!vm
:simple-fun-arglist-slot
)))
407 (sb!kernel
:code-header-ref code
409 sb
!vm
:simple-fun-type-slot
))))
410 (format stream
".~A ~S~:A" 'entry name args
)
411 (note (lambda (stream)
412 (format stream
"~:S" type
)) ; use format to print NIL as ()
414 (incf (dstate-next-offs dstate
)
415 (words-to-bytes sb
!vm
:simple-fun-code-offset
)))
417 (defun alignment-hook (chunk stream dstate
)
418 (declare (type dchunk chunk
)
420 (type (or null stream
) stream
)
421 (type disassem-state dstate
))
423 (+ (seg-virtual-location (dstate-segment dstate
))
424 (dstate-cur-offs dstate
)))
425 (alignment (dstate-alignment dstate
)))
426 (unless (aligned-p location alignment
)
428 (format stream
"~A~Vt~W~%" '.align
429 (dstate-argument-column dstate
)
431 (incf(dstate-next-offs dstate
)
432 (- (align location alignment
) location
)))
435 (defun rewind-current-segment (dstate segment
)
436 (declare (type disassem-state dstate
)
437 (type segment segment
))
438 (setf (dstate-segment dstate
) segment
)
439 (setf (dstate-cur-offs-hooks dstate
)
440 (stable-sort (nreverse (copy-list (seg-hooks segment
)))
442 (or (< (offs-hook-offset oh1
) (offs-hook-offset oh2
))
443 (and (= (offs-hook-offset oh1
)
444 (offs-hook-offset oh2
))
445 (offs-hook-before-address oh1
)
446 (not (offs-hook-before-address oh2
)))))))
447 (setf (dstate-cur-offs dstate
) 0)
448 (setf (dstate-cur-labels dstate
) (dstate-labels dstate
)))
450 (defun call-offs-hooks (before-address stream dstate
)
451 (declare (type (or null stream
) stream
)
452 (type disassem-state dstate
))
453 (let ((cur-offs (dstate-cur-offs dstate
)))
454 (setf (dstate-next-offs dstate
) cur-offs
)
456 (let ((next-hook (car (dstate-cur-offs-hooks dstate
))))
457 (when (null next-hook
)
459 (let ((hook-offs (offs-hook-offset next-hook
)))
460 (when (or (> hook-offs cur-offs
)
461 (and (= hook-offs cur-offs
)
463 (not (offs-hook-before-address next-hook
))))
465 (unless (< hook-offs cur-offs
)
466 (funcall (offs-hook-fun next-hook
) stream dstate
))
467 (pop (dstate-cur-offs-hooks dstate
))
468 (unless (= (dstate-next-offs dstate
) cur-offs
)
471 (defun call-fun-hooks (chunk stream dstate
)
472 (let ((hooks (dstate-fun-hooks dstate
))
473 (cur-offs (dstate-cur-offs dstate
)))
474 (setf (dstate-next-offs dstate
) cur-offs
)
475 (dolist (hook hooks nil
)
476 (let ((prefix-p (funcall hook chunk stream dstate
)))
477 (unless (= (dstate-next-offs dstate
) cur-offs
)
478 (return prefix-p
))))))
480 (defun handle-bogus-instruction (stream dstate
)
481 (let ((alignment (dstate-alignment dstate
)))
482 (unless (null stream
)
483 (multiple-value-bind (words bytes
)
484 (truncate alignment sb
!vm
:n-word-bytes
)
486 (print-words words stream dstate
))
488 (print-bytes bytes stream dstate
))))
489 (incf (dstate-next-offs dstate
) alignment
)))
491 ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
492 ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE.
493 (defun map-segment-instructions (function segment dstate
&optional stream
)
494 (declare (type function function
)
495 (type segment segment
)
496 (type disassem-state dstate
)
497 (type (or null stream
) stream
))
499 (let ((ispace (get-inst-space))
500 (prefix-p nil
)) ; just processed a prefix inst
502 (rewind-current-segment dstate segment
)
505 (when (>= (dstate-cur-offs dstate
)
506 (seg-length (dstate-segment dstate
)))
510 (setf (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
512 (call-offs-hooks t stream dstate
)
513 (unless (or prefix-p
(null stream
))
514 (print-current-address stream dstate
))
515 (call-offs-hooks nil stream dstate
)
517 (unless (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
518 (sb!sys
:without-gcing
519 (setf (dstate-segment-sap dstate
) (funcall (seg-sap-maker segment
)))
522 (sap-ref-dchunk (dstate-segment-sap dstate
)
523 (dstate-cur-offs dstate
)
524 (dstate-byte-order dstate
))))
525 (let ((fun-prefix-p (call-fun-hooks chunk stream dstate
)))
526 (if (> (dstate-next-offs dstate
) (dstate-cur-offs dstate
))
527 (setf prefix-p fun-prefix-p
)
528 (let ((inst (find-inst chunk ispace
)))
530 (handle-bogus-instruction stream dstate
))
532 (setf (dstate-next-offs dstate
)
533 (+ (dstate-cur-offs dstate
)
536 (let ((prefilter (inst-prefilter inst
))
537 (control (inst-control inst
)))
539 (funcall prefilter chunk dstate
))
541 (funcall function chunk inst
)
543 (setf prefix-p
(null (inst-printer inst
)))
546 (funcall control chunk inst stream dstate
))))))
549 (setf (dstate-cur-offs dstate
) (dstate-next-offs dstate
))
551 (unless (null stream
)
553 (print-notes-and-newline stream dstate
))
554 (setf (dstate-output-state dstate
) nil
)))))
556 ;;; Make an initial non-printing disassembly pass through DSTATE,
557 ;;; noting any addresses that are referenced by instructions in this
559 (defun add-segment-labels (segment dstate
)
560 ;; add labels at the beginning with a label-number of nil; we'll notice
561 ;; later and fill them in (and sort them)
562 (declare (type disassem-state dstate
))
563 (let ((labels (dstate-labels dstate
)))
564 (map-segment-instructions
566 (declare (type dchunk chunk
) (type instruction inst
))
567 (let ((labeller (inst-labeller inst
)))
569 (setf labels
(funcall labeller chunk labels dstate
)))))
572 (setf (dstate-labels dstate
) labels
)
573 ;; erase any notes that got there by accident
574 (setf (dstate-notes dstate
) nil
)))
576 ;;; If any labels in DSTATE have been added since the last call to
577 ;;; this function, give them label-numbers, enter them in the
578 ;;; hash-table, and make sure the label list is in sorted order.
579 (defun number-labels (dstate)
580 (let ((labels (dstate-labels dstate
)))
581 (when (and labels
(null (cdar labels
)))
582 ;; at least one label left un-numbered
583 (setf labels
(sort labels
#'< :key
#'car
))
585 (label-hash (dstate-label-hash dstate
)))
586 (dolist (label labels
)
587 (when (not (null (cdr label
)))
588 (setf max
(max max
(cdr label
)))))
589 (dolist (label labels
)
590 (when (null (cdr label
))
592 (setf (cdr label
) max
)
593 (setf (gethash (car label
) label-hash
)
594 (format nil
"L~W" max
)))))
595 (setf (dstate-labels dstate
) labels
))))
597 ;;; Get the instruction-space, creating it if necessary.
598 (defun get-inst-space ()
599 (let ((ispace *disassem-inst-space
*))
602 (maphash (lambda (name inst-flavs
)
603 (declare (ignore name
))
604 (dolist (flav inst-flavs
)
607 (setf ispace
(build-inst-space insts
)))
608 (setf *disassem-inst-space
* ispace
))
611 ;;;; Add global hooks.
613 (defun add-offs-hook (segment addr hook
)
614 (let ((entry (cons addr hook
)))
615 (if (null (seg-hooks segment
))
616 (setf (seg-hooks segment
) (list entry
))
617 (push entry
(cdr (last (seg-hooks segment
)))))))
619 (defun add-offs-note-hook (segment addr note
)
620 (add-offs-hook segment
622 (lambda (stream dstate
)
623 (declare (type (or null stream
) stream
)
624 (type disassem-state dstate
))
626 (note note dstate
)))))
628 (defun add-offs-comment-hook (segment addr comment
)
629 (add-offs-hook segment
631 (lambda (stream dstate
)
632 (declare (type (or null stream
) stream
)
635 (write-string ";;; " stream
)
638 (write-string comment stream
))
640 (funcall comment stream
)))
643 (defun add-fun-hook (dstate function
)
644 (push function
(dstate-fun-hooks dstate
)))
646 (defun set-location-printing-range (dstate from length
)
647 (setf (dstate-addr-print-len dstate
)
648 ;; 4 bits per hex digit
649 (ceiling (integer-length (logxor from
(+ from length
))) 4)))
651 ;;; Print the current address in DSTATE to STREAM, plus any labels that
652 ;;; correspond to it, and leave the cursor in the instruction column.
653 (defun print-current-address (stream dstate
)
654 (declare (type stream stream
)
655 (type disassem-state dstate
))
657 (+ (seg-virtual-location (dstate-segment dstate
))
658 (dstate-cur-offs dstate
)))
659 (location-column-width *disassem-location-column-width
*)
660 (plen (dstate-addr-print-len dstate
)))
663 (setf plen location-column-width
)
664 (let ((seg (dstate-segment dstate
)))
665 (set-location-printing-range dstate
666 (seg-virtual-location seg
)
668 (when (eq (dstate-output-state dstate
) :beginning
)
669 (setf plen location-column-width
))
673 (setf location-column-width
(+ 2 location-column-width
))
676 ;; print the location
677 ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
678 ;; usually avoids any consing]
679 (tab0 (- location-column-width plen
) stream
)
680 (let* ((printed-bits (* 4 plen
))
681 (printed-value (ldb (byte printed-bits
0) location
))
683 (truncate (- printed-bits
(integer-length printed-value
)) 4)))
684 (dotimes (i leading-zeros
)
685 (write-char #\
0 stream
))
686 (unless (zerop printed-value
)
687 (write printed-value
:stream stream
:base
16 :radix nil
))
688 (write-char #\
: stream
))
692 (let* ((next-label (car (dstate-cur-labels dstate
)))
693 (label-location (car next-label
)))
694 (when (or (null label-location
) (> label-location location
))
696 (unless (< label-location location
)
697 (format stream
" L~W:" (cdr next-label
)))
698 (pop (dstate-cur-labels dstate
))))
700 ;; move to the instruction column
701 (tab0 (+ location-column-width
1 label-column-width
) stream
)
704 (eval-when (:compile-toplevel
:execute
)
705 (sb!xc
:defmacro with-print-restrictions
(&rest body
)
706 `(let ((*print-pretty
* t
)
712 ;;; Print a newline to STREAM, inserting any pending notes in DSTATE
713 ;;; as end-of-line comments. If there is more than one note, a
714 ;;; separate line will be used for each one.
715 (defun print-notes-and-newline (stream dstate
)
716 (declare (type stream stream
)
717 (type disassem-state dstate
))
718 (with-print-restrictions
719 (dolist (note (dstate-notes dstate
))
720 (format stream
"~Vt " *disassem-note-column
*)
721 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
724 (write-string note stream
))
726 (funcall note stream
))))
729 (setf (dstate-notes dstate
) nil
)))
731 ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
732 (defun print-bytes (num stream dstate
)
733 (declare (type offset num
)
735 (type disassem-state dstate
))
736 (format stream
"~A~Vt" 'BYTE
(dstate-argument-column dstate
))
737 (let ((sap (dstate-segment-sap dstate
))
738 (start-offs (dstate-cur-offs dstate
)))
741 (write-string ", " stream
))
742 (format stream
"#X~2,'0x" (sb!sys
:sap-ref-8 sap
(+ offs start-offs
))))))
744 ;;; Disassemble NUM machine-words to STREAM as simple `WORD' instructions.
745 (defun print-words (num stream dstate
)
746 (declare (type offset num
)
748 (type disassem-state dstate
))
749 (format stream
"~A~Vt" 'WORD
(dstate-argument-column dstate
))
750 (let ((sap (dstate-segment-sap dstate
))
751 (start-offs (dstate-cur-offs dstate
))
752 (byte-order (dstate-byte-order dstate
)))
753 (dotimes (word-offs num
)
754 (unless (zerop word-offs
)
755 (write-string ", " stream
))
756 (let ((word 0) (bit-shift 0))
757 (dotimes (byte-offs sb
!vm
:n-word-bytes
)
762 (* word-offs sb
!vm
:n-word-bytes
)
765 (if (eq byte-order
:big-endian
)
766 (+ (ash word sb
!vm
:n-byte-bits
) byte
)
767 (+ word
(ash byte bit-shift
))))
768 (incf bit-shift sb
!vm
:n-byte-bits
)))
769 (format stream
"#X~V,'0X" (ash sb
!vm
:n-word-bits -
2) word
)))))
771 (defvar *default-dstate-hooks
* (list #'lra-hook
))
773 ;;; Make a disassembler-state object.
774 (defun make-dstate (&optional
(fun-hooks *default-dstate-hooks
*))
776 (sb!sys
:vector-sap
(coerce #() '(vector (unsigned-byte 8)))))
777 (alignment *disassem-inst-alignment-bytes
*)
779 (+ (or *disassem-opcode-column-width
* 0)
780 *disassem-location-column-width
*
782 label-column-width
)))
784 (when (> alignment
1)
785 (push #'alignment-hook fun-hooks
))
787 (%make-dstate
:segment-sap sap
789 :argument-column arg-column
791 :byte-order sb
!c
:*backend-byte-order
*)))
793 (defun add-fun-header-hooks (segment)
794 (declare (type segment segment
))
795 (do ((fun (sb!kernel
:code-header-ref
(seg-code segment
)
796 sb
!vm
:code-entry-points-slot
)
798 (length (seg-length segment
)))
800 (let ((offset (code-offs-to-segment-offs (fun-offset fun
) segment
)))
801 (when (<= 0 offset length
)
802 (push (make-offs-hook :offset offset
:fun
#'fun-header-hook
)
803 (seg-hooks segment
))))))
805 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
807 #!-sb-fluid
(declaim (inline sap-maker
))
809 (defun sap-maker (function input offset
)
810 (declare (optimize (speed 3))
811 (type (function (t) sb
!sys
:system-area-pointer
) function
)
812 (type offset offset
))
813 (let ((old-sap (sb!sys
:sap
+ (funcall function input
) offset
)))
814 (declare (type sb
!sys
:system-area-pointer old-sap
))
817 (+ (sb!sys
:sap-int
(funcall function input
)) offset
)))
818 ;; Saving the sap like this avoids consing except when the sap
819 ;; changes (because the sap-int, arith, etc., get inlined).
820 (declare (type address new-addr
))
821 (if (= (sb!sys
:sap-int old-sap
) new-addr
)
823 (setf old-sap
(sb!sys
:int-sap new-addr
)))))))
825 (defun vector-sap-maker (vector offset
)
826 (declare (optimize (speed 3))
827 (type offset offset
))
828 (sap-maker #'sb
!sys
:vector-sap vector offset
))
830 (defun code-sap-maker (code offset
)
831 (declare (optimize (speed 3))
832 (type sb
!kernel
:code-component code
)
833 (type offset offset
))
834 (sap-maker #'sb
!kernel
:code-instructions code offset
))
836 (defun memory-sap-maker (address)
837 (declare (optimize (speed 3))
838 (type address address
))
839 (let ((sap (sb!sys
:int-sap address
)))
842 ;;; Return a memory segment located at the system-area-pointer returned by
843 ;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
845 ;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
846 ;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a
847 ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
849 (defun make-segment (sap-maker length
851 code virtual-location
852 debug-fun source-form-cache
854 (declare (type (function () sb
!sys
:system-area-pointer
) sap-maker
)
855 (type disassem-length length
)
856 (type (or null address
) virtual-location
)
857 (type (or null sb
!di
:debug-fun
) debug-fun
)
858 (type (or null source-form-cache
) source-form-cache
))
863 :virtual-location
(or virtual-location
864 (sb!sys
:sap-int
(funcall sap-maker
)))
867 (add-debugging-hooks segment debug-fun source-form-cache
)
868 (add-fun-header-hooks segment
)
871 (defun make-vector-segment (vector offset
&rest args
)
872 (declare (type vector vector
)
874 (inline make-segment
))
875 (apply #'make-segment
(vector-sap-maker vector offset
) args
))
877 (defun make-code-segment (code offset length
&rest args
)
878 (declare (type sb
!kernel
:code-component code
)
880 (inline make-segment
))
881 (apply #'make-segment
(code-sap-maker code offset
) length
:code code args
))
883 (defun make-memory-segment (address &rest args
)
884 (declare (type address address
)
885 (inline make-segment
))
886 (apply #'make-segment
(memory-sap-maker address
) args
))
889 (defun print-fun-headers (function)
890 (declare (type compiled-function function
))
891 (let* ((self (fun-self function
))
892 (code (sb!kernel
:fun-code-header self
)))
893 (format t
"Code-header ~S: size: ~S, trace-table-offset: ~S~%"
895 (sb!kernel
:code-header-ref code
896 sb
!vm
:code-code-size-slot
)
897 (sb!kernel
:code-header-ref code
898 sb
!vm
:code-trace-table-offset-slot
))
899 (do ((fun (sb!kernel
:code-header-ref code sb
!vm
:code-entry-points-slot
)
902 (let ((fun-offset (sb!kernel
:get-closure-length fun
)))
903 ;; There is function header fun-offset words from the
905 (format t
"Fun-header ~S at offset ~W (words): ~S~A => ~S~%"
908 (sb!kernel
:code-header-ref
909 code
(+ fun-offset sb
!vm
:simple-fun-name-slot
))
910 (sb!kernel
:code-header-ref
911 code
(+ fun-offset sb
!vm
:simple-fun-arglist-slot
))
912 (sb!kernel
:code-header-ref
913 code
(+ fun-offset sb
!vm
:simple-fun-type-slot
)))))))
915 ;;; getting at the source code...
917 (defstruct (source-form-cache (:conc-name sfcache-
)
919 (debug-source nil
:type
(or null sb
!di
:debug-source
))
920 (toplevel-form-index -
1 :type fixnum
)
921 (toplevel-form nil
:type list
)
922 (form-number-mapping-table nil
:type
(or null
(vector list
)))
923 (last-location-retrieved nil
:type
(or null sb
!di
:code-location
))
924 (last-form-retrieved -
1 :type fixnum
))
926 (defun get-toplevel-form (debug-source tlf-index
)
927 (let ((name (sb!di
:debug-source-name debug-source
)))
928 (ecase (sb!di
:debug-source-from debug-source
)
930 (cond ((not (probe-file name
))
931 (warn "The source file ~S no longer seems to exist." name
)
934 (let ((start-positions
935 (sb!di
:debug-source-start-positions debug-source
)))
936 (cond ((null start-positions
)
937 (warn "There is no start positions map.")
940 (let* ((local-tlf-index
942 (sb!di
:debug-source-root-number
945 (aref start-positions local-tlf-index
)))
946 (with-open-file (f name
)
947 (cond ((= (sb!di
:debug-source-created debug-source
)
948 (file-write-date name
))
949 (file-position f char-offset
))
951 (warn "Source file ~S has been modified; ~@
952 using form offset instead of ~
955 (let ((*read-suppress
* t
))
956 (dotimes (i local-tlf-index
) (read f
)))))
957 (let ((*readtable
* (copy-readtable)))
958 (set-dispatch-macro-character
960 (lambda (stream sub-char
&rest rest
)
961 (declare (ignore rest sub-char
))
962 (let ((token (read stream t nil t
)))
963 (format nil
"#.~S" token
))))
967 (aref name tlf-index
)))))
969 (defun cache-valid (loc cache
)
971 (and (eq (sb!di
:code-location-debug-source loc
)
972 (sfcache-debug-source cache
))
973 (eq (sb!di
:code-location-toplevel-form-offset loc
)
974 (sfcache-toplevel-form-index cache
)))))
976 (defun get-source-form (loc context
&optional cache
)
977 (let* ((cache-valid (cache-valid loc cache
))
978 (tlf-index (sb!di
:code-location-toplevel-form-offset loc
))
979 (form-number (sb!di
:code-location-form-number loc
))
982 (sfcache-toplevel-form cache
)
983 (get-toplevel-form (sb!di
:code-location-debug-source loc
)
987 (sfcache-form-number-mapping-table cache
)
988 (sb!di
:form-number-translations toplevel-form tlf-index
))))
989 (when (and (not cache-valid
) cache
)
990 (setf (sfcache-debug-source cache
) (sb!di
:code-location-debug-source loc
)
991 (sfcache-toplevel-form-index cache
) tlf-index
992 (sfcache-toplevel-form cache
) toplevel-form
993 (sfcache-form-number-mapping-table cache
) mapping-table
))
994 (cond ((null toplevel-form
)
996 ((> form-number
(length mapping-table
))
997 (warn "bogus form-number in form! The source file has probably ~@
998 been changed too much to cope with.")
1000 ;; Disable future warnings.
1001 (setf (sfcache-toplevel-form cache
) nil
))
1005 (setf (sfcache-last-location-retrieved cache
) loc
)
1006 (setf (sfcache-last-form-retrieved cache
) form-number
))
1007 (sb!di
:source-path-context toplevel-form
1008 (aref mapping-table form-number
)
1011 (defun get-different-source-form (loc context
&optional cache
)
1012 (if (and (cache-valid loc cache
)
1013 (or (= (sb!di
:code-location-form-number loc
)
1014 (sfcache-last-form-retrieved cache
))
1015 (and (sfcache-last-location-retrieved cache
)
1016 (sb!di
:code-location
=
1018 (sfcache-last-location-retrieved cache
)))))
1020 (values (get-source-form loc context cache
) t
)))
1022 ;;;; stuff to use debugging info to augment the disassembly
1024 (defun code-fun-map (code)
1025 (declare (type sb
!kernel
:code-component code
))
1026 (sb!c
::compiled-debug-info-fun-map
(sb!kernel
:%code-debug-info code
)))
1028 (defstruct (location-group (:copier nil
))
1029 (locations #() :type
(vector (or list fixnum
))))
1031 (defstruct (storage-info (:copier nil
))
1032 (groups nil
:type list
) ; alist of (name . location-group)
1033 (debug-vars #() :type vector
))
1035 ;;; Return the vector of DEBUG-VARs currently associated with DSTATE.
1036 (defun dstate-debug-vars (dstate)
1037 (declare (type disassem-state dstate
))
1038 (storage-info-debug-vars (seg-storage-info (dstate-segment dstate
))))
1040 ;;; Given the OFFSET of a location within the location-group called
1041 ;;; LG-NAME, see whether there's a current mapping to a source
1042 ;;; variable in DSTATE, and if so, return the offset of that variable
1043 ;;; in the current debug-var vector.
1044 (defun find-valid-storage-location (offset lg-name dstate
)
1045 (declare (type offset offset
)
1046 (type symbol lg-name
)
1047 (type disassem-state dstate
))
1048 (let* ((storage-info
1049 (seg-storage-info (dstate-segment dstate
)))
1052 (cdr (assoc lg-name
(storage-info-groups storage-info
)))))
1054 (dstate-current-valid-locations dstate
)))
1056 (not (null currently-valid
))
1057 (let ((locations (location-group-locations location-group
)))
1058 (and (< offset
(length locations
))
1059 (let ((used-by (aref locations offset
)))
1061 (let ((debug-var-num
1065 (zerop (bit currently-valid used-by
)))
1071 (bit currently-valid num
)))
1076 ;; Found a valid storage reference!
1077 ;; can't use it again until it's revalidated...
1078 (setf (bit (dstate-current-valid-locations
1085 ;;; Return a new vector which has the same contents as the old one
1086 ;;; VEC, plus new cells (for a total size of NEW-LEN). The additional
1087 ;;; elements are initialized to INITIAL-ELEMENT.
1088 (defun grow-vector (vec new-len
&optional initial-element
)
1089 (declare (type vector vec
)
1090 (type fixnum new-len
))
1092 (make-sequence `(vector ,(array-element-type vec
) ,new-len
)
1094 :initial-element initial-element
)))
1095 (dotimes (i (length vec
))
1096 (setf (aref new i
) (aref vec i
)))
1099 ;;; Return a STORAGE-INFO struction describing the object-to-source
1100 ;;; variable mappings from DEBUG-FUN.
1101 (defun storage-info-for-debug-fun (debug-fun)
1102 (declare (type sb
!di
:debug-fun debug-fun
))
1103 (let ((sc-vec sb
!c
::*backend-sc-numbers
*)
1105 (debug-vars (sb!di
::debug-fun-debug-vars
1108 (dotimes (debug-var-offset
1110 (make-storage-info :groups groups
1111 :debug-vars debug-vars
))
1112 (let ((debug-var (aref debug-vars debug-var-offset
)))
1114 (format t
";;; At offset ~W: ~S~%" debug-var-offset debug-var
)
1116 (sb!di
::compiled-debug-var-sc-offset debug-var
))
1119 (sb!c
:sc-sb
(aref sc-vec
1120 (sb!c
:sc-offset-scn sc-offset
))))))
1122 (format t
";;; SET: ~S[~W]~%"
1123 sb-name
(sb!c
:sc-offset-offset sc-offset
))
1124 (unless (null sb-name
)
1125 (let ((group (cdr (assoc sb-name groups
))))
1127 (setf group
(make-location-group))
1128 (push `(,sb-name .
,group
) groups
))
1129 (let* ((locations (location-group-locations group
))
1130 (length (length locations
))
1131 (offset (sb!c
:sc-offset-offset sc-offset
)))
1132 (when (>= offset length
)
1134 (grow-vector locations
1138 (location-group-locations group
)
1140 (let ((already-there (aref locations offset
)))
1141 (cond ((null already-there
)
1142 (setf (aref locations offset
) debug-var-offset
))
1143 ((eql already-there debug-var-offset
))
1145 (if (listp already-there
)
1146 (pushnew debug-var-offset
1147 (aref locations offset
))
1148 (setf (aref locations offset
)
1149 (list debug-var-offset
1154 (defun source-available-p (debug-fun)
1156 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1157 (declare (ignore block
))
1159 (sb!di
:no-debug-blocks
() nil
)))
1161 (defun print-block-boundary (stream dstate
)
1162 (let ((os (dstate-output-state dstate
)))
1163 (when (not (eq os
:beginning
))
1164 (when (not (eq os
:block-boundary
))
1166 (setf (dstate-output-state dstate
)
1169 ;;; Add hooks to track to track the source code in SEGMENT during
1170 ;;; disassembly. SFCACHE can be either NIL or it can be a
1171 ;;; SOURCE-FORM-CACHE structure, in which case it is used to cache
1172 ;;; forms from files.
1173 (defun add-source-tracking-hooks (segment debug-fun
&optional sfcache
)
1174 (declare (type segment segment
)
1175 (type (or null sb
!di
:debug-fun
) debug-fun
)
1176 (type (or null source-form-cache
) sfcache
))
1177 (let ((last-block-pc -
1))
1178 (flet ((add-hook (pc fun
&optional before-address
)
1179 (push (make-offs-hook
1180 :offset pc
;; ### FIX to account for non-zero offs in code
1182 :before-address before-address
)
1183 (seg-hooks segment
))))
1185 (sb!di
:do-debug-fun-blocks
(block debug-fun
)
1186 (let ((first-location-in-block-p t
))
1187 (sb!di
:do-debug-block-locations
(loc block
)
1188 (let ((pc (sb!di
::compiled-code-location-pc loc
)))
1190 ;; Put blank lines in at block boundaries
1191 (when (and first-location-in-block-p
1192 (/= pc last-block-pc
))
1193 (setf first-location-in-block-p nil
)
1195 (lambda (stream dstate
)
1196 (print-block-boundary stream dstate
))
1198 (setf last-block-pc pc
))
1200 ;; Print out corresponding source; this information is not
1201 ;; all that accurate, but it's better than nothing
1202 (unless (zerop (sb!di
:code-location-form-number loc
))
1203 (multiple-value-bind (form new
)
1204 (get-different-source-form loc
0 sfcache
)
1206 (let ((at-block-begin (= pc last-block-pc
)))
1209 (lambda (stream dstate
)
1210 (declare (ignore dstate
))
1212 (unless at-block-begin
1214 (format stream
";;; [~W] "
1215 (sb!di
:code-location-form-number
1217 (prin1-short form stream
)
1222 ;; Keep track of variable live-ness as best we can.
1224 (copy-seq (sb!di
::compiled-code-location-live-set
1228 (lambda (stream dstate
)
1229 (declare (ignore stream
))
1230 (setf (dstate-current-valid-locations dstate
)
1233 (note (lambda (stream)
1234 (let ((*print-length
* nil
))
1235 (format stream
"live set: ~S"
1239 (sb!di
:no-debug-blocks
() nil
)))))
1241 (defun add-debugging-hooks (segment debug-fun
&optional sfcache
)
1243 (setf (seg-storage-info segment
)
1244 (storage-info-for-debug-fun debug-fun
))
1245 (add-source-tracking-hooks segment debug-fun sfcache
)
1246 (let ((kind (sb!di
:debug-fun-kind debug-fun
)))
1247 (flet ((add-new-hook (n)
1248 (push (make-offs-hook
1250 :fun
(lambda (stream dstate
)
1251 (declare (ignore stream
))
1253 (seg-hooks segment
))))
1257 (add-new-hook "no-arg-parsing entry point"))
1259 (add-new-hook (lambda (stream)
1260 (format stream
"~S entry point" kind
)))))))))
1262 ;;; Return a list of the segments of memory containing machine code
1263 ;;; instructions for FUNCTION.
1264 (defun get-fun-segments (function)
1265 (declare (type compiled-function function
))
1266 (let* ((code (fun-code function
))
1267 (fun-map (code-fun-map code
))
1268 (fname (sb!kernel
:%simple-fun-name function
))
1269 (sfcache (make-source-form-cache)))
1270 (let ((first-block-seen-p nil
)
1271 (nil-block-seen-p nil
)
1273 (last-debug-fun nil
)
1275 (flet ((add-seg (offs len df
)
1277 (push (make-code-segment code offs len
1279 :source-form-cache sfcache
)
1281 (dotimes (fmap-index (length fun-map
))
1282 (let ((fmap-entry (aref fun-map fmap-index
)))
1283 (etypecase fmap-entry
1285 (when first-block-seen-p
1286 (add-seg last-offset
1287 (- fmap-entry last-offset
)
1289 (setf last-debug-fun nil
))
1290 (setf last-offset fmap-entry
))
1291 (sb!c
::compiled-debug-fun
1292 (let ((name (sb!c
::compiled-debug-fun-name fmap-entry
))
1293 (kind (sb!c
::compiled-debug-fun-kind fmap-entry
)))
1295 (format t
";;; SAW ~S ~S ~S,~S ~W,~W~%"
1296 name kind first-block-seen-p nil-block-seen-p
1298 (sb!c
::compiled-debug-fun-start-pc fmap-entry
))
1299 (cond (#+nil
(eq last-offset fun-offset
)
1300 (and (equal name fname
) (not first-block-seen-p
))
1301 (setf first-block-seen-p t
))
1302 ((eq kind
:external
)
1303 (when first-block-seen-p
1306 (when nil-block-seen-p
1308 (when first-block-seen-p
1309 (setf nil-block-seen-p t
))))
1310 (setf last-debug-fun
1311 (sb!di
::make-compiled-debug-fun fmap-entry code
)))))))
1312 (let ((max-offset (code-inst-area-length code
)))
1313 (when (and first-block-seen-p last-debug-fun
)
1314 (add-seg last-offset
1315 (- max-offset last-offset
)
1318 (let ((offs (fun-insts-offset function
)))
1320 (make-code-segment code offs
(- max-offset offs
))))
1321 (nreverse segments
)))))))
1323 ;;; Return a list of the segments of memory containing machine code
1324 ;;; instructions for the code-component CODE. If START-OFFSET and/or
1325 ;;; LENGTH is supplied, only that part of the code-segment is used
1326 ;;; (but these are constrained to lie within the code-segment).
1327 (defun get-code-segments (code
1330 (length (code-inst-area-length code
)))
1331 (declare (type sb
!kernel
:code-component code
)
1332 (type offset start-offset
)
1333 (type disassem-length length
))
1334 (let ((segments nil
))
1336 (let ((fun-map (code-fun-map code
))
1337 (sfcache (make-source-form-cache)))
1338 (let ((last-offset 0)
1339 (last-debug-fun nil
))
1340 (flet ((add-seg (offs len df
)
1341 (let* ((restricted-offs
1342 (min (max start-offset offs
)
1343 (+ start-offset length
)))
1345 (- (min (max start-offset
(+ offs len
))
1346 (+ start-offset length
))
1348 (when (> restricted-len
0)
1349 (push (make-code-segment code
1350 restricted-offs restricted-len
1352 :source-form-cache sfcache
)
1354 (dotimes (fun-map-index (length fun-map
))
1355 (let ((fun-map-entry (aref fun-map fun-map-index
)))
1356 (etypecase fun-map-entry
1358 (add-seg last-offset
(- fun-map-entry last-offset
)
1360 (setf last-debug-fun nil
)
1361 (setf last-offset fun-map-entry
))
1362 (sb!c
::compiled-debug-fun
1363 (setf last-debug-fun
1364 (sb!di
::make-compiled-debug-fun fun-map-entry
1366 (when last-debug-fun
1367 (add-seg last-offset
1368 (- (code-inst-area-length code
) last-offset
)
1369 last-debug-fun
))))))
1371 (make-code-segment code start-offset length
)
1372 (nreverse segments
))))
1374 ;;; Return two values: the amount by which the last instruction in the
1375 ;;; segment goes past the end of the segment, and the offset of the
1376 ;;; end of the segment from the beginning of that instruction. If all
1377 ;;; instructions fit perfectly, return 0 and 0.
1378 (defun segment-overflow (segment dstate
)
1379 (declare (type segment segment
)
1380 (type disassem-state dstate
))
1381 (let ((seglen (seg-length segment
))
1383 (map-segment-instructions (lambda (chunk inst
)
1384 (declare (ignore chunk inst
))
1385 (setf last-start
(dstate-cur-offs dstate
)))
1388 (values (- (dstate-cur-offs dstate
) seglen
)
1389 (- seglen last-start
))))
1391 ;;; Compute labels for all the memory segments in SEGLIST and adds
1392 ;;; them to DSTATE. It's important to call this function with all the
1393 ;;; segments you're interested in, so that it can find references from
1395 (defun label-segments (seglist dstate
)
1396 (declare (type list seglist
)
1397 (type disassem-state dstate
))
1398 (dolist (seg seglist
)
1399 (add-segment-labels seg dstate
))
1400 ;; Now remove any labels that don't point anywhere in the segments
1402 (setf (dstate-labels dstate
)
1403 (remove-if (lambda (lab)
1406 (let ((start (seg-virtual-location seg
)))
1409 (+ start
(seg-length seg
)))))
1411 (dstate-labels dstate
))))
1413 ;;; Disassemble the machine code instructions in SEGMENT to STREAM.
1414 (defun disassemble-segment (segment stream dstate
)
1415 (declare (type segment segment
)
1416 (type stream stream
)
1417 (type disassem-state dstate
))
1418 (let ((*print-pretty
* nil
)) ; otherwise the pp conses hugely
1419 (number-labels dstate
)
1420 (map-segment-instructions
1421 (lambda (chunk inst
)
1422 (declare (type dchunk chunk
) (type instruction inst
))
1423 (let ((printer (inst-printer inst
)))
1425 (funcall printer chunk inst stream dstate
))))
1430 ;;; Disassemble the machine code instructions in each memory segment
1431 ;;; in SEGMENTS in turn to STREAM.
1432 (defun disassemble-segments (segments stream dstate
)
1433 (declare (type list segments
)
1434 (type stream stream
)
1435 (type disassem-state dstate
))
1436 (unless (null segments
)
1437 (let ((first (car segments
))
1438 (last (car (last segments
))))
1439 (set-location-printing-range dstate
1440 (seg-virtual-location first
)
1441 (- (+ (seg-virtual-location last
)
1443 (seg-virtual-location first
)))
1444 (setf (dstate-output-state dstate
) :beginning
)
1445 (dolist (seg segments
)
1446 (disassemble-segment seg stream dstate
)))))
1448 ;;;; top level functions
1450 ;;; Disassemble the machine code instructions for FUNCTION.
1451 (defun disassemble-fun (fun &key
1452 (stream *standard-output
*)
1454 (declare (type compiled-function fun
)
1455 (type stream stream
)
1456 (type (member t nil
) use-labels
))
1457 (let* ((dstate (make-dstate))
1458 (segments (get-fun-segments fun
)))
1460 (label-segments segments dstate
))
1461 (disassemble-segments segments stream dstate
)))
1463 ;;; FIXME: We probably don't need this any more now that there are
1464 ;;; no interpreted functions, only compiled ones.
1465 (defun compile-function-lambda-expr (function)
1466 (declare (type function function
))
1467 (multiple-value-bind (lambda closurep name
)
1468 (function-lambda-expression function
)
1469 (declare (ignore name
))
1471 (error "can't compile a lexical closure"))
1472 (compile nil lambda
)))
1474 (defun compiled-fun-or-lose (thing &optional
(name thing
))
1475 (cond ((legal-fun-name-p thing
)
1476 (compiled-fun-or-lose (fdefinition thing
) thing
))
1480 (eq (car thing
) 'lambda
))
1481 (compile nil thing
))
1483 (error "can't make a compiled function from ~S" name
))))
1485 (defun disassemble (object &key
1486 (stream *standard-output
*)
1489 "Disassemble the compiled code associated with OBJECT, which can be a
1490 function, a lambda expression, or a symbol with a function definition. If
1491 it is not already compiled, the compiler is called to produce something to
1493 (declare (type (or function symbol cons
) object
)
1494 (type (or (member t
) stream
) stream
)
1495 (type (member t nil
) use-labels
))
1496 (pprint-logical-block (*standard-output
* nil
:per-line-prefix
"; ")
1497 (disassemble-fun (compiled-fun-or-lose object
)
1499 :use-labels use-labels
)
1502 ;;; Disassembles the given area of memory starting at ADDRESS and
1503 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
1504 ;;; could move during a GC, you'd better disable it around the call to
1506 (defun disassemble-memory (address
1509 (stream *standard-output
*)
1512 (declare (type (or address sb
!sys
:system-area-pointer
) address
)
1513 (type disassem-length length
)
1514 (type stream stream
)
1515 (type (or null sb
!kernel
:code-component
) code-component
)
1516 (type (member t nil
) use-labels
))
1518 (if (sb!sys
:system-area-pointer-p address
)
1519 (sb!sys
:sap-int address
)
1521 (dstate (make-dstate))
1527 (sb!kernel
:code-instructions code-component
)))))
1528 (when (or (< code-offs
0)
1529 (> code-offs
(code-inst-area-length code-component
)))
1530 (error "address ~X not in the code component ~S"
1531 address code-component
))
1532 (get-code-segments code-component code-offs length
))
1533 (list (make-memory-segment address length
)))))
1535 (label-segments segments dstate
))
1536 (disassemble-segments segments stream dstate
)))
1538 ;;; Disassemble the machine code instructions associated with
1539 ;;; CODE-COMPONENT (this may include multiple entry points).
1540 (defun disassemble-code-component (code-component &key
1541 (stream *standard-output
*)
1543 (declare (type (or null sb
!kernel
:code-component compiled-function
)
1545 (type stream stream
)
1546 (type (member t nil
) use-labels
))
1547 (let* ((code-component
1548 (if (functionp code-component
)
1549 (fun-code code-component
)
1551 (dstate (make-dstate))
1552 (segments (get-code-segments code-component
)))
1554 (label-segments segments dstate
))
1555 (disassemble-segments segments stream dstate
)))
1557 ;;; code for making useful segments from arbitrary lists of code-blocks
1559 ;;; the maximum size of an instruction. Note that this includes
1560 ;;; pseudo-instructions like error traps with their associated
1561 ;;; operands, so it should be big enough to include them, i.e. it's
1562 ;;; not just 4 on a risc machine!
1563 (defconstant max-instruction-size
16)
1565 (defun add-block-segments (seg-code-block
1570 (declare (type list seglist
)
1571 (type integer location
)
1572 (type (or null
(vector (unsigned-byte 8))) connecting-vec
)
1573 (type disassem-state dstate
))
1574 (flet ((addit (seg overflow
)
1575 (let ((length (+ (seg-length seg
) overflow
)))
1577 (setf (seg-length seg
) length
)
1578 (incf location length
)
1579 (push seg seglist
)))))
1580 (let ((connecting-overflow 0)
1581 (amount (length seg-code-block
)))
1582 (when connecting-vec
1583 ;; Tack on some of the new block to the old overflow vector.
1584 (let* ((beginning-of-block-amount
1585 (if seg-code-block
(min max-instruction-size amount
) 0))
1589 '(vector (unsigned-byte 8))
1591 (subseq seg-code-block
0 beginning-of-block-amount
))
1593 (when (and (< (length connecting-vec
) max-instruction-size
)
1594 (not (null seg-code-block
)))
1595 (return-from add-block-segments
1596 ;; We want connecting vectors to be large enough to hold
1597 ;; any instruction, and since the current seg-code-block
1598 ;; wasn't large enough to do this (and is now entirely
1599 ;; on the end of the overflow-vector), just save it for
1601 (values seglist location connecting-vec
)))
1602 (when (> (length connecting-vec
) 0)
1604 (make-vector-segment connecting-vec
1606 (- (length connecting-vec
)
1607 beginning-of-block-amount
)
1608 :virtual-location location
)))
1609 (setf connecting-overflow
(segment-overflow seg dstate
))
1610 (addit seg connecting-overflow
)))))
1611 (cond ((null seg-code-block
)
1612 ;; nothing more to add
1613 (values seglist location nil
))
1614 ((< (- amount connecting-overflow
) max-instruction-size
)
1615 ;; We can't create a segment with the minimum size
1616 ;; required for an instruction, so just keep on accumulating
1617 ;; in the overflow vector for the time-being.
1620 (subseq seg-code-block connecting-overflow amount
)))
1622 ;; Put as much as we can into a new segment, and the rest
1623 ;; into the overflow-vector.
1624 (let* ((initial-length
1625 (- amount connecting-overflow max-instruction-size
))
1627 (make-vector-segment seg-code-block
1630 :virtual-location location
))
1632 (segment-overflow seg dstate
)))
1633 (addit seg overflow
)
1636 (subseq seg-code-block
1637 (+ connecting-overflow
(seg-length seg
))
1640 ;;;; code to disassemble assembler segments
1642 (defun assem-segment-to-disassem-segments (assem-segment dstate
)
1643 (declare (type sb
!assem
:segment assem-segment
)
1644 (type disassem-state dstate
))
1646 (disassem-segments nil
)
1647 (connecting-vec nil
))
1648 (sb!assem
:on-segment-contents-vectorly
1650 (lambda (seg-code-block)
1651 (multiple-value-setq (disassem-segments location connecting-vec
)
1652 (add-block-segments seg-code-block
1657 (when connecting-vec
1658 (setf disassem-segments
1659 (add-block-segments nil
1664 (sort disassem-segments
#'< :key
#'seg-virtual-location
)))
1666 ;;; Disassemble the machine code instructions associated with
1667 ;;; ASSEM-SEGMENT (of type assem:segment).
1668 (defun disassemble-assem-segment (assem-segment stream
)
1669 (declare (type sb
!assem
:segment assem-segment
)
1670 (type stream stream
))
1671 (let* ((dstate (make-dstate))
1673 (assem-segment-to-disassem-segments assem-segment dstate
)))
1674 (label-segments disassem-segments dstate
)
1675 (disassemble-segments disassem-segments stream dstate
)))
1677 ;;; routines to find things in the Lisp environment
1679 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
1680 ;;; in a symbol object that we know about
1681 (defparameter *grokked-symbol-slots
*
1682 (sort `((,sb
!vm
:symbol-value-slot . symbol-value
)
1683 (,sb
!vm
:symbol-plist-slot . symbol-plist
)
1684 (,sb
!vm
:symbol-name-slot . symbol-name
)
1685 (,sb
!vm
:symbol-package-slot . symbol-package
))
1689 ;;; Given ADDRESS, try and figure out if which slot of which symbol is
1690 ;;; being referred to. Of course we can just give up, so it's not a
1691 ;;; big deal... Return two values, the symbol and the name of the
1692 ;;; access function of the slot.
1693 (defun grok-symbol-slot-ref (address)
1694 (declare (type address address
))
1695 (if (not (aligned-p address sb
!vm
:n-word-bytes
))
1697 (do ((slots-tail *grokked-symbol-slots
* (cdr slots-tail
)))
1700 (let* ((field (car slots-tail
))
1701 (slot-offset (words-to-bytes (car field
)))
1702 (maybe-symbol-addr (- address slot-offset
))
1704 (sb!kernel
:make-lisp-obj
1705 (+ maybe-symbol-addr sb
!vm
:other-pointer-lowtag
))))
1706 (when (symbolp maybe-symbol
)
1707 (return (values maybe-symbol
(cdr field
))))))))
1709 (defvar *address-of-nil-object
* (sb!kernel
:get-lisp-obj-address nil
))
1711 ;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
1712 ;;; which symbol is being referred to. Of course we can just give up,
1713 ;;; so it's not a big deal... Return two values, the symbol and the
1714 ;;; access function.
1715 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1716 (declare (type offset byte-offset
))
1717 (grok-symbol-slot-ref (+ *address-of-nil-object
* byte-offset
)))
1719 ;;; Return the Lisp object located BYTE-OFFSET from NIL.
1720 (defun get-nil-indexed-object (byte-offset)
1721 (declare (type offset byte-offset
))
1722 (sb!kernel
:make-lisp-obj
(+ *address-of-nil-object
* byte-offset
)))
1724 ;;; Return two values; the Lisp object located at BYTE-OFFSET in the
1725 ;;; constant area of the code-object in the current segment and T, or
1726 ;;; NIL and NIL if there is no code-object in the current segment.
1727 (defun get-code-constant (byte-offset dstate
)
1729 (declare (type offset byte-offset
)
1730 (type disassem-state dstate
))
1731 (let ((code (seg-code (dstate-segment dstate
))))
1734 (sb!kernel
:code-header-ref code
1736 sb
!vm
:other-pointer-lowtag
)
1737 (- sb
!vm
:word-shift
)))
1741 (defun get-code-constant-absolute (addr dstate
)
1742 (declare (type address addr
))
1743 (declare (type disassem-state dstate
))
1744 (let ((code (seg-code (dstate-segment dstate
))))
1746 (return-from get-code-constant-absolute
(values nil nil
)))
1747 (let ((code-size (ash (sb!kernel
:get-header-data code
) sb
!vm
:word-shift
)))
1748 (sb!sys
:without-gcing
1749 (let ((code-addr (- (sb!kernel
:get-lisp-obj-address code
)
1750 sb
!vm
:other-pointer-lowtag
)))
1751 (if (or (< addr code-addr
) (>= addr
(+ code-addr code-size
)))
1753 (values (sb!kernel
:code-header-ref
1755 (ash (- addr code-addr
) (- sb
!vm
:word-shift
)))
1758 (defvar *assembler-routines-by-addr
* nil
)
1760 (defvar *foreign-symbols-by-addr
* nil
)
1762 ;;; Build an address-name hash-table from the name-address hash
1763 (defun invert-address-hash (htable &optional
(addr-hash (make-hash-table)))
1764 (maphash (lambda (name address
)
1765 (setf (gethash address addr-hash
) name
))
1769 ;;; Return the name of the primitive Lisp assembler routine or foreign
1770 ;;; symbol located at ADDRESS, or NIL if there isn't one.
1771 (defun find-assembler-routine (address)
1772 (declare (type address address
))
1773 (when (null *assembler-routines-by-addr
*)
1774 (setf *assembler-routines-by-addr
*
1775 (invert-address-hash sb
!fasl
:*assembler-routines
*))
1776 (setf *assembler-routines-by-addr
*
1777 (invert-address-hash sb
!fasl
:*static-foreign-symbols
*
1778 *assembler-routines-by-addr
*)))
1779 (gethash address
*assembler-routines-by-addr
*))
1781 ;;;; some handy function for machine-dependent code to use...
1783 #!-sb-fluid
(declaim (maybe-inline sap-ref-int read-suffix
))
1785 (defun sap-ref-int (sap offset length byte-order
)
1786 (declare (type sb
!sys
:system-area-pointer sap
)
1787 (type (unsigned-byte 16) offset
)
1788 (type (member 1 2 4) length
)
1789 (type (member :little-endian
:big-endian
) byte-order
)
1790 (optimize (speed 3) (safety 0)))
1792 (1 (sb!sys
:sap-ref-8 sap offset
))
1793 (2 (if (eq byte-order
:big-endian
)
1794 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 8)
1795 (sb!sys
:sap-ref-8 sap
(+ offset
1)))
1796 (+ (ash (sb!sys
:sap-ref-8 sap
(+ offset
1)) 8)
1797 (sb!sys
:sap-ref-8 sap offset
))))
1798 (4 (if (eq byte-order
:big-endian
)
1799 (+ (ash (sb!sys
:sap-ref-8 sap offset
) 24)
1800 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 16)
1801 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 8)
1802 (sb!sys
:sap-ref-8 sap
(+ 3 offset
)))
1803 (+ (sb!sys
:sap-ref-8 sap offset
)
1804 (ash (sb!sys
:sap-ref-8 sap
(+ 1 offset
)) 8)
1805 (ash (sb!sys
:sap-ref-8 sap
(+ 2 offset
)) 16)
1806 (ash (sb!sys
:sap-ref-8 sap
(+ 3 offset
)) 24))))))
1808 (defun read-suffix (length dstate
)
1809 (declare (type (member 8 16 32) length
)
1810 (type disassem-state dstate
)
1811 (optimize (speed 3) (safety 0)))
1812 (let ((length (ecase length
(8 1) (16 2) (32 4))))
1813 (declare (type (unsigned-byte 3) length
))
1815 (sap-ref-int (dstate-segment-sap dstate
)
1816 (dstate-next-offs dstate
)
1818 (dstate-byte-order dstate
))
1819 (incf (dstate-next-offs dstate
) length
))))
1821 ;;;; optional routines to make notes about code
1823 ;;; Store NOTE (which can be either a string or a function with a
1824 ;;; single stream argument) to be printed as an end-of-line comment
1825 ;;; after the current instruction is disassembled.
1826 (defun note (note dstate
)
1827 (declare (type (or string function
) note
)
1828 (type disassem-state dstate
))
1829 (push note
(dstate-notes dstate
)))
1831 (defun prin1-short (thing stream
)
1832 (with-print-restrictions
1833 (prin1 thing stream
)))
1835 (defun prin1-quoted-short (thing stream
)
1836 (if (self-evaluating-p thing
)
1837 (prin1-short thing stream
)
1838 (prin1-short `',thing stream
)))
1840 ;;; Store a note about the lisp constant located BYTE-OFFSET bytes
1841 ;;; from the current code-component, to be printed as an end-of-line
1842 ;;; comment after the current instruction is disassembled.
1843 (defun note-code-constant (byte-offset dstate
)
1844 (declare (type offset byte-offset
)
1845 (type disassem-state dstate
))
1846 (multiple-value-bind (const valid
)
1847 (get-code-constant byte-offset dstate
)
1849 (note (lambda (stream)
1850 (prin1-quoted-short const stream
))
1854 ;;; Store a note about the lisp constant located at ADDR in the
1855 ;;; current code-component, to be printed as an end-of-line comment
1856 ;;; after the current instruction is disassembled.
1857 (defun note-code-constant-absolute (addr dstate
)
1858 (declare (type address addr
)
1859 (type disassem-state dstate
))
1860 (multiple-value-bind (const valid
)
1861 (get-code-constant-absolute addr dstate
)
1863 (note (lambda (stream)
1864 (prin1-quoted-short const stream
))
1866 (values const valid
)))
1868 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1869 ;;; constant NIL is a valid slot in a symbol, store a note describing
1870 ;;; which symbol and slot, to be printed as an end-of-line comment
1871 ;;; after the current instruction is disassembled. Returns non-NIL iff
1872 ;;; a note was recorded.
1873 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate
)
1874 (declare (type offset nil-byte-offset
)
1875 (type disassem-state dstate
))
1876 (multiple-value-bind (symbol access-fun
)
1877 (grok-nil-indexed-symbol-slot-ref nil-byte-offset
)
1879 (note (lambda (stream)
1880 (prin1 (if (eq access-fun
'symbol-value
)
1882 `(,access-fun
',symbol
))
1887 ;;; If the memory address located NIL-BYTE-OFFSET bytes from the
1888 ;;; constant NIL is a valid lisp object, store a note describing which
1889 ;;; symbol and slot, to be printed as an end-of-line comment after the
1890 ;;; current instruction is disassembled. Returns non-NIL iff a note
1892 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate
)
1893 (declare (type offset nil-byte-offset
)
1894 (type disassem-state dstate
))
1895 (let ((obj (get-nil-indexed-object nil-byte-offset
)))
1896 (note (lambda (stream)
1897 (prin1-quoted-short obj stream
))
1901 ;;; If ADDRESS is the address of a primitive assembler routine or
1902 ;;; foreign symbol, store a note describing which one, to be printed
1903 ;;; as an end-of-line comment after the current instruction is
1904 ;;; disassembled. Returns non-NIL iff a note was recorded. If
1905 ;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made.
1906 (defun maybe-note-assembler-routine (address note-address-p dstate
)
1907 (declare (type disassem-state dstate
))
1908 (unless (typep address
'address
)
1909 (return-from maybe-note-assembler-routine nil
))
1910 (let ((name (find-assembler-routine address
)))
1912 (note (lambda (stream)
1914 (format stream
"#x~8,'0x: ~a" address name
)
1915 (princ name stream
)))
1919 ;;; If there's a valid mapping from OFFSET in the storage class
1920 ;;; SC-NAME to a source variable, make a note of the source-variable
1921 ;;; name, to be printed as an end-of-line comment after the current
1922 ;;; instruction is disassembled. Returns non-NIL iff a note was
1924 (defun maybe-note-single-storage-ref (offset sc-name dstate
)
1925 (declare (type offset offset
)
1926 (type symbol sc-name
)
1927 (type disassem-state dstate
))
1928 (let ((storage-location
1929 (find-valid-storage-location offset sc-name dstate
)))
1930 (when storage-location
1931 (note (lambda (stream)
1932 (princ (sb!di
:debug-var-symbol
1933 (aref (storage-info-debug-vars
1934 (seg-storage-info (dstate-segment dstate
)))
1940 ;;; If there's a valid mapping from OFFSET in the storage-base called
1941 ;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with
1942 ;;; the source-variable name, to be printed as an end-of-line comment
1943 ;;; after the current instruction is disassembled. Returns non-NIL iff
1944 ;;; a note was recorded.
1945 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate
)
1946 (declare (type offset offset
)
1947 (type symbol sb-name
)
1948 (type (or symbol string
) assoc-with
)
1949 (type disassem-state dstate
))
1950 (let ((storage-location
1951 (find-valid-storage-location offset sb-name dstate
)))
1952 (when storage-location
1953 (note (lambda (stream)
1954 (format stream
"~A = ~S"
1956 (sb!di
:debug-var-symbol
1957 (aref (dstate-debug-vars dstate
)
1958 storage-location
))))
1962 (defun get-internal-error-name (errnum)
1963 (car (svref sb
!c
:*backend-internal-errors
* errnum
)))
1965 (defun get-sc-name (sc-offs)
1966 (sb!c
::location-print-name
1967 ;; FIXME: This seems like an awful lot of computation just to get a name.
1968 ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
1970 (sb!c
:make-random-tn
:kind
:normal
1971 :sc
(svref sb
!c
:*backend-sc-numbers
*
1972 (sb!c
:sc-offset-scn sc-offs
))
1973 :offset
(sb!c
:sc-offset-offset sc-offs
))))
1975 ;;; When called from an error break instruction's :DISASSEM-CONTROL (or
1976 ;;; :DISASSEM-PRINTER) function, will correctly deal with printing the
1977 ;;; arguments to the break.
1979 ;;; ERROR-PARSE-FUN should be a function that accepts:
1980 ;;; 1) a SYSTEM-AREA-POINTER
1981 ;;; 2) a BYTE-OFFSET from the SAP to begin at
1982 ;;; 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
1983 ;;; the byte length of the arguments (to avoid unnecessary consing)
1984 ;;; It should read information from the SAP starting at BYTE-OFFSET, and
1985 ;;; return four values:
1986 ;;; 1) the error number
1987 ;;; 2) the total length, in bytes, of the information
1988 ;;; 3) a list of SC-OFFSETs of the locations of the error parameters
1989 ;;; 4) a list of the length (as read from the SAP), in bytes, of each
1990 ;;; of the return values.
1991 (defun handle-break-args (error-parse-fun stream dstate
)
1992 (declare (type function error-parse-fun
)
1993 (type (or null stream
) stream
)
1994 (type disassem-state dstate
))
1995 (multiple-value-bind (errnum adjust sc-offsets lengths
)
1996 (funcall error-parse-fun
1997 (dstate-segment-sap dstate
)
1998 (dstate-next-offs dstate
)
2001 (setf (dstate-cur-offs dstate
)
2002 (dstate-next-offs dstate
))
2003 (flet ((emit-err-arg (note)
2004 (let ((num (pop lengths
)))
2005 (print-notes-and-newline stream dstate
)
2006 (print-current-address stream dstate
)
2007 (print-bytes num stream dstate
)
2008 (incf (dstate-cur-offs dstate
) num
)
2010 (note note dstate
)))))
2012 (emit-err-arg (symbol-name (get-internal-error-name errnum
)))
2013 (dolist (sc-offs sc-offsets
)
2014 (emit-err-arg (get-sc-name sc-offs
)))))
2015 (incf (dstate-next-offs dstate
)