/[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.8 - (hide annotations)
Mon Mar 5 12:08:44 1990 UTC (24 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.7: +57 -39 lines
Mucho debugging of debug-location dumping.  Check for the successors being the
component tail.  Dump the number of locations in each block.  Only dump
elsewhere block if there are some elsewhere locations.  Fixed uses of renamed
compiled-debug-variable constants.  Put back in support for DELETED arguments.
1 wlott 1.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 ram 1.2 (defvar *byte-buffer*
18     (make-array 10 :element-type '(unsigned-byte 8)
19     :fill-pointer 0 :adjustable t))
20    
21 ram 1.3
22     ;;;; Debug blocks:
23 ram 1.2
24 ram 1.3 (deftype location-kind ()
25 ram 1.6 '(member :unknown-return :known-return :internal-error :non-local-exit
26     :block-start))
27 ram 1.3
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 ram 1.8 (defun note-debug-location (vop label kind)
52 ram 1.3 (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 ram 1.8 (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
77 ram 1.3 :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 ram 1.7 (setf (sbit res num) 1))))))
85     res))
86 ram 1.3
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 ram 1.6 (type location-kind kind) (type (or index null) tlf-num)
101 ram 1.3 (type hash-table var-locs))
102    
103     (vector-push-extend
104 ram 1.8 (dpb (position kind compiled-code-location-kinds)
105     compiled-code-location-kind-byte
106     0)
107 ram 1.3 *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 ram 1.6 (write-var-integer (node-tlf-number node) *byte-buffer*))
115     (write-var-integer (first (node-source-path node)) *byte-buffer*)
116 ram 1.3
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 ram 1.7 (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 ram 1.3 (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 ram 1.8 ;;; -- Dump the elsewhere block header and all the elsewhere locations (if
152     ;;; any.)
153 ram 1.3 ;;;
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 ram 1.6 (continuation-next (block-start block)))
167     tlf-num)
168 ram 1.3 (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 ram 1.8 (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 ram 1.3
191 ram 1.8 (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 ram 1.3 (values (copy-seq *byte-buffer*) tlf-num)))
214    
215    
216 wlott 1.1 ;;; 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 ram 1.6 :start-positions
232     (when (policy nil (>= debug 2))
233     (coerce-to-smallest-eltype
234     (file-info-positions x))))))
235 wlott 1.1 (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 ram 1.3 ;;; 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 ram 1.6 (dolist (val seq)
260 ram 1.3 (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 ram 1.2 ;;; TN-SC-OFFSET -- Internal
273 wlott 1.1 ;;;
274 ram 1.2 ;;; Return a SC-OFFSET describing TN's location.
275 wlott 1.1 ;;;
276 ram 1.2 (defun tn-sc-offset (tn)
277     (declare (type tn tn))
278     (make-sc-offset (sc-number (tn-sc tn))
279     (tn-offset tn)))
280 wlott 1.1
281    
282 ram 1.3 ;;; DUMP-1-VARIABLE -- Internal
283 ram 1.2 ;;;
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 ram 1.3 (defun dump-1-variable (var tn id buffer)
289 ram 1.2 (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 ram 1.8 (setq flags (logior flags compiled-debug-variable-uninterned)))
297 ram 1.2 (when package-p
298 ram 1.8 (setq flags (logior flags compiled-debug-variable-packaged)))
299 ram 1.2 (when (eq (tn-kind tn) :environment)
300 ram 1.8 (setq flags (logior flags compiled-debug-variable-environment-live)))
301 ram 1.2 (when save-tn
302 ram 1.8 (setq flags (logior flags compiled-debug-variable-save-loc-p)))
303 ram 1.2 (unless (zerop id)
304 ram 1.8 (setq flags (logior flags compiled-debug-variable-id-p)))
305 ram 1.2 (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 wlott 1.1 ;;; COMPUTE-VARIABLES -- Internal
318     ;;;
319     ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
320 ram 1.2 ;;; 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 wlott 1.1 ;;;
324 ram 1.2 (defun compute-variables (fun level var-locs)
325 wlott 1.1 (declare (type clambda fun) (type hash-table var-locs))
326 ram 1.2 (collect ((vars))
327     (labels ((frob-leaf (leaf tn gensym-p)
328 wlott 1.1 (let ((name (leaf-name leaf)))
329     (when (and name (leaf-refs leaf)
330 ram 1.2 (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 ram 1.6 (frob-lambda let (= level 3)))))
345 wlott 1.1
346 ram 1.2 (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 ram 1.3 (dump-1-variable var (cdr x) id *byte-buffer*)
362     (setf (gethash var var-locs) i))
363 ram 1.2 (incf i)))
364 wlott 1.1
365 ram 1.2 (copy-seq *byte-buffer*)))
366 wlott 1.1
367 ram 1.2
368     ;;; DEBUG-LOCATION-FOR -- Internal
369     ;;;
370     ;;; Return Var's relative position in the function's variables (determined
371 ram 1.8 ;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
372 ram 1.2 ;;;
373     (defun debug-location-for (var var-locs)
374 ram 1.7 (declare (type lambda-var var) (type hash-table var-locs))
375 ram 1.2 (let ((res (gethash var var-locs)))
376 ram 1.8 (cond (res)
377     (t
378     (assert (null (leaf-refs var)))
379     'deleted))))
380 ram 1.2
381 ram 1.3
382     ;;;; Arguments/returns:
383 ram 1.2
384 wlott 1.1 ;;; 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 ram 1.3 (coerce-to-smallest-eltype (res))))
418 wlott 1.1
419    
420     ;;; COMPUTE-DEBUG-RETURNS -- Internal
421     ;;;
422 ram 1.8 ;;; Return a vector of SC offsets describing Fun's return locations. (Must
423     ;;; be known values return...)
424 wlott 1.1 ;;;
425     (defun compute-debug-returns (fun)
426 ram 1.3 (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 wlott 1.1
431 ram 1.3
432 wlott 1.1 ;;; 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 ram 1.2 (let ((level (cookie-debug *default-cookie*))
442     (res (make-compiled-debug-info :name (component-name component)
443     :package (package-name *package*))))
444 wlott 1.1 (collect ((dfuns))
445     (let ((var-locs (make-hash-table :test #'eq)))
446     (dolist (fun (component-lambdas component))
447     (clrhash var-locs)
448 ram 1.5 (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 fun)))
452     (and ef (leaf-name ef))))
453     (t
454     (component-name component)))
455     :kind (functional-kind fun)
456     :return-pc (tn-sc-offset
457     (ir2-environment-return-pc 2env))
458     :old-cont (tn-sc-offset
459     (ir2-environment-old-cont 2env))
460     ;; Not right...
461     :start-pc 0)))
462 wlott 1.1
463 ram 1.2 (when (>= level 1)
464 wlott 1.1 (setf (compiled-debug-function-variables dfun)
465 ram 1.2 (compute-variables fun level var-locs)))
466 wlott 1.1
467 ram 1.2 (unless (= level 0)
468 wlott 1.1 (setf (compiled-debug-function-arguments dfun)
469     (compute-arguments fun var-locs)))
470 ram 1.3
471     (when (>= level 2)
472     (multiple-value-bind (blocks tlf-num)
473 ram 1.6 (compute-debug-blocks fun var-locs)
474 ram 1.8 (setf (compiled-debug-function-tlf-number dfun) tlf-num)
475     (setf (compiled-debug-function-blocks dfun) blocks)))
476 wlott 1.1
477     (let ((tails (lambda-tail-set fun)))
478     (when tails
479     (let ((info (tail-set-info tails)))
480     (cond ((eq (return-info-kind info) :unknown)
481     (setf (compiled-debug-function-returns dfun)
482     :standard))
483 ram 1.2 ((/= level 0)
484 wlott 1.1 (setf (compiled-debug-function-returns dfun)
485     (compute-debug-returns fun)))))))
486    
487     (dfuns (cons (label-location
488     (block-label
489     (node-block
490     (lambda-bind fun))))
491     dfun)))))
492    
493     (let* ((sorted (sort (dfuns) #'< :key #'car))
494     (len (1- (* (length sorted) 2)))
495     (funs-vec (make-array len)))
496     (do ((i -1 (+ i 2))
497     (sorted sorted (cdr sorted)))
498     ((= i len))
499     (let ((dfun (car sorted)))
500     (unless (minusp i)
501     (setf (svref funs-vec i) (car dfun)))
502     (setf (svref funs-vec (1+ i)) (cdr dfun))))
503     (setf (compiled-debug-info-function-map res) funs-vec)))
504    
505     res))

  ViewVC Help
Powered by ViewVC 1.1.5