source: trunk/source/library/chud-metering.lisp @ 13067

Last change on this file since 13067 was 13067, checked in by rme, 11 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.6 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                         ccl::area-dynamic
144                         )))
145    (functions)))
146
147#+x8632-target
148(defun identify-functions-with-pure-code ()
149  (ccl::freeze)
150  (ccl::collect ((functions))
151    (block walk
152      (let* ((frozen-dnodes (ccl::frozen-space-dnodes)))
153        (ccl::%map-areas (lambda (o)
154                           (when (>= (dynamic-dnode o) frozen-dnodes)
155                             (return-from walk nil))
156                           (when (typep o 'function)
157                             (functions o)))
158                         ccl::area-dynamic
159                         ccl::area-dynamic
160                         )))
161    (functions)))
162
163#+ppc-target
164(defun identify-functions-with-pure-code ()
165  (ccl::purify)
166  (multiple-value-bind (pure-low pure-high)
167                                 
168      (ccl::do-gc-areas (a)
169        (when (eql(ccl::%fixnum-ref a target::area.code)
170                  ccl::area-readonly)
171          (return
172            (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
173                    (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))
174    (let* ((hash (make-hash-table :test #'eq)))
175      (ccl::%map-lfuns #'(lambda (f)
176                           (let* ((code-vector  (ccl:uvref f 0))
177                                  (startaddr (+ (ccl::%address-of code-vector)
178                                                target::misc-data-offset)))
179                             (when (and (>= startaddr pure-low)
180                                        (< startaddr pure-high))
181                               (push f (gethash code-vector hash))))))
182      (let* ((n 0))
183        (declare (fixnum n))
184        (maphash #'(lambda (k v)
185                     (declare (ignore k))
186                     (if (null (cdr v))
187                       (incf n)))
188                 hash)
189        (let* ((functions ()))
190          (maphash #'(lambda (k v)
191                       (declare (ignore k))
192                       (when (null (cdr v))
193                         (push (car v) functions)))
194                   hash)
195          (sort functions
196                #'(lambda (x y)
197                    (< (ccl::%address-of (uvref x 0) )
198                       (ccl::%address-of  (uvref y 0))))))))))
199       
200                           
201
202
203(defun generate-shark-spatch-file ()
204  (let* ((functions (identify-functions-with-pure-code)))
205    (with-open-file (f (make-pathname
206                        :host nil
207                        :directory (pathname-directory
208                                    (ensure-shark-session-path))
209                        :name (format nil "~a_~D"
210                                      (pathname-name
211                                       (car
212                                        ccl::*command-line-argument-list*))
213                                      (ccl::getpid))
214                        :type "spatch")
215                       :direction :output
216                       :if-exists :supersede)
217      (format f "!SHARK_SPATCH_BEGIN~%")
218      (dolist (fun functions)
219        (print-shark-spatch-record fun f))
220      (format f "!SHARK_SPATCH_END~%"))))
221
222(defun terminate-shark-process ()
223  (when *shark-process*
224    (signal-external-process *shark-process* #$SIGUSR2))
225  (setq *shark-process* nil
226        *sampling* nil))
227
228(defun toggle-sampling ()
229  (if *shark-process*
230    (progn
231      (signal-external-process *shark-process* #$SIGUSR1)
232      (setq *sampling* (not *sampling*)))
233    (warn "No active shark procsss")))
234
235(defun enable-sampling ()
236  (unless *sampling* (toggle-sampling)))
237
238(defun disable-sampling ()
239  (when *sampling* (toggle-sampling)))
240
241(defun ensure-shark-process (reset hook)
242  (when (or (null *shark-process*) reset)
243    (terminate-shark-process)
244    (when (or reset (not *written-spatch-file*))
245      (generate-shark-spatch-file))
246    (let* ((args (list "-b" "-1" "-a" (format nil "~d" (ccl::getpid))
247                             "-d" *shark-session-native-namestring*)))
248      (when *shark-config-file*
249        (push (ccl::native-untranslated-namestring *shark-config-file*)
250              args)
251        (push "-m" args))
252      (setq *shark-process*
253            (run-program "/usr/bin/shark"
254                         args
255                         :output :stream
256                         :status-hook hook
257                         :wait nil))
258      (let* ((output (external-process-output-stream *shark-process*)))
259        (do* ((line (read-line output nil nil) (read-line output nil nil)))
260             ((null line))
261          (when *debug-shark-process-output*
262            (format t "~&~a" line))
263          (when (search "ready." line :key #'char-downcase)
264            (sleep 1)
265            (return)))))))
266
267(defun display-shark-session-file (line)
268  (let* ((last-quote (position #\' line :from-end t))
269         (first-quote (and last-quote (position #\' line :end (1- last-quote) :from-end t)))
270         (path (and first-quote  (subseq line (1+ first-quote) last-quote))))
271    (when path (finder-open-file path))))
272   
273(defun scan-shark-process-output (p)
274  (with-interrupts-enabled 
275      (let* ((out (ccl::external-process-output p)))
276        (do* ((line (read-line out nil nil) (read-line out nil nil)))
277             ((null line))
278          (when *debug-shark-process-output*
279            (format t "~&~a" line))
280          (when (search "Created session file:" line)
281            (display-shark-session-file line)
282            (return))))))
283
284
285
286(defmacro meter (form &key reset debug-output)
287  (let* ((hook (gensym))
288         (block (gensym))
289         (process (gensym)))
290    `(block ,block
291      (flet ((,hook (p)
292               (when (or (eq (external-process-status p) :exited)
293                         (eq (external-process-status p) :signaled))
294                 (setq *shark-process* nil
295                       *sampling* nil))))
296        (let* ((*debug-shark-process-output* ,debug-output))
297          (ensure-shark-process ,reset #',hook)
298          (unwind-protect
299               (progn
300                 (enable-sampling)
301                 ,form)
302            (disable-sampling)
303            (let* ((,process *shark-process*))
304              (when ,process
305                (scan-shark-process-output ,process)))))))))
306
307;;; Try to clean up after ourselves when the lisp quits.
308(pushnew 'terminate-shark-process ccl::*save-exit-functions*)
Note: See TracBrowser for help on using the repository browser.