protect against read-time package-lock circumvention from LOCKED::(BAR)
[sbcl.git] / 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 ;;; Given a local conflicts vector and an IR2 block to represent the
56 ;;; set of live TNs, and the VAR-LOCS hash-table representing the
57 ;;; variables dumped, compute a bit-vector representing the set of
58 ;;; live variables. If the TN is environment-live, we only mark it as
59 ;;; live when it is in scope at NODE.
60 (defun compute-live-vars (live node block var-locs vop)
61   (declare (type ir2-block block) (type local-tn-bit-vector live)
62            (type hash-table var-locs) (type node node)
63            (type (or vop null) vop))
64   (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
65                          :element-type 'bit
66                          :initial-element 0))
67         (spilled (gethash vop
68                           (ir2-component-spilled-vops
69                            (component-info *component-being-compiled*)))))
70     (do-live-tns (tn live block)
71       (let ((leaf (tn-leaf tn)))
72         (when (and (lambda-var-p leaf)
73                    (or (not (member (tn-kind tn)
74                                     '(:environment :debug-environment)))
75                        (rassoc leaf (lexenv-vars (node-lexenv node))))
76                    (or (null spilled)
77                        (not (member tn spilled))))
78           (let ((num (gethash leaf var-locs)))
79             (when num
80               (setf (sbit res num) 1))))))
81     res))
82
83 ;;; The PC for the location most recently dumped.
84 (defvar *previous-location*)
85 (declaim (type index *previous-location*))
86
87 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
88 ;;; the code/source map and live info. If true, VOP is the VOP
89 ;;; associated with this location, for use in determining whether TNs
90 ;;; are spilled.
91 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
92   (declare (type node node) (type ir2-block block)
93            (type (or null local-tn-bit-vector) live)
94            (type (or label index) label)
95            (type location-kind kind) (type (or index null) tlf-num)
96            (type hash-table var-locs) (type (or vop null) vop))
97
98   (vector-push-extend
99    (dpb (position-or-lose kind *compiled-code-location-kinds*)
100         compiled-code-location-kind-byte
101         0)
102    *byte-buffer*)
103
104   (let ((loc (if (fixnump label) label (label-position label))))
105     (write-var-integer (- loc *previous-location*) *byte-buffer*)
106     (setq *previous-location* loc))
107
108   (let ((path (node-source-path node)))
109     (unless tlf-num
110       (write-var-integer (source-path-tlf-number path) *byte-buffer*))
111     (write-var-integer (source-path-form-number path) *byte-buffer*))
112
113   (if live
114       (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
115                                *byte-buffer*)
116       (write-packed-bit-vector
117        (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
118                    :initial-element 0
119                    :element-type 'bit)
120        *byte-buffer*))
121
122   (write-var-string (or (and (typep node 'combination)
123                              (combination-step-info node))
124                         "")
125                     *byte-buffer*)
126   (values))
127
128 ;;; Extract context info from a Location-Info structure and use it to
129 ;;; dump a compiled code-location.
130 (defun dump-location-from-info (loc tlf-num var-locs)
131   (declare (type location-info loc) (type (or index null) tlf-num)
132            (type hash-table var-locs))
133   (let ((vop (location-info-vop loc)))
134     (dump-1-location (vop-node vop)
135                      (vop-block vop)
136                      (location-info-kind loc)
137                      tlf-num
138                      (location-info-label loc)
139                      (vop-save-set vop)
140                      var-locs
141                      vop))
142   (values))
143
144 ;;; Scan all the blocks, determining if all locations are in the same
145 ;;; TLF, and returning it or NIL.
146 (defun find-tlf-number (fun)
147   (declare (type clambda fun))
148   (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
149     (declare (type (or index null) res))
150     (do-physenv-ir2-blocks (2block (lambda-physenv fun))
151       (let ((block (ir2-block-block 2block)))
152         (when (eq (block-info block) 2block)
153           (unless (eql (source-path-tlf-number
154                         (node-source-path
155                          (block-start-node block)))
156                        res)
157             (setq res nil)))
158
159         (dolist (loc (ir2-block-locations 2block))
160           (unless (eql (source-path-tlf-number
161                         (node-source-path
162                          (vop-node (location-info-vop loc))))
163                        res)
164             (setq res nil)))))
165     res))
166
167 ;;; Dump out the number of locations and the locations for Block.
168 (defun dump-block-locations (block locations tlf-num var-locs)
169   (declare (type cblock block) (list locations))
170   (if (and locations
171            (eq (location-info-kind (first locations))
172                :non-local-entry))
173       (write-var-integer (length locations) *byte-buffer*)
174       (let ((2block (block-info block)))
175         (write-var-integer (+ (length locations) 1) *byte-buffer*)
176         (dump-1-location (block-start-node block)
177                          2block :block-start tlf-num
178                          (ir2-block-%label 2block)
179                          (ir2-block-live-out 2block)
180                          var-locs
181                          nil)))
182   (dolist (loc locations)
183     (dump-location-from-info loc tlf-num var-locs))
184   (values))
185
186 ;;; Dump the successors of Block, being careful not to fly into space
187 ;;; on weird successors.
188 (defun dump-block-successors (block physenv)
189   (declare (type cblock block) (type physenv physenv))
190   (let* ((tail (component-tail (block-component block)))
191          (succ (block-succ block))
192          (valid-succ
193           (if (and succ
194                    (or (eq (car succ) tail)
195                        (not (eq (block-physenv (car succ)) physenv))))
196               ()
197               succ)))
198     (vector-push-extend
199      (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
200      *byte-buffer*)
201     (let ((base (block-number
202                  (node-block
203                   (lambda-bind (physenv-lambda physenv))))))
204       (dolist (b valid-succ)
205         (write-var-integer
206          (the index (- (block-number b) base))
207          *byte-buffer*))))
208   (values))
209
210 ;;; Return a vector and an integer (or null) suitable for use as the
211 ;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. This requires two
212 ;;; passes to compute:
213 ;;; -- Scan all blocks, dumping the header and successors followed
214 ;;;    by all the non-elsewhere locations.
215 ;;; -- Dump the elsewhere block header and all the elsewhere
216 ;;;    locations (if any.)
217 (defun compute-debug-blocks (fun var-locs)
218   (declare (type clambda fun) (type hash-table var-locs))
219   (setf (fill-pointer *byte-buffer*) 0)
220   (let ((*previous-location* 0)
221         (tlf-num (find-tlf-number fun))
222         (physenv (lambda-physenv fun))
223         (prev-locs nil)
224         (prev-block nil))
225     (collect ((elsewhere))
226       (do-physenv-ir2-blocks (2block physenv)
227         (let ((block (ir2-block-block 2block)))
228           (when (eq (block-info block) 2block)
229             (when prev-block
230               (dump-block-locations prev-block prev-locs tlf-num var-locs))
231             (setq prev-block block  prev-locs ())
232             (dump-block-successors block physenv)))
233
234         (collect ((here prev-locs))
235           (dolist (loc (ir2-block-locations 2block))
236             (if (label-elsewhere-p (location-info-label loc))
237                 (elsewhere loc)
238                 (here loc)))
239           (setq prev-locs (here))))
240
241       (dump-block-locations prev-block prev-locs tlf-num var-locs)
242
243       (when (elsewhere)
244         (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
245         (write-var-integer (length (elsewhere)) *byte-buffer*)
246         (dolist (loc (elsewhere))
247           (dump-location-from-info loc tlf-num var-locs))))
248
249     (values (copy-seq *byte-buffer*) tlf-num)))
250 \f
251 ;;; Return DEBUG-SOURCE structure containing information derived from
252 ;;; INFO.
253 (defun debug-source-for-info (info &key function)
254   (declare (type source-info info))
255   (let ((file-info (get-toplevelish-file-info info)))
256     (make-debug-source
257      :compiled (source-info-start-time info)
258
259      :namestring (or *source-namestring*
260                      (make-file-info-namestring
261                       (if (pathnamep (file-info-name file-info))
262                           (file-info-name file-info))
263                       file-info))
264      :created (file-info-write-date file-info)
265      :source-root (file-info-source-root file-info)
266      :start-positions (coerce-to-smallest-eltype
267                        (file-info-positions file-info))
268
269      :form (let ((direct-file-info (source-info-file-info info)))
270              (when (eq :lisp (file-info-name direct-file-info))
271                (let ((form (elt (file-info-forms direct-file-info) 0)))
272                  ;; The form COMPILE saves may include gunk
273                  ;; from %SIMPLE-EVAL -- this gets rid of that.
274                  (sb!impl::eval-lambda-source-lambda form))))
275      :function function)))
276
277 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
278 ;;; possible. Ordinarily we coerce it to the smallest specialized
279 ;;; vector we can. However, we also have a special hack for
280 ;;; cross-compiling at bootstrap time, when arbitrarily-specialized
281 ;;; vectors aren't fully supported: in that case, we coerce it only to
282 ;;; a vector whose element size is an integer multiple of output byte
283 ;;; size.
284 (defun coerce-to-smallest-eltype (seq)
285   (let ((maxoid 0))
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       (let ((specializer `(unsigned-byte
298                            ,(etypecase maxoid
299                               ((unsigned-byte 8) 8)
300                               ((unsigned-byte 16) 16)
301                               ((unsigned-byte 32) 32)))))
302         ;; cross-compilers beware! It would be possible for the
303         ;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be
304         ;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is
305         ;; completely valid by ANSI.  However, the cross-compiler
306         ;; doesn't know how to dump (in practice) anything but the
307         ;; above three specialized array types, so make it break here
308         ;; if this is violated.
309         #+sb-xc-host
310         (aver
311          ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
312          ;; worried about whether the host's implementation of arrays.
313          (let ((uaet (upgraded-array-element-type specializer)))
314            (dolist (et '((unsigned-byte 8)
315                          (unsigned-byte 16)
316                          (unsigned-byte 32))
317                     nil)
318              (when (and (subtypep et uaet) (subtypep uaet et))
319                (return t)))))
320         (coerce seq `(simple-array ,specializer (*)))))))
321 \f
322 ;;;; variables
323
324 ;;; Return a SC-OFFSET describing TN's location.
325 (defun tn-sc-offset (tn)
326   (declare (type tn tn))
327   (make-sc-offset (sc-number (tn-sc tn))
328                   (tn-offset tn)))
329
330 (defun lambda-ancestor-p (maybe-ancestor maybe-descendant)
331   (declare (type clambda maybe-ancestor)
332            (type (or clambda null) maybe-descendant))
333   (loop
334      (when (eq maybe-ancestor maybe-descendant)
335        (return t))
336      (setf maybe-descendant (lambda-parent maybe-descendant))
337      (when (null maybe-descendant)
338        (return nil))))
339
340 ;;; Dump info to represent VAR's location being TN. ID is an integer
341 ;;; that makes VAR's name unique in the function. BUFFER is the vector
342 ;;; we stick the result in. If MINIMAL, we suppress name dumping, and
343 ;;; set the minimal flag.
344 ;;;
345 ;;; The DEBUG-VAR is only marked as always-live if the TN is
346 ;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
347 ;;; then we also exclude set variables, since the variable is not
348 ;;; guaranteed to be live everywhere in that case.
349 (defun dump-1-var (fun var tn id minimal buffer)
350   (declare (type lambda-var var) (type (or tn null) tn) (type index id)
351            (type clambda fun))
352   (let* ((name (leaf-debug-name var))
353          (save-tn (and tn (tn-save-tn tn)))
354          (kind (and tn (tn-kind tn)))
355          (flags 0)
356          (info (lambda-var-arg-info var)))
357     (declare (type index flags))
358     (when minimal
359       (setq flags (logior flags compiled-debug-var-minimal-p))
360       (unless (and tn (tn-offset tn))
361         (setq flags (logior flags compiled-debug-var-deleted-p))))
362     (when (and (or (eq kind :environment)
363                    (and (eq kind :debug-environment)
364                         (null (basic-var-sets var))))
365                (not (gethash tn (ir2-component-spilled-tns
366                                  (component-info *component-being-compiled*))))
367                (lambda-ancestor-p (lambda-var-home var) fun))
368       (setq flags (logior flags compiled-debug-var-environment-live)))
369     (when save-tn
370       (setq flags (logior flags compiled-debug-var-save-loc-p)))
371     (unless (or (zerop id) minimal)
372       (setq flags (logior flags compiled-debug-var-id-p)))
373     (when info
374       (case (arg-info-kind info)
375         (:more-context
376          (setq flags (logior flags compiled-debug-var-more-context-p)))
377         (:more-count
378          (setq flags (logior flags compiled-debug-var-more-count-p)))))
379     (vector-push-extend flags buffer)
380     (unless minimal
381       (vector-push-extend name buffer)
382       (unless (zerop id)
383         (vector-push-extend id buffer)))
384     (if (and tn (tn-offset tn))
385         (vector-push-extend (tn-sc-offset tn) buffer)
386         (aver minimal))
387     (when save-tn
388       (vector-push-extend (tn-sc-offset save-tn) buffer)))
389   (values))
390
391 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS
392 ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
393 ;;; hash table in which we enter the translation from LAMBDA-VARS to
394 ;;; the relative position of that variable's location in the resulting
395 ;;; vector.
396 (defun compute-vars (fun level var-locs)
397   (declare (type clambda fun) (type hash-table var-locs))
398   (collect ((vars))
399     (labels ((frob-leaf (leaf tn gensym-p)
400                (let ((name (leaf-debug-name leaf)))
401                  (when (and name (leaf-refs leaf) (tn-offset tn)
402                             (or gensym-p (symbol-package name)))
403                    (vars (cons leaf tn)))))
404              (frob-lambda (x gensym-p)
405                (dolist (leaf (lambda-vars x))
406                  (frob-leaf leaf (leaf-info leaf) gensym-p))))
407       (frob-lambda fun t)
408       (when (>= level 2)
409         (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
410           (let ((thing (car x)))
411             (when (lambda-var-p thing)
412               (frob-leaf thing (cdr x) (= level 3)))))
413
414         (dolist (let (lambda-lets fun))
415           (frob-lambda let (= level 3)))))
416
417     (let ((sorted (sort (vars) #'string<
418                         :key (lambda (x)
419                                (symbol-name (leaf-debug-name (car x))))))
420           (prev-name nil)
421           (id 0)
422           (i 0)
423           (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
424       (declare (type (or simple-string null) prev-name)
425                (type index id i))
426       (dolist (x sorted)
427         (let* ((var (car x))
428                (name (symbol-name (leaf-debug-name var))))
429           (cond ((and prev-name (string= prev-name name))
430                  (incf id))
431                 (t
432                  (setq id 0  prev-name name)))
433           (dump-1-var fun var (cdr x) id nil buffer)
434           (setf (gethash var var-locs) i)
435           (incf i)))
436       (coerce buffer 'simple-vector))))
437
438 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
439 ;;; FUN, representing the arguments to FUN in minimal variable format.
440 (defun compute-minimal-vars (fun)
441   (declare (type clambda fun))
442   (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
443     (dolist (var (lambda-vars fun))
444       (dump-1-var fun var (leaf-info var) 0 t buffer))
445     (coerce buffer 'simple-vector)))
446
447 ;;; Return VAR's relative position in the function's variables (determined
448 ;;; from the VAR-LOCS hashtable).  If VAR is deleted, then return DELETED.
449 (defun debug-location-for (var var-locs)
450   (declare (type lambda-var var) (type hash-table var-locs))
451   (let ((res (gethash var var-locs)))
452     (cond (res)
453           (t
454            (aver (or (null (leaf-refs var))
455                      (not (tn-offset (leaf-info var)))))
456            'deleted))))
457 \f
458 ;;;; arguments/returns
459
460 ;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
461 ;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
462 ;;; the ARGLIST to determine the syntax, otherwise pretend all
463 ;;; arguments are fixed.
464 ;;;
465 ;;; ### This assumption breaks down in EPs other than the main-entry,
466 ;;; since they may or may not have supplied-p vars, etc.
467 (defun compute-args (fun var-locs)
468   (declare (type clambda fun) (type hash-table var-locs))
469   (collect ((res))
470     (let ((od (lambda-optional-dispatch fun)))
471       (if (and od (eq (optional-dispatch-main-entry od) fun))
472           (let ((actual-vars (lambda-vars fun))
473                 (saw-optional nil))
474             (labels ((one-arg (arg)
475                        (let ((info (lambda-var-arg-info arg))
476                              (actual (pop actual-vars)))
477                          (cond (info
478                                 (case (arg-info-kind info)
479                                   (:keyword
480                                    (res (arg-info-key info)))
481                                   (:rest
482                                    (let ((more (arg-info-default info)))
483                                      (cond ((and (consp more) (third more))
484                                             (one-arg (first (arg-info-default info)))
485                                             (one-arg (second (arg-info-default info)))
486                                             (return-from one-arg))
487                                            (more
488                                             (setf (arg-info-default info) t)))
489                                      (res 'rest-arg)))
490                                   (:more-context
491                                    (res 'more-arg))
492                                   (:optional
493                                    (unless saw-optional
494                                      (res 'optional-args)
495                                      (setq saw-optional t))))
496                                 (res (debug-location-for actual var-locs))
497                                 (when (arg-info-supplied-p info)
498                                   (res 'supplied-p)
499                                   (res (debug-location-for (pop actual-vars) var-locs))))
500                                 (t
501                                  (res (debug-location-for actual var-locs)))))))
502               (dolist (arg (optional-dispatch-arglist od))
503                 (one-arg arg))))
504           (dolist (var (lambda-vars fun))
505             (res (debug-location-for var var-locs)))))
506
507     (coerce-to-smallest-eltype (res))))
508
509 ;;; Return a vector of SC offsets describing FUN's return locations.
510 ;;; (Must be known values return...)
511 (defun compute-debug-returns (fun)
512   (coerce-to-smallest-eltype
513    (mapcar (lambda (loc)
514              (tn-sc-offset loc))
515            (return-info-locations (tail-set-info (lambda-tail-set fun))))))
516 \f
517 ;;;; debug functions
518
519 ;;; Return a C-D-F structure with all the mandatory slots filled in.
520 (defun dfun-from-fun (fun)
521   (declare (type clambda fun))
522   (let* ((2env (physenv-info (lambda-physenv fun)))
523          (dispatch (lambda-optional-dispatch fun))
524          (main-p (and dispatch
525                       (eq fun (optional-dispatch-main-entry dispatch)))))
526     (make-compiled-debug-fun
527      :name (leaf-debug-name fun)
528      :kind (if main-p nil (functional-kind fun))
529      :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env))
530      :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env))
531      :start-pc (label-position (ir2-physenv-environment-start 2env))
532      :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)))))
533
534 ;;; Return a complete C-D-F structure for FUN. This involves
535 ;;; determining the DEBUG-INFO level and filling in optional slots as
536 ;;; appropriate.
537 (defun compute-1-debug-fun (fun var-locs)
538   (declare (type clambda fun) (type hash-table var-locs))
539   (let* ((dfun (dfun-from-fun fun))
540          (actual-level (policy (lambda-bind fun) compute-debug-fun))
541          (level (if #!+sb-dyncount *collect-dynamic-statistics*
542                     #!-sb-dyncount nil
543                     (max actual-level 2)
544                     actual-level)))
545     (cond ((zerop level))
546           ((and (<= level 1)
547                 (let ((od (lambda-optional-dispatch fun)))
548                   (or (not od)
549                       (not (eq (optional-dispatch-main-entry od) fun)))))
550            (setf (compiled-debug-fun-vars dfun)
551                  (compute-minimal-vars fun))
552            (setf (compiled-debug-fun-arguments dfun) :minimal))
553           (t
554            (setf (compiled-debug-fun-vars dfun)
555                  (compute-vars fun level var-locs))
556            (setf (compiled-debug-fun-arguments dfun)
557                  (compute-args fun var-locs))))
558
559     (if (>= level 2)
560         (multiple-value-bind (blocks tlf-num)
561             (compute-debug-blocks fun var-locs)
562           (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
563           (setf (compiled-debug-fun-blocks dfun) blocks))
564         (setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
565
566     (if (xep-p fun)
567         (setf (compiled-debug-fun-returns dfun) :standard)
568         (let ((info (tail-set-info (lambda-tail-set fun))))
569           (when info
570             (cond ((eq (return-info-kind info) :unknown)
571                    (setf (compiled-debug-fun-returns dfun)
572                          :standard))
573                   ((/= level 0)
574                    (setf (compiled-debug-fun-returns dfun)
575                          (compute-debug-returns fun)))))))
576     dfun))
577 \f
578 ;;;; full component dumping
579
580 ;;; Compute the full form (simple-vector) function map.
581 (defun compute-debug-fun-map (sorted)
582   (declare (list sorted))
583   (let* ((len (1- (* (length sorted) 2)))
584          (funs-vec (make-array len)))
585     (do ((i -1 (+ i 2))
586          (sorted sorted (cdr sorted)))
587         ((= i len))
588       (declare (fixnum i))
589       (let ((dfun (car sorted)))
590         (unless (minusp i)
591           (setf (svref funs-vec i) (car dfun)))
592         (setf (svref funs-vec (1+ i)) (cdr dfun))))
593     funs-vec))
594
595 ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
596 ;;; called after assembly so that source map information is available.
597 (defun debug-info-for-component (component)
598   (declare (type component component))
599   (let ((dfuns nil)
600         (var-locs (make-hash-table :test 'eq))
601         (*byte-buffer* (make-array 10
602                                    :element-type '(unsigned-byte 8)
603                                    :fill-pointer 0
604                                    :adjustable t)))
605     (dolist (lambda (component-lambdas component))
606       (clrhash var-locs)
607       (push (cons (label-position (block-label (lambda-block lambda)))
608                   (compute-1-debug-fun lambda var-locs))
609             dfuns))
610     (let* ((sorted (sort dfuns #'< :key #'car))
611            (fun-map (compute-debug-fun-map sorted)))
612       (make-compiled-debug-info :name (component-name component)
613                                 :fun-map fun-map))))
614 \f
615 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
616 ;;; BITS must be evenly divisible by eight.
617 (defun write-packed-bit-vector (bits byte-buffer)
618   (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
619
620   ;; Enforce constraint from CMU-CL-era comment.
621   (aver (zerop (mod (length bits) 8)))
622
623   (multiple-value-bind (initial step done)
624       (ecase *backend-byte-order*
625         (:little-endian (values 0  1  8))
626         (:big-endian    (values 7 -1 -1)))
627     (let ((shift initial)
628           (byte 0))
629       (dotimes (i (length bits))
630         (let ((int (aref bits i)))
631           (setf byte (logior byte (ash int shift)))
632           (incf shift step))
633         (when (= shift done)
634           (vector-push-extend byte byte-buffer)
635           (setf shift initial
636                 byte 0)))
637       (unless (= shift initial)
638         (vector-push-extend byte byte-buffer))))
639   (values))