;;; -*- Mode: Emacs-Lisp -*- ;;;; Superior Lisp Interaction Mode for Emacs ;;;; Statistical Profiling Interface ;;; Copyright (C) 2005, 2006 Juho Snellman ;;; Copyright (C) 2006 Taylor Campbell ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;;; SOFTWARE. (defvar slime-sprofile-graph nil "Graph of statistical profiling results. Dynamically bound to a value returned from Lisp in order to initialize the profile browser buffer.") (define-derived-mode slime-sprofile-browser-mode fundamental-mode "slprof" "Major mode for browsing statistical profiler data. \\ \\{slime-compiler-notes-mode-map}" (setq buffer-read-only t) (let ((inhibit-read-only t)) (erase-buffer) (insert (format "%4s %-54s %6s %6s %6s\n" "Rank" "Name" "Self%" "Cumul%" "Total%")) (dolist (data slime-sprofile-graph) (slime-sprofile-browser-insert-line data 54))) (goto-line 2)) (slime-define-keys slime-sprofile-browser-mode-map ("q" 'slime-temp-buffer-quit) ("d" 'slime-sprofile-browser-disassemble-function) ("g" 'slime-sprofile-browser-go-to) ("v" 'slime-sprofile-browser-view-source) ((kbd "RET") 'slime-sprofile-browser-toggle)) ;; Start / stop profiling (defun slime-sprofile-start () (interactive) (slime-eval `(swank:swank-sprofile-start))) (defun slime-sprofile-stop () (interactive) (slime-eval `(swank:swank-sprofile-stop))) ;; Reporting (defun slime-sprofile-browser () (interactive) (lexical-let ((buffer (slime-sprofile-browser-get-buffer))) (slime-eval-async `(swank:swank-sprofile-get-call-graph) (lambda (graph) (let ((slime-sprofile-graph graph)) (with-current-buffer buffer (switch-to-buffer buffer) (slime-sprofile-browser-mode))))))) (defun slime-sprofile-browser-get-buffer () (get-buffer-create "*slime-sprofile-browser*")) (defun slime-sprofile-browser-insert-line (data name-length) (destructuring-bind (index name self cumul total) data (if index (insert (format "%-4d " index)) (insert " ")) (slime-insert-propertized (slime-sprofile-browser-name-properties) (format (format "%%-%ds " name-length) (slime-sprofile-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-sprofile-browser-add-line-text-properties `(profile-index ,index expanded nil))) (insert "\n"))) (defun slime-sprofile-abbreviate-name (name max-length) (lexical-let ((length (min (length name) max-length))) (subseq name 0 length))) ;; Expanding / collapsing (defun slime-sprofile-browser-toggle () (interactive) (let ((index (get-text-property (point) 'profile-index))) (when index (save-excursion (if (slime-sprofile-browser-line-expanded-p) (slime-sprofile-browser-collapse) (slime-sprofile-browser-expand)))))) (defun slime-sprofile-browser-collapse () (let ((inhibit-read-only t)) (slime-sprofile-browser-add-line-text-properties '(expanded nil)) (forward-line) (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-sprofile-browser-expand () (lexical-let* ((buffer (current-buffer)) (point (point)) (index (get-text-property point 'profile-index))) (slime-eval-async `(swank:swank-sprofile-expand-node ,index) (lambda (data) (with-current-buffer buffer (save-excursion (destructuring-bind (&key callers calls) data (slime-sprofile-browser-add-expansion callers "Callers" 0) (slime-sprofile-browser-add-expansion calls "Calls" 0)))))))) (defun slime-sprofile-browser-add-expansion (data type nesting) (when data (let ((inhibit-read-only t)) (slime-sprofile-browser-add-line-text-properties '(expanded t)) (end-of-line) (insert (format "\n %s" type)) (dolist (node data) (destructuring-bind (index name cumul) node (insert (format (format "\n%%%ds" (+ 7 (* 2 nesting))) "")) (slime-insert-propertized (slime-sprofile-browser-name-properties) (let ((len (- 59 (* 2 nesting)))) (format (format "%%-%ds " len) (slime-sprofile-abbreviate-name name len)))) (slime-sprofile-browser-add-line-text-properties `(profile-sub-index ,index)) (insert (format "%6.2f" cumul))))))) (defun slime-sprofile-browser-line-expanded-p () (get-text-property (point) 'expanded)) (defun slime-sprofile-browser-add-line-text-properties (properties) (add-text-properties (point-at-bol) (point-at-eol) properties)) (defun slime-sprofile-browser-name-properties () '(face sldb-restart-number-face)) ;; "Go to function" (defun slime-sprofile-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-sprofile-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-sprofile-disassemble ,index))))) ;; View source (defun slime-sprofile-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-sprofile-source-location ,index) (lambda (source-location) (destructure-case source-location ((:error message) (message "%s" message) (ding)) (t (slime-show-source-location source-location)))))))) (provide 'slime-sprof) ;;; Local Variables: ;;; Eval: (put 'slime-eval-async 'lisp-indent-hook 1) ;;; End: