dotemacs

sly-profiler.el (5482B)

---

 ;;; -*- coding: utf-8; lexical-binding: t -*-
 ;;;
 ;;; sly-profiler.el -- a navigable dialog of inspectable timing entries
 ;;;
 (eval-and-compile
   (require 'sly)
   (require 'sly-parse "lib/sly-parse"))
 
 (define-sly-contrib sly-profiler
   "Provide an interfactive timing dialog buffer for managing and
 inspecting details of timing functions. Invoke this dialog with C-c Y."
   (:authors "João Távora <joaotavora@gmail.com>")
   (:license "GPL")
   (:slynk-dependencies slynk/profiler)
   (:on-load (add-hook 'sly-mode-hook 'sly-profiler-enable))
   (:on-unload (remove-hook 'sly-mode-hook 'sly-profiler-enable)))
 
 
 ;;;; Modes and mode maps
 ;;;
 (defvar sly-profiler-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "G") 'sly-profiler-fetch-timings)
     (define-key map (kbd "C-k") 'sly-profiler-clear-fetched-timings)
     (define-key map (kbd "g") 'sly-profiler-fetch-status)
     (define-key map (kbd "q") 'quit-window)
     map))
 
 (define-derived-mode sly-profiler-mode fundamental-mode
   "SLY Timing Dialog" "Mode for controlling SLY's Timing Dialog"
   (set-syntax-table lisp-mode-syntax-table)
   (read-only-mode 1))
 
 (defvar sly-profiler-shortcut-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "C-c Y") 'sly-profiler)
     (define-key map (kbd "C-c C-y") 'sly-profiler-toggle-timing)
     map))
 
 (define-minor-mode sly-profiler-shortcut-mode
   "Add keybindings for accessing SLY's Profiler.")
 
 (defun sly-profiler-enable () (sly-profiler-shortcut-mode 1))
 
 
 ;;;; Helpers
 ;;;
 (defun sly-profiler--get-buffer ()
   (let* ((name (format "*profiler for %s*"
                        (sly-connection-name sly-default-connection)))
          (existing (get-buffer name)))
     (cond ((and existing
                 (buffer-live-p existing)
                 (with-current-buffer existing
                   (memq sly-buffer-connection sly-net-processes)))
            existing)
           (t
            (if existing (kill-buffer existing))
            (with-current-buffer (get-buffer-create name)
              (sly-profiler-mode)
              (setq sly-buffer-connection sly-default-connection)
              (pop-to-buffer (current-buffer)))))))
 
 (defun sly-profiler--clear-local-tree ()
   (erase-buffer)
   (insert "Cleared timings!"))
 
 (defun sly-profiler--render-timings (timing-specs)
   (let ((inhibit-read-only t))
     (erase-buffer)
     (let ((standard-output (current-buffer)))
       (cl-loop for spec in timing-specs
                do (princ spec) (terpri)))))
 
 ;;;; Interactive functions
 ;;;
 ;; (defun sly-profiler-fetch-specs ()
 ;;   "Refresh just list of timing specs."
 ;;   (interactive)
 ;;   (sly-eval-async `(slynk-profiler:report-specs)
 ;;     #'sly-profiler--open-specs))
 
 (defun sly-profiler-clear-fetched-timings (&optional interactive)
   "Clear local and remote timings collected so far"
   (interactive "p")
   (when (or (not interactive)
             (y-or-n-p "Clear all collected and fetched timings?"))
     (sly-eval-async
         '(slynk-profiler:clear-timing-tree)
       #'sly-profiler--clear-local-tree)))
 
 (defun sly-profiler-fetch-timings ()
   (interactive)
   (sly-eval-async `(slynk-profiler:report-latest-timings)
     #'sly-profiler--render-timings))
 
 (defun sly-profiler-fetch-status ()
   (interactive)
   (sly-profiler-fetch-timings))
 
 (defun sly-profiler-toggle-timing (&optional using-context-p)
   "Toggle the dialog-timing of the spec at point.
 
 When USING-CONTEXT-P, attempt to decipher lambdas. methods and
 other complicated function specs."
   (interactive "P")
   ;; Notice the use of "spec strings" here as opposed to the
   ;; proper cons specs we use on the slynk side.
   ;;
   ;; Notice the conditional use of `sly-trace-query' found in
   ;; slynk-fancy-trace.el
   ;;
   (let* ((spec-string (if using-context-p
                           (sly-extract-context)
                         (sly-symbol-at-point)))
          (spec-string (read-from-minibuffer "(Un)time: " (format "%s" spec-string))))
     (message "%s" (sly-eval `(slynk-profiler:toggle-timing
                                 (slynk::from-string ,spec-string))))))
 
 (defun sly-profiler (&optional refresh)
   "Show timing dialog and refresh timing collection status.
 
 With optional CLEAR-AND-FETCH prefix arg, clear the current tree
 and fetch a first batch of timings."
   (interactive "P")
   (sly-with-popup-buffer ((sly-buffer-name :profiler :connection sly-default-connection)
                           :mode 'sly-profiler-mode
                           :select t)
     (when refresh (sly-profiler-fetch-timings))))
 
 
 ;;;; Menu
 ;;;
 (easy-menu-define sly-profiler--shortcut-menu nil
   "Menu setting traces from anywhere in SLY."
   (let* ((in-dialog '(eq major-mode 'sly-profiler-mode))
          (_dialog-live `(and ,in-dialog
                              (memq sly-buffer-connection sly-net-processes)))
          (connected '(sly-connected-p)))
     `("Profiling"
       ["(Un)Profile definition" sly-profiler-toggle-timing ,connected]
       ["Open Profiler Dialog" sly-profiler (and ,connected (not ,in-dialog))])))
 
 (easy-menu-add-item sly-menu nil sly-profiler--shortcut-menu "Documentation")
 
 (defvar sly-profiler--easy-menu
   (let ((condition '(memq sly-buffer-connection sly-net-processes)))
     `("Timing"
       [ "Clear fetched timings" sly-profiler-clear-fetched-timings ,condition]
       [ "Fetch timings" sly-profiler-fetch-timings ,condition])))
 
 (easy-menu-define my-menu sly-profiler-mode-map "Timing"
   sly-profiler--easy-menu)
 
 (provide 'sly-profiler)