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