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

  ViewVC Help
Powered by ViewVC 1.1.5