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

  ViewVC Help
Powered by ViewVC 1.1.5