source: release/1.2/source/library/chud-metering.lisp @ 9675

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

*debug-shark-process-output* shouldn't be static

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