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
26 ;;; about locations which code generation decided were "interesting".
27 (defstruct (location-info
28 (:constructor make-location-info
(kind label vop
))
30 ;; The kind of location noted.
31 (kind nil
:type location-kind
)
32 ;; The label pointing to the interesting code location.
33 (label nil
:type
(or label index null
))
34 ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
37 ;;; This is called during code generation in places where there is an
38 ;;; "interesting" location: someplace where we are likely to end up
39 ;;; in the debugger, and thus want debug info.
40 (defun note-debug-location (vop label kind
)
41 (declare (type vop vop
) (type (or label null
) label
)
42 (type location-kind kind
))
43 (let ((location (make-location-info kind label vop
)))
44 (setf (ir2-block-locations (vop-block vop
))
45 (nconc (ir2-block-locations (vop-block vop
))
49 #!-sb-fluid
(declaim (inline ir2-block-physenv
))
50 (defun ir2-block-physenv (2block)
51 (declare (type ir2-block
2block
))
52 (block-physenv (ir2-block-block 2block
)))
54 ;;; Given a local conflicts vector and an IR2 block to represent the
55 ;;; set of live TNs, and the VAR-LOCS hash-table representing the
56 ;;; variables dumped, compute a bit-vector representing the set of
57 ;;; live variables. If the TN is environment-live, we only mark it as
58 ;;; live when it is in scope at NODE.
59 (defun compute-live-vars (live node block var-locs vop
)
60 (declare (type ir2-block block
) (type local-tn-bit-vector live
)
61 (type hash-table var-locs
) (type node node
)
62 (type (or vop null
) vop
))
63 (let ((res (make-array (logandc2 (+ (hash-table-count var-locs
) 7) 7)
67 (ir2-component-spilled-vops
68 (component-info *component-being-compiled
*)))))
69 (do-live-tns (tn live block
)
70 (let ((leaf (tn-leaf tn
)))
71 (when (and (lambda-var-p leaf
)
72 (or (not (member (tn-kind tn
)
73 '(:environment
:debug-environment
)))
74 (rassoc leaf
(lexenv-vars (node-lexenv node
))))
76 (not (member tn spilled
))))
77 (let ((num (gethash leaf var-locs
)))
79 (setf (sbit res num
) 1))))))
82 ;;; The PC for the location most recently dumped.
83 (defvar *previous-location
*)
84 (declaim (type index
*previous-location
*))
86 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
87 ;;; the code/source map and live info. If true, VOP is the VOP
88 ;;; associated with this location, for use in determining whether TNs
90 (defun dump-1-location (node block kind tlf-num label live var-locs vop
)
91 (declare (type node node
) (type ir2-block block
)
92 (type local-tn-bit-vector live
)
93 (type (or label index
) label
)
94 (type location-kind kind
) (type (or index null
) tlf-num
)
95 (type hash-table var-locs
) (type (or vop null
) vop
))
98 (dpb (position-or-lose kind
*compiled-code-location-kinds
*)
99 compiled-code-location-kind-byte
103 (let ((loc (if (fixnump label
) label
(label-position label
))))
104 (write-var-integer (- loc
*previous-location
*) *byte-buffer
*)
105 (setq *previous-location
* loc
))
107 (let ((path (node-source-path node
)))
109 (write-var-integer (source-path-tlf-number path
) *byte-buffer
*))
110 (write-var-integer (source-path-form-number path
) *byte-buffer
*))
112 (write-packed-bit-vector (compute-live-vars live node block var-locs vop
)
117 ;;; Extract context info from a Location-Info structure and use it to
118 ;;; dump a compiled code-location.
119 (defun dump-location-from-info (loc tlf-num var-locs
)
120 (declare (type location-info loc
) (type (or index null
) tlf-num
)
121 (type hash-table var-locs
))
122 (let ((vop (location-info-vop loc
)))
123 (dump-1-location (vop-node vop
)
125 (location-info-kind loc
)
127 (location-info-label loc
)
133 ;;; Scan all the blocks, determining if all locations are in the same
134 ;;; TLF, and returning it or NIL.
135 (defun find-tlf-number (fun)
136 (declare (type clambda fun
))
137 (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun
)))))
138 (declare (type (or index null
) res
))
139 (do-physenv-ir2-blocks (2block (lambda-physenv fun
))
140 (let ((block (ir2-block-block 2block
)))
141 (when (eq (block-info block
) 2block
)
142 (unless (eql (source-path-tlf-number
144 (block-start-node block
)))
148 (dolist (loc (ir2-block-locations 2block
))
149 (unless (eql (source-path-tlf-number
151 (vop-node (location-info-vop loc
))))
156 ;;; Dump out the number of locations and the locations for Block.
157 (defun dump-block-locations (block locations tlf-num var-locs
)
158 (declare (type cblock block
) (list locations
))
160 (eq (location-info-kind (first locations
))
162 (write-var-integer (length locations
) *byte-buffer
*)
163 (let ((2block (block-info block
)))
164 (write-var-integer (+ (length locations
) 1) *byte-buffer
*)
165 (dump-1-location (block-start-node block
)
166 2block
:block-start tlf-num
167 (ir2-block-%label
2block
)
168 (ir2-block-live-out 2block
)
171 (dolist (loc locations
)
172 (dump-location-from-info loc tlf-num var-locs
))
175 ;;; Dump the successors of Block, being careful not to fly into space
176 ;;; on weird successors.
177 (defun dump-block-successors (block physenv
)
178 (declare (type cblock block
) (type physenv physenv
))
179 (let* ((tail (component-tail (block-component block
)))
180 (succ (block-succ block
))
183 (or (eq (car succ
) tail
)
184 (not (eq (block-physenv (car succ
)) physenv
))))
188 (dpb (length valid-succ
) compiled-debug-block-nsucc-byte
0)
190 (let ((base (block-number
192 (lambda-bind (physenv-lambda physenv
))))))
193 (dolist (b valid-succ
)
195 (the index
(- (block-number b
) base
))
199 ;;; Return a vector and an integer (or null) suitable for use as the
200 ;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. This requires two
201 ;;; passes to compute:
202 ;;; -- Scan all blocks, dumping the header and successors followed
203 ;;; by all the non-elsewhere locations.
204 ;;; -- Dump the elsewhere block header and all the elsewhere
205 ;;; locations (if any.)
206 (defun compute-debug-blocks (fun var-locs
)
207 (declare (type clambda fun
) (type hash-table var-locs
))
208 (setf (fill-pointer *byte-buffer
*) 0)
209 (let ((*previous-location
* 0)
210 (tlf-num (find-tlf-number fun
))
211 (physenv (lambda-physenv fun
))
214 (collect ((elsewhere))
215 (do-physenv-ir2-blocks (2block physenv
)
216 (let ((block (ir2-block-block 2block
)))
217 (when (eq (block-info block
) 2block
)
219 (dump-block-locations prev-block prev-locs tlf-num var-locs
))
220 (setq prev-block block prev-locs
())
221 (dump-block-successors block physenv
)))
223 (collect ((here prev-locs
))
224 (dolist (loc (ir2-block-locations 2block
))
225 (if (label-elsewhere-p (location-info-label loc
))
228 (setq prev-locs
(here))))
230 (dump-block-locations prev-block prev-locs tlf-num var-locs
)
233 (vector-push-extend compiled-debug-block-elsewhere-p
*byte-buffer
*)
234 (write-var-integer (length (elsewhere)) *byte-buffer
*)
235 (dolist (loc (elsewhere))
236 (dump-location-from-info loc tlf-num var-locs
))))
238 (values (copy-seq *byte-buffer
*) tlf-num
)))
240 ;;; Return DEBUG-SOURCE structure containing information derived from
242 (defun debug-source-for-info (info)
243 (declare (type source-info info
))
244 (let* ((file-info (source-info-file-info info
))
245 (res (make-debug-source
247 :created
(file-info-write-date file-info
)
248 :compiled
(source-info-start-time info
)
249 :source-root
(file-info-source-root file-info
)
250 :start-positions
(coerce-to-smallest-eltype
251 (file-info-positions file-info
))))
252 (name (file-info-name file-info
)))
255 (setf (debug-source-from res
) name
256 (debug-source-name res
) (file-info-forms file-info
)))
258 (let* ((untruename (file-info-untruename file-info
))
259 (dir (pathname-directory untruename
)))
260 (setf (debug-source-name res
)
262 (let ((src (position "src" dir
:test
#'string
= :from-end t
)))
264 (format nil
"SYS:~{~:@(~A~);~}~:@(~A~).LISP"
265 (subseq dir src
) (pathname-name untruename
))
266 ;; FIXME: just output/stuff-groveled-from-headers.lisp
267 (namestring untruename
)))
270 (if (and dir
(eq (first dir
) :absolute
))
275 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
276 ;;; possible. Ordinarily we coerce it to the smallest specialized
277 ;;; vector we can. However, we also have a special hack for
278 ;;; cross-compiling at bootstrap time, when arbitrarily-specialized
279 ;;; vectors aren't fully supported: in that case, we coerce it only to
280 ;;; a vector whose element size is an integer multiple of output byte
282 (defun coerce-to-smallest-eltype (seq)
285 (if (typep x
'unsigned-byte
)
288 (return-from coerce-to-smallest-eltype
289 (coerce seq
'simple-vector
)))))
295 (let ((specializer `(unsigned-byte
297 ((unsigned-byte 8) 8)
298 ((unsigned-byte 16) 16)
299 ((unsigned-byte 32) 32)))))
300 ;; cross-compilers beware! It would be possible for the
301 ;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be
302 ;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is
303 ;; completely valid by ANSI. However, the cross-compiler
304 ;; doesn't know how to dump (in practice) anything but the
305 ;; above three specialized array types, so make it break here
306 ;; if this is violated.
309 ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
310 ;; worried about whether the host's implementation of arrays.
311 (let ((uaet (upgraded-array-element-type specializer
)))
312 (dolist (et '((unsigned-byte 8)
316 (when (and (subtypep et uaet
) (subtypep uaet et
))
318 (coerce seq
`(simple-array ,specializer
(*)))))))
322 ;;; Return a SC-OFFSET describing TN's location.
323 (defun tn-sc-offset (tn)
324 (declare (type tn tn
))
325 (make-sc-offset (sc-number (tn-sc tn
))
328 ;;; Dump info to represent VAR's location being TN. ID is an integer
329 ;;; that makes VAR's name unique in the function. BUFFER is the vector
330 ;;; we stick the result in. If MINIMAL, we suppress name dumping, and
331 ;;; set the minimal flag.
333 ;;; The DEBUG-VAR is only marked as always-live if the TN is
334 ;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
335 ;;; then we also exclude set variables, since the variable is not
336 ;;; guaranteed to be live everywhere in that case.
337 (defun dump-1-var (fun var tn id minimal buffer
)
338 (declare (type lambda-var var
) (type (or tn null
) tn
) (type index id
)
340 (let* ((name (leaf-debug-name var
))
341 (save-tn (and tn
(tn-save-tn tn
)))
342 (kind (and tn
(tn-kind tn
)))
344 (declare (type index flags
))
346 (setq flags
(logior flags compiled-debug-var-minimal-p
))
348 (setq flags
(logior flags compiled-debug-var-deleted-p
))))
349 (when (and (or (eq kind
:environment
)
350 (and (eq kind
:debug-environment
)
351 (null (basic-var-sets var
))))
352 (not (gethash tn
(ir2-component-spilled-tns
353 (component-info *component-being-compiled
*))))
354 (eq (lambda-var-home var
) fun
))
355 (setq flags
(logior flags compiled-debug-var-environment-live
)))
357 (setq flags
(logior flags compiled-debug-var-save-loc-p
)))
358 (unless (or (zerop id
) minimal
)
359 (setq flags
(logior flags compiled-debug-var-id-p
)))
360 (vector-push-extend flags buffer
)
362 (vector-push-extend name buffer
)
364 (vector-push-extend id buffer
)))
366 (vector-push-extend (tn-sc-offset tn
) buffer
)
369 (vector-push-extend (tn-sc-offset save-tn
) buffer
)))
372 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS
373 ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
374 ;;; hash table in which we enter the translation from LAMBDA-VARS to
375 ;;; the relative position of that variable's location in the resulting
377 (defun compute-vars (fun level var-locs
)
378 (declare (type clambda fun
) (type hash-table var-locs
))
380 (labels ((frob-leaf (leaf tn gensym-p
)
381 (let ((name (leaf-debug-name leaf
)))
382 (when (and name
(leaf-refs leaf
) (tn-offset tn
)
383 (or gensym-p
(symbol-package name
)))
384 (vars (cons leaf tn
)))))
385 (frob-lambda (x gensym-p
)
386 (dolist (leaf (lambda-vars x
))
387 (frob-leaf leaf
(leaf-info leaf
) gensym-p
))))
390 (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun
))))
391 (let ((thing (car x
)))
392 (when (lambda-var-p thing
)
393 (frob-leaf thing
(cdr x
) (= level
3)))))
395 (dolist (let (lambda-lets fun
))
396 (frob-lambda let
(= level
3)))))
398 (let ((sorted (sort (vars) #'string
<
400 (symbol-name (leaf-debug-name (car x
))))))
404 (buffer (make-array 0 :fill-pointer
0 :adjustable t
)))
405 (declare (type (or simple-string null
) prev-name
)
409 (name (symbol-name (leaf-debug-name var
))))
410 (cond ((and prev-name
(string= prev-name name
))
413 (setq id
0 prev-name name
)))
414 (dump-1-var fun var
(cdr x
) id nil buffer
)
415 (setf (gethash var var-locs
) i
))
417 (coerce buffer
'simple-vector
))))
419 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
420 ;;; FUN, representing the arguments to FUN in minimal variable format.
421 (defun compute-minimal-vars (fun)
422 (declare (type clambda fun
))
423 (let ((buffer (make-array 0 :fill-pointer
0 :adjustable t
)))
424 (dolist (var (lambda-vars fun
))
425 (dump-1-var fun var
(leaf-info var
) 0 t buffer
))
426 (coerce buffer
'simple-vector
)))
428 ;;; Return VAR's relative position in the function's variables (determined
429 ;;; from the VAR-LOCS hashtable). If VAR is deleted, then return DELETED.
430 (defun debug-location-for (var var-locs
)
431 (declare (type lambda-var var
) (type hash-table var-locs
))
432 (let ((res (gethash var var-locs
)))
435 (aver (or (null (leaf-refs var
))
436 (not (tn-offset (leaf-info var
)))))
439 ;;;; arguments/returns
441 ;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
442 ;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
443 ;;; the ARGLIST to determine the syntax, otherwise pretend all
444 ;;; arguments are fixed.
446 ;;; ### This assumption breaks down in EPs other than the main-entry,
447 ;;; since they may or may not have supplied-p vars, etc.
448 (defun compute-args (fun var-locs
)
449 (declare (type clambda fun
) (type hash-table var-locs
))
451 (let ((od (lambda-optional-dispatch fun
)))
452 (if (and od
(eq (optional-dispatch-main-entry od
) fun
))
453 (let ((actual-vars (lambda-vars fun
))
455 (dolist (arg (optional-dispatch-arglist od
))
456 (let ((info (lambda-var-arg-info arg
))
457 (actual (pop actual-vars
)))
459 (case (arg-info-kind info
)
461 (res (arg-info-key info
)))
469 (setq saw-optional t
))))
470 (res (debug-location-for actual var-locs
))
471 (when (arg-info-supplied-p info
)
473 (res (debug-location-for (pop actual-vars
) var-locs
))))
475 (res (debug-location-for actual var-locs
)))))))
476 (dolist (var (lambda-vars fun
))
477 (res (debug-location-for var var-locs
)))))
479 (coerce-to-smallest-eltype (res))))
481 ;;; Return a vector of SC offsets describing FUN's return locations.
482 ;;; (Must be known values return...)
483 (defun compute-debug-returns (fun)
484 (coerce-to-smallest-eltype
485 (mapcar (lambda (loc)
487 (return-info-locations (tail-set-info (lambda-tail-set fun
))))))
491 ;;; Return a C-D-F structure with all the mandatory slots filled in.
492 (defun dfun-from-fun (fun)
493 (declare (type clambda fun
))
494 (let* ((2env (physenv-info (lambda-physenv fun
)))
495 (dispatch (lambda-optional-dispatch fun
))
496 (main-p (and dispatch
497 (eq fun
(optional-dispatch-main-entry dispatch
)))))
498 (make-compiled-debug-fun
499 :name
(leaf-debug-name fun
)
500 :kind
(if main-p nil
(functional-kind fun
))
501 :return-pc
(tn-sc-offset (ir2-physenv-return-pc 2env
))
502 :old-fp
(tn-sc-offset (ir2-physenv-old-fp 2env
))
503 :start-pc
(label-position (ir2-physenv-environment-start 2env
))
504 :elsewhere-pc
(label-position (ir2-physenv-elsewhere-start 2env
)))))
506 ;;; Return a complete C-D-F structure for FUN. This involves
507 ;;; determining the DEBUG-INFO level and filling in optional slots as
509 (defun compute-1-debug-fun (fun var-locs
)
510 (declare (type clambda fun
) (type hash-table var-locs
))
511 (let* ((dfun (dfun-from-fun fun
))
512 (actual-level (policy (lambda-bind fun
) debug
))
513 (level (if #!+sb-dyncount
*collect-dynamic-statistics
*
517 (cond ((zerop level
))
519 (let ((od (lambda-optional-dispatch fun
)))
521 (not (eq (optional-dispatch-main-entry od
) fun
)))))
522 (setf (compiled-debug-fun-vars dfun
)
523 (compute-minimal-vars fun
))
524 (setf (compiled-debug-fun-arguments dfun
) :minimal
))
526 (setf (compiled-debug-fun-vars dfun
)
527 (compute-vars fun level var-locs
))
528 (setf (compiled-debug-fun-arguments dfun
)
529 (compute-args fun var-locs
))))
532 (multiple-value-bind (blocks tlf-num
)
533 (compute-debug-blocks fun var-locs
)
534 (setf (compiled-debug-fun-tlf-number dfun
) tlf-num
)
535 (setf (compiled-debug-fun-blocks dfun
) blocks
))
536 (setf (compiled-debug-fun-tlf-number dfun
) (find-tlf-number fun
)))
539 (setf (compiled-debug-fun-returns dfun
) :standard
)
540 (let ((info (tail-set-info (lambda-tail-set fun
))))
542 (cond ((eq (return-info-kind info
) :unknown
)
543 (setf (compiled-debug-fun-returns dfun
)
546 (setf (compiled-debug-fun-returns dfun
)
547 (compute-debug-returns fun
)))))))
550 ;;;; full component dumping
552 ;;; Compute the full form (simple-vector) function map.
553 (defun compute-debug-fun-map (sorted)
554 (declare (list sorted
))
555 (let* ((len (1- (* (length sorted
) 2)))
556 (funs-vec (make-array len
)))
558 (sorted sorted
(cdr sorted
)))
561 (let ((dfun (car sorted
)))
563 (setf (svref funs-vec i
) (car dfun
)))
564 (setf (svref funs-vec
(1+ i
)) (cdr dfun
))))
567 ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
568 ;;; called after assembly so that source map information is available.
569 (defun debug-info-for-component (component)
570 (declare (type component component
))
572 (var-locs (make-hash-table :test
'eq
))
573 (*byte-buffer
* (make-array 10
574 :element-type
'(unsigned-byte 8)
577 (dolist (lambda (component-lambdas component
))
579 (push (cons (label-position (block-label (lambda-block lambda
)))
580 (compute-1-debug-fun lambda var-locs
))
582 (let* ((sorted (sort dfuns
#'< :key
#'car
))
583 (fun-map (compute-debug-fun-map sorted
)))
584 (make-compiled-debug-info :name
(component-name component
)
587 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
588 ;;; BITS must be evenly divisible by eight.
589 (defun write-packed-bit-vector (bits byte-buffer
)
590 (declare (type simple-bit-vector bits
) (type byte-buffer byte-buffer
))
592 ;; Enforce constraint from CMU-CL-era comment.
593 (aver (zerop (mod (length bits
) 8)))
595 (multiple-value-bind (initial step done
)
596 (ecase *backend-byte-order
*
597 (:little-endian
(values 0 1 8))
598 (:big-endian
(values 7 -
1 -
1)))
599 (let ((shift initial
)
601 (dotimes (i (length bits
))
602 (let ((int (aref bits i
)))
603 (setf byte
(logior byte
(ash int shift
)))
606 (vector-push-extend byte byte-buffer
)
609 (unless (= shift initial
)
610 (vector-push-extend byte byte-buffer
))))