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

Contents of /src/code/cprofile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2.56.2 - (hide annotations)
Tue Feb 9 14:56:38 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-19-1000, intl-branch-working-2010-02-11-1000, intl-branch-2010-03-18-1300
Changes since 1.2.56.1: +14 -14 lines
Mark translatable strings; update cmucl.pot and ko/cmucl.po
accordingly.
1 ram 1.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 rtoy 1.2.56.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/cprofile.lisp,v 1.2.56.2 2010/02/09 14:56:38 rtoy Exp $")
9 ram 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; This file contains run-time support for collecting dynamic profiling
13     ;;; information from code instrumented by the compiler.
14     ;;;
15 rtoy 1.2.56.1 (intl:textdomain "cmucl")
16    
17 ram 1.1 (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 rtoy 1.2.56.2 (error _"You don't want to compile this file with profiling.")))
26 ram 1.1
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 rtoy 1.2.56.2 (format stream _"~A, top ~D, cost ~S" (selection-name s)
67 ram 1.1 (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 rtoy 1.2.56.2 _N"Our guess is to how many cycles in each block are really due to
82 ram 1.1 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 rtoy 1.2.56.2 _N"Clear all profiling counts. Call this before running your test."
137 ram 1.1 (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 rtoy 1.2.56.2 (error _"No profilable code objects found."))
204 ram 1.1 (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 rtoy 1.2.56.2 (format t _"~,2E: Total~%" total)
231     (format t _"~,2E: Other~%" (- (selection-total-cost selection) total))))
232 ram 1.1
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 rtoy 1.2.56.2 _N"Print detailed information about the costs associated with a particular
285 ram 1.1 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 rtoy 1.2.56.2 (format t _"~%~,2E cycles, ~[not run, ~;~:; ~:*~D repeats, ~]~
327 ram 1.1 ~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 rtoy 1.2.56.2 (format t _" ~10:D: Other~&" other))
404 ram 1.1 (setf i 0)
405     (setf other 0)
406     (when (> (third e) cost)
407 rtoy 1.2.56.2 (format t _"Package: ~A~&" package-name)))
408 ram 1.1 (cond ((< i top-n)
409     (when (> (third e) cost)
410 rtoy 1.2.56.2 (format t _" ~10:D: ~S~&" (third e) (first e))))
411 ram 1.1 (t
412     (incf other (third e))))
413     (incf i))
414     (when (> other cost)
415 rtoy 1.2.56.2 (format t _" ~10:D: Other~&" other))))

  ViewVC Help
Powered by ViewVC 1.1.5