Changeset 9187


Ignore:
Timestamp:
Apr 18, 2008, 8:13:35 PM (11 years ago)
Author:
gb
Message:

Conditionalize for x86-64; need to see if I broke it on PPC.
Add a 1-second delay after shark says it's "Ready"; don't know
how to tell if it really is.

File:
1 edited

Legend:

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

    r9168 r9187  
    7373  *shark-session-path*)
    7474
    75 ;;; This is cheesy: it should watch for directory changes (or something)
    76 ;;; rather than guessing how long it'll take for an mshark file to appear
    77 ;;; in the session directory.
    78 (defun wait-and-open-mshark-file (path delay)
    79   (process-run-function "mshark file watch"
    80                         (lambda ()
    81                           (sleep delay)
    82                           (let* ((path (make-pathname
    83                                         :host nil
    84                                         :directory
    85                                         (pathname-directory path)
    86                                         :name "*"
    87                                         :type "mshark"
    88                                         :defaults nil))
    89                                  (mshark
    90                                   (ignore-errors (car (last (directory path))))))
    91                             (when mshark
    92                               (finder-open-file
    93                                (ccl::native-untranslated-namestring mshark)))))))
    94 
    9575
    9676 
     
    9979(defvar *sampling* nil)
    10080
    101 #+ppc-target
    102 (defun get-static-function-area-bounds ()
    103   (ccl::do-gc-areas (a)
    104     (when (eql(ccl::%fixnum-ref a target::area.code)
    105                ccl::area-readonly)
    106       (return
    107         (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
    108                 (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift))))))
    10981
    11082(defun safe-shark-function-name (function)
     
    11587  (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn)
    11688         (startaddr (+ (ccl::%address-of code-vector)
     89                       #+x8664-target 0
    11790                       #+ppc32-target target::misc-data-offset
    11891                       #-ppc32-target 0))
    119          (endaddr (+ startaddr (* 4 (- (uvsize code-vector)
     92         (endaddr (+ startaddr
     93                     #+x8664-target
     94                     (1+ (ash (1- (ccl::%function-code-words fn)
     95                                  ) target::word-shift))
     96                     #+ppc-target
     97                     (* 4 (- (uvsize code-vector)
    12098                                       #+ppc64-target 2
    12199                                       #-ppc64-target 1)))))
     
    132110            endaddr)))
    133111
    134 (defun identify-functions-with-pure-code (pure-low pure-high)
    135   (let* ((hash (make-hash-table :test #'eq)))
    136     (ccl::%map-lfuns #'(lambda (f)
    137                          (let* ((code-vector #+ppc-target (ccl:uvref f 0)
    138                                              #+x8664-target (ccl::function-to-function-vector f))
    139                                 (startaddr (+ (ccl::%address-of code-vector)
    140                                               target::misc-data-offset)))
    141                            (when (and (>= startaddr pure-low)
    142                                       (< startaddr pure-high))
    143                              (push f (gethash code-vector hash))))))
    144     (let* ((n 0))
    145       (declare (fixnum n))
    146       (maphash #'(lambda (k v)
    147                    (declare (ignore k))
    148                    (if (null (cdr v))
    149                      (incf n)))
    150                hash)
    151       (let* ((functions (make-array n))
    152              (i 0))
     112#+x8664-target
     113(ccl::defx86lapfunction dynamic-dnode ((x arg_z))
     114  (movq (% x) (% imm0))
     115  (ref-global x86::heap-start arg_y)
     116  (subq (% arg_y) (% imm0))
     117  (shrq ($ x8664::dnode-shift) (% imm0))
     118  (box-fixnum imm0 arg_z)
     119  (single-value-return))
     120
     121#+x8664-target
     122(defun identify-functions-with-pure-code ()
     123  (ccl::collect ((functions))
     124    (block walk
     125      (let* ((frozen-dnodes (ccl::frozen-space-dnodes)))
     126        (ccl::%map-areas (lambda (o)
     127                           (when (>= (dynamic-dnode o) frozen-dnodes)
     128                             (return-from walk nil))
     129                           (when (typep o 'ccl::function-vector)
     130                             (functions (ccl::function-vector-to-function o))))
     131                         ccl::area-dynamic
     132                         ccl::area-dynamic
     133                         )))
     134    (functions)))
     135
     136#+ppc-target
     137(defun identify-functions-with-pure-code ()
     138  (multiple-value-bind (pure-low pure-high)
     139                                 
     140      (ccl::do-gc-areas (a)
     141        (when (eql(ccl::%fixnum-ref a target::area.code)
     142                  ccl::area-readonly)
     143          (return
     144            (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
     145                    (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))
     146    (let* ((hash (make-hash-table :test #'eq)))
     147      (ccl::%map-lfuns #'(lambda (f)
     148                           (let* ((code-vector  (ccl:uvref f 0))
     149                                  (startaddr (+ (ccl::%address-of code-vector)
     150                                                target::misc-data-offset)))
     151                             (when (and (>= startaddr pure-low)
     152                                        (< startaddr pure-high))
     153                               (push f (gethash code-vector hash))))))
     154      (let* ((n 0))
     155        (declare (fixnum n))
    153156        (maphash #'(lambda (k v)
    154157                     (declare (ignore k))
    155                      (when (null (cdr v))
    156                        (setf (svref functions i) (car v)
    157                              i (1+ i))))
     158                     (if (null (cdr v))
     159                       (incf n)))
    158160                 hash)
    159         (sort functions
    160               #'(lambda (x y)
    161                   (< (ccl::%address-of #+ppc-target (uvref x 0)
    162                                        #+x8664-target x)
    163                      (ccl::%address-of #+ppc-target (uvref y 0)
    164                                        #+x8664-target y))))))))
     161        (let* ((functions ()))
     162          (maphash #'(lambda (k v)
     163                       (declare (ignore k))
     164                       (when (null (cdr v))
     165                         (push (car v) functions)))
     166                   hash)
     167          (sort functions
     168                #'(lambda (x y)
     169                    (< (ccl::%address-of (uvref x 0) )
     170                       (ccl::%address-of  (uvref y 0))))))))))
    165171       
    166172                           
     
    168174  #+ppc-target (ccl::purify)
    169175  #+x86-target (ccl::freeze)
    170   (multiple-value-bind (pure-low pure-high)
    171       (get-static-function-area-bounds)
    172     (let* ((functions (identify-functions-with-pure-code pure-low pure-high)))
    173       (with-open-file (f (make-pathname
    174                           :host nil
    175                           :directory (pathname-directory
    176                                       (ensure-shark-session-path))
    177                           :name (format nil "~a_~D"
    178                                         (pathname-name
    179                                          (car
    180                                           ccl::*command-line-argument-list*))
    181                                         (ccl::getpid))
    182                           :type "spatch")
    183                          :direction :output
    184                          :if-exists :supersede)
    185         (format f "!SHARK_SPATCH_BEGIN~%")
    186         (dotimes (i (length functions))
    187           (print-shark-spatch-record (svref functions i) f))
    188         (format f "!SHARK_SPATCH_END~%")))
    189     (setq *written-spatch-file* t)
    190     t))
     176  (let* ((functions (identify-functions-with-pure-code)))
     177    (with-open-file (f (make-pathname
     178                        :host nil
     179                        :directory (pathname-directory
     180                                    (ensure-shark-session-path))
     181                        :name (format nil "~a_~D"
     182                                      (pathname-name
     183                                       (car
     184                                        ccl::*command-line-argument-list*))
     185                                      (ccl::getpid))
     186                        :type "spatch")
     187                       :direction :output
     188                       :if-exists :supersede)
     189      (format f "!SHARK_SPATCH_BEGIN~%")
     190      (dolist (fun functions)
     191        (print-shark-spatch-record fun f))
     192      (format f "!SHARK_SPATCH_END~%"))))
    191193
    192194(defun terminate-shark-process ()
     
    229231        (do* ((line (read-line output nil nil) (read-line output nil nil)))
    230232             ((null line))
     233          (format t "~&~a" line)
    231234          (when (search "ready." line :key #'char-downcase)
     235            (sleep 1)
    232236            (return)))))))
    233237
     
    243247        (do* ((line (read-line out nil nil) (read-line out nil nil)))
    244248             ((null line))
     249          (format t "~&~a" line)
    245250          (when (search "Created session file:" line)
    246251            (display-shark-session-file line)
Note: See TracChangeset for help on using the changeset viewer.