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

  ViewVC Help
Powered by ViewVC 1.1.5