source: trunk/abcl/src/org/armedbear/lisp/profiler.lisp @ 12682

Last change on this file since 12682 was 12682, checked in by ehuelsmann, 13 years ago

Add APIs to access data gathered in the profiler
to detect (lisp) hot spots.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.7 KB
Line 
1;;; profiler.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: profiler.lisp 12682 2010-05-15 10:20:40Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:profiler)
33
34(export '(*hidden-functions*))
35
36(require '#:clos)
37(require '#:format)
38
39(defvar *type* nil)
40
41(defvar *granularity* 1 "Sampling interval (in milliseconds).")
42
43(defvar *hidden-functions*
44  '(funcall apply eval
45    sys::%eval sys::interactive-eval
46    tpl::repl tpl::top-level-loop))
47
48(defstruct (profile-info
49            (:constructor make-profile-info (object full-count hot-count)))
50  object
51  full-count
52  hot-count)
53
54;; Returns list of all symbols with non-zero call counts.
55(defun list-called-objects ()
56  (let ((result '()))
57    (dolist (pkg (list-all-packages))
58      (dolist (sym (sys:package-symbols pkg))
59        (unless (memq sym *hidden-functions*)
60          (when (fboundp sym)
61            (let* ((definition (fdefinition sym))
62                   (full-count (sys:call-count definition))
63                   (hot-count (sys:hot-count definition)))
64              (unless (zerop full-count)
65                (cond ((typep definition 'generic-function)
66                       (push (make-profile-info definition
67                                                full-count hot-count) result)
68                       (dolist (method
69                                 (mop::generic-function-methods definition))
70                         (let ((function (sys:%method-function method)))
71                           (setf full-count (sys:call-count function))
72                           (setf hot-count (sys:hot-count function)))
73                         (unless (zerop full-count)
74                           (push (make-profile-info method full-count
75                                                    hot-count) result))))
76                      (t
77                       (push (make-profile-info sym full-count hot-count)
78                             result)))))))))
79    (remove-duplicates result :key 'profile-info-object :test 'eq)))
80
81(defun object-name (object)
82  (cond ((symbolp object)
83         object)
84        ((typep object 'generic-function)
85         (sys:%generic-function-name object))
86        ((typep object 'method)
87         (list 'METHOD
88               (sys:%generic-function-name (sys:%method-generic-function object))
89               (sys:%method-specializers object)))))
90
91(defun object-compiled-function-p (object)
92  (cond ((symbolp object)
93         (compiled-function-p (fdefinition object)))
94        ((typep object 'method)
95         (compiled-function-p (sys:%method-function object)))
96        (t
97         (compiled-function-p object))))
98
99(defun show-call-count (info max-count)
100  (let* ((object (profile-info-object info))
101         (count (profile-info-full-count info)))
102    (if max-count
103        (format t "~5,1F ~8D ~S~A~%"
104                (/ (* count 100.0) max-count)
105                count
106                (object-name object)
107                (if (object-compiled-function-p object)
108                    ""
109                    " [interpreted function]"))
110        (format t "~8D ~S~A~%"
111                count
112                (object-name object)
113                (if (object-compiled-function-p object)
114                    ""
115                    " [interpreted function]")))))
116
117(defun show-hot-count (info max-count)
118  (let* ((object (profile-info-object info))
119         (count (profile-info-hot-count info)))
120    (if max-count
121        (format t "~5,1F ~8D ~S~A~%"
122                (/ (* count 100.0) max-count)
123                count
124                (object-name object)
125                (if (object-compiled-function-p object)
126                    ""
127                    " [interpreted function]"))
128        (format t "~8D ~S~A~%"
129                count
130                (object-name object)
131                (if (object-compiled-function-p object)
132                    ""
133                    " [interpreted function]")))))
134
135(defun show-call-counts ()
136  (let ((list (list-called-objects)))
137    (setf list (sort list #'< :key 'profile-info-full-count))
138    (let ((max-count nil))
139      (when (eq *type* :time)
140        (let ((last-info (car (last list))))
141          (setf max-count (if last-info
142                              (profile-info-full-count last-info)
143                              nil))
144          (when (eql max-count 0)
145            (setf max-count nil))))
146      (dolist (info list)
147        (show-call-count info max-count))))
148  (values))
149
150(defun show-hot-counts ()
151  (let ((list (list-called-objects)))
152    (setf list (sort list #'< :key 'profile-info-hot-count))
153    (let ((max-count nil))
154      (when (eq *type* :time)
155        (let ((last-info (car (last list))))
156          (setf max-count (if last-info
157                              (profile-info-hot-count last-info)
158                              nil))
159          (when (eql max-count 0)
160            (setf max-count nil))))
161      (dolist (info list)
162        (show-hot-count info max-count))))
163  (values))
164
165(defun start-profiler (&key type)
166  "Starts the profiler.
167  :TYPE may be either :TIME (statistical sampling) or :COUNT-ONLY (exact call
168  counts)."
169  (unless type
170    (setf type :time))
171  (unless (memq type '(:time :count-only))
172    (error ":TYPE must be :TIME or :COUNT-ONLY"))
173  (setf *type* type)
174  (%start-profiler type *granularity*))
175
176(defmacro with-profiling ((&key type) &body body)
177  `(unwind-protect (progn (start-profiler :type ,type) ,@body)
178                   (stop-profiler)))
Note: See TracBrowser for help on using the repository browser.