1 files changed, 154 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-sprof.lisp b/vim/bundle/slimv/slime/contrib/swank-sprof.lisp
new file mode 100644
index 0000000..675240f
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-sprof.lisp
@@ -0,0 +1,154 @@
+;;; swank-sprof.lisp
+;;
+;; Authors: Juho Snellman
+;;
+;; License: MIT
+;;
+
+(in-package :swank)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :sb-sprof))
+
+#+sbcl(progn
+
+(defvar *call-graph* nil)
+(defvar *node-numbers* nil)
+(defvar *number-nodes* nil)
+
+(defun frame-name (name)
+  (if (consp name)
+      (case (first name)
+        ((sb-c::xep sb-c::tl-xep
+                    sb-c::&more-processor
+                    sb-c::top-level-form
+                    sb-c::&optional-processor)
+         (second name))
+        (sb-pcl::fast-method
+         (cdr name))
+        ((flet labels lambda)
+         (let* ((in (member :in name)))
+           (if (stringp (cadr in))
+               (append (ldiff name in) (cddr in))
+               name)))
+        (t
+         name))
+      name))
+
+(defun pretty-name (name)
+  (let ((*package* (find-package :common-lisp-user))
+        (*print-right-margin* most-positive-fixnum))
+    (format nil "~S" (frame-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 filter-swank-nodes (nodes)
+  (let ((swank-packages (load-time-value
+                         (mapcar #'find-package
+                                 '(swank swank/rpc swank/mop
+                                   swank/match swank/backend)))))
+    (remove-if (lambda (node)
+                 (let ((name (sb-sprof::node-name node)))
+                   (and (symbolp name)
+                        (member (symbol-package name) swank-packages
+                                :test #'eq))))
+               nodes)))
+
+(defun serialize-call-graph (&key exclude-swank)
+  (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*)))
+    (when exclude-swank
+      (setf nodes (filter-swank-nodes nodes)))
+    (setf nodes (sort (copy-list nodes) #'>
+                      ;; :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 (&key exclude-swank)
+  (when (setf *call-graph* (sb-sprof:report :type nil))
+    (serialize-call-graph :exclude-swank exclude-swank)))
+
+(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 (loop for node in
+                           (sort (copy-list (sb-sprof::node-callers node)) #'>
+                                 :key #'caller-count)
+                           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 (&key (mode :cpu))
+  (sb-sprof:start-profiling :mode mode))
+
+(defslimefun swank-sprof-stop ()
+  (sb-sprof:stop-profiling))
+
+)
+
+(provide :swank-sprof)