;;; profiler.el --- UI and helper functions for Emacs's native profiler -*- lexical-binding: t -*-
-;; Copyright (C) 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2012-2014 Free Software Foundation, Inc.
;; Author: Tomohiro Matsuyama <tomo@cx4a.org>
;; Keywords: lisp
-;; This program is free software; you can redistribute it and/or modify
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
-;;
+;; See Info node `(elisp)Profiling'.
;;; Code:
-(eval-when-compile
- (require 'cl-lib))
+(require 'cl-lib)
+(require 'pcase)
(defgroup profiler nil
"Emacs profiler."
:group 'lisp
+ :version "24.3"
:prefix "profiler-")
-\f
+(defconst profiler-version "24.3")
+(defcustom profiler-sampling-interval 1000000
+ "Default sampling interval in nanoseconds."
+ :type 'integer
+ :group 'profiler)
+
+\f
;;; Utilities
(defun profiler-ensure-string (object)
- (if (stringp object)
- object
- (format "%s" object)))
+ (cond ((stringp object)
+ object)
+ ((symbolp object)
+ (symbol-name object))
+ ((numberp object)
+ (number-to-string object))
+ (t
+ (format "%s" object))))
+
+(defun profiler-format-percent (number divisor)
+ (concat (number-to-string (/ (* number 100) divisor)) "%"))
+
+(defun profiler-format-number (number)
+ "Format NUMBER in human readable string."
+ (if (and (integerp number) (> number 0))
+ (cl-loop with i = (% (1+ (floor (log number 10))) 3)
+ for c in (append (number-to-string number) nil)
+ if (= i 0)
+ collect ?, into s
+ and do (setq i 3)
+ collect c into s
+ do (cl-decf i)
+ finally return
+ (apply 'string (if (eq (car s) ?,) (cdr s) s)))
+ (profiler-ensure-string number)))
(defun profiler-format (fmt &rest args)
(cl-loop for (width align subfmt) in fmt
for arg in args
- for str = (cl-typecase subfmt
- (cons (apply 'profiler-format subfmt arg))
- (string (format subfmt arg))
- (t (profiler-ensure-string arg)))
+ for str = (cond
+ ((consp subfmt)
+ (apply 'profiler-format subfmt arg))
+ ((stringp subfmt)
+ (format subfmt arg))
+ ((and (symbolp subfmt)
+ (fboundp subfmt))
+ (funcall subfmt arg))
+ (t
+ (profiler-ensure-string arg)))
for len = (length str)
if (< width len)
- collect (substring str 0 width) into frags
+ collect (progn (put-text-property (max 0 (- width 2)) len
+ 'invisible 'profiler str)
+ str) into frags
else
collect
- (let ((padding (make-string (- width len) ?\s)))
+ (let ((padding (make-string (max 0 (- width len)) ?\s)))
(cl-ecase align
(left (concat str padding))
(right (concat padding str))))
finally return (apply #'concat frags)))
\f
+;;; Entries
+
+(defun profiler-format-entry (entry)
+ "Format ENTRY in human readable string. ENTRY would be a
+function name of a function itself."
+ (cond ((memq (car-safe entry) '(closure lambda))
+ (format "#<lambda 0x%x>" (sxhash entry)))
+ ((byte-code-function-p entry)
+ (format "#<compiled 0x%x>" (sxhash entry)))
+ ((or (subrp entry) (symbolp entry) (stringp entry))
+ (format "%s" entry))
+ (t
+ (format "#<unknown 0x%x>" (sxhash entry)))))
+
+(defun profiler-fixup-entry (entry)
+ (if (symbolp entry)
+ entry
+ (profiler-format-entry entry)))
-;;; Slot data structure
+\f
+;;; Backtraces
-(cl-defstruct (profiler-slot (:type list)
- (:constructor profiler-make-slot))
- backtrace count elapsed)
+(defun profiler-fixup-backtrace (backtrace)
+ (apply 'vector (mapcar 'profiler-fixup-entry backtrace)))
\f
-
-;;; Log data structure
-
-(cl-defstruct (profiler-log (:type list)
- (:constructor profiler-make-log))
- type diff-p timestamp slots)
-
-(defun profiler-log-diff (log1 log2)
- ;; FIXME zeros
- (unless (eq (profiler-log-type log1)
- (profiler-log-type log2))
- (error "Can't compare different type of logs"))
- (let ((slots (profiler-log-slots log2)))
- (dolist (slot (profiler-log-slots log1))
- (push (profiler-make-slot :backtrace (profiler-slot-backtrace slot)
- :count (- (profiler-slot-count slot))
- :elapsed (- (profiler-slot-elapsed slot)))
- slots))
- (profiler-make-log :type (profiler-log-type log1)
- :diff-p t
- :timestamp (current-time)
- :slots slots)))
-
-(defun profiler-log-fixup (log)
- "Fixup LOG so that the log could be serialized into file."
- (let ((fixup-entry
- (lambda (entry)
- (cond
- ((and (consp entry)
- (or (eq (car entry) 'lambda)
- (eq (car entry) 'closure)))
- (format "#<closure 0x%x>" (sxhash entry)))
- ((eq (type-of entry) 'compiled-function)
- (format "#<compiled 0x%x>" (sxhash entry)))
- ((subrp entry)
- (subr-name entry))
- ((symbolp entry)
- entry)
- (t
- (format "#<unknown 0x%x>" (sxhash entry)))))))
- (dolist (slot (profiler-log-slots log))
- (setf (profiler-slot-backtrace slot)
- (mapcar fixup-entry (profiler-slot-backtrace slot))))))
+;;; Logs
+
+;; The C code returns the log in the form of a hash-table where the keys are
+;; vectors (of size profiler-max-stack-depth, holding truncated
+;; backtraces, where the first element is the top of the stack) and
+;; the values are integers (which count how many times this backtrace
+;; has been seen, multiplied by a "weight factor" which is either the
+;; sampling-interval or the memory being allocated).
+
+(defun profiler-compare-logs (log1 log2)
+ "Compare LOG1 with LOG2 and return diff."
+ (let ((newlog (make-hash-table :test 'equal)))
+ ;; Make a copy of `log1' into `newlog'.
+ (maphash (lambda (backtrace count) (puthash backtrace count newlog))
+ log1)
+ (maphash (lambda (backtrace count)
+ (puthash backtrace (- (gethash backtrace log1 0) count)
+ newlog))
+ log2)
+ newlog))
+
+(defun profiler-fixup-log (log)
+ (let ((newlog (make-hash-table :test 'equal)))
+ (maphash (lambda (backtrace count)
+ (puthash (profiler-fixup-backtrace backtrace)
+ count newlog))
+ log)
+ newlog))
\f
+;;; Profiles
+
+(cl-defstruct (profiler-profile (:type vector)
+ (:constructor profiler-make-profile))
+ (tag 'profiler-profile)
+ (version profiler-version)
+ ;; - `type' has a value indicating the kind of profile (`memory' or `cpu').
+ ;; - `log' indicates the profile log.
+ ;; - `timestamp' has a value giving the time when the profile was obtained.
+ ;; - `diff-p' indicates if this profile represents a diff between two profiles.
+ type log timestamp diff-p)
+
+(defun profiler-compare-profiles (profile1 profile2)
+ "Compare PROFILE1 with PROFILE2 and return diff."
+ (unless (eq (profiler-profile-type profile1)
+ (profiler-profile-type profile2))
+ (error "Can't compare different type of profiles"))
+ (profiler-make-profile
+ :type (profiler-profile-type profile1)
+ :timestamp (current-time)
+ :diff-p t
+ :log (profiler-compare-logs
+ (profiler-profile-log profile1)
+ (profiler-profile-log profile2))))
+
+(defun profiler-fixup-profile (profile)
+ "Fixup PROFILE so that the profile could be serialized into file."
+ (profiler-make-profile
+ :type (profiler-profile-type profile)
+ :timestamp (profiler-profile-timestamp profile)
+ :diff-p (profiler-profile-diff-p profile)
+ :log (profiler-fixup-log (profiler-profile-log profile))))
+
+(defun profiler-write-profile (profile filename &optional confirm)
+ "Write PROFILE into file FILENAME."
+ (with-temp-buffer
+ (let (print-level print-length)
+ (print (profiler-fixup-profile profile)
+ (current-buffer)))
+ (write-file filename confirm)))
+
+(defun profiler-read-profile (filename)
+ "Read profile from file FILENAME."
+ ;; FIXME: tag and version check
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (read (current-buffer))))
+
+(defun profiler-running-p (&optional mode)
+ "Return non-nil if the profiler is running.
+Optional argument MODE means only check for the specified mode (cpu or mem)."
+ (cond ((eq mode 'cpu) (and (fboundp 'profiler-cpu-running-p)
+ (profiler-cpu-running-p)))
+ ((eq mode 'mem) (profiler-memory-running-p))
+ (t (or (profiler-running-p 'cpu)
+ (profiler-running-p 'mem)))))
+
+(defun profiler-cpu-profile ()
+ "Return CPU profile."
+ (when (profiler-running-p 'cpu)
+ (profiler-make-profile
+ :type 'cpu
+ :timestamp (current-time)
+ :log (profiler-cpu-log))))
+
+(defun profiler-memory-profile ()
+ "Return memory profile."
+ (when (profiler-memory-running-p)
+ (profiler-make-profile
+ :type 'memory
+ :timestamp (current-time)
+ :log (profiler-memory-log))))
-;;; Calltree data structure
+\f
+;;; Calltrees
(cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
entry
- (count 0) count-percent
- (elapsed 0) elapsed-percent
+ (count 0) (count-percent "")
parent children)
(defun profiler-calltree-leaf-p (tree)
(defun profiler-calltree-count> (a b)
(not (profiler-calltree-count< a b)))
-(defun profiler-calltree-elapsed< (a b)
- (cond ((eq (profiler-calltree-entry a) t) t)
- ((eq (profiler-calltree-entry b) t) nil)
- (t (< (profiler-calltree-elapsed a)
- (profiler-calltree-elapsed b)))))
-
-(defun profiler-calltree-elapsed> (a b)
- (not (profiler-calltree-elapsed< a b)))
-
(defun profiler-calltree-depth (tree)
- (let ((parent (profiler-calltree-parent tree)))
- (if (null parent)
- 0
- (1+ (profiler-calltree-depth parent)))))
+ (let ((d 0))
+ (while (setq tree (profiler-calltree-parent tree))
+ (cl-incf d))
+ d))
(defun profiler-calltree-find (tree entry)
- (cl-dolist (child (profiler-calltree-children tree))
- (when (equal (profiler-calltree-entry child) entry)
- (cl-return child))))
+ "Return a child tree of ENTRY under TREE."
+ (let (result (children (profiler-calltree-children tree)))
+ (while (and children (null result))
+ (let ((child (car children)))
+ (when (function-equal (profiler-calltree-entry child) entry)
+ (setq result child))
+ (setq children (cdr children))))
+ result))
(defun profiler-calltree-walk (calltree function)
(funcall function calltree)
(profiler-calltree-walk child function)))
(defun profiler-calltree-build-1 (tree log &optional reverse)
- (dolist (slot (profiler-log-slots log))
- (let ((backtrace (profiler-slot-backtrace slot))
- (count (profiler-slot-count slot))
- (elapsed (profiler-slot-elapsed slot))
- (node tree))
- (dolist (entry (if reverse backtrace (reverse backtrace)))
- (let ((child (profiler-calltree-find node entry)))
- (unless child
- (setq child (profiler-make-calltree :entry entry :parent node))
- (push child (profiler-calltree-children node)))
- (cl-incf (profiler-calltree-count child) count)
- (cl-incf (profiler-calltree-elapsed child) elapsed)
- (setq node child))))))
+ ;; This doesn't try to stitch up partial backtraces together.
+ ;; We still use it for reverse calltrees, but for forward calltrees, we use
+ ;; profiler-calltree-build-unified instead now.
+ (maphash
+ (lambda (backtrace count)
+ (let ((node tree)
+ (max (length backtrace)))
+ (dotimes (i max)
+ (let ((entry (aref backtrace (if reverse i (- max i 1)))))
+ (when entry
+ (let ((child (profiler-calltree-find node entry)))
+ (unless child
+ (setq child (profiler-make-calltree
+ :entry entry :parent node))
+ (push child (profiler-calltree-children node)))
+ (cl-incf (profiler-calltree-count child) count)
+ (setq node child)))))))
+ log))
+
+
+(define-hash-table-test 'profiler-function-equal #'function-equal
+ (lambda (f) (cond
+ ((byte-code-function-p f) (aref f 1))
+ ((eq (car-safe f) 'closure) (cddr f))
+ (t f))))
+
+(defun profiler-calltree-build-unified (tree log)
+ ;; Let's try to unify all those partial backtraces into a single
+ ;; call tree. First, we record in fun-map all the functions that appear
+ ;; in `log' and where they appear.
+ (let ((fun-map (make-hash-table :test 'profiler-function-equal))
+ (parent-map (make-hash-table :test 'eq))
+ (leftover-tree (profiler-make-calltree
+ :entry (intern "...") :parent tree)))
+ (push leftover-tree (profiler-calltree-children tree))
+ (maphash
+ (lambda (backtrace _count)
+ (let ((max (length backtrace)))
+ ;; Don't record the head elements in there, since we want to use this
+ ;; fun-map to find parents of partial backtraces, but parents only
+ ;; make sense if they have something "above".
+ (dotimes (i (1- max))
+ (let ((f (aref backtrace i)))
+ (when f
+ (push (cons i backtrace) (gethash f fun-map)))))))
+ log)
+ ;; Then, for each partial backtrace, try to find a parent backtrace
+ ;; (i.e. a backtrace that describes (part of) the truncated part of
+ ;; the partial backtrace). For a partial backtrace like "[f3 f2 f1]" (f3
+ ;; is deeper), any backtrace that includes f1 could be a parent; and indeed
+ ;; the counts of this partial backtrace could each come from a different
+ ;; parent backtrace (some of which may not even be in `log'). So we should
+ ;; consider each backtrace that includes f1 and give it some percentage of
+ ;; `count'. But we can't know for sure what percentage to give to each
+ ;; possible parent.
+ ;; The "right" way might be to give a percentage proportional to the counts
+ ;; already registered for that parent, or some such statistical principle.
+ ;; But instead, we will give all our counts to a single "best
+ ;; matching" parent. So let's look for the best matching parent, and store
+ ;; the result in parent-map.
+ ;; Using the "best matching parent" is important also to try and avoid
+ ;; stitching together backtraces that can't possibly go together.
+ ;; For example, when the head is `apply' (or `mapcar', ...), we want to
+ ;; make sure we don't just use any parent that calls `apply', since most of
+ ;; them would never, in turn, cause apply to call the subsequent function.
+ (maphash
+ (lambda (backtrace _count)
+ (let* ((max (1- (length backtrace)))
+ (head (aref backtrace max))
+ (best-parent nil)
+ (best-match (1+ max))
+ (parents (gethash head fun-map)))
+ (pcase-dolist (`(,i . ,parent) parents)
+ (when t ;; (<= (- max i) best-match) ;Else, it can't be better.
+ (let ((match max)
+ (imatch i))
+ (cl-assert (>= match imatch))
+ (cl-assert (function-equal (aref backtrace max)
+ (aref parent i)))
+ (while (progn
+ (cl-decf imatch) (cl-decf match)
+ (when (> imatch 0)
+ (function-equal (aref backtrace match)
+ (aref parent imatch)))))
+ (when (< match best-match)
+ (cl-assert (<= (- max i) best-match))
+ ;; Let's make sure this parent is not already our child: we
+ ;; don't want cycles here!
+ (let ((valid t)
+ (tmp-parent parent))
+ (while (setq tmp-parent
+ (if (eq tmp-parent backtrace)
+ (setq valid nil)
+ (cdr (gethash tmp-parent parent-map)))))
+ (when valid
+ (setq best-match match)
+ (setq best-parent (cons i parent))))))))
+ (puthash backtrace best-parent parent-map)))
+ log)
+ ;; Now we have a single parent per backtrace, so we have a unified tree.
+ ;; Let's build the actual call-tree from it.
+ (maphash
+ (lambda (backtrace count)
+ (let ((node tree)
+ (parents (list (cons -1 backtrace)))
+ (tmp backtrace)
+ (max (length backtrace)))
+ (while (setq tmp (gethash tmp parent-map))
+ (push tmp parents)
+ (setq tmp (cdr tmp)))
+ (when (aref (cdar parents) (1- max))
+ (cl-incf (profiler-calltree-count leftover-tree) count)
+ (setq node leftover-tree))
+ (pcase-dolist (`(,i . ,parent) parents)
+ (let ((j (1- max)))
+ (while (> j i)
+ (let ((f (aref parent j)))
+ (cl-decf j)
+ (when f
+ (let ((child (profiler-calltree-find node f)))
+ (unless child
+ (setq child (profiler-make-calltree
+ :entry f :parent node))
+ (push child (profiler-calltree-children node)))
+ (cl-incf (profiler-calltree-count child) count)
+ (setq node child)))))))))
+ log)))
(defun profiler-calltree-compute-percentages (tree)
- (let ((total-count 0)
- (total-elapsed 0))
+ (let ((total-count 0))
+ ;; FIXME: the memory profiler's total wraps around all too easily!
(dolist (child (profiler-calltree-children tree))
- (cl-incf total-count (profiler-calltree-count child))
- (cl-incf total-elapsed (profiler-calltree-elapsed child)))
- (profiler-calltree-walk
- tree (lambda (node)
- (unless (zerop total-count)
- (setf (profiler-calltree-count-percent node)
- (format "%s%%"
- (/ (* (profiler-calltree-count node) 100)
- total-count))))
- (unless (zerop total-elapsed)
- (setf (profiler-calltree-elapsed-percent node)
- (format "%s%%"
- (/ (* (profiler-calltree-elapsed node) 100)
- total-elapsed))))))))
+ (cl-incf total-count (profiler-calltree-count child)))
+ (unless (zerop total-count)
+ (profiler-calltree-walk
+ tree (lambda (node)
+ (setf (profiler-calltree-count-percent node)
+ (profiler-format-percent (profiler-calltree-count node)
+ total-count)))))))
(cl-defun profiler-calltree-build (log &key reverse)
(let ((tree (profiler-make-calltree)))
- (profiler-calltree-build-1 tree log reverse)
+ (if reverse
+ (profiler-calltree-build-1 tree log reverse)
+ (profiler-calltree-build-unified tree log))
(profiler-calltree-compute-percentages tree)
tree))
(profiler-calltree-sort child predicate))))
\f
-
;;; Report rendering
(defcustom profiler-report-closed-mark "+"
:type 'string
:group 'profiler)
-(defvar profiler-report-sample-line-format
- '((60 left)
- (14 right ((9 right)
+(defvar profiler-report-cpu-line-format
+ '((50 left)
+ (24 right ((19 right)
(5 right)))))
(defvar profiler-report-memory-line-format
- '((60 left)
- (14 right ((9 right)
+ '((55 left)
+ (19 right ((14 right profiler-format-number)
(5 right)))))
-(defvar profiler-report-log nil)
-(defvar profiler-report-reversed nil)
-(defvar profiler-report-order nil)
+(defvar-local profiler-report-profile nil
+ "The current profile.")
+
+(defvar-local profiler-report-reversed nil
+ "True if calltree is rendered in bottom-up. Do not touch this
+variable directly.")
+
+(defvar-local profiler-report-order nil
+ "The value can be `ascending' or `descending'. Do not touch
+this variable directly.")
(defun profiler-report-make-entry-part (entry)
- (let ((string
- (cond
- ((eq entry t)
- "Others")
- ((and (symbolp entry)
- (fboundp entry))
- (propertize (symbol-name entry)
- 'face 'link
- 'mouse-face 'highlight
- 'help-echo "mouse-2 or RET jumps to definition"))
- (t
- (profiler-ensure-string entry)))))
- (propertize string 'entry entry)))
+ (let ((string (cond
+ ((eq entry t)
+ "Others")
+ ((and (symbolp entry)
+ (fboundp entry))
+ (propertize (symbol-name entry)
+ 'face 'link
+ 'mouse-face 'highlight
+ 'help-echo "\
+mouse-2: jump to definition\n\
+RET: expand or collapse"))
+ (t
+ (profiler-format-entry entry)))))
+ (propertize string 'profiler-entry entry)))
(defun profiler-report-make-name-part (tree)
(let* ((entry (profiler-calltree-entry tree))
(depth (profiler-calltree-depth tree))
- (indent (make-string (* (1- depth) 2) ?\s))
+ (indent (make-string (* (1- depth) 1) ?\s))
(mark (if (profiler-calltree-leaf-p tree)
profiler-report-leaf-mark
profiler-report-closed-mark))
(format "%s%s %s" indent mark entry)))
(defun profiler-report-header-line-format (fmt &rest args)
- (let* ((header (apply 'profiler-format fmt args))
+ (let* ((header (apply #'profiler-format fmt args))
(escaped (replace-regexp-in-string "%" "%%" header)))
(concat " " escaped)))
(defun profiler-report-line-format (tree)
- (let ((diff-p (profiler-log-diff-p profiler-report-log))
+ (let ((diff-p (profiler-profile-diff-p profiler-report-profile))
(name-part (profiler-report-make-name-part tree))
- (elapsed (profiler-calltree-elapsed tree))
- (elapsed-percent (profiler-calltree-elapsed-percent tree))
(count (profiler-calltree-count tree))
(count-percent (profiler-calltree-count-percent tree)))
- (cl-ecase (profiler-log-type profiler-report-log)
- (sample
- (if diff-p
- (profiler-format profiler-report-sample-line-format
- name-part
- (list (if (> elapsed 0)
- (format "+%s" elapsed)
- elapsed)
- ""))
- (profiler-format profiler-report-sample-line-format
- name-part (list elapsed elapsed-percent))))
- (memory
- (if diff-p
- (profiler-format profiler-report-memory-line-format
- name-part
- (list (if (> count 0)
- (format "+%s" count)
- count)
- ""))
- (profiler-format profiler-report-memory-line-format
- name-part (list count count-percent)))))))
+ (profiler-format (cl-ecase (profiler-profile-type profiler-report-profile)
+ (cpu profiler-report-cpu-line-format)
+ (memory profiler-report-memory-line-format))
+ name-part
+ (if diff-p
+ (list (if (> count 0)
+ (format "+%s" count)
+ count)
+ "")
+ (list count count-percent)))))
(defun profiler-report-insert-calltree (tree)
(let ((line (profiler-report-line-format tree)))
(insert (propertize (concat line "\n") 'calltree tree))))
(defun profiler-report-insert-calltree-children (tree)
- (mapc 'profiler-report-insert-calltree
+ (mapc #'profiler-report-insert-calltree
(profiler-calltree-children tree)))
\f
-
;;; Report mode
(defvar profiler-report-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "n" 'profiler-report-next-entry)
(define-key map "p" 'profiler-report-previous-entry)
- (define-key map [down] 'profiler-report-next-entry)
- (define-key map [up] 'profiler-report-previous-entry)
+ ;; I find it annoying more than helpful to not be able to navigate
+ ;; normally with the cursor keys. --Stef
+ ;; (define-key map [down] 'profiler-report-next-entry)
+ ;; (define-key map [up] 'profiler-report-previous-entry)
(define-key map "\r" 'profiler-report-toggle-entry)
(define-key map "\t" 'profiler-report-toggle-entry)
(define-key map "i" 'profiler-report-toggle-entry)
(define-key map "B" 'profiler-report-render-reversed-calltree)
(define-key map "A" 'profiler-report-ascending-sort)
(define-key map "D" 'profiler-report-descending-sort)
- (define-key map "=" 'profiler-report-compare-log)
- (define-key map (kbd "C-x C-w") 'profiler-report-write-log)
- (define-key map "q" 'quit-window)
- map))
-
-(defun profiler-report-make-buffer-name (log)
- (let ((time (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log))))
- (cl-ecase (profiler-log-type log)
- (sample (format "*CPU-Profiler-Report %s*" time))
- (memory (format "*Memory-Profiler-Report %s*" time)))))
-
-(defun profiler-report-setup-buffer (log)
- (let* ((buf-name (profiler-report-make-buffer-name log))
+ (define-key map "=" 'profiler-report-compare-profile)
+ (define-key map (kbd "C-x C-w") 'profiler-report-write-profile)
+ (easy-menu-define profiler-report-menu map "Menu for Profiler Report mode."
+ '("Profiler"
+ ["Next Entry" profiler-report-next-entry :active t
+ :help "Move to next entry"]
+ ["Previous Entry" profiler-report-previous-entry :active t
+ :help "Move to previous entry"]
+ "--"
+ ["Toggle Entry" profiler-report-toggle-entry
+ :active (profiler-report-calltree-at-point)
+ :help "Expand or collapse the current entry"]
+ ["Find Entry" profiler-report-find-entry
+ ;; FIXME should deactivate if not on a known function.
+ :active (profiler-report-calltree-at-point)
+ :help "Find the definition of the current entry"]
+ ["Describe Entry" profiler-report-describe-entry
+ :active (profiler-report-calltree-at-point)
+ :help "Show the documentation of the current entry"]
+ "--"
+ ["Show Calltree" profiler-report-render-calltree
+ :active profiler-report-reversed
+ :help "Show calltree view"]
+ ["Show Reversed Calltree" profiler-report-render-reversed-calltree
+ :active (not profiler-report-reversed)
+ :help "Show reversed calltree view"]
+ ["Sort Ascending" profiler-report-ascending-sort
+ :active (not (eq profiler-report-order 'ascending))
+ :help "Sort calltree view in ascending order"]
+ ["Sort Descending" profiler-report-descending-sort
+ :active (not (eq profiler-report-order 'descending))
+ :help "Sort calltree view in descending order"]
+ "--"
+ ["Compare Profile..." profiler-report-compare-profile :active t
+ :help "Compare current profile with another"]
+ ["Write Profile..." profiler-report-write-profile :active t
+ :help "Write current profile to a file"]
+ "--"
+ ["Start Profiler" profiler-start :active (not (profiler-running-p))
+ :help "Start profiling"]
+ ["Stop Profiler" profiler-stop :active (profiler-running-p)
+ :help "Stop profiling"]
+ ["New Report" profiler-report :active (profiler-running-p)
+ :help "Make a new report"]))
+ map)
+ "Keymap for `profiler-report-mode'.")
+
+(defun profiler-report-make-buffer-name (profile)
+ (format "*%s-Profiler-Report %s*"
+ (cl-ecase (profiler-profile-type profile) (cpu 'CPU) (memory 'Memory))
+ (format-time-string "%Y-%m-%d %T" (profiler-profile-timestamp profile))))
+
+(defun profiler-report-setup-buffer-1 (profile)
+ "Make a buffer for PROFILE and return it."
+ (let* ((buf-name (profiler-report-make-buffer-name profile))
(buffer (get-buffer-create buf-name)))
(with-current-buffer buffer
(profiler-report-mode)
- (setq profiler-report-log log
+ (setq profiler-report-profile profile
profiler-report-reversed nil
profiler-report-order 'descending))
buffer))
+(defun profiler-report-setup-buffer (profile)
+ "Make a buffer for PROFILE with rendering the profile and
+return it."
+ (let ((buffer (profiler-report-setup-buffer-1 profile)))
+ (with-current-buffer buffer
+ (profiler-report-render-calltree))
+ buffer))
+
(define-derived-mode profiler-report-mode special-mode "Profiler-Report"
"Profiler Report Mode."
- (make-local-variable 'profiler-report-log)
- (make-local-variable 'profiler-report-reversed)
- (make-local-variable 'profiler-report-order)
- (use-local-map profiler-report-mode-map)
+ (add-to-invisibility-spec '(profiler . t))
(setq buffer-read-only t
buffer-undo-list t
truncate-lines t))
\f
-
;;; Report commands
-(defun profiler-report-calltree-at-point ()
- (get-text-property (point) 'calltree))
+(defun profiler-report-calltree-at-point (&optional point)
+ (get-text-property (or point (point)) 'calltree))
(defun profiler-report-move-to-entry ()
- (let ((point (next-single-property-change (line-beginning-position) 'entry)))
+ (let ((point (next-single-property-change
+ (line-beginning-position) 'profiler-entry)))
(if point
(goto-char point)
(back-to-indentation))))
(defun profiler-report-next-entry ()
- "Move cursor to next profile entry."
+ "Move cursor to next entry."
(interactive)
(forward-line)
(profiler-report-move-to-entry))
(defun profiler-report-previous-entry ()
- "Move cursor to previous profile entry."
+ "Move cursor to previous entry."
(interactive)
(forward-line -1)
(profiler-report-move-to-entry))
-(defun profiler-report-expand-entry ()
- "Expand profile entry at point."
- (interactive)
+(defun profiler-report-expand-entry (&optional full)
+ "Expand entry at point.
+With a prefix argument, expand the whole subtree."
+ (interactive "P")
(save-excursion
(beginning-of-line)
(when (search-forward (concat profiler-report-closed-mark " ")
(line-end-position) t)
(let ((tree (profiler-report-calltree-at-point)))
(when tree
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(replace-match (concat profiler-report-open-mark " "))
(forward-line)
- (profiler-report-insert-calltree-children tree)
+ (let ((first (point))
+ (last (copy-marker (point) t)))
+ (profiler-report-insert-calltree-children tree)
+ (when full
+ (goto-char first)
+ (while (< (point) last)
+ (profiler-report-expand-entry)
+ (forward-line 1))))
t))))))
(defun profiler-report-collapse-entry ()
- "Collpase profile entry at point."
+ "Collapse entry at point."
(interactive)
(save-excursion
(beginning-of-line)
(start (line-beginning-position 2))
d)
(when tree
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(replace-match (concat profiler-report-closed-mark " "))
(while (and (eq (forward-line) 0)
(let ((child (get-text-property (point) 'calltree)))
(delete-region start (line-beginning-position)))))
t)))
-(defun profiler-report-toggle-entry ()
- "Expand profile entry at point if the tree is collapsed,
-otherwise collapse the entry."
- (interactive)
- (or (profiler-report-expand-entry)
+(defun profiler-report-toggle-entry (&optional arg)
+ "Expand entry at point if the tree is collapsed,
+otherwise collapse."
+ (interactive "P")
+ (or (profiler-report-expand-entry arg)
(profiler-report-collapse-entry)))
(defun profiler-report-find-entry (&optional event)
- "Find profile entry at point."
+ "Find entry at point."
(interactive (list last-nonmenu-event))
- (if event (posn-set-point (event-end event)))
- (let ((tree (profiler-report-calltree-at-point)))
- (when tree
- (let ((entry (profiler-calltree-entry tree)))
- (find-function entry)))))
+ (with-current-buffer
+ (if event (window-buffer (posn-window (event-start event)))
+ (current-buffer))
+ (and event (setq event (event-end event))
+ (posn-set-point event))
+ (let ((tree (profiler-report-calltree-at-point)))
+ (when tree
+ (let ((entry (profiler-calltree-entry tree)))
+ (find-function entry))))))
(defun profiler-report-describe-entry ()
- "Describe profile entry at point."
+ "Describe entry at point."
(interactive)
(let ((tree (profiler-report-calltree-at-point)))
(when tree
(require 'help-fns)
(describe-function entry)))))
-(cl-defun profiler-report-render-calltree-1 (log &key reverse (order 'descending))
- (let ((calltree (profiler-calltree-build profiler-report-log
- :reverse reverse)))
- (cl-ecase (profiler-log-type log)
- (sample
- (setq header-line-format
+(cl-defun profiler-report-render-calltree-1
+ (profile &key reverse (order 'descending))
+ (let ((calltree (profiler-calltree-build
+ (profiler-profile-log profile)
+ :reverse reverse)))
+ (setq header-line-format
+ (cl-ecase (profiler-profile-type profile)
+ (cpu
(profiler-report-header-line-format
- profiler-report-sample-line-format
- "Function" (list "Time (ms)" "%")))
- (let ((predicate (cl-ecase order
- (ascending 'profiler-calltree-elapsed<)
- (descending 'profiler-calltree-elapsed>))))
- (profiler-calltree-sort calltree predicate)))
- (memory
- (setq header-line-format
+ profiler-report-cpu-line-format
+ "Function" (list "CPU samples" "%")))
+ (memory
(profiler-report-header-line-format
profiler-report-memory-line-format
- "Function" (list "Alloc" "%")))
- (let ((predicate (cl-ecase order
- (ascending 'profiler-calltree-count<)
- (descending 'profiler-calltree-count>))))
- (profiler-calltree-sort calltree predicate))))
- (let ((buffer-read-only nil))
+ "Function" (list "Bytes" "%")))))
+ (let ((predicate (cl-ecase order
+ (ascending #'profiler-calltree-count<)
+ (descending #'profiler-calltree-count>))))
+ (profiler-calltree-sort calltree predicate))
+ (let ((inhibit-read-only t))
(erase-buffer)
(profiler-report-insert-calltree-children calltree)
(goto-char (point-min))
(profiler-report-move-to-entry))))
(defun profiler-report-rerender-calltree ()
- (profiler-report-render-calltree-1 profiler-report-log
+ (profiler-report-render-calltree-1 profiler-report-profile
:reverse profiler-report-reversed
:order profiler-report-order))
(defun profiler-report-render-calltree ()
- "Render calltree view of the current profile."
+ "Render calltree view."
(interactive)
(setq profiler-report-reversed nil)
(profiler-report-rerender-calltree))
(defun profiler-report-render-reversed-calltree ()
- "Render reversed calltree view of the current profile."
+ "Render reversed calltree view."
(interactive)
(setq profiler-report-reversed t)
(profiler-report-rerender-calltree))
(setq profiler-report-order 'descending)
(profiler-report-rerender-calltree))
-(defun profiler-report-log (log)
- (let ((buffer (profiler-report-setup-buffer log)))
- (with-current-buffer buffer
- (profiler-report-render-calltree))
- (pop-to-buffer buffer)))
+(defun profiler-report-profile (profile)
+ (switch-to-buffer (profiler-report-setup-buffer profile)))
+
+(defun profiler-report-profile-other-window (profile)
+ (switch-to-buffer-other-window (profiler-report-setup-buffer profile)))
-(defun profiler-report-compare-log (buffer)
- "Compare current profiler log with another profiler log."
+(defun profiler-report-profile-other-frame (profile)
+ (switch-to-buffer-other-frame (profiler-report-setup-buffer profile)))
+
+(defun profiler-report-compare-profile (buffer)
+ "Compare the current profile with another."
(interactive (list (read-buffer "Compare to: ")))
- (let ((log1 (with-current-buffer buffer profiler-report-log))
- (log2 profiler-report-log))
- (profiler-report-log (profiler-log-diff log1 log2))))
+ (let* ((profile1 (with-current-buffer buffer profiler-report-profile))
+ (profile2 profiler-report-profile)
+ (diff-profile (profiler-compare-profiles profile1 profile2)))
+ (profiler-report-profile diff-profile)))
-(defun profiler-report-write-log (filename &optional confirm)
- "Write current profiler log into FILENAME."
+(defun profiler-report-write-profile (filename &optional confirm)
+ "Write the current profile into file FILENAME."
(interactive
- (list (read-file-name "Write log: " default-directory)
+ (list (read-file-name "Write profile: " default-directory)
(not current-prefix-arg)))
- (let ((log profiler-report-log))
- (with-temp-buffer
- (let (print-level print-length)
- (print log (current-buffer)))
- (write-file filename confirm))))
+ (profiler-write-profile profiler-report-profile
+ filename
+ confirm))
\f
-
;;; Profiler commands
-(defcustom profiler-sample-interval 10
- "Default sample interval in millisecond."
- :type 'integer
- :group 'profiler)
-
;;;###autoload
(defun profiler-start (mode)
+ "Start/restart profilers.
+MODE can be one of `cpu', `mem', or `cpu+mem'.
+If MODE is `cpu' or `cpu+mem', time-based profiler will be started.
+Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started."
(interactive
- (list (intern (completing-read "Mode: " '("cpu" "mem" "cpu+mem")
- nil t nil nil "cpu"))))
+ (list (if (not (fboundp 'profiler-cpu-start)) 'mem
+ (intern (completing-read "Mode (default cpu): "
+ '("cpu" "mem" "cpu+mem")
+ nil t nil nil "cpu")))))
(cl-ecase mode
(cpu
- (sample-profiler-start profiler-sample-interval)
+ (profiler-cpu-start profiler-sampling-interval)
(message "CPU profiler started"))
(mem
- (memory-profiler-start)
+ (profiler-memory-start)
(message "Memory profiler started"))
(cpu+mem
- (sample-profiler-start profiler-sample-interval)
- (memory-profiler-start)
+ (profiler-cpu-start profiler-sampling-interval)
+ (profiler-memory-start)
(message "CPU and memory profiler started"))))
(defun profiler-stop ()
+ "Stop started profilers. Profiler logs will be kept."
(interactive)
- (cond
- ((and (sample-profiler-running-p)
- (memory-profiler-running-p))
- (sample-profiler-stop)
- (memory-profiler-stop)
- (message "CPU and memory profiler stopped"))
- ((sample-profiler-running-p)
- (sample-profiler-stop)
- (message "CPU profiler stopped"))
- ((memory-profiler-running-p)
- (memory-profiler-stop)
- (message "Memory profiler stopped"))
- (t
- (error "No profilers started"))))
+ (let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop)))
+ (mem (profiler-memory-stop)))
+ (message "%s profiler stopped"
+ (cond ((and mem cpu) "CPU and memory")
+ (mem "Memory")
+ (cpu "CPU")
+ (t "No")))))
(defun profiler-reset ()
+ "Reset profiler logs."
(interactive)
- (sample-profiler-reset)
- (memory-profiler-reset)
+ (when (fboundp 'profiler-cpu-log)
+ (ignore (profiler-cpu-log)))
+ (ignore (profiler-memory-log))
t)
-(defun sample-profiler-report ()
- (let ((sample-log (sample-profiler-log)))
- (when sample-log
- (profiler-log-fixup sample-log)
- (profiler-report-log sample-log))))
+(defun profiler-report-cpu ()
+ (let ((profile (profiler-cpu-profile)))
+ (when profile
+ (profiler-report-profile-other-window profile))))
-(defun memory-profiler-report ()
- (let ((memory-log (memory-profiler-log)))
- (when memory-log
- (profiler-log-fixup memory-log)
- (profiler-report-log memory-log))))
+(defun profiler-report-memory ()
+ (let ((profile (profiler-memory-profile)))
+ (when profile
+ (profiler-report-profile-other-window profile))))
(defun profiler-report ()
+ "Report profiling results."
(interactive)
- (sample-profiler-report)
- (memory-profiler-report))
+ (profiler-report-cpu)
+ (profiler-report-memory))
;;;###autoload
-(defun profiler-find-log (filename)
+(defun profiler-find-profile (filename)
+ "Open profile FILENAME."
(interactive
- (list (read-file-name "Find log: " default-directory)))
- (with-temp-buffer
- (insert-file-contents filename)
- (goto-char (point-min))
- (let ((log (read (current-buffer))))
- (profiler-report-log log))))
+ (list (read-file-name "Find profile: " default-directory)))
+ (profiler-report-profile (profiler-read-profile filename)))
-\f
+;;;###autoload
+(defun profiler-find-profile-other-window (filename)
+ "Open profile FILENAME."
+ (interactive
+ (list (read-file-name "Find profile: " default-directory)))
+ (profiler-report-profile-other-window (profiler-read-profile filename)))
+
+;;;###autoload
+(defun profiler-find-profile-other-frame (filename)
+ "Open profile FILENAME."
+ (interactive
+ (list (read-file-name "Find profile: " default-directory)))
+ (profiler-report-profile-other-frame(profiler-read-profile filename)))
+\f
;;; Profiling helpers
-(cl-defmacro with-sample-profiling ((&key (interval profiler-sample-interval)) &rest body)
- `(progn
- (sample-profiler-start ,interval)
- (sample-profiler-reset)
- (unwind-protect
- (progn ,@body)
- (sample-profiler-stop)
- (sample-profiler-report)
- (sample-profiler-reset))))
-
-(cl-defmacro with-memory-profiling (() &rest body)
- `(progn
- (memory-profiler-start)
- (memory-profiler-reset)
- (unwind-protect
- (progn ,@body)
- (memory-profiler-stop)
- (memory-profiler-report)
- (memory-profiler-reset))))
+;; (cl-defmacro with-cpu-profiling ((&key sampling-interval) &rest body)
+;; `(unwind-protect
+;; (progn
+;; (ignore (profiler-cpu-log))
+;; (profiler-cpu-start ,sampling-interval)
+;; ,@body)
+;; (profiler-cpu-stop)
+;; (profiler--report-cpu)))
+
+;; (defmacro with-memory-profiling (&rest body)
+;; `(unwind-protect
+;; (progn
+;; (ignore (profiler-memory-log))
+;; (profiler-memory-start)
+;; ,@body)
+;; (profiler-memory-stop)
+;; (profiler--report-memory)))
(provide 'profiler)
;;; profiler.el ends here