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