1 ;;;; stuff that creates debugger information from the compiler's
2 ;;;; internal data structures
4 ;;;; This software is part of the SBCL system. See the README file for
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.
15 (deftype byte-buffer () '(vector (unsigned-byte 8)))
16 (defvar *byte-buffer*)
17 (declaim (type byte-buffer *byte-buffer*))
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))
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.)
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))
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)))
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)
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))))
74 (not (member tn spilled))))
75 (let ((num (gethash leaf var-locs)))
77 (setf (sbit res num) 1))))))
80 ;;; The PC for the location most recently dumped.
81 (defvar *previous-location*)
82 (declaim (type index *previous-location*))
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))
95 (dpb (position-or-lose kind compiled-code-location-kinds)
96 compiled-code-location-kind-byte
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))
104 (let ((path (node-source-path node)))
106 (write-var-integer (source-path-tlf-number path) *byte-buffer*))
107 (write-var-integer (source-path-form-number path) *byte-buffer*))
109 (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
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)
122 (location-info-kind loc)
124 (location-info-label loc)
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
142 (block-start block))))
146 (dolist (loc (ir2-block-locations 2block))
147 (unless (eql (source-path-tlf-number
149 (vop-node (location-info-vop loc))))
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))
158 (eq (location-info-kind (first locations))
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)
169 (dolist (loc locations)
170 (dump-location-from-info loc tlf-num var-locs))
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))
181 (or (eq (car succ) tail)
182 (not (eq (block-environment (car succ)) env))))
186 (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
188 (let ((base (block-number
190 (lambda-bind (environment-function env))))))
191 (dolist (b valid-succ)
193 (the index (- (block-number b) base))
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
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
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))
212 (collect ((elsewhere))
213 (do-environment-ir2-blocks (2block env)
214 (let ((block (ir2-block-block 2block)))
215 (when (eq (block-info block) 2block)
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)))
221 (collect ((here prev-locs))
222 (dolist (loc (ir2-block-locations 2block))
223 (if (label-elsewhere-p (location-info-label loc))
226 (setq prev-locs (here))))
228 (dump-block-locations prev-block prev-locs tlf-num var-locs)
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))))
236 (values (copy-seq *byte-buffer*) tlf-num)))
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
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
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)
253 (unless (eq *byte-compile* 't)
254 (coerce-to-smallest-eltype
255 (file-info-positions x)))))
256 (name (file-info-name x)))
259 (setf (debug-source-from res) name)
260 (setf (debug-source-name res)
261 (coerce (file-info-forms x) 'simple-vector)))
263 (let* ((untruename (file-info-untruename x))
264 (dir (pathname-directory untruename)))
265 (setf (debug-source-name res)
267 (if (and dir (eq (first dir) :absolute))
271 (source-info-files info)))
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
287 (if (typep x 'unsigned-byte)
290 (return-from coerce-to-smallest-eltype
291 (coerce seq 'simple-vector)))))
297 (coerce seq `(simple-array (integer 0 ,maxoid) (*))))))
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))
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
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)
319 (let* ((name (leaf-name var))
320 (save-tn (and tn (tn-save-tn tn)))
321 (kind (and tn (tn-kind tn)))
323 (declare (type index flags))
325 (setq flags (logior flags compiled-debug-var-minimal-p))
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)))
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)
341 (vector-push-extend name buffer)
343 (vector-push-extend id buffer)))
345 (vector-push-extend (tn-sc-offset tn) buffer)
348 (vector-push-extend (tn-sc-offset save-tn) buffer)))
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))
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))))
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)))))
374 (dolist (let (lambda-lets fun))
375 (frob-lambda let (= level 3)))))
377 (let ((sorted (sort (vars) #'string<
379 (symbol-name (leaf-name (car x))))))
383 (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
384 (declare (type (or simple-string null) prev-name)
388 (name (symbol-name (leaf-name var))))
389 (cond ((and prev-name (string= prev-name name))
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))
396 (coerce buffer 'simple-vector))))
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)))
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)))
414 (assert (or (null (leaf-refs var))
415 (not (tn-offset (leaf-info var)))))
418 ;;;; arguments/returns
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.
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))
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))
433 (dolist (arg (optional-dispatch-arglist od))
434 (let ((info (lambda-var-arg-info arg))
435 (actual (pop actual-vars)))
437 (case (arg-info-kind info)
439 (res (arg-info-keyword info)))
447 (setq saw-optional t))))
448 (res (debug-location-for actual var-locs))
449 (when (arg-info-supplied-p info)
451 (res (debug-location-for (pop actual-vars) var-locs))))
453 (res (debug-location-for actual var-locs)))))))
454 (dolist (var (lambda-vars fun))
455 (res (debug-location-for var var-locs)))))
457 (coerce-to-smallest-eltype (res))))
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)
465 (return-info-locations (tail-set-info (lambda-tail-set fun))))))
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
480 (and ef (leaf-name ef))))
481 ((and main-p (leaf-name dispatch)))
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)))))
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))
497 (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
498 (level (if #!+sb-dyncount *collect-dynamic-statistics*
502 (cond ((zerop level))
504 (let ((od (lambda-optional-dispatch fun)))
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))
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))))
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)))
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))))
525 (cond ((eq (return-info-kind info) :unknown)
526 (setf (compiled-debug-function-returns dfun)
529 (setf (compiled-debug-function-returns dfun)
530 (compute-debug-returns fun)))))))
533 ;;;; minimal debug functions
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)))))
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)))
557 (cond ((stringp base-name)
558 minimal-debug-function-name-component)
560 minimal-debug-function-name-uninterned)
562 minimal-debug-function-name-symbol)
564 minimal-debug-function-name-packaged))))
565 (assert (or (atom name) setf-p))
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*))
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*))
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*))
592 (let ((vars (compiled-debug-function-variables dfun)))
594 (let ((len (length vars)))
595 (write-var-integer len *byte-buffer*)
597 (vector-push-extend (aref vars i) *byte-buffer*)))))
599 (let ((returns (compiled-debug-function-returns dfun)))
600 (when (vectorp returns)
601 (let ((len (length returns)))
602 (write-var-integer len *byte-buffer*)
604 (write-var-integer (aref returns i) *byte-buffer*)))))
606 (write-var-integer (compiled-debug-function-return-pc dfun)
608 (write-var-integer (compiled-debug-function-old-fp dfun)
610 (when (compiled-debug-function-nfp dfun)
611 (write-var-integer (compiled-debug-function-nfp dfun)
613 (write-var-integer (- start prev-start) *byte-buffer*)
614 (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
616 (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
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)
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*))
634 ;;;; full component dumping
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)))
642 (sorted sorted (cdr sorted)))
645 (let ((dfun (car sorted)))
647 (setf (svref funs-vec i) (car dfun)))
648 (setf (svref funs-vec (1+ i)) (cdr dfun))))
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))
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)
663 (dolist (fun (component-lambdas component))
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))
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)))))
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)
692 (dotimes (i (length bits))
693 (let ((int (aref bits i)))
694 (setf byte (logior byte (ash int shift)))
697 (vector-push-extend byte byte-buffer)
700 (unless (= shift initial)
701 (vector-push-extend byte byte-buffer))))