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

  ViewVC Help
Powered by ViewVC 1.1.5