0.8.0.24:

[sbcl.git] / src / code / profile.lisp

diff --git a/src/code/profile.lisp b/src/code/profile.lisp
index dbdc65e..0a257b3 100644 (file)
--- a/src/code/profile.lisp
+++ b/src/code/profile.lisp
@@ -47,7 +47,11 @@
 ;;; We associate a PROFILE-INFO structure with each profiled function
 ;;; name. This holds the functions that we call to manipulate the
 ;;; closure which implements the encapsulation.
 ;;; We associate a PROFILE-INFO structure with each profiled function
 ;;; name. This holds the functions that we call to manipulate the
 ;;; closure which implements the encapsulation.

-(defvar *profiled-fun-name->info* (make-hash-table))
+(defvar *profiled-fun-name->info*
+  (make-hash-table
+   ;; EQL testing isn't good enough for generalized function names
+   ;; like (SETF FOO).
+   :test 'equal))

 (defstruct (profile-info (:copier nil))
   (name              (missing-arg) :read-only t)
   (encapsulated-fun  (missing-arg) :type function :read-only t)
 (defstruct (profile-info (:copier nil))
   (name              (missing-arg) :read-only t)
   (encapsulated-fun  (missing-arg) :type function :read-only t)

@@ -98,8 +102,7 @@
 \f
 ;;;; profile encapsulations
 
 \f
 ;;;; profile encapsulations
 

-;;; Trade off space for time by handling the usual all-FIXNUM cases
-;;; inline.
+;;; Trade off space for time by handling the usual all-FIXNUM cases inline.

 (defmacro fastbig- (x y)
   (once-only ((x x) (y y))
     `(if (and (typep ,x '(and fixnum unsigned-byte))
 (defmacro fastbig- (x y)
   (once-only ((x x) (y y))
     `(if (and (typep ,x '(and fixnum unsigned-byte))

@@ -164,7 +167,7 @@
         (aver (typep dticks 'unsigned-byte))
         (aver (typep dconsing 'unsigned-byte))
         (aver (typep inner-enclosed-profiles 'unsigned-byte))
         (aver (typep dticks 'unsigned-byte))
         (aver (typep dconsing 'unsigned-byte))
         (aver (typep inner-enclosed-profiles 'unsigned-byte))

-        (multiple-value-prog1
+        (unwind-protect

             (let* ((start-ticks (get-internal-ticks))
                    (*enclosed-ticks* 0)
                    (*enclosed-consing* 0)
             (let* ((start-ticks (get-internal-ticks))
                    (*enclosed-ticks* 0)
                    (*enclosed-consing* 0)

@@ -172,7 +175,7 @@
                    (nbf0 *n-bytes-freed-or-purified*)
                    (dynamic-usage-0 (sb-kernel:dynamic-usage)))
               (declare (inline pcounter-or-fixnum->integer))
                    (nbf0 *n-bytes-freed-or-purified*)
                    (dynamic-usage-0 (sb-kernel:dynamic-usage)))
               (declare (inline pcounter-or-fixnum->integer))

-              (multiple-value-prog1
+              (unwind-protect

                   (multiple-value-call encapsulated-fun
                                        (sb-c:%more-arg-values arg-context
                                                               0
                   (multiple-value-call encapsulated-fun
                                        (sb-c:%more-arg-values arg-context
                                                               0

@@ -191,7 +194,9 @@
                         (pcounter-or-fixnum->integer *enclosed-profiles*))
                   (let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
                     (fastbig-incf-pcounter-or-fixnum ticks net-dticks))
                         (pcounter-or-fixnum->integer *enclosed-profiles*))
                   (let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
                     (fastbig-incf-pcounter-or-fixnum ticks net-dticks))

-                  (let ((net-dconsing (fastbig- dconsing *enclosed-consing*)))
+                  (let ((net-dconsing (fastbig- dconsing
+                                                (pcounter-or-fixnum->integer
+                                                 *enclosed-consing*))))

                     (fastbig-incf-pcounter-or-fixnum consing net-dconsing))
                   (fastbig-incf-pcounter-or-fixnum profiles
                                                    inner-enclosed-profiles))))
                     (fastbig-incf-pcounter-or-fixnum consing net-dconsing))
                   (fastbig-incf-pcounter-or-fixnum profiles
                                                    inner-enclosed-profiles))))

@@ -217,14 +222,12 @@
 
 ;;; A symbol or (SETF FOO) list names a function, a string names all
 ;;; the functions named by symbols in the named package.
 
 ;;; A symbol or (SETF FOO) list names a function, a string names all
 ;;; the functions named by symbols in the named package.

-(defun mapc-on-named-functions (function names)
+(defun mapc-on-named-funs (function names)

   (dolist (name names)
     (etypecase name
       (symbol (funcall function name))
       (list
   (dolist (name names)
     (etypecase name
       (symbol (funcall function name))
       (list

-       ;; We call this just for the side effect of checking that
-       ;; NAME is a legal function name:
-       (fun-name-block-name name)
+       (legal-fun-name-or-type-error name)

        ;; Then we map onto it.
        (funcall function name))
       (string (let ((package (find-undeleted-package-or-lose name)))
        ;; Then we map onto it.
        (funcall function name))
       (string (let ((package (find-undeleted-package-or-lose name)))

@@ -239,7 +242,7 @@
 
 ;;; Profile the named function, which should exist and not be profiled
 ;;; already.
 
 ;;; Profile the named function, which should exist and not be profiled
 ;;; already.

-(defun profile-1-unprofiled-function (name)
+(defun profile-1-unprofiled-fun (name)

   (let ((encapsulated-fun (fdefinition name)))
     (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
        (profile-encapsulation-lambdas encapsulated-fun)
   (let ((encapsulated-fun (fdefinition name)))
     (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
        (profile-encapsulation-lambdas encapsulated-fun)

@@ -254,18 +257,18 @@
       (values))))
 
 ;;; Profile the named function. If already profiled, unprofile first.
       (values))))
 
 ;;; Profile the named function. If already profiled, unprofile first.

-(defun profile-1-function (name)
+(defun profile-1-fun (name)

   (cond ((fboundp name)
         (when (gethash name *profiled-fun-name->info*)
           (warn "~S is already profiled, so unprofiling it first." name)
   (cond ((fboundp name)
         (when (gethash name *profiled-fun-name->info*)
           (warn "~S is already profiled, so unprofiling it first." name)

-          (unprofile-1-function name))
-        (profile-1-unprofiled-function name))
+          (unprofile-1-fun name))
+        (profile-1-unprofiled-fun name))

        (t
         (warn "ignoring undefined function ~S" name)))
   (values))
 
 ;;; Unprofile the named function, if it is profiled.
        (t
         (warn "ignoring undefined function ~S" name)))
   (values))
 
 ;;; Unprofile the named function, if it is profiled.

-(defun unprofile-1-function (name)
+(defun unprofile-1-fun (name)

   (let ((pinfo (gethash name *profiled-fun-name->info*)))
     (cond (pinfo
           (remhash name *profiled-fun-name->info*)
   (let ((pinfo (gethash name *profiled-fun-name->info*)))
     (cond (pinfo
           (remhash name *profiled-fun-name->info*)

@@ -293,7 +296,7 @@
   (if (null names)
       `(loop for k being each hash-key in *profiled-fun-name->info*
             collecting k)
   (if (null names)
       `(loop for k being each hash-key in *profiled-fun-name->info*
             collecting k)

-      `(mapc-on-named-functions #'profile-1-function ',names)))
+      `(mapc-on-named-funs #'profile-1-fun ',names)))

 
 (defmacro unprofile (&rest names)
   #+sb-doc
 
 (defmacro unprofile (&rest names)
   #+sb-doc

@@ -303,13 +306,13 @@
   named package. NAMES defaults to the list of names of all currently 
   profiled functions."
   (if names
   named package. NAMES defaults to the list of names of all currently 
   profiled functions."
   (if names

-      `(mapc-on-named-functions #'unprofile-1-function ',names)
+      `(mapc-on-named-funs #'unprofile-1-fun ',names)

       `(unprofile-all)))
 
 (defun unprofile-all ()
   (dohash (name profile-info *profiled-fun-name->info*)
     (declare (ignore profile-info))
       `(unprofile-all)))
 
 (defun unprofile-all ()
   (dohash (name profile-info *profiled-fun-name->info*)
     (declare (ignore profile-info))

-    (unprofile-1-function name)))
+    (unprofile-1-fun name)))

 
 (defun reset ()
   "Reset the counters for all profiled functions."
 
 (defun reset ()
   "Reset the counters for all profiled functions."

@@ -443,6 +446,7 @@ Lisp process."
   (flet ((frob ()
           (let ((start (get-internal-ticks))
                 (fun (symbol-function 'compute-overhead-aux)))
   (flet ((frob ()
           (let ((start (get-internal-ticks))
                 (fun (symbol-function 'compute-overhead-aux)))

+             (declare (type function fun))

             (dotimes (i *timer-overhead-iterations*)
               (funcall fun fun))
             (/ (float (- (get-internal-ticks) start))
             (dotimes (i *timer-overhead-iterations*)
               (funcall fun fun))
             (/ (float (- (get-internal-ticks) start))