Changeset 9162


Ignore:
Timestamp:
Apr 15, 2008, 11:27:35 AM (12 years ago)
Author:
gb
Message:

Work-in-progress; lots of timing screws.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/library/chud-metering.lisp

    r5851 r9162  
    2525(defpackage "CHUD"
    2626  (:use "CL" "CCL")
    27   (:export "METER" "PREPARE-METERING" "*SPATCH-DIRECTORY-PATH*"
     27  (:export "METER" "PREPARE-METERING" "SHARK-SESSION-PATH"
    2828           "LAUNCH-SHARK" "CLEANUP-SPATCH-FILES" "RESET-METERING"))
    2929 
    3030(in-package "CHUD")
    3131
    32 
    33 (defparameter *CHUD-library-path*
    34   "/System/Library/PrivateFrameworks/CHUD.Framework/CHUD"
    35   "This seems to move around with every release.")
    36 
    37 (defparameter *shark-app-path* "/Developer/Applications/Performance\ Tools/Shark.app")
    38 
    39 (defparameter *spatch-directory-path* nil
    40   "If non-NIL, should be a pathname whose directory component matches the
    41 \"Patch FIles\" search path in Shark's Preferences.  When this variable
    42 is NIL, USER-HOMEDIR-PATHNAME is used instead.")
    43 
    44 (eval-when (:load-toplevel :execute)
    45   (open-shared-library (namestring *CHUD-library-path*)))
    46 
    47 (eval-when (:compile-toplevel :execute)
    48   (use-interface-dir :chud))
    49 
    50 ;;; CHUD apparently has this notion of global, persistent
    51 ;;; "status" (the result returned by the last operation.)
    52 ;;; I have not idea whether or not that's thread-specific;
    53 ;;; there doesn't seem to be any other way of getting a
    54 ;;; string that describes an error code.
    55 (defun chud-get-status-string ()
    56   (with-macptrs ((s (#_chudGetStatusStr)))
    57     (if (%null-ptr-p s)
    58       ""
    59       (%get-cstring s))))
    60 
    61 (defun chud-check-error (result context)
    62   (or (eql result #$chudSuccess)
    63       (error "CHUD error ~d (~a) while ~a. " result (chud-get-status-string) context)))
     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
    6495 
    65 (defun chud-is-initialized ()
    66   (not (eql (#_chudIsInitialized) 0)))
    67 
    68 (defparameter *chud-supported-major-version* 4)
    69 (defparameter *chud-supported-minor-version* 1)
    70 
    71 ;; Don't know if it makes sense to worry about max supported versions
    72 ;; as well.
    73 
    74 (defun check-chud-version ()
    75   (let* ((version (#_chudFrameworkVersion))
    76          (major (ldb (byte 8 24) version))
    77          (minor (ldb (byte 8 12) version)))
    78     (or (and (>= major *chud-supported-major-version*)
    79              (when (= major *chud-supported-major-version*)
    80                (>= minor *chud-supported-minor-version*)))
    81         (warn "The installed CHUD framework is version ~d.~d.  ~
    82 The minimum version supported by this interface is ~d.~d."
    83               major minor *chud-supported-major-version*
    84               *chud-supported-minor-version*))))
    85    
    86 
    87 (defun initialize-chud ()
    88   (or (chud-is-initialized)
    89       (and (check-chud-version)
    90            (chud-check-error (#_chudInitialize) "initializing CHUD"))))
    91 
    92 (defun acquired-remote-access ()
    93   (eql #$true (#_chudIsRemoteAccessAcquired)))
    94  
    95 ;;; If we've already successfully called (#_chudAcquireRemoteAccess),
    96 ;;; we can call it again without error (e.g., it's a no-op in that
    97 ;;; case.)  However, we can successfully release it at most once.
    98 
    99 (defun acquire-remote-access ()
    100   (or (acquired-remote-access)
    101       (chud-check-error (#_chudAcquireRemoteAccess) "acquiring remote access")))
    102 
    103 (defun release-remote-access ()
    104   (chud-check-error (#_chudReleaseRemoteAccess) "releasing remote access"))
    105 
    106 (defun start-remote-perf-monitor (label)
    107   (with-cstrs ((clabel (format nil "~a" label)))
    108     (chud-check-error (#_chudStartRemotePerfMonitor clabel)
    109                       "starting performance monitor")))
    110 
    111 (defun stop-remote-perf-monitor ()
    112   (chud-check-error (#_chudStopRemotePerfMonitor)
    113                     "stopping performance monitor"))
    114 
    115 (defun setup-timer (duration frequency)
    116   (#_chudSetupTimer frequency
    117                     #$chudMicroSeconds
    118                     0
    119                     #$chudMicroSeconds
    120                     duration))
    121 
    122 (defun get-readonly-area-bounds ()
     96
     97(defvar *shark-process* nil)
     98(defvar *sampling* nil)
     99
     100#+ppc-target
     101(defun get-static-function-area-bounds ()
    123102  (ccl::do-gc-areas (a)
    124103    (when (eql(ccl::%fixnum-ref a target::area.code)
    125               #+ppc-target ccl::area-readonly
    126               #+x8664-target ccl::area-managed-static)
     104               ccl::area-readonly)
    127105      (return
    128106        (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
     
    134112
    135113(defun print-shark-spatch-record (fn &optional (stream t))
    136   (let* ((code-vector (uvref fn 0))
     114  (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn)
    137115         (startaddr (+ (ccl::%address-of code-vector)
    138                        target::misc-data-offset))
    139          (endaddr (+ startaddr (* target::node-size (uvsize 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)))))
    140121    ;; i hope all lisp sym characters are allowed... we'll see
    141122    (format stream "{~%~@
     
    184165                           
    185166(defun generate-shark-spatch-file ()
    186   (ccl::purify)
     167  #+ppc-target (ccl::purify)
     168  #+x86-target (ccl::freeze)
    187169  (multiple-value-bind (pure-low pure-high)
    188       (get-readonly-area-bounds)
     170      (get-static-function-area-bounds)
    189171    (let* ((functions (identify-functions-with-pure-code pure-low pure-high)))
    190172      (with-open-file (f (make-pathname
    191173                          :host nil
    192174                          :directory (pathname-directory
    193                                       (or *spatch-directory-path*
    194                                           (user-homedir-pathname)))
     175                                      (ensure-shark-session-path))
    195176                          :name (format nil "~a_~D"
    196177                                        (pathname-name
     
    206187        (format f "!SHARK_SPATCH_END~%"))) t))
    207188
    208 (defun cleanup-spatch-files ()
    209   (dolist (f (directory
    210               (make-pathname
    211                :host nil
    212                :directory
    213                (pathname-directory
    214                 (or *spatch-directory-path*
    215                     (user-homedir-pathname)))
    216                :name :wild
    217                :type "spatch")))
    218     (delete-file f)))
    219 
    220 
    221 (defun launch-shark ()
    222   (run-program "/usr/bin/open" (list *shark-app-path*)))
    223 
    224  
    225 (defun reset-metering ()
    226   (when (acquired-remote-access)
    227     (release-remote-access)
    228     (format t "~&Note: it may be desirable to quit and restart Shark.")
    229     t))
    230    
    231 (defun prepare-metering ()
    232   (launch-shark)
    233   (generate-shark-spatch-file)
    234   (initialize-chud)
    235   (loop
    236     (when (ignore-errors (acquire-remote-access))
    237       (return))
    238     ;; Yes, this is lame.
    239     (loop (when (y-or-n-p "Is Shark in Remote mode yet?")
    240             (return)))))
    241 
    242 (defmacro meter (form &key (duration 0) (frequency 1))
    243   (let* ((started (gensym)))
    244     `(let* ((,started nil))
    245       (unless (and (chud-is-initialized)
    246                    (acquired-remote-access))
    247         (prepare-metering))
    248       (setup-timer ,duration ,frequency)
     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)
    249229      (unwind-protect
    250230         (progn
    251            (setq ,started (start-remote-perf-monitor ',form))
     231           (enable-sampling)
    252232           ,form)
    253         (when ,started (stop-remote-perf-monitor))))))
    254 
    255 (defun chud-cleanup ()
    256   (when (chud-is-initialized)
    257     (when (acquired-remote-access)
    258       (ignore-errors (release-remote-access)))
    259     (#_chudCleanup))
    260   (cleanup-spatch-files))
    261  
    262 (pushnew 'chud-cleanup *lisp-cleanup-functions*)
     233        (disable-sampling)
     234        (wait-and-open-mshark-file *shark-session-path* 5))))
     235
     236
Note: See TracChangeset for help on using the changeset viewer.