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