Changeset 14610

Timestamp:

Jan 30, 2011, 12:41:54 AM (14 years ago)

Author:

Gary Byers

Message:

New scheme (using native heap images.) Lose all of the .spatch
stuff.

File:

• trunk/source/library/chud-metering.lisp (modified) (7 diffs)

trunk/source/library/chud-metering.lisp

@@ -18 +18 @@
 ;;; (and possibly others.)
 
-;;; CHUD 4.4.3-5 claims to offer 64-bit support; however, the library
-;;; which provides the API to control CHUD metering functions still
-;;; seems to be 32-bit only.  Conditionalization for x86-64 and
-;;; for 64-bit targets is (so far) just an exercise.
-
 (defpackage "CHUD"
   (:use "CL" "CCL")
@@ -37 +32 @@
 (defparameter *shark-session-path* nil)
 
-(defloadvar *written-spatch-file* nil)
 
 (defparameter *shark-session-native-namestring* nil)
@@ -66 +60 @@
              (native-name (ccl::native-untranslated-namestring dir)))
         (ensure-directories-exist dir)
-        (setenv "SHARK_SEARCH_PATH_PATCH_FILES" native-name)
         (setq *shark-session-native-namestring*
               native-name
@@ -81 +74 @@
 
 
-(defun safe-shark-function-name (function)
-  (let* ((name (format nil "~s" function)))
-    (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1)))
 
-(defun print-shark-spatch-record (fn &optional (stream t))
-  (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn)
-         (startaddr (+ (ccl::%address-of code-vector)
-                       #+x8664-target 0
-                       #+ppc32-target target::misc-data-offset
-                       #-ppc32-target 0))
-         (endaddr (+ startaddr
-                     #+x8664-target
-                     (1+ (ash (1- (ccl::%function-code-words fn)
-                                  ) target::word-shift))
-                     #+ppc-target
-                     (* 4 (- (uvsize code-vector)
-                                       #+ppc64-target 2
-                                       #-ppc64-target 1)))))
-    ;; i hope all lisp sym characters are allowed... we'll see
-    (format stream "{~%~@
-                        ~a~@
-                        ~@?~@
-                        ~@?~@
-                        }~%"
-            (safe-shark-function-name fn)
-            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
-            startaddr
-            #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x"
-            endaddr)))
-
-#+x8664-target
-(ccl::defx86lapfunction dynamic-dnode ((x arg_z))
-  (movq (% x) (% imm0))
-  (ref-global x86::heap-start arg_y)
-  (subq (% arg_y) (% imm0))
-  (shrq ($ x8664::dnode-shift) (% imm0))
-  (box-fixnum imm0 arg_z)
-  (single-value-return))
-
-#+x8632-target
-(ccl::defx8632lapfunction dynamic-dnode ((x arg_z))
-  (movl (% x) (% imm0))
-  (ref-global x86::heap-start arg_y)
-  (subl (% arg_y) (% imm0))
-  (shrl ($ x8632::dnode-shift) (% imm0))
-  (box-fixnum imm0 arg_z)
-  (single-value-return))
-
-#+x8664-target
-(defun identify-functions-with-pure-code ()
-  (ccl::freeze)
-  (ccl::collect ((functions))
-    (block walk
-      (let* ((frozen-dnodes (ccl::frozen-space-dnodes)))
-        (ccl::%map-areas (lambda (o)
-                           (when (>= (dynamic-dnode o) frozen-dnodes)
-                             (return-from walk nil))
-                           (when (typep o 'ccl::function-vector)
-                             (functions (ccl::function-vector-to-function o))))
-                         ccl::area-dynamic
-                         )))
-    (functions)))
-
-#+x8632-target
-(defun identify-functions-with-pure-code ()
-  (ccl::freeze)
-  (ccl::collect ((functions))
-    (block walk
-      (let* ((frozen-dnodes (ccl::frozen-space-dnodes)))
-        (ccl::%map-areas (lambda (o)
-                           (when (>= (dynamic-dnode o) frozen-dnodes)
-                             (return-from walk nil))
-                           (when (typep o 'function)
-                             (functions o)))
-                         ccl::area-dynamic
-                         )))
-    (functions)))
-
-#+ppc-target
-(defun identify-functions-with-pure-code ()
-  (ccl::purify)
-  (multiple-value-bind (pure-low pure-high)
-                                 
-      (ccl::do-gc-areas (a)
-        (when (eql(ccl::%fixnum-ref a target::area.code)
-                  ccl::area-readonly)
-          (return
-            (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
-                    (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))
-    (let* ((hash (make-hash-table :test #'eq)))
-      (ccl::%map-lfuns #'(lambda (f)
-                           (let* ((code-vector  (ccl:uvref f 0))
-                                  (startaddr (+ (ccl::%address-of code-vector)
-                                                target::misc-data-offset)))
-                             (when (and (>= startaddr pure-low)
-                                        (< startaddr pure-high))
-                               (push f (gethash code-vector hash))))))
-      (let* ((n 0))
-        (declare (fixnum n))
-        (maphash #'(lambda (k v)
-                     (declare (ignore k))
-                     (if (null (cdr v))
-                       (incf n)))
-                 hash)
-        (let* ((functions ()))
-          (maphash #'(lambda (k v)
-                       (declare (ignore k))
-                       (when (null (cdr v))
-                         (push (car v) functions)))
-                   hash)
-          (sort functions
-                #'(lambda (x y)
-                    (< (ccl::%address-of (uvref x 0) )
-                       (ccl::%address-of  (uvref y 0))))))))))
-        
-                           
-
-
-(defun generate-shark-spatch-file ()
-  (let* ((functions (identify-functions-with-pure-code)))
-    (with-open-file (f (make-pathname
-                        :host nil
-                        :directory (pathname-directory
-                                    (ensure-shark-session-path))
-                        :name (format nil "~a_~D"
-                                      (pathname-name
-                                       (car
-                                        ccl::*command-line-argument-list*))
-                                      (ccl::getpid))
-                        :type "spatch")
-                       :direction :output
-                       :if-exists :supersede)
-      (format f "!SHARK_SPATCH_BEGIN~%")
-      (dolist (fun functions)
-        (print-shark-spatch-record fun f))
-      (format f "!SHARK_SPATCH_END~%"))))
 
 (defun terminate-shark-process ()
@@ -227 +85 @@
   (if *shark-process*
     (progn
-      (signal-external-process *shark-process* #$SIGUSR1)
+      (signal-external-process *shark-process* (if *sampling* #$SIGUSR2 #$SIGUSR1))
       (setq *sampling* (not *sampling*)))
     (warn "No active shark procsss")))
@@ -240 +98 @@
   (when (or (null *shark-process*) reset)
     (terminate-shark-process)
-    (when (or reset (not *written-spatch-file*))
-      (generate-shark-spatch-file))
-    (let* ((args (list "-b" "-1" "-a" (format nil "~d" (ccl::getpid))
-                             "-d" *shark-session-native-namestring*)))
+    (let* ((args (list "-r" "-b" "-1" "-a" (format nil "~d" (ccl::getpid))
+                       "-d" *shark-session-native-namestring*)))
       (when *shark-config-file*
         (push (ccl::native-untranslated-namestring *shark-config-file*)
@@ -293 +149 @@
                        *sampling* nil))))
         (let* ((*debug-shark-process-output* ,debug-output))
+          (ensure-shark-session-path)
           (ensure-shark-process ,reset #',hook)
           (unwind-protect