src/compiler/debug-dump.lisp

   1 ;;;; stuff that creates debugger information from the compiler's
   2 ;;;; internal data structures
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!C")
  14
  15 (deftype byte-buffer () '(vector (unsigned-byte 8)))
  16 (defvar *byte-buffer*)
  17 (declaim (type byte-buffer *byte-buffer*))
  18 \f
  19 ;;;; debug blocks
  20
  21 (deftype location-kind ()
  22   '(member :unknown-return :known-return :internal-error :non-local-exit
  23            :block-start :call-site :single-value-return :non-local-entry))
  24
  25 ;;; The LOCATION-INFO structure holds the information what we need
  26 ;;; about locations which code generation decided were "interesting".
  27 (defstruct (location-info
  28             (:constructor make-location-info (kind label vop)))
  29   ;; The kind of location noted.
  30   (kind nil :type location-kind)
  31   ;; The label pointing to the interesting code location.
  32   (label nil :type (or label index null))
  33   ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
  34   (vop nil :type vop))
  35
  36 ;;; This is called during code generation in places where there is an
  37 ;;; "interesting" location: someplace where we are likely to end up
  38 ;;; in the debugger, and thus want debug info.
  39 (defun note-debug-location (vop label kind)
  40   (declare (type vop vop) (type (or label null) label)
  41            (type location-kind kind))
  42   (let ((location (make-location-info kind label vop)))
  43     (setf (ir2-block-locations (vop-block vop))
  44           (nconc (ir2-block-locations (vop-block vop))
  45                  (list location)))
  46     location))
  47
  48 #!-sb-fluid (declaim (inline ir2-block-environment))
  49 (defun ir2-block-environment (2block)
  50   (declare (type ir2-block 2block))
  51   (block-environment (ir2-block-block 2block)))
  52
  53 ;;; Given a local conflicts vector and an IR2 block to represent the
  54 ;;; set of live TNs, and the VAR-LOCS hash-table representing the
  55 ;;; variables dumped, compute a bit-vector representing the set of
  56 ;;; live variables. If the TN is environment-live, we only mark it as
  57 ;;; live when it is in scope at NODE.
  58 (defun compute-live-vars (live node block var-locs vop)
  59   (declare (type ir2-block block) (type local-tn-bit-vector live)
  60            (type hash-table var-locs) (type node node)
  61            (type (or vop null) vop))
  62   (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
  63                          :element-type 'bit
  64                          :initial-element 0))
  65         (spilled (gethash vop
  66                           (ir2-component-spilled-vops
  67                            (component-info *component-being-compiled*)))))
  68     (do-live-tns (tn live block)
  69       (let ((leaf (tn-leaf tn)))
  70         (when (and (lambda-var-p leaf)
  71                    (or (not (member (tn-kind tn)
  72                                     '(:environment :debug-environment)))
  73                        (rassoc leaf (lexenv-variables (node-lexenv node))))
  74                    (or (null spilled)
  75                        (not (member tn spilled))))
  76           (let ((num (gethash leaf var-locs)))
  77             (when num
  78               (setf (sbit res num) 1))))))
  79     res))
  80
  81 ;;; The PC for the location most recently dumped.
  82 (defvar *previous-location*)
  83 (declaim (type index *previous-location*))
  84
  85 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
  86 ;;; the code/source map and live info. If true, VOP is the VOP
  87 ;;; associated with this location, for use in determining whether TNs
  88 ;;; are spilled.
  89 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
  90   (declare (type node node) (type ir2-block block)
  91            (type local-tn-bit-vector live)
  92            (type (or label index) label)
  93            (type location-kind kind) (type (or index null) tlf-num)
  94            (type hash-table var-locs) (type (or vop null) vop))
  95
  96   (vector-push-extend
  97    (dpb (position-or-lose kind *compiled-code-location-kinds*)
  98         compiled-code-location-kind-byte
  99         0)
 100    *byte-buffer*)
 101
 102   (let ((loc (if (target-fixnump label) label (label-position label))))
 103     (write-var-integer (- loc *previous-location*) *byte-buffer*)
 104     (setq *previous-location* loc))
 105
 106   (let ((path (node-source-path node)))
 107     (unless tlf-num
 108       (write-var-integer (source-path-tlf-number path) *byte-buffer*))
 109     (write-var-integer (source-path-form-number path) *byte-buffer*))
 110
 111   (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
 112                            *byte-buffer*)
 113
 114   (values))
 115
 116 ;;; Extract context info from a Location-Info structure and use it to
 117 ;;; dump a compiled code-location.
 118 (defun dump-location-from-info (loc tlf-num var-locs)
 119   (declare (type location-info loc) (type (or index null) tlf-num)
 120            (type hash-table var-locs))
 121   (let ((vop (location-info-vop loc)))
 122     (dump-1-location (vop-node vop)
 123                      (vop-block vop)
 124                      (location-info-kind loc)
 125                      tlf-num
 126                      (location-info-label loc)
 127                      (vop-save-set vop)
 128                      var-locs
 129                      vop))
 130   (values))
 131
 132 ;;; Scan all the blocks, determining if all locations are in the same
 133 ;;; TLF, and returning it or NIL.
 134 (defun find-tlf-number (fun)
 135   (declare (type clambda fun))
 136   (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
 137     (declare (type (or index null) res))
 138     (do-environment-ir2-blocks (2block (lambda-environment fun))
 139       (let ((block (ir2-block-block 2block)))
 140         (when (eq (block-info block) 2block)
 141           (unless (eql (source-path-tlf-number
 142                         (node-source-path
 143                          (continuation-next
 144                           (block-start block))))
 145                        res)
 146             (setq res nil)))
 147
 148         (dolist (loc (ir2-block-locations 2block))
 149           (unless (eql (source-path-tlf-number
 150                         (node-source-path
 151                          (vop-node (location-info-vop loc))))
 152                        res)
 153             (setq res nil)))))
 154     res))
 155
 156 ;;; Dump out the number of locations and the locations for Block.
 157 (defun dump-block-locations (block locations tlf-num var-locs)
 158   (declare (type cblock block) (list locations))
 159   (if (and locations
 160            (eq (location-info-kind (first locations))
 161                :non-local-entry))
 162       (write-var-integer (length locations) *byte-buffer*)
 163       (let ((2block (block-info block)))
 164         (write-var-integer (+ (length locations) 1) *byte-buffer*)
 165         (dump-1-location (continuation-next (block-start block))
 166                          2block :block-start tlf-num
 167                          (ir2-block-%label 2block)
 168                          (ir2-block-live-out 2block)
 169                          var-locs
 170                          nil)))
 171   (dolist (loc locations)
 172     (dump-location-from-info loc tlf-num var-locs))
 173   (values))
 174
 175 ;;; Dump the successors of Block, being careful not to fly into space on
 176 ;;; weird successors.
 177 (defun dump-block-successors (block env)
 178   (declare (type cblock block) (type environment env))
 179   (let* ((tail (component-tail (block-component block)))
 180          (succ (block-succ block))
 181          (valid-succ
 182           (if (and succ
 183                    (or (eq (car succ) tail)
 184                        (not (eq (block-environment (car succ)) env))))
 185               ()
 186               succ)))
 187     (vector-push-extend
 188      (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
 189      *byte-buffer*)
 190     (let ((base (block-number
 191                  (node-block
 192                   (lambda-bind (environment-function env))))))
 193       (dolist (b valid-succ)
 194         (write-var-integer
 195          (the index (- (block-number b) base))
 196          *byte-buffer*))))
 197   (values))
 198
 199 ;;; Return a vector and an integer (or null) suitable for use as the
 200 ;;; BLOCKS and TLF-NUMBER in Fun's debug-function. This requires two
 201 ;;; passes to compute:
 202 ;;; -- Scan all blocks, dumping the header and successors followed
 203 ;;;    by all the non-elsewhere locations.
 204 ;;; -- Dump the elsewhere block header and all the elsewhere
 205 ;;;    locations (if any.)
 206 (defun compute-debug-blocks (fun var-locs)
 207   (declare (type clambda fun) (type hash-table var-locs))
 208   (setf (fill-pointer *byte-buffer*) 0)
 209   (let ((*previous-location* 0)
 210         (tlf-num (find-tlf-number fun))
 211         (env (lambda-environment fun))
 212         (prev-locs nil)
 213         (prev-block nil))
 214     (collect ((elsewhere))
 215       (do-environment-ir2-blocks (2block env)
 216         (let ((block (ir2-block-block 2block)))
 217           (when (eq (block-info block) 2block)
 218             (when prev-block
 219               (dump-block-locations prev-block prev-locs tlf-num var-locs))
 220             (setq prev-block block  prev-locs ())
 221             (dump-block-successors block env)))
 222
 223         (collect ((here prev-locs))
 224           (dolist (loc (ir2-block-locations 2block))
 225             (if (label-elsewhere-p (location-info-label loc))
 226                 (elsewhere loc)
 227                 (here loc)))
 228           (setq prev-locs (here))))
 229
 230       (dump-block-locations prev-block prev-locs tlf-num var-locs)
 231
 232       (when (elsewhere)
 233         (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
 234         (write-var-integer (length (elsewhere)) *byte-buffer*)
 235         (dolist (loc (elsewhere))
 236           (dump-location-from-info loc tlf-num var-locs))))
 237
 238     (values (copy-seq *byte-buffer*) tlf-num)))
 239 \f
 240 ;;; Return a list of DEBUG-SOURCE structures containing information
 241 ;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always
 242 ;;; dump the Start-Positions, since it is too hard figure out whether
 243 ;;; we need them or not.
 244 (defun debug-source-for-info (info)
 245   (declare (type source-info info))
 246   (assert (not (source-info-current-file info)))
 247   (mapcar #'(lambda (x)
 248               (let ((res (make-debug-source
 249                           :from :file
 250                           :comment (file-info-comment x)
 251                           :created (file-info-write-date x)
 252                           :compiled (source-info-start-time info)
 253                           :source-root (file-info-source-root x)
 254                           :start-positions
 255                           (unless (eq *byte-compile* 't)
 256                             (coerce-to-smallest-eltype
 257                              (file-info-positions x)))))
 258                     (name (file-info-name x)))
 259                 (etypecase name
 260                   ((member :lisp)
 261                    (setf (debug-source-from res) name)
 262                    (setf (debug-source-name res)
 263                          (coerce (file-info-forms x) 'simple-vector)))
 264                   (pathname
 265                    (let* ((untruename (file-info-untruename x))
 266                           (dir (pathname-directory untruename)))
 267                      (setf (debug-source-name res)
 268                            (namestring
 269                             (if (and dir (eq (first dir) :absolute))
 270                                 untruename
 271                                 name))))))
 272                 res))
 273           (source-info-files info)))
 274
 275 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
 276 ;;; possible. Ordinarily we coerce it to the smallest specialized
 277 ;;; vector we can. However, we also have a special hack for
 278 ;;; cross-compiling at bootstrap time, when arbitrarily-specialized
 279 ;;; aren't fully supported: in that case, we coerce it only to a
 280 ;;; vector whose element size is an integer multiple of output byte
 281 ;;; size.
 282 (defun coerce-to-smallest-eltype (seq)
 283   (let ((maxoid #-sb-xc-host 0
 284                 ;; An initial value value of 255 prevents us from
 285                 ;; specializing the array to anything smaller than
 286                 ;; (UNSIGNED-BYTE 8), which keeps the cross-compiler's
 287                 ;; portable specialized array output functions happy.
 288                 #+sb-xc-host 255))
 289     (flet ((frob (x)
 290              (if (typep x 'unsigned-byte)
 291                (when (>= x maxoid)
 292                  (setf maxoid x))
 293                (return-from coerce-to-smallest-eltype
 294                  (coerce seq 'simple-vector)))))
 295       (if (listp seq)
 296         (dolist (i seq)
 297           (frob i))
 298         (dovector (i seq)
 299           (frob i)))
 300       (coerce seq `(simple-array (integer 0 ,maxoid) (*))))))
 301 \f
 302 ;;;; variables
 303
 304 ;;; Return a SC-OFFSET describing TN's location.
 305 (defun tn-sc-offset (tn)
 306   (declare (type tn tn))
 307   (make-sc-offset (sc-number (tn-sc tn))
 308                   (tn-offset tn)))
 309
 310 ;;; Dump info to represent Var's location being TN. ID is an integer
 311 ;;; that makes Var's name unique in the function. Buffer is the vector
 312 ;;; we stick the result in. If Minimal is true, we suppress name
 313 ;;; dumping, and set the minimal flag.
 314 ;;;
 315 ;;; The debug-var is only marked as always-live if the TN is
 316 ;;; environment live and is an argument. If a :debug-environment TN,
 317 ;;; then we also exclude set variables, since the variable is not
 318 ;;; guaranteed to be live everywhere in that case.
 319 (defun dump-1-variable (fun var tn id minimal buffer)
 320   (declare (type lambda-var var) (type (or tn null) tn) (type index id)
 321            (type clambda fun))
 322   (let* ((name (leaf-name var))
 323          (save-tn (and tn (tn-save-tn tn)))
 324          (kind (and tn (tn-kind tn)))
 325          (flags 0))
 326     (declare (type index flags))
 327     (when minimal
 328       (setq flags (logior flags compiled-debug-var-minimal-p))
 329       (unless tn
 330         (setq flags (logior flags compiled-debug-var-deleted-p))))
 331     (when (and (or (eq kind :environment)
 332                    (and (eq kind :debug-environment)
 333                         (null (basic-var-sets var))))
 334                (not (gethash tn (ir2-component-spilled-tns
 335                                  (component-info *component-being-compiled*))))
 336                (eq (lambda-var-home var) fun))
 337       (setq flags (logior flags compiled-debug-var-environment-live)))
 338     (when save-tn
 339       (setq flags (logior flags compiled-debug-var-save-loc-p)))
 340     (unless (or (zerop id) minimal)
 341       (setq flags (logior flags compiled-debug-var-id-p)))
 342     (vector-push-extend flags buffer)
 343     (unless minimal
 344       (vector-push-extend name buffer)
 345       (unless (zerop id)
 346         (vector-push-extend id buffer)))
 347     (if tn
 348         (vector-push-extend (tn-sc-offset tn) buffer)
 349         (assert minimal))
 350     (when save-tn
 351       (vector-push-extend (tn-sc-offset save-tn) buffer)))
 352   (values))
 353
 354 ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES
 355 ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
 356 ;;; hashtable in which we enter the translation from LAMBDA-VARS to
 357 ;;; the relative position of that variable's location in the resulting
 358 ;;; vector.
 359 (defun compute-variables (fun level var-locs)
 360   (declare (type clambda fun) (type hash-table var-locs))
 361   (collect ((vars))
 362     (labels ((frob-leaf (leaf tn gensym-p)
 363                (let ((name (leaf-name leaf)))
 364                  (when (and name (leaf-refs leaf) (tn-offset tn)
 365                             (or gensym-p (symbol-package name)))
 366                    (vars (cons leaf tn)))))
 367              (frob-lambda (x gensym-p)
 368                (dolist (leaf (lambda-vars x))
 369                  (frob-leaf leaf (leaf-info leaf) gensym-p))))
 370       (frob-lambda fun t)
 371       (when (>= level 2)
 372         (dolist (x (ir2-environment-environment
 373                     (environment-info (lambda-environment fun))))
 374           (let ((thing (car x)))
 375             (when (lambda-var-p thing)
 376               (frob-leaf thing (cdr x) (= level 3)))))
 377
 378         (dolist (let (lambda-lets fun))
 379           (frob-lambda let (= level 3)))))
 380
 381     (let ((sorted (sort (vars) #'string<
 382                         :key #'(lambda (x)
 383                                  (symbol-name (leaf-name (car x))))))
 384           (prev-name nil)
 385           (id 0)
 386           (i 0)
 387           (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
 388       (declare (type (or simple-string null) prev-name)
 389                (type index id i))
 390       (dolist (x sorted)
 391         (let* ((var (car x))
 392                (name (symbol-name (leaf-name var))))
 393           (cond ((and prev-name (string= prev-name name))
 394                  (incf id))
 395                 (t
 396                  (setq id 0  prev-name name)))
 397           (dump-1-variable fun var (cdr x) id nil buffer)
 398           (setf (gethash var var-locs) i))
 399         (incf i))
 400       (coerce buffer 'simple-vector))))
 401
 402 ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of
 403 ;;; FUN, representing the arguments to FUN in minimal variable format.
 404 (defun compute-minimal-variables (fun)
 405   (declare (type clambda fun))
 406   (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
 407     (dolist (var (lambda-vars fun))
 408       (dump-1-variable fun var (leaf-info var) 0 t buffer))
 409     (coerce buffer 'simple-vector)))
 410
 411 ;;; Return Var's relative position in the function's variables (determined
 412 ;;; from the Var-Locs hashtable.)  If Var is deleted, then return DELETED.
 413 (defun debug-location-for (var var-locs)
 414   (declare (type lambda-var var) (type hash-table var-locs))
 415   (let ((res (gethash var var-locs)))
 416     (cond (res)
 417           (t
 418            (assert (or (null (leaf-refs var))
 419                        (not (tn-offset (leaf-info var)))))
 420            'deleted))))
 421 \f
 422 ;;;; arguments/returns
 423
 424 ;;; Return a vector to be used as the
 425 ;;; COMPILED-DEBUG-FUNCTION-ARGUMENTS for Fun. If fun is the
 426 ;;; MAIN-ENTRY for an optional dispatch, then look at the ARGLIST to
 427 ;;; determine the syntax, otherwise pretend all arguments are fixed.
 428 ;;;
 429 ;;; ### This assumption breaks down in EPs other than the main-entry,
 430 ;;; since they may or may not have supplied-p vars, etc.
 431 (defun compute-arguments (fun var-locs)
 432   (declare (type clambda fun) (type hash-table var-locs))
 433   (collect ((res))
 434     (let ((od (lambda-optional-dispatch fun)))
 435       (if (and od (eq (optional-dispatch-main-entry od) fun))
 436           (let ((actual-vars (lambda-vars fun))
 437                 (saw-optional nil))
 438             (dolist (arg (optional-dispatch-arglist od))
 439               (let ((info (lambda-var-arg-info arg))
 440                     (actual (pop actual-vars)))
 441                 (cond (info
 442                        (case (arg-info-kind info)
 443                          (:keyword
 444                           (res (arg-info-keyword info)))
 445                          (:rest
 446                           (res 'rest-arg))
 447                          (:more-context
 448                           (res 'more-arg))
 449                          (:optional
 450                           (unless saw-optional
 451                             (res 'optional-args)
 452                             (setq saw-optional t))))
 453                        (res (debug-location-for actual var-locs))
 454                        (when (arg-info-supplied-p info)
 455                          (res 'supplied-p)
 456                          (res (debug-location-for (pop actual-vars) var-locs))))
 457                       (t
 458                        (res (debug-location-for actual var-locs)))))))
 459           (dolist (var (lambda-vars fun))
 460             (res (debug-location-for var var-locs)))))
 461
 462     (coerce-to-smallest-eltype (res))))
 463
 464 ;;; Return a vector of SC offsets describing Fun's return locations.
 465 ;;; (Must be known values return...)
 466 (defun compute-debug-returns (fun)
 467   (coerce-to-smallest-eltype
 468    (mapcar #'(lambda (loc)
 469                (tn-sc-offset loc))
 470            (return-info-locations (tail-set-info (lambda-tail-set fun))))))
 471 \f
 472 ;;;; debug functions
 473
 474 ;;; Return a C-D-F structure with all the mandatory slots filled in.
 475 (defun dfun-from-fun (fun)
 476   (declare (type clambda fun))
 477   (let* ((2env (environment-info (lambda-environment fun)))
 478          (dispatch (lambda-optional-dispatch fun))
 479          (main-p (and dispatch
 480                       (eq fun (optional-dispatch-main-entry dispatch)))))
 481     (make-compiled-debug-function
 482      :name (cond ((leaf-name fun))
 483                  ((let ((ef (functional-entry-function
 484                              fun)))
 485                     (and ef (leaf-name ef))))
 486                  ((and main-p (leaf-name dispatch)))
 487                  (t
 488                   (component-name
 489                    (block-component (node-block (lambda-bind fun))))))
 490      :kind (if main-p nil (functional-kind fun))
 491      :return-pc (tn-sc-offset (ir2-environment-return-pc 2env))
 492      :old-fp (tn-sc-offset (ir2-environment-old-fp 2env))
 493      :start-pc (label-position (ir2-environment-environment-start 2env))
 494      :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env)))))
 495
 496 ;;; Return a complete C-D-F structure for Fun. This involves
 497 ;;; determining the DEBUG-INFO level and filling in optional slots as
 498 ;;; appropriate.
 499 (defun compute-1-debug-function (fun var-locs)
 500   (declare (type clambda fun) (type hash-table var-locs))
 501   (let* ((dfun (dfun-from-fun fun))
 502          (actual-level
 503           (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
 504          (level (if #!+sb-dyncount *collect-dynamic-statistics*
 505                     #!-sb-dyncount nil
 506                     (max actual-level 2)
 507                     actual-level)))
 508     (cond ((zerop level))
 509           ((and (<= level 1)
 510                 (let ((od (lambda-optional-dispatch fun)))
 511                   (or (not od)
 512                       (not (eq (optional-dispatch-main-entry od) fun)))))
 513            (setf (compiled-debug-function-variables dfun)
 514                  (compute-minimal-variables fun))
 515            (setf (compiled-debug-function-arguments dfun) :minimal))
 516           (t
 517            (setf (compiled-debug-function-variables dfun)
 518                  (compute-variables fun level var-locs))
 519            (setf (compiled-debug-function-arguments dfun)
 520                  (compute-arguments fun var-locs))))
 521
 522     (when (>= level 2)
 523       (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs)
 524         (setf (compiled-debug-function-tlf-number dfun) tlf-num)
 525         (setf (compiled-debug-function-blocks dfun) blocks)))
 526
 527     (if (external-entry-point-p fun)
 528         (setf (compiled-debug-function-returns dfun) :standard)
 529         (let ((info (tail-set-info (lambda-tail-set fun))))
 530           (when info
 531             (cond ((eq (return-info-kind info) :unknown)
 532                    (setf (compiled-debug-function-returns dfun)
 533                          :standard))
 534                   ((/= level 0)
 535                    (setf (compiled-debug-function-returns dfun)
 536                          (compute-debug-returns fun)))))))
 537     dfun))
 538 \f
 539 ;;;; minimal debug functions
 540
 541 ;;; Return true if DFUN can be represented as a minimal debug
 542 ;;; function. DFUN is a cons (<start offset> . C-D-F).
 543 (defun debug-function-minimal-p (dfun)
 544   (declare (type cons dfun))
 545   (let ((dfun (cdr dfun)))
 546     (and (member (compiled-debug-function-arguments dfun) '(:minimal nil))
 547          (null (compiled-debug-function-blocks dfun)))))
 548
 549 ;;; Dump a packed binary representation of a DFUN into *BYTE-BUFFER*.
 550 ;;; PREV-START and START are the byte offsets in the code where the
 551 ;;; previous function started and where this one starts.
 552 ;;; PREV-ELSEWHERE is the previous function's elsewhere PC.
 553 (defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere)
 554   (declare (type compiled-debug-function dfun)
 555            (type index prev-start start prev-elsewhere))
 556   (let* ((name (compiled-debug-function-name dfun))
 557          (setf-p (and (consp name) (eq (car name) 'setf)
 558                       (consp (cdr name)) (symbolp (cadr name))))
 559          (base-name (if setf-p (cadr name) name))
 560          (pkg (when (symbolp base-name)
 561                 (symbol-package base-name)))
 562          (name-rep
 563           (cond ((stringp base-name)
 564                  minimal-debug-function-name-component)
 565                 ((not pkg)
 566                  minimal-debug-function-name-uninterned)
 567                 ((eq pkg *package*)
 568                  minimal-debug-function-name-symbol)
 569                 (t
 570                  minimal-debug-function-name-packaged))))
 571     (assert (or (atom name) setf-p))
 572     (let ((options 0))
 573       (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
 574       (setf (ldb minimal-debug-function-kind-byte options)
 575             (position-or-lose (compiled-debug-function-kind dfun)
 576                               *minimal-debug-function-kinds*))
 577       (setf (ldb minimal-debug-function-returns-byte options)
 578             (etypecase (compiled-debug-function-returns dfun)
 579               ((member :standard) minimal-debug-function-returns-standard)
 580               ((member :fixed) minimal-debug-function-returns-fixed)
 581               (vector minimal-debug-function-returns-specified)))
 582       (vector-push-extend options *byte-buffer*))
 583
 584     (let ((flags 0))
 585       (when setf-p
 586         (setq flags (logior flags minimal-debug-function-setf-bit)))
 587       (when (compiled-debug-function-nfp dfun)
 588         (setq flags (logior flags minimal-debug-function-nfp-bit)))
 589       (when (compiled-debug-function-variables dfun)
 590         (setq flags (logior flags minimal-debug-function-variables-bit)))
 591       (vector-push-extend flags *byte-buffer*))
 592
 593     (when (eql name-rep minimal-debug-function-name-packaged)
 594       (write-var-string (package-name pkg) *byte-buffer*))
 595     (unless (stringp base-name)
 596       (write-var-string (symbol-name base-name) *byte-buffer*))
 597
 598     (let ((vars (compiled-debug-function-variables dfun)))
 599       (when vars
 600         (let ((len (length vars)))
 601           (write-var-integer len *byte-buffer*)
 602           (dotimes (i len)
 603             (vector-push-extend (aref vars i) *byte-buffer*)))))
 604
 605     (let ((returns (compiled-debug-function-returns dfun)))
 606       (when (vectorp returns)
 607         (let ((len (length returns)))
 608           (write-var-integer len *byte-buffer*)
 609           (dotimes (i len)
 610             (write-var-integer (aref returns i) *byte-buffer*)))))
 611
 612     (write-var-integer (compiled-debug-function-return-pc dfun)
 613                        *byte-buffer*)
 614     (write-var-integer (compiled-debug-function-old-fp dfun)
 615                        *byte-buffer*)
 616     (when (compiled-debug-function-nfp dfun)
 617       (write-var-integer (compiled-debug-function-nfp dfun)
 618                          *byte-buffer*))
 619     (write-var-integer (- start prev-start) *byte-buffer*)
 620     (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
 621                        *byte-buffer*)
 622     (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
 623                           prev-elsewhere)
 624                        *byte-buffer*)))
 625
 626 ;;; Return a byte-vector holding all the debug functions for a
 627 ;;; component in the packed binary minimal-debug-function format.
 628 (defun compute-minimal-debug-functions (dfuns)
 629   (declare (list dfuns))
 630   (setf (fill-pointer *byte-buffer*) 0)
 631   (let ((prev-start 0)
 632         (prev-elsewhere 0))
 633     (dolist (dfun dfuns)
 634       (let ((start (car dfun))
 635             (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun))))
 636         (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
 637         (setq prev-start start  prev-elsewhere elsewhere))))
 638   (copy-seq *byte-buffer*))
 639 \f
 640 ;;;; full component dumping
 641
 642 ;;; Compute the full form (simple-vector) function map.
 643 (defun compute-debug-function-map (sorted)
 644   (declare (list sorted))
 645   (let* ((len (1- (* (length sorted) 2)))
 646          (funs-vec (make-array len)))
 647     (do ((i -1 (+ i 2))
 648          (sorted sorted (cdr sorted)))
 649         ((= i len))
 650       (declare (fixnum i))
 651       (let ((dfun (car sorted)))
 652         (unless (minusp i)
 653           (setf (svref funs-vec i) (car dfun)))
 654         (setf (svref funs-vec (1+ i)) (cdr dfun))))
 655     funs-vec))
 656
 657 ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
 658 ;;; called after assembly so that source map information is available.
 659 (defun debug-info-for-component (component)
 660   (declare (type component component))
 661   (collect ((dfuns))
 662     (let ((var-locs (make-hash-table :test 'eq))
 663           ;; FIXME: What is *BYTE-BUFFER* for? Has it become dead code
 664           ;; now that we no longer use minimal-debug-function
 665           ;; representation?
 666           (*byte-buffer* (make-array 10
 667                                      :element-type '(unsigned-byte 8)
 668                                      :fill-pointer 0
 669                                      :adjustable t)))
 670       (dolist (fun (component-lambdas component))
 671         (clrhash var-locs)
 672         (dfuns (cons (label-position
 673                       (block-label (node-block (lambda-bind fun))))
 674                      (compute-1-debug-function fun var-locs))))
 675       (let* ((sorted (sort (dfuns) #'< :key #'car))
 676              ;; FIXME: CMU CL had
 677              ;;    (IF (EVERY #'DEBUG-FUNCTION-MINIMAL-P SORTED)
 678              ;;        (COMPUTE-MINIMAL-DEBUG-FUNCTIONS SORTED)
 679              ;;        (COMPUTE-DEBUG-FUNCTION-MAP SORTED))
 680              ;; here. We've gotten rid of the minimal-debug-function
 681              ;; case in SBCL because the minimal representation
 682              ;; couldn't be made to transform properly under package
 683              ;; renaming. Now that that case is gone, a lot of code is
 684              ;; dead, and once everything is known to work, the dead
 685              ;; code should be deleted.
 686              (function-map (compute-debug-function-map sorted)))
 687         (make-compiled-debug-info :name (component-name component)
 688                                   :function-map function-map)))))
 689 \f
 690 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
 691 ;;; BITS must be evenly divisible by eight.
 692 (defun write-packed-bit-vector (bits byte-buffer)
 693   (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
 694   (multiple-value-bind (initial step done)
 695       (ecase *backend-byte-order*
 696         (:little-endian (values 0  1  8))
 697         (:big-endian    (values 7 -1 -1)))
 698     (let ((shift initial)
 699           (byte 0))
 700       (dotimes (i (length bits))
 701         (let ((int (aref bits i)))
 702           (setf byte (logior byte (ash int shift)))
 703           (incf shift step))
 704         (when (= shift done)
 705           (vector-push-extend byte byte-buffer)
 706           (setf shift initial
 707                 byte 0)))
 708       (unless (= shift initial)
 709         (vector-push-extend byte byte-buffer))))
 710   (values))