/[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.44 - (show annotations)
Sun Feb 16 19:05:19 2003 UTC (11 years, 2 months ago) by emarsden
Branch: MAIN
CVS Tags: snapshot-2003-10, release-18e-base, remove_negative_zero_not_zero, dynamic-extent-base, sparc_gencgc_merge, release-18e-pre2, cold-pcl-base, sparc_gencgc, release-18e, lisp-executable-base, release-18e-pre1
Branch point for: sparc_gencgc_branch, dynamic-extent, lisp-executable, release-18e-branch, cold-pcl
Changes since 1.43: +6 -3 lines
Fix an assertion on function names when dumping minimal debug info to use
VALID-FUNCTION-NAME-P, instead of checking for (setf xxx) names.

Declare two new valid function name classes: names of the form

   (:macro foo)
   (:compiler-macro foo)

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

  ViewVC Help
Powered by ViewVC 1.1.5