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

  ViewVC Help
Powered by ViewVC 1.1.5