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