/[cmucl]/src/code/cprofile.lisp
ViewVC logotype

Contents of /src/code/cprofile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri Mar 19 15:18:58 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: post-merge-intl-branch, snapshot-2010-04
Changes since 1.2: +16 -14 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: CPROFILE -*-
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/code/cprofile.lisp,v 1.3 2010/03/19 15:18:58 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains run-time support for collecting dynamic profiling
13 ;;; information from code instrumented by the compiler.
14 ;;;
15 (intl:textdomain "cmucl")
16
17 (defpackage "CPROFILE"
18 (:use "C" "DI" "KERNEL" "EXTENSIONS" "LISP" "SYSTEM"))
19 (in-package "C")
20 (export '(dyncount-info dyncount-info-p) "C")
21 (in-package "CPROFILE")
22
23 (eval-when (compile)
24 (when *collect-dynamic-statistics*
25 (error _"You don't want to compile this file with profiling.")))
26
27
28 ;;; Represents a single high-cost code object we've pulled out of memory.
29 ;;;
30 (defstruct (selection-elt
31 (:print-function
32 (lambda (s stream d)
33 (declare (ignore d))
34 (print-unreadable-object (s stream :type t :identity t)))))
35 ;;
36 ;; The code-object we're collecting info for.
37 (code nil)
38 ;;
39 ;; The Dyncount-Info for this object (the first constant.)
40 (info nil :type (or dyncount-info null))
41 ;;
42 ;; The total cost associated with this code object.
43 (cost 0d0 :type double-float)
44
45 ;;
46 ;; Remaining slots only filled in when we have definitely selected this
47 ;; object...
48 ;;
49 ;; A copy of the counts vector (so the results don't get modified.)
50 (counts nil :type (or (simple-array (unsigned-byte 32) (*)) null))
51 ;;
52 ;; A list of lists ((debug-function cost first-index) for all the functions
53 ;; in this object, where cost is the total cost for this function and
54 ;; first-index is the index in costs/counts of the first block in this
55 ;; function.
56 (functions nil :type list))
57
58
59 ;;; Represents a collection of the N most expensive code objects.
60 ;;;
61 (defstruct (selection
62 (:print-function
63 (lambda (s stream d)
64 (declare (ignore d))
65 (print-unreadable-object (s stream :type t :identity t)
66 (format stream _"~A, top ~D, cost ~S" (selection-name s)
67 (length (selection-elements s))
68 (selection-total-cost s))))))
69 ;;
70 ;; Some kind of descriptive name.
71 (name (required-argument) :type string)
72 ;;
73 ;; Total cost of all code objects scanned.
74 (total-cost 0d0 :type double-float)
75 ;;
76 ;; List of elements selected.
77 (elements (list (make-selection-elt :cost -1d0)) :type list))
78
79
80 (defconstant count-me-cost-fudge 3d0
81 _N"Our guess is to how many cycles in each block are really due to
82 profiling.")
83
84 ;;; SAVE-SELECT-RESULT -- Internal
85 ;;;
86 ;;; First copy all of the counts vectors, then find the debug-functions and
87 ;;; costs. This split avoids considering spurious costs related to parsing
88 ;;; debug-info, etc.
89 ;;;
90 (defun save-select-result (res)
91 (dolist (elt res)
92 (declare (optimize (speed 3) (safety 0)))
93 (let* ((info (selection-elt-info elt))
94 (counts (dyncount-info-counts info))
95 (len (length counts))
96 (new (make-array len :element-type '(unsigned-byte 32))))
97 (dotimes (i len)
98 (setf (aref new i) (aref counts i)))
99 (setf (selection-elt-counts elt) new)))
100
101 (dolist (elt res)
102 (let* ((object (selection-elt-code elt))
103 (debug-info (code-header-ref object vm:code-debug-info-slot))
104 (map (di::get-debug-info-function-map debug-info))
105 (costs (dyncount-info-costs (selection-elt-info elt)))
106 (counts (selection-elt-counts elt))
107 (j 0)
108 (last-j 0))
109 (declare (simple-vector map))
110 (dotimes (i (length map))
111 (declare (fixnum i))
112 (let ((e (svref map i)))
113 (when (c::compiled-debug-function-p e)
114 (let ((fn (di::make-compiled-debug-function e object))
115 (sum 0d0))
116 (declare (double-float sum) (type index j))
117 (do-debug-function-blocks (blk fn)
118 (unless (debug-block-elsewhere-p blk)
119 (incf sum
120 (* (- (coerce (the (unsigned-byte 31)
121 (aref costs j))
122 'double-float)
123 count-me-cost-fudge)
124 (coerce (the (unsigned-byte 31)
125 (aref counts j))
126 'double-float)))
127 (incf j)))
128 (push (list fn sum last-j)
129 (selection-elt-functions elt))
130 (setq last-j j)))))))
131 (undefined-value))
132
133 ;;; CLEAR-PROFILE-INFO -- Public
134 ;;;
135 (defun clear-profile-info (&optional (spaces '(:dynamic)))
136 _N"Clear all profiling counts. Call this before running your test."
137 (declare (inline vm::map-allocated-objects)
138 (optimize (speed 3) (safety 0)))
139 (without-gcing
140 (dolist (space spaces)
141 (vm::map-allocated-objects
142 #'(lambda (object type-code size)
143 (declare (ignore type-code size))
144 (when (code-component-p object)
145 (let ((info (code-header-ref object vm:code-constants-offset)))
146 (when (dyncount-info-p info)
147 (clear-dyncount-info info)))))
148 space)))
149 (values))
150
151
152 ;;; SELECT-PROFILE-RESULT -- Public
153 ;;;
154 (defun select-profile-result (&key (name "unknown") (n 30)
155 (spaces '(:dynamic)))
156 (declare (string name) (list spaces) (type index n))
157 (let ((res (loop repeat n collect (make-selection-elt :cost -1d0)))
158 (min-cost -1d0)
159 (selection (make-selection :name name)))
160 (declare (type double-float min-cost)
161 (inline vm::map-allocated-objects)
162 (optimize (speed 3) (safety 0)))
163 (without-gcing
164 (dolist (space spaces)
165 (vm::map-allocated-objects
166 #'(lambda (object type-code size)
167 (declare (ignore type-code size))
168 (when (code-component-p object)
169 (let ((info (code-header-ref object vm:code-constants-offset)))
170 (when (dyncount-info-p info)
171 (let ((costs (dyncount-info-costs info))
172 (counts (dyncount-info-counts info))
173 (this-cost 0d0))
174 (declare (double-float this-cost))
175 (dotimes (i (length counts))
176 (incf this-cost
177 (* (coerce (the (unsigned-byte 31)
178 (aref counts i))
179 'double-float)
180 (- (coerce (the (unsigned-byte 31)
181 (aref costs i))
182 'double-float)
183 count-me-cost-fudge))))
184 (incf (selection-total-cost selection) this-cost)
185 (when (> this-cost min-cost)
186 (do ((prev res current)
187 (current (cdr res) (cdr current)))
188 ((or (null current)
189 (> (selection-elt-cost (car current))
190 this-cost))
191 (setf (cdr prev)
192 (cons (make-selection-elt
193 :cost this-cost
194 :code object
195 :info info)
196 current))))
197 (let ((old (pop res)))
198 (setq min-cost (selection-elt-cost old)))))))))
199 space)))
200
201 (loop
202 (unless res
203 (error _"No profilable code objects found."))
204 (unless (minusp (selection-elt-cost (first res))) (return))
205 (pop res))
206
207 (save-select-result res)
208 (setf (selection-elements selection) res)
209 selection))
210
211 (defun function-report (selection &key (top-n 20))
212 (let ((selected-funs ()))
213 (dolist (elt (selection-elements selection))
214 (let ((comp-funs ()))
215 (dolist (fun (selection-elt-functions elt))
216 (let* ((name (debug-function-name (first fun)))
217 (found (assoc name comp-funs :test #'equal)))
218 (if found
219 (incf (cdr found) (second fun))
220 (push (cons name (second fun)) comp-funs))))
221 (setq selected-funs (append comp-funs selected-funs))))
222
223 (let ((sorted (sort selected-funs #'> :key #'cdr))
224 (total 0d0))
225 (declare (double-float total))
226 (loop for (name . cost) in sorted
227 repeat top-n do
228 (format t "~,2E: ~S~%" cost name)
229 (incf total cost))
230 (format t _"~,2E: Total~%" total)
231 (format t _"~,2E: Other~%" (- (selection-total-cost selection) total))))
232
233 (values))
234
235
236 ;;; FIND-INFO-FOR -- Interface
237 ;;;
238 ;;; Return the DYNCOUNT-INFO for FUNCTION.
239 ;;;
240 (defun find-info-for (function)
241 (declare (type function function))
242 (let* ((function (%closure-function function))
243 (component (di::function-code-header function)))
244 (do ((end (get-header-data component))
245 (i vm:code-constants-offset (1+ i)))
246 ((= end i))
247 (let ((constant (code-header-ref component i)))
248 (when (dyncount-info-p constant)
249 (return constant))))))
250
251 ;;
252 (defun clear-dyncount-info (info)
253 (declare (type dyncount-info info))
254 (declare (optimize (speed 3) (safety 0)))
255 (let ((counts (dyncount-info-counts info)))
256 (dotimes (i (length counts))
257 (setf (aref counts i) 0))))
258
259 ;;
260 (defun dyncount-total-cost (info)
261 (let ((costs (dyncount-info-costs info))
262 (counts (dyncount-info-counts info))
263 (sum 0))
264 (dotimes (i (length costs))
265 (incf sum (* (aref costs i) (aref counts i))))
266 sum))
267
268
269 ;;; SAME-SOURCE-P -- Internal
270 ;;;
271 ;;; Return true if two code locations have the same source form.
272 ;;;
273 (defun same-source-p (x y)
274 (and (= (code-location-form-number x)
275 (code-location-form-number y))
276 (= (di:code-location-top-level-form-offset x)
277 (di:code-location-top-level-form-offset y))))
278
279
280 ;;; FUNCTION-CYCLES -- External.
281 ;;;
282 (defun function-cycles (name selection &key (top-n 15) (combine t))
283 (declare (type selection selection))
284 _N"Print detailed information about the costs associated with a particular
285 function in a SELECTION of dynamic statistics. All functions with names
286 EQUAL to the specified name are reported. If Combine is true, then
287 all blocks with the same source location are combined into a single entry in
288 the report."
289 ;;
290 ;; DFs = list of (selection-elt . (debug-fun cost first-num))
291 ;; Locs = list of (code-location . (loc-cost max-count))
292 (collect ((dfs)
293 (locs))
294 (dolist (sel (selection-elements selection))
295 (dolist (fun (selection-elt-functions sel))
296 (when (equal (debug-function-name (first fun)) name)
297 (dfs (cons sel fun)))))
298 (dolist (df (dfs))
299 (let* ((num (third (cdr df)))
300 (sel (car df))
301 (counts (selection-elt-counts sel))
302 (costs (dyncount-info-costs (selection-elt-info sel))))
303 (declare (type index num))
304 (do-debug-function-blocks (db (first (cdr df)))
305 (do-debug-block-locations (loc db)
306 (let* ((cnt (coerce (aref counts num) 'double-float))
307 (cost (* (- (coerce (aref costs num) 'double-float)
308 count-me-cost-fudge)
309 cnt)))
310 (unless (debug-block-elsewhere-p db)
311 (assert (member (code-location-kind loc)
312 '(:block-start :non-local-entry)))
313 (let ((found (and combine
314 (assoc loc (locs) :test #'same-source-p))))
315 (cond (found
316 (incf (second found) cost)
317 (setf (third found)
318 (max (the double-float (third found)) cnt)))
319 (t
320 (locs (list loc cost cnt)))))
321 (incf num))
322 (return))))))
323
324 (let ((locs (stable-sort (locs) #'>= :key #'second)))
325 (dolist (loc (subseq locs 0 (min (length locs) top-n)))
326 (format t _"~%~,2E cycles, ~[not run, ~;~:; ~:*~D repeats, ~]~
327 ~S:~% "
328 (second loc)
329 (truncate (third loc))
330 (debug-function-name (code-location-debug-function (car loc))))
331 (debug::print-code-location-source-form (car loc) 0)
332 (fresh-line))))
333 (values))
334
335 #+nil
336 ;;; GET-SPACE-LIST -- Internal.
337 ;;;
338 ;;;
339 (defun get-space-list (spaces clear)
340 (locally
341 (declare (optimize (speed 3) (safety 0))
342 (inline vm::map-allocated-objects))
343 (without-gcing
344 (let ((list nil))
345 (dolist (space spaces)
346 (vm::map-allocated-objects
347 #'(lambda (object type-code size)
348 (declare (ignore type-code size))
349 (when (kernel:code-component-p object)
350 (let ((info (kernel:code-header-ref object 5))
351 (j 0)
352 (sum 0)
353 (alist))
354 (declare (fixnum j))
355 (when (dyncount-info-p info)
356 (let* ((debug-info (kernel:code-header-ref object 3))
357 (map (di::get-debug-info-function-map debug-info)))
358 (declare (vector map))
359 (dotimes (i (length map))
360 (declare (fixnum i))
361 (let ((e (svref map i)))
362 (when (c::compiled-debug-function-p e)
363 (let ((fn (di::make-compiled-debug-function
364 e object)))
365 (di:do-debug-function-blocks (blk fn)
366 (unless (di:debug-block-elsewhere-p blk)
367 (incf sum
368 (* (aref (dyncount-info-costs info) j)
369 (aref (dyncount-info-counts info) j)))
370 (incf j)))
371 (let ((a (find (di:debug-function-name fn)
372 alist :key #'car)))
373 (cond (a (incf (third a) sum))
374 (t
375 (push (list (di:debug-function-name fn)
376 (c::compiled-debug-info-package
377 debug-info)
378 sum)
379 alist)))
380 (setf sum 0)))))))
381 (when clear
382 (clear-dyncount-info info)))
383 (dolist (e alist)
384 (push e list)))))
385 space))
386 list))))
387
388 #+nil
389 ;;; GET-STATS -- External.
390 ;;;
391 ;;; Returns the cycles of all the functions in the spaces.
392 ;;;
393 (defun get-stats (&key (spaces '(:dynamic)) (clear nil) (top-n 10) (cost 0))
394 (let ((list (stable-sort (sort (get-space-list spaces clear)
395 #'> :key #'third) #'string< :key #'second))
396 (package-name "")
397 (i 0)
398 (other 0))
399 (dolist (e list)
400 (unless (string= package-name (second e))
401 (setf package-name (second e))
402 (when (> other cost)
403 (format t _" ~10:D: Other~&" other))
404 (setf i 0)
405 (setf other 0)
406 (when (> (third e) cost)
407 (format t _"Package: ~A~&" package-name)))
408 (cond ((< i top-n)
409 (when (> (third e) cost)
410 (format t _" ~10:D: ~S~&" (third e) (first e))))
411 (t
412 (incf other (third e))))
413 (incf i))
414 (when (> other cost)
415 (format t _" ~10:D: Other~&" other))))

  ViewVC Help
Powered by ViewVC 1.1.5