source: release/1.6/source/library/chud-metering.lisp @ 14493

Last change on this file since 14493 was 13174, checked in by gz, 10 years ago

heap utilization tweaks:

Changed %MAP-AREAS to take an area or list of areas, rather than min/max area codes. Make it accept symbolic area names as well.

Made HEAP-UTILIZATION accept some new keyword args:

  • :AREA can be used to restrict the area or areas walked, as in %map-areas.
  • :CLASSES, if true, causes it to classify objects by actual class rather than typecode.
  • :SORT specifies the order in which to print results, default is by name
  • :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes.

Added COLLECT-HEAP-UTILIZATION, which returns a list of (type count logical-size physical-size) instead of printing anything.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.5 KB
Line 
1;;;-*-Mode: LISP; Package: (CHUD (:USE CL CCL)) -*-
2;;;
3;;;   Copyright (C) 2005,2008,2009 Clozure Associates and contributors
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; Some of this is based on work done by Dan Knapp and Hamilton Link
18;;; (and possibly others.)
19
20;;; CHUD 4.4.3-5 claims to offer 64-bit support; however, the library
21;;; which provides the API to control CHUD metering functions still
22;;; seems to be 32-bit only.  Conditionalization for x86-64 and
23;;; for 64-bit targets is (so far) just an exercise.
24
25(defpackage "CHUD"
26  (:use "CL" "CCL")
27  (:export "METER" "*SHARK-CONFIG-FILE*"))
28 
29(in-package "CHUD")
30
31(eval-when (:compile-toplevel :load-toplevel :execute)
32  (progn
33    #-darwin-target
34    (error "This code is Darwin/MacOSX-specific.")))
35
36
37(defparameter *shark-session-path* nil)
38
39(defloadvar *written-spatch-file* nil)
40
41(defparameter *shark-session-native-namestring* nil)
42
43(defparameter *shark-config-file* nil "Full pathname of .cfg file to use for profiling, or NIL.")
44
45(defun finder-open-file (namestring)
46  "Open the file named by NAMESTRING, as if it was double-clicked on
47in the finder"
48  (run-program "/usr/bin/open" (list namestring) :output nil))
49
50(defun ensure-shark-session-path ()
51  (unless *shark-session-path*
52    (multiple-value-bind (second minute hour date month year)
53        (decode-universal-time (get-universal-time))
54      (let* ((subdir (format nil "profiling-session-~A-~d_~d-~d-~d_~d.~d.~d"
55                             (pathname-name
56                              (car
57                               ccl::*command-line-argument-list*))
58                             (ccl::getpid)
59                             month
60                             date
61                             year
62                             hour
63                             minute
64                             second))
65             (dir (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list subdir)) :defaults nil))
66             (native-name (ccl::native-untranslated-namestring dir)))
67        (ensure-directories-exist dir)
68        (setenv "SHARK_SEARCH_PATH_PATCH_FILES" native-name)
69        (setq *shark-session-native-namestring*
70              native-name
71              *shark-session-path* dir))))
72  *shark-session-path*)
73
74
75 
76
77(defloadvar *shark-process* nil)
78(defloadvar *sampling* nil)
79
80(defvar *debug-shark-process-output* nil)
81
82
83(defun safe-shark-function-name (function)
84  (let* ((name (format nil "~s" function)))
85    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
86
87(defun print-shark-spatch-record (fn &optional (stream t))
88  (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn)
89         (startaddr (+ (ccl::%address-of code-vector)
90                       #+x8664-target 0
91                       #+ppc32-target target::misc-data-offset
92                       #-ppc32-target 0))
93         (endaddr (+ startaddr
94                     #+x8664-target
95                     (1+ (ash (1- (ccl::%function-code-words fn)
96                                  ) target::word-shift))
97                     #+ppc-target
98                     (* 4 (- (uvsize code-vector)
99                                       #+ppc64-target 2
100                                       #-ppc64-target 1)))))
101    ;; i hope all lisp sym characters are allowed... we'll see
102    (format stream "{~%~@
103                        ~a~@
104                        ~@?~@
105                        ~@?~@
106                        }~%"
107            (safe-shark-function-name fn)
108            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
109            startaddr
110            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
111            endaddr)))
112
113#+x8664-target
114(ccl::defx86lapfunction dynamic-dnode ((x arg_z))
115  (movq (% x) (% imm0))
116  (ref-global x86::heap-start arg_y)
117  (subq (% arg_y) (% imm0))
118  (shrq ($ x8664::dnode-shift) (% imm0))
119  (box-fixnum imm0 arg_z)
120  (single-value-return))
121
122#+x8632-target
123(ccl::defx8632lapfunction dynamic-dnode ((x arg_z))
124  (movl (% x) (% imm0))
125  (ref-global x86::heap-start arg_y)
126  (subl (% arg_y) (% imm0))
127  (shrl ($ x8632::dnode-shift) (% imm0))
128  (box-fixnum imm0 arg_z)
129  (single-value-return))
130
131#+x8664-target
132(defun identify-functions-with-pure-code ()
133  (ccl::freeze)
134  (ccl::collect ((functions))
135    (block walk
136      (let* ((frozen-dnodes (ccl::frozen-space-dnodes)))
137        (ccl::%map-areas (lambda (o)
138                           (when (>= (dynamic-dnode o) frozen-dnodes)
139                             (return-from walk nil))
140                           (when (typep o 'ccl::function-vector)
141                             (functions (ccl::function-vector-to-function o))))
142                         ccl::area-dynamic
143                         )))
144    (functions)))
145
146#+x8632-target
147(defun identify-functions-with-pure-code ()
148  (ccl::freeze)
149  (ccl::collect ((functions))
150    (block walk
151      (let* ((frozen-dnodes (ccl::frozen-space-dnodes)))
152        (ccl::%map-areas (lambda (o)
153                           (when (>= (dynamic-dnode o) frozen-dnodes)
154                             (return-from walk nil))
155                           (when (typep o 'function)
156                             (functions o)))
157                         ccl::area-dynamic
158                         )))
159    (functions)))
160
161#+ppc-target
162(defun identify-functions-with-pure-code ()
163  (ccl::purify)
164  (multiple-value-bind (pure-low pure-high)
165                                 
166      (ccl::do-gc-areas (a)
167        (when (eql(ccl::%fixnum-ref a target::area.code)
168                  ccl::area-readonly)
169          (return
170            (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
171                    (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))
172    (let* ((hash (make-hash-table :test #'eq)))
173      (ccl::%map-lfuns #'(lambda (f)
174                           (let* ((code-vector  (ccl:uvref f 0))
175                                  (startaddr (+ (ccl::%address-of code-vector)
176                                                target::misc-data-offset)))
177                             (when (and (>= startaddr pure-low)
178                                        (< startaddr pure-high))
179                               (push f (gethash code-vector hash))))))
180      (let* ((n 0))
181        (declare (fixnum n))
182        (maphash #'(lambda (k v)
183                     (declare (ignore k))
184                     (if (null (cdr v))
185                       (incf n)))
186                 hash)
187        (let* ((functions ()))
188          (maphash #'(lambda (k v)
189                       (declare (ignore k))
190                       (when (null (cdr v))
191                         (push (car v) functions)))
192                   hash)
193          (sort functions
194                #'(lambda (x y)
195                    (< (ccl::%address-of (uvref x 0) )
196                       (ccl::%address-of  (uvref y 0))))))))))
197       
198                           
199
200
201(defun generate-shark-spatch-file ()
202  (let* ((functions (identify-functions-with-pure-code)))
203    (with-open-file (f (make-pathname
204                        :host nil
205                        :directory (pathname-directory
206                                    (ensure-shark-session-path))
207                        :name (format nil "~a_~D"
208                                      (pathname-name
209                                       (car
210                                        ccl::*command-line-argument-list*))
211                                      (ccl::getpid))
212                        :type "spatch")
213                       :direction :output
214                       :if-exists :supersede)
215      (format f "!SHARK_SPATCH_BEGIN~%")
216      (dolist (fun functions)
217        (print-shark-spatch-record fun f))
218      (format f "!SHARK_SPATCH_END~%"))))
219
220(defun terminate-shark-process ()
221  (when *shark-process*
222    (signal-external-process *shark-process* #$SIGUSR2))
223  (setq *shark-process* nil
224        *sampling* nil))
225
226(defun toggle-sampling ()
227  (if *shark-process*
228    (progn
229      (signal-external-process *shark-process* #$SIGUSR1)
230      (setq *sampling* (not *sampling*)))
231    (warn "No active shark procsss")))
232
233(defun enable-sampling ()
234  (unless *sampling* (toggle-sampling)))
235
236(defun disable-sampling ()
237  (when *sampling* (toggle-sampling)))
238
239(defun ensure-shark-process (reset hook)
240  (when (or (null *shark-process*) reset)
241    (terminate-shark-process)
242    (when (or reset (not *written-spatch-file*))
243      (generate-shark-spatch-file))
244    (let* ((args (list "-b" "-1" "-a" (format nil "~d" (ccl::getpid))
245                             "-d" *shark-session-native-namestring*)))
246      (when *shark-config-file*
247        (push (ccl::native-untranslated-namestring *shark-config-file*)
248              args)
249        (push "-m" args))
250      (setq *shark-process*
251            (run-program "/usr/bin/shark"
252                         args
253                         :output :stream
254                         :status-hook hook
255                         :wait nil))
256      (let* ((output (external-process-output-stream *shark-process*)))
257        (do* ((line (read-line output nil nil) (read-line output nil nil)))
258             ((null line))
259          (when *debug-shark-process-output*
260            (format t "~&~a" line))
261          (when (search "ready." line :key #'char-downcase)
262            (sleep 1)
263            (return)))))))
264
265(defun display-shark-session-file (line)
266  (let* ((last-quote (position #\' line :from-end t))
267         (first-quote (and last-quote (position #\' line :end (1- last-quote) :from-end t)))
268         (path (and first-quote  (subseq line (1+ first-quote) last-quote))))
269    (when path (finder-open-file path))))
270   
271(defun scan-shark-process-output (p)
272  (with-interrupts-enabled 
273      (let* ((out (ccl::external-process-output p)))
274        (do* ((line (read-line out nil nil) (read-line out nil nil)))
275             ((null line))
276          (when *debug-shark-process-output*
277            (format t "~&~a" line))
278          (when (search "Created session file:" line)
279            (display-shark-session-file line)
280            (return))))))
281
282
283
284(defmacro meter (form &key reset debug-output)
285  (let* ((hook (gensym))
286         (block (gensym))
287         (process (gensym)))
288    `(block ,block
289      (flet ((,hook (p)
290               (when (or (eq (external-process-status p) :exited)
291                         (eq (external-process-status p) :signaled))
292                 (setq *shark-process* nil
293                       *sampling* nil))))
294        (let* ((*debug-shark-process-output* ,debug-output))
295          (ensure-shark-process ,reset #',hook)
296          (unwind-protect
297               (progn
298                 (enable-sampling)
299                 ,form)
300            (disable-sampling)
301            (let* ((,process *shark-process*))
302              (when ,process
303                (scan-shark-process-output ,process)))))))))
304
305;;; Try to clean up after ourselves when the lisp quits.
306(pushnew 'terminate-shark-process ccl::*save-exit-functions*)
Note: See TracBrowser for help on using the repository browser.