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

  ViewVC Help
Powered by ViewVC 1.1.5