src/compiler/target-disassem.lisp

   1 ;;;; disassembler-related stuff not needed in cross-compilation host
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!DISASSEM")
  13
  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).
  17 \f
  18 ;;;; combining instructions where one specializes another
  19
  20 (defun inst-specializes-p (special general)
  21   #!+sb-doc
  22   "Returns non-NIL if the instruction SPECIAL is a more specific version of
  23   GENERAL (i.e., the same instruction, but with more constraints)."
  24   (declare (type instruction special general))
  25   (let ((smask (inst-mask special))
  26         (gmask (inst-mask general)))
  27     (and (dchunk= (inst-id general)
  28                   (dchunk-and (inst-id special) gmask))
  29          (dchunk-strict-superset-p smask gmask))))
  30
  31 ;;; a bit arbitrary, but should work ok...
  32 (defun specializer-rank (inst)
  33   #!+sb-doc
  34   "Returns an integer corresponding to the specificity of the instruction INST."
  35   (declare (type instruction inst))
  36   (* (dchunk-count-bits (inst-mask inst)) 4))
  37
  38 (defun order-specializers (insts)
  39   #!+sb-doc
  40   "Order the list of instructions INSTS with more specific (more constant
  41   bits, or same-as argument constains) ones first. Returns the ordered list."
  42   (declare (type list insts))
  43   (sort insts
  44         #'(lambda (i1 i2)
  45             (> (specializer-rank i1) (specializer-rank i2)))))
  46
  47 (defun specialization-error (insts)
  48   (error "Instructions either aren't related or conflict in some way:~% ~S"
  49          insts))
  50
  51 (defun try-specializing (insts)
  52   #!+sb-doc
  53   "Given a list of instructions INSTS, Sees if one of these instructions is a
  54   more general form of all the others, in which case they are put into its
  55   specializers list, and it is returned. Otherwise an error is signaled."
  56   (declare (type list insts))
  57   (let ((masters (copy-list insts)))
  58     (dolist (possible-master insts)
  59       (dolist (possible-specializer insts)
  60         (unless (or (eq possible-specializer possible-master)
  61                     (inst-specializes-p possible-specializer possible-master))
  62           (setf masters (delete possible-master masters))
  63           (return)                      ; exit the inner loop
  64           )))
  65     (cond ((null masters)
  66            (specialization-error insts))
  67           ((cdr masters)
  68            (error "multiple specializing masters: ~S" masters))
  69           (t
  70            (let ((master (car masters)))
  71              (setf (inst-specializers master)
  72                    (order-specializers (remove master insts)))
  73              master)))))
  74 \f
  75 ;;;; choosing an instruction
  76
  77 #!-sb-fluid (declaim (inline inst-matches-p choose-inst-specialization))
  78
  79 (defun inst-matches-p (inst chunk)
  80   #!+sb-doc
  81   "Returns non-NIL if all constant-bits in INST match CHUNK."
  82   (declare (type instruction inst)
  83            (type dchunk chunk))
  84   (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst)))
  85
  86 (defun choose-inst-specialization (inst chunk)
  87   #!+sb-doc
  88   "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the
  89   most specific instruction on INST's specializer list whose constraints are
  90   met by CHUNK. If none do, then INST is returned."
  91   (declare (type instruction inst)
  92            (type dchunk chunk))
  93   (or (dolist (spec (inst-specializers inst) nil)
  94         (declare (type instruction spec))
  95         (when (inst-matches-p spec chunk)
  96           (return spec)))
  97       inst))
  98 \f
  99 ;;;; searching for an instruction in instruction space
 100
 101 (defun find-inst (chunk inst-space)
 102   #!+sb-doc
 103   "Returns the instruction object within INST-SPACE corresponding to the
 104   bit-pattern CHUNK, or NIL if there isn't one."
 105   (declare (type dchunk chunk)
 106            (type (or null inst-space instruction) inst-space))
 107   (etypecase inst-space
 108     (null nil)
 109     (instruction
 110      (if (inst-matches-p inst-space chunk)
 111          (choose-inst-specialization inst-space chunk)
 112          nil))
 113     (inst-space
 114      (let* ((mask (ispace-valid-mask inst-space))
 115             (id (dchunk-and mask chunk)))
 116        (declare (type dchunk id mask))
 117        (dolist (choice (ispace-choices inst-space))
 118          (declare (type inst-space-choice choice))
 119          (when (dchunk= id (ischoice-common-id choice))
 120            (return (find-inst chunk (ischoice-subspace choice)))))))))
 121 \f
 122 ;;;; building the instruction space
 123
 124 (defun build-inst-space (insts &optional (initial-mask dchunk-one))
 125   #!+sb-doc
 126   "Returns an instruction-space object corresponding to the list of
 127   instructions INSTS. If the optional parameter INITIAL-MASK is supplied, only
 128   bits it has set are used."
 129   ;; This is done by finding any set of bits that's common to
 130   ;; all instructions, building an instruction-space node that selects on those
 131   ;; bits, and recursively handle sets of instructions with a common value for
 132   ;; these bits (which, since there should be fewer instructions than in INSTS,
 133   ;; should have some additional set of bits to select on, etc). If there
 134   ;; are no common bits, or all instructions have the same value within those
 135   ;; bits, TRY-SPECIALIZING is called, which handles the cases of many
 136   ;; variations on a single instruction.
 137   (declare (type list insts)
 138            (type dchunk initial-mask))
 139   (cond ((null insts)
 140          nil)
 141         ((null (cdr insts))
 142          (car insts))
 143         (t
 144          (let ((vmask (dchunk-copy initial-mask)))
 145            (dolist (inst insts)
 146              (dchunk-andf vmask (inst-mask inst)))
 147            (if (dchunk-zerop vmask)
 148                (try-specializing insts)
 149                (let ((buckets nil))
 150                  (dolist (inst insts)
 151                    (let* ((common-id (dchunk-and (inst-id inst) vmask))
 152                           (bucket (assoc common-id buckets :test #'dchunk=)))
 153                      (cond ((null bucket)
 154                             (push (list common-id inst) buckets))
 155                            (t
 156                             (push inst (cdr bucket))))))
 157                  (let ((submask (dchunk-clear initial-mask vmask)))
 158                    (if (= (length buckets) 1)
 159                        (try-specializing insts)
 160                        (make-inst-space
 161                         :valid-mask vmask
 162                         :choices (mapcar #'(lambda (bucket)
 163                                              (make-inst-space-choice
 164                                               :subspace (build-inst-space
 165                                                          (cdr bucket)
 166                                                          submask)
 167                                               :common-id (car bucket)))
 168                                          buckets))))))))))
 169 \f
 170 ;;;; an inst-space printer for debugging purposes
 171
 172 (defun print-masked-binary (num mask word-size &optional (show word-size))
 173   (do ((bit (1- word-size) (1- bit)))
 174       ((< bit 0))
 175     (write-char (cond ((logbitp bit mask)
 176                        (if (logbitp bit num) #\1 #\0))
 177                       ((< bit show) #\x)
 178                       (t #\space)))))
 179
 180 (defun print-inst-bits (inst)
 181   (print-masked-binary (inst-id inst)
 182                        (inst-mask inst)
 183                        dchunk-bits
 184                        (bytes-to-bits (inst-length inst))))
 185
 186 (defun print-inst-space (inst-space &optional (indent 0))
 187   #!+sb-doc
 188   "Prints a nicely formatted version of INST-SPACE."
 189   (etypecase inst-space
 190     (null)
 191     (instruction
 192      (format t "~Vt[~A(~A)~40T" indent
 193              (inst-name inst-space)
 194              (inst-format-name inst-space))
 195      (print-inst-bits inst-space)
 196      (dolist (inst (inst-specializers inst-space))
 197        (format t "~%~Vt:~A~40T" indent (inst-name inst))
 198        (print-inst-bits inst))
 199      (write-char #\])
 200      (terpri))
 201     (inst-space
 202      (format t "~Vt---- ~8,'0X ----~%"
 203              indent
 204              (ispace-valid-mask inst-space))
 205      (map nil
 206           #'(lambda (choice)
 207               (format t "~Vt~8,'0X ==>~%"
 208                       (+ 2 indent)
 209                       (ischoice-common-id choice))
 210               (print-inst-space (ischoice-subspace choice)
 211                                 (+ 4 indent)))
 212           (ispace-choices inst-space)))))
 213 \f
 214 ;;;; (The actual disassembly part follows.)
 215 \f
 216 ;;; Code object layout:
 217 ;;;     header-word
 218 ;;;     code-size (starting from first inst, in words)
 219 ;;;     entry-points (points to first function header)
 220 ;;;     debug-info
 221 ;;;     trace-table-offset (starting from first inst, in bytes)
 222 ;;;     constant1
 223 ;;;     constant2
 224 ;;;     ...
 225 ;;;     <padding to dual-word boundary>
 226 ;;;     start of instructions
 227 ;;;     ...
 228 ;;;     function-headers and lra's buried in here randomly
 229 ;;;     ...
 230 ;;;     start of trace-table
 231 ;;;     <padding to dual-word boundary>
 232 ;;;
 233 ;;; Function header layout (dual word aligned):
 234 ;;;     header-word
 235 ;;;     self pointer
 236 ;;;     next pointer (next function header)
 237 ;;;     name
 238 ;;;     arglist
 239 ;;;     type
 240 ;;;
 241 ;;; LRA layout (dual word aligned):
 242 ;;;     header-word
 243
 244 #!-sb-fluid (declaim (inline words-to-bytes bytes-to-words))
 245
 246 (eval-when (:compile-toplevel :load-toplevel :execute)
 247   (defun words-to-bytes (num)
 248     "Converts a word-offset NUM to a byte-offset."
 249     (declare (type offset num))
 250     (ash num sb!vm:word-shift))
 251   ) ; EVAL-WHEN
 252
 253 (defun bytes-to-words (num)
 254   #!+sb-doc
 255   "Converts a byte-offset NUM to a word-offset."
 256   (declare (type offset num))
 257   (ash num (- sb!vm:word-shift)))
 258
 259 (defconstant lra-size (words-to-bytes 1))
 260 \f
 261 (defstruct offs-hook
 262   (offset 0 :type offset)
 263   (function (required-argument) :type function)
 264   (before-address nil :type (member t nil)))
 265
 266 (defstruct (segment (:conc-name seg-)
 267                     (:constructor %make-segment))
 268   (sap-maker (required-argument)
 269              :type (function () sb!sys:system-area-pointer))
 270   (length 0 :type length)
 271   (virtual-location 0 :type address)
 272   (storage-info nil :type (or null storage-info))
 273   (code nil :type (or null sb!kernel:code-component))
 274   (hooks nil :type list))
 275 (def!method print-object ((seg segment) stream)
 276   (print-unreadable-object (seg stream :type t)
 277     (let ((addr (sb!sys:sap-int (funcall (seg-sap-maker seg)))))
 278       (format stream "#X~X[~D]~:[ (#X~X)~;~*~]~@[ in ~S~]"
 279               addr
 280               (seg-length seg)
 281               (= (seg-virtual-location seg) addr)
 282               (seg-virtual-location seg)
 283               (seg-code seg)))))
 284 \f
 285 ;;; All state during disassembly. We store some seemingly redundant
 286 ;;; information so that we can allow garbage collect during disassembly and
 287 ;;; not get tripped up by a code block being moved...
 288 (defstruct (disassem-state (:conc-name dstate-)
 289                            (:constructor %make-dstate))
 290   (cur-offs 0 :type offset)             ; offset of current pos in segment
 291   (next-offs 0 :type offset)            ; offset of next position
 292
 293   (segment-sap (required-argument) :type sb!sys:system-area-pointer)
 294                                         ; a sap pointing to our segment
 295   (segment nil :type (or null segment)) ; the current segment
 296
 297   (alignment sb!vm:word-bytes :type alignment) ; what to align to in most cases
 298   (byte-order :little-endian
 299               :type (member :big-endian :little-endian))
 300
 301   (properties nil :type list)           ; for user code to hang stuff off of
 302   (filtered-values (make-array max-filtered-value-index)
 303                    :type filtered-value-vector)
 304
 305   (addr-print-len nil :type             ; used for prettifying printing
 306                   (or null (integer 0 20)))
 307   (argument-column 0 :type column)
 308   (output-state :beginning              ; to make output look nicer
 309                 :type (member :beginning
 310                               :block-boundary
 311                               nil))
 312
 313   (labels nil :type list)               ; alist of (address . label-number)
 314   (label-hash (make-hash-table)         ; same thing in a different form
 315               :type hash-table)
 316
 317   (fun-hooks nil :type list)            ; list of function
 318
 319   ;; these next two are popped as they are used
 320   (cur-labels nil :type list)           ; alist of (address . label-number)
 321   (cur-offs-hooks nil :type list)       ; list of offs-hook
 322
 323   (notes nil :type list)                ; for the current location
 324
 325   (current-valid-locations nil          ; currently active source variables
 326                            :type (or null (vector bit))))
 327 (def!method print-object ((dstate disassem-state) stream)
 328   (print-unreadable-object (dstate stream :type t)
 329     (format stream
 330             "+~D~@[ in ~S~]"
 331             (dstate-cur-offs dstate)
 332             (dstate-segment dstate))))
 333
 334 (defun dstate-cur-addr (dstate)
 335   #!+sb-doc
 336   "Returns the absolute address of the current instruction in DSTATE."
 337   (the address (+ (seg-virtual-location (dstate-segment dstate))
 338                   (dstate-cur-offs dstate))))
 339
 340 (defun dstate-next-addr (dstate)
 341   #!+sb-doc
 342   "Returns the absolute address of the next instruction in DSTATE."
 343   (the address (+ (seg-virtual-location (dstate-segment dstate))
 344                   (dstate-next-offs dstate))))
 345 \f
 346 ;;;; function ops
 347
 348 (defun fun-self (fun)
 349   (declare (type compiled-function fun))
 350   (sb!kernel:%function-self fun))
 351
 352 (defun fun-code (fun)
 353   (declare (type compiled-function fun))
 354   (sb!kernel:function-code-header (fun-self fun)))
 355
 356 (defun fun-next (fun)
 357   (declare (type compiled-function fun))
 358   (sb!kernel:%function-next fun))
 359
 360 (defun fun-address (function)
 361   (declare (type compiled-function function))
 362   (- (sb!kernel:get-lisp-obj-address function) sb!vm:function-pointer-type))
 363
 364 (defun fun-insts-offset (function)
 365   #!+sb-doc
 366   "Offset of FUNCTION from the start of its code-component's instruction area."
 367   (declare (type compiled-function function))
 368   (- (fun-address function)
 369      (sb!sys:sap-int (sb!kernel:code-instructions (fun-code function)))))
 370
 371 (defun fun-offset (function)
 372   #!+sb-doc
 373   "Offset of FUNCTION from the start of its code-component."
 374   (declare (type compiled-function function))
 375   (words-to-bytes (sb!kernel:get-closure-length function)))
 376 \f
 377 ;;;; operations on code-components (which hold the instructions for
 378 ;;;; one or more functions)
 379
 380 (defun code-inst-area-length (code-component)
 381   #!+sb-doc
 382   "Returns the length of the instruction area in CODE-COMPONENT."
 383   (declare (type sb!kernel:code-component code-component))
 384   (sb!kernel:code-header-ref code-component
 385                              sb!vm:code-trace-table-offset-slot))
 386
 387 (defun code-inst-area-address (code-component)
 388   #!+sb-doc
 389   "Returns the address of the instruction area in CODE-COMPONENT."
 390   (declare (type sb!kernel:code-component code-component))
 391   (sb!sys:sap-int (sb!kernel:code-instructions code-component)))
 392
 393 (defun code-first-function (code-component)
 394   #!+sb-doc
 395   "Returns the first function in CODE-COMPONENT."
 396   (declare (type sb!kernel:code-component code-component))
 397   (sb!kernel:code-header-ref code-component
 398                              sb!vm:code-trace-table-offset-slot))
 399
 400 (defun segment-offs-to-code-offs (offset segment)
 401   (sb!sys:without-gcing
 402    (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
 403           (code-addr
 404            (logandc1 sb!vm:lowtag-mask
 405                      (sb!kernel:get-lisp-obj-address (seg-code segment))))
 406           (addr (+ offset seg-base-addr)))
 407      (declare (type address seg-base-addr code-addr addr))
 408      (- addr code-addr))))
 409
 410 (defun code-offs-to-segment-offs (offset segment)
 411   (sb!sys:without-gcing
 412    (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
 413           (code-addr
 414            (logandc1 sb!vm:lowtag-mask
 415                      (sb!kernel:get-lisp-obj-address (seg-code segment))))
 416           (addr (+ offset code-addr)))
 417      (declare (type address seg-base-addr code-addr addr))
 418      (- addr seg-base-addr))))
 419
 420 (defun code-insts-offs-to-segment-offs (offset segment)
 421   (sb!sys:without-gcing
 422    (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
 423           (code-insts-addr
 424            (sb!sys:sap-int (sb!kernel:code-instructions (seg-code segment))))
 425           (addr (+ offset code-insts-addr)))
 426      (declare (type address seg-base-addr code-insts-addr addr))
 427      (- addr seg-base-addr))))
 428 \f
 429 (defun lra-hook (chunk stream dstate)
 430   (declare (type dchunk chunk)
 431            (ignore chunk)
 432            (type (or null stream) stream)
 433            (type disassem-state dstate))
 434   (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate))
 435                            (dstate-cur-offs dstate))
 436                         (* 2 sb!vm:word-bytes))
 437              ;; Check type.
 438              (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate)
 439                                   (if (eq (dstate-byte-order dstate)
 440                                           :little-endian)
 441                                       (dstate-cur-offs dstate)
 442                                       (+ (dstate-cur-offs dstate)
 443                                          (1- lra-size))))
 444                 sb!vm:return-pc-header-type))
 445     (unless (null stream)
 446       (princ '.lra stream))
 447     (incf (dstate-next-offs dstate) lra-size))
 448   nil)
 449
 450 (defun fun-header-hook (stream dstate)
 451   #!+sb-doc
 452   "Print the function-header (entry-point) pseudo-instruction at the current
 453   location in DSTATE to STREAM."
 454   (declare (type (or null stream) stream)
 455            (type disassem-state dstate))
 456   (unless (null stream)
 457     (let* ((seg (dstate-segment dstate))
 458            (code (seg-code seg))
 459            (woffs
 460             (bytes-to-words
 461              (segment-offs-to-code-offs (dstate-cur-offs dstate) seg)))
 462            (name
 463             (sb!kernel:code-header-ref code
 464                                        (+ woffs sb!vm:function-name-slot)))
 465            (args
 466             (sb!kernel:code-header-ref code
 467                                        (+ woffs sb!vm:function-arglist-slot)))
 468            (type
 469             (sb!kernel:code-header-ref code
 470                                        (+ woffs sb!vm:function-type-slot))))
 471       (format stream ".~A ~S~:A" 'entry name args)
 472       (note #'(lambda (stream)
 473                 (format stream "~:S" type)) ; use format to print NIL as ()
 474             dstate)))
 475   (incf (dstate-next-offs dstate)
 476         (words-to-bytes sb!vm:function-code-offset)))
 477 \f
 478 (defun alignment-hook (chunk stream dstate)
 479   (declare (type dchunk chunk)
 480            (ignore chunk)
 481            (type (or null stream) stream)
 482            (type disassem-state dstate))
 483   (let ((location
 484          (+ (seg-virtual-location (dstate-segment dstate))
 485             (dstate-cur-offs dstate)))
 486         (alignment (dstate-alignment dstate)))
 487     (unless (aligned-p location alignment)
 488       (when stream
 489         (format stream "~A~Vt~D~%" '.align
 490                 (dstate-argument-column dstate)
 491                 alignment))
 492       (incf(dstate-next-offs dstate)
 493            (- (align location alignment) location)))
 494     nil))
 495
 496 (defun rewind-current-segment (dstate segment)
 497   (declare (type disassem-state dstate)
 498            (type segment segment))
 499   (setf (dstate-segment dstate) segment)
 500   (setf (dstate-cur-offs-hooks dstate)
 501         (stable-sort (nreverse (copy-list (seg-hooks segment)))
 502                      #'(lambda (oh1 oh2)
 503                          (or (< (offs-hook-offset oh1) (offs-hook-offset oh2))
 504                              (and (= (offs-hook-offset oh1)
 505                                      (offs-hook-offset oh2))
 506                                   (offs-hook-before-address oh1)
 507                                   (not (offs-hook-before-address oh2)))))))
 508   (setf (dstate-cur-offs dstate) 0)
 509   (setf (dstate-cur-labels dstate) (dstate-labels dstate)))
 510
 511 (defun do-offs-hooks (before-address stream dstate)
 512   (declare (type (or null stream) stream)
 513            (type disassem-state dstate))
 514   (let ((cur-offs (dstate-cur-offs dstate)))
 515     (setf (dstate-next-offs dstate) cur-offs)
 516     (loop
 517       (let ((next-hook (car (dstate-cur-offs-hooks dstate))))
 518         (when (null next-hook)
 519           (return))
 520         (let ((hook-offs (offs-hook-offset next-hook)))
 521           (when (or (> hook-offs cur-offs)
 522                     (and (= hook-offs cur-offs)
 523                          before-address
 524                          (not (offs-hook-before-address next-hook))))
 525             (return))
 526           (unless (< hook-offs cur-offs)
 527             (funcall (offs-hook-function next-hook) stream dstate))
 528           (pop (dstate-cur-offs-hooks dstate))
 529           (unless (= (dstate-next-offs dstate) cur-offs)
 530             (return)))))))
 531
 532 (defun do-fun-hooks (chunk stream dstate)
 533   (let ((hooks (dstate-fun-hooks dstate))
 534         (cur-offs (dstate-cur-offs dstate)))
 535     (setf (dstate-next-offs dstate) cur-offs)
 536     (dolist (hook hooks nil)
 537       (let ((prefix-p (funcall hook chunk stream dstate)))
 538         (unless (= (dstate-next-offs dstate) cur-offs)
 539           (return prefix-p))))))
 540
 541 (defun handle-bogus-instruction (stream dstate)
 542   (let ((alignment (dstate-alignment dstate)))
 543     (unless (null stream)
 544       (multiple-value-bind (words bytes)
 545           (truncate alignment sb!vm:word-bytes)
 546         (when (> words 0)
 547           (print-words words stream dstate))
 548         (when (> bytes 0)
 549           (print-bytes bytes stream dstate))))
 550     (incf (dstate-next-offs dstate) alignment)))
 551
 552 (defun map-segment-instructions (function segment dstate &optional stream)
 553   #!+sb-doc
 554   "Iterate through the instructions in SEGMENT, calling FUNCTION
 555   for each instruction, with arguments of CHUNK, STREAM, and DSTATE."
 556   (declare (type function function)
 557            (type segment segment)
 558            (type disassem-state dstate)
 559            (type (or null stream) stream))
 560
 561   (let ((ispace (get-inst-space))
 562         (prefix-p nil)) ; just processed a prefix inst
 563
 564     (rewind-current-segment dstate segment)
 565
 566     (loop
 567       (when (>= (dstate-cur-offs dstate)
 568                 (seg-length (dstate-segment dstate)))
 569         ;; done!
 570         (return))
 571
 572       (setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
 573
 574       (do-offs-hooks t stream dstate)
 575       (unless (or prefix-p (null stream))
 576         (print-current-address stream dstate))
 577       (do-offs-hooks nil stream dstate)
 578
 579       (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
 580         (sb!sys:without-gcing
 581          (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment)))
 582
 583          (let ((chunk
 584                 (sap-ref-dchunk (dstate-segment-sap dstate)
 585                                 (dstate-cur-offs dstate)
 586                                 (dstate-byte-order dstate))))
 587            (let ((fun-prefix-p (do-fun-hooks chunk stream dstate)))
 588              (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
 589                  (setf prefix-p fun-prefix-p)
 590                  (let ((inst (find-inst chunk ispace)))
 591                    (cond ((null inst)
 592                           (handle-bogus-instruction stream dstate))
 593                          (t
 594                           (setf (dstate-next-offs dstate)
 595                                 (+ (dstate-cur-offs dstate)
 596                                    (inst-length inst)))
 597
 598                           (let ((prefilter (inst-prefilter inst))
 599                                 (control (inst-control inst)))
 600                             (when prefilter
 601                               (funcall prefilter chunk dstate))
 602
 603                             (funcall function chunk inst)
 604
 605                             (setf prefix-p (null (inst-printer inst)))
 606
 607                             (when control
 608                               (funcall control chunk inst stream dstate))))))
 609                  )))))
 610
 611       (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
 612
 613       (unless (null stream)
 614         (unless prefix-p
 615           (print-notes-and-newline stream dstate))
 616         (setf (dstate-output-state dstate) nil)))))
 617 \f
 618 (defun add-segment-labels (segment dstate)
 619   #!+sb-doc
 620   "Make an initial non-printing disassembly pass through DSTATE, noting any
 621   addresses that are referenced by instructions in this segment."
 622   ;; add labels at the beginning with a label-number of nil; we'll notice
 623   ;; later and fill them in (and sort them)
 624   (declare (type disassem-state dstate))
 625   (let ((labels (dstate-labels dstate)))
 626     (map-segment-instructions
 627      #'(lambda (chunk inst)
 628          (declare (type dchunk chunk) (type instruction inst))
 629          (let ((labeller (inst-labeller inst)))
 630            (when labeller
 631              (setf labels (funcall labeller chunk labels dstate)))))
 632      segment
 633      dstate)
 634     (setf (dstate-labels dstate) labels)
 635     ;; erase any notes that got there by accident
 636     (setf (dstate-notes dstate) nil)))
 637
 638 (defun number-labels (dstate)
 639   #!+sb-doc
 640   "If any labels in DSTATE have been added since the last call to this
 641   function, give them label-numbers, enter them in the hash-table, and make
 642   sure the label list is in sorted order."
 643   (let ((labels (dstate-labels dstate)))
 644     (when (and labels (null (cdar labels)))
 645       ;; at least one label left un-numbered
 646       (setf labels (sort labels #'< :key #'car))
 647       (let ((max -1)
 648             (label-hash (dstate-label-hash dstate)))
 649         (dolist (label labels)
 650           (when (not (null (cdr label)))
 651             (setf max (max max (cdr label)))))
 652         (dolist (label labels)
 653           (when (null (cdr label))
 654             (incf max)
 655             (setf (cdr label) max)
 656             (setf (gethash (car label) label-hash)
 657                   (format nil "L~D" max)))))
 658       (setf (dstate-labels dstate) labels))))
 659 \f
 660 (defun get-inst-space ()
 661   #!+sb-doc
 662   "Get the instruction-space, creating it if necessary."
 663   (let ((ispace *disassem-inst-space*))
 664     (when (null ispace)
 665       (let ((insts nil))
 666         (maphash #'(lambda (name inst-flavs)
 667                      (declare (ignore name))
 668                      (dolist (flav inst-flavs)
 669                        (push flav insts)))
 670                  *disassem-insts*)
 671         (setf ispace (build-inst-space insts)))
 672       (setf *disassem-inst-space* ispace))
 673     ispace))
 674 \f
 675 ;;;; Add global hooks.
 676
 677 (defun add-offs-hook (segment addr hook)
 678   (let ((entry (cons addr hook)))
 679     (if (null (seg-hooks segment))
 680         (setf (seg-hooks segment) (list entry))
 681         (push entry (cdr (last (seg-hooks segment)))))))
 682
 683 (defun add-offs-note-hook (segment addr note)
 684   (add-offs-hook segment
 685                  addr
 686                  #'(lambda (stream dstate)
 687                      (declare (type (or null stream) stream)
 688                               (type disassem-state dstate))
 689                      (when stream
 690                        (note note dstate)))))
 691
 692 (defun add-offs-comment-hook (segment addr comment)
 693   (add-offs-hook segment
 694                  addr
 695                  #'(lambda (stream dstate)
 696                      (declare (type (or null stream) stream)
 697                               (ignore dstate))
 698                      (when stream
 699                        (write-string ";;; " stream)
 700                        (etypecase comment
 701                          (string
 702                           (write-string comment stream))
 703                          (function
 704                           (funcall comment stream)))
 705                        (terpri stream)))))
 706
 707 (defun add-fun-hook (dstate function)
 708   (push function (dstate-fun-hooks dstate)))
 709 \f
 710 (defun set-location-printing-range (dstate from length)
 711   (setf (dstate-addr-print-len dstate)
 712         ;; 4 bits per hex digit
 713         (ceiling (integer-length (logxor from (+ from length))) 4)))
 714
 715 (defun print-current-address (stream dstate)
 716   #!+sb-doc
 717   "Print the current address in DSTATE to STREAM, plus any labels that
 718   correspond to it, and leave the cursor in the instruction column."
 719   (declare (type stream stream)
 720            (type disassem-state dstate))
 721   (let* ((location
 722           (+ (seg-virtual-location (dstate-segment dstate))
 723              (dstate-cur-offs dstate)))
 724          (location-column-width *disassem-location-column-width*)
 725          (plen (dstate-addr-print-len dstate)))
 726
 727     (when (null plen)
 728       (setf plen location-column-width)
 729       (set-location-printing-range dstate
 730                                   (seg-virtual-location (dstate-segment dstate))
 731                                   (seg-length (dstate-segment dstate))))
 732     (when (eq (dstate-output-state dstate) :beginning)
 733       (setf plen location-column-width))
 734
 735     (fresh-line stream)
 736
 737     ;; print the location
 738     ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
 739     ;;  usually avoids any consing]
 740     (tab0 (- location-column-width plen) stream)
 741     (let* ((printed-bits (* 4 plen))
 742            (printed-value (ldb (byte printed-bits 0) location))
 743            (leading-zeros
 744             (truncate (- printed-bits (integer-length printed-value)) 4)))
 745       (dotimes (i leading-zeros)
 746         (write-char #\0 stream))
 747       (unless (zerop printed-value)
 748         (write printed-value :stream stream :base 16 :radix nil))
 749       (write-char #\: stream))
 750
 751     ;; print any labels
 752     (loop
 753       (let* ((next-label (car (dstate-cur-labels dstate)))
 754              (label-location (car next-label)))
 755         (when (or (null label-location) (> label-location location))
 756           (return))
 757         (unless (< label-location location)
 758           (format stream " L~D:" (cdr next-label)))
 759         (pop (dstate-cur-labels dstate))))
 760
 761     ;; move to the instruction column
 762     (tab0 (+ location-column-width 1 label-column-width) stream)
 763     ))
 764 \f
 765 (eval-when (:compile-toplevel :execute)
 766   (sb!xc:defmacro with-print-restrictions (&rest body)
 767     `(let ((*print-pretty* t)
 768            (*print-lines* 2)
 769            (*print-length* 4)
 770            (*print-level* 3))
 771        ,@body)))
 772
 773 (defun print-notes-and-newline (stream dstate)
 774   #!+sb-doc
 775   "Print a newline to STREAM, inserting any pending notes in DSTATE as
 776   end-of-line comments. If there is more than one note, a separate line
 777   will be used for each one."
 778   (declare (type stream stream)
 779            (type disassem-state dstate))
 780   (with-print-restrictions
 781     (dolist (note (dstate-notes dstate))
 782       (format stream "~Vt; " *disassem-note-column*)
 783       (etypecase note
 784         (string
 785          (write-string note stream))
 786         (function
 787          (funcall note stream)))
 788       (terpri stream))
 789     (fresh-line stream)
 790     (setf (dstate-notes dstate) nil)))
 791
 792 (defun print-bytes (num stream dstate)
 793   #!+sb-doc
 794   "Disassemble NUM bytes to STREAM as simple `BYTE' instructions"
 795   (declare (type offset num)
 796            (type stream stream)
 797            (type disassem-state dstate))
 798   (format stream "~A~Vt" 'BYTE (dstate-argument-column dstate))
 799   (let ((sap (dstate-segment-sap dstate))
 800         (start-offs (dstate-cur-offs dstate)))
 801     (dotimes (offs num)
 802       (unless (zerop offs)
 803         (write-string ", " stream))
 804       (format stream "#X~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs))))))
 805
 806 (defun print-words (num stream dstate)
 807   #!+sb-doc
 808   "Disassemble NUM machine-words to STREAM as simple `WORD' instructions"
 809   (declare (type offset num)
 810            (type stream stream)
 811            (type disassem-state dstate))
 812   (format stream "~A~Vt" 'WORD (dstate-argument-column dstate))
 813   (let ((sap (dstate-segment-sap dstate))
 814         (start-offs (dstate-cur-offs dstate))
 815         (byte-order (dstate-byte-order dstate)))
 816     (dotimes (word-offs num)
 817       (unless (zerop word-offs)
 818         (write-string ", " stream))
 819       (let ((word 0) (bit-shift 0))
 820         (dotimes (byte-offs sb!vm:word-bytes)
 821           (let ((byte
 822                  (sb!sys:sap-ref-8
 823                         sap
 824                         (+ start-offs
 825                            (* word-offs sb!vm:word-bytes)
 826                            byte-offs))))
 827             (setf word
 828                   (if (eq byte-order :big-endian)
 829                       (+ (ash word sb!vm:byte-bits) byte)
 830                       (+ word (ash byte bit-shift))))
 831             (incf bit-shift sb!vm:byte-bits)))
 832         (format stream "#X~V,'0X" (ash sb!vm:word-bits -2) word)))))
 833 \f
 834 (defvar *default-dstate-hooks* (list #'lra-hook))
 835
 836 (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
 837   #!+sb-doc
 838   "Make a disassembler-state object."
 839   (let ((sap
 840          (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
 841         (alignment *disassem-inst-alignment-bytes*)
 842         (arg-column
 843          (+ (or *disassem-opcode-column-width* 0)
 844             *disassem-location-column-width*
 845             1
 846             label-column-width)))
 847
 848     (when (> alignment 1)
 849       (push #'alignment-hook fun-hooks))
 850
 851     (%make-dstate :segment-sap sap
 852                   :fun-hooks fun-hooks
 853                   :argument-column arg-column
 854                   :alignment alignment
 855                   :byte-order sb!c:*backend-byte-order*)))
 856
 857 (defun add-fun-header-hooks (segment)
 858   (declare (type segment segment))
 859   (do ((fun (sb!kernel:code-header-ref (seg-code segment)
 860                                        sb!vm:code-entry-points-slot)
 861             (fun-next fun))
 862        (length (seg-length segment)))
 863       ((null fun))
 864     (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment)))
 865       (when (<= 0 offset length)
 866         (push (make-offs-hook :offset offset :function #'fun-header-hook)
 867               (seg-hooks segment))))))
 868 \f
 869 ;;; A SAP-MAKER is a no-argument function that returns a SAP.
 870
 871 #!-sb-fluid (declaim (inline sap-maker))
 872
 873 (defun sap-maker (function input offset)
 874   (declare (optimize (speed 3))
 875            (type (function (t) sb!sys:system-area-pointer) function)
 876            (type offset offset))
 877   (let ((old-sap (sb!sys:sap+ (funcall function input) offset)))
 878     (declare (type sb!sys:system-area-pointer old-sap))
 879     #'(lambda ()
 880         (let ((new-addr
 881                (+ (sb!sys:sap-int (funcall function input)) offset)))
 882           ;; Saving the sap like this avoids consing except when the sap
 883           ;; changes (because the sap-int, arith, etc., get inlined).
 884           (declare (type address new-addr))
 885           (if (= (sb!sys:sap-int old-sap) new-addr)
 886               old-sap
 887               (setf old-sap (sb!sys:int-sap new-addr)))))))
 888
 889 (defun vector-sap-maker (vector offset)
 890   (declare (optimize (speed 3))
 891            (type offset offset))
 892   (sap-maker #'sb!sys:vector-sap vector offset))
 893
 894 (defun code-sap-maker (code offset)
 895   (declare (optimize (speed 3))
 896            (type sb!kernel:code-component code)
 897            (type offset offset))
 898   (sap-maker #'sb!kernel:code-instructions code offset))
 899
 900 (defun memory-sap-maker (address)
 901   (declare (optimize (speed 3))
 902            (type address address))
 903   (let ((sap (sb!sys:int-sap address)))
 904     #'(lambda () sap)))
 905 \f
 906 (defun make-segment (sap-maker length
 907                      &key
 908                      code virtual-location
 909                      debug-function source-form-cache
 910                      hooks)
 911   #!+sb-doc
 912   "Return a memory segment located at the system-area-pointer returned by
 913   SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
 914   Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as
 915   the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache
 916   object), and :HOOKS (a list of offs-hook objects)."
 917   (declare (type (function () sb!sys:system-area-pointer) sap-maker)
 918            (type length length)
 919            (type (or null address) virtual-location)
 920            (type (or null sb!di:debug-function) debug-function)
 921            (type (or null source-form-cache) source-form-cache))
 922   (let* ((segment
 923           (%make-segment
 924            :sap-maker sap-maker
 925            :length length
 926            :virtual-location (or virtual-location
 927                                  (sb!sys:sap-int (funcall sap-maker)))
 928            :hooks hooks
 929            :code code)))
 930     (add-debugging-hooks segment debug-function source-form-cache)
 931     (add-fun-header-hooks segment)
 932     segment))
 933
 934 (defun make-vector-segment (vector offset &rest args)
 935   (declare (type vector vector)
 936            (type offset offset)
 937            (inline make-segment))
 938   (apply #'make-segment (vector-sap-maker vector offset) args))
 939
 940 (defun make-code-segment (code offset length &rest args)
 941   (declare (type sb!kernel:code-component code)
 942            (type offset offset)
 943            (inline make-segment))
 944   (apply #'make-segment (code-sap-maker code offset) length :code code args))
 945
 946 (defun make-memory-segment (address &rest args)
 947   (declare (type address address)
 948            (inline make-segment))
 949   (apply #'make-segment (memory-sap-maker address) args))
 950 \f
 951 ;;; just for fun
 952 (defun print-fun-headers (function)
 953   (declare (type compiled-function function))
 954   (let* ((self (fun-self function))
 955          (code (sb!kernel:function-code-header self)))
 956     (format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%"
 957             code
 958             (sb!kernel:code-header-ref code
 959                                        sb!vm:code-code-size-slot)
 960             (sb!kernel:code-header-ref code
 961                                        sb!vm:code-trace-table-offset-slot))
 962     (do ((fun (sb!kernel:code-header-ref code sb!vm:code-entry-points-slot)
 963               (fun-next fun)))
 964         ((null fun))
 965       (let ((fun-offset (sb!kernel:get-closure-length fun)))
 966         ;; There is function header fun-offset words from the
 967         ;; code header.
 968         (format t "Fun-header ~S at offset ~D (words): ~S~A => ~S~%"
 969                 fun
 970                 fun-offset
 971                 (sb!kernel:code-header-ref
 972                  code (+ fun-offset sb!vm:function-name-slot))
 973                 (sb!kernel:code-header-ref
 974                  code (+ fun-offset sb!vm:function-arglist-slot))
 975                 (sb!kernel:code-header-ref
 976                  code (+ fun-offset sb!vm:function-type-slot)))))))
 977 \f
 978 ;;; getting at the source code...
 979
 980 (defstruct (source-form-cache (:conc-name sfcache-))
 981   (debug-source nil :type (or null sb!di:debug-source))
 982   (top-level-form-index -1 :type fixnum)
 983   (top-level-form nil :type list)
 984   (form-number-mapping-table nil :type (or null (vector list)))
 985   (last-location-retrieved nil :type (or null sb!di:code-location))
 986   (last-form-retrieved -1 :type fixnum)
 987   )
 988
 989 (defun get-top-level-form (debug-source tlf-index)
 990   (let ((name (sb!di:debug-source-name debug-source)))
 991     (ecase (sb!di:debug-source-from debug-source)
 992       (:file
 993        (cond ((not (probe-file name))
 994               (warn "The source file ~S no longer seems to exist." name)
 995               nil)
 996              (t
 997               (let ((start-positions
 998                      (sb!di:debug-source-start-positions debug-source)))
 999                 (cond ((null start-positions)
1000                        (warn "There is no start positions map.")
1001                        nil)
1002                       (t
1003                        (let* ((local-tlf-index
1004                                (- tlf-index
1005                                   (sb!di:debug-source-root-number
1006                                    debug-source)))
1007                               (char-offset
1008                                (aref start-positions local-tlf-index)))
1009                          (with-open-file (f name)
1010                            (cond ((= (sb!di:debug-source-created debug-source)
1011                                      (file-write-date name))
1012                                   (file-position f char-offset))
1013                                  (t
1014                                   (warn "Source file ~S has been modified; ~@
1015                                          using form offset instead of file index."
1016                                         name)
1017                                   (let ((*read-suppress* t))
1018                                     (dotimes (i local-tlf-index) (read f)))))
1019                            (let ((*readtable* (copy-readtable)))
1020                              (set-dispatch-macro-character
1021                               #\# #\.
1022                               #'(lambda (stream sub-char &rest rest)
1023                                   (declare (ignore rest sub-char))
1024                                   (let ((token (read stream t nil t)))
1025                                     (format nil "#.~S" token))))
1026                              (read f))
1027                            ))))))))
1028       (:lisp
1029        (aref name tlf-index)))))
1030
1031 (defun cache-valid (loc cache)
1032   (and cache
1033        (and (eq (sb!di:code-location-debug-source loc)
1034                 (sfcache-debug-source cache))
1035             (eq (sb!di:code-location-top-level-form-offset loc)
1036                 (sfcache-top-level-form-index cache)))))
1037
1038 (defun get-source-form (loc context &optional cache)
1039   (let* ((cache-valid (cache-valid loc cache))
1040          (tlf-index (sb!di:code-location-top-level-form-offset loc))
1041          (form-number (sb!di:code-location-form-number loc))
1042          (top-level-form
1043           (if cache-valid
1044               (sfcache-top-level-form cache)
1045               (get-top-level-form (sb!di:code-location-debug-source loc)
1046                                   tlf-index)))
1047          (mapping-table
1048           (if cache-valid
1049               (sfcache-form-number-mapping-table cache)
1050               (sb!di:form-number-translations top-level-form tlf-index))))
1051     (when (and (not cache-valid) cache)
1052       (setf (sfcache-debug-source cache) (sb!di:code-location-debug-source loc)
1053             (sfcache-top-level-form-index cache) tlf-index
1054             (sfcache-top-level-form cache) top-level-form
1055             (sfcache-form-number-mapping-table cache) mapping-table))
1056     (cond ((null top-level-form)
1057            nil)
1058           ((> form-number (length mapping-table))
1059            (warn "bogus form-number in form!  The source file has probably ~@
1060                   been changed too much to cope with.")
1061            (when cache
1062              ;; Disable future warnings.
1063              (setf (sfcache-top-level-form cache) nil))
1064            nil)
1065           (t
1066            (when cache
1067              (setf (sfcache-last-location-retrieved cache) loc)
1068              (setf (sfcache-last-form-retrieved cache) form-number))
1069            (sb!di:source-path-context top-level-form
1070                                       (aref mapping-table form-number)
1071                                       context)))))
1072
1073 (defun get-different-source-form (loc context &optional cache)
1074   (if (and (cache-valid loc cache)
1075            (or (= (sb!di:code-location-form-number loc)
1076                   (sfcache-last-form-retrieved cache))
1077                (and (sfcache-last-location-retrieved cache)
1078                     (sb!di:code-location=
1079                      loc
1080                      (sfcache-last-location-retrieved cache)))))
1081       (values nil nil)
1082       (values (get-source-form loc context cache) t)))
1083 \f
1084 ;;;; stuff to use debugging-info to augment the disassembly
1085
1086 (defun code-function-map (code)
1087   (declare (type sb!kernel:code-component code))
1088   (sb!di::get-debug-info-function-map (sb!kernel:%code-debug-info code)))
1089
1090 (defstruct location-group
1091   (locations #() :type (vector (or list fixnum)))
1092   )
1093
1094 (defstruct storage-info
1095   (groups nil :type list)               ; alist of (name . location-group)
1096   (debug-vars #() :type vector))
1097
1098 (defun dstate-debug-vars (dstate)
1099   #!+sb-doc
1100   "Return the vector of DEBUG-VARs currently associated with DSTATE."
1101   (declare (type disassem-state dstate))
1102   (storage-info-debug-vars (seg-storage-info (dstate-segment dstate))))
1103
1104 (defun find-valid-storage-location (offset lg-name dstate)
1105   #!+sb-doc
1106   "Given the OFFSET of a location within the location-group called LG-NAME,
1107   see whether there's a current mapping to a source variable in DSTATE, and
1108   if so, return the offset of that variable in the current debug-var vector."
1109   (declare (type offset offset)
1110            (type symbol lg-name)
1111            (type disassem-state dstate))
1112   (let* ((storage-info
1113           (seg-storage-info (dstate-segment dstate)))
1114          (location-group
1115           (and storage-info
1116                (cdr (assoc lg-name (storage-info-groups storage-info)))))
1117          (currently-valid
1118           (dstate-current-valid-locations dstate)))
1119     (and location-group
1120          (not (null currently-valid))
1121          (let ((locations (location-group-locations location-group)))
1122            (and (< offset (length locations))
1123                 (let ((used-by (aref locations offset)))
1124                   (and used-by
1125                        (let ((debug-var-num
1126                               (typecase used-by
1127                                 (fixnum
1128                                  (and (not
1129                                        (zerop (bit currently-valid used-by)))
1130                                       used-by))
1131                                 (list
1132                                  (some #'(lambda (num)
1133                                            (and (not
1134                                                  (zerop
1135                                                   (bit currently-valid num)))
1136                                                 num))
1137                                        used-by)))))
1138                          (and debug-var-num
1139                               (progn
1140                                 ;; Found a valid storage reference!
1141                                 ;; can't use it again until it's revalidated...
1142                                 (setf (bit (dstate-current-valid-locations
1143                                             dstate)
1144                                            debug-var-num)
1145                                       0)
1146                                 debug-var-num))
1147                          ))))))))
1148
1149 (defun grow-vector (vec new-len &optional initial-element)
1150   #!+sb-doc
1151   "Return a new vector which has the same contents as the old one VEC, plus
1152   new cells (for a total size of NEW-LEN). The additional elements are
1153   initialized to INITIAL-ELEMENT."
1154   (declare (type vector vec)
1155            (type fixnum new-len))
1156   (let ((new
1157          (make-sequence `(vector ,(array-element-type vec) ,new-len)
1158                         new-len
1159                         :initial-element initial-element)))
1160     (dotimes (i (length vec))
1161       (setf (aref new i) (aref vec i)))
1162     new))
1163
1164 (defun storage-info-for-debug-function (debug-function)
1165   #!+sb-doc
1166   "Returns a STORAGE-INFO struction describing the object-to-source
1167   variable mappings from DEBUG-FUNCTION."
1168   (declare (type sb!di:debug-function debug-function))
1169   (let ((sc-vec sb!c::*backend-sc-numbers*)
1170         (groups nil)
1171         (debug-vars (sb!di::debug-function-debug-vars
1172                      debug-function)))
1173     (and debug-vars
1174          (dotimes (debug-var-offset
1175                    (length debug-vars)
1176                    (make-storage-info :groups groups
1177                                       :debug-vars debug-vars))
1178            (let ((debug-var (aref debug-vars debug-var-offset)))
1179              #+nil
1180              (format t ";;; At offset ~D: ~S~%" debug-var-offset debug-var)
1181              (let* ((sc-offset
1182                      (sb!di::compiled-debug-var-sc-offset debug-var))
1183                     (sb-name
1184                      (sb!c:sb-name
1185                       (sb!c:sc-sb (aref sc-vec
1186                                         (sb!c:sc-offset-scn sc-offset))))))
1187                #+nil
1188                (format t ";;; SET: ~S[~D]~%"
1189                        sb-name (sb!c:sc-offset-offset sc-offset))
1190                (unless (null sb-name)
1191                  (let ((group (cdr (assoc sb-name groups))))
1192                    (when (null group)
1193                      (setf group (make-location-group))
1194                      (push `(,sb-name . ,group) groups))
1195                    (let* ((locations (location-group-locations group))
1196                           (length (length locations))
1197                           (offset (sb!c:sc-offset-offset sc-offset)))
1198                      (when (>= offset length)
1199                        (setf locations
1200                              (grow-vector locations
1201                                           (max (* 2 length)
1202                                                (1+ offset))
1203                                           nil)
1204                              (location-group-locations group)
1205                              locations))
1206                      (let ((already-there (aref locations offset)))
1207                        (cond ((null already-there)
1208                               (setf (aref locations offset) debug-var-offset))
1209                              ((eql already-there debug-var-offset))
1210                              (t
1211                               (if (listp already-there)
1212                                   (pushnew debug-var-offset
1213                                            (aref locations offset))
1214                                   (setf (aref locations offset)
1215                                         (list debug-var-offset
1216                                               already-there)))))
1217                        )))))))
1218          )))
1219
1220 (defun source-available-p (debug-function)
1221   (handler-case
1222       (sb!di:do-debug-function-blocks (block debug-function)
1223         (declare (ignore block))
1224         (return t))
1225     (sb!di:no-debug-blocks () nil)))
1226
1227 (defun print-block-boundary (stream dstate)
1228   (let ((os (dstate-output-state dstate)))
1229     (when (not (eq os :beginning))
1230       (when (not (eq os :block-boundary))
1231         (terpri stream))
1232       (setf (dstate-output-state dstate)
1233             :block-boundary))))
1234
1235 (defun add-source-tracking-hooks (segment debug-function &optional sfcache)
1236   #!+sb-doc
1237   "Add hooks to track to track the source code in SEGMENT during
1238   disassembly. SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
1239   structure, in which case it is used to cache forms from files."
1240   (declare (type segment segment)
1241            (type (or null sb!di:debug-function) debug-function)
1242            (type (or null source-form-cache) sfcache))
1243   (let ((last-block-pc -1))
1244     (flet ((add-hook (pc fun &optional before-address)
1245              (push (make-offs-hook
1246                     :offset pc ;; ##### FIX to account for non-zero offs in code
1247                     :function fun
1248                     :before-address before-address)
1249                    (seg-hooks segment))))
1250       (handler-case
1251           (sb!di:do-debug-function-blocks (block debug-function)
1252             (let ((first-location-in-block-p t))
1253               (sb!di:do-debug-block-locations (loc block)
1254                 (let ((pc (sb!di::compiled-code-location-pc loc)))
1255
1256                   ;; Put blank lines in at block boundaries
1257                   (when (and first-location-in-block-p
1258                              (/= pc last-block-pc))
1259                     (setf first-location-in-block-p nil)
1260                     (add-hook pc
1261                               #'(lambda (stream dstate)
1262                                   (print-block-boundary stream dstate))
1263                               t)
1264                     (setf last-block-pc pc))
1265
1266                   ;; Print out corresponding source; this information is not
1267                   ;; all that accurate, but it's better than nothing
1268                   (unless (zerop (sb!di:code-location-form-number loc))
1269                     (multiple-value-bind (form new)
1270                         (get-different-source-form loc 0 sfcache)
1271                       (when new
1272                          (let ((at-block-begin (= pc last-block-pc)))
1273                            (add-hook
1274                             pc
1275                             #'(lambda (stream dstate)
1276                                 (declare (ignore dstate))
1277                                 (when stream
1278                                   (unless at-block-begin
1279                                     (terpri stream))
1280                                   (format stream ";;; [~D] "
1281                                           (sb!di:code-location-form-number
1282                                            loc))
1283                                   (prin1-short form stream)
1284                                   (terpri stream)
1285                                   (terpri stream)))
1286                             t)))))
1287
1288                   ;; Keep track of variable live-ness as best we can.
1289                   (let ((live-set
1290                          (copy-seq (sb!di::compiled-code-location-live-set
1291                                     loc))))
1292                     (add-hook
1293                      pc
1294                      #'(lambda (stream dstate)
1295                          (declare (ignore stream))
1296                          (setf (dstate-current-valid-locations dstate)
1297                                live-set)
1298                          #+nil
1299                          (note #'(lambda (stream)
1300                                    (let ((*print-length* nil))
1301                                      (format stream "live set: ~S"
1302                                              live-set)))
1303                                dstate))))
1304                   ))))
1305         (sb!di:no-debug-blocks () nil)))))
1306
1307 (defun add-debugging-hooks (segment debug-function &optional sfcache)
1308   (when debug-function
1309     (setf (seg-storage-info segment)
1310           (storage-info-for-debug-function debug-function))
1311     (add-source-tracking-hooks segment debug-function sfcache)
1312     (let ((kind (sb!di:debug-function-kind debug-function)))
1313       (flet ((anh (n)
1314                (push (make-offs-hook
1315                       :offset 0
1316                       :function #'(lambda (stream dstate)
1317                                     (declare (ignore stream))
1318                                     (note n dstate)))
1319                      (seg-hooks segment))))
1320         (case kind
1321           (:external)
1322           ((nil)
1323            (anh "No-arg-parsing entry point"))
1324           (t
1325            (anh #'(lambda (stream)
1326                     (format stream "~S entry point" kind)))))))))
1327 \f
1328 (defun get-function-segments (function)
1329   #!+sb-doc
1330   "Returns a list of the segments of memory containing machine code
1331   instructions for FUNCTION."
1332   (declare (type compiled-function function))
1333   (let* ((code (fun-code function))
1334          (function-map (code-function-map code))
1335          (fname (sb!kernel:%function-name function))
1336          (sfcache (make-source-form-cache)))
1337     (let ((first-block-seen-p nil)
1338           (nil-block-seen-p nil)
1339           (last-offset 0)
1340           (last-debug-function nil)
1341           (segments nil))
1342       (flet ((add-seg (offs len df)
1343                (when (> len 0)
1344                  (push (make-code-segment code offs len
1345                                           :debug-function df
1346                                           :source-form-cache sfcache)
1347                        segments))))
1348         (dotimes (fmap-index (length function-map))
1349           (let ((fmap-entry (aref function-map fmap-index)))
1350             (etypecase fmap-entry
1351               (integer
1352                (when first-block-seen-p
1353                  (add-seg last-offset
1354                           (- fmap-entry last-offset)
1355                           last-debug-function)
1356                  (setf last-debug-function nil))
1357                (setf last-offset fmap-entry))
1358               (sb!c::compiled-debug-function
1359                (let ((name (sb!c::compiled-debug-function-name fmap-entry))
1360                      (kind (sb!c::compiled-debug-function-kind fmap-entry)))
1361                  #+nil
1362                  (format t ";;; SAW ~S ~S ~S,~S ~D,~D~%"
1363                          name kind first-block-seen-p nil-block-seen-p
1364                          last-offset
1365                          (sb!c::compiled-debug-function-start-pc fmap-entry))
1366                  (cond (#+nil (eq last-offset fun-offset)
1367                               (and (equal name fname) (not first-block-seen-p))
1368                               (setf first-block-seen-p t))
1369                        ((eq kind :external)
1370                         (when first-block-seen-p
1371                           (return)))
1372                        ((eq kind nil)
1373                         (when nil-block-seen-p
1374                           (return))
1375                         (when first-block-seen-p
1376                           (setf nil-block-seen-p t))))
1377                  (setf last-debug-function
1378                        (sb!di::make-compiled-debug-function fmap-entry code))
1379                  )))))
1380         (let ((max-offset (code-inst-area-length code)))
1381           (when (and first-block-seen-p last-debug-function)
1382             (add-seg last-offset
1383                      (- max-offset last-offset)
1384                      last-debug-function))
1385           (if (null segments)
1386               (let ((offs (fun-insts-offset function)))
1387                 (make-code-segment code offs (- max-offset offs)))
1388               (nreverse segments)))))))
1389
1390 (defun get-code-segments (code
1391                           &optional
1392                           (start-offs 0)
1393                           (length (code-inst-area-length code)))
1394   #!+sb-doc
1395   "Returns a list of the segments of memory containing machine code
1396   instructions for the code-component CODE. If START-OFFS and/or LENGTH is
1397   supplied, only that part of the code-segment is used (but these are
1398   constrained to lie within the code-segment)."
1399   (declare (type sb!kernel:code-component code)
1400            (type offset start-offs)
1401            (type length length))
1402   (let ((segments nil))
1403     (when code
1404       (let ((function-map (code-function-map code))
1405             (sfcache (make-source-form-cache)))
1406         (let ((last-offset 0)
1407               (last-debug-function nil))
1408           (flet ((add-seg (offs len df)
1409                    (let* ((restricted-offs
1410                            (min (max start-offs offs) (+ start-offs length)))
1411                           (restricted-len
1412                            (- (min (max start-offs (+ offs len))
1413                                    (+ start-offs length))
1414                               restricted-offs)))
1415                      (when (> restricted-len 0)
1416                        (push (make-code-segment code
1417                                                 restricted-offs restricted-len
1418                                                 :debug-function df
1419                                                 :source-form-cache sfcache)
1420                              segments)))))
1421             (dotimes (fmap-index (length function-map))
1422               (let ((fmap-entry (aref function-map fmap-index)))
1423                 (etypecase fmap-entry
1424                   (integer
1425                    (add-seg last-offset (- fmap-entry last-offset)
1426                             last-debug-function)
1427                    (setf last-debug-function nil)
1428                    (setf last-offset fmap-entry))
1429                   (sb!c::compiled-debug-function
1430                    (setf last-debug-function
1431                          (sb!di::make-compiled-debug-function fmap-entry
1432                                                               code))))))
1433             (when last-debug-function
1434               (add-seg last-offset
1435                        (- (code-inst-area-length code) last-offset)
1436                        last-debug-function))))))
1437     (if (null segments)
1438         (make-code-segment code start-offs length)
1439         (nreverse segments))))
1440 \f
1441 #+nil
1442 (defun find-function-segment (fun)
1443   #!+sb-doc
1444   "Return the address of the instructions for function and its length.
1445   The length is computed using a heuristic, and so may not be accurate."
1446   (declare (type compiled-function fun))
1447   (let* ((code
1448           (fun-code fun))
1449          (fun-addr
1450           (- (sb!kernel:get-lisp-obj-address fun) sb!vm:function-pointer-type))
1451          (max-length
1452           (code-inst-area-length code))
1453          (upper-bound
1454           (+ (code-inst-area-address code) max-length)))
1455     (do ((some-fun (code-first-function code)
1456                    (fun-next some-fun)))
1457         ((null some-fun)
1458          (values fun-addr (- upper-bound fun-addr)))
1459       (let ((some-addr (fun-address some-fun)))
1460         (when (and (> some-addr fun-addr)
1461                    (< some-addr upper-bound))
1462           (setf upper-bound some-addr))))))
1463 \f
1464 (defun segment-overflow (segment dstate)
1465   #!+sb-doc
1466   "Returns two values:  the amount by which the last instruction in the
1467   segment goes past the end of the segment, and the offset of the end of the
1468   segment from the beginning of that instruction. If all instructions fit
1469   perfectly, this will return 0 and 0."
1470   (declare (type segment segment)
1471            (type disassem-state dstate))
1472   (let ((seglen (seg-length segment))
1473         (last-start 0))
1474     (map-segment-instructions #'(lambda (chunk inst)
1475                                   (declare (ignore chunk inst))
1476                                   (setf last-start (dstate-cur-offs dstate)))
1477                               segment
1478                               dstate)
1479     (values (- (dstate-cur-offs dstate) seglen)
1480             (- seglen last-start))))
1481
1482 (defun label-segments (seglist dstate)
1483   #!+sb-doc
1484   "Computes labels for all the memory segments in SEGLIST and adds them to
1485   DSTATE. It's important to call this function with all the segments you're
1486   interested in, so it can find references from one to another."
1487   (declare (type list seglist)
1488            (type disassem-state dstate))
1489   (dolist (seg seglist)
1490     (add-segment-labels seg dstate))
1491   ;; now remove any labels that don't point anywhere in the segments we have
1492   (setf (dstate-labels dstate)
1493         (remove-if #'(lambda (lab)
1494                        (not
1495                         (some #'(lambda (seg)
1496                                   (let ((start (seg-virtual-location seg)))
1497                                     (<= start
1498                                         (car lab)
1499                                         (+ start (seg-length seg)))))
1500                               seglist)))
1501                    (dstate-labels dstate))))
1502
1503 (defun disassemble-segment (segment stream dstate)
1504   #!+sb-doc
1505   "Disassemble the machine code instructions in SEGMENT to STREAM."
1506   (declare (type segment segment)
1507            (type stream stream)
1508            (type disassem-state dstate))
1509   (let ((*print-pretty* nil)) ; otherwise the pp conses hugely
1510     (number-labels dstate)
1511     (map-segment-instructions
1512      #'(lambda (chunk inst)
1513          (declare (type dchunk chunk) (type instruction inst))
1514          (let ((printer (inst-printer inst)))
1515            (when printer
1516              (funcall printer chunk inst stream dstate))))
1517      segment
1518      dstate
1519      stream)))
1520
1521 (defun disassemble-segments (segments stream dstate)
1522   #!+sb-doc
1523   "Disassemble the machine code instructions in each memory segment in
1524   SEGMENTS in turn to STREAM."
1525   (declare (type list segments)
1526            (type stream stream)
1527            (type disassem-state dstate))
1528   (unless (null segments)
1529     (let ((first (car segments))
1530           (last (car (last segments))))
1531       (set-location-printing-range dstate
1532                                   (seg-virtual-location first)
1533                                   (- (+ (seg-virtual-location last)
1534                                         (seg-length last))
1535                                      (seg-virtual-location first)))
1536       (setf (dstate-output-state dstate) :beginning)
1537       (dolist (seg segments)
1538         (disassemble-segment seg stream dstate)))))
1539 \f
1540 ;;;; top-level functions
1541
1542 (defun disassemble-function (function &key
1543                                       (stream *standard-output*)
1544                                       (use-labels t))
1545   #!+sb-doc
1546   "Disassemble the machine code instructions for FUNCTION."
1547   (declare (type compiled-function function)
1548            (type stream stream)
1549            (type (member t nil) use-labels))
1550   (let* ((dstate (make-dstate))
1551          (segments (get-function-segments function)))
1552     (when use-labels
1553       (label-segments segments dstate))
1554     (disassemble-segments segments stream dstate)))
1555
1556 (defun compile-function-lambda-expr (function)
1557   (declare (type function function))
1558   (multiple-value-bind (lambda closurep name)
1559       (function-lambda-expression function)
1560     (declare (ignore name))
1561     (when closurep
1562       (error "cannot compile a lexical closure"))
1563     (compile nil lambda)))
1564
1565 (defun compiled-function-or-lose (thing &optional (name thing))
1566   (cond ((or (symbolp thing)
1567              (and (listp thing)
1568                   (eq (car thing) 'setf)))
1569          (compiled-function-or-lose (fdefinition thing) thing))
1570         ((sb!eval:interpreted-function-p thing)
1571          (compile-function-lambda-expr thing))
1572         ((functionp thing)
1573          thing)
1574         ((and (listp thing)
1575               (eq (car thing) 'sb!impl::lambda))
1576          (compile nil thing))
1577         (t
1578          (error "can't make a compiled function from ~S" name))))
1579
1580 (defun disassemble (object &key
1581                            (stream *standard-output*)
1582                            (use-labels t))
1583   #!+sb-doc
1584   "Disassemble the machine code associated with OBJECT, which can be a
1585   function, a lambda expression, or a symbol with a function definition. If
1586   it is not already compiled, the compiler is called to produce something to
1587   disassemble."
1588   (declare (type (or function symbol cons) object)
1589            (type (or (member t) stream) stream)
1590            (type (member t nil) use-labels))
1591   (let ((fun (compiled-function-or-lose object)))
1592     (if (typep fun 'sb!kernel:byte-function)
1593         (sb!c:disassem-byte-fun fun)
1594         ;; we can't detect closures, so be careful
1595         (disassemble-function (fun-self fun)
1596                               :stream stream
1597                               :use-labels use-labels)))
1598   (values))
1599
1600 (defun disassemble-memory (address
1601                            length
1602                            &key
1603                            (stream *standard-output*)
1604                            code-component
1605                            (use-labels t))
1606   #!+sb-doc
1607   "Disassembles the given area of memory starting at ADDRESS and LENGTH long.
1608   Note that if CODE-COMPONENT is NIL and this memory could move during a GC,
1609   you'd better disable it around the call to this function."
1610   (declare (type (or address sb!sys:system-area-pointer) address)
1611            (type length length)
1612            (type stream stream)
1613            (type (or null sb!kernel:code-component) code-component)
1614            (type (member t nil) use-labels))
1615   (let* ((address
1616           (if (sb!sys:system-area-pointer-p address)
1617               (sb!sys:sap-int address)
1618               address))
1619          (dstate (make-dstate))
1620          (segments
1621           (if code-component
1622               (let ((code-offs
1623                      (- address
1624                         (sb!sys:sap-int
1625                          (sb!kernel:code-instructions code-component)))))
1626                 (when (or (< code-offs 0)
1627                           (> code-offs (code-inst-area-length code-component)))
1628                   (error "address ~X not in the code component ~S"
1629                          address code-component))
1630                 (get-code-segments code-component code-offs length))
1631               (list (make-memory-segment address length)))))
1632     (when use-labels
1633       (label-segments segments dstate))
1634     (disassemble-segments segments stream dstate)))
1635
1636 (defun disassemble-code-component (code-component &key
1637                                                   (stream *standard-output*)
1638                                                   (use-labels t))
1639   #!+sb-doc
1640   "Disassemble the machine code instructions associated with
1641   CODE-COMPONENT (this may include multiple entry points)."
1642   (declare (type (or null sb!kernel:code-component compiled-function)
1643                  code-component)
1644            (type stream stream)
1645            (type (member t nil) use-labels))
1646   (let* ((code-component
1647           (if (functionp code-component)
1648               (fun-code code-component)
1649               code-component))
1650          (dstate (make-dstate))
1651          (segments (get-code-segments code-component)))
1652     (when use-labels
1653       (label-segments segments dstate))
1654     (disassemble-segments segments stream dstate)))
1655 \f
1656 ;;; Code for making useful segments from arbitrary lists of code-blocks
1657
1658 ;;; The maximum size of an instruction -- this includes pseudo-instructions
1659 ;;; like error traps with their associated operands, so it should be big enough
1660 ;;; to include them (i.e. it's not just 4 on a risc machine!).
1661 (defconstant max-instruction-size 16)
1662
1663 (defun sap-to-vector (sap start end)
1664     (let* ((length (- end start))
1665            (result (make-array length :element-type '(unsigned-byte 8)))
1666            (sap (sb!sys:sap+ sap start)))
1667       (dotimes (i length)
1668         (setf (aref result i) (sb!sys:sap-ref-8 sap i)))
1669       result))
1670
1671 (defun add-block-segments (sap amount seglist location connecting-vec dstate)
1672   (declare (type list seglist)
1673            (type integer location)
1674            (type (or null (vector (unsigned-byte 8))) connecting-vec)
1675            (type disassem-state dstate))
1676   (flet ((addit (seg overflow)
1677            (let ((length (+ (seg-length seg) overflow)))
1678              (when (> length 0)
1679                (setf (seg-length seg) length)
1680                (incf location length)
1681                (push seg seglist)))))
1682     (let ((connecting-overflow 0))
1683       (when connecting-vec
1684         ;; tack on some of the new block to the old overflow vector
1685         (let* ((beginning-of-block-amount
1686                 (if sap (min max-instruction-size amount) 0))
1687                (connecting-vec
1688                 (if sap
1689                     (concatenate
1690                      '(vector (unsigned-byte 8))
1691                      connecting-vec
1692                      (sap-to-vector sap 0 beginning-of-block-amount))
1693                     connecting-vec)))
1694           (when (and (< (length connecting-vec) max-instruction-size)
1695                      (not (null sap)))
1696             (return-from add-block-segments
1697               ;; We want connecting vectors to be large enough to hold
1698               ;; any instruction, and since the current sap wasn't large
1699               ;; enough to do this (and is now entirely on the end of the
1700               ;; overflow-vector), just save it for next time.
1701               (values seglist location connecting-vec)))
1702           (when (> (length connecting-vec) 0)
1703             (let ((seg
1704                    (make-vector-segment connecting-vec
1705                                         0
1706                                         (- (length connecting-vec)
1707                                            beginning-of-block-amount)
1708                                         :virtual-location location)))
1709               (setf connecting-overflow (segment-overflow seg dstate))
1710               (addit seg connecting-overflow)))))
1711       (cond ((null sap)
1712              ;; Nothing more to add.
1713              (values seglist location nil))
1714             ((< (- amount connecting-overflow) max-instruction-size)
1715              ;; We can't create a segment with the minimum size
1716              ;; required for an instruction, so just keep on accumulating
1717              ;; in the overflow vector for the time-being.
1718              (values seglist
1719                      location
1720                      (sap-to-vector sap connecting-overflow amount)))
1721             (t
1722              ;; Put as much as we can into a new segment, and the rest
1723              ;; into the overflow-vector.
1724              (let* ((initial-length
1725                      (- amount connecting-overflow max-instruction-size))
1726                     (seg
1727                      (make-segment #'(lambda ()
1728                                        (sb!sys:sap+ sap connecting-overflow))
1729                                    initial-length
1730                                    :virtual-location location))
1731                     (overflow
1732                      (segment-overflow seg dstate)))
1733                (addit seg overflow)
1734                (values seglist
1735                        location
1736                        (sap-to-vector sap
1737                                       (+ connecting-overflow (seg-length seg))
1738                                       amount))))))))
1739 \f
1740 ;;;; code to disassemble assembler segments
1741
1742 (defun assem-segment-to-disassem-segments (assem-segment dstate)
1743   (declare (type sb!assem:segment assem-segment)
1744            (type disassem-state dstate))
1745   (let ((location 0)
1746         (disassem-segments nil)
1747         (connecting-vec nil))
1748     (error "stub: code not converted to new SEGMENT WHN 19990322" ; KLUDGE
1749            assem-segment) ; (to avoid "ASSEM-SEGMENT defined but never used")
1750     ;; old code, needs to be converted to use less-SAPpy ASSEM-SEGMENTs:
1751     #|(sb!assem:segment-map-output
1752      assem-segment
1753      #'(lambda (sap amount)
1754          (multiple-value-setq (disassem-segments location connecting-vec)
1755            (add-block-segments sap amount
1756                                disassem-segments location
1757                                connecting-vec
1758                                dstate))))|#
1759     (when connecting-vec
1760       (setf disassem-segments
1761             (add-block-segments nil nil
1762                                 disassem-segments location
1763                                 connecting-vec
1764                                 dstate)))
1765     (sort disassem-segments #'< :key #'seg-virtual-location)))
1766
1767 ;;; FIXME: I noticed that this is only called by #!+SB-SHOW code. It would
1768 ;;; be good to see whether this is the only caller of any other functions.
1769 #!+sb-show
1770 (defun disassemble-assem-segment (assem-segment stream)
1771   #!+sb-doc
1772   "Disassemble the machine code instructions associated with
1773   ASSEM-SEGMENT (of type assem:segment)."
1774   (declare (type sb!assem:segment assem-segment)
1775            (type stream stream))
1776   (let* ((dstate (make-dstate))
1777          (disassem-segments
1778           (assem-segment-to-disassem-segments assem-segment dstate)))
1779     (label-segments disassem-segments dstate)
1780     (disassemble-segments disassem-segments stream dstate)))
1781 \f
1782 ;;; routines to find things in the Lisp environment
1783
1784 (defconstant groked-symbol-slots
1785   (sort `((,sb!vm:symbol-value-slot . symbol-value)
1786           (,sb!vm:symbol-plist-slot . symbol-plist)
1787           (,sb!vm:symbol-name-slot . symbol-name)
1788           (,sb!vm:symbol-package-slot . symbol-package))
1789         #'<
1790         :key #'car)
1791   #!+sb-doc
1792   "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a
1793 symbol object that we know about.")
1794
1795 (defun grok-symbol-slot-ref (address)
1796   #!+sb-doc
1797   "Given ADDRESS, try and figure out if which slot of which symbol is being
1798   refered to. Of course we can just give up, so it's not a big deal...
1799   Returns two values, the symbol and the name of the access function of the
1800   slot."
1801   (declare (type address address))
1802   (if (not (aligned-p address sb!vm:word-bytes))
1803       (values nil nil)
1804       (do ((slots-tail groked-symbol-slots (cdr slots-tail)))
1805           ((null slots-tail)
1806            (values nil nil))
1807         (let* ((field (car slots-tail))
1808                (slot-offset (words-to-bytes (car field)))
1809                (maybe-symbol-addr (- address slot-offset))
1810                (maybe-symbol
1811                 (sb!kernel:make-lisp-obj
1812                  (+ maybe-symbol-addr sb!vm:other-pointer-type))))
1813           (when (symbolp maybe-symbol)
1814             (return (values maybe-symbol (cdr field))))))))
1815
1816 (defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil))
1817
1818 (defun grok-nil-indexed-symbol-slot-ref (byte-offset)
1819   #!+sb-doc
1820   "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which
1821   symbol is being refered to. Of course we can just give up, so it's not a big
1822   deal... Returns two values, the symbol and the access function."
1823   (declare (type offset byte-offset))
1824   (grok-symbol-slot-ref (+ *address-of-nil-object* byte-offset)))
1825
1826 (defun get-nil-indexed-object (byte-offset)
1827   #!+sb-doc
1828   "Returns the lisp object located BYTE-OFFSET from NIL."
1829   (declare (type offset byte-offset))
1830   (sb!kernel:make-lisp-obj (+ *address-of-nil-object* byte-offset)))
1831
1832 (defun get-code-constant (byte-offset dstate)
1833   #!+sb-doc
1834   "Returns two values; the lisp-object located at BYTE-OFFSET in the constant
1835   area of the code-object in the current segment and T, or NIL and NIL if
1836   there is no code-object in the current segment."
1837   (declare (type offset byte-offset)
1838            (type disassem-state dstate))
1839   (let ((code (seg-code (dstate-segment dstate))))
1840     (if code
1841         (values
1842          (sb!kernel:code-header-ref code
1843                                     (ash (+ byte-offset
1844                                             sb!vm:other-pointer-type)
1845                                          (- sb!vm:word-shift)))
1846          t)
1847         (values nil nil))))
1848
1849 (defvar *assembler-routines-by-addr* nil)
1850
1851 (defun find-assembler-routine (address)
1852   #!+sb-doc
1853   "Returns the name of the primitive lisp assembler routine located at
1854   ADDRESS, or NIL if there isn't one."
1855   (declare (type address address))
1856   (when (null *assembler-routines-by-addr*)
1857     (setf *assembler-routines-by-addr* (make-hash-table))
1858     (maphash #'(lambda (name address)
1859                  (setf (gethash address *assembler-routines-by-addr*) name))
1860              sb!kernel:*assembler-routines*))
1861   (gethash address *assembler-routines-by-addr*))
1862 \f
1863 ;;;; some handy function for machine-dependent code to use...
1864
1865 #!-sb-fluid (declaim (maybe-inline sap-ref-int read-suffix))
1866
1867 (defun sap-ref-int (sap offset length byte-order)
1868   (declare (type sb!sys:system-area-pointer sap)
1869            (type (unsigned-byte 16) offset)
1870            (type (member 1 2 4) length)
1871            (type (member :little-endian :big-endian) byte-order)
1872            (optimize (speed 3) (safety 0)))
1873   (ecase length
1874     (1 (sb!sys:sap-ref-8 sap offset))
1875     (2 (if (eq byte-order :big-endian)
1876            (+ (ash (sb!sys:sap-ref-8 sap offset) 8)
1877               (sb!sys:sap-ref-8 sap (+ offset 1)))
1878            (+ (ash (sb!sys:sap-ref-8 sap (+ offset 1)) 8)
1879               (sb!sys:sap-ref-8 sap offset))))
1880     (4 (if (eq byte-order :big-endian)
1881            (+ (ash (sb!sys:sap-ref-8 sap offset) 24)
1882               (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 16)
1883               (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 8)
1884               (sb!sys:sap-ref-8 sap (+ 3 offset)))
1885            (+ (sb!sys:sap-ref-8 sap offset)
1886               (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8)
1887               (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16)
1888               (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24))))))
1889
1890 (defun read-suffix (length dstate)
1891   (declare (type (member 8 16 32) length)
1892            (type disassem-state dstate)
1893            (optimize (speed 3) (safety 0)))
1894   (let ((length (ecase length (8 1) (16 2) (32 4))))
1895     (declare (type (unsigned-byte 3) length))
1896     (prog1
1897       (sap-ref-int (dstate-segment-sap dstate)
1898                    (dstate-next-offs dstate)
1899                    length
1900                    (dstate-byte-order dstate))
1901       (incf (dstate-next-offs dstate) length))))
1902 \f
1903 ;;;; optional routines to make notes about code
1904
1905 (defun note (note dstate)
1906   #!+sb-doc
1907   "Store NOTE (which can be either a string or a function with a single
1908   stream argument) to be printed as an end-of-line comment after the current
1909   instruction is disassembled."
1910   (declare (type (or string function) note)
1911            (type disassem-state dstate))
1912   (push note (dstate-notes dstate)))
1913
1914 (defun prin1-short (thing stream)
1915   (with-print-restrictions
1916     (prin1 thing stream)))
1917
1918 (defun prin1-quoted-short (thing stream)
1919   (if (self-evaluating-p thing)
1920       (prin1-short thing stream)
1921       (prin1-short `',thing stream)))
1922
1923 (defun note-code-constant (byte-offset dstate)
1924   #!+sb-doc
1925   "Store a note about the lisp constant located BYTE-OFFSET bytes from the
1926   current code-component, to be printed as an end-of-line comment after the
1927   current instruction is disassembled."
1928   (declare (type offset byte-offset)
1929            (type disassem-state dstate))
1930   (multiple-value-bind (const valid)
1931       (get-code-constant byte-offset dstate)
1932     (when valid
1933       (note #'(lambda (stream)
1934                 (prin1-quoted-short const stream))
1935             dstate))
1936     const))
1937
1938 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate)
1939   #!+sb-doc
1940   "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
1941   is a valid slot in a symbol, store a note describing which symbol and slot,
1942   to be printed as an end-of-line comment after the current instruction is
1943   disassembled. Returns non-NIL iff a note was recorded."
1944   (declare (type offset nil-byte-offset)
1945            (type disassem-state dstate))
1946   (multiple-value-bind (symbol access-fun)
1947       (grok-nil-indexed-symbol-slot-ref nil-byte-offset)
1948     (when access-fun
1949       (note #'(lambda (stream)
1950                 (prin1 (if (eq access-fun 'symbol-value)
1951                            symbol
1952                            `(,access-fun ',symbol))
1953                        stream))
1954             dstate))
1955     access-fun))
1956
1957 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate)
1958   #!+sb-doc
1959   "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
1960   is a valid lisp object, store a note describing which symbol and slot, to
1961   be printed as an end-of-line comment after the current instruction is
1962   disassembled. Returns non-NIL iff a note was recorded."
1963   (declare (type offset nil-byte-offset)
1964            (type disassem-state dstate))
1965   (let ((obj (get-nil-indexed-object nil-byte-offset)))
1966     (note #'(lambda (stream)
1967               (prin1-quoted-short obj stream))
1968           dstate)
1969     t))
1970
1971 (defun maybe-note-assembler-routine (address note-address-p dstate)
1972   #!+sb-doc
1973   "If ADDRESS is the address of a primitive assembler routine, store a note
1974   describing which one, to be printed as an end-of-line comment after the
1975   current instruction is disassembled. Returns non-NIL iff a note was
1976   recorded. If NOTE-ADDRESS-P is non-NIL, a note of the address is also made."
1977   (declare (type address address)
1978            (type disassem-state dstate))
1979   (let ((name (find-assembler-routine address)))
1980     (unless (null name)
1981       (note #'(lambda (stream)
1982                 (if NOTE-ADDRESS-P
1983                     (format stream "#X~8,'0x: ~S" address name)
1984                     (prin1 name stream)))
1985             dstate))
1986     name))
1987
1988 (defun maybe-note-single-storage-ref (offset sc-name dstate)
1989   #!+sb-doc
1990   "If there's a valid mapping from OFFSET in the storage class SC-NAME to a
1991   source variable, make a note of the source-variable name, to be printed as
1992   an end-of-line comment after the current instruction is disassembled.
1993   Returns non-NIL iff a note was recorded."
1994   (declare (type offset offset)
1995            (type symbol sc-name)
1996            (type disassem-state dstate))
1997   (let ((storage-location
1998          (find-valid-storage-location offset sc-name dstate)))
1999     (when storage-location
2000       (note #'(lambda (stream)
2001                 (princ (sb!di:debug-var-symbol
2002                         (aref (storage-info-debug-vars
2003                                (seg-storage-info (dstate-segment dstate)))
2004                               storage-location))
2005                        stream))
2006             dstate)
2007       t)))
2008
2009 (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate)
2010   #!+sb-doc
2011   "If there's a valid mapping from OFFSET in the storage-base called SB-NAME
2012   to a source variable, make a note equating ASSOC-WITH with the
2013   source-variable name, to be printed as an end-of-line comment after the
2014   current instruction is disassembled. Returns non-NIL iff a note was
2015   recorded."
2016   (declare (type offset offset)
2017            (type symbol sb-name)
2018            (type (or symbol string) assoc-with)
2019            (type disassem-state dstate))
2020   (let ((storage-location
2021          (find-valid-storage-location offset sb-name dstate)))
2022     (when storage-location
2023       (note #'(lambda (stream)
2024                 (format stream "~A = ~S"
2025                         assoc-with
2026                         (sb!di:debug-var-symbol
2027                          (aref (dstate-debug-vars dstate)
2028                                storage-location))
2029                        stream))
2030             dstate)
2031       t)))
2032 \f
2033 (defun get-internal-error-name (errnum)
2034   (car (svref sb!c:*backend-internal-errors* errnum)))
2035
2036 (defun get-sc-name (sc-offs)
2037   (sb!c::location-print-name
2038    ;; FIXME: This seems like an awful lot of computation just to get a name.
2039    ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
2040    ;; up a new object?
2041    (sb!c:make-random-tn :kind :normal
2042                         :sc (svref sb!c:*backend-sc-numbers*
2043                                    (sb!c:sc-offset-scn sc-offs))
2044                         :offset (sb!c:sc-offset-offset sc-offs))))
2045
2046 (defun handle-break-args (error-parse-fun stream dstate)
2047   #!+sb-doc
2048   "When called from an error break instruction's :DISASSEM-CONTROL (or
2049   :DISASSEM-PRINTER) function, will correctly deal with printing the
2050   arguments to the break.
2051
2052   ERROR-PARSE-FUN should be a function that accepts:
2053     1) a SYSTEM-AREA-POINTER
2054     2) a BYTE-OFFSET from the SAP to begin at
2055     3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
2056        the byte length of the arguments (to avoid unnecessary consing)
2057   It should read information from the SAP starting at BYTE-OFFSET, and return
2058   four values:
2059     1) the error number
2060     2) the total length, in bytes, of the information
2061     3) a list of SC-OFFSETs of the locations of the error parameters
2062     4) a list of the length (as read from the SAP), in bytes, of each of the
2063        return-values."
2064   (declare (type function error-parse-fun)
2065            (type (or null stream) stream)
2066            (type disassem-state dstate))
2067   (multiple-value-bind (errnum adjust sc-offsets lengths)
2068       (funcall error-parse-fun
2069                (dstate-segment-sap dstate)
2070                (dstate-next-offs dstate)
2071                (null stream))
2072     (when stream
2073       (setf (dstate-cur-offs dstate)
2074             (dstate-next-offs dstate))
2075       (flet ((emit-err-arg (note)
2076                (let ((num (pop lengths)))
2077                  (print-notes-and-newline stream dstate)
2078                  (print-current-address stream dstate)
2079                  (print-bytes num stream dstate)
2080                  (incf (dstate-cur-offs dstate) num)
2081                  (when note
2082                    (note note dstate)))))
2083         (emit-err-arg nil)
2084         (emit-err-arg (symbol-name (get-internal-error-name errnum)))
2085         (dolist (sc-offs sc-offsets)
2086           (emit-err-arg (get-sc-name sc-offs)))))
2087     (incf (dstate-next-offs dstate)
2088           adjust)))