src/compiler/debug-dump.lisp

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