You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
224 lines
7.5 KiB
224 lines
7.5 KiB
(require 'slime)
|
|
(require 'cl-lib)
|
|
(eval-when-compile (require 'cl)) ; lexical-let*
|
|
|
|
(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 ()
|
|
(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)
|
|
(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)
|