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

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

Work-in-progress; lots of timing screws.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.3 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(defparameter *shark-session-native-namestring* nil)
41
42(defparameter *shark-config-file* nil "Full pathname of .cfg file to use for profiling, or NIL.")
43
44(defun finder-open-file (namestring)
45  "Open the file named by NAMESTRING, as if it was double-clicked on
46in the finder"
47  (run-program "/usr/bin/open" (list namestring) :output nil))
48
49(defun ensure-shark-session-path ()
50  (unless *shark-session-path*
51    (multiple-value-bind (second minute hour date month year)
52        (decode-universal-time (get-universal-time))
53      (let* ((subdir (format nil "profiling-session-~A-~d_~d-~d-~d_~d.~d.~d"
54                             (pathname-name
55                              (car
56                               ccl::*command-line-argument-list*))
57                             (ccl::getpid)
58                             month
59                             date
60                             year
61                             hour
62                             minute
63                             second))
64             (dir (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list subdir)) :defaults nil))
65             (native-name (ccl::native-untranslated-namestring dir)))
66        (ensure-directories-exist dir)
67        (finder-open-file native-name)
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;;; This is cheesy: it should watch for directory changes (or something)
75;;; rather than guessing how long it'll take for an mshark file to appear
76;;; in the session directory.
77(defun wait-and-open-mshark-file (path delay)
78  (process-run-function "mshark file watch"
79                        (lambda ()
80                          (sleep delay)
81                          (let* ((path (make-pathname
82                                        :host nil
83                                        :directory
84                                        (pathname-directory path)
85                                        :name "*"
86                                        :type "mshark"
87                                        :defaults nil))
88                                 (mshark
89                                  (ignore-errors (car (last (directory path))))))
90                            (when mshark
91                              (finder-open-file
92                               (ccl::native-untranslated-namestring mshark)))))))
93
94
95 
96
97(defvar *shark-process* nil)
98(defvar *sampling* nil)
99
100#+ppc-target
101(defun get-static-function-area-bounds ()
102  (ccl::do-gc-areas (a)
103    (when (eql(ccl::%fixnum-ref a target::area.code)
104               ccl::area-readonly)
105      (return
106        (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
107                (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift))))))
108
109(defun safe-shark-function-name (function)
110  (let* ((name (format nil "~s" function)))
111    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
112
113(defun print-shark-spatch-record (fn &optional (stream t))
114  (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn)
115         (startaddr (+ (ccl::%address-of code-vector)
116                       #+ppc32-target target::misc-data-offset
117                       #-ppc32-target 0))
118         (endaddr (+ startaddr (* 4 (- (uvsize code-vector)
119                                       #+ppc64-target 2
120                                       #-ppc64-target 1)))))
121    ;; i hope all lisp sym characters are allowed... we'll see
122    (format stream "{~%~@
123                        ~a~@
124                        ~@?~@
125                        ~@?~@
126                        }~%"
127            (safe-shark-function-name fn)
128            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
129            startaddr
130            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
131            endaddr)))
132
133(defun identify-functions-with-pure-code (pure-low pure-high)
134  (let* ((hash (make-hash-table :test #'eq)))
135    (ccl::%map-lfuns #'(lambda (f)
136                         (let* ((code-vector #+ppc-target (ccl:uvref f 0)
137                                             #+x8664-target (ccl::function-to-function-vector f))
138                                (startaddr (+ (ccl::%address-of code-vector)
139                                              target::misc-data-offset)))
140                           (when (and (>= startaddr pure-low)
141                                      (< startaddr pure-high))
142                             (push f (gethash code-vector hash))))))
143    (let* ((n 0))
144      (declare (fixnum n))
145      (maphash #'(lambda (k v)
146                   (declare (ignore k))
147                   (if (null (cdr v))
148                     (incf n)))
149               hash)
150      (let* ((functions (make-array n))
151             (i 0))
152        (maphash #'(lambda (k v)
153                     (declare (ignore k))
154                     (when (null (cdr v))
155                       (setf (svref functions i) (car v)
156                             i (1+ i))))
157                 hash)
158        (sort functions
159              #'(lambda (x y)
160                  (< (ccl::%address-of #+ppc-target (uvref x 0)
161                                       #+x8664-target x)
162                     (ccl::%address-of #+ppc-target (uvref y 0)
163                                       #+x8664-target y))))))))
164       
165                           
166(defun generate-shark-spatch-file ()
167  #+ppc-target (ccl::purify)
168  #+x86-target (ccl::freeze)
169  (multiple-value-bind (pure-low pure-high)
170      (get-static-function-area-bounds)
171    (let* ((functions (identify-functions-with-pure-code pure-low pure-high)))
172      (with-open-file (f (make-pathname
173                          :host nil
174                          :directory (pathname-directory
175                                      (ensure-shark-session-path))
176                          :name (format nil "~a_~D"
177                                        (pathname-name
178                                         (car
179                                          ccl::*command-line-argument-list*))
180                                        (ccl::getpid))
181                          :type "spatch")
182                         :direction :output
183                         :if-exists :supersede)
184        (format f "!SHARK_SPATCH_BEGIN~%")
185        (dotimes (i (length functions))
186          (print-shark-spatch-record (svref functions i) f))
187        (format f "!SHARK_SPATCH_END~%"))) t))
188
189(defun terminate-shark-process ()
190  (when *shark-process*
191    (signal-external-process *shark-process* #$SIGUSR2))
192  (setq *shark-process* nil
193        *sampling* nil))
194
195(defun toggle-sampling ()
196  (if *shark-process*
197    (progn
198      (signal-external-process *shark-process* (if *sampling* #$SIGUSR2 #$SIGUSR1))
199      (setq *sampling* (not *sampling*)))
200    (warn "No active shark procsss")))
201
202(defun enable-sampling ()
203  (unless *sampling* (toggle-sampling)))
204
205(defun disable-sampling ()
206  (when *sampling* (toggle-sampling)))
207
208(defun ensure-shark-process (reset)
209  (when (or (null *shark-process*) reset)
210    (terminate-shark-process)
211    (generate-shark-spatch-file)
212    (let* ((args (list "-b" "-r" "-a" (format nil "~d" (ccl::getpid))
213                             "-d" *shark-session-native-namestring*)))
214      (when *shark-config-file*
215        (push (ccl::native-untranslated-namestring *shark-config-file*)
216              args)
217        (push "-m" args))
218      (setq *shark-process*
219            (run-program "/usr/bin/shark"
220                         args
221                         :output t
222                         :wait nil))
223      (sleep 5))))
224
225
226(defmacro meter (form &key reset)
227    `(progn
228      (ensure-shark-process ,reset)
229      (unwind-protect
230         (progn
231           (enable-sampling)
232           ,form)
233        (disable-sampling)
234        (wait-and-open-mshark-file *shark-session-path* 5))))
235
236
Note: See TracBrowser for help on using the repository browser.