/[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.47 - (hide annotations)
Tue Apr 6 20:44:01 2004 UTC (10 years ago) by rtoy
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, sse2-packed-base, amd64-dd-start, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, unicode-utf16-sync-2008-12, release-19c-base, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, snapshot-2004-12, snapshot-2004-11, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, snapshot-2008-04, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, RELEASE-19F-BRANCH, portable-clx-branch, unicode-string-buffer-branch, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, unicode-utf16-extfmt-branch
Changes since 1.46: +13 -8 lines
 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 ram 1.21 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.47 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/debug-dump.lisp,v 1.47 2004/04/06 20:44:01 rtoy Rel $")
9 ram 1.21 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains stuff that creates debugger information from the
13     ;;; compiler's internal data structures.
14     ;;;
15     ;;; Written by Rob MacLachlan
16     ;;;
17 wlott 1.31 (in-package :c)
18 wlott 1.1
19 ram 1.22 (defvar *byte-buffer*)
20     (declaim (type (vector (unsigned-byte 8)) *byte-buffer*))
21 ram 1.2
22 ram 1.3
23     ;;;; Debug blocks:
24 ram 1.2
25 ram 1.3 (deftype location-kind ()
26 ram 1.6 '(member :unknown-return :known-return :internal-error :non-local-exit
27 wlott 1.28 :block-start :call-site :single-value-return :non-local-entry))
28 ram 1.3
29    
30     ;;; The Location-Info structure holds the information what we need about
31     ;;; locations which code generation decided were "interesting".
32     ;;;
33     (defstruct (location-info
34     (:constructor make-location-info (kind label vop)))
35     ;;
36     ;; The kind of location noted.
37     (kind nil :type location-kind)
38     ;;
39     ;; The label pointing to the interesting code location.
40 wlott 1.31 (label nil :type (or label index null))
41 ram 1.3 ;;
42     ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
43     (vop nil :type vop))
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 wlott 1.31 (declare (type vop vop) (type (or label null) label)
53 wlott 1.28 (type location-kind kind))
54 wlott 1.31 (let ((location (make-location-info kind label vop)))
55     (setf (ir2-block-locations (vop-block vop))
56     (nconc (ir2-block-locations (vop-block vop))
57     (list location)))
58     location))
59 ram 1.3
60    
61     ;;; IR2-BLOCK-ENVIRONMENT -- Interface
62     ;;;
63 pw 1.42 (declaim (inline ir2-block-environment))
64 ram 1.3 (defun ir2-block-environment (2block)
65     (declare (type ir2-block 2block))
66 ram 1.15 (block-environment (ir2-block-block 2block)))
67 ram 1.3
68    
69     ;;; COMPUTE-LIVE-VARS -- Internal
70     ;;;
71     ;;; Given a local conflicts vector and an IR2 block to represent the set of
72 ram 1.22 ;;; live TNs, and the Var-Locs hash-table representing the variables dumped,
73 ram 1.15 ;;; compute a bit-vector representing the set of live variables. If the TN is
74     ;;; environment-live, we only mark it as live when it is in scope at Node.
75 ram 1.3 ;;;
76 ram 1.18 (defun compute-live-vars (live node block var-locs vop)
77 ram 1.3 (declare (type ir2-block block) (type local-tn-bit-vector live)
78 ram 1.18 (type hash-table var-locs) (type node node)
79     (type (or vop null) vop))
80 ram 1.8 (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
81 ram 1.3 :element-type 'bit
82 ram 1.18 :initial-element 0))
83     (spilled (gethash vop
84     (ir2-component-spilled-vops
85     (component-info *compile-component*)))))
86 ram 1.3 (do-live-tns (tn live block)
87     (let ((leaf (tn-leaf tn)))
88 ram 1.15 (when (and (lambda-var-p leaf)
89 ram 1.16 (or (not (member (tn-kind tn)
90     '(:environment :debug-environment)))
91 ram 1.18 (rassoc leaf (lexenv-variables (node-lexenv node))))
92     (or (null spilled)
93     (not (member tn spilled))))
94 ram 1.3 (let ((num (gethash leaf var-locs)))
95     (when num
96 ram 1.7 (setf (sbit res num) 1))))))
97     res))
98 ram 1.3
99    
100     ;;; The PC for the location most recently dumped.
101     ;;;
102     (defvar *previous-location*)
103 pw 1.42 (declaim (type index *previous-location*))
104 ram 1.3
105     ;;; DUMP-1-LOCATION -- Internal
106     ;;;
107     ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the
108 ram 1.18 ;;; code/source map and live info. If true, VOP is the VOP associated with
109     ;;; this location, for use in determining whether TNs are spilled.
110 ram 1.3 ;;;
111 ram 1.18 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
112 ram 1.3 (declare (type node node) (type ir2-block block)
113 wlott 1.30 (type local-tn-bit-vector live)
114     (type (or label index) label)
115 ram 1.6 (type location-kind kind) (type (or index null) tlf-num)
116 ram 1.18 (type hash-table var-locs) (type (or vop null) vop))
117 ram 1.3
118     (vector-push-extend
119 ram 1.38 (dpb (eposition kind compiled-code-location-kinds)
120 ram 1.8 compiled-code-location-kind-byte
121     0)
122 ram 1.3 *byte-buffer*)
123    
124 wlott 1.30 (let ((loc (if (fixnump label) label (label-position label))))
125 ram 1.3 (write-var-integer (- loc *previous-location*) *byte-buffer*)
126     (setq *previous-location* loc))
127 ram 1.15
128     (let ((path (node-source-path node)))
129     (unless tlf-num
130     (write-var-integer (source-path-tlf-number path) *byte-buffer*))
131     (write-var-integer (source-path-form-number path) *byte-buffer*))
132 ram 1.3
133 ram 1.18 (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
134 ram 1.3 *byte-buffer*)
135    
136     (undefined-value))
137    
138    
139     ;;; DUMP-LOCATION-FROM-INFO -- Internal
140     ;;;
141     ;;; Extract context info from a Location-Info structure and use it to dump a
142     ;;; compiled code-location.
143     ;;;
144 ram 1.7 (defun dump-location-from-info (loc tlf-num var-locs)
145     (declare (type location-info loc) (type (or index null) tlf-num)
146     (type hash-table var-locs))
147 ram 1.3 (let ((vop (location-info-vop loc)))
148     (dump-1-location (vop-node vop)
149     (vop-block vop)
150     (location-info-kind loc)
151     tlf-num
152     (location-info-label loc)
153     (vop-save-set vop)
154 ram 1.18 var-locs
155     vop))
156 ram 1.3 (undefined-value))
157    
158    
159 ram 1.32 ;;; FIND-TLF-NUMBER -- Internal
160 ram 1.12 ;;;
161 ram 1.32 ;;; Scan all the blocks, determining if all locations are in the same TLF,
162     ;;; and returing it or NIL.
163 ram 1.12 ;;;
164 ram 1.32 (defun find-tlf-number (fun)
165 ram 1.12 (declare (type clambda fun))
166 ram 1.32 (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
167     (declare (type (or index null) res))
168 ram 1.12 (do-environment-ir2-blocks (2block (lambda-environment fun))
169     (let ((block (ir2-block-block 2block)))
170     (when (eq (block-info block) 2block)
171 ram 1.15 (unless (eql (source-path-tlf-number
172     (node-source-path
173     (continuation-next
174     (block-start block))))
175 ram 1.12 res)
176     (setq res nil)))
177    
178     (dolist (loc (ir2-block-locations 2block))
179 ram 1.15 (unless (eql (source-path-tlf-number
180     (node-source-path
181     (vop-node (location-info-vop loc))))
182 ram 1.12 res)
183     (setq res nil)))))
184     res))
185    
186    
187     ;;; DUMP-BLOCK-LOCATIONS -- Internal
188     ;;;
189     ;;; Dump out the number of locations and the locations for Block.
190     ;;;
191     (defun dump-block-locations (block locations tlf-num var-locs)
192     (declare (type cblock block) (list locations))
193 wlott 1.28 (if (and locations
194 wlott 1.29 (eq (location-info-kind (first locations))
195 wlott 1.28 :non-local-entry))
196     (write-var-integer (length locations) *byte-buffer*)
197     (let ((2block (block-info block)))
198     (write-var-integer (+ (length locations) 1) *byte-buffer*)
199     (dump-1-location (continuation-next (block-start block))
200     2block :block-start tlf-num
201     (ir2-block-%label 2block)
202     (ir2-block-live-out 2block)
203     var-locs
204     nil)))
205 ram 1.12 (dolist (loc locations)
206     (dump-location-from-info loc tlf-num var-locs))
207     (undefined-value))
208    
209    
210     ;;; DUMP-BLOCK-SUCCESSORS -- Internal
211     ;;;
212     ;;; Dump the successors of Block, being careful not to fly into space on
213     ;;; weird successors.
214     ;;;
215     (defun dump-block-successors (block env)
216     (declare (type cblock block) (type environment env))
217     (let* ((tail (component-tail (block-component block)))
218     (succ (block-succ block))
219     (valid-succ
220     (if (and succ
221     (or (eq (car succ) tail)
222 ram 1.15 (not (eq (block-environment (car succ)) env))))
223 ram 1.12 ()
224     succ)))
225     (vector-push-extend
226     (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
227     *byte-buffer*)
228 ram 1.32 (let ((base (block-number
229     (node-block
230     (lambda-bind (environment-function env))))))
231     (dolist (b valid-succ)
232     (write-var-integer
233     (the index (- (block-number b) base))
234     *byte-buffer*))))
235 ram 1.12 (undefined-value))
236    
237    
238 ram 1.3 ;;; COMPUTE-DEBUG-BLOCKS -- Internal
239     ;;;
240     ;;; Return a vector and an integer (or null) suitable for use as the BLOCKS
241 ram 1.33 ;;; and TLF-NUMBER in Fun's debug-function. This requires two passes to
242 ram 1.3 ;;; compute:
243     ;;; -- Scan all blocks, dumping the header and successors followed by all the
244     ;;; non-elsewhere locations.
245 ram 1.8 ;;; -- Dump the elsewhere block header and all the elsewhere locations (if
246     ;;; any.)
247 ram 1.3 ;;;
248     (defun compute-debug-blocks (fun var-locs)
249     (declare (type clambda fun) (type hash-table var-locs))
250     (setf (fill-pointer *byte-buffer*) 0)
251     (let ((*previous-location* 0)
252 ram 1.32 (tlf-num (find-tlf-number fun))
253 ram 1.12 (env (lambda-environment fun))
254     (prev-locs nil)
255     (prev-block nil))
256     (collect ((elsewhere))
257     (do-environment-ir2-blocks (2block env)
258 ram 1.3 (let ((block (ir2-block-block 2block)))
259     (when (eq (block-info block) 2block)
260 ram 1.12 (when prev-block
261     (dump-block-locations prev-block prev-locs tlf-num var-locs))
262     (setq prev-block block prev-locs ())
263     (dump-block-successors block env)))
264    
265     (collect ((here prev-locs))
266 ram 1.3 (dolist (loc (ir2-block-locations 2block))
267 ram 1.12 (if (label-elsewhere-p (location-info-label loc))
268     (elsewhere loc)
269     (here loc)))
270     (setq prev-locs (here))))
271 ram 1.3
272 ram 1.12 (dump-block-locations prev-block prev-locs tlf-num var-locs)
273 ram 1.3
274 ram 1.8 (when (elsewhere)
275     (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
276     (write-var-integer (length (elsewhere)) *byte-buffer*)
277     (dolist (loc (elsewhere))
278     (dump-location-from-info loc tlf-num var-locs))))
279    
280 ram 1.3 (values (copy-seq *byte-buffer*) tlf-num)))
281    
282    
283 rtoy 1.47 (defun namestring-for-debug-source (file-info)
284     "Extract the namestring from FILE-INFO for the DEBUG-SOURCE.
285     Return FILE-INFO's untruename (e.g., target:foo) if it is absolute;
286     otherwise the truename."
287     (let* ((untruename (file-info-untruename file-info))
288     (dir (pathname-directory untruename)))
289     (namestring (if (and dir (eq (first dir) :absolute))
290     untruename
291     (file-info-name file-info)))))
292    
293 wlott 1.1 ;;; DEBUG-SOURCE-FOR-INFO -- Interface
294     ;;;
295     ;;; Return a list of DEBUG-SOURCE structures containing information derived
296 ram 1.37 ;;; from Info. Unless :BYTE-COMPILE T was specified, we always dump the
297     ;;; Start-Positions, since it is too hard figure out whether we need them or
298     ;;; not.
299 wlott 1.1 ;;;
300     (defun debug-source-for-info (info)
301     (declare (type source-info info))
302     (assert (not (source-info-current-file info)))
303     (mapcar #'(lambda (x)
304 ram 1.34 (let ((res (make-debug-source
305 wlott 1.1 :from :file
306 ram 1.11 :comment (file-info-comment x)
307 wlott 1.1 :created (file-info-write-date x)
308     :compiled (source-info-start-time info)
309     :source-root (file-info-source-root x)
310 ram 1.6 :start-positions
311 ram 1.37 (unless (eq *byte-compile* 't)
312     (coerce-to-smallest-eltype
313     (file-info-positions x)))))
314 ram 1.35 (name (file-info-name x)))
315 ram 1.34 (etypecase name
316 ram 1.36 ((member :stream :lisp)
317 ram 1.34 (setf (debug-source-from res) name)
318     (setf (debug-source-name res)
319     (coerce (file-info-forms x) 'simple-vector)))
320     (pathname
321 rtoy 1.47 (setf (debug-source-name res)
322     (namestring-for-debug-source x))))
323 wlott 1.1 res))
324     (source-info-files info)))
325    
326    
327 ram 1.3 ;;; COERCE-TO-SMALLEST-ELTYPE -- Internal
328     ;;;
329     ;;; Given an arbirtary sequence, coerce it to an unsigned vector if
330     ;;; possible.
331     ;;;
332     (defun coerce-to-smallest-eltype (seq)
333 ram 1.18 (declare (type sequence seq))
334 ram 1.3 (let ((max 0))
335 ram 1.18 (declare (type (or index null) max))
336 ram 1.3 (macrolet ((frob ()
337 ram 1.18 '(if (and (typep val 'index) max)
338 ram 1.3 (when (> val max)
339     (setq max val))
340     (setq max nil))))
341     (if (listp seq)
342 ram 1.6 (dolist (val seq)
343 ram 1.3 (frob))
344     (dotimes (i (length seq))
345     (let ((val (aref seq i)))
346     (frob)))))
347    
348     (if max
349 wlott 1.40 (coerce seq `(simple-array (integer 0 ,max) (*)))
350 ram 1.3 (coerce seq 'simple-vector))))
351    
352    
353 ram 1.15 ;;;; Variables:
354 ram 1.3
355 ram 1.2 ;;; TN-SC-OFFSET -- Internal
356 wlott 1.1 ;;;
357 ram 1.2 ;;; Return a SC-OFFSET describing TN's location.
358 wlott 1.1 ;;;
359 ram 1.2 (defun tn-sc-offset (tn)
360     (declare (type tn tn))
361     (make-sc-offset (sc-number (tn-sc tn))
362     (tn-offset tn)))
363 wlott 1.1
364    
365 ram 1.3 ;;; DUMP-1-VARIABLE -- Internal
366 ram 1.2 ;;;
367     ;;; Dump info to represent Var's location being TN. ID is an integer that
368     ;;; makes Var's name unique in the function. Buffer is the vector we stick the
369 ram 1.22 ;;; result in. If Minimal is true, we suppress name dumping, and set the
370     ;;; minimal flag.
371 ram 1.2 ;;;
372 ram 1.16 ;;; The debug-variable is only marked as always-live if the TN is
373     ;;; environment live and is an argument. If a :debug-environment TN, then we
374     ;;; also exclude set variables, since the variable is not guranteed to be live
375     ;;; everywhere in that case.
376     ;;;
377 ram 1.22 (defun dump-1-variable (fun var tn id minimal buffer)
378     (declare (type lambda-var var) (type (or tn null) tn) (type index id)
379 ram 1.15 (type clambda fun))
380 ram 1.2 (let* ((name (leaf-name var))
381     (package (symbol-package name))
382     (package-p (and package (not (eq package *package*))))
383 ram 1.22 (save-tn (and tn (tn-save-tn tn)))
384     (kind (and tn (tn-kind tn)))
385 ram 1.2 (flags 0))
386 ram 1.18 (declare (type index flags))
387 gerd 1.45 ;;
388     ;; FIXME: Dead code elimination sometimes leaves spurious
389     ;; references to unused lambda-vars. Unused vars are not packed,
390     ;; and so have a tn but a null tn-offset. Some of these cases
391     ;; have been fixed, but not all of them, and since it's not sure
392     ;; if/when all of them will be fixed, add a hack for these cases.
393     ;; -- gerd 2003-10-06
394     (when (and tn (null (tn-offset tn)))
395     (setq tn nil))
396    
397 ram 1.22 (cond (minimal
398     (setq flags (logior flags compiled-debug-variable-minimal-p))
399     (unless tn
400     (setq flags (logior flags compiled-debug-variable-deleted-p))))
401     (t
402     (unless package
403     (setq flags (logior flags compiled-debug-variable-uninterned)))
404     (when package-p
405     (setq flags (logior flags compiled-debug-variable-packaged)))))
406 ram 1.16 (when (and (or (eq kind :environment)
407     (and (eq kind :debug-environment)
408     (null (basic-var-sets var))))
409 ram 1.18 (not (gethash tn (ir2-component-spilled-tns
410     (component-info *compile-component*))))
411 ram 1.15 (eq (lambda-var-home var) fun))
412 ram 1.8 (setq flags (logior flags compiled-debug-variable-environment-live)))
413 ram 1.2 (when save-tn
414 ram 1.8 (setq flags (logior flags compiled-debug-variable-save-loc-p)))
415 ram 1.22 (unless (or (zerop id) minimal)
416 ram 1.8 (setq flags (logior flags compiled-debug-variable-id-p)))
417 ram 1.2 (vector-push-extend flags buffer)
418 ram 1.22 (unless minimal
419     (write-var-string (symbol-name name) buffer)
420     (when package-p
421     (write-var-string (package-name package) buffer))
422     (unless (zerop id)
423     (write-var-integer id buffer)))
424     (if tn
425     (write-var-integer (tn-sc-offset tn) buffer)
426     (assert minimal))
427 ram 1.2 (when save-tn
428     (write-var-integer (tn-sc-offset save-tn) buffer)))
429     (undefined-value))
430    
431    
432 wlott 1.1 ;;; COMPUTE-VARIABLES -- Internal
433     ;;;
434     ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
435 ram 1.2 ;;; Level is the current DEBUG-INFO quality. Var-Locs is a hashtable in which
436     ;;; we enter the translation from LAMBDA-VARS to the relative position of that
437     ;;; variable's location in the resulting vector.
438 wlott 1.1 ;;;
439 ram 1.2 (defun compute-variables (fun level var-locs)
440 wlott 1.1 (declare (type clambda fun) (type hash-table var-locs))
441 ram 1.2 (collect ((vars))
442     (labels ((frob-leaf (leaf tn gensym-p)
443 wlott 1.1 (let ((name (leaf-name leaf)))
444 ram 1.20 (when (and name (leaf-refs leaf) (tn-offset tn)
445 ram 1.2 (or gensym-p (symbol-package name)))
446     (vars (cons leaf tn)))))
447     (frob-lambda (x gensym-p)
448     (dolist (leaf (lambda-vars x))
449     (frob-leaf leaf (leaf-info leaf) gensym-p))))
450     (frob-lambda fun t)
451     (when (>= level 2)
452     (dolist (x (ir2-environment-environment
453     (environment-info (lambda-environment fun))))
454     (let ((thing (car x)))
455     (when (lambda-var-p thing)
456     (frob-leaf thing (cdr x) (= level 3)))))
457    
458     (dolist (let (lambda-lets fun))
459 ram 1.6 (frob-lambda let (= level 3)))))
460 wlott 1.1
461 ram 1.2 (setf (fill-pointer *byte-buffer*) 0)
462     (let ((sorted (sort (vars) #'string<
463     :key #'(lambda (x)
464     (symbol-name (leaf-name (car x))))))
465     (prev-name nil)
466     (id 0)
467     (i 0))
468 ram 1.18 (declare (type (or simple-string null) prev-name)
469     (type index id i))
470 ram 1.2 (dolist (x sorted)
471     (let* ((var (car x))
472     (name (symbol-name (leaf-name var))))
473     (cond ((and prev-name (string= prev-name name))
474     (incf id))
475     (t
476     (setq id 0 prev-name name)))
477 ram 1.22 (dump-1-variable fun var (cdr x) id nil *byte-buffer*)
478 ram 1.3 (setf (gethash var var-locs) i))
479 ram 1.2 (incf i)))
480 wlott 1.1
481 ram 1.2 (copy-seq *byte-buffer*)))
482 wlott 1.1
483 ram 1.2
484 ram 1.22 ;;; COMPUTE-MINIMAL-VARIABLES -- Internal
485     ;;;
486     ;;; Dump out the arguments to Fun in the minimal variable format.
487     ;;;
488     (defun compute-minimal-variables (fun)
489     (declare (type clambda fun))
490     (setf (fill-pointer *byte-buffer*) 0)
491     (dolist (var (lambda-vars fun))
492     (dump-1-variable fun var (leaf-info var) 0 t *byte-buffer*))
493     (copy-seq *byte-buffer*))
494    
495    
496 ram 1.2 ;;; DEBUG-LOCATION-FOR -- Internal
497     ;;;
498     ;;; Return Var's relative position in the function's variables (determined
499 ram 1.8 ;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
500 ram 1.2 ;;;
501     (defun debug-location-for (var var-locs)
502 ram 1.7 (declare (type lambda-var var) (type hash-table var-locs))
503 ram 1.2 (let ((res (gethash var var-locs)))
504 ram 1.8 (cond (res)
505     (t
506 ram 1.20 (assert (or (null (leaf-refs var))
507     (not (tn-offset (leaf-info var)))))
508 ram 1.8 'deleted))))
509 ram 1.2
510 ram 1.3
511     ;;;; Arguments/returns:
512 ram 1.2
513 wlott 1.1 ;;; COMPUTE-ARGUMENTS -- Internal
514     ;;;
515     ;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
516     ;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the
517     ;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
518     ;;;
519     ;;; ### This assumption breaks down in EPs other than the main-entry, since
520     ;;; they may or may not have supplied-p vars, etc.
521     ;;;
522     (defun compute-arguments (fun var-locs)
523     (declare (type clambda fun) (type hash-table var-locs))
524     (collect ((res))
525     (let ((od (lambda-optional-dispatch fun)))
526     (if (and od (eq (optional-dispatch-main-entry od) fun))
527 ram 1.12 (let ((actual-vars (lambda-vars fun))
528     (saw-optional nil))
529 wlott 1.1 (dolist (arg (optional-dispatch-arglist od))
530     (let ((info (lambda-var-arg-info arg))
531     (actual (pop actual-vars)))
532     (cond (info
533     (case (arg-info-kind info)
534     (:keyword
535     (res (arg-info-keyword info)))
536     (:rest
537 ram 1.12 (res 'rest-arg))
538 wlott 1.39 (:more-context
539     (res 'more-arg))
540 ram 1.12 (:optional
541     (unless saw-optional
542     (res 'optional-args)
543     (setq saw-optional t))))
544 wlott 1.1 (res (debug-location-for actual var-locs))
545     (when (arg-info-supplied-p info)
546     (res 'supplied-p)
547     (res (debug-location-for (pop actual-vars) var-locs))))
548     (t
549     (res (debug-location-for actual var-locs)))))))
550     (dolist (var (lambda-vars fun))
551     (res (debug-location-for var var-locs)))))
552    
553 ram 1.3 (coerce-to-smallest-eltype (res))))
554 wlott 1.1
555    
556     ;;; COMPUTE-DEBUG-RETURNS -- Internal
557     ;;;
558 ram 1.8 ;;; Return a vector of SC offsets describing Fun's return locations. (Must
559     ;;; be known values return...)
560 wlott 1.1 ;;;
561     (defun compute-debug-returns (fun)
562 ram 1.3 (coerce-to-smallest-eltype
563     (mapcar #'(lambda (loc)
564     (tn-sc-offset loc))
565     (return-info-locations (tail-set-info (lambda-tail-set fun))))))
566 wlott 1.1
567 ram 1.3
568 ram 1.22 ;;;; Debug functions:
569    
570     ;;; DFUN-FROM-FUN -- Internal
571     ;;;
572     ;;; Return a C-D-F structure with all the mandatory slots filled in.
573     ;;;
574     (defun dfun-from-fun (fun)
575     (declare (type clambda fun))
576     (let* ((2env (environment-info (lambda-environment fun)))
577     (dispatch (lambda-optional-dispatch fun))
578     (main-p (and dispatch
579     (eq fun (optional-dispatch-main-entry dispatch)))))
580     (make-compiled-debug-function
581     :name (cond ((leaf-name fun))
582     ((let ((ef (functional-entry-function
583     fun)))
584     (and ef (leaf-name ef))))
585     ((and main-p (leaf-name dispatch)))
586     (t
587     (component-name
588     (block-component (node-block (lambda-bind fun))))))
589     :kind (if main-p nil (functional-kind fun))
590     :return-pc (tn-sc-offset (ir2-environment-return-pc 2env))
591     :old-fp (tn-sc-offset (ir2-environment-old-fp 2env))
592     :start-pc (label-position (ir2-environment-environment-start 2env))
593     :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env)))))
594    
595    
596     ;;; COMPUTE-1-DEBUG-FUNCTION -- Internal
597     ;;;
598     ;;; Return a complete C-D-F structure for Fun. This involves determining
599     ;;; the DEBUG-INFO level and filling in optional slots as appropriate.
600     ;;;
601     (defun compute-1-debug-function (fun var-locs)
602     (declare (type clambda fun) (type hash-table var-locs))
603     (let* ((dfun (dfun-from-fun fun))
604 ram 1.32 (actual-level
605     (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
606     (level (if *collect-dynamic-statistics*
607     (max actual-level 2)
608     actual-level)))
609 ram 1.22 (cond ((zerop level))
610     ((and (<= level 1)
611     (let ((od (lambda-optional-dispatch fun)))
612     (or (not od)
613     (not (eq (optional-dispatch-main-entry od) fun)))))
614     (setf (compiled-debug-function-variables dfun)
615     (compute-minimal-variables fun))
616     (setf (compiled-debug-function-arguments dfun) :minimal))
617     (t
618 ram 1.24 (setf (compiled-debug-function-variables dfun)
619     (compute-variables fun level var-locs))
620     (setf (compiled-debug-function-arguments dfun)
621     (compute-arguments fun var-locs))))
622 ram 1.22
623 gerd 1.46 (if (>= level 2)
624     (multiple-value-bind (blocks tlf-num)
625     (compute-debug-blocks fun var-locs)
626     (setf (compiled-debug-function-tlf-number dfun) tlf-num)
627     (setf (compiled-debug-function-blocks dfun) blocks))
628     (setf (compiled-debug-function-tlf-number dfun)
629     (find-tlf-number fun)))
630 ram 1.22
631     (if (external-entry-point-p fun)
632     (setf (compiled-debug-function-returns dfun) :standard)
633 ram 1.26 (let ((info (tail-set-info (lambda-tail-set fun))))
634     (when info
635     (cond ((eq (return-info-kind info) :unknown)
636     (setf (compiled-debug-function-returns dfun)
637     :standard))
638     ((/= level 0)
639     (setf (compiled-debug-function-returns dfun)
640     (compute-debug-returns fun)))))))
641 ram 1.22 dfun))
642    
643    
644     ;;;; Minimal debug functions:
645    
646     ;;; DEBUG-FUNCTION-MINIMAL-P -- Internal
647     ;;;
648     ;;; Return true if Dfun can be represented as a minimal debug function.
649     ;;; Dfun is a cons (<start offset> . C-D-F).
650     ;;;
651     (defun debug-function-minimal-p (dfun)
652     (declare (type cons dfun))
653     (let ((dfun (cdr dfun)))
654     (and (member (compiled-debug-function-arguments dfun) '(:minimal nil))
655     (null (compiled-debug-function-blocks dfun)))))
656    
657    
658     ;;; DUMP-1-MINIMAL-DFUN -- Internal
659     ;;;
660     ;;; Dump a packed binary representation of a Dfun into *byte-buffer*.
661     ;;; Prev-Start and Start are the byte offsets in the code where the previous
662     ;;; function started and where this one starts. Prev-Elsewhere is the previous
663     ;;; function's elsewhere PC.
664     ;;;
665     (defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere)
666     (declare (type compiled-debug-function dfun)
667     (type index prev-start start prev-elsewhere))
668     (let* ((name (compiled-debug-function-name dfun))
669     (setf-p (and (consp name) (eq (car name) 'setf)
670     (consp (cdr name)) (symbolp (cadr name))))
671 emarsden 1.44 (base-name (if (stringp name) name
672     (multiple-value-bind (valid block-name)
673     (valid-function-name-p name)
674     (assert valid)
675     block-name)))
676 ram 1.22 (pkg (when (symbolp base-name)
677     (symbol-package base-name)))
678     (name-rep
679     (cond ((stringp base-name)
680     minimal-debug-function-name-component)
681     ((not pkg)
682     minimal-debug-function-name-uninterned)
683     ((eq pkg *package*)
684     minimal-debug-function-name-symbol)
685     (t
686     minimal-debug-function-name-packaged))))
687     (let ((options 0))
688     (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
689     (setf (ldb minimal-debug-function-kind-byte options)
690 ram 1.38 (eposition (compiled-debug-function-kind dfun)
691 ram 1.22 minimal-debug-function-kinds))
692     (setf (ldb minimal-debug-function-returns-byte options)
693     (etypecase (compiled-debug-function-returns dfun)
694     ((member :standard) minimal-debug-function-returns-standard)
695     ((member :fixed) minimal-debug-function-returns-fixed)
696     (vector minimal-debug-function-returns-specified)))
697     (vector-push-extend options *byte-buffer*))
698    
699     (let ((flags 0))
700     (when setf-p
701     (setq flags (logior flags minimal-debug-function-setf-bit)))
702     (when (compiled-debug-function-nfp dfun)
703     (setq flags (logior flags minimal-debug-function-nfp-bit)))
704     (when (compiled-debug-function-variables dfun)
705     (setq flags (logior flags minimal-debug-function-variables-bit)))
706     (vector-push-extend flags *byte-buffer*))
707    
708     (when (eql name-rep minimal-debug-function-name-packaged)
709     (write-var-string (package-name pkg) *byte-buffer*))
710     (unless (stringp base-name)
711     (write-var-string (symbol-name base-name) *byte-buffer*))
712    
713     (let ((vars (compiled-debug-function-variables dfun)))
714     (when vars
715     (let ((len (length vars)))
716     (write-var-integer len *byte-buffer*)
717     (dotimes (i len)
718     (vector-push-extend (aref vars i) *byte-buffer*)))))
719    
720     (let ((returns (compiled-debug-function-returns dfun)))
721     (when (vectorp returns)
722     (let ((len (length returns)))
723     (write-var-integer len *byte-buffer*)
724     (dotimes (i len)
725     (write-var-integer (aref returns i) *byte-buffer*)))))
726    
727     (write-var-integer (compiled-debug-function-return-pc dfun)
728     *byte-buffer*)
729     (write-var-integer (compiled-debug-function-old-fp dfun)
730     *byte-buffer*)
731     (when (compiled-debug-function-nfp dfun)
732     (write-var-integer (compiled-debug-function-nfp dfun)
733     *byte-buffer*))
734     (write-var-integer (- start prev-start) *byte-buffer*)
735     (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
736     *byte-buffer*)
737     (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
738     prev-elsewhere)
739     *byte-buffer*)))
740    
741    
742     ;;; COMPUTE-MINIMAL-DEBUG-FUNCTIONS -- Internal
743     ;;;
744     ;;; Return a byte-vector holding all the debug functions for a component in
745     ;;; the packed binary minimal-debug-function format.
746     ;;;
747     (defun compute-minimal-debug-functions (dfuns)
748     (declare (list dfuns))
749     (setf (fill-pointer *byte-buffer*) 0)
750     (let ((prev-start 0)
751     (prev-elsewhere 0))
752     (dolist (dfun dfuns)
753     (let ((start (car dfun))
754     (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun))))
755     (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
756     (setq prev-start start prev-elsewhere elsewhere))))
757     (copy-seq *byte-buffer*))
758    
759    
760     ;;;; Full component dumping:
761    
762     ;;; COMPUTE-DEBUG-FUNCTION-MAP -- Internal
763     ;;;
764     ;;; Compute the full form (simple-vector) function map.
765     ;;;
766     (defun compute-debug-function-map (sorted)
767     (declare (list sorted))
768     (let* ((len (1- (* (length sorted) 2)))
769     (funs-vec (make-array len)))
770     (do ((i -1 (+ i 2))
771     (sorted sorted (cdr sorted)))
772     ((= i len))
773     (declare (fixnum i))
774     (let ((dfun (car sorted)))
775     (unless (minusp i)
776     (setf (svref funs-vec i) (car dfun)))
777     (setf (svref funs-vec (1+ i)) (cdr dfun))))
778     funs-vec))
779    
780    
781 wlott 1.1 ;;; DEBUG-INFO-FOR-COMPONENT -- Interface
782     ;;;
783 ram 1.22 ;;; Return a debug-info structure describing component. This has to be
784     ;;; called after assembly so that source map information is available.
785     ;;;
786 wlott 1.17 (defun debug-info-for-component (component)
787     (declare (type component component))
788 ram 1.18 (let ((res (make-compiled-debug-info :name (component-name component)
789 ram 1.2 :package (package-name *package*))))
790 wlott 1.1 (collect ((dfuns))
791 ram 1.22 (let ((var-locs (make-hash-table :test #'eq))
792     (*byte-buffer*
793     (make-array 10 :element-type '(unsigned-byte 8)
794     :fill-pointer 0 :adjustable t)))
795 wlott 1.1 (dolist (fun (component-lambdas component))
796     (clrhash var-locs)
797 ram 1.22 (dfuns (cons (label-position
798     (block-label (node-block (lambda-bind fun))))
799 ram 1.23 (compute-1-debug-function fun var-locs))))
800    
801     (let ((sorted (sort (dfuns) #'< :key #'car)))
802     (setf (compiled-debug-info-function-map res)
803     (if (every #'debug-function-minimal-p sorted)
804     (compute-minimal-debug-functions sorted)
805     (compute-debug-function-map sorted))))))
806 wlott 1.1
807     res))

  ViewVC Help
Powered by ViewVC 1.1.5