0.8.12.7: Merge package locks, AKA "what can go wrong with a 3783 line patch?"

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

diff --git a/src/code/profile.lisp b/src/code/profile.lisp
index 0a257b3..30bd69d 100644 (file)
--- a/src/code/profile.lisp
+++ b/src/code/profile.lisp
@@ -233,7 +233,9 @@
       (string (let ((package (find-undeleted-package-or-lose name)))
                (do-symbols (symbol package)
                  (when (eq (symbol-package symbol) package)
-                   (when (fboundp symbol)
+                   (when (and (fboundp symbol)
+                              (not (macro-function symbol))
+                              (not (special-operator-p symbol)))
                      (funcall function symbol))
                    (let ((setf-name `(setf ,symbol)))
                      (when (fboundp setf-name)
@@ -246,8 +248,9 @@
   (let ((encapsulated-fun (fdefinition name)))
     (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
        (profile-encapsulation-lambdas encapsulated-fun)
-      (setf (fdefinition name)
-           encapsulation-fun)
+      (without-package-locks
+       (setf (fdefinition name)
+            encapsulation-fun))
       (setf (gethash name *profiled-fun-name->info*)
            (make-profile-info :name name
                               :encapsulated-fun encapsulated-fun
@@ -273,7 +276,8 @@
     (cond (pinfo
           (remhash name *profiled-fun-name->info*)
           (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
-              (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))
+              (without-package-locks
+               (setf (fdefinition name) (profile-info-encapsulated-fun pinfo)))
               (warn "preserving current definition of redefined function ~S"
                     name)))
          (t
@@ -381,30 +385,69 @@ Lisp process."
          (sort time-info-list
                #'>=
                :key #'time-info-seconds))
+    (print-profile-table time-info-list)
 
-    (format *trace-output*
-           "~&  seconds  |  consed   |  calls  |  sec/call  |  name~@
-              ------------------------------------------------------~%")
+    (when no-call-name-list
+      (format *trace-output*
+             "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
+             (sort no-call-name-list #'string<
+                   :key (lambda (name)
+                          (symbol-name (fun-name-block-name name))))))
+
+    (values)))
+
+
+(defun print-profile-table (time-info-list)
+  (let ((total-seconds 0.0)
+        (total-consed 0)
+        (total-calls 0)
+        (seconds-width (length "seconds"))
+        (consed-width (length "consed"))
+        (calls-width (length "calls"))
+        (sec/call-width 10)
+        (name-width 6))
+    (dolist (time-info time-info-list)
+      (incf total-seconds (time-info-seconds time-info))
+      (incf total-consed (time-info-consing time-info))
+      (incf total-calls (time-info-calls time-info)))
+    (setf seconds-width (max (length (format nil "~10,3F" total-seconds))
+                             seconds-width)
+          calls-width (max (length (format nil "~:D" total-calls))
+                           calls-width)
+          consed-width (max (length (format nil "~:D" total-consed))
+                            consed-width))
+
+    (flet ((dashes ()
+             (dotimes (i (+ seconds-width consed-width calls-width
+                            sec/call-width name-width
+                            (* 5 3)))
+               (write-char #\- *trace-output*))
+             (terpri *trace-output*)))
+      (format *trace-output* "~&~@{ ~v:@<~A~>~^|~}~%"
+              seconds-width "seconds"
+              (1+ consed-width) "consed"
+              (1+ calls-width) "calls"
+              (1+ sec/call-width) "sec/call"
+              (1+ name-width) "name")
+
+      (dashes)
 
-    (let ((total-time 0.0)
-         (total-consed 0)
-         (total-calls 0))
       (dolist (time-info time-info-list)
-       (incf total-time (time-info-seconds time-info))
-       (incf total-calls (time-info-calls time-info))
-       (incf total-consed (time-info-consing time-info))
-       (format *trace-output*
-               "~10,3F | ~9:D | ~7:D | ~10,6F | ~S~%"
-               (time-info-seconds time-info)
-               (time-info-consing time-info)
-               (time-info-calls time-info)
-               (/ (time-info-seconds time-info)
-                  (float (time-info-calls time-info)))
-               (time-info-name time-info)))
-      (format *trace-output*
-             "------------------------------------------------------~@
-             ~10,3F | ~9:D | ~7:D |        | Total~%"
-             total-time total-consed total-calls)
+        (format *trace-output* "~v,3F | ~v:D | ~v:D | ~10,6F | ~S~%"
+                seconds-width (time-info-seconds time-info)
+                consed-width (time-info-consing time-info)
+                calls-width (time-info-calls time-info)
+                (/ (time-info-seconds time-info)
+                   (float (time-info-calls time-info)))
+                (time-info-name time-info)))
+
+      (dashes)
+
+      (format *trace-output* "~v,3F | ~v:D | ~v:D |            | Total~%"
+                seconds-width total-seconds
+                consed-width total-consed
+                calls-width total-calls)
+
       (format *trace-output*
              "~%estimated total profiling overhead: ~4,2F seconds~%"
              (* (overhead-total *overhead*) (float total-calls)))
@@ -412,16 +455,8 @@ Lisp process."
              "~&overhead estimation parameters:~%  ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
              (overhead-call *overhead*)
              (overhead-total *overhead*)
-             (overhead-internal *overhead*)))
+             (overhead-internal *overhead*)))))
 
-    (when no-call-name-list
-      (format *trace-output*
-             "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
-             (sort no-call-name-list #'string<
-                   :key (lambda (name)
-                          (symbol-name (fun-name-block-name name))))))
-
-    (values)))
 \f
 ;;;; overhead estimation
 
@@ -482,5 +517,6 @@ Lisp process."
 ;;; different machine running at a different speed. We avoid this by
 ;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
 (pushnew (lambda ()
-          (makunbound '*overhead*))
+          (without-package-locks
+           (makunbound '*overhead*)))
         *before-save-initializations*)