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

  ViewVC Help
Powered by ViewVC 1.1.5