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