dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/contrib/slime-sprof.el

(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)