[slime-cvs] CVS update: slime/slime.el slime/swank.lisp slime/swank-backend.lisp slime/swank-sbcl.lisp slime/swank-cmucl.lisp
Helmut Eller
heller at common-lisp.net
Thu Jan 29 08:37:57 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv16297
Modified Files:
slime.el swank.lisp swank-backend.lisp swank-sbcl.lisp
swank-cmucl.lisp
Log Message:
Profiler support. Patch by Michael Weber.
Date: Thu Jan 29 03:37:57 2004
Author: heller
Index: slime/slime.el
diff -u slime/slime.el:1.197 slime/slime.el:1.198
--- slime/slime.el:1.197 Fri Jan 23 09:17:57 2004
+++ slime/slime.el Thu Jan 29 03:37:57 2004
@@ -526,6 +526,14 @@
[ "List Callers..." slime-list-callers ,C ]
[ "List Callees..." slime-list-callees ,C ]
[ "Next Location" slime-next-location t ])
+ ("Profiling"
+ [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ]
+ [ "Profile Package" slime-profile-package ,C]
+ [ "Unprofile All" slime-unprofile-all ,C ]
+ [ "Show Profiled" slime-profiled-functions ,C ]
+ "--"
+ [ "Report" slime-profile-report ,C ]
+ [ "Reset Counters" slime-profile-reset ,C ])
("Documentation"
[ "Describe Symbol..." slime-describe-symbol ,C ]
[ "Apropos..." slime-apropos ,C ]
@@ -572,14 +580,6 @@
(add-hook 'slime-mode-hook 'slime-setup-command-hooks)
(add-hook 'slime-mode-hook 'slime-buffer-package)
-(add-hook 'inferior-lisp-mode-hook
- (lambda ()
- (add-to-list
- (make-local-variable 'comint-output-filter-functions)
- (lambda (string)
- (unless (get-buffer-window (current-buffer) t)
- (display-buffer (current-buffer) t))
- (comint-postoutput-scroll-to-bottom string)))))
;;; Common utility functions and macros
@@ -3173,7 +3173,7 @@
(defvar slime-complete-saved-window-configuration nil
"Window configuration before we show the *Completions* buffer.\n\
This is buffer local in the buffer where the complition is
-perfermed.")
+performed.")
(defun slime-complete-maybe-save-window-configuration ()
(make-local-variable 'slime-complete-saved-window-configuration)
@@ -3615,6 +3615,53 @@
(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))))
+ (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string)
+ (slime-buffer-package t)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-unprofile-all ()
+ "Unprofile all functions."
+ (interactive)
+ (slime-eval-async '(swank:unprofile-all) (slime-buffer-package t)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profile-report ()
+ "Print profile report."
+ (interactive)
+ (slime-eval-with-transcript '(swank:profile-report) nil))
+
+(defun slime-profile-reset ()
+ "Reset profile counters."
+ (interactive)
+ (slime-eval-async (slime-eval `(swank:profile-reset)) nil
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profiled-functions ()
+ "Return list of names of currently profiled functions."
+ (interactive)
+ (slime-eval-async `(swank:profiled-functions) nil
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profile-package (package callers methods)
+ "Profile all functions in PACKAGE.
+If CALLER is non-nil names have counts of the most common calling
+functions recorded.
+If METHODS is non-nil, profile all methods of all generic function
+having names in the given package."
+ (interactive (list (slime-read-package-name "Package: ")
+ (y-or-n-p "Record the most common callers? ")
+ (y-or-n-p "Profile methods? ")))
+ (slime-eval-async `(swank:profile-package ,package ,callers ,methods) nil
+ (lambda (r) (message "%s" r))))
+
+
+
;;; Documentation
(defun slime-hyperspec-lookup (symbol-name)
@@ -4133,6 +4180,8 @@
("\M-p" 'sldb-details-up)
("l" 'sldb-list-locals)
("t" 'sldb-toggle-details)
+ ("r" 'sldb-restart-frame)
+ ("R" 'sldb-return-from-frame)
("c" 'sldb-continue)
("s" 'sldb-step)
("a" 'sldb-abort)
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.109 slime/swank.lisp:1.110
--- slime/swank.lisp:1.109 Thu Jan 22 19:20:39 2004
+++ slime/swank.lisp Thu Jan 29 03:37:57 2004
@@ -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
Index: slime/swank-backend.lisp
diff -u slime/swank-backend.lisp:1.22 slime/swank-backend.lisp:1.23
--- slime/swank-backend.lisp:1.22 Wed Jan 21 19:35:17 2004
+++ slime/swank-backend.lisp Thu Jan 29 03:37:57 2004
@@ -77,6 +77,13 @@
#:throw-to-toplevel
#:toggle-trace-fdefinition
#:untrace-all
+ #:profile
+ #:unprofile
+ #:unprofile-all
+ #:profiled-functions
+ #:profile-report
+ #:profile-reset
+ #:profile-package
#:wait-goahead
#:warn-unimplemented-interfaces
#:who-binds
@@ -392,6 +399,43 @@
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.")
+
+(definterface profile-package (package callers-p methods)
+ "Wrap profiling code around all functions in PACKAGE. If a function
+is already profiled, then unprofile and reprofile (useful to notice
+function redefinition.)
+
+If CALLERS-P is T names have counts of the most common calling
+functions recorded.
+
+When called with arguments :METHODS T, profile all methods of all
+generic functions having names in the given package. Generic functions
+themselves, that is, their dispatch functions, are left alone.")
+
+
;;;; Queries
#+(or)
@@ -489,6 +533,7 @@
(definterface make-lock (&key name)
"Make a lock for thread synchronization.
Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."
+ (declare (ignore name))
:null-lock)
(definterface call-with-lock-held (lock function)
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.56 slime/swank-sbcl.lisp:1.57
--- slime/swank-sbcl.lisp:1.56 Fri Jan 23 16:03:11 2004
+++ slime/swank-sbcl.lisp Thu Jan 29 03:37:57 2004
@@ -536,6 +536,30 @@
(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: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.57 slime/swank-cmucl.lisp:1.58
--- slime/swank-cmucl.lisp:1.57 Wed Jan 21 19:38:48 2004
+++ slime/swank-cmucl.lisp Thu Jan 29 03:37:57 2004
@@ -819,6 +819,15 @@
(with-output-to-string (*standard-output*)
(c::print-all-blocks (expand-ir1-top-level (from-string form)))))
+(defslimefun print-compilation-trace (form)
+ (with-output-to-string (*standard-output*)
+ (with-input-from-string (s form)
+ (let ((*package* *buffer-package*))
+ (ext:compile-from-stream s
+ :verbose t
+ :progress t
+ :trace-stream *standard-output*)))))
+
(defslimefun set-default-directory (directory)
(setf (ext:default-directory) (namestring directory))
;; Setting *default-pathname-defaults* to an absolute directory
@@ -1036,34 +1045,116 @@
(error "Cannot continue in from condition: ~A"
*swank-debugger-condition*))))
+(defun frame-cfp (frame)
+ "Return the Control-Stack-Frame-Pointer for FRAME."
+ (etypecase frame
+ (di::compiled-frame (di::frame-pointer frame))
+ ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+ "Return the (absolute) instruction pointer and the relative pc of FRAME."
+ (if (not frame)
+ -1
+ (let ((debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((code-loc (di:frame-code-location frame))
+ (component (di::compiled-debug-function-component debug-fun))
+ (pc (di::compiled-code-location-pc code-loc))
+ (ip (sys:without-gcing
+ (sys:sap-int
+ (sys:sap+ (kernel:code-instructions component) pc)))))
+ (values ip pc)))
+ ((or di::bogus-debug-function di::interpreted-debug-function)
+ -1)))))
+
+(defun frame-registers (frame)
+ "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+ (let* ((cfp (frame-cfp frame))
+ (csp (frame-cfp (di::frame-up frame)))
+ (ip (frame-ip frame))
+ (ocfp (frame-cfp (di::frame-down frame)))
+ (lra (frame-ip (di::frame-down frame))))
+ (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+ (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+ (flet ((fixnum (p) (etypecase p
+ (integer p)
+ (sys:system-area-pointer (sys:sap-int p)))))
+ (apply #'format t "~
+CSP = ~X
+CFP = ~X
+IP = ~X
+OCFP = ~X
+LRA = ~X~%" (mapcar #'fixnum
+ (multiple-value-list (frame-registers frame)))))))
+
(defslimefun sldb-disassemble (frame-number)
"Return a string with the disassembly of frames code."
- ;; this could need some refactoring.
- (let* ((frame (nth-frame frame-number))
- (real-frame (di::frame-real-frame frame))
- (frame-pointer (di::frame-pointer real-frame))
- (debug-fun (di:frame-debug-function real-frame)))
(with-output-to-string (*standard-output*)
- (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
- frame (eq frame real-frame) real-frame frame-pointer)
- (etypecase debug-fun
- (di::compiled-debug-function
- (let* ((code-loc (di:frame-code-location frame))
- (component (di::compiled-debug-function-component debug-fun))
- (pc (di::compiled-code-location-pc code-loc))
- (ip (sys:sap-int
- (sys:sap+ (kernel:code-instructions component) pc)))
- (kind (if (di:code-location-unknown-p code-loc)
- :unkown
- (di:code-location-kind code-loc)))
- (fun (di:debug-function-function debug-fun)))
- (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
- ip pc kind)
- (if fun
- (disassemble fun)
- (disassem:disassemble-code-component component))))
- (di::bogus-debug-function
- (format t "~%[Disassembling bogus frames not implemented]"))))))
+ (print-frame-registers frame-number)
+ (terpri)
+ (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+ (debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((component (di::compiled-debug-function-component debug-fun))
+ (fun (di:debug-function-function debug-fun)))
+ (if fun
+ (disassemble fun)
+ (disassem:disassemble-code-component component))))
+ (di::bogus-debug-function
+ (format t "~%[Disassembling bogus frames not implemented]"))))))
+
+
+#+(or)
+(defun print-binding-stack ()
+ (do ((bsp (kernel:binding-stack-pointer-sap)
+ (sys:sap+ bsp (- (* vm:binding-size vm:word-bytes))))
+ (start (sys:int-sap (lisp::binding-stack-start))))
+ ((sys:sap<= bsp start))
+ (format t "~X: ~S = ~S~%"
+ (sys:sap-int bsp)
+ (kernel:make-lisp-obj
+ (sys:sap-ref-32 bsp (* vm:binding-symbol-slot vm:word-bytes)))
+ (kernel:make-lisp-obj
+ (sys:sap-ref-32 bsp (* vm:binding-value-slot vm:word-bytes))))))
+
+;; (print-binding-stack)
+
+#+(or)
+(defun print-catch-blocks ()
+ (do ((b (di::descriptor-sap lisp::*current-catch-block*)
+ (sys:sap-ref-sap b (* vm:catch-block-previous-catch-slot
+ vm:word-bytes))))
+ (nil)
+ (let ((int (sys:sap-int b)))
+ (when (zerop int) (return))
+ (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
+ (let ((uwp (ref vm:catch-block-current-uwp-slot))
+ (cfp (ref vm:catch-block-current-cont-slot))
+ (tag (ref vm:catch-block-tag-slot))
+ )
+ (format t "~X: uwp = ~8X cfp = ~8X tag = ~X~%"
+ int uwp cfp (kernel:make-lisp-obj tag)))))))
+
+;; (print-catch-blocks)
+
+#+(or)
+(defun print-unwind-blocks ()
+ (do ((b (di::descriptor-sap lisp::*current-unwind-protect-block*)
+ (sys:sap-ref-sap b (* vm:unwind-block-current-uwp-slot
+ vm:word-bytes))))
+ (nil)
+ (let ((int (sys:sap-int b)))
+ (when (zerop int) (return))
+ (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
+ (let ((cfp (ref vm:unwind-block-current-cont-slot)))
+ (format t "~X: cfp = ~X~%" int cfp))))))
+
+;; (print-unwind-blocks)
+
;;;; Inspecting
@@ -1160,6 +1251,33 @@
(values (format nil "~A~% is a fdefn object." o)
`(("Name" . ,(kernel:fdefn-name o))
("Function" . ,(kernel:fdefn-function o)))))
+
+
+;;;; Profiling
+(defimplementation profile (fname)
+ (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+ (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report-time))
+
+(defimplementation profile-reset ()
+ (profile:reset-time)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+ (profile:profile-all :package package
+ :callers-p callers
+ :methods methods))
;;;; Multiprocessing
More information about the slime-cvs
mailing list