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

  ViewVC Help
Powered by ViewVC 1.1.5