[slime-devel] Feature: basic profiling interface

[Michael Weber]

Hi,

Attached is a patch which defines and implements (for SBCL and CMUCL)
a basic profiling interface for SLIME.

Profiling submenu and following key combos added: C-c p {t,u,f,r,c}

The CMUCL implementation is not tested, since my swank-cmucl.lisp does
not compile currently, but it is written according to docs.  If
somebody with working CMUCL SLIME could have a look, that would be
fine :)


Cheers,
Michael
-------------- next part --------------
cvs server: Diffing .
Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.197
diff -u -r1.197 slime.el
--- slime.el	23 Jan 2004 14:17:57 -0000	1.197
+++ slime.el	28 Jan 2004 21:03:39 -0000
@@ -422,6 +423,12 @@
     ;; NB: XEmacs dosn't like \C-g.  Use \C-b as "break" key.
     ("\C-b" slime-interrupt :prefixed t :inferior t :sldb t)
     ("\M-g" slime-quit :prefixed t :inferior t :sldb t)
+    ;; Profiling
+    ("pt" slime-toggle-profile-fdefinition :prefixed t :inferior t :sldb t)
+    ("pu" slime-unprofile-all :prefixed t :inferior t :sldb t)
+    ("pf" slime-profiled-functions :prefixed t :inferior t :sldb t)
+    ("pr" slime-profile-report :prefixed t :inferior t :sldb t)
+    ("pc" slime-profile-reset :prefixed t :inferior t :sldb t)
     ;; Documentation
     (" " slime-space :inferior t)
     ("\C-d" slime-describe-symbol :prefixed t :inferior t :sldb t)
@@ -508,6 +516,13 @@
        [ "Toggle Trace..."         slime-toggle-trace-fdefinition ,C ]
        [ "Disassemble..."          slime-disassemble-symbol ,C ]
        [ "Inspect..."              slime-inspect ,C ])
+      ("Profiling"
+       [ "Toggle Profiling..."     slime-toggle-profile-fdefinition ,C ]
+       [ "Unprofile All"           slime-unprofile-all ,C ]
+       [ "Show Profiled"           slime-profiled-functions ,C ]
+       "--"
+       [ "Report"                  slime-profile-report ,C ]
+       [ "Reset Counters"          slime-profile-reset ,C ])
       ("Compilation"
        [ "Compile Defun"           slime-compile-defun ,C ]
        [ "Compile/Load File"       slime-compile-and-load-file ,C ]
@@ -3615,6 +3631,37 @@
     (slime-eval-with-transcript `(swank:load-file ,lisp-filename) nil)))
 
 

+;;;; Profiling
+
+(defun slime-toggle-profile-fdefinition (fname-string)
+  "Toggle profiling for FNAME-STRING."
+  (interactive (list (slime-read-from-minibuffer
+		      "(Un)Profile: " (slime-symbol-name-at-point))))
+  (message "%s" (slime-eval `(swank:toggle-profile-fdefinition ,fname-string)
+			    (slime-buffer-package t))))
+
+(defun slime-unprofile-all ()
+  "Unprofile all functions."
+  (interactive)
+  (message "%s" (slime-eval `(swank:unprofile-all) (slime-buffer-package t))))
+
+(defun slime-profile-report ()
+  "Print profile report."
+  (interactive)
+  (slime-eval `(swank:profile-report)))
+
+(defun slime-profile-reset ()
+  "Reset profile counters."
+  (interactive)
+  (message "%s" (slime-eval `(swank:profile-reset))))
+
+(defun slime-profiled-functions ()
+  "Return list of names of currently profiled functions."
+  (interactive)
+  (message "%s" (slime-eval `(swank:profiled-functions))))
+
+
+

 ;;; Documentation
 
 (defun slime-hyperspec-lookup (symbol-name)
Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.22
diff -u -r1.22 swank-backend.lisp
--- swank-backend.lisp	22 Jan 2004 00:35:17 -0000	1.22
+++ swank-backend.lisp	28 Jan 2004 21:03:40 -0000
@@ -77,6 +77,12 @@
            #:throw-to-toplevel
            #:toggle-trace-fdefinition
            #:untrace-all
+           #:profile
+           #:unprofile
+           #:unprofile-all
+           #:profiled-functions
+           #:profile-report
+           #:profile-reset
            #:wait-goahead
            #:warn-unimplemented-interfaces
            #:who-binds
@@ -390,6 +396,31 @@
 (definterface restart-frame (frame-number)
   "Restart execution of the frame FRAME-NUMBER with the same arguments
 as it was called originally.")
+
+

+;;;; Profiling
+
+;;; The following functions define a minimal profiling interface.
+
+(definterface profile (fname)
+  "Marks symbol FNAME for profiling.")
+
+(definterface profiled-functions ()
+  "Returns a list of profiled functions.")
+
+(definterface unprofile (fname)
+  "Marks symbol FNAME as not profiled.")
+
+(definterface unprofile-all ()
+  "Marks all currently profiled functions as not profiled."
+  (dolist (f (profiled-functions))
+    (unprofile f)))
+
+(definterface profile-report ()
+  "Prints profile report.")
+
+(definterface profile-reset ()
+  "Resets profile counters.")
 
 

 ;;;; Queries
Index: swank-cmucl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-cmucl.lisp,v
retrieving revision 1.57
diff -u -r1.57 swank-cmucl.lisp
--- swank-cmucl.lisp	22 Jan 2004 00:38:48 -0000	1.57
+++ swank-cmucl.lisp	28 Jan 2004 21:03:43 -0000
@@ -1162,6 +1162,29 @@
 	    ("Function" . ,(kernel:fdefn-function o)))))
 
 

+;;;; Profiling
+(defimplementation profile (fname)
+  (when fname (eval `(sb-profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+  (when fname (eval `(sb-profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+  (sb-profile:unprofile)
+  "All functions unprofiled.")
+
+(defimplementation profile-report ()
+  (sb-profile:report-time))
+
+(defimplementation profile-reset ()
+  (sb-profile:reset-time)
+  "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+  profile:*timed-functions*)
+
+
+

 ;;;; Multiprocessing
 
 #+MP
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.56
diff -u -r1.56 swank-sbcl.lisp
--- swank-sbcl.lisp	23 Jan 2004 21:03:11 -0000	1.56
+++ swank-sbcl.lisp	28 Jan 2004 21:03:44 -0000
@@ -536,6 +536,29 @@
     (cond (probe (throw (car probe) (eval-in-frame form index)))
           (t (format nil "Cannot return from frame: ~S" frame)))))
     
+

+;;;; Profiling
+(defimplementation profile (fname)
+  (when fname (eval `(sb-profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+  (when fname (eval `(sb-profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+  (sb-profile:unprofile)
+  "All functions unprofiled.")
+
+(defimplementation profile-report ()
+  (sb-profile:report))
+
+(defimplementation profile-reset ()
+  (sb-profile:reset)
+  "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+  (sb-profile:profile))
+
+

 ;;;; Multiprocessing
 
 #+SB-THREAD
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.109
diff -u -r1.109 swank.lisp
--- swank.lisp	23 Jan 2004 00:20:39 -0000	1.109
+++ swank.lisp	28 Jan 2004 21:03:51 -0000
@@ -1136,6 +1136,21 @@
   (throw 'slime-toplevel nil))
 
 

+;;;; Profiling
+
+(defun profiledp (fspec)
+  (member fspec (profiled-functions)))
+
+(defslimefun toggle-profile-fdefinition (fname-string)
+  (let ((fname (from-string fname-string)))
+    (cond ((profiledp fname)
+	   (unprofile fname)
+	   (format nil "~S is now unprofiled." fname))
+	  (t
+           (profile fname)
+	   (format nil "~S is now profiled." fname)))))  
+
+

 ;;;; Source Locations
 
 (defstruct (:location (:type list) :named