Changeset 9916


Ignore:
Timestamp:
Jul 7, 2008, 5:24:20 PM (11 years ago)
Author:
gz
Message:

Merge in some more changes from trunk, unused here (e.g. for other platforms) but keeping in sync makes diffs easier

Location:
branches/working-0711/ccl/library
Files:
2 added
5 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/library/chud-metering.lisp

    r5851 r9916  
    11;;;-*-Mode: LISP; Package: (CHUD (:USE CL CCL)) -*-
    22;;;
    3 ;;;   Copyright (C) 2005 Clozure Associates and contributors
     3;;;   Copyright (C) 2005,2008 Clozure Associates and contributors
    44;;;   This file is part of OpenMCL. 
    55;;;
     
    2525(defpackage "CHUD"
    2626  (:use "CL" "CCL")
    27   (:export "METER" "PREPARE-METERING" "*SPATCH-DIRECTORY-PATH*"
    28            "LAUNCH-SHARK" "CLEANUP-SPATCH-FILES" "RESET-METERING"))
     27  (:export "METER" "*SHARK-CONFIG-FILE*"))
    2928 
    3029(in-package "CHUD")
    3130
    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)))
     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
    6475 
    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 ()
    123   (ccl::do-gc-areas (a)
    124     (when (eql(ccl::%fixnum-ref a target::area.code)
    125               #+ppc-target ccl::area-readonly
    126               #+x8664-target ccl::area-managed-static)
    127       (return
    128         (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
    129                 (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift))))))
     76
     77(defloadvar *shark-process* nil)
     78(defloadvar *sampling* nil)
     79
     80(defvar *debug-shark-process-output* nil)
     81
    13082
    13183(defun safe-shark-function-name (function)
     
    13486
    13587(defun print-shark-spatch-record (fn &optional (stream t))
    136   (let* ((code-vector (uvref fn 0))
     88  (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn)
    13789         (startaddr (+ (ccl::%address-of code-vector)
    138                        target::misc-data-offset))
    139          (endaddr (+ startaddr (* target::node-size (uvsize 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)))))
    140101    ;; i hope all lisp sym characters are allowed... we'll see
    141102    (format stream "{~%~@
     
    150111            endaddr)))
    151112
    152 (defun identify-functions-with-pure-code (pure-low pure-high)
    153   (let* ((hash (make-hash-table :test #'eq)))
    154     (ccl::%map-lfuns #'(lambda (f)
    155                          (let* ((code-vector #+ppc-target (ccl:uvref f 0)
    156                                              #+x8664-target (ccl::function-to-function-vector f))
    157                                 (startaddr (+ (ccl::%address-of code-vector)
    158                                               target::misc-data-offset)))
    159                            (when (and (>= startaddr pure-low)
    160                                       (< startaddr pure-high))
    161                              (push f (gethash code-vector hash))))))
    162     (let* ((n 0))
    163       (declare (fixnum n))
    164       (maphash #'(lambda (k v)
    165                    (declare (ignore k))
    166                    (if (null (cdr v))
    167                      (incf n)))
    168                hash)
    169       (let* ((functions (make-array n))
    170              (i 0))
     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))
    171159        (maphash #'(lambda (k v)
    172160                     (declare (ignore k))
    173                      (when (null (cdr v))
    174                        (setf (svref functions i) (car v)
    175                              i (1+ i))))
     161                     (if (null (cdr v))
     162                       (incf n)))
    176163                 hash)
    177         (sort functions
    178               #'(lambda (x y)
    179                   (< (ccl::%address-of #+ppc-target (uvref x 0)
    180                                        #+x8664-target x)
    181                      (ccl::%address-of #+ppc-target (uvref y 0)
    182                                        #+x8664-target y))))))))
     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))))))))))
    183174       
    184175                           
     176
     177
    185178(defun generate-shark-spatch-file ()
    186   (ccl::purify)
    187   (multiple-value-bind (pure-low pure-high)
    188       (get-readonly-area-bounds)
    189     (let* ((functions (identify-functions-with-pure-code pure-low pure-high)))
    190       (with-open-file (f (make-pathname
    191                           :host nil
    192                           :directory (pathname-directory
    193                                       (or *spatch-directory-path*
    194                                           (user-homedir-pathname)))
    195                           :name (format nil "~a_~D"
    196                                         (pathname-name
    197                                          (car
    198                                           ccl::*command-line-argument-list*))
    199                                         (ccl::getpid))
    200                           :type "spatch")
    201                          :direction :output
    202                          :if-exists :supersede)
    203         (format f "!SHARK_SPATCH_BEGIN~%")
    204         (dotimes (i (length functions))
    205           (print-shark-spatch-record (svref functions i) f))
    206         (format f "!SHARK_SPATCH_END~%"))) t))
    207 
    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))
     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))))
    230247   
    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)
    249       (unwind-protect
    250          (progn
    251            (setq ,started (start-remote-perf-monitor ',form))
    252            ,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*)
     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*)
  • branches/working-0711/ccl/library/darwinppc-syscalls.lisp

    r4968 r9916  
    9393(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-doubleword) :signed-fullword )
    9494
     95(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::poll 230 ((:* (:struct :pollfd)) :int :int) :int)
     96
    9597#+notdefinedyet
    9698(progn
  • branches/working-0711/ccl/library/darwinx8664-syscalls.lisp

    r4975 r9916  
    9393(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::truncate  (logior darwinx8664-unix-syscall-mask 200) (:address :unsigned-doubleword) :signed-fullword )
    9494(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ftruncate  (logior darwinx8664-unix-syscall-mask 201) (:unsigned-fullword :unsigned-doubleword) :signed-fullword )
    95 
     95(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::poll (logior darwinx8664-unix-syscall-mask 230) ((:* (:struct :pollfd)) :int :int) :int)
    9696#+notdefinedyet
    9797(progn
  • branches/working-0711/ccl/library/ppc-linux-syscalls.lisp

    r3768 r9916  
    119119(define-syscall (logior platform-cpu-ppc platform-os-linux)  syscalls::getcwd 182 (:address :unsigned-fullword) :signed-fullword )
    120120
    121 
     121(define-syscall (logior platform-cpu-ppc platform-os-linux)  syscalls::poll 167 ((:* (:struct :pollfd)) :int :int) :int)
    122122
    123123#+notdefinedyet
  • branches/working-0711/ccl/library/x8664-freebsd-syscalls.lisp

    r7434 r9916  
    8686(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::rename 128 (:address :address) :signed-fullword )
    8787(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword )
    88 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::rmdir 17 (:address) :signed-fullword )
     88(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::rmdir 137 (:address) :signed-fullword )
    8989(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::dup 41 (:unsigned-fullword) :signed-fullword )
    9090(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::pipe 42 (:address) :signed-fullword )
     
    156156(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::getcwd 326 (:address :unsigned-fullword) :signed-fullword )
    157157
    158 
     158(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::poll 209 ((:* (:struct :pollfd)) :int :int) :int)
    159159
    160160#+notdefinedyet
Note: See TracChangeset for help on using the changeset viewer.