/[cmucl]/src/compiler/debug-dump.lisp
ViewVC logotype

Contents of /src/compiler/debug-dump.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (show annotations)
Wed Aug 25 00:15:01 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.37: +3 -3 lines
Fix compiler warnings.
1 ;;; -*- 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 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/debug-dump.lisp,v 1.38 1993/08/25 00:15:01 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
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 (defvar *byte-buffer*)
22 (declaim (type (vector (unsigned-byte 8)) *byte-buffer*))
23
24
25 ;;;; Debug blocks:
26
27 (deftype location-kind ()
28 '(member :unknown-return :known-return :internal-error :non-local-exit
29 :block-start :call-site :single-value-return :non-local-entry))
30
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 (or label index null))
43 ;;
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 (defun note-debug-location (vop label kind)
54 (declare (type vop vop) (type (or label null) label)
55 (type location-kind kind))
56 (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
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 (block-environment (ir2-block-block 2block)))
69
70
71 ;;; COMPUTE-LIVE-VARS -- Internal
72 ;;;
73 ;;; Given a local conflicts vector and an IR2 block to represent the set of
74 ;;; live TNs, and the Var-Locs hash-table representing the variables dumped,
75 ;;; 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 ;;;
78 (defun compute-live-vars (live node block var-locs vop)
79 (declare (type ir2-block block) (type local-tn-bit-vector live)
80 (type hash-table var-locs) (type node node)
81 (type (or vop null) vop))
82 (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
83 :element-type 'bit
84 :initial-element 0))
85 (spilled (gethash vop
86 (ir2-component-spilled-vops
87 (component-info *compile-component*)))))
88 (do-live-tns (tn live block)
89 (let ((leaf (tn-leaf tn)))
90 (when (and (lambda-var-p leaf)
91 (or (not (member (tn-kind tn)
92 '(:environment :debug-environment)))
93 (rassoc leaf (lexenv-variables (node-lexenv node))))
94 (or (null spilled)
95 (not (member tn spilled))))
96 (let ((num (gethash leaf var-locs)))
97 (when num
98 (setf (sbit res num) 1))))))
99 res))
100
101
102 ;;; The PC for the location most recently dumped.
103 ;;;
104 (defvar *previous-location*)
105 (proclaim '(type index *previous-location*))
106
107 ;;; DUMP-1-LOCATION -- Internal
108 ;;;
109 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the
110 ;;; 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 ;;;
113 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
114 (declare (type node node) (type ir2-block block)
115 (type local-tn-bit-vector live)
116 (type (or label index) label)
117 (type location-kind kind) (type (or index null) tlf-num)
118 (type hash-table var-locs) (type (or vop null) vop))
119
120 (vector-push-extend
121 (dpb (eposition kind compiled-code-location-kinds)
122 compiled-code-location-kind-byte
123 0)
124 *byte-buffer*)
125
126 (let ((loc (if (fixnump label) label (label-position label))))
127 (write-var-integer (- loc *previous-location*) *byte-buffer*)
128 (setq *previous-location* loc))
129
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
135 (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
136 *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 (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 (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 var-locs
157 vop))
158 (undefined-value))
159
160
161 ;;; FIND-TLF-NUMBER -- Internal
162 ;;;
163 ;;; Scan all the blocks, determining if all locations are in the same TLF,
164 ;;; and returing it or NIL.
165 ;;;
166 (defun find-tlf-number (fun)
167 (declare (type clambda fun))
168 (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
169 (declare (type (or index null) res))
170 (do-environment-ir2-blocks (2block (lambda-environment fun))
171 (let ((block (ir2-block-block 2block)))
172 (when (eq (block-info block) 2block)
173 (unless (eql (source-path-tlf-number
174 (node-source-path
175 (continuation-next
176 (block-start block))))
177 res)
178 (setq res nil)))
179
180 (dolist (loc (ir2-block-locations 2block))
181 (unless (eql (source-path-tlf-number
182 (node-source-path
183 (vop-node (location-info-vop loc))))
184 res)
185 (setq res nil)))))
186 res))
187
188
189 ;;; DUMP-BLOCK-LOCATIONS -- Internal
190 ;;;
191 ;;; Dump out the number of locations and the locations for Block.
192 ;;;
193 (defun dump-block-locations (block locations tlf-num var-locs)
194 (declare (type cblock block) (list locations))
195 (if (and locations
196 (eq (location-info-kind (first locations))
197 :non-local-entry))
198 (write-var-integer (length locations) *byte-buffer*)
199 (let ((2block (block-info block)))
200 (write-var-integer (+ (length locations) 1) *byte-buffer*)
201 (dump-1-location (continuation-next (block-start block))
202 2block :block-start tlf-num
203 (ir2-block-%label 2block)
204 (ir2-block-live-out 2block)
205 var-locs
206 nil)))
207 (dolist (loc locations)
208 (dump-location-from-info loc tlf-num var-locs))
209 (undefined-value))
210
211
212 ;;; DUMP-BLOCK-SUCCESSORS -- Internal
213 ;;;
214 ;;; Dump the successors of Block, being careful not to fly into space on
215 ;;; weird successors.
216 ;;;
217 (defun dump-block-successors (block env)
218 (declare (type cblock block) (type environment env))
219 (let* ((tail (component-tail (block-component block)))
220 (succ (block-succ block))
221 (valid-succ
222 (if (and succ
223 (or (eq (car succ) tail)
224 (not (eq (block-environment (car succ)) env))))
225 ()
226 succ)))
227 (vector-push-extend
228 (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
229 *byte-buffer*)
230 (let ((base (block-number
231 (node-block
232 (lambda-bind (environment-function env))))))
233 (dolist (b valid-succ)
234 (write-var-integer
235 (the index (- (block-number b) base))
236 *byte-buffer*))))
237 (undefined-value))
238
239
240 ;;; COMPUTE-DEBUG-BLOCKS -- Internal
241 ;;;
242 ;;; Return a vector and an integer (or null) suitable for use as the BLOCKS
243 ;;; and TLF-NUMBER in Fun's debug-function. This requires two passes to
244 ;;; compute:
245 ;;; -- Scan all blocks, dumping the header and successors followed by all the
246 ;;; non-elsewhere locations.
247 ;;; -- Dump the elsewhere block header and all the elsewhere locations (if
248 ;;; any.)
249 ;;;
250 (defun compute-debug-blocks (fun var-locs)
251 (declare (type clambda fun) (type hash-table var-locs))
252 (setf (fill-pointer *byte-buffer*) 0)
253 (let ((*previous-location* 0)
254 (tlf-num (find-tlf-number fun))
255 (env (lambda-environment fun))
256 (prev-locs nil)
257 (prev-block nil))
258 (collect ((elsewhere))
259 (do-environment-ir2-blocks (2block env)
260 (let ((block (ir2-block-block 2block)))
261 (when (eq (block-info block) 2block)
262 (when prev-block
263 (dump-block-locations prev-block prev-locs tlf-num var-locs))
264 (setq prev-block block prev-locs ())
265 (dump-block-successors block env)))
266
267 (collect ((here prev-locs))
268 (dolist (loc (ir2-block-locations 2block))
269 (if (label-elsewhere-p (location-info-label loc))
270 (elsewhere loc)
271 (here loc)))
272 (setq prev-locs (here))))
273
274 (dump-block-locations prev-block prev-locs tlf-num var-locs)
275
276 (when (elsewhere)
277 (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
278 (write-var-integer (length (elsewhere)) *byte-buffer*)
279 (dolist (loc (elsewhere))
280 (dump-location-from-info loc tlf-num var-locs))))
281
282 (values (copy-seq *byte-buffer*) tlf-num)))
283
284
285 ;;; DEBUG-SOURCE-FOR-INFO -- Interface
286 ;;;
287 ;;; Return a list of DEBUG-SOURCE structures containing information derived
288 ;;; from Info. Unless :BYTE-COMPILE T was specified, we always dump the
289 ;;; Start-Positions, since it is too hard figure out whether we need them or
290 ;;; not.
291 ;;;
292 (defun debug-source-for-info (info)
293 (declare (type source-info info))
294 (assert (not (source-info-current-file info)))
295 (mapcar #'(lambda (x)
296 (let ((res (make-debug-source
297 :from :file
298 :comment (file-info-comment x)
299 :created (file-info-write-date x)
300 :compiled (source-info-start-time info)
301 :source-root (file-info-source-root x)
302 :start-positions
303 (unless (eq *byte-compile* 't)
304 (coerce-to-smallest-eltype
305 (file-info-positions x)))))
306 (name (file-info-name x)))
307 (etypecase name
308 ((member :stream :lisp)
309 (setf (debug-source-from res) name)
310 (setf (debug-source-name res)
311 (coerce (file-info-forms x) 'simple-vector)))
312 (pathname
313 (let* ((untruename (file-info-untruename x))
314 (dir (pathname-directory untruename)))
315 (setf (debug-source-name res)
316 (namestring
317 (if (and dir (eq (first dir) :absolute))
318 untruename
319 name))))))
320 res))
321 (source-info-files info)))
322
323
324 ;;; COERCE-TO-SMALLEST-ELTYPE -- Internal
325 ;;;
326 ;;; Given an arbirtary sequence, coerce it to an unsigned vector if
327 ;;; possible.
328 ;;;
329 (defun coerce-to-smallest-eltype (seq)
330 (declare (type sequence seq))
331 (let ((max 0))
332 (declare (type (or index null) max))
333 (macrolet ((frob ()
334 '(if (and (typep val 'index) max)
335 (when (> val max)
336 (setq max val))
337 (setq max nil))))
338 (if (listp seq)
339 (dolist (val seq)
340 (frob))
341 (dotimes (i (length seq))
342 (let ((val (aref seq i)))
343 (frob)))))
344
345 (if max
346 (coerce seq `(simple-array (integer 0 ,max)))
347 (coerce seq 'simple-vector))))
348
349
350 ;;;; Variables:
351
352 ;;; TN-SC-OFFSET -- Internal
353 ;;;
354 ;;; Return a SC-OFFSET describing TN's location.
355 ;;;
356 (defun tn-sc-offset (tn)
357 (declare (type tn tn))
358 (make-sc-offset (sc-number (tn-sc tn))
359 (tn-offset tn)))
360
361
362 ;;; DUMP-1-VARIABLE -- Internal
363 ;;;
364 ;;; Dump info to represent Var's location being TN. ID is an integer that
365 ;;; makes Var's name unique in the function. Buffer is the vector we stick the
366 ;;; result in. If Minimal is true, we suppress name dumping, and set the
367 ;;; minimal flag.
368 ;;;
369 ;;; The debug-variable is only marked as always-live if the TN is
370 ;;; environment live and is an argument. If a :debug-environment TN, then we
371 ;;; also exclude set variables, since the variable is not guranteed to be live
372 ;;; everywhere in that case.
373 ;;;
374 (defun dump-1-variable (fun var tn id minimal buffer)
375 (declare (type lambda-var var) (type (or tn null) tn) (type index id)
376 (type clambda fun))
377 (let* ((name (leaf-name var))
378 (package (symbol-package name))
379 (package-p (and package (not (eq package *package*))))
380 (save-tn (and tn (tn-save-tn tn)))
381 (kind (and tn (tn-kind tn)))
382 (flags 0))
383 (declare (type index flags))
384 (cond (minimal
385 (setq flags (logior flags compiled-debug-variable-minimal-p))
386 (unless tn
387 (setq flags (logior flags compiled-debug-variable-deleted-p))))
388 (t
389 (unless package
390 (setq flags (logior flags compiled-debug-variable-uninterned)))
391 (when package-p
392 (setq flags (logior flags compiled-debug-variable-packaged)))))
393 (when (and (or (eq kind :environment)
394 (and (eq kind :debug-environment)
395 (null (basic-var-sets var))))
396 (not (gethash tn (ir2-component-spilled-tns
397 (component-info *compile-component*))))
398 (eq (lambda-var-home var) fun))
399 (setq flags (logior flags compiled-debug-variable-environment-live)))
400 (when save-tn
401 (setq flags (logior flags compiled-debug-variable-save-loc-p)))
402 (unless (or (zerop id) minimal)
403 (setq flags (logior flags compiled-debug-variable-id-p)))
404 (vector-push-extend flags buffer)
405 (unless minimal
406 (write-var-string (symbol-name name) buffer)
407 (when package-p
408 (write-var-string (package-name package) buffer))
409 (unless (zerop id)
410 (write-var-integer id buffer)))
411 (if tn
412 (write-var-integer (tn-sc-offset tn) buffer)
413 (assert minimal))
414 (when save-tn
415 (write-var-integer (tn-sc-offset save-tn) buffer)))
416 (undefined-value))
417
418
419 ;;; COMPUTE-VARIABLES -- Internal
420 ;;;
421 ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
422 ;;; Level is the current DEBUG-INFO quality. Var-Locs is a hashtable in which
423 ;;; we enter the translation from LAMBDA-VARS to the relative position of that
424 ;;; variable's location in the resulting vector.
425 ;;;
426 (defun compute-variables (fun level var-locs)
427 (declare (type clambda fun) (type hash-table var-locs))
428 (collect ((vars))
429 (labels ((frob-leaf (leaf tn gensym-p)
430 (let ((name (leaf-name leaf)))
431 (when (and name (leaf-refs leaf) (tn-offset tn)
432 (or gensym-p (symbol-package name)))
433 (vars (cons leaf tn)))))
434 (frob-lambda (x gensym-p)
435 (dolist (leaf (lambda-vars x))
436 (frob-leaf leaf (leaf-info leaf) gensym-p))))
437 (frob-lambda fun t)
438 (when (>= level 2)
439 (dolist (x (ir2-environment-environment
440 (environment-info (lambda-environment fun))))
441 (let ((thing (car x)))
442 (when (lambda-var-p thing)
443 (frob-leaf thing (cdr x) (= level 3)))))
444
445 (dolist (let (lambda-lets fun))
446 (frob-lambda let (= level 3)))))
447
448 (setf (fill-pointer *byte-buffer*) 0)
449 (let ((sorted (sort (vars) #'string<
450 :key #'(lambda (x)
451 (symbol-name (leaf-name (car x))))))
452 (prev-name nil)
453 (id 0)
454 (i 0))
455 (declare (type (or simple-string null) prev-name)
456 (type index id i))
457 (dolist (x sorted)
458 (let* ((var (car x))
459 (name (symbol-name (leaf-name var))))
460 (cond ((and prev-name (string= prev-name name))
461 (incf id))
462 (t
463 (setq id 0 prev-name name)))
464 (dump-1-variable fun var (cdr x) id nil *byte-buffer*)
465 (setf (gethash var var-locs) i))
466 (incf i)))
467
468 (copy-seq *byte-buffer*)))
469
470
471 ;;; COMPUTE-MINIMAL-VARIABLES -- Internal
472 ;;;
473 ;;; Dump out the arguments to Fun in the minimal variable format.
474 ;;;
475 (defun compute-minimal-variables (fun)
476 (declare (type clambda fun))
477 (setf (fill-pointer *byte-buffer*) 0)
478 (dolist (var (lambda-vars fun))
479 (dump-1-variable fun var (leaf-info var) 0 t *byte-buffer*))
480 (copy-seq *byte-buffer*))
481
482
483 ;;; DEBUG-LOCATION-FOR -- Internal
484 ;;;
485 ;;; Return Var's relative position in the function's variables (determined
486 ;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
487 ;;;
488 (defun debug-location-for (var var-locs)
489 (declare (type lambda-var var) (type hash-table var-locs))
490 (let ((res (gethash var var-locs)))
491 (cond (res)
492 (t
493 (assert (or (null (leaf-refs var))
494 (not (tn-offset (leaf-info var)))))
495 'deleted))))
496
497
498 ;;;; Arguments/returns:
499
500 ;;; COMPUTE-ARGUMENTS -- Internal
501 ;;;
502 ;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
503 ;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the
504 ;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
505 ;;;
506 ;;; ### This assumption breaks down in EPs other than the main-entry, since
507 ;;; they may or may not have supplied-p vars, etc.
508 ;;;
509 (defun compute-arguments (fun var-locs)
510 (declare (type clambda fun) (type hash-table var-locs))
511 (collect ((res))
512 (let ((od (lambda-optional-dispatch fun)))
513 (if (and od (eq (optional-dispatch-main-entry od) fun))
514 (let ((actual-vars (lambda-vars fun))
515 (saw-optional nil))
516 (dolist (arg (optional-dispatch-arglist od))
517 (let ((info (lambda-var-arg-info arg))
518 (actual (pop actual-vars)))
519 (cond (info
520 (case (arg-info-kind info)
521 (:keyword
522 (res (arg-info-keyword info)))
523 (:rest
524 (res 'rest-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 setf-p (cadr name) name))
655 (pkg (when (symbolp base-name)
656 (symbol-package base-name)))
657 (name-rep
658 (cond ((stringp base-name)
659 minimal-debug-function-name-component)
660 ((not pkg)
661 minimal-debug-function-name-uninterned)
662 ((eq pkg *package*)
663 minimal-debug-function-name-symbol)
664 (t
665 minimal-debug-function-name-packaged))))
666 (assert (or (atom name) setf-p))
667 (let ((options 0))
668 (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
669 (setf (ldb minimal-debug-function-kind-byte options)
670 (eposition (compiled-debug-function-kind dfun)
671 minimal-debug-function-kinds))
672 (setf (ldb minimal-debug-function-returns-byte options)
673 (etypecase (compiled-debug-function-returns dfun)
674 ((member :standard) minimal-debug-function-returns-standard)
675 ((member :fixed) minimal-debug-function-returns-fixed)
676 (vector minimal-debug-function-returns-specified)))
677 (vector-push-extend options *byte-buffer*))
678
679 (let ((flags 0))
680 (when setf-p
681 (setq flags (logior flags minimal-debug-function-setf-bit)))
682 (when (compiled-debug-function-nfp dfun)
683 (setq flags (logior flags minimal-debug-function-nfp-bit)))
684 (when (compiled-debug-function-variables dfun)
685 (setq flags (logior flags minimal-debug-function-variables-bit)))
686 (vector-push-extend flags *byte-buffer*))
687
688 (when (eql name-rep minimal-debug-function-name-packaged)
689 (write-var-string (package-name pkg) *byte-buffer*))
690 (unless (stringp base-name)
691 (write-var-string (symbol-name base-name) *byte-buffer*))
692
693 (let ((vars (compiled-debug-function-variables dfun)))
694 (when vars
695 (let ((len (length vars)))
696 (write-var-integer len *byte-buffer*)
697 (dotimes (i len)
698 (vector-push-extend (aref vars i) *byte-buffer*)))))
699
700 (let ((returns (compiled-debug-function-returns dfun)))
701 (when (vectorp returns)
702 (let ((len (length returns)))
703 (write-var-integer len *byte-buffer*)
704 (dotimes (i len)
705 (write-var-integer (aref returns i) *byte-buffer*)))))
706
707 (write-var-integer (compiled-debug-function-return-pc dfun)
708 *byte-buffer*)
709 (write-var-integer (compiled-debug-function-old-fp dfun)
710 *byte-buffer*)
711 (when (compiled-debug-function-nfp dfun)
712 (write-var-integer (compiled-debug-function-nfp dfun)
713 *byte-buffer*))
714 (write-var-integer (- start prev-start) *byte-buffer*)
715 (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
716 *byte-buffer*)
717 (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
718 prev-elsewhere)
719 *byte-buffer*)))
720
721
722 ;;; COMPUTE-MINIMAL-DEBUG-FUNCTIONS -- Internal
723 ;;;
724 ;;; Return a byte-vector holding all the debug functions for a component in
725 ;;; the packed binary minimal-debug-function format.
726 ;;;
727 (defun compute-minimal-debug-functions (dfuns)
728 (declare (list dfuns))
729 (setf (fill-pointer *byte-buffer*) 0)
730 (let ((prev-start 0)
731 (prev-elsewhere 0))
732 (dolist (dfun dfuns)
733 (let ((start (car dfun))
734 (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun))))
735 (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
736 (setq prev-start start prev-elsewhere elsewhere))))
737 (copy-seq *byte-buffer*))
738
739
740 ;;;; Full component dumping:
741
742 ;;; COMPUTE-DEBUG-FUNCTION-MAP -- Internal
743 ;;;
744 ;;; Compute the full form (simple-vector) function map.
745 ;;;
746 (defun compute-debug-function-map (sorted)
747 (declare (list sorted))
748 (let* ((len (1- (* (length sorted) 2)))
749 (funs-vec (make-array len)))
750 (do ((i -1 (+ i 2))
751 (sorted sorted (cdr sorted)))
752 ((= i len))
753 (declare (fixnum i))
754 (let ((dfun (car sorted)))
755 (unless (minusp i)
756 (setf (svref funs-vec i) (car dfun)))
757 (setf (svref funs-vec (1+ i)) (cdr dfun))))
758 funs-vec))
759
760
761 ;;; DEBUG-INFO-FOR-COMPONENT -- Interface
762 ;;;
763 ;;; Return a debug-info structure describing component. This has to be
764 ;;; called after assembly so that source map information is available.
765 ;;;
766 (defun debug-info-for-component (component)
767 (declare (type component component))
768 (let ((res (make-compiled-debug-info :name (component-name component)
769 :package (package-name *package*))))
770 (collect ((dfuns))
771 (let ((var-locs (make-hash-table :test #'eq))
772 (*byte-buffer*
773 (make-array 10 :element-type '(unsigned-byte 8)
774 :fill-pointer 0 :adjustable t)))
775 (dolist (fun (component-lambdas component))
776 (clrhash var-locs)
777 (dfuns (cons (label-position
778 (block-label (node-block (lambda-bind fun))))
779 (compute-1-debug-function fun var-locs))))
780
781 (let ((sorted (sort (dfuns) #'< :key #'car)))
782 (setf (compiled-debug-info-function-map res)
783 (if (every #'debug-function-minimal-p sorted)
784 (compute-minimal-debug-functions sorted)
785 (compute-debug-function-map sorted))))))
786
787 res))

  ViewVC Help
Powered by ViewVC 1.1.5