/[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.2 - (show annotations)
Sat Feb 10 12:59:31 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.1: +114 -75 lines
Changed stuff to dump locations in the new packed binary format.
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
18 (defvar *byte-buffer*
19 (make-array 10 :element-type '(unsigned-byte 8)
20 :fill-pointer 0 :adjustable t))
21
22
23 ;;; DEBUG-SOURCE-FOR-INFO -- Interface
24 ;;;
25 ;;; Return a list of DEBUG-SOURCE structures containing information derived
26 ;;; from Info.
27 ;;;
28 (defun debug-source-for-info (info)
29 (declare (type source-info info))
30 (assert (not (source-info-current-file info)))
31 (mapcar #'(lambda (x)
32 (let ((name (file-info-name x))
33 (res (make-debug-source
34 :from :file
35 :created (file-info-write-date x)
36 :compiled (source-info-start-time info)
37 :source-root (file-info-source-root x)
38 :start-position 0)))
39 (cond ((pathnamep name)
40 (setf (debug-source-name res) name))
41 (t
42 (setf (debug-source-from res) name)
43 (when (eq name :lisp)
44 (setf (debug-source-name res)
45 (cadr (aref (file-info-forms x) 0))))))
46 res))
47 (source-info-files info)))
48
49
50 ;;; TN-SC-OFFSET -- Internal
51 ;;;
52 ;;; Return a SC-OFFSET describing TN's location.
53 ;;;
54 (defun tn-sc-offset (tn)
55 (declare (type tn tn))
56 (make-sc-offset (sc-number (tn-sc tn))
57 (tn-offset tn)))
58
59
60 ;;; DUMP-1-LOCATION -- Internal
61 ;;;
62 ;;; Dump info to represent Var's location being TN. ID is an integer that
63 ;;; makes Var's name unique in the function. Buffer is the vector we stick the
64 ;;; result in.
65 ;;;
66 (defun dump-1-location (var tn id buffer)
67 (declare (type lambda-var var) (type tn tn) (type unsigned-byte id))
68 (let* ((name (leaf-name var))
69 (package (symbol-package name))
70 (package-p (and package (not (eq package *package*))))
71 (save-tn (tn-save-tn tn))
72 (flags 0))
73 (unless package
74 (setq flags (logior flags compiled-location-uninterned)))
75 (when package-p
76 (setq flags (logior flags compiled-location-packaged)))
77 (when (eq (tn-kind tn) :environment)
78 (setq flags (logior flags compiled-location-environment-live)))
79 (when save-tn
80 (setq flags (logior flags compiled-location-save-loc-p)))
81 (unless (zerop id)
82 (setq flags (logior flags compiled-location-id-p)))
83 (vector-push-extend flags buffer)
84 (write-var-string (symbol-name name) buffer)
85 (when package-p
86 (write-var-string (package-name package) buffer))
87 (unless (zerop id)
88 (write-var-integer id buffer))
89 (write-var-integer (tn-sc-offset tn) buffer)
90 (when save-tn
91 (write-var-integer (tn-sc-offset save-tn) buffer)))
92 (undefined-value))
93
94
95 ;;; COMPUTE-VARIABLES -- Internal
96 ;;;
97 ;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
98 ;;; Level is the current DEBUG-INFO quality. Var-Locs is a hashtable in which
99 ;;; we enter the translation from LAMBDA-VARS to the relative position of that
100 ;;; variable's location in the resulting vector.
101 ;;;
102 (defun compute-variables (fun level var-locs)
103 (declare (type clambda fun) (type hash-table var-locs))
104 (collect ((vars))
105 (labels ((frob-leaf (leaf tn gensym-p)
106 (let ((name (leaf-name leaf)))
107 (when (and name (leaf-refs leaf)
108 (or gensym-p (symbol-package name)))
109 (vars (cons leaf tn)))))
110 (frob-lambda (x gensym-p)
111 (dolist (leaf (lambda-vars x))
112 (frob-leaf leaf (leaf-info leaf) gensym-p))))
113 (frob-lambda fun t)
114 (when (>= level 2)
115 (dolist (x (ir2-environment-environment
116 (environment-info (lambda-environment fun))))
117 (let ((thing (car x)))
118 (when (lambda-var-p thing)
119 (frob-leaf thing (cdr x) (= level 3)))))
120
121 (dolist (let (lambda-lets fun))
122 (frob let (= level 3)))))
123
124 (setf (fill-pointer *byte-buffer*) 0)
125 (let ((sorted (sort (vars) #'string<
126 :key #'(lambda (x)
127 (symbol-name (leaf-name (car x))))))
128 (prev-name nil)
129 (id 0)
130 (i 0))
131 (declare (type (or simple-string null) prev-name))
132 (dolist (x sorted)
133 (let* ((var (car x))
134 (name (symbol-name (leaf-name var))))
135 (cond ((and prev-name (string= prev-name name))
136 (incf id))
137 (t
138 (setq id 0 prev-name name)))
139 (dump-1-location var (cdr x) id *byte-buffer*))
140 (setf (gethash var var-locs) i)
141 (incf i)))
142
143 (copy-seq *byte-buffer*)))
144
145
146 ;;; DEBUG-LOCATION-FOR -- Internal
147 ;;;
148 ;;; Return Var's relative position in the function's variables (determined
149 ;;; from the Var-Locs hashtable.)
150 ;;;
151 (defun debug-location-for (var var-locs)
152 (declare (type lambda-var var) (type hashtable var-locs))
153 (let ((res (gethash var var-locs)))
154 (assert res () "No location for ~S?" var)
155 res))
156
157
158 ;;; COMPUTE-ARGUMENTS -- Internal
159 ;;;
160 ;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
161 ;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the
162 ;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
163 ;;;
164 ;;; ### This assumption breaks down in EPs other than the main-entry, since
165 ;;; they may or may not have supplied-p vars, etc.
166 ;;;
167 (defun compute-arguments (fun var-locs)
168 (declare (type clambda fun) (type hash-table var-locs))
169 (collect ((res))
170 (let ((od (lambda-optional-dispatch fun)))
171 (if (and od (eq (optional-dispatch-main-entry od) fun))
172 (let ((actual-vars (lambda-vars fun)))
173 (dolist (arg (optional-dispatch-arglist od))
174 (let ((info (lambda-var-arg-info arg))
175 (actual (pop actual-vars)))
176 (cond (info
177 (case (arg-info-kind info)
178 (:keyword
179 (res (arg-info-keyword info)))
180 (:rest
181 (res 'rest-arg)))
182 (res (debug-location-for actual var-locs))
183 (when (arg-info-supplied-p info)
184 (res 'supplied-p)
185 (res (debug-location-for (pop actual-vars) var-locs))))
186 (t
187 (res (debug-location-for actual var-locs)))))))
188 (dolist (var (lambda-vars fun))
189 (res (debug-location-for var var-locs)))))
190
191 (coerce (res) 'simple-vector)))
192
193
194 ;;; COMPUTE-DEBUG-RETURNS -- Internal
195 ;;;
196 ;;; Return a list of COMPILED-LOCATION structures for the fixed-values
197 ;;; return from Fun.
198 ;;;
199 (defun compute-debug-returns (fun)
200 (let* ((locs (return-info-locations (tail-set-info (lambda-tail-set fun))))
201 (len (length locs))
202 (res (make-array len :element-type '(unsigned-byte 32))))
203 (do ((i 0 (1+ i))
204 (loc locs (cdr loc)))
205 ((null loc))
206 (setf (aref res i) (tn-sc-offset (car loc))))
207 res))
208
209
210 ;;; DEBUG-INFO-FOR-COMPONENT -- Interface
211 ;;;
212 ;;; Return a debug-info structure describing component. This has to be called
213 ;;; at some particular time (after assembly) so that source map information is
214 ;;; available.
215 ;;;
216 (defun debug-info-for-component (component assem-nodes count)
217 (declare (type component component) (simple-vector assem-nodes)
218 (type index count))
219 (let ((level (cookie-debug *default-cookie*))
220 (res (make-compiled-debug-info :name (component-name component)
221 :package (package-name *package*))))
222 (collect ((dfuns))
223 (let ((var-locs (make-hash-table :test #'eq)))
224 (dolist (fun (component-lambdas component))
225 (clrhash var-locs)
226 (let ((dfun (make-compiled-debug-function
227 :name (cond ((leaf-name fun))
228 ((let ((ef (functional-entry-function fun)))
229 (and ef (leaf-name ef))))
230 (t
231 (component-name component)))
232 :kind (functional-kind fun))))
233
234 (when (>= level 1)
235 (setf (compiled-debug-function-variables dfun)
236 (compute-variables fun level var-locs)))
237
238 (unless (= level 0)
239 (setf (compiled-debug-function-arguments dfun)
240 (compute-arguments fun var-locs)))
241
242 (let ((tails (lambda-tail-set fun)))
243 (when tails
244 (let ((info (tail-set-info tails)))
245 (cond ((eq (return-info-kind info) :unknown)
246 (setf (compiled-debug-function-returns dfun)
247 :standard))
248 ((/= level 0)
249 (setf (compiled-debug-function-returns dfun)
250 (compute-debug-returns fun)))))))
251
252 (dfuns (cons (label-location
253 (block-label
254 (node-block
255 (lambda-bind fun))))
256 dfun)))))
257
258 (let* ((sorted (sort (dfuns) #'< :key #'car))
259 (len (1- (* (length sorted) 2)))
260 (funs-vec (make-array len)))
261 (do ((i -1 (+ i 2))
262 (sorted sorted (cdr sorted)))
263 ((= i len))
264 (let ((dfun (car sorted)))
265 (unless (minusp i)
266 (setf (svref funs-vec i) (car dfun)))
267 (setf (svref funs-vec (1+ i)) (cdr dfun))))
268 (setf (compiled-debug-info-function-map res) funs-vec)))
269
270 res))

  ViewVC Help
Powered by ViewVC 1.1.5