/[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 - (hide 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 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 ram 1.11 (block-component (node-block (lambda-bind fun)))))
178     (env (lambda-environment fun)))
179     (do-environment-ir2-blocks (2block env)
180 ram 1.8 (let ((block (ir2-block-block 2block)))
181     (when (eq (block-info block) 2block)
182     (let ((succ (let ((s (block-succ block)))
183 ram 1.11 (if (and s
184     (or (eq (car s) tail)
185     (not (eq (lambda-environment
186     (block-lambda (car s)))
187     env))))
188 ram 1.8 ()
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 ram 1.3
196 ram 1.8 (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 ram 1.3 (values (copy-seq *byte-buffer*) tlf-num)))
219    
220    
221 wlott 1.1 ;;; 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 ram 1.11 :comment (file-info-comment x)
234 wlott 1.1 :created (file-info-write-date x)
235     :compiled (source-info-start-time info)
236     :source-root (file-info-source-root x)
237 ram 1.6 :start-positions
238     (when (policy nil (>= debug 2))
239     (coerce-to-smallest-eltype
240     (file-info-positions x))))))
241 wlott 1.1 (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 ram 1.3 ;;; 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 ram 1.6 (dolist (val seq)
266 ram 1.3 (frob))
267     (dotimes (i (length seq))
268     (let ((val (aref seq i)))
269     (frob)))))
270    
271     (if max
272 ram 1.10 (coerce seq `(simple-array (integer 0 ,max)))
273 ram 1.3 (coerce seq 'simple-vector))))
274    
275    
276     ;;;; Locations:
277    
278 ram 1.2 ;;; TN-SC-OFFSET -- Internal
279 wlott 1.1 ;;;
280 ram 1.2 ;;; Return a SC-OFFSET describing TN's location.
281 wlott 1.1 ;;;
282 ram 1.2 (defun tn-sc-offset (tn)
283     (declare (type tn tn))
284     (make-sc-offset (sc-number (tn-sc tn))
285     (tn-offset tn)))
286 wlott 1.1
287    
288 ram 1.3 ;;; DUMP-1-VARIABLE -- Internal
289 ram 1.2 ;;;
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 ram 1.3 (defun dump-1-variable (var tn id buffer)
295 ram 1.2 (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 ram 1.8 (setq flags (logior flags compiled-debug-variable-uninterned)))
303 ram 1.2 (when package-p
304 ram 1.8 (setq flags (logior flags compiled-debug-variable-packaged)))
305 ram 1.2 (when (eq (tn-kind tn) :environment)
306 ram 1.8 (setq flags (logior flags compiled-debug-variable-environment-live)))
307 ram 1.2 (when save-tn
308 ram 1.8 (setq flags (logior flags compiled-debug-variable-save-loc-p)))
309 ram 1.2 (unless (zerop id)
310 ram 1.8 (setq flags (logior flags compiled-debug-variable-id-p)))
311 ram 1.2 (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 wlott 1.1 ;;; COMPUTE-VARIABLES -- Internal
324     ;;;
325     ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
326 ram 1.2 ;;; 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 wlott 1.1 ;;;
330 ram 1.2 (defun compute-variables (fun level var-locs)
331 wlott 1.1 (declare (type clambda fun) (type hash-table var-locs))
332 ram 1.2 (collect ((vars))
333     (labels ((frob-leaf (leaf tn gensym-p)
334 wlott 1.1 (let ((name (leaf-name leaf)))
335     (when (and name (leaf-refs leaf)
336 ram 1.2 (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 ram 1.6 (frob-lambda let (= level 3)))))
351 wlott 1.1
352 ram 1.2 (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 ram 1.3 (dump-1-variable var (cdr x) id *byte-buffer*)
368     (setf (gethash var var-locs) i))
369 ram 1.2 (incf i)))
370 wlott 1.1
371 ram 1.2 (copy-seq *byte-buffer*)))
372 wlott 1.1
373 ram 1.2
374     ;;; DEBUG-LOCATION-FOR -- Internal
375     ;;;
376     ;;; Return Var's relative position in the function's variables (determined
377 ram 1.8 ;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
378 ram 1.2 ;;;
379     (defun debug-location-for (var var-locs)
380 ram 1.7 (declare (type lambda-var var) (type hash-table var-locs))
381 ram 1.2 (let ((res (gethash var var-locs)))
382 ram 1.8 (cond (res)
383     (t
384     (assert (null (leaf-refs var)))
385     'deleted))))
386 ram 1.2
387 ram 1.3
388     ;;;; Arguments/returns:
389 ram 1.2
390 wlott 1.1 ;;; 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 ram 1.3 (coerce-to-smallest-eltype (res))))
424 wlott 1.1
425    
426     ;;; COMPUTE-DEBUG-RETURNS -- Internal
427     ;;;
428 ram 1.8 ;;; Return a vector of SC offsets describing Fun's return locations. (Must
429     ;;; be known values return...)
430 wlott 1.1 ;;;
431     (defun compute-debug-returns (fun)
432 ram 1.3 (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 wlott 1.1
437 ram 1.3
438 wlott 1.1 ;;; 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 ram 1.2 (let ((level (cookie-debug *default-cookie*))
448     (res (make-compiled-debug-info :name (component-name component)
449     :package (package-name *package*))))
450 wlott 1.1 (collect ((dfuns))
451     (let ((var-locs (make-hash-table :test #'eq)))
452     (dolist (fun (component-lambdas component))
453     (clrhash var-locs)
454 ram 1.5 (let* ((2env (environment-info (lambda-environment fun)))
455     (dfun (make-compiled-debug-function
456     :name (cond ((leaf-name fun))
457 ram 1.9 ((let ((ef (functional-entry-function
458     fun)))
459 ram 1.5 (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 ram 1.11 :old-fp (tn-sc-offset
466     (ir2-environment-old-fp 2env))
467 ram 1.9 :start-pc (label-location
468     (ir2-environment-environment-start 2env))
469    
470     :elsewhere-pc
471     (label-location
472     (ir2-environment-elsewhere-start 2env)))))
473 wlott 1.1
474 ram 1.2 (when (>= level 1)
475 wlott 1.1 (setf (compiled-debug-function-variables dfun)
476 ram 1.2 (compute-variables fun level var-locs)))
477 wlott 1.1
478 ram 1.2 (unless (= level 0)
479 wlott 1.1 (setf (compiled-debug-function-arguments dfun)
480     (compute-arguments fun var-locs)))
481 ram 1.3
482     (when (>= level 2)
483     (multiple-value-bind (blocks tlf-num)
484 ram 1.6 (compute-debug-blocks fun var-locs)
485 ram 1.8 (setf (compiled-debug-function-tlf-number dfun) tlf-num)
486     (setf (compiled-debug-function-blocks dfun) blocks)))
487 wlott 1.1
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 ram 1.2 ((/= level 0)
495 wlott 1.1 (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