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             (:copier nil))
  30   ;; The kind of location noted.
  31   (kind nil :type location-kind)
  32   ;; The label pointing to the interesting code location.
  33   (label nil :type (or label index null))
  34   ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
  35   (vop nil :type vop))
  36
  37 ;;; This is called during code generation in places where there is an
  38 ;;; "interesting" location: someplace where we are likely to end up
  39 ;;; in the debugger, and thus want debug info.
  40 (defun note-debug-location (vop label kind)
  41   (declare (type vop vop) (type (or label null) label)
  42            (type location-kind kind))
  43   (let ((location (make-location-info kind label vop)))
  44     (setf (ir2-block-locations (vop-block vop))
  45           (nconc (ir2-block-locations (vop-block vop))
  46                  (list location)))
  47     location))
  48
  49 #!-sb-fluid (declaim (inline ir2-block-physenv))
  50 (defun ir2-block-physenv (2block)
  51   (declare (type ir2-block 2block))
  52   (block-physenv (ir2-block-block 2block)))
  53
  54 ;;; Given a local conflicts vector and an IR2 block to represent the
  55 ;;; set of live TNs, and the VAR-LOCS hash-table representing the
  56 ;;; variables dumped, compute a bit-vector representing the set of
  57 ;;; live variables. If the TN is environment-live, we only mark it as
  58 ;;; live when it is in scope at NODE.
  59 (defun compute-live-vars (live node block var-locs vop)
  60   (declare (type ir2-block block) (type local-tn-bit-vector live)
  61            (type hash-table var-locs) (type node node)
  62            (type (or vop null) vop))
  63   (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
  64                          :element-type 'bit
  65                          :initial-element 0))
  66         (spilled (gethash vop
  67                           (ir2-component-spilled-vops
  68                            (component-info *component-being-compiled*)))))
  69     (do-live-tns (tn live block)
  70       (let ((leaf (tn-leaf tn)))
  71         (when (and (lambda-var-p leaf)
  72                    (or (not (member (tn-kind tn)
  73                                     '(:environment :debug-environment)))
  74                        (rassoc leaf (lexenv-vars (node-lexenv node))))
  75                    (or (null spilled)
  76                        (not (member tn spilled))))
  77           (let ((num (gethash leaf var-locs)))
  78             (when num
  79               (setf (sbit res num) 1))))))
  80     res))
  81
  82 ;;; The PC for the location most recently dumped.
  83 (defvar *previous-location*)
  84 (declaim (type index *previous-location*))
  85
  86 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
  87 ;;; the code/source map and live info. If true, VOP is the VOP
  88 ;;; associated with this location, for use in determining whether TNs
  89 ;;; are spilled.
  90 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
  91   (declare (type node node) (type ir2-block block)
  92            (type local-tn-bit-vector live)
  93            (type (or label index) label)
  94            (type location-kind kind) (type (or index null) tlf-num)
  95            (type hash-table var-locs) (type (or vop null) vop))
  96
  97   (vector-push-extend
  98    (dpb (position-or-lose kind *compiled-code-location-kinds*)
  99         compiled-code-location-kind-byte
 100         0)
 101    *byte-buffer*)
 102
 103   (let ((loc (if (fixnump label) label (label-position label))))
 104     (write-var-integer (- loc *previous-location*) *byte-buffer*)
 105     (setq *previous-location* loc))
 106
 107   (let ((path (node-source-path node)))
 108     (unless tlf-num
 109       (write-var-integer (source-path-tlf-number path) *byte-buffer*))
 110     (write-var-integer (source-path-form-number path) *byte-buffer*))
 111
 112   (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
 113                            *byte-buffer*)
 114
 115   (values))
 116
 117 ;;; Extract context info from a Location-Info structure and use it to
 118 ;;; dump a compiled code-location.
 119 (defun dump-location-from-info (loc tlf-num var-locs)
 120   (declare (type location-info loc) (type (or index null) tlf-num)
 121            (type hash-table var-locs))
 122   (let ((vop (location-info-vop loc)))
 123     (dump-1-location (vop-node vop)
 124                      (vop-block vop)
 125                      (location-info-kind loc)
 126                      tlf-num
 127                      (location-info-label loc)
 128                      (vop-save-set vop)
 129                      var-locs
 130                      vop))
 131   (values))
 132
 133 ;;; Scan all the blocks, determining if all locations are in the same
 134 ;;; TLF, and returning it or NIL.
 135 (defun find-tlf-number (fun)
 136   (declare (type clambda fun))
 137   (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
 138     (declare (type (or index null) res))
 139     (do-physenv-ir2-blocks (2block (lambda-physenv fun))
 140       (let ((block (ir2-block-block 2block)))
 141         (when (eq (block-info block) 2block)
 142           (unless (eql (source-path-tlf-number
 143                         (node-source-path
 144                          (block-start-node 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 (block-start-node 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
 176 ;;; on weird successors.
 177 (defun dump-block-successors (block physenv)
 178   (declare (type cblock block) (type physenv physenv))
 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-physenv (car succ)) physenv))))
 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 (physenv-lambda physenv))))))
 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-FUN. 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         (physenv (lambda-physenv fun))
 212         (prev-locs nil)
 213         (prev-block nil))
 214     (collect ((elsewhere))
 215       (do-physenv-ir2-blocks (2block physenv)
 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 physenv)))
 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   (let* ((file-info (source-info-file-info info))
 247          (res (make-debug-source
 248                :from :file
 249                :created (file-info-write-date file-info)
 250                :compiled (source-info-start-time info)
 251                :source-root (file-info-source-root file-info)
 252                :start-positions (coerce-to-smallest-eltype
 253                                  (file-info-positions file-info))))
 254          (name (file-info-name file-info)))
 255     (etypecase name
 256       ((member :lisp)
 257        (setf (debug-source-from res) name)
 258        (setf (debug-source-name res)
 259              (coerce (file-info-forms file-info) 'simple-vector)))
 260       (pathname
 261        (let* ((untruename (file-info-untruename file-info))
 262               (dir (pathname-directory untruename)))
 263          (setf (debug-source-name res)
 264                #+sb-xc-host
 265                (let ((src (position "src" dir :test #'string= :from-end t)))
 266                  (if src
 267                      (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
 268                              (subseq dir src) (pathname-name untruename))
 269                      ;; FIXME: just output/stuff-groveled-from-headers.lisp
 270                      (namestring untruename)))
 271                #-sb-xc-host
 272                (namestring
 273                 (if (and dir (eq (first dir) :absolute))
 274                     untruename
 275                     name))))))
 276     (list res)))
 277
 278 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
 279 ;;; possible. Ordinarily we coerce it to the smallest specialized
 280 ;;; vector we can. However, we also have a special hack for
 281 ;;; cross-compiling at bootstrap time, when arbitrarily-specialized
 282 ;;; vectors aren't fully supported: in that case, we coerce it only to
 283 ;;; a vector whose element size is an integer multiple of output byte
 284 ;;; size.
 285 (defun coerce-to-smallest-eltype (seq)
 286   (let ((maxoid 0))
 287     (flet ((frob (x)
 288              (if (typep x 'unsigned-byte)
 289                  (when (>= x maxoid)
 290                    (setf maxoid x))
 291                  (return-from coerce-to-smallest-eltype
 292                    (coerce seq 'simple-vector)))))
 293       (if (listp seq)
 294           (dolist (i seq)
 295             (frob i))
 296           (dovector (i seq)
 297             (frob i)))
 298       (let ((specializer `(unsigned-byte
 299                            ,(etypecase maxoid
 300                               ((unsigned-byte 8) 8)
 301                               ((unsigned-byte 16) 16)
 302                               ((unsigned-byte 32) 32)))))
 303         ;; cross-compilers beware! It would be possible for the
 304         ;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be
 305         ;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is
 306         ;; completely valid by ANSI.  However, the cross-compiler
 307         ;; doesn't know how to dump (in practice) anything but the
 308         ;; above three specialized array types, so make it break here
 309         ;; if this is violated.
 310         #+sb-xc-host
 311         (aver
 312          ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
 313          ;; worried about whether the host's implementation of arrays.
 314          (let ((uaet (upgraded-array-element-type specializer)))
 315            (dolist (et '((unsigned-byte 8)
 316                          (unsigned-byte 16)
 317                          (unsigned-byte 32))
 318                     nil)
 319              (when (and (subtypep et uaet) (subtypep uaet et))
 320                (return t)))))
 321         (coerce seq `(simple-array ,specializer (*)))))))
 322 \f
 323 ;;;; variables
 324
 325 ;;; Return a SC-OFFSET describing TN's location.
 326 (defun tn-sc-offset (tn)
 327   (declare (type tn tn))
 328   (make-sc-offset (sc-number (tn-sc tn))
 329                   (tn-offset tn)))
 330
 331 ;;; Dump info to represent VAR's location being TN. ID is an integer
 332 ;;; that makes VAR's name unique in the function. BUFFER is the vector
 333 ;;; we stick the result in. If MINIMAL, we suppress name dumping, and
 334 ;;; set the minimal flag.
 335 ;;;
 336 ;;; The DEBUG-VAR is only marked as always-live if the TN is
 337 ;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
 338 ;;; then we also exclude set variables, since the variable is not
 339 ;;; guaranteed to be live everywhere in that case.
 340 (defun dump-1-var (fun var tn id minimal buffer)
 341   (declare (type lambda-var var) (type (or tn null) tn) (type index id)
 342            (type clambda fun))
 343   (let* ((name (leaf-debug-name var))
 344          (save-tn (and tn (tn-save-tn tn)))
 345          (kind (and tn (tn-kind tn)))
 346          (flags 0))
 347     (declare (type index flags))
 348     (when minimal
 349       (setq flags (logior flags compiled-debug-var-minimal-p))
 350       (unless tn
 351         (setq flags (logior flags compiled-debug-var-deleted-p))))
 352     (when (and (or (eq kind :environment)
 353                    (and (eq kind :debug-environment)
 354                         (null (basic-var-sets var))))
 355                (not (gethash tn (ir2-component-spilled-tns
 356                                  (component-info *component-being-compiled*))))
 357                (eq (lambda-var-home var) fun))
 358       (setq flags (logior flags compiled-debug-var-environment-live)))
 359     (when save-tn
 360       (setq flags (logior flags compiled-debug-var-save-loc-p)))
 361     (unless (or (zerop id) minimal)
 362       (setq flags (logior flags compiled-debug-var-id-p)))
 363     (vector-push-extend flags buffer)
 364     (unless minimal
 365       (vector-push-extend name buffer)
 366       (unless (zerop id)
 367         (vector-push-extend id buffer)))
 368     (if tn
 369         (vector-push-extend (tn-sc-offset tn) buffer)
 370         (aver minimal))
 371     (when save-tn
 372       (vector-push-extend (tn-sc-offset save-tn) buffer)))
 373   (values))
 374
 375 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS
 376 ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
 377 ;;; hash table in which we enter the translation from LAMBDA-VARS to
 378 ;;; the relative position of that variable's location in the resulting
 379 ;;; vector.
 380 (defun compute-vars (fun level var-locs)
 381   (declare (type clambda fun) (type hash-table var-locs))
 382   (collect ((vars))
 383     (labels ((frob-leaf (leaf tn gensym-p)
 384                (let ((name (leaf-debug-name leaf)))
 385                  (when (and name (leaf-refs leaf) (tn-offset tn)
 386                             (or gensym-p (symbol-package name)))
 387                    (vars (cons leaf tn)))))
 388              (frob-lambda (x gensym-p)
 389                (dolist (leaf (lambda-vars x))
 390                  (frob-leaf leaf (leaf-info leaf) gensym-p))))
 391       (frob-lambda fun t)
 392       (when (>= level 2)
 393         (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
 394           (let ((thing (car x)))
 395             (when (lambda-var-p thing)
 396               (frob-leaf thing (cdr x) (= level 3)))))
 397
 398         (dolist (let (lambda-lets fun))
 399           (frob-lambda let (= level 3)))))
 400
 401     (let ((sorted (sort (vars) #'string<
 402                         :key (lambda (x)
 403                                (symbol-name (leaf-debug-name (car x))))))
 404           (prev-name nil)
 405           (id 0)
 406           (i 0)
 407           (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
 408       (declare (type (or simple-string null) prev-name)
 409                (type index id i))
 410       (dolist (x sorted)
 411         (let* ((var (car x))
 412                (name (symbol-name (leaf-debug-name var))))
 413           (cond ((and prev-name (string= prev-name name))
 414                  (incf id))
 415                 (t
 416                  (setq id 0  prev-name name)))
 417           (dump-1-var fun var (cdr x) id nil buffer)
 418           (setf (gethash var var-locs) i))
 419         (incf i))
 420       (coerce buffer 'simple-vector))))
 421
 422 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
 423 ;;; FUN, representing the arguments to FUN in minimal variable format.
 424 (defun compute-minimal-vars (fun)
 425   (declare (type clambda fun))
 426   (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
 427     (dolist (var (lambda-vars fun))
 428       (dump-1-var fun var (leaf-info var) 0 t buffer))
 429     (coerce buffer 'simple-vector)))
 430
 431 ;;; Return VAR's relative position in the function's variables (determined
 432 ;;; from the VAR-LOCS hashtable).  If VAR is deleted, then return DELETED.
 433 (defun debug-location-for (var var-locs)
 434   (declare (type lambda-var var) (type hash-table var-locs))
 435   (let ((res (gethash var var-locs)))
 436     (cond (res)
 437           (t
 438            (aver (or (null (leaf-refs var))
 439                      (not (tn-offset (leaf-info var)))))
 440            'deleted))))
 441 \f
 442 ;;;; arguments/returns
 443
 444 ;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
 445 ;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
 446 ;;; the ARGLIST to determine the syntax, otherwise pretend all
 447 ;;; arguments are fixed.
 448 ;;;
 449 ;;; ### This assumption breaks down in EPs other than the main-entry,
 450 ;;; since they may or may not have supplied-p vars, etc.
 451 (defun compute-args (fun var-locs)
 452   (declare (type clambda fun) (type hash-table var-locs))
 453   (collect ((res))
 454     (let ((od (lambda-optional-dispatch fun)))
 455       (if (and od (eq (optional-dispatch-main-entry od) fun))
 456           (let ((actual-vars (lambda-vars fun))
 457                 (saw-optional nil))
 458             (dolist (arg (optional-dispatch-arglist od))
 459               (let ((info (lambda-var-arg-info arg))
 460                     (actual (pop actual-vars)))
 461                 (cond (info
 462                        (case (arg-info-kind info)
 463                          (:keyword
 464                           (res (arg-info-key info)))
 465                          (:rest
 466                           (res 'rest-arg))
 467                          (:more-context
 468                           (res 'more-arg))
 469                          (:optional
 470                           (unless saw-optional
 471                             (res 'optional-args)
 472                             (setq saw-optional t))))
 473                        (res (debug-location-for actual var-locs))
 474                        (when (arg-info-supplied-p info)
 475                          (res 'supplied-p)
 476                          (res (debug-location-for (pop actual-vars) var-locs))))
 477                       (t
 478                        (res (debug-location-for actual var-locs)))))))
 479           (dolist (var (lambda-vars fun))
 480             (res (debug-location-for var var-locs)))))
 481
 482     (coerce-to-smallest-eltype (res))))
 483
 484 ;;; Return a vector of SC offsets describing FUN's return locations.
 485 ;;; (Must be known values return...)
 486 (defun compute-debug-returns (fun)
 487   (coerce-to-smallest-eltype
 488    (mapcar (lambda (loc)
 489              (tn-sc-offset loc))
 490            (return-info-locations (tail-set-info (lambda-tail-set fun))))))
 491 \f
 492 ;;;; debug functions
 493
 494 ;;; Return a C-D-F structure with all the mandatory slots filled in.
 495 (defun dfun-from-fun (fun)
 496   (declare (type clambda fun))
 497   (let* ((2env (physenv-info (lambda-physenv fun)))
 498          (dispatch (lambda-optional-dispatch fun))
 499          (main-p (and dispatch
 500                       (eq fun (optional-dispatch-main-entry dispatch)))))
 501     (make-compiled-debug-fun
 502      :name (leaf-debug-name fun)
 503      :kind (if main-p nil (functional-kind fun))
 504      :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env))
 505      :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env))
 506      :start-pc (label-position (ir2-physenv-environment-start 2env))
 507      :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)))))
 508
 509 ;;; Return a complete C-D-F structure for FUN. This involves
 510 ;;; determining the DEBUG-INFO level and filling in optional slots as
 511 ;;; appropriate.
 512 (defun compute-1-debug-fun (fun var-locs)
 513   (declare (type clambda fun) (type hash-table var-locs))
 514   (let* ((dfun (dfun-from-fun fun))
 515          (actual-level (policy (lambda-bind fun) debug))
 516          (level (if #!+sb-dyncount *collect-dynamic-statistics*
 517                     #!-sb-dyncount nil
 518                     (max actual-level 2)
 519                     actual-level)))
 520     (cond ((zerop level))
 521           ((and (<= level 1)
 522                 (let ((od (lambda-optional-dispatch fun)))
 523                   (or (not od)
 524                       (not (eq (optional-dispatch-main-entry od) fun)))))
 525            (setf (compiled-debug-fun-vars dfun)
 526                  (compute-minimal-vars fun))
 527            (setf (compiled-debug-fun-arguments dfun) :minimal))
 528           (t
 529            (setf (compiled-debug-fun-vars dfun)
 530                  (compute-vars fun level var-locs))
 531            (setf (compiled-debug-fun-arguments dfun)
 532                  (compute-args fun var-locs))))
 533
 534     (if (>= level 2)
 535         (multiple-value-bind (blocks tlf-num)
 536             (compute-debug-blocks fun var-locs)
 537           (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
 538           (setf (compiled-debug-fun-blocks dfun) blocks))
 539         (setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
 540
 541     (if (xep-p fun)
 542         (setf (compiled-debug-fun-returns dfun) :standard)
 543         (let ((info (tail-set-info (lambda-tail-set fun))))
 544           (when info
 545             (cond ((eq (return-info-kind info) :unknown)
 546                    (setf (compiled-debug-fun-returns dfun)
 547                          :standard))
 548                   ((/= level 0)
 549                    (setf (compiled-debug-fun-returns dfun)
 550                          (compute-debug-returns fun)))))))
 551     dfun))
 552 \f
 553 ;;;; full component dumping
 554
 555 ;;; Compute the full form (simple-vector) function map.
 556 (defun compute-debug-fun-map (sorted)
 557   (declare (list sorted))
 558   (let* ((len (1- (* (length sorted) 2)))
 559          (funs-vec (make-array len)))
 560     (do ((i -1 (+ i 2))
 561          (sorted sorted (cdr sorted)))
 562         ((= i len))
 563       (declare (fixnum i))
 564       (let ((dfun (car sorted)))
 565         (unless (minusp i)
 566           (setf (svref funs-vec i) (car dfun)))
 567         (setf (svref funs-vec (1+ i)) (cdr dfun))))
 568     funs-vec))
 569
 570 ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
 571 ;;; called after assembly so that source map information is available.
 572 (defun debug-info-for-component (component)
 573   (declare (type component component))
 574   (let ((dfuns nil)
 575         (var-locs (make-hash-table :test 'eq))
 576         (*byte-buffer* (make-array 10
 577                                    :element-type '(unsigned-byte 8)
 578                                    :fill-pointer 0
 579                                    :adjustable t)))
 580     (dolist (lambda (component-lambdas component))
 581       (clrhash var-locs)
 582       (push (cons (label-position (block-label (lambda-block lambda)))
 583                   (compute-1-debug-fun lambda var-locs))
 584             dfuns))
 585     (let* ((sorted (sort dfuns #'< :key #'car))
 586            (fun-map (compute-debug-fun-map sorted)))
 587       (make-compiled-debug-info :name (component-name component)
 588                                 :fun-map fun-map))))
 589 \f
 590 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
 591 ;;; BITS must be evenly divisible by eight.
 592 (defun write-packed-bit-vector (bits byte-buffer)
 593   (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
 594
 595   ;; Enforce constraint from CMU-CL-era comment.
 596   (aver (zerop (mod (length bits) 8)))
 597
 598   (multiple-value-bind (initial step done)
 599       (ecase *backend-byte-order*
 600         (:little-endian (values 0  1  8))
 601         (:big-endian    (values 7 -1 -1)))
 602     (let ((shift initial)
 603           (byte 0))
 604       (dotimes (i (length bits))
 605         (let ((int (aref bits i)))
 606           (setf byte (logior byte (ash int shift)))
 607           (incf shift step))
 608         (when (= shift done)
 609           (vector-push-extend byte byte-buffer)
 610           (setf shift initial
 611                 byte 0)))
 612       (unless (= shift initial)
 613         (vector-push-extend byte byte-buffer))))
 614   (values))