/[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.14 - (hide annotations)
Mon May 7 10:49:09 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Branch point for: eval_debug
Changes since 1.13: +1 -1 lines
Fixed debug-function dumping so that unnamed optional-dispatches get the
component name instead of NIL.
1 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice 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 Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10     ;;; This file contains stuff that creates debugger information from the
11     ;;; compiler's internal data structures.
12     ;;;
13     ;;; Written by Rob MacLachlan
14     ;;;
15     (in-package 'c)
16    
17 ram 1.2 (defvar *byte-buffer*
18     (make-array 10 :element-type '(unsigned-byte 8)
19     :fill-pointer 0 :adjustable t))
20    
21 ram 1.3
22     ;;;; Debug blocks:
23 ram 1.2
24 ram 1.3 (deftype location-kind ()
25 ram 1.6 '(member :unknown-return :known-return :internal-error :non-local-exit
26     :block-start))
27 ram 1.3
28    
29     ;;; The Location-Info structure holds the information what we need about
30     ;;; locations which code generation decided were "interesting".
31     ;;;
32     (defstruct (location-info
33     (:constructor make-location-info (kind label vop)))
34     ;;
35     ;; The kind of location noted.
36     (kind nil :type location-kind)
37     ;;
38     ;; The label pointing to the interesting code location.
39     (label nil :type label)
40     ;;
41     ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
42     (vop nil :type vop))
43    
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 ram 1.8 (defun note-debug-location (vop label kind)
52 ram 1.3 (declare (type vop vop) (type label label) (type location-kind kind))
53     (setf (ir2-block-locations (vop-block vop))
54     (nconc (ir2-block-locations (vop-block vop))
55     (list (make-location-info kind label vop))))
56     (undefined-value))
57    
58    
59     ;;; IR2-BLOCK-ENVIRONMENT -- Interface
60     ;;;
61     (proclaim '(inline ir2-block-environment))
62     (defun ir2-block-environment (2block)
63     (declare (type ir2-block 2block))
64     (lambda-environment (block-lambda (ir2-block-block 2block))))
65    
66    
67     ;;; COMPUTE-LIVE-VARS -- Internal
68     ;;;
69     ;;; Given a local conflicts vector and an IR2 block to represent the set of
70     ;;; live TNs, and the Var-Locs hashtable representing the variables dumped,
71     ;;; compute a bit-vector representing the set of live variables.
72     ;;;
73     (defun compute-live-vars (live block var-locs)
74     (declare (type ir2-block block) (type local-tn-bit-vector live)
75     (type hash-table var-locs))
76 ram 1.8 (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
77 ram 1.3 :element-type 'bit
78     :initial-element 0)))
79     (do-live-tns (tn live block)
80     (let ((leaf (tn-leaf tn)))
81     (when (lambda-var-p leaf)
82     (let ((num (gethash leaf var-locs)))
83     (when num
84 ram 1.7 (setf (sbit res num) 1))))))
85     res))
86 ram 1.3
87    
88     ;;; The PC for the location most recently dumped.
89     ;;;
90     (defvar *previous-location*)
91    
92     ;;; DUMP-1-LOCATION -- Internal
93     ;;;
94     ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the
95     ;;; code/source map and live info.
96     ;;;
97     (defun dump-1-location (node block kind tlf-num label live var-locs)
98     (declare (type node node) (type ir2-block block)
99     (type local-tn-bit-vector live) (type label label)
100 ram 1.6 (type location-kind kind) (type (or index null) tlf-num)
101 ram 1.3 (type hash-table var-locs))
102    
103     (vector-push-extend
104 ram 1.8 (dpb (position kind compiled-code-location-kinds)
105     compiled-code-location-kind-byte
106     0)
107 ram 1.3 *byte-buffer*)
108    
109     (let ((loc (label-location label)))
110     (write-var-integer (- loc *previous-location*) *byte-buffer*)
111     (setq *previous-location* loc))
112    
113     (unless tlf-num
114 ram 1.6 (write-var-integer (node-tlf-number node) *byte-buffer*))
115     (write-var-integer (first (node-source-path node)) *byte-buffer*)
116 ram 1.3
117     (write-packed-bit-vector (compute-live-vars live block var-locs)
118     *byte-buffer*)
119    
120     (undefined-value))
121    
122    
123     ;;; DUMP-LOCATION-FROM-INFO -- Internal
124     ;;;
125     ;;; Extract context info from a Location-Info structure and use it to dump a
126     ;;; compiled code-location.
127     ;;;
128 ram 1.7 (defun dump-location-from-info (loc tlf-num var-locs)
129     (declare (type location-info loc) (type (or index null) tlf-num)
130     (type hash-table var-locs))
131 ram 1.3 (let ((vop (location-info-vop loc)))
132     (dump-1-location (vop-node vop)
133     (vop-block vop)
134     (location-info-kind loc)
135     tlf-num
136     (location-info-label loc)
137     (vop-save-set vop)
138     var-locs))
139     (undefined-value))
140    
141    
142 ram 1.12 ;;; FIND-TLF-AND-BLOCK-NUMBERS -- Internal
143     ;;;
144     ;;; Scan all the blocks, caching the block numbering in the BLOCK-FLAG and
145     ;;; determining if all locations are in the same TLF.
146     ;;;
147     (defun find-tlf-and-block-numbers (fun)
148     (declare (type clambda fun))
149     (let ((res (node-tlf-number (lambda-bind fun)))
150     (num 0))
151     (do-environment-ir2-blocks (2block (lambda-environment fun))
152     (let ((block (ir2-block-block 2block)))
153     (when (eq (block-info block) 2block)
154     (setf (block-flag block) num)
155     (incf num)
156     (unless (eql (node-tlf-number (continuation-next (block-start block)))
157     res)
158     (setq res nil)))
159    
160     (dolist (loc (ir2-block-locations 2block))
161     (unless (eql (node-tlf-number (vop-node (location-info-vop loc)))
162     res)
163     (setq res nil)))))
164     res))
165    
166    
167     ;;; DUMP-BLOCK-LOCATIONS -- Internal
168     ;;;
169     ;;; Dump out the number of locations and the locations for Block.
170     ;;;
171     (defun dump-block-locations (block locations tlf-num var-locs)
172     (declare (type cblock block) (list locations))
173     (write-var-integer (1+ (length locations)) *byte-buffer*)
174     (let ((2block (block-info block)))
175     (dump-1-location (continuation-next (block-start block))
176     2block :block-start tlf-num
177     (ir2-block-%label 2block)
178     (ir2-block-live-out 2block)
179     var-locs))
180     (dolist (loc locations)
181     (dump-location-from-info loc tlf-num var-locs))
182     (undefined-value))
183    
184    
185     ;;; DUMP-BLOCK-SUCCESSORS -- Internal
186     ;;;
187     ;;; Dump the successors of Block, being careful not to fly into space on
188     ;;; weird successors.
189     ;;;
190     (defun dump-block-successors (block env)
191     (declare (type cblock block) (type environment env))
192     (let* ((tail (component-tail (block-component block)))
193     (succ (block-succ block))
194     (valid-succ
195     (if (and succ
196     (or (eq (car succ) tail)
197     (not (eq (lambda-environment (block-lambda (car succ)))
198     env))))
199     ()
200     succ)))
201     (vector-push-extend
202     (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
203     *byte-buffer*)
204     (dolist (b valid-succ)
205     (write-var-integer (block-flag b) *byte-buffer*)))
206     (undefined-value))
207    
208    
209 ram 1.3 ;;; COMPUTE-DEBUG-BLOCKS -- Internal
210     ;;;
211     ;;; Return a vector and an integer (or null) suitable for use as the BLOCKS
212     ;;; and TLF-NUMBER in Fun's debug-function. This requires three passes to
213     ;;; compute:
214     ;;; -- Scan all blocks, dumping the header and successors followed by all the
215     ;;; non-elsewhere locations.
216 ram 1.8 ;;; -- Dump the elsewhere block header and all the elsewhere locations (if
217     ;;; any.)
218 ram 1.3 ;;;
219     (defun compute-debug-blocks (fun var-locs)
220     (declare (type clambda fun) (type hash-table var-locs))
221     (setf (fill-pointer *byte-buffer*) 0)
222     (let ((*previous-location* 0)
223 ram 1.12 (tlf-num (find-tlf-and-block-numbers fun))
224     (env (lambda-environment fun))
225     (prev-locs nil)
226     (prev-block nil))
227     (collect ((elsewhere))
228     (do-environment-ir2-blocks (2block env)
229 ram 1.3 (let ((block (ir2-block-block 2block)))
230     (when (eq (block-info block) 2block)
231 ram 1.12 (when prev-block
232     (dump-block-locations prev-block prev-locs tlf-num var-locs))
233     (setq prev-block block prev-locs ())
234     (dump-block-successors block env)))
235    
236     (collect ((here prev-locs))
237 ram 1.3 (dolist (loc (ir2-block-locations 2block))
238 ram 1.12 (if (label-elsewhere-p (location-info-label loc))
239     (elsewhere loc)
240     (here loc)))
241     (setq prev-locs (here))))
242 ram 1.3
243 ram 1.12 (dump-block-locations prev-block prev-locs tlf-num var-locs)
244 ram 1.3
245 ram 1.8 (when (elsewhere)
246     (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
247     (write-var-integer (length (elsewhere)) *byte-buffer*)
248     (dolist (loc (elsewhere))
249     (dump-location-from-info loc tlf-num var-locs))))
250    
251 ram 1.3 (values (copy-seq *byte-buffer*) tlf-num)))
252    
253    
254 wlott 1.1 ;;; DEBUG-SOURCE-FOR-INFO -- Interface
255     ;;;
256     ;;; Return a list of DEBUG-SOURCE structures containing information derived
257     ;;; from Info.
258     ;;;
259     (defun debug-source-for-info (info)
260     (declare (type source-info info))
261     (assert (not (source-info-current-file info)))
262     (mapcar #'(lambda (x)
263     (let ((name (file-info-name x))
264     (res (make-debug-source
265     :from :file
266 ram 1.11 :comment (file-info-comment x)
267 wlott 1.1 :created (file-info-write-date x)
268     :compiled (source-info-start-time info)
269     :source-root (file-info-source-root x)
270 ram 1.6 :start-positions
271     (when (policy nil (>= debug 2))
272     (coerce-to-smallest-eltype
273     (file-info-positions x))))))
274 wlott 1.1 (cond ((pathnamep name)
275     (setf (debug-source-name res) name))
276     (t
277     (setf (debug-source-from res) name)
278     (when (eq name :lisp)
279     (setf (debug-source-name res)
280     (cadr (aref (file-info-forms x) 0))))))
281     res))
282     (source-info-files info)))
283    
284    
285 ram 1.3 ;;; COERCE-TO-SMALLEST-ELTYPE -- Internal
286     ;;;
287     ;;; Given an arbirtary sequence, coerce it to an unsigned vector if
288     ;;; possible.
289     ;;;
290     (defun coerce-to-smallest-eltype (seq)
291     (let ((max 0))
292     (macrolet ((frob ()
293     '(if (and (integerp val) (>= val 0) max)
294     (when (> val max)
295     (setq max val))
296     (setq max nil))))
297     (if (listp seq)
298 ram 1.6 (dolist (val seq)
299 ram 1.3 (frob))
300     (dotimes (i (length seq))
301     (let ((val (aref seq i)))
302     (frob)))))
303    
304     (if max
305 ram 1.10 (coerce seq `(simple-array (integer 0 ,max)))
306 ram 1.3 (coerce seq 'simple-vector))))
307    
308    
309     ;;;; Locations:
310    
311 ram 1.2 ;;; TN-SC-OFFSET -- Internal
312 wlott 1.1 ;;;
313 ram 1.2 ;;; Return a SC-OFFSET describing TN's location.
314 wlott 1.1 ;;;
315 ram 1.2 (defun tn-sc-offset (tn)
316     (declare (type tn tn))
317     (make-sc-offset (sc-number (tn-sc tn))
318     (tn-offset tn)))
319 wlott 1.1
320    
321 ram 1.3 ;;; DUMP-1-VARIABLE -- Internal
322 ram 1.2 ;;;
323     ;;; Dump info to represent Var's location being TN. ID is an integer that
324     ;;; makes Var's name unique in the function. Buffer is the vector we stick the
325     ;;; result in.
326     ;;;
327 ram 1.3 (defun dump-1-variable (var tn id buffer)
328 ram 1.2 (declare (type lambda-var var) (type tn tn) (type unsigned-byte id))
329     (let* ((name (leaf-name var))
330     (package (symbol-package name))
331     (package-p (and package (not (eq package *package*))))
332     (save-tn (tn-save-tn tn))
333     (flags 0))
334     (unless package
335 ram 1.8 (setq flags (logior flags compiled-debug-variable-uninterned)))
336 ram 1.2 (when package-p
337 ram 1.8 (setq flags (logior flags compiled-debug-variable-packaged)))
338 ram 1.2 (when (eq (tn-kind tn) :environment)
339 ram 1.8 (setq flags (logior flags compiled-debug-variable-environment-live)))
340 ram 1.2 (when save-tn
341 ram 1.8 (setq flags (logior flags compiled-debug-variable-save-loc-p)))
342 ram 1.2 (unless (zerop id)
343 ram 1.8 (setq flags (logior flags compiled-debug-variable-id-p)))
344 ram 1.2 (vector-push-extend flags buffer)
345     (write-var-string (symbol-name name) buffer)
346     (when package-p
347     (write-var-string (package-name package) buffer))
348     (unless (zerop id)
349     (write-var-integer id buffer))
350     (write-var-integer (tn-sc-offset tn) buffer)
351     (when save-tn
352     (write-var-integer (tn-sc-offset save-tn) buffer)))
353     (undefined-value))
354    
355    
356 wlott 1.1 ;;; COMPUTE-VARIABLES -- Internal
357     ;;;
358     ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
359 ram 1.2 ;;; Level is the current DEBUG-INFO quality. Var-Locs is a hashtable in which
360     ;;; we enter the translation from LAMBDA-VARS to the relative position of that
361     ;;; variable's location in the resulting vector.
362 wlott 1.1 ;;;
363 ram 1.2 (defun compute-variables (fun level var-locs)
364 wlott 1.1 (declare (type clambda fun) (type hash-table var-locs))
365 ram 1.2 (collect ((vars))
366     (labels ((frob-leaf (leaf tn gensym-p)
367 wlott 1.1 (let ((name (leaf-name leaf)))
368     (when (and name (leaf-refs leaf)
369 ram 1.2 (or gensym-p (symbol-package name)))
370     (vars (cons leaf tn)))))
371     (frob-lambda (x gensym-p)
372     (dolist (leaf (lambda-vars x))
373     (frob-leaf leaf (leaf-info leaf) gensym-p))))
374     (frob-lambda fun t)
375     (when (>= level 2)
376     (dolist (x (ir2-environment-environment
377     (environment-info (lambda-environment fun))))
378     (let ((thing (car x)))
379     (when (lambda-var-p thing)
380     (frob-leaf thing (cdr x) (= level 3)))))
381    
382     (dolist (let (lambda-lets fun))
383 ram 1.6 (frob-lambda let (= level 3)))))
384 wlott 1.1
385 ram 1.2 (setf (fill-pointer *byte-buffer*) 0)
386     (let ((sorted (sort (vars) #'string<
387     :key #'(lambda (x)
388     (symbol-name (leaf-name (car x))))))
389     (prev-name nil)
390     (id 0)
391     (i 0))
392     (declare (type (or simple-string null) prev-name))
393     (dolist (x sorted)
394     (let* ((var (car x))
395     (name (symbol-name (leaf-name var))))
396     (cond ((and prev-name (string= prev-name name))
397     (incf id))
398     (t
399     (setq id 0 prev-name name)))
400 ram 1.3 (dump-1-variable var (cdr x) id *byte-buffer*)
401     (setf (gethash var var-locs) i))
402 ram 1.2 (incf i)))
403 wlott 1.1
404 ram 1.2 (copy-seq *byte-buffer*)))
405 wlott 1.1
406 ram 1.2
407     ;;; DEBUG-LOCATION-FOR -- Internal
408     ;;;
409     ;;; Return Var's relative position in the function's variables (determined
410 ram 1.8 ;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
411 ram 1.2 ;;;
412     (defun debug-location-for (var var-locs)
413 ram 1.7 (declare (type lambda-var var) (type hash-table var-locs))
414 ram 1.2 (let ((res (gethash var var-locs)))
415 ram 1.8 (cond (res)
416     (t
417     (assert (null (leaf-refs var)))
418     'deleted))))
419 ram 1.2
420 ram 1.3
421     ;;;; Arguments/returns:
422 ram 1.2
423 wlott 1.1 ;;; COMPUTE-ARGUMENTS -- Internal
424     ;;;
425     ;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
426     ;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the
427     ;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
428     ;;;
429     ;;; ### This assumption breaks down in EPs other than the main-entry, since
430     ;;; they may or may not have supplied-p vars, etc.
431     ;;;
432     (defun compute-arguments (fun var-locs)
433     (declare (type clambda fun) (type hash-table var-locs))
434     (collect ((res))
435     (let ((od (lambda-optional-dispatch fun)))
436     (if (and od (eq (optional-dispatch-main-entry od) fun))
437 ram 1.12 (let ((actual-vars (lambda-vars fun))
438     (saw-optional nil))
439 wlott 1.1 (dolist (arg (optional-dispatch-arglist od))
440     (let ((info (lambda-var-arg-info arg))
441     (actual (pop actual-vars)))
442     (cond (info
443     (case (arg-info-kind info)
444     (:keyword
445     (res (arg-info-keyword info)))
446     (:rest
447 ram 1.12 (res 'rest-arg))
448     (:optional
449     (unless saw-optional
450     (res 'optional-args)
451     (setq saw-optional t))))
452 wlott 1.1 (res (debug-location-for actual var-locs))
453     (when (arg-info-supplied-p info)
454     (res 'supplied-p)
455     (res (debug-location-for (pop actual-vars) var-locs))))
456     (t
457     (res (debug-location-for actual var-locs)))))))
458     (dolist (var (lambda-vars fun))
459     (res (debug-location-for var var-locs)))))
460    
461 ram 1.3 (coerce-to-smallest-eltype (res))))
462 wlott 1.1
463    
464     ;;; COMPUTE-DEBUG-RETURNS -- Internal
465     ;;;
466 ram 1.8 ;;; Return a vector of SC offsets describing Fun's return locations. (Must
467     ;;; be known values return...)
468 wlott 1.1 ;;;
469     (defun compute-debug-returns (fun)
470 ram 1.3 (coerce-to-smallest-eltype
471     (mapcar #'(lambda (loc)
472     (tn-sc-offset loc))
473     (return-info-locations (tail-set-info (lambda-tail-set fun))))))
474 wlott 1.1
475 ram 1.3
476 wlott 1.1 ;;; DEBUG-INFO-FOR-COMPONENT -- Interface
477     ;;;
478     ;;; Return a debug-info structure describing component. This has to be called
479     ;;; at some particular time (after assembly) so that source map information is
480     ;;; available.
481     ;;;
482     (defun debug-info-for-component (component assem-nodes count)
483     (declare (type component component) (simple-vector assem-nodes)
484     (type index count))
485 ram 1.2 (let ((level (cookie-debug *default-cookie*))
486     (res (make-compiled-debug-info :name (component-name component)
487     :package (package-name *package*))))
488 wlott 1.1 (collect ((dfuns))
489     (let ((var-locs (make-hash-table :test #'eq)))
490     (dolist (fun (component-lambdas component))
491     (clrhash var-locs)
492 ram 1.5 (let* ((2env (environment-info (lambda-environment fun)))
493 ram 1.12 (dispatch (lambda-optional-dispatch fun))
494     (main-p (and dispatch
495 ram 1.13 (eq fun (optional-dispatch-main-entry dispatch))))
496 ram 1.5 (dfun (make-compiled-debug-function
497     :name (cond ((leaf-name fun))
498 ram 1.9 ((let ((ef (functional-entry-function
499     fun)))
500 ram 1.5 (and ef (leaf-name ef))))
501 ram 1.14 ((and main-p (leaf-name dispatch)))
502 ram 1.5 (t
503     (component-name component)))
504 ram 1.12 :kind (if main-p nil (functional-kind fun))
505 ram 1.5 :return-pc (tn-sc-offset
506     (ir2-environment-return-pc 2env))
507 ram 1.11 :old-fp (tn-sc-offset
508     (ir2-environment-old-fp 2env))
509 ram 1.9 :start-pc (label-location
510     (ir2-environment-environment-start 2env))
511    
512     :elsewhere-pc
513     (label-location
514     (ir2-environment-elsewhere-start 2env)))))
515 wlott 1.1
516 ram 1.2 (when (>= level 1)
517 wlott 1.1 (setf (compiled-debug-function-variables dfun)
518 ram 1.2 (compute-variables fun level var-locs)))
519 wlott 1.1
520 ram 1.2 (unless (= level 0)
521 wlott 1.1 (setf (compiled-debug-function-arguments dfun)
522     (compute-arguments fun var-locs)))
523 ram 1.3
524     (when (>= level 2)
525     (multiple-value-bind (blocks tlf-num)
526 ram 1.6 (compute-debug-blocks fun var-locs)
527 ram 1.8 (setf (compiled-debug-function-tlf-number dfun) tlf-num)
528     (setf (compiled-debug-function-blocks dfun) blocks)))
529 wlott 1.1
530     (let ((tails (lambda-tail-set fun)))
531     (when tails
532     (let ((info (tail-set-info tails)))
533     (cond ((eq (return-info-kind info) :unknown)
534     (setf (compiled-debug-function-returns dfun)
535     :standard))
536 ram 1.2 ((/= level 0)
537 wlott 1.1 (setf (compiled-debug-function-returns dfun)
538     (compute-debug-returns fun)))))))
539    
540     (dfuns (cons (label-location
541     (block-label
542     (node-block
543     (lambda-bind fun))))
544     dfun)))))
545    
546     (let* ((sorted (sort (dfuns) #'< :key #'car))
547     (len (1- (* (length sorted) 2)))
548     (funs-vec (make-array len)))
549     (do ((i -1 (+ i 2))
550     (sorted sorted (cdr sorted)))
551     ((= i len))
552     (let ((dfun (car sorted)))
553     (unless (minusp i)
554     (setf (svref funs-vec i) (car dfun)))
555     (setf (svref funs-vec (1+ i)) (cdr dfun))))
556     (setf (compiled-debug-info-function-map res) funs-vec)))
557    
558     res))

  ViewVC Help
Powered by ViewVC 1.1.5