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 |
---|
47 | in 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*) |
---|