source: release/1.9/source/library/chud-metering.lisp @ 15706

Last change on this file since 15706 was 14628, checked in by gb, 8 years ago

Tell the user that we're waiting for shark to process samples.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.1 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(defpackage "CHUD"
21  (:use "CL" "CCL")
22  (:export "METER" "*SHARK-CONFIG-FILE*"))
23 
24(in-package "CHUD")
25
26(eval-when (:compile-toplevel :load-toplevel :execute)
27  (progn
28    #-darwin-target
29    (error "This code is Darwin/MacOSX-specific.")))
30
31
32(defparameter *shark-session-path* nil)
33
34
35(defparameter *shark-session-native-namestring* nil)
36
37(defparameter *shark-config-file* nil "Full pathname of .cfg file to use for profiling, or NIL.")
38
39(defun finder-open-file (namestring)
40  "Open the file named by NAMESTRING, as if it was double-clicked on
41in the finder"
42  (run-program "/usr/bin/open" (list namestring) :output nil))
43
44(defun ensure-shark-session-path ()
45  (unless *shark-session-path*
46    (multiple-value-bind (second minute hour date month year)
47        (decode-universal-time (get-universal-time))
48      (let* ((subdir (format nil "profiling-session-~A-~d_~d-~d-~d_~d.~d.~d"
49                             (pathname-name
50                              (car
51                               ccl::*command-line-argument-list*))
52                             (ccl::getpid)
53                             month
54                             date
55                             year
56                             hour
57                             minute
58                             second))
59             (dir (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list subdir)) :defaults nil))
60             (native-name (ccl::native-untranslated-namestring dir)))
61        (ensure-directories-exist dir)
62        (setq *shark-session-native-namestring*
63              native-name
64              *shark-session-path* dir))))
65  *shark-session-path*)
66
67
68 
69
70(defloadvar *shark-process* nil)
71(defloadvar *sampling* nil)
72
73(defvar *debug-shark-process-output* nil)
74
75
76
77
78(defun terminate-shark-process ()
79  (when *shark-process*
80    (signal-external-process *shark-process* #$SIGUSR2))
81  (setq *shark-process* nil
82        *sampling* nil))
83
84(defun toggle-sampling ()
85  (if *shark-process*
86    (progn
87      (signal-external-process *shark-process* (if *sampling* #$SIGUSR2 #$SIGUSR1))
88      (setq *sampling* (not *sampling*)))
89    (warn "No active shark procsss")))
90
91(defun enable-sampling ()
92  (unless *sampling* (toggle-sampling)))
93
94(defun disable-sampling ()
95  (when *sampling* (toggle-sampling)))
96
97(defun ensure-shark-process (reset hook)
98  (when (or (null *shark-process*) reset)
99    (terminate-shark-process)
100    (let* ((args (list "-r" "-b" "-1" "-a" (format nil "~d" (ccl::getpid))
101                       "-d" *shark-session-native-namestring*)))
102      (when *shark-config-file*
103        (push (ccl::native-untranslated-namestring *shark-config-file*)
104              args)
105        (push "-m" args))
106      (setq *shark-process*
107            (run-program "/usr/bin/shark"
108                         args
109                         :output :stream
110                         :status-hook hook
111                         :wait nil))
112      (let* ((output (external-process-output-stream *shark-process*)))
113        (do* ((line (read-line output nil nil) (read-line output nil nil)))
114             ((null line))
115          (when *debug-shark-process-output*
116            (format t "~&~a" line))
117          (when (search "ready." line :key #'char-downcase)
118            (sleep 1)
119            (return)))))))
120
121(defun display-shark-session-file (line)
122  (let* ((last-quote (position #\' line :from-end t))
123         (first-quote (and last-quote (position #\' line :end (1- last-quote) :from-end t)))
124         (path (and first-quote  (subseq line (1+ first-quote) last-quote))))
125    (when path (finder-open-file path))))
126   
127(defun scan-shark-process-output (p)
128  (format t "~&;;; Waiting for shark to process samples ...")
129  (with-interrupts-enabled 
130      (let* ((out (ccl::external-process-output p)))
131        (do* ((line (read-line out nil nil) (read-line out nil nil)))
132             ((null line))
133          (when *debug-shark-process-output*
134            (format t "~&~a" line))
135          (when (search "Created session file:" line)
136            (format t "done.~&")
137            (display-shark-session-file line)
138            (return))))))
139
140
141
142(defmacro meter (form &key reset debug-output)
143  (let* ((hook (gensym))
144         (block (gensym))
145         (process (gensym)))
146    `(block ,block
147      (flet ((,hook (p)
148               (when (or (eq (external-process-status p) :exited)
149                         (eq (external-process-status p) :signaled))
150                 (setq *shark-process* nil
151                       *sampling* nil))))
152        (let* ((*debug-shark-process-output* ,debug-output))
153          (ensure-shark-session-path)
154          (ensure-shark-process ,reset #',hook)
155          (unwind-protect
156               (progn
157                 (enable-sampling)
158                 ,form)
159            (disable-sampling)
160            (let* ((,process *shark-process*))
161              (when ,process
162                (scan-shark-process-output ,process)))))))))
163
164;;; Try to clean up after ourselves when the lisp quits.
165(pushnew 'terminate-shark-process ccl::*save-exit-functions*)
Note: See TracBrowser for help on using the repository browser.