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

  ViewVC Help
Powered by ViewVC 1.1.5