[slime-cvs] CVS slime/contrib
CVS User sboukarev
sboukarev at common-lisp.net
Mon Sep 21 19:08:29 UTC 2009
Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv27356/contrib
Modified Files:
ChangeLog
Added Files:
slime-sprof.el swank-sprof.lisp
Log Message:
* contrib/{slime-sprof.el, swank-sprof.lisp}: New contrib for
integration with SBCL's sb-sprof profiler,
adopted from Juho Snellman's code.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/09/17 14:56:22 1.246
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/09/21 19:08:28 1.247
@@ -1,3 +1,9 @@
+2009-09-21 Stas Boukarev <stassats at gmail.com>
+
+ * slime-sprof.el, swank-sprof.lisp: New contrib for
+ integration with SBCL's sb-sprof profiler,
+ adopted from Juho Snellman's code.
+
2009-09-17 Stas Boukarev <stassats at gmail.com>
* slime-repl.el (slime-repl-clear-buffer): Don't change cursor
--- /project/slime/cvsroot/slime/contrib/slime-sprof.el 2009/09/21 19:08:29 NONE
+++ /project/slime/cvsroot/slime/contrib/slime-sprof.el 2009/09/21 19:08:29 1.1
;;; slime-sprof.el --- Integration with SBCL's sb-sprof
;;;
;;; Authors: Juho Snellman
;;;
;;; License: MIT
;;;
;;; Installation
;;
;; Add this to your .emacs:
;;
;; (slime-setup '(... slime-sprof))
(slime-require :swank-sprof)
(define-derived-mode slime-sprof-browser-mode fundamental-mode
"slprof"
"Mode for browsing profiler data\
\\<slime-sprof-browser-mode-map>\
\\{slime-sprof-browser-mode-map}"
(setq buffer-read-only t)
(let ((inhibit-read-only t))
(erase-buffer)
(insert (format "%4s %-54s %6s %6s %6s\n"
"Rank"
"Name"
"Self%"
"Cumul%"
"Total%"))
(dolist (data graph)
(slime-sprof-browser-insert-line data 54)))
(goto-line 2))
(slime-define-keys slime-sprof-browser-mode-map
("h" 'describe-mode)
("q" 'bury-buffer)
("d" 'slime-sprof-browser-disassemble-function)
("g" 'slime-sprof-browser-go-to)
("v" 'slime-sprof-browser-view-source)
((kbd "RET") 'slime-sprof-browser-toggle))
;; Start / stop profiling
(defun slime-sprof-start ()
(interactive)
(slime-eval `(swank:swank-sprof-start)))
(defun slime-sprof-stop ()
(interactive)
(slime-eval `(swank:swank-sprof-stop)))
;; Reporting
(defun slime-sprof-browser ()
(interactive)
(lexical-let ((buffer (slime-sprof-browser-get-buffer)))
(slime-eval-async `(swank:swank-sprof-get-call-graph)
(lambda (graph)
(with-current-buffer buffer
(switch-to-buffer buffer)
(slime-sprof-browser-mode))))))
(defun slime-sprof-browser-get-buffer ()
(get-buffer-create "*slime-sprof-browser*"))
(defun slime-sprof-browser-insert-line (data name-length)
(destructuring-bind (index name self cumul total)
data
(if index
(insert (format "%-4d " index))
(insert " "))
(slime-insert-propertized
(slime-sprof-browser-name-properties)
(format (format "%%-%ds " name-length)
(abbreviate-name name name-length)))
(insert (format "%6.2f " self))
(when cumul
(insert (format "%6.2f " cumul))
(when total
(insert (format "%6.2f" total))))
(when index
(slime-sprof-browser-add-line-text-properties
`(profile-index ,index expanded nil)))
(insert "\n")))
(defun abbreviate-name (name max-length)
(lexical-let ((length (min (length name) max-length)))
(subseq name 0 length)))
;; Expanding / collapsing
(defun slime-sprof-browser-toggle ()
(interactive)
(let ((index (get-text-property (point) 'profile-index)))
(when index
(save-excursion
(if (slime-sprof-browser-line-expanded-p)
(slime-sprof-browser-collapse)
(slime-sprof-browser-expand))))))
(defun slime-sprof-browser-collapse ()
(let ((inhibit-read-only t))
(slime-sprof-browser-add-line-text-properties '(expanded nil))
(forward-line)
(loop until (or (eobp)
(get-text-property (point) 'profile-index))
do
(delete-region (point-at-bol) (point-at-eol))
(unless (eobp)
(delete-char 1)))))
(defun slime-sprof-browser-expand ()
(lexical-let* ((buffer (current-buffer))
(point (point))
(index (get-text-property point 'profile-index)))
(slime-eval-async `(swank:swank-sprof-expand-node ,index)
(lambda (data)
(with-current-buffer buffer
(save-excursion
(destructuring-bind (&key callers calls)
data
(slime-sprof-browser-add-expansion callers
"Callers"
0)
(slime-sprof-browser-add-expansion calls
"Calls"
0))))))))
(defun slime-sprof-browser-add-expansion (data type nesting)
(when data
(let ((inhibit-read-only t))
(slime-sprof-browser-add-line-text-properties '(expanded t))
(end-of-line)
(insert (format "\n %s" type))
(dolist (node data)
(destructuring-bind (index name cumul) node
(insert (format (format "\n%%%ds" (+ 7 (* 2 nesting))) ""))
(slime-insert-propertized
(slime-sprof-browser-name-properties)
(let ((len (- 59 (* 2 nesting))))
(format (format "%%-%ds " len)
(abbreviate-name name len))))
(slime-sprof-browser-add-line-text-properties
`(profile-sub-index ,index))
(insert (format "%6.2f" cumul)))))))
(defun slime-sprof-browser-line-expanded-p ()
(get-text-property (point) 'expanded))
(defun slime-sprof-browser-add-line-text-properties (properties)
(add-text-properties (point-at-bol)
(point-at-eol)
properties))
(defun slime-sprof-browser-name-properties ()
'(face sldb-restart-number-face))
;; "Go to function"
(defun slime-sprof-browser-go-to ()
(interactive)
(let ((sub-index (get-text-property (point) 'profile-sub-index)))
(when sub-index
(let ((pos (text-property-any
(point-min) (point-max) 'profile-index sub-index)))
(when pos (goto-char pos))))))
;; Disassembly
(defun slime-sprof-browser-disassemble-function ()
(interactive)
(let ((index (or (get-text-property (point) 'profile-index)
(get-text-property (point) 'profile-sub-index))))
(when index
(slime-eval-describe `(swank:swank-sprof-disassemble
,index)))))
;; View source
(defun slime-sprof-browser-view-source ()
(interactive)
(let ((index (or (get-text-property (point) 'profile-index)
(get-text-property (point) 'profile-sub-index))))
(when index
(slime-eval-async
`(swank:swank-sprof-source-location ,index)
(lambda (source-location)
(destructure-case source-location
((:error message)
(message "%s" message)
(ding))
(t
(slime-show-source-location source-location))))))))
(provide 'slime-sprof)
--- /project/slime/cvsroot/slime/contrib/swank-sprof.lisp 2009/09/21 19:08:29 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-sprof.lisp 2009/09/21 19:08:29 1.1
;;; swank-sprof.lisp
;;
;; Authors: Juho Snellman
;;
;; License: MIT
;;
(in-package :swank)
#+sbcl(progn
#.(prog1 nil (require :sb-sprof))
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sb-sprof))
(defvar *call-graph* nil)
(defvar *node-numbers* nil)
(defvar *number-nodes* nil)
(defun pretty-name (name)
(let ((*package* (find-package :common-lisp-user))
(*print-right-margin* most-positive-fixnum))
(format nil "~S" (if (consp name)
(let ((head (car name)))
(if (or (eq head 'sb-c::tl-xep)
(eq head 'sb-c::hairy-arg-processor)
(eq head 'sb-c::top-level-form)
(eq head 'sb-c::xep))
(cadr name)
name))
name))))
(defun samples-percent (count)
(sb-sprof::samples-percent *call-graph* count))
(defun node-values (node)
(values (pretty-name (sb-sprof::node-name node))
(samples-percent (sb-sprof::node-count node))
(samples-percent (sb-sprof::node-accrued-count node))))
(defun serialize-call-graph ()
(let ((nodes (sort (copy-list
(sb-sprof::call-graph-flat-nodes *call-graph*))
#'>
;; :key #'sb-sprof::node-count)))
:key #'sb-sprof::node-accrued-count)))
(setf *number-nodes* (make-hash-table))
(setf *node-numbers* (make-hash-table))
(loop for node in nodes
for i from 1
with total = 0
collect (multiple-value-bind (name self cumulative)
(node-values node)
(setf (gethash node *node-numbers*) i
(gethash i *number-nodes*) node)
(incf total self)
(list i name self cumulative total)) into list
finally (return
(let ((rest (- 100 total)))
(return (append list
`((nil "Elsewhere" ,rest nil nil)))))))))
(defslimefun swank-sprof-get-call-graph ()
(setf *call-graph* (sb-sprof:report :type nil))
(serialize-call-graph))
(defslimefun swank-sprof-expand-node (index)
(let* ((node (gethash index *number-nodes*)))
(labels ((caller-count (v)
(loop for e in (sb-sprof::vertex-edges v) do
(when (eq (sb-sprof::edge-vertex e) node)
(return-from caller-count (sb-sprof::call-count e))))
0)
(serialize-node (node count)
(etypecase node
(sb-sprof::cycle
(list (sb-sprof::cycle-index node)
(sb-sprof::cycle-name node)
(samples-percent count)))
(sb-sprof::node
(let ((name (node-values node)))
(list (gethash node *node-numbers*)
name
(samples-percent count)))))))
(list :callers (let ((edges (sort (copy-list (sb-sprof::node-callers node))
#'>
:key #'caller-count)))
(loop for node in edges
collect (serialize-node node
(caller-count node))))
:calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node))
#'>
:key #'sb-sprof::call-count)))
(loop for edge in edges
collect
(serialize-node (sb-sprof::edge-vertex edge)
(sb-sprof::call-count edge))))))))
(defslimefun swank-sprof-disassemble (index)
(let* ((node (gethash index *number-nodes*))
(debug-info (sb-sprof::node-debug-info node)))
(with-output-to-string (s)
(typecase debug-info
(sb-impl::code-component
(sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info)
(sb-vm::%code-code-size debug-info)
:stream s))
(sb-di::compiled-debug-fun
(let ((component (sb-di::compiled-debug-fun-component debug-info)))
(sb-disassem::disassemble-code-component component :stream s)))
(t `(:error "No disassembly available"))))))
(defslimefun swank-sprof-source-location (index)
(let* ((node (gethash index *number-nodes*))
(debug-info (sb-sprof::node-debug-info node)))
(or (when (typep debug-info 'sb-di::compiled-debug-fun)
(let* ((component (sb-di::compiled-debug-fun-component debug-info))
(function (sb-kernel::%code-entry-points component)))
(when function
(find-source-location function))))
`(:error "No source location available"))))
(defslimefun swank-sprof-start ()
(sb-sprof:start-profiling))
(defslimefun swank-sprof-stop ()
(sb-sprof:stop-profiling))
)
(provide :swank-sprof)
More information about the slime-cvs
mailing list