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

Contents of /src/code/cprofile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5