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            :step-before-vop))
  25
  26 ;;; The LOCATION-INFO structure holds the information what we need
  27 ;;; about locations which code generation decided were "interesting".
  28 (defstruct (location-info
  29             (:constructor make-location-info (kind label vop))
  30             (:copier nil))
  31   ;; The kind of location noted.
  32   (kind nil :type location-kind)
  33   ;; The label pointing to the interesting code location.
  34   (label nil :type (or label index null))
  35   ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
  36   (vop nil :type vop))
  37
  38 ;;; This is called during code generation in places where there is an
  39 ;;; "interesting" location: someplace where we are likely to end up
  40 ;;; in the debugger, and thus want debug info.
  41 (defun note-debug-location (vop label kind)
  42   (declare (type vop vop) (type (or label null) label)
  43            (type location-kind kind))
  44   (let ((location (make-location-info kind label vop)))
  45     (setf (ir2-block-locations (vop-block vop))
  46           (nconc (ir2-block-locations (vop-block vop))
  47                  (list location)))
  48     location))
  49
  50 #!-sb-fluid (declaim (inline ir2-block-physenv))
  51 (defun ir2-block-physenv (2block)
  52   (declare (type ir2-block 2block))
  53   (block-physenv (ir2-block-block 2block)))
  54
  55 (defun leaf-visible-to-debugger-p (leaf node)
  56   (or (rassoc leaf (lexenv-vars (node-lexenv node)))
  57       (labels ((visible-in-call-lexenv (lambda)
  58                  (when lambda
  59                    (let ((call-lexenv (lambda-call-lexenv lambda)))
  60                      (and call-lexenv
  61                           (or (rassoc leaf (lexenv-vars call-lexenv))
  62                               (visible-in-call-lexenv (lexenv-lambda call-lexenv))))))))
  63         (visible-in-call-lexenv (lexenv-lambda (node-lexenv node))))))
  64
  65 ;;; Given a local conflicts vector and an IR2 block to represent the
  66 ;;; set of live TNs, and the VAR-LOCS hash-table representing the
  67 ;;; variables dumped, compute a bit-vector representing the set of
  68 ;;; live variables. If the TN is environment-live, we only mark it as
  69 ;;; live when it is in scope at NODE.
  70 (defun compute-live-vars (live node block var-locs vop)
  71   (declare (type ir2-block block) (type local-tn-bit-vector live)
  72            (type hash-table var-locs) (type node node)
  73            (type (or vop null) vop))
  74   (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
  75                          :element-type 'bit
  76                          :initial-element 0))
  77         (spilled (gethash vop
  78                           (ir2-component-spilled-vops
  79                            (component-info *component-being-compiled*)))))
  80     (do-live-tns (tn live block)
  81       (let ((leaf (tn-leaf tn)))
  82         (when (and (lambda-var-p leaf)
  83                    (or (not (member (tn-kind tn)
  84                                     '(:environment :debug-environment)))
  85                        (leaf-visible-to-debugger-p leaf node))
  86                    (or (null spilled)
  87                        (not (member tn spilled))))
  88           (let ((num (gethash leaf var-locs)))
  89             (when num
  90               (setf (sbit res num) 1))))))
  91     res))
  92
  93 ;;; The PC for the location most recently dumped.
  94 (defvar *previous-location*)
  95 (declaim (type index *previous-location*))
  96
  97 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
  98 ;;; the code/source map and live info. If true, VOP is the VOP
  99 ;;; associated with this location, for use in determining whether TNs
 100 ;;; are spilled.
 101 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
 102   (declare (type node node) (type ir2-block block)
 103            (type (or null local-tn-bit-vector) live)
 104            (type (or label index) label)
 105            (type location-kind kind) (type (or index null) tlf-num)
 106            (type hash-table var-locs) (type (or vop null) vop))
 107
 108   (let ((byte-buffer *byte-buffer*))
 109     (vector-push-extend
 110      (position-or-lose kind *compiled-code-location-kinds*)
 111      byte-buffer)
 112
 113     (let ((loc (if (fixnump label) label (label-position label))))
 114       (write-var-integer (- loc *previous-location*) byte-buffer)
 115       (setq *previous-location* loc))
 116
 117     (let ((path (node-source-path node)))
 118       (unless tlf-num
 119         (write-var-integer (source-path-tlf-number path) byte-buffer))
 120       (write-var-integer (source-path-form-number path) byte-buffer))
 121
 122     (if live
 123         (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
 124                                  byte-buffer)
 125         (write-packed-bit-vector
 126          (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
 127                      :initial-element 0
 128                      :element-type 'bit)
 129          byte-buffer))
 130
 131     (write-var-string (or (and (typep node 'combination)
 132                                (combination-step-info node))
 133                           "")
 134                       byte-buffer))
 135   (values))
 136
 137 ;;; Extract context info from a Location-Info structure and use it to
 138 ;;; dump a compiled code-location.
 139 (defun dump-location-from-info (loc tlf-num var-locs)
 140   (declare (type location-info loc) (type (or index null) tlf-num)
 141            (type hash-table var-locs))
 142   (let ((vop (location-info-vop loc)))
 143     (dump-1-location (vop-node vop)
 144                      (vop-block vop)
 145                      (location-info-kind loc)
 146                      tlf-num
 147                      (location-info-label loc)
 148                      (vop-save-set vop)
 149                      var-locs
 150                      vop))
 151   (values))
 152
 153 ;;; Scan all the blocks, determining if all locations are in the same
 154 ;;; TLF, and returning it or NIL.
 155 (defun find-tlf-number (fun)
 156   (declare (type clambda fun))
 157   (let* ((source-path (node-source-path (lambda-bind fun)))
 158          (res (source-path-tlf-number source-path)))
 159     (declare (type (or index null) res))
 160     (do-physenv-ir2-blocks (2block (lambda-physenv fun))
 161       (let ((block (ir2-block-block 2block)))
 162         (when (eq (block-info block) 2block)
 163           (unless (eql (source-path-tlf-number
 164                         (node-source-path
 165                          (block-start-node block)))
 166                        res)
 167             (setq res nil)))
 168
 169         (dolist (loc (ir2-block-locations 2block))
 170           (unless (eql (source-path-tlf-number
 171                         (node-source-path
 172                          (vop-node (location-info-vop loc))))
 173                        res)
 174             (setq res nil)))))
 175     (values res (source-path-form-number source-path))))
 176
 177 ;;; Dump out the number of locations and the locations for Block.
 178 (defun dump-block-locations (block locations tlf-num var-locs)
 179   (declare (type cblock block) (list locations))
 180   (if (and locations
 181            (eq (location-info-kind (first locations))
 182                :non-local-entry))
 183       (write-var-integer (length locations) *byte-buffer*)
 184       (let ((2block (block-info block)))
 185         (write-var-integer (+ (length locations) 1) *byte-buffer*)
 186         (dump-1-location (block-start-node block)
 187                          2block :block-start tlf-num
 188                          (ir2-block-%label 2block)
 189                          (ir2-block-live-out 2block)
 190                          var-locs
 191                          nil)))
 192   (dolist (loc locations)
 193     (dump-location-from-info loc tlf-num var-locs))
 194   (values))
 195
 196 ;;; Return a vector and an integer (or null) suitable for use as the
 197 ;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN.
 198 (defun compute-debug-blocks (fun var-locs)
 199   (declare (type clambda fun) (type hash-table var-locs))
 200   (multiple-value-bind (tlf-num form-number) (find-tlf-number fun)
 201    (let ((*previous-location* 0)
 202          (physenv (lambda-physenv fun))
 203          (byte-buffer *byte-buffer*)
 204          prev-block
 205          locations
 206          elsewhere-locations)
 207      (setf (fill-pointer byte-buffer) 0)
 208      (do-physenv-ir2-blocks (2block physenv)
 209        (let ((block (ir2-block-block 2block)))
 210          (when (eq (block-info block) 2block)
 211            (when prev-block
 212              (dump-block-locations prev-block (nreverse (shiftf locations nil))
 213                                    tlf-num var-locs))
 214            (setf prev-block block)))
 215        (dolist (loc (ir2-block-locations 2block))
 216          (if (label-elsewhere-p (location-info-label loc)
 217                                 (location-info-kind loc))
 218              (push loc elsewhere-locations)
 219              (push loc locations))))
 220
 221      (dump-block-locations prev-block (nreverse locations)
 222                            tlf-num var-locs)
 223
 224      (when elsewhere-locations
 225        (write-var-integer (length elsewhere-locations) byte-buffer)
 226        (dolist (loc (nreverse elsewhere-locations))
 227          (push loc locations)
 228          (dump-location-from-info loc tlf-num var-locs)))
 229
 230      (values (!make-specialized-array (length byte-buffer) '(unsigned-byte 8)
 231                                       byte-buffer)
 232              tlf-num form-number))))
 233 \f
 234 ;;; Return DEBUG-SOURCE structure containing information derived from
 235 ;;; INFO.
 236 (defun debug-source-for-info (info &key function)
 237   (declare (type source-info info))
 238   (let ((file-info (get-toplevelish-file-info info)))
 239     (make-debug-source
 240      :compiled (source-info-start-time info)
 241
 242      :namestring (or *source-namestring*
 243                      (make-file-info-namestring
 244                       (if (pathnamep (file-info-name file-info))
 245                           (file-info-name file-info))
 246                       file-info))
 247      :created (file-info-write-date file-info)
 248      :source-root (file-info-source-root file-info)
 249      :start-positions (coerce-to-smallest-eltype
 250                        (file-info-positions file-info))
 251
 252      :form (let ((direct-file-info (source-info-file-info info)))
 253              (when (eq :lisp (file-info-name direct-file-info))
 254                (elt (file-info-forms direct-file-info) 0)))
 255      :function function)))
 256
 257 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
 258 ;;; possible. Ordinarily we coerce it to the smallest specialized
 259 ;;; vector we can.
 260 ;;; During cross-compilation the in-memory representation is opaque -
 261 ;;; we don't care how it looks, but can recover the intended specialization.
 262
 263 (defun coerce-to-smallest-eltype (seq)
 264   (let ((maxoid 0) (length 0))
 265     (flet ((frob (x)
 266              (if (typep x 'unsigned-byte)
 267                  (when (>= x maxoid)
 268                    (setf maxoid x))
 269                  (return-from coerce-to-smallest-eltype
 270                    (coerce seq 'simple-vector)))))
 271       (if (listp seq)
 272           (dolist (i seq)
 273             (incf length) ; so not to traverse again to compute it
 274             (frob i))
 275           (dovector (i seq (setq length (length seq)))
 276             (frob i)))
 277       (let ((specializer (etypecase maxoid
 278                            ((unsigned-byte 8) '(unsigned-byte 8))
 279                            ((unsigned-byte 16) '(unsigned-byte 16))
 280                            ((unsigned-byte 32) '(unsigned-byte 32))
 281                            ((unsigned-byte 64) '(unsigned-byte 64)))))
 282         ;; formerly (coerce seq `(simple-array ,specializer (*)))
 283         ;; plus a kludge for cross-compilation. This is nicer.
 284         (!make-specialized-array length specializer seq)))))
 285 \f
 286 ;;;; variables
 287
 288 ;;; Return a SC-OFFSET describing TN's location.
 289 (defun tn-sc-offset (tn)
 290   (declare (type tn tn))
 291   (make-sc-offset (sc-number (tn-sc tn))
 292                   (tn-offset tn)))
 293
 294 (defun lambda-ancestor-p (maybe-ancestor maybe-descendant)
 295   (declare (type clambda maybe-ancestor)
 296            (type (or clambda null) maybe-descendant))
 297   (loop
 298      (when (eq maybe-ancestor maybe-descendant)
 299        (return t))
 300      (setf maybe-descendant (lambda-parent maybe-descendant))
 301      (when (null maybe-descendant)
 302        (return nil))))
 303
 304 ;;; Dump info to represent VAR's location being TN. ID is an integer
 305 ;;; that makes VAR's name unique in the function. BUFFER is the vector
 306 ;;; we stick the result in. If MINIMAL, we suppress name dumping, and
 307 ;;; set the minimal flag.
 308 ;;;
 309 ;;; The DEBUG-VAR is only marked as always-live if the TN is
 310 ;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
 311 ;;; then we also exclude set variables, since the variable is not
 312 ;;; guaranteed to be live everywhere in that case.
 313 (defun dump-1-var (fun var tn id minimal buffer)
 314   (declare (type lambda-var var) (type (or tn null) tn) (type index id)
 315            (type clambda fun))
 316   (let* ((name (leaf-debug-name var))
 317          (save-tn (and tn (tn-save-tn tn)))
 318          (kind (and tn (tn-kind tn)))
 319          (flags 0)
 320          (info (lambda-var-arg-info var))
 321          (indirect (and (lambda-var-indirect var)
 322                         (not (lambda-var-explicit-value-cell var))
 323                         (neq (lambda-physenv fun)
 324                              (lambda-physenv (lambda-var-home var))))))
 325     (declare (type index flags))
 326     (when minimal
 327       (setq flags (logior flags compiled-debug-var-minimal-p))
 328       (unless (and tn (tn-offset tn))
 329         (setq flags (logior flags compiled-debug-var-deleted-p))))
 330     (when (and (or (eq kind :environment)
 331                    (and (eq kind :debug-environment)
 332                         (null (basic-var-sets var))))
 333                (not (gethash tn (ir2-component-spilled-tns
 334                                  (component-info *component-being-compiled*))))
 335                (lambda-ancestor-p (lambda-var-home var) fun))
 336       (setq flags (logior flags compiled-debug-var-environment-live)))
 337     (when save-tn
 338       (setq flags (logior flags compiled-debug-var-save-loc-p)))
 339     (unless (or (zerop id) minimal)
 340       (setq flags (logior flags compiled-debug-var-id-p)))
 341     (when indirect
 342       (setq flags (logior flags compiled-debug-var-indirect-p)))
 343     (when info
 344       (case (arg-info-kind info)
 345         (:more-context
 346          (setq flags (logior flags compiled-debug-var-more-context-p)))
 347         (:more-count
 348          (setq flags (logior flags compiled-debug-var-more-count-p)))))
 349     #!+64-bit
 350     (cond (indirect
 351            (setf (ldb (byte 27 8) flags) (tn-sc-offset tn))
 352            (when save-tn
 353              (setf (ldb (byte 27 35) flags) (tn-sc-offset save-tn))))
 354           (t
 355            (if (and tn (tn-offset tn))
 356                (setf (ldb (byte 27 8) flags) (tn-sc-offset tn))
 357                (aver minimal))
 358            (when save-tn
 359              (setf (ldb (byte 27 35) flags) (tn-sc-offset save-tn)))))
 360     (vector-push-extend flags buffer)
 361     (unless minimal
 362       (vector-push-extend name buffer)
 363       (unless (zerop id)
 364         (vector-push-extend id buffer)))
 365
 366     (cond (indirect
 367            ;; Indirect variables live in the parent frame, and are
 368            ;; accessed through a saved frame pointer.
 369            ;; The first one/two sc-offsets are for the frame pointer,
 370            ;; the third is for the stack offset.
 371            #!-64-bit
 372            (vector-push-extend (tn-sc-offset tn) buffer)
 373            #!-64-bit
 374            (when save-tn
 375              (vector-push-extend (tn-sc-offset save-tn) buffer))
 376            (vector-push-extend (tn-sc-offset (leaf-info var)) buffer))
 377           #!-64-bit
 378           (t
 379            (if (and tn (tn-offset tn))
 380                (vector-push-extend (tn-sc-offset tn) buffer)
 381                (aver minimal))
 382            (when save-tn
 383              (vector-push-extend (tn-sc-offset save-tn) buffer)))))
 384   (values))
 385
 386 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS
 387 ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
 388 ;;; hash table in which we enter the translation from LAMBDA-VARS to
 389 ;;; the relative position of that variable's location in the resulting
 390 ;;; vector.
 391 (defun compute-vars (fun level var-locs)
 392   (declare (type clambda fun) (type hash-table var-locs))
 393   (collect ((vars))
 394     (labels ((frob-leaf (leaf tn gensym-p)
 395                (let ((name (leaf-debug-name leaf)))
 396                  (when (and name (leaf-refs leaf) (tn-offset tn)
 397                             (or gensym-p (symbol-package name)))
 398                    (vars (cons leaf tn)))))
 399              (frob-lambda (x gensym-p)
 400                (dolist (leaf (lambda-vars x))
 401                  (frob-leaf leaf (leaf-info leaf) gensym-p))))
 402       (frob-lambda fun t)
 403       (when (>= level 2)
 404         (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
 405           (let ((thing (car x)))
 406             (when (lambda-var-p thing)
 407               (frob-leaf thing (cdr x) (= level 3)))))
 408
 409         (dolist (let (lambda-lets fun))
 410           (frob-lambda let (= level 3)))))
 411
 412     (let ((sorted (sort (vars) #'string<
 413                         :key (lambda (x)
 414                                (symbol-name (leaf-debug-name (car x))))))
 415           (prev-name nil)
 416           (id 0)
 417           (i 0)
 418           (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
 419       (declare (type (or simple-string null) prev-name)
 420                (type index id i))
 421       (dolist (x sorted)
 422         (let* ((var (car x))
 423                (name (symbol-name (leaf-debug-name var))))
 424           (cond ((and prev-name (string= prev-name name))
 425                  (incf id))
 426                 (t
 427                  (setq id 0  prev-name name)))
 428           (dump-1-var fun var (cdr x) id nil buffer)
 429           (setf (gethash var var-locs) i)
 430           (incf i)))
 431       (coerce buffer 'simple-vector))))
 432
 433 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
 434 ;;; FUN, representing the arguments to FUN in minimal variable format.
 435 (defun compute-minimal-vars (fun)
 436   (declare (type clambda fun))
 437   (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
 438     (dolist (var (lambda-vars fun))
 439       (dump-1-var fun var (leaf-info var) 0 t buffer))
 440     (coerce buffer 'simple-vector)))
 441
 442 ;;; Return VAR's relative position in the function's variables (determined
 443 ;;; from the VAR-LOCS hashtable).  If VAR is deleted, then return DELETED.
 444 (defun debug-location-for (var var-locs)
 445   (declare (type lambda-var var) (type hash-table var-locs))
 446   (let ((res (gethash var var-locs)))
 447     (cond (res)
 448           (t
 449            (aver (or (null (leaf-refs var))
 450                      (not (tn-offset (leaf-info var)))))
 451            'deleted))))
 452 \f
 453 ;;;; arguments/returns
 454
 455 ;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
 456 ;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
 457 ;;; the ARGLIST to determine the syntax, otherwise pretend all
 458 ;;; arguments are fixed.
 459 ;;;
 460 ;;; ### This assumption breaks down in EPs other than the main-entry,
 461 ;;; since they may or may not have supplied-p vars, etc.
 462 (defun compute-args (fun var-locs)
 463   (declare (type clambda fun) (type hash-table var-locs))
 464   (collect ((res))
 465     (let ((od (lambda-optional-dispatch fun)))
 466       (if (and od (eq (optional-dispatch-main-entry od) fun))
 467           (let ((actual-vars (lambda-vars fun))
 468                 (saw-optional nil))
 469             (labels ((one-arg (arg)
 470                        (let ((info (lambda-var-arg-info arg))
 471                              (actual (pop actual-vars)))
 472                          (cond (info
 473                                 (case (arg-info-kind info)
 474                                   (:keyword
 475                                    (res (arg-info-key info)))
 476                                   (:rest
 477                                    (let ((more (arg-info-default info)))
 478                                      (cond ((and (consp more) (third more))
 479                                             (one-arg (first (arg-info-default info)))
 480                                             (one-arg (second (arg-info-default info)))
 481                                             (return-from one-arg))
 482                                            (more
 483                                             (setf (arg-info-default info) t)))
 484                                      (res 'rest-arg)))
 485                                   (:more-context
 486                                    (res 'more-arg))
 487                                   (:optional
 488                                    (unless saw-optional
 489                                      (res 'optional-args)
 490                                      (setq saw-optional t))))
 491                                 (res (debug-location-for actual var-locs))
 492                                 (when (arg-info-supplied-p info)
 493                                   (res 'supplied-p)
 494                                   (res (debug-location-for (pop actual-vars) var-locs))))
 495                                 (t
 496                                  (res (debug-location-for actual var-locs)))))))
 497               (dolist (arg (optional-dispatch-arglist od))
 498                 (one-arg arg))))
 499           (dolist (var (lambda-vars fun))
 500             (res (debug-location-for var var-locs)))))
 501
 502     (coerce-to-smallest-eltype (res))))
 503
 504 ;;; Return a vector of SC offsets describing FUN's return locations.
 505 ;;; (Must be known values return...)
 506 (defun compute-debug-returns (fun)
 507   (coerce-to-smallest-eltype
 508    (mapcar (lambda (loc)
 509              (tn-sc-offset loc))
 510            (return-info-locations (tail-set-info (lambda-tail-set fun))))))
 511 \f
 512 ;;;; debug functions
 513
 514 ;;; Return a C-D-F structure with all the mandatory slots filled in.
 515 (defun dfun-from-fun (fun)
 516   (declare (type clambda fun))
 517   (let* ((2env (physenv-info (lambda-physenv fun)))
 518          (dispatch (lambda-optional-dispatch fun))
 519          (main-p (and dispatch
 520                       (eq fun (optional-dispatch-main-entry dispatch)))))
 521     (make-compiled-debug-fun
 522      :name (leaf-debug-name fun)
 523      :kind (if main-p nil (functional-kind fun))
 524      #!-fp-and-pc-standard-save :return-pc
 525      #!-fp-and-pc-standard-save (tn-sc-offset (ir2-physenv-return-pc 2env))
 526      #!-fp-and-pc-standard-save :old-fp
 527      #!-fp-and-pc-standard-save (tn-sc-offset (ir2-physenv-old-fp 2env))
 528      :start-pc (label-position (ir2-physenv-environment-start 2env))
 529      :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env))
 530      :closure-save (when (ir2-physenv-closure-save-tn 2env)
 531                      (tn-sc-offset (ir2-physenv-closure-save-tn 2env)))
 532      #!+unwind-to-frame-and-call-vop
 533      :bsp-save
 534      #!+unwind-to-frame-and-call-vop
 535      (when (ir2-physenv-bsp-save-tn 2env)
 536        (tn-sc-offset (ir2-physenv-bsp-save-tn 2env))))))
 537
 538 ;;; Return a complete C-D-F structure for FUN. This involves
 539 ;;; determining the DEBUG-INFO level and filling in optional slots as
 540 ;;; appropriate.
 541 (defun compute-1-debug-fun (fun var-locs)
 542   (declare (type clambda fun) (type hash-table var-locs))
 543   (let* ((dfun (dfun-from-fun fun))
 544          (actual-level (policy (lambda-bind fun) compute-debug-fun))
 545          (level (if #!+sb-dyncount *collect-dynamic-statistics*
 546                     #!-sb-dyncount nil
 547                     (max actual-level 2)
 548                     actual-level))
 549          (toplevel-p (eq :toplevel (compiled-debug-fun-kind dfun))))
 550     (cond ((or (zerop level) toplevel-p))
 551           ((and (<= level 1)
 552                 (let ((od (lambda-optional-dispatch fun)))
 553                   (or (not od)
 554                       (not (eq (optional-dispatch-main-entry od) fun)))))
 555            (setf (compiled-debug-fun-vars dfun)
 556                  (compute-minimal-vars fun))
 557            (setf (compiled-debug-fun-arguments dfun) :minimal))
 558           (t
 559            (setf (compiled-debug-fun-vars dfun)
 560                  (compute-vars fun level var-locs))
 561            (setf (compiled-debug-fun-arguments dfun)
 562                  (compute-args fun var-locs))))
 563
 564     (if (and (>= level 2) (not toplevel-p))
 565         (multiple-value-bind (blocks tlf-num form-number)
 566             (compute-debug-blocks fun var-locs)
 567           (setf (compiled-debug-fun-blocks dfun) blocks
 568                 (compiled-debug-fun-tlf-number dfun) tlf-num
 569                 (compiled-debug-fun-form-number dfun) form-number))
 570         (multiple-value-bind (tlf-num form-number) (find-tlf-number fun)
 571           (setf (compiled-debug-fun-tlf-number dfun) tlf-num
 572                 (compiled-debug-fun-form-number dfun) form-number)))
 573     (if (xep-p fun)
 574         (setf (compiled-debug-fun-returns dfun) :standard)
 575         (let ((info (tail-set-info (lambda-tail-set fun))))
 576           (when info
 577             (cond ((eq (return-info-kind info) :unknown)
 578                    (setf (compiled-debug-fun-returns dfun)
 579                          :standard))
 580                   ((/= level 0)
 581                    (setf (compiled-debug-fun-returns dfun)
 582                          (compute-debug-returns fun)))))))
 583     dfun))
 584 \f
 585 ;;;; full component dumping
 586
 587 ;;; Compute the full form (simple-vector) function map.
 588 (defun compute-debug-fun-map (sorted)
 589   (declare (list sorted))
 590   (let* ((len (1- (* (length sorted) 2)))
 591          (funs-vec (make-array len)))
 592     (do ((i -1 (+ i 2))
 593          (sorted sorted (cdr sorted)))
 594         ((= i len))
 595       (declare (fixnum i))
 596       (let ((dfun (car sorted)))
 597         (unless (minusp i)
 598           (setf (svref funs-vec i) (car dfun)))
 599         (setf (svref funs-vec (1+ i)) (cdr dfun))))
 600     funs-vec))
 601
 602 ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
 603 ;;; called after assembly so that source map information is available.
 604 (defun debug-info-for-component (component)
 605   (declare (type component component))
 606   (let ((dfuns nil)
 607         (var-locs (make-hash-table :test 'eq))
 608         (*byte-buffer* (make-array 10
 609                                    :element-type '(unsigned-byte 8)
 610                                    :fill-pointer 0
 611                                    :adjustable t)))
 612     (dolist (lambda (component-lambdas component))
 613       (clrhash var-locs)
 614       (push (cons (label-position (block-label (lambda-block lambda)))
 615                   (compute-1-debug-fun lambda var-locs))
 616             dfuns))
 617     (let* ((sorted (sort dfuns #'< :key #'car))
 618            (fun-map (compute-debug-fun-map sorted)))
 619       (make-compiled-debug-info :name (component-name component)
 620                                 :fun-map fun-map))))
 621 \f
 622 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
 623 ;;; BITS must be evenly divisible by eight.
 624 (defun write-packed-bit-vector (bits byte-buffer)
 625   (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
 626
 627   ;; Enforce constraint from CMU-CL-era comment.
 628   (aver (zerop (mod (length bits) 8)))
 629
 630   (multiple-value-bind (initial step done)
 631       (ecase *backend-byte-order*
 632         (:little-endian (values 0  1  8))
 633         (:big-endian    (values 7 -1 -1)))
 634     (let ((shift initial)
 635           (byte 0))
 636       (dotimes (i (length bits))
 637         (let ((int (aref bits i)))
 638           (setf byte (logior byte (ash int shift)))
 639           (incf shift step))
 640         (when (= shift done)
 641           (vector-push-extend byte byte-buffer)
 642           (setf shift initial
 643                 byte 0)))
 644       (unless (= shift initial)
 645         (vector-push-extend byte byte-buffer))))
 646   (values))