src/compiler/target-disassem.lisp

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