;;;; -*- lexical-binding: t -*-
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-sprof
"Integration with SBCL's sb-sprof."
(:authors "Juho Snellman"
"Stas Boukarev")
(:license "MIT")
(:swank-dependencies swank-sprof)
(:on-load
(let ((C '(and (slime-connected-p)
(equal (slime-lisp-implementation-type) "SBCL"))))
(setf (cdr (last (assoc "Profiling" slime-easy-menu)))
`("--"
[ "Start sb-sprof" slime-sprof-start ,C ]
[ "Stop sb-sprof" slime-sprof-stop ,C ]
[ "Report sb-sprof" slime-sprof-report ,C ])))))
(defvar slime-sprof-exclude-swank nil
"*Display swank functions in the report.")
(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}"
:syntax-table lisp-mode-syntax-table
(setq buffer-read-only t))
(set-keymap-parent slime-sprof-browser-mode-map slime-parent-map)
(slime-define-keys slime-sprof-browser-mode-map
("h" 'describe-mode)
("d" 'slime-sprof-browser-disassemble-function)
("g" 'slime-sprof-browser-go-to)
("v" 'slime-sprof-browser-view-source)
("s" 'slime-sprof-toggle-swank-exclusion)
((kbd "RET") 'slime-sprof-browser-toggle))
;; Start / stop profiling
(cl-defun slime-sprof-start (&optional (mode :cpu))
(interactive)
(slime-eval `(swank:swank-sprof-start :mode ,mode)))
(defun slime-sprof-start-alloc ()
(interactive)
(slime-sprof-start :alloc))
(defun slime-sprof-start-time ()
(interactive)
(slime-sprof-start :time))
(defun slime-sprof-stop ()
(interactive)
(slime-eval `(swank:swank-sprof-stop)))
;; Reporting
(defun slime-sprof-format (graph)
(with-current-buffer (slime-buffer-name :sprof)
(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))))
(forward-line 2))
(cl-defun slime-sprof-update (&optional (exclude-swank slime-sprof-exclude-swank))
(slime-eval-async `(swank:swank-sprof-get-call-graph
:exclude-swank ,exclude-swank)
'slime-sprof-format))
(defalias 'slime-sprof-browser 'slime-sprof-report)
(defun slime-sprof-report ()
(interactive)
(slime-with-popup-buffer ((slime-buffer-name :sprof)
:connection t
:select t
:mode 'slime-sprof-browser-mode)
(slime-sprof-update)))
(defun slime-sprof-toggle-swank-exclusion ()
(interactive)
(setq slime-sprof-exclude-swank
(not slime-sprof-exclude-swank))
(slime-sprof-update))
(defun slime-sprof-browser-insert-line (data name-length)
(cl-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)
(slime-sprof-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 slime-sprof-abbreviate-name (name max-length)
(cl-subseq name 0 (min (length name) max-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)
(cl-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 ()
(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
(cl-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)
(cl-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)
(slime-sprof-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)
(slime-dcase source-location
((:error message)
(message "%s" message)
(ding))
(t
(slime-show-source-location source-location))))))))
(provide 'slime-sprof)