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