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

Last change on this file since 9168 was 9168, checked in by gb, 11 years ago

Getting closer to actually working, at least on ppc32/ppc64.
With the -b option, receipt of SIGUSR1 toggles sampling; when it's toggled
from on to off, a session file is (generally) produced.
There -may- be a race condition (hard to reproduce) whereby a SIGUSR1
sent too soon after shark announces that it's 'ready' is dropped.
Try to read process output via a pipe, to determine (a) when a newly-created
shark process announces that it's ready and (b) to pick up the name of
any session file created after sampling's toggled off.
In all modes (certainly including -b/batch), SIGUSR2 toggles sampling off
and causes the shark process to exit. Use a (simple) status-hook function
to detect cases where the shark process dies, which is (a) better than not
noticing or (b) polling for the process' status all the time.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.5 KB
Line 
1;;;-*-Mode: LISP; Package: (CHUD (:USE CL CCL)) -*-
2;;;
3;;;   Copyright (C) 2005 Clozure Associates and contributors
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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" "PREPARE-METERING" "SHARK-SESSION-PATH"
28           "LAUNCH-SHARK" "CLEANUP-SPATCH-FILES" "RESET-METERING"))
29 
30(in-package "CHUD")
31
32(eval-when (:compile-toplevel :load-toplevel :execute)
33  (progn
34    #-darwin-target
35    (error "This code is Darwin/MacOSX-specific.")))
36
37
38(defparameter *shark-session-path* nil)
39
40(defloadvar *written-spatch-file* nil)
41
42(defparameter *shark-session-native-namestring* nil)
43
44(defparameter *shark-config-file* nil "Full pathname of .cfg file to use for profiling, or NIL.")
45
46(defun finder-open-file (namestring)
47  "Open the file named by NAMESTRING, as if it was double-clicked on
48in the finder"
49  (run-program "/usr/bin/open" (list namestring) :output nil))
50
51(defun ensure-shark-session-path ()
52  (unless *shark-session-path*
53    (multiple-value-bind (second minute hour date month year)
54        (decode-universal-time (get-universal-time))
55      (let* ((subdir (format nil "profiling-session-~A-~d_~d-~d-~d_~d.~d.~d"
56                             (pathname-name
57                              (car
58                               ccl::*command-line-argument-list*))
59                             (ccl::getpid)
60                             month
61                             date
62                             year
63                             hour
64                             minute
65                             second))
66             (dir (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list subdir)) :defaults nil))
67             (native-name (ccl::native-untranslated-namestring dir)))
68        (ensure-directories-exist dir)
69        (setenv "SHARK_SEARCH_PATH_PATCH_FILES" native-name)
70        (setq *shark-session-native-namestring*
71              native-name
72              *shark-session-path* dir))))
73  *shark-session-path*)
74
75;;; This is cheesy: it should watch for directory changes (or something)
76;;; rather than guessing how long it'll take for an mshark file to appear
77;;; in the session directory.
78(defun wait-and-open-mshark-file (path delay)
79  (process-run-function "mshark file watch"
80                        (lambda ()
81                          (sleep delay)
82                          (let* ((path (make-pathname
83                                        :host nil
84                                        :directory
85                                        (pathname-directory path)
86                                        :name "*"
87                                        :type "mshark"
88                                        :defaults nil))
89                                 (mshark
90                                  (ignore-errors (car (last (directory path))))))
91                            (when mshark
92                              (finder-open-file
93                               (ccl::native-untranslated-namestring mshark)))))))
94
95
96 
97
98(defvar *shark-process* nil)
99(defvar *sampling* nil)
100
101#+ppc-target
102(defun get-static-function-area-bounds ()
103  (ccl::do-gc-areas (a)
104    (when (eql(ccl::%fixnum-ref a target::area.code)
105               ccl::area-readonly)
106      (return
107        (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
108                (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift))))))
109
110(defun safe-shark-function-name (function)
111  (let* ((name (format nil "~s" function)))
112    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
113
114(defun print-shark-spatch-record (fn &optional (stream t))
115  (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn)
116         (startaddr (+ (ccl::%address-of code-vector)
117                       #+ppc32-target target::misc-data-offset
118                       #-ppc32-target 0))
119         (endaddr (+ startaddr (* 4 (- (uvsize code-vector)
120                                       #+ppc64-target 2
121                                       #-ppc64-target 1)))))
122    ;; i hope all lisp sym characters are allowed... we'll see
123    (format stream "{~%~@
124                        ~a~@
125                        ~@?~@
126                        ~@?~@
127                        }~%"
128            (safe-shark-function-name fn)
129            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
130            startaddr
131            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
132            endaddr)))
133
134(defun identify-functions-with-pure-code (pure-low pure-high)
135  (let* ((hash (make-hash-table :test #'eq)))
136    (ccl::%map-lfuns #'(lambda (f)
137                         (let* ((code-vector #+ppc-target (ccl:uvref f 0)
138                                             #+x8664-target (ccl::function-to-function-vector f))
139                                (startaddr (+ (ccl::%address-of code-vector)
140                                              target::misc-data-offset)))
141                           (when (and (>= startaddr pure-low)
142                                      (< startaddr pure-high))
143                             (push f (gethash code-vector hash))))))
144    (let* ((n 0))
145      (declare (fixnum n))
146      (maphash #'(lambda (k v)
147                   (declare (ignore k))
148                   (if (null (cdr v))
149                     (incf n)))
150               hash)
151      (let* ((functions (make-array n))
152             (i 0))
153        (maphash #'(lambda (k v)
154                     (declare (ignore k))
155                     (when (null (cdr v))
156                       (setf (svref functions i) (car v)
157                             i (1+ i))))
158                 hash)
159        (sort functions
160              #'(lambda (x y)
161                  (< (ccl::%address-of #+ppc-target (uvref x 0)
162                                       #+x8664-target x)
163                     (ccl::%address-of #+ppc-target (uvref y 0)
164                                       #+x8664-target y))))))))
165       
166                           
167(defun generate-shark-spatch-file ()
168  #+ppc-target (ccl::purify)
169  #+x86-target (ccl::freeze)
170  (multiple-value-bind (pure-low pure-high)
171      (get-static-function-area-bounds)
172    (let* ((functions (identify-functions-with-pure-code pure-low pure-high)))
173      (with-open-file (f (make-pathname
174                          :host nil
175                          :directory (pathname-directory
176                                      (ensure-shark-session-path))
177                          :name (format nil "~a_~D"
178                                        (pathname-name
179                                         (car
180                                          ccl::*command-line-argument-list*))
181                                        (ccl::getpid))
182                          :type "spatch")
183                         :direction :output
184                         :if-exists :supersede)
185        (format f "!SHARK_SPATCH_BEGIN~%")
186        (dotimes (i (length functions))
187          (print-shark-spatch-record (svref functions i) f))
188        (format f "!SHARK_SPATCH_END~%")))
189    (setq *written-spatch-file* t)
190    t))
191
192(defun terminate-shark-process ()
193  (when *shark-process*
194    (signal-external-process *shark-process* #$SIGUSR2))
195  (setq *shark-process* nil
196        *sampling* nil))
197
198(defun toggle-sampling ()
199  (if *shark-process*
200    (progn
201      (signal-external-process *shark-process* #$SIGUSR1)
202      (setq *sampling* (not *sampling*)))
203    (warn "No active shark procsss")))
204
205(defun enable-sampling ()
206  (unless *sampling* (toggle-sampling)))
207
208(defun disable-sampling ()
209  (when *sampling* (toggle-sampling)))
210
211(defun ensure-shark-process (reset hook)
212  (when (or (null *shark-process*) reset)
213    (terminate-shark-process)
214    (when (or reset (not *written-spatch-file*))
215      (generate-shark-spatch-file))
216    (let* ((args (list "-b" "-1" "-a" (format nil "~d" (ccl::getpid))
217                             "-d" *shark-session-native-namestring*)))
218      (when *shark-config-file*
219        (push (ccl::native-untranslated-namestring *shark-config-file*)
220              args)
221        (push "-m" args))
222      (setq *shark-process*
223            (run-program "/usr/bin/shark"
224                         args
225                         :output :stream
226                         :status-hook hook
227                         :wait nil))
228      (let* ((output (external-process-output-stream *shark-process*)))
229        (do* ((line (read-line output nil nil) (read-line output nil nil)))
230             ((null line))
231          (when (search "ready." line :key #'char-downcase)
232            (return)))))))
233
234(defun display-shark-session-file (line)
235  (let* ((last-quote (position #\' line :from-end t))
236         (first-quote (and last-quote (position #\' line :end (1- last-quote) :from-end t)))
237         (path (and first-quote  (subseq line (1+ first-quote) last-quote))))
238    (when path (finder-open-file path))))
239   
240(defun scan-shark-process-output (p)
241  (with-interrupts-enabled 
242      (let* ((out (ccl::external-process-output p)))
243        (do* ((line (read-line out nil nil) (read-line out nil nil)))
244             ((null line))
245          (when (search "Created session file:" line)
246            (display-shark-session-file line)
247            (return))))))
248
249
250
251(defmacro meter (form &key reset)
252  (let* ((hook (gensym))
253         (block (gensym))
254         (process (gensym)))
255    `(block ,block
256      (flet ((,hook (p)
257               (when (or (eq (external-process-status p) :exited)
258                         (eq (external-process-status p) :signaled))
259                 (setq *shark-process* nil
260                       *sampling* nil))))
261      (ensure-shark-process ,reset #',hook)
262      (unwind-protect
263         (progn
264           (enable-sampling)
265           ,form)
266        (disable-sampling)
267        (let* ((,process *shark-process*))
268          (when ,process
269            (scan-shark-process-output ,process))))))))
270
271
Note: See TracBrowser for help on using the repository browser.