/[cmucl]/src/compiler/debug-dump.lisp
ViewVC logotype

Contents of /src/compiler/debug-dump.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Sat Oct 6 18:16:54 1990 UTC (23 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.17: +41 -20 lines
Added stuff to check for spilled TNs so that the debugger knows they
aren't really there.
Also, added declarations and stuff to avoid generic arith.
And fixed up the debug-info policy handling a bit so that this quality
works reasonably as a local declaration.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; This file contains stuff that creates debugger information from the
11 ;;; compiler's internal data structures.
12 ;;;
13 ;;; Written by Rob MacLachlan
14 ;;;
15 (in-package 'c)
16
17 (defvar *byte-buffer*
18 (make-array 10 :element-type '(unsigned-byte 8)
19 :fill-pointer 0 :adjustable t))
20
21
22 ;;;; Debug blocks:
23
24 (deftype location-kind ()
25 '(member :unknown-return :known-return :internal-error :non-local-exit
26 :block-start))
27
28
29 ;;; The Location-Info structure holds the information what we need about
30 ;;; locations which code generation decided were "interesting".
31 ;;;
32 (defstruct (location-info
33 (:constructor make-location-info (kind label vop)))
34 ;;
35 ;; The kind of location noted.
36 (kind nil :type location-kind)
37 ;;
38 ;; The label pointing to the interesting code location.
39 (label nil :type label)
40 ;;
41 ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
42 (vop nil :type vop))
43
44
45 ;;; NOTE-DEBUG-LOCATION -- Interface
46 ;;;
47 ;;; Called during code generation in places where there is an "interesting"
48 ;;; location: some place where we are likely to end up in the debugger, and
49 ;;; thus want debug info.
50 ;;;
51 (defun note-debug-location (vop label kind)
52 (declare (type vop vop) (type label label) (type location-kind kind))
53 (setf (ir2-block-locations (vop-block vop))
54 (nconc (ir2-block-locations (vop-block vop))
55 (list (make-location-info kind label vop))))
56 (undefined-value))
57
58
59 ;;; IR2-BLOCK-ENVIRONMENT -- Interface
60 ;;;
61 (proclaim '(inline ir2-block-environment))
62 (defun ir2-block-environment (2block)
63 (declare (type ir2-block 2block))
64 (block-environment (ir2-block-block 2block)))
65
66
67 ;;; COMPUTE-LIVE-VARS -- Internal
68 ;;;
69 ;;; Given a local conflicts vector and an IR2 block to represent the set of
70 ;;; live TNs, and the Var-Locs hashtable representing the variables dumped,
71 ;;; compute a bit-vector representing the set of live variables. If the TN is
72 ;;; environment-live, we only mark it as live when it is in scope at Node.
73 ;;;
74 (defun compute-live-vars (live node block var-locs vop)
75 (declare (type ir2-block block) (type local-tn-bit-vector live)
76 (type hash-table var-locs) (type node node)
77 (type (or vop null) vop))
78 (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
79 :element-type 'bit
80 :initial-element 0))
81 (spilled (gethash vop
82 (ir2-component-spilled-vops
83 (component-info *compile-component*)))))
84 (do-live-tns (tn live block)
85 (let ((leaf (tn-leaf tn)))
86 (when (and (lambda-var-p leaf)
87 (or (not (member (tn-kind tn)
88 '(:environment :debug-environment)))
89 (rassoc leaf (lexenv-variables (node-lexenv node))))
90 (or (null spilled)
91 (not (member tn spilled))))
92 (let ((num (gethash leaf var-locs)))
93 (when num
94 (setf (sbit res num) 1))))))
95 res))
96
97
98 ;;; The PC for the location most recently dumped.
99 ;;;
100 (defvar *previous-location*)
101 (proclaim '(type index *previous-location*))
102
103 ;;; DUMP-1-LOCATION -- Internal
104 ;;;
105 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the
106 ;;; code/source map and live info. If true, VOP is the VOP associated with
107 ;;; this location, for use in determining whether TNs are spilled.
108 ;;;
109 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
110 (declare (type node node) (type ir2-block block)
111 (type local-tn-bit-vector live) (type label label)
112 (type location-kind kind) (type (or index null) tlf-num)
113 (type hash-table var-locs) (type (or vop null) vop))
114
115 (vector-push-extend
116 (dpb (position kind compiled-code-location-kinds)
117 compiled-code-location-kind-byte
118 0)
119 *byte-buffer*)
120
121 (let ((loc (label-position label)))
122 (write-var-integer (- loc *previous-location*) *byte-buffer*)
123 (setq *previous-location* loc))
124
125 (let ((path (node-source-path node)))
126 (unless tlf-num
127 (write-var-integer (source-path-tlf-number path) *byte-buffer*))
128 (write-var-integer (source-path-form-number path) *byte-buffer*))
129
130 (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
131 *byte-buffer*)
132
133 (undefined-value))
134
135
136 ;;; DUMP-LOCATION-FROM-INFO -- Internal
137 ;;;
138 ;;; Extract context info from a Location-Info structure and use it to dump a
139 ;;; compiled code-location.
140 ;;;
141 (defun dump-location-from-info (loc tlf-num var-locs)
142 (declare (type location-info loc) (type (or index null) tlf-num)
143 (type hash-table var-locs))
144 (let ((vop (location-info-vop loc)))
145 (dump-1-location (vop-node vop)
146 (vop-block vop)
147 (location-info-kind loc)
148 tlf-num
149 (location-info-label loc)
150 (vop-save-set vop)
151 var-locs
152 vop))
153 (undefined-value))
154
155
156 ;;; FIND-TLF-AND-BLOCK-NUMBERS -- Internal
157 ;;;
158 ;;; Scan all the blocks, caching the block numbering in the BLOCK-FLAG and
159 ;;; determining if all locations are in the same TLF.
160 ;;;
161 (defun find-tlf-and-block-numbers (fun)
162 (declare (type clambda fun))
163 (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
164 (num 0))
165 (declare (type index num) (type (or index null) res))
166 (do-environment-ir2-blocks (2block (lambda-environment fun))
167 (let ((block (ir2-block-block 2block)))
168 (when (eq (block-info block) 2block)
169 (setf (block-flag block) num)
170 (incf num)
171 (unless (eql (source-path-tlf-number
172 (node-source-path
173 (continuation-next
174 (block-start block))))
175 res)
176 (setq res nil)))
177
178 (dolist (loc (ir2-block-locations 2block))
179 (unless (eql (source-path-tlf-number
180 (node-source-path
181 (vop-node (location-info-vop loc))))
182 res)
183 (setq res nil)))))
184 res))
185
186
187 ;;; DUMP-BLOCK-LOCATIONS -- Internal
188 ;;;
189 ;;; Dump out the number of locations and the locations for Block.
190 ;;;
191 (defun dump-block-locations (block locations tlf-num var-locs)
192 (declare (type cblock block) (list locations))
193 (write-var-integer (1+ (length locations)) *byte-buffer*)
194 (let ((2block (block-info block)))
195 (dump-1-location (continuation-next (block-start block))
196 2block :block-start tlf-num
197 (ir2-block-%label 2block)
198 (ir2-block-live-out 2block)
199 var-locs
200 nil))
201 (dolist (loc locations)
202 (dump-location-from-info loc tlf-num var-locs))
203 (undefined-value))
204
205
206 ;;; DUMP-BLOCK-SUCCESSORS -- Internal
207 ;;;
208 ;;; Dump the successors of Block, being careful not to fly into space on
209 ;;; weird successors.
210 ;;;
211 (defun dump-block-successors (block env)
212 (declare (type cblock block) (type environment env))
213 (let* ((tail (component-tail (block-component block)))
214 (succ (block-succ block))
215 (valid-succ
216 (if (and succ
217 (or (eq (car succ) tail)
218 (not (eq (block-environment (car succ)) env))))
219 ()
220 succ)))
221 (vector-push-extend
222 (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
223 *byte-buffer*)
224 (dolist (b valid-succ)
225 (write-var-integer (block-flag b) *byte-buffer*)))
226 (undefined-value))
227
228
229 ;;; COMPUTE-DEBUG-BLOCKS -- Internal
230 ;;;
231 ;;; Return a vector and an integer (or null) suitable for use as the BLOCKS
232 ;;; and TLF-NUMBER in Fun's debug-function. This requires three passes to
233 ;;; compute:
234 ;;; -- Scan all blocks, dumping the header and successors followed by all the
235 ;;; non-elsewhere locations.
236 ;;; -- Dump the elsewhere block header and all the elsewhere locations (if
237 ;;; any.)
238 ;;;
239 (defun compute-debug-blocks (fun var-locs)
240 (declare (type clambda fun) (type hash-table var-locs))
241 (setf (fill-pointer *byte-buffer*) 0)
242 (let ((*previous-location* 0)
243 (tlf-num (find-tlf-and-block-numbers fun))
244 (env (lambda-environment fun))
245 (prev-locs nil)
246 (prev-block nil))
247 (collect ((elsewhere))
248 (do-environment-ir2-blocks (2block env)
249 (let ((block (ir2-block-block 2block)))
250 (when (eq (block-info block) 2block)
251 (when prev-block
252 (dump-block-locations prev-block prev-locs tlf-num var-locs))
253 (setq prev-block block prev-locs ())
254 (dump-block-successors block env)))
255
256 (collect ((here prev-locs))
257 (dolist (loc (ir2-block-locations 2block))
258 (if (label-elsewhere-p (location-info-label loc))
259 (elsewhere loc)
260 (here loc)))
261 (setq prev-locs (here))))
262
263 (dump-block-locations prev-block prev-locs tlf-num var-locs)
264
265 (when (elsewhere)
266 (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
267 (write-var-integer (length (elsewhere)) *byte-buffer*)
268 (dolist (loc (elsewhere))
269 (dump-location-from-info loc tlf-num var-locs))))
270
271 (values (copy-seq *byte-buffer*) tlf-num)))
272
273
274 ;;; DEBUG-SOURCE-FOR-INFO -- Interface
275 ;;;
276 ;;; Return a list of DEBUG-SOURCE structures containing information derived
277 ;;; from Info. We always dump the Start-Positions, since it is too hard
278 ;;; figure out whether we need them or not.
279 ;;;
280 (defun debug-source-for-info (info)
281 (declare (type source-info info))
282 (assert (not (source-info-current-file info)))
283 (mapcar #'(lambda (x)
284 (let ((name (file-info-name x))
285 (res (make-debug-source
286 :from :file
287 :comment (file-info-comment x)
288 :created (file-info-write-date x)
289 :compiled (source-info-start-time info)
290 :source-root (file-info-source-root x)
291 :start-positions
292 (coerce-to-smallest-eltype
293 (file-info-positions x)))))
294 (cond ((pathnamep name)
295 (setf (debug-source-name res) name))
296 (t
297 (setf (debug-source-from res) name)
298 (when (eq name :lisp)
299 (setf (debug-source-name res)
300 (aref (file-info-forms x) 0)))))
301 res))
302 (source-info-files info)))
303
304
305 ;;; COERCE-TO-SMALLEST-ELTYPE -- Internal
306 ;;;
307 ;;; Given an arbirtary sequence, coerce it to an unsigned vector if
308 ;;; possible.
309 ;;;
310 (defun coerce-to-smallest-eltype (seq)
311 (declare (type sequence seq))
312 (let ((max 0))
313 (declare (type (or index null) max))
314 (macrolet ((frob ()
315 '(if (and (typep val 'index) max)
316 (when (> val max)
317 (setq max val))
318 (setq max nil))))
319 (if (listp seq)
320 (dolist (val seq)
321 (frob))
322 (dotimes (i (length seq))
323 (let ((val (aref seq i)))
324 (frob)))))
325
326 (if max
327 (coerce seq `(simple-array (integer 0 ,max)))
328 (coerce seq 'simple-vector))))
329
330
331 ;;;; Variables:
332
333 ;;; TN-SC-OFFSET -- Internal
334 ;;;
335 ;;; Return a SC-OFFSET describing TN's location.
336 ;;;
337 (defun tn-sc-offset (tn)
338 (declare (type tn tn))
339 (make-sc-offset (sc-number (tn-sc tn))
340 (tn-offset tn)))
341
342
343 ;;; DUMP-1-VARIABLE -- Internal
344 ;;;
345 ;;; Dump info to represent Var's location being TN. ID is an integer that
346 ;;; makes Var's name unique in the function. Buffer is the vector we stick the
347 ;;; result in.
348 ;;;
349 ;;; The debug-variable is only marked as always-live if the TN is
350 ;;; environment live and is an argument. If a :debug-environment TN, then we
351 ;;; also exclude set variables, since the variable is not guranteed to be live
352 ;;; everywhere in that case.
353 ;;;
354 (defun dump-1-variable (fun var tn id buffer)
355 (declare (type lambda-var var) (type tn tn) (type index id)
356 (type clambda fun))
357 (let* ((name (leaf-name var))
358 (package (symbol-package name))
359 (package-p (and package (not (eq package *package*))))
360 (save-tn (tn-save-tn tn))
361 (kind (tn-kind tn))
362 (flags 0))
363 (declare (type index flags))
364 (unless package
365 (setq flags (logior flags compiled-debug-variable-uninterned)))
366 (when package-p
367 (setq flags (logior flags compiled-debug-variable-packaged)))
368 (when (and (or (eq kind :environment)
369 (and (eq kind :debug-environment)
370 (null (basic-var-sets var))))
371 (not (gethash tn (ir2-component-spilled-tns
372 (component-info *compile-component*))))
373 (eq (lambda-var-home var) fun))
374 (setq flags (logior flags compiled-debug-variable-environment-live)))
375 (when save-tn
376 (setq flags (logior flags compiled-debug-variable-save-loc-p)))
377 (unless (zerop id)
378 (setq flags (logior flags compiled-debug-variable-id-p)))
379 (vector-push-extend flags buffer)
380 (write-var-string (symbol-name name) buffer)
381 (when package-p
382 (write-var-string (package-name package) buffer))
383 (unless (zerop id)
384 (write-var-integer id buffer))
385 (write-var-integer (tn-sc-offset tn) buffer)
386 (when save-tn
387 (write-var-integer (tn-sc-offset save-tn) buffer)))
388 (undefined-value))
389
390
391 ;;; COMPUTE-VARIABLES -- Internal
392 ;;;
393 ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
394 ;;; Level is the current DEBUG-INFO quality. Var-Locs is a hashtable in which
395 ;;; we enter the translation from LAMBDA-VARS to the relative position of that
396 ;;; variable's location in the resulting vector.
397 ;;;
398 (defun compute-variables (fun level var-locs)
399 (declare (type clambda fun) (type hash-table var-locs))
400 (collect ((vars))
401 (labels ((frob-leaf (leaf tn gensym-p)
402 (let ((name (leaf-name leaf)))
403 (when (and name (leaf-refs leaf)
404 (or gensym-p (symbol-package name)))
405 (vars (cons leaf tn)))))
406 (frob-lambda (x gensym-p)
407 (dolist (leaf (lambda-vars x))
408 (frob-leaf leaf (leaf-info leaf) gensym-p))))
409 (frob-lambda fun t)
410 (when (>= level 2)
411 (dolist (x (ir2-environment-environment
412 (environment-info (lambda-environment fun))))
413 (let ((thing (car x)))
414 (when (lambda-var-p thing)
415 (frob-leaf thing (cdr x) (= level 3)))))
416
417 (dolist (let (lambda-lets fun))
418 (frob-lambda let (= level 3)))))
419
420 (setf (fill-pointer *byte-buffer*) 0)
421 (let ((sorted (sort (vars) #'string<
422 :key #'(lambda (x)
423 (symbol-name (leaf-name (car x))))))
424 (prev-name nil)
425 (id 0)
426 (i 0))
427 (declare (type (or simple-string null) prev-name)
428 (type index id i))
429 (dolist (x sorted)
430 (let* ((var (car x))
431 (name (symbol-name (leaf-name var))))
432 (cond ((and prev-name (string= prev-name name))
433 (incf id))
434 (t
435 (setq id 0 prev-name name)))
436 (dump-1-variable fun var (cdr x) id *byte-buffer*)
437 (setf (gethash var var-locs) i))
438 (incf i)))
439
440 (copy-seq *byte-buffer*)))
441
442
443 ;;; DEBUG-LOCATION-FOR -- Internal
444 ;;;
445 ;;; Return Var's relative position in the function's variables (determined
446 ;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
447 ;;;
448 (defun debug-location-for (var var-locs)
449 (declare (type lambda-var var) (type hash-table var-locs))
450 (let ((res (gethash var var-locs)))
451 (cond (res)
452 (t
453 (assert (null (leaf-refs var)))
454 'deleted))))
455
456
457 ;;;; Arguments/returns:
458
459 ;;; COMPUTE-ARGUMENTS -- Internal
460 ;;;
461 ;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
462 ;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the
463 ;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
464 ;;;
465 ;;; ### This assumption breaks down in EPs other than the main-entry, since
466 ;;; they may or may not have supplied-p vars, etc.
467 ;;;
468 (defun compute-arguments (fun var-locs)
469 (declare (type clambda fun) (type hash-table var-locs))
470 (collect ((res))
471 (let ((od (lambda-optional-dispatch fun)))
472 (if (and od (eq (optional-dispatch-main-entry od) fun))
473 (let ((actual-vars (lambda-vars fun))
474 (saw-optional nil))
475 (dolist (arg (optional-dispatch-arglist od))
476 (let ((info (lambda-var-arg-info arg))
477 (actual (pop actual-vars)))
478 (cond (info
479 (case (arg-info-kind info)
480 (:keyword
481 (res (arg-info-keyword info)))
482 (:rest
483 (res 'rest-arg))
484 (:optional
485 (unless saw-optional
486 (res 'optional-args)
487 (setq saw-optional t))))
488 (res (debug-location-for actual var-locs))
489 (when (arg-info-supplied-p info)
490 (res 'supplied-p)
491 (res (debug-location-for (pop actual-vars) var-locs))))
492 (t
493 (res (debug-location-for actual var-locs)))))))
494 (dolist (var (lambda-vars fun))
495 (res (debug-location-for var var-locs)))))
496
497 (coerce-to-smallest-eltype (res))))
498
499
500 ;;; COMPUTE-DEBUG-RETURNS -- Internal
501 ;;;
502 ;;; Return a vector of SC offsets describing Fun's return locations. (Must
503 ;;; be known values return...)
504 ;;;
505 (defun compute-debug-returns (fun)
506 (coerce-to-smallest-eltype
507 (mapcar #'(lambda (loc)
508 (tn-sc-offset loc))
509 (return-info-locations (tail-set-info (lambda-tail-set fun))))))
510
511
512 ;;; DEBUG-INFO-FOR-COMPONENT -- Interface
513 ;;;
514 ;;; Return a debug-info structure describing component. This has to be called
515 ;;; at some particular time (after assembly) so that source map information is
516 ;;; available.
517 ;;;
518 (defun debug-info-for-component (component)
519 (declare (type component component))
520 (let ((res (make-compiled-debug-info :name (component-name component)
521 :package (package-name *package*))))
522 (collect ((dfuns))
523 (let ((var-locs (make-hash-table :test #'eq)))
524 (dolist (fun (component-lambdas component))
525 (clrhash var-locs)
526 (let* ((2env (environment-info (lambda-environment fun)))
527 (dispatch (lambda-optional-dispatch fun))
528 (main-p (and dispatch
529 (eq fun (optional-dispatch-main-entry dispatch))))
530 (dfun (make-compiled-debug-function
531 :name (cond ((leaf-name fun))
532 ((let ((ef (functional-entry-function
533 fun)))
534 (and ef (leaf-name ef))))
535 ((and main-p (leaf-name dispatch)))
536 (t
537 (component-name component)))
538 :kind (if main-p nil (functional-kind fun))
539 :return-pc (tn-sc-offset
540 (ir2-environment-return-pc 2env))
541 :old-fp (tn-sc-offset
542 (ir2-environment-old-fp 2env))
543 :start-pc (label-position
544 (ir2-environment-environment-start 2env))
545
546 :elsewhere-pc
547 (label-position
548 (ir2-environment-elsewhere-start 2env))))
549 (level (cookie-debug
550 (lexenv-cookie
551 (node-lexenv
552 (lambda-bind fun))))))
553
554 (when (>= level 1)
555 (setf (compiled-debug-function-variables dfun)
556 (compute-variables fun level var-locs)))
557
558 (unless (= level 0)
559 (setf (compiled-debug-function-arguments dfun)
560 (compute-arguments fun var-locs)))
561
562 (when (>= level 2)
563 (multiple-value-bind (blocks tlf-num)
564 (compute-debug-blocks fun var-locs)
565 (setf (compiled-debug-function-tlf-number dfun) tlf-num)
566 (setf (compiled-debug-function-blocks dfun) blocks)))
567
568 (let ((tails (lambda-tail-set fun)))
569 (when tails
570 (let ((info (tail-set-info tails)))
571 (cond ((eq (return-info-kind info) :unknown)
572 (setf (compiled-debug-function-returns dfun)
573 :standard))
574 ((/= level 0)
575 (setf (compiled-debug-function-returns dfun)
576 (compute-debug-returns fun)))))))
577
578 (dfuns (cons (label-position
579 (block-label
580 (node-block
581 (lambda-bind fun))))
582 dfun)))))
583
584 (let* ((sorted (sort (dfuns) #'< :key #'car))
585 (len (1- (* (length sorted) 2)))
586 (funs-vec (make-array len)))
587 (do ((i -1 (+ i 2))
588 (sorted sorted (cdr sorted)))
589 ((= i len))
590 (declare (fixnum i))
591 (let ((dfun (car sorted)))
592 (unless (minusp i)
593 (setf (svref funs-vec i) (car dfun)))
594 (setf (svref funs-vec (1+ i)) (cdr dfun))))
595 (setf (compiled-debug-info-function-map res) funs-vec)))
596
597 res))

  ViewVC Help
Powered by ViewVC 1.1.5