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