src/compiler/target-disassem.lisp

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