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
145 (block-start block))))
149 (dolist (loc (ir2-block-locations 2block))
150 (unless (eql (source-path-tlf-number
152 (vop-node (location-info-vop loc))))
157 ;;; Dump out the number of locations and the locations for Block.
158 (defun dump-block-locations (block locations tlf-num var-locs)
159 (declare (type cblock block) (list locations))
161 (eq (location-info-kind (first locations))
163 (write-var-integer (length locations) *byte-buffer*)
164 (let ((2block (block-info block)))
165 (write-var-integer (+ (length locations) 1) *byte-buffer*)
166 (dump-1-location (continuation-next (block-start block))
167 2block :block-start tlf-num
168 (ir2-block-%label 2block)
169 (ir2-block-live-out 2block)
172 (dolist (loc locations)
173 (dump-location-from-info loc tlf-num var-locs))
176 ;;; Dump the successors of Block, being careful not to fly into space
177 ;;; on weird successors.
178 (defun dump-block-successors (block physenv)
179 (declare (type cblock block) (type physenv physenv))
180 (let* ((tail (component-tail (block-component block)))
181 (succ (block-succ block))
184 (or (eq (car succ) tail)
185 (not (eq (block-physenv (car succ)) physenv))))
189 (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
191 (let ((base (block-number
193 (lambda-bind (physenv-lambda physenv))))))
194 (dolist (b valid-succ)
196 (the index (- (block-number b) base))
200 ;;; Return a vector and an integer (or null) suitable for use as the
201 ;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. This requires two
202 ;;; passes to compute:
203 ;;; -- Scan all blocks, dumping the header and successors followed
204 ;;; by all the non-elsewhere locations.
205 ;;; -- Dump the elsewhere block header and all the elsewhere
206 ;;; locations (if any.)
207 (defun compute-debug-blocks (fun var-locs)
208 (declare (type clambda fun) (type hash-table var-locs))
209 (setf (fill-pointer *byte-buffer*) 0)
210 (let ((*previous-location* 0)
211 (tlf-num (find-tlf-number fun))
212 (physenv (lambda-physenv fun))
215 (collect ((elsewhere))
216 (do-physenv-ir2-blocks (2block physenv)
217 (let ((block (ir2-block-block 2block)))
218 (when (eq (block-info block) 2block)
220 (dump-block-locations prev-block prev-locs tlf-num var-locs))
221 (setq prev-block block prev-locs ())
222 (dump-block-successors block physenv)))
224 (collect ((here prev-locs))
225 (dolist (loc (ir2-block-locations 2block))
226 (if (label-elsewhere-p (location-info-label loc))
229 (setq prev-locs (here))))
231 (dump-block-locations prev-block prev-locs tlf-num var-locs)
234 (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
235 (write-var-integer (length (elsewhere)) *byte-buffer*)
236 (dolist (loc (elsewhere))
237 (dump-location-from-info loc tlf-num var-locs))))
239 (values (copy-seq *byte-buffer*) tlf-num)))
241 ;;; Return a list of DEBUG-SOURCE structures containing information
242 ;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always
243 ;;; dump the START-POSITIONS, since it is too hard figure out whether
244 ;;; we need them or not.
245 (defun debug-source-for-info (info)
246 (declare (type source-info info))
247 (let* ((file-info (source-info-file-info info))
248 (res (make-debug-source
250 :created (file-info-write-date file-info)
251 :compiled (source-info-start-time info)
252 :source-root (file-info-source-root file-info)
253 :start-positions (coerce-to-smallest-eltype
254 (file-info-positions file-info))))
255 (name (file-info-name file-info)))
258 (setf (debug-source-from res) name)
259 (setf (debug-source-name res)
260 (coerce (file-info-forms file-info) 'simple-vector)))
262 (let* ((untruename (file-info-untruename file-info))
263 (dir (pathname-directory untruename)))
264 (setf (debug-source-name res)
266 (if (and dir (eq (first dir) :absolute))
272 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
273 ;;; possible. Ordinarily we coerce it to the smallest specialized
274 ;;; vector we can. However, we also have a special hack for
275 ;;; cross-compiling at bootstrap time, when arbitrarily-specialized
276 ;;; vectors aren't fully supported: in that case, we coerce it only to
277 ;;; a vector whose element size is an integer multiple of output byte
279 (defun coerce-to-smallest-eltype (seq)
282 (if (typep x 'unsigned-byte)
285 (return-from coerce-to-smallest-eltype
286 (coerce seq 'simple-vector)))))
292 (let ((specializer `(unsigned-byte
294 ((unsigned-byte 8) 8)
295 ((unsigned-byte 16) 16)
296 ((unsigned-byte 32) 32)))))
297 ;; cross-compilers beware! It would be possible for the
298 ;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be
299 ;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is
300 ;; completely valid by ANSI. However, the cross-compiler
301 ;; doesn't know how to dump (in practice) anything but the
302 ;; above three specialized array types, so make it break here
303 ;; if this is violated.
306 ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
307 ;; worried about whether the host's implementation of arrays.
308 (let ((uaet (upgraded-array-element-type specializer)))
309 (dolist (et '((unsigned-byte 8)
313 (when (and (subtypep et uaet) (subtypep uaet et))
315 (coerce seq `(simple-array ,specializer (*)))))))
319 ;;; Return a SC-OFFSET describing TN's location.
320 (defun tn-sc-offset (tn)
321 (declare (type tn tn))
322 (make-sc-offset (sc-number (tn-sc tn))
325 ;;; Dump info to represent VAR's location being TN. ID is an integer
326 ;;; that makes VAR's name unique in the function. BUFFER is the vector
327 ;;; we stick the result in. If MINIMAL, we suppress name dumping, and
328 ;;; set the minimal flag.
330 ;;; The DEBUG-VAR is only marked as always-live if the TN is
331 ;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
332 ;;; then we also exclude set variables, since the variable is not
333 ;;; guaranteed to be live everywhere in that case.
334 (defun dump-1-var (fun var tn id minimal buffer)
335 (declare (type lambda-var var) (type (or tn null) tn) (type index id)
337 (let* ((name (leaf-debug-name var))
338 (save-tn (and tn (tn-save-tn tn)))
339 (kind (and tn (tn-kind tn)))
341 (declare (type index flags))
343 (setq flags (logior flags compiled-debug-var-minimal-p))
345 (setq flags (logior flags compiled-debug-var-deleted-p))))
346 (when (and (or (eq kind :environment)
347 (and (eq kind :debug-environment)
348 (null (basic-var-sets var))))
349 (not (gethash tn (ir2-component-spilled-tns
350 (component-info *component-being-compiled*))))
351 (eq (lambda-var-home var) fun))
352 (setq flags (logior flags compiled-debug-var-environment-live)))
354 (setq flags (logior flags compiled-debug-var-save-loc-p)))
355 (unless (or (zerop id) minimal)
356 (setq flags (logior flags compiled-debug-var-id-p)))
357 (vector-push-extend flags buffer)
359 (vector-push-extend name buffer)
361 (vector-push-extend id buffer)))
363 (vector-push-extend (tn-sc-offset tn) buffer)
366 (vector-push-extend (tn-sc-offset save-tn) buffer)))
369 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS
370 ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
371 ;;; hash table in which we enter the translation from LAMBDA-VARS to
372 ;;; the relative position of that variable's location in the resulting
374 (defun compute-vars (fun level var-locs)
375 (declare (type clambda fun) (type hash-table var-locs))
377 (labels ((frob-leaf (leaf tn gensym-p)
378 (let ((name (leaf-debug-name leaf)))
379 (when (and name (leaf-refs leaf) (tn-offset tn)
380 (or gensym-p (symbol-package name)))
381 (vars (cons leaf tn)))))
382 (frob-lambda (x gensym-p)
383 (dolist (leaf (lambda-vars x))
384 (frob-leaf leaf (leaf-info leaf) gensym-p))))
387 (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
388 (let ((thing (car x)))
389 (when (lambda-var-p thing)
390 (frob-leaf thing (cdr x) (= level 3)))))
392 (dolist (let (lambda-lets fun))
393 (frob-lambda let (= level 3)))))
395 (let ((sorted (sort (vars) #'string<
397 (symbol-name (leaf-debug-name (car x))))))
401 (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
402 (declare (type (or simple-string null) prev-name)
406 (name (symbol-name (leaf-debug-name var))))
407 (cond ((and prev-name (string= prev-name name))
410 (setq id 0 prev-name name)))
411 (dump-1-var fun var (cdr x) id nil buffer)
412 (setf (gethash var var-locs) i))
414 (coerce buffer 'simple-vector))))
416 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
417 ;;; FUN, representing the arguments to FUN in minimal variable format.
418 (defun compute-minimal-vars (fun)
419 (declare (type clambda fun))
420 (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
421 (dolist (var (lambda-vars fun))
422 (dump-1-var fun var (leaf-info var) 0 t buffer))
423 (coerce buffer 'simple-vector)))
425 ;;; Return VAR's relative position in the function's variables (determined
426 ;;; from the VAR-LOCS hashtable). If VAR is deleted, then return DELETED.
427 (defun debug-location-for (var var-locs)
428 (declare (type lambda-var var) (type hash-table var-locs))
429 (let ((res (gethash var var-locs)))
432 (aver (or (null (leaf-refs var))
433 (not (tn-offset (leaf-info var)))))
436 ;;;; arguments/returns
438 ;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
439 ;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
440 ;;; the ARGLIST to determine the syntax, otherwise pretend all
441 ;;; arguments are fixed.
443 ;;; ### This assumption breaks down in EPs other than the main-entry,
444 ;;; since they may or may not have supplied-p vars, etc.
445 (defun compute-args (fun var-locs)
446 (declare (type clambda fun) (type hash-table var-locs))
448 (let ((od (lambda-optional-dispatch fun)))
449 (if (and od (eq (optional-dispatch-main-entry od) fun))
450 (let ((actual-vars (lambda-vars fun))
452 (dolist (arg (optional-dispatch-arglist od))
453 (let ((info (lambda-var-arg-info arg))
454 (actual (pop actual-vars)))
456 (case (arg-info-kind info)
458 (res (arg-info-key info)))
466 (setq saw-optional t))))
467 (res (debug-location-for actual var-locs))
468 (when (arg-info-supplied-p info)
470 (res (debug-location-for (pop actual-vars) var-locs))))
472 (res (debug-location-for actual var-locs)))))))
473 (dolist (var (lambda-vars fun))
474 (res (debug-location-for var var-locs)))))
476 (coerce-to-smallest-eltype (res))))
478 ;;; Return a vector of SC offsets describing FUN's return locations.
479 ;;; (Must be known values return...)
480 (defun compute-debug-returns (fun)
481 (coerce-to-smallest-eltype
482 (mapcar (lambda (loc)
484 (return-info-locations (tail-set-info (lambda-tail-set fun))))))
488 ;;; Return a C-D-F structure with all the mandatory slots filled in.
489 (defun dfun-from-fun (fun)
490 (declare (type clambda fun))
491 (let* ((2env (physenv-info (lambda-physenv fun)))
492 (dispatch (lambda-optional-dispatch fun))
493 (main-p (and dispatch
494 (eq fun (optional-dispatch-main-entry dispatch)))))
495 (make-compiled-debug-fun
496 :name (leaf-debug-name fun)
497 :kind (if main-p nil (functional-kind fun))
498 :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env))
499 :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env))
500 :start-pc (label-position (ir2-physenv-environment-start 2env))
501 :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)))))
503 ;;; Return a complete C-D-F structure for FUN. This involves
504 ;;; determining the DEBUG-INFO level and filling in optional slots as
506 (defun compute-1-debug-fun (fun var-locs)
507 (declare (type clambda fun) (type hash-table var-locs))
508 (let* ((dfun (dfun-from-fun fun))
509 (actual-level (policy (lambda-bind fun) debug))
510 (level (if #!+sb-dyncount *collect-dynamic-statistics*
514 (cond ((zerop level))
516 (let ((od (lambda-optional-dispatch fun)))
518 (not (eq (optional-dispatch-main-entry od) fun)))))
519 (setf (compiled-debug-fun-vars dfun)
520 (compute-minimal-vars fun))
521 (setf (compiled-debug-fun-arguments dfun) :minimal))
523 (setf (compiled-debug-fun-vars dfun)
524 (compute-vars fun level var-locs))
525 (setf (compiled-debug-fun-arguments dfun)
526 (compute-args fun var-locs))))
529 (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs)
530 (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
531 (setf (compiled-debug-fun-blocks dfun) blocks)))
534 (setf (compiled-debug-fun-returns dfun) :standard)
535 (let ((info (tail-set-info (lambda-tail-set fun))))
537 (cond ((eq (return-info-kind info) :unknown)
538 (setf (compiled-debug-fun-returns dfun)
541 (setf (compiled-debug-fun-returns dfun)
542 (compute-debug-returns fun)))))))
545 ;;;; full component dumping
547 ;;; Compute the full form (simple-vector) function map.
548 (defun compute-debug-fun-map (sorted)
549 (declare (list sorted))
550 (let* ((len (1- (* (length sorted) 2)))
551 (funs-vec (make-array len)))
553 (sorted sorted (cdr sorted)))
556 (let ((dfun (car sorted)))
558 (setf (svref funs-vec i) (car dfun)))
559 (setf (svref funs-vec (1+ i)) (cdr dfun))))
562 ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
563 ;;; called after assembly so that source map information is available.
564 (defun debug-info-for-component (component)
565 (declare (type component component))
567 (var-locs (make-hash-table :test 'eq))
568 (*byte-buffer* (make-array 10
569 :element-type '(unsigned-byte 8)
572 (dolist (lambda (component-lambdas component))
574 (push (cons (label-position (block-label (lambda-block lambda)))
575 (compute-1-debug-fun lambda var-locs))
577 (let* ((sorted (sort dfuns #'< :key #'car))
578 (fun-map (compute-debug-fun-map sorted)))
579 (make-compiled-debug-info :name (component-name component)
582 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
583 ;;; BITS must be evenly divisible by eight.
584 (defun write-packed-bit-vector (bits byte-buffer)
585 (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
587 ;; Enforce constraint from CMU-CL-era comment.
588 (aver (zerop (mod (length bits) 8)))
590 (multiple-value-bind (initial step done)
591 (ecase *backend-byte-order*
592 (:little-endian (values 0 1 8))
593 (:big-endian (values 7 -1 -1)))
594 (let ((shift initial)
596 (dotimes (i (length bits))
597 (let ((int (aref bits i)))
598 (setf byte (logior byte (ash int shift)))
601 (vector-push-extend byte byte-buffer)
604 (unless (= shift initial)
605 (vector-push-extend byte byte-buffer))))