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

  ViewVC Help
Powered by ViewVC 1.1.5