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

  ViewVC Help
Powered by ViewVC 1.1.5