lisp/profiler.el

   1 ;;; profiler.el --- UI and helper functions for Emacs's native profiler -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomohiro Matsuyama <tomo@cx4a.org>
   6 ;; Keywords: lisp
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; See Info node `(elisp)Profiling'.
  26
  27 ;;; Code:
  28
  29 (require 'cl-lib)
  30
  31 (defgroup profiler nil
  32   "Emacs profiler."
  33   :group 'lisp
  34   :version "24.3"
  35   :prefix "profiler-")
  36
  37 (defconst profiler-version "24.3")
  38
  39 (defcustom profiler-sampling-interval 1000000
  40   "Default sampling interval in nanoseconds."
  41   :type 'integer
  42   :group 'profiler)
  43
  44 \f
  45 ;;; Utilities
  46
  47 (defun profiler-ensure-string (object)
  48   (cond ((stringp object)
  49          object)
  50         ((symbolp object)
  51          (symbol-name object))
  52         ((numberp object)
  53          (number-to-string object))
  54         (t
  55          (format "%s" object))))
  56
  57 (defun profiler-format-percent (number divisor)
  58   (format "%d%%" (floor (* 100.0 number) divisor)))
  59
  60 (defun profiler-format-number (number)
  61   "Format NUMBER in human readable string."
  62   (if (and (integerp number) (> number 0))
  63       (cl-loop with i = (% (1+ (floor (log number 10))) 3)
  64                for c in (append (number-to-string number) nil)
  65                if (= i 0)
  66                collect ?, into s
  67                and do (setq i 3)
  68                collect c into s
  69                do (cl-decf i)
  70                finally return
  71                (apply 'string (if (eq (car s) ?,) (cdr s) s)))
  72     (profiler-ensure-string number)))
  73
  74 (defun profiler-format (fmt &rest args)
  75   (cl-loop for (width align subfmt) in fmt
  76            for arg in args
  77            for str = (cond
  78                       ((consp subfmt)
  79                        (apply 'profiler-format subfmt arg))
  80                       ((stringp subfmt)
  81                        (format subfmt arg))
  82                       ((and (symbolp subfmt)
  83                             (fboundp subfmt))
  84                        (funcall subfmt arg))
  85                       (t
  86                        (profiler-ensure-string arg)))
  87            for len = (length str)
  88            if (< width len)
  89            collect (progn (put-text-property (max 0 (- width 2)) len
  90                                              'invisible 'profiler str)
  91                           str) into frags
  92            else
  93            collect
  94            (let ((padding (make-string (max 0 (- width len)) ?\s)))
  95              (cl-ecase align
  96                (left (concat str padding))
  97                (right (concat padding str))))
  98            into frags
  99            finally return (apply #'concat frags)))
 100
 101 \f
 102 ;;; Entries
 103
 104 (defun profiler-format-entry (entry)
 105   "Format ENTRY in human readable string.  ENTRY would be a
 106 function name of a function itself."
 107   (cond ((memq (car-safe entry) '(closure lambda))
 108          (format "#<lambda 0x%x>" (sxhash entry)))
 109         ((byte-code-function-p entry)
 110          (format "#<compiled 0x%x>" (sxhash entry)))
 111         ((or (subrp entry) (symbolp entry) (stringp entry))
 112          (format "%s" entry))
 113         (t
 114          (format "#<unknown 0x%x>" (sxhash entry)))))
 115
 116 (defun profiler-fixup-entry (entry)
 117   (if (symbolp entry)
 118       entry
 119     (profiler-format-entry entry)))
 120
 121 \f
 122 ;;; Backtraces
 123
 124 (defun profiler-fixup-backtrace (backtrace)
 125   (apply 'vector (mapcar 'profiler-fixup-entry backtrace)))
 126
 127 \f
 128 ;;; Logs
 129
 130 ;; The C code returns the log in the form of a hash-table where the keys are
 131 ;; vectors (of size profiler-max-stack-depth, holding truncated
 132 ;; backtraces, where the first element is the top of the stack) and
 133 ;; the values are integers (which count how many times this backtrace
 134 ;; has been seen, multiplied by a "weight factor" which is either the
 135 ;; sampling-interval or the memory being allocated).
 136
 137 (defun profiler-compare-logs (log1 log2)
 138   "Compare LOG1 with LOG2 and return diff."
 139   (let ((newlog (make-hash-table :test 'equal)))
 140     ;; Make a copy of `log1' into `newlog'.
 141     (maphash (lambda (backtrace count) (puthash backtrace count newlog))
 142              log1)
 143     (maphash (lambda (backtrace count)
 144                (puthash backtrace (- (gethash backtrace log1 0) count)
 145                         newlog))
 146              log2)
 147     newlog))
 148
 149 (defun profiler-fixup-log (log)
 150   (let ((newlog (make-hash-table :test 'equal)))
 151     (maphash (lambda (backtrace count)
 152                (puthash (profiler-fixup-backtrace backtrace)
 153                         count newlog))
 154              log)
 155     newlog))
 156
 157 \f
 158 ;;; Profiles
 159
 160 (cl-defstruct (profiler-profile (:type vector)
 161                                 (:constructor profiler-make-profile))
 162   (tag 'profiler-profile)
 163   (version profiler-version)
 164   ;; - `type' has a value indicating the kind of profile (`memory' or `cpu').
 165   ;; - `log' indicates the profile log.
 166   ;; - `timestamp' has a value giving the time when the profile was obtained.
 167   ;; - `diff-p' indicates if this profile represents a diff between two profiles.
 168   type log timestamp diff-p)
 169
 170 (defun profiler-compare-profiles (profile1 profile2)
 171   "Compare PROFILE1 with PROFILE2 and return diff."
 172   (unless (eq (profiler-profile-type profile1)
 173               (profiler-profile-type profile2))
 174     (error "Can't compare different type of profiles"))
 175   (profiler-make-profile
 176    :type (profiler-profile-type profile1)
 177    :timestamp (current-time)
 178    :diff-p t
 179    :log (profiler-compare-logs
 180          (profiler-profile-log profile1)
 181          (profiler-profile-log profile2))))
 182
 183 (defun profiler-fixup-profile (profile)
 184   "Fixup PROFILE so that the profile could be serialized into file."
 185   (profiler-make-profile
 186    :type (profiler-profile-type profile)
 187    :timestamp (profiler-profile-timestamp profile)
 188    :diff-p (profiler-profile-diff-p profile)
 189    :log (profiler-fixup-log (profiler-profile-log profile))))
 190
 191 (defun profiler-write-profile (profile filename &optional confirm)
 192   "Write PROFILE into file FILENAME."
 193   (with-temp-buffer
 194     (let (print-level print-length)
 195       (print (profiler-fixup-profile profile)
 196              (current-buffer)))
 197     (write-file filename confirm)))
 198
 199 (defun profiler-read-profile (filename)
 200   "Read profile from file FILENAME."
 201   ;; FIXME: tag and version check
 202   (with-temp-buffer
 203     (insert-file-contents filename)
 204     (goto-char (point-min))
 205     (read (current-buffer))))
 206
 207 (defun profiler-running-p (&optional mode)
 208   "Return non-nil if the profiler is running.
 209 Optional argument MODE means only check for the specified mode (cpu or mem)."
 210   (cond ((eq mode 'cpu) (and (fboundp 'profiler-cpu-running-p)
 211                              (profiler-cpu-running-p)))
 212         ((eq mode 'mem) (profiler-memory-running-p))
 213         (t (or (profiler-running-p 'cpu)
 214                (profiler-running-p 'mem)))))
 215
 216 (defun profiler-cpu-profile ()
 217   "Return CPU profile."
 218   (when (profiler-running-p 'cpu)
 219     (profiler-make-profile
 220      :type 'cpu
 221      :timestamp (current-time)
 222      :log (profiler-cpu-log))))
 223
 224 (defun profiler-memory-profile ()
 225   "Return memory profile."
 226   (when (profiler-memory-running-p)
 227     (profiler-make-profile
 228      :type 'memory
 229      :timestamp (current-time)
 230      :log (profiler-memory-log))))
 231
 232 \f
 233 ;;; Calltrees
 234
 235 (cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
 236   entry
 237   (count 0) (count-percent "")
 238   parent children)
 239
 240 (defun profiler-calltree-leaf-p (tree)
 241   (null (profiler-calltree-children tree)))
 242
 243 (defun profiler-calltree-count< (a b)
 244   (cond ((eq (profiler-calltree-entry a) t) t)
 245         ((eq (profiler-calltree-entry b) t) nil)
 246         (t (< (profiler-calltree-count a)
 247               (profiler-calltree-count b)))))
 248
 249 (defun profiler-calltree-count> (a b)
 250   (not (profiler-calltree-count< a b)))
 251
 252 (defun profiler-calltree-depth (tree)
 253   (let ((d 0))
 254     (while (setq tree (profiler-calltree-parent tree))
 255       (cl-incf d))
 256     d))
 257
 258 (defun profiler-calltree-find (tree entry)
 259   "Return a child tree of ENTRY under TREE."
 260   (let (result (children (profiler-calltree-children tree)))
 261     (while (and children (null result))
 262       (let ((child (car children)))
 263         (when (function-equal (profiler-calltree-entry child) entry)
 264           (setq result child))
 265         (setq children (cdr children))))
 266     result))
 267
 268 (defun profiler-calltree-walk (calltree function)
 269   (funcall function calltree)
 270   (dolist (child (profiler-calltree-children calltree))
 271     (profiler-calltree-walk child function)))
 272
 273 (defun profiler-calltree-build-1 (tree log &optional reverse)
 274   ;; This doesn't try to stitch up partial backtraces together.
 275   ;; We still use it for reverse calltrees, but for forward calltrees, we use
 276   ;; profiler-calltree-build-unified instead now.
 277   (maphash
 278    (lambda (backtrace count)
 279      (let ((node tree)
 280            (max (length backtrace)))
 281        (dotimes (i max)
 282          (let ((entry (aref backtrace (if reverse i (- max i 1)))))
 283            (when entry
 284              (let ((child (profiler-calltree-find node entry)))
 285                (unless child
 286                  (setq child (profiler-make-calltree
 287                               :entry entry :parent node))
 288                  (push child (profiler-calltree-children node)))
 289                (cl-incf (profiler-calltree-count child) count)
 290                (setq node child)))))))
 291    log))
 292
 293
 294 (define-hash-table-test 'profiler-function-equal #'function-equal
 295   (lambda (f) (cond
 296           ((byte-code-function-p f) (aref f 1))
 297           ((eq (car-safe f) 'closure) (cddr f))
 298           (t f))))
 299
 300 (defun profiler-calltree-build-unified (tree log)
 301   ;; Let's try to unify all those partial backtraces into a single
 302   ;; call tree.  First, we record in fun-map all the functions that appear
 303   ;; in `log' and where they appear.
 304   (let ((fun-map (make-hash-table :test 'profiler-function-equal))
 305         (parent-map (make-hash-table :test 'eq))
 306         (leftover-tree (profiler-make-calltree
 307                         :entry (intern "...") :parent tree)))
 308     (push leftover-tree (profiler-calltree-children tree))
 309     (maphash
 310      (lambda (backtrace _count)
 311        (let ((max (length backtrace)))
 312          ;; Don't record the head elements in there, since we want to use this
 313          ;; fun-map to find parents of partial backtraces, but parents only
 314          ;; make sense if they have something "above".
 315          (dotimes (i (1- max))
 316            (let ((f (aref backtrace i)))
 317              (when f
 318                (push (cons i backtrace) (gethash f fun-map)))))))
 319      log)
 320     ;; Then, for each partial backtrace, try to find a parent backtrace
 321     ;; (i.e. a backtrace that describes (part of) the truncated part of
 322     ;; the partial backtrace).  For a partial backtrace like "[f3 f2 f1]" (f3
 323     ;; is deeper), any backtrace that includes f1 could be a parent; and indeed
 324     ;; the counts of this partial backtrace could each come from a different
 325     ;; parent backtrace (some of which may not even be in `log').  So we should
 326     ;; consider each backtrace that includes f1 and give it some percentage of
 327     ;; `count'.  But we can't know for sure what percentage to give to each
 328     ;; possible parent.
 329     ;; The "right" way might be to give a percentage proportional to the counts
 330     ;; already registered for that parent, or some such statistical principle.
 331     ;; But instead, we will give all our counts to a single "best
 332     ;; matching" parent.  So let's look for the best matching parent, and store
 333     ;; the result in parent-map.
 334     ;; Using the "best matching parent" is important also to try and avoid
 335     ;; stitching together backtraces that can't possibly go together.
 336     ;; For example, when the head is `apply' (or `mapcar', ...), we want to
 337     ;; make sure we don't just use any parent that calls `apply', since most of
 338     ;; them would never, in turn, cause apply to call the subsequent function.
 339     (maphash
 340      (lambda (backtrace _count)
 341        (let* ((max (1- (length backtrace)))
 342               (head (aref backtrace max))
 343               (best-parent nil)
 344               (best-match (1+ max))
 345               (parents (gethash head fun-map)))
 346          (pcase-dolist (`(,i . ,parent) parents)
 347            (when t ;; (<= (- max i) best-match) ;Else, it can't be better.
 348              (let ((match max)
 349                    (imatch i))
 350                (cl-assert (>= match imatch))
 351                (cl-assert (function-equal (aref backtrace max)
 352                                           (aref parent i)))
 353                (while (progn
 354                         (cl-decf imatch) (cl-decf match)
 355                         (when (> imatch 0)
 356                           (function-equal (aref backtrace match)
 357                                           (aref parent imatch)))))
 358                (when (< match best-match)
 359                  (cl-assert (<= (- max i) best-match))
 360                  ;; Let's make sure this parent is not already our child: we
 361                  ;; don't want cycles here!
 362                  (let ((valid t)
 363                        (tmp-parent parent))
 364                    (while (setq tmp-parent
 365                                 (if (eq tmp-parent backtrace)
 366                                     (setq valid nil)
 367                                   (cdr (gethash tmp-parent parent-map)))))
 368                    (when valid
 369                      (setq best-match match)
 370                      (setq best-parent (cons i parent))))))))
 371          (puthash backtrace best-parent parent-map)))
 372      log)
 373     ;; Now we have a single parent per backtrace, so we have a unified tree.
 374     ;; Let's build the actual call-tree from it.
 375     (maphash
 376      (lambda (backtrace count)
 377        (let ((node tree)
 378              (parents (list (cons -1 backtrace)))
 379              (tmp backtrace)
 380              (max (length backtrace)))
 381          (while (setq tmp (gethash tmp parent-map))
 382            (push tmp parents)
 383            (setq tmp (cdr tmp)))
 384          (when (aref (cdar parents) (1- max))
 385            (cl-incf (profiler-calltree-count leftover-tree) count)
 386            (setq node leftover-tree))
 387          (pcase-dolist (`(,i . ,parent) parents)
 388            (let ((j (1- max)))
 389              (while (> j i)
 390                (let ((f (aref parent j)))
 391                  (cl-decf j)
 392                  (when f
 393                    (let ((child (profiler-calltree-find node f)))
 394                      (unless child
 395                        (setq child (profiler-make-calltree
 396                                     :entry f :parent node))
 397                        (push child (profiler-calltree-children node)))
 398                      (cl-incf (profiler-calltree-count child) count)
 399                      (setq node child)))))))))
 400      log)))
 401
 402 (defun profiler-calltree-compute-percentages (tree)
 403   (let ((total-count 0))
 404     ;; FIXME: the memory profiler's total wraps around all too easily!
 405     (dolist (child (profiler-calltree-children tree))
 406       (cl-incf total-count (profiler-calltree-count child)))
 407     (unless (zerop total-count)
 408       (profiler-calltree-walk
 409        tree (lambda (node)
 410               (setf (profiler-calltree-count-percent node)
 411                     (profiler-format-percent (profiler-calltree-count node)
 412                                              total-count)))))))
 413
 414 (cl-defun profiler-calltree-build (log &key reverse)
 415   (let ((tree (profiler-make-calltree)))
 416     (if reverse
 417         (profiler-calltree-build-1 tree log reverse)
 418       (profiler-calltree-build-unified tree log))
 419     (profiler-calltree-compute-percentages tree)
 420     tree))
 421
 422 (defun profiler-calltree-sort (tree predicate)
 423   (let ((children (profiler-calltree-children tree)))
 424     (setf (profiler-calltree-children tree) (sort children predicate))
 425     (dolist (child (profiler-calltree-children tree))
 426       (profiler-calltree-sort child predicate))))
 427
 428 \f
 429 ;;; Report rendering
 430
 431 (defcustom profiler-report-closed-mark "+"
 432   "An indicator of closed calltrees."
 433   :type 'string
 434   :group 'profiler)
 435
 436 (defcustom profiler-report-open-mark "-"
 437   "An indicator of open calltrees."
 438   :type 'string
 439   :group 'profiler)
 440
 441 (defcustom profiler-report-leaf-mark " "
 442   "An indicator of calltree leaves."
 443   :type 'string
 444   :group 'profiler)
 445
 446 (defvar profiler-report-cpu-line-format
 447   '((50 left)
 448     (24 right ((19 right)
 449                (5 right)))))
 450
 451 (defvar profiler-report-memory-line-format
 452   '((55 left)
 453     (19 right ((14 right profiler-format-number)
 454                (5 right)))))
 455
 456 (defvar-local profiler-report-profile nil
 457   "The current profile.")
 458
 459 (defvar-local profiler-report-reversed nil
 460   "True if calltree is rendered in bottom-up.  Do not touch this
 461 variable directly.")
 462
 463 (defvar-local profiler-report-order nil
 464   "The value can be `ascending' or `descending'.  Do not touch
 465 this variable directly.")
 466
 467 (defun profiler-report-make-entry-part (entry)
 468   (let ((string (cond
 469                  ((eq entry t)
 470                   "Others")
 471                  ((and (symbolp entry)
 472                        (fboundp entry))
 473                   (propertize (symbol-name entry)
 474                               'face 'link
 475                               'mouse-face 'highlight
 476                               'help-echo "\
 477 mouse-2: jump to definition\n\
 478 RET: expand or collapse"))
 479                  (t
 480                   (profiler-format-entry entry)))))
 481     (propertize string 'profiler-entry entry)))
 482
 483 (defun profiler-report-make-name-part (tree)
 484   (let* ((entry (profiler-calltree-entry tree))
 485          (depth (profiler-calltree-depth tree))
 486          (indent (make-string (* (1- depth) 1) ?\s))
 487          (mark (if (profiler-calltree-leaf-p tree)
 488                    profiler-report-leaf-mark
 489                  profiler-report-closed-mark))
 490          (entry (profiler-report-make-entry-part entry)))
 491     (format "%s%s %s" indent mark entry)))
 492
 493 (defun profiler-report-header-line-format (fmt &rest args)
 494   (let* ((header (apply #'profiler-format fmt args))
 495          (escaped (replace-regexp-in-string "%" "%%" header)))
 496     (concat " " escaped)))
 497
 498 (defun profiler-report-line-format (tree)
 499   (let ((diff-p (profiler-profile-diff-p profiler-report-profile))
 500         (name-part (profiler-report-make-name-part tree))
 501         (count (profiler-calltree-count tree))
 502         (count-percent (profiler-calltree-count-percent tree)))
 503     (profiler-format (cl-ecase (profiler-profile-type profiler-report-profile)
 504                        (cpu profiler-report-cpu-line-format)
 505                        (memory profiler-report-memory-line-format))
 506                      name-part
 507                      (if diff-p
 508                          (list (if (> count 0)
 509                                    (format "+%s" count)
 510                                  count)
 511                                "")
 512                        (list count count-percent)))))
 513
 514 (defun profiler-report-insert-calltree (tree)
 515   (let ((line (profiler-report-line-format tree)))
 516     (insert (propertize (concat line "\n") 'calltree tree))))
 517
 518 (defun profiler-report-insert-calltree-children (tree)
 519   (mapc #'profiler-report-insert-calltree
 520         (profiler-calltree-children tree)))
 521
 522 \f
 523 ;;; Report mode
 524
 525 (defvar profiler-report-mode-map
 526   (let ((map (make-sparse-keymap)))
 527     (define-key map "n"     'profiler-report-next-entry)
 528     (define-key map "p"     'profiler-report-previous-entry)
 529     ;; I find it annoying more than helpful to not be able to navigate
 530     ;; normally with the cursor keys.  --Stef
 531     ;; (define-key map [down]  'profiler-report-next-entry)
 532     ;; (define-key map [up]    'profiler-report-previous-entry)
 533     (define-key map "\r"    'profiler-report-toggle-entry)
 534     (define-key map "\t"    'profiler-report-toggle-entry)
 535     (define-key map "i"     'profiler-report-toggle-entry)
 536     (define-key map [mouse-1] 'profiler-report-toggle-entry)
 537     (define-key map "f"     'profiler-report-find-entry)
 538     (define-key map "j"     'profiler-report-find-entry)
 539     (define-key map [mouse-2] 'profiler-report-find-entry)
 540     (define-key map "d"     'profiler-report-describe-entry)
 541     (define-key map "C"     'profiler-report-render-calltree)
 542     (define-key map "B"     'profiler-report-render-reversed-calltree)
 543     (define-key map "A"     'profiler-report-ascending-sort)
 544     (define-key map "D"     'profiler-report-descending-sort)
 545     (define-key map "="     'profiler-report-compare-profile)
 546     (define-key map (kbd "C-x C-w") 'profiler-report-write-profile)
 547     (easy-menu-define  profiler-report-menu map "Menu for Profiler Report mode."
 548       '("Profiler"
 549         ["Next Entry" profiler-report-next-entry :active t
 550          :help "Move to next entry"]
 551         ["Previous Entry" profiler-report-previous-entry :active t
 552          :help "Move to previous entry"]
 553         "--"
 554         ["Toggle Entry" profiler-report-toggle-entry
 555          :active (profiler-report-calltree-at-point)
 556          :help "Expand or collapse the current entry"]
 557         ["Find Entry" profiler-report-find-entry
 558          ;; FIXME should deactivate if not on a known function.
 559          :active (profiler-report-calltree-at-point)
 560          :help "Find the definition of the current entry"]
 561         ["Describe Entry" profiler-report-describe-entry
 562          :active (profiler-report-calltree-at-point)
 563          :help "Show the documentation of the current entry"]
 564         "--"
 565         ["Show Calltree" profiler-report-render-calltree
 566          :active profiler-report-reversed
 567          :help "Show calltree view"]
 568         ["Show Reversed Calltree" profiler-report-render-reversed-calltree
 569          :active (not profiler-report-reversed)
 570          :help "Show reversed calltree view"]
 571         ["Sort Ascending" profiler-report-ascending-sort
 572          :active (not (eq profiler-report-order 'ascending))
 573          :help "Sort calltree view in ascending order"]
 574         ["Sort Descending" profiler-report-descending-sort
 575          :active (not (eq profiler-report-order 'descending))
 576          :help "Sort calltree view in descending order"]
 577         "--"
 578         ["Compare Profile..." profiler-report-compare-profile :active t
 579          :help "Compare current profile with another"]
 580         ["Write Profile..." profiler-report-write-profile :active t
 581          :help "Write current profile to a file"]
 582         "--"
 583         ["Start Profiler" profiler-start :active (not (profiler-running-p))
 584          :help "Start profiling"]
 585         ["Stop Profiler" profiler-stop :active (profiler-running-p)
 586          :help "Stop profiling"]
 587         ["New Report" profiler-report :active (profiler-running-p)
 588          :help "Make a new report"]))
 589       map)
 590   "Keymap for `profiler-report-mode'.")
 591
 592 (defun profiler-report-make-buffer-name (profile)
 593   (format "*%s-Profiler-Report %s*"
 594           (cl-ecase (profiler-profile-type profile) (cpu 'CPU) (memory 'Memory))
 595           (format-time-string "%Y-%m-%d %T" (profiler-profile-timestamp profile))))
 596
 597 (defun profiler-report-setup-buffer-1 (profile)
 598   "Make a buffer for PROFILE and return it."
 599   (let* ((buf-name (profiler-report-make-buffer-name profile))
 600          (buffer (get-buffer-create buf-name)))
 601     (with-current-buffer buffer
 602       (profiler-report-mode)
 603       (setq profiler-report-profile profile
 604             profiler-report-reversed nil
 605             profiler-report-order 'descending))
 606     buffer))
 607
 608 (defun profiler-report-setup-buffer (profile)
 609   "Make a buffer for PROFILE with rendering the profile and
 610 return it."
 611   (let ((buffer (profiler-report-setup-buffer-1 profile)))
 612     (with-current-buffer buffer
 613       (profiler-report-render-calltree))
 614     buffer))
 615
 616 (define-derived-mode profiler-report-mode special-mode "Profiler-Report"
 617   "Profiler Report Mode."
 618   (add-to-invisibility-spec '(profiler . t))
 619   (setq buffer-read-only t
 620         buffer-undo-list t
 621         truncate-lines t))
 622
 623 \f
 624 ;;; Report commands
 625
 626 (defun profiler-report-calltree-at-point (&optional point)
 627   (get-text-property (or point (point)) 'calltree))
 628
 629 (defun profiler-report-move-to-entry ()
 630   (let ((point (next-single-property-change
 631                 (line-beginning-position) 'profiler-entry)))
 632     (if point
 633         (goto-char point)
 634       (back-to-indentation))))
 635
 636 (defun profiler-report-next-entry ()
 637   "Move cursor to next entry."
 638   (interactive)
 639   (forward-line)
 640   (profiler-report-move-to-entry))
 641
 642 (defun profiler-report-previous-entry ()
 643   "Move cursor to previous entry."
 644   (interactive)
 645   (forward-line -1)
 646   (profiler-report-move-to-entry))
 647
 648 (defun profiler-report-expand-entry (&optional full)
 649   "Expand entry at point.
 650 With a prefix argument, expand the whole subtree."
 651   (interactive "P")
 652   (save-excursion
 653     (beginning-of-line)
 654     (when (search-forward (concat profiler-report-closed-mark " ")
 655                           (line-end-position) t)
 656       (let ((tree (profiler-report-calltree-at-point)))
 657         (when tree
 658           (let ((inhibit-read-only t))
 659             (replace-match (concat profiler-report-open-mark " "))
 660             (forward-line)
 661             (let ((first (point))
 662                   (last (copy-marker (point) t)))
 663               (profiler-report-insert-calltree-children tree)
 664               (when full
 665                 (goto-char first)
 666                 (while (< (point) last)
 667                   (profiler-report-expand-entry)
 668                   (forward-line 1))))
 669             t))))))
 670
 671 (defun profiler-report-collapse-entry ()
 672   "Collapse entry at point."
 673   (interactive)
 674   (save-excursion
 675     (beginning-of-line)
 676     (when (search-forward (concat profiler-report-open-mark " ")
 677                           (line-end-position) t)
 678       (let* ((tree (profiler-report-calltree-at-point))
 679              (depth (profiler-calltree-depth tree))
 680              (start (line-beginning-position 2))
 681              d)
 682         (when tree
 683           (let ((inhibit-read-only t))
 684             (replace-match (concat profiler-report-closed-mark " "))
 685             (while (and (eq (forward-line) 0)
 686                         (let ((child (get-text-property (point) 'calltree)))
 687                           (and child
 688                                (numberp (setq d (profiler-calltree-depth child)))))
 689                         (> d depth)))
 690             (delete-region start (line-beginning-position)))))
 691       t)))
 692
 693 (defun profiler-report-toggle-entry (&optional arg)
 694   "Expand entry at point if the tree is collapsed,
 695 otherwise collapse.  With prefix argument, expand all subentries
 696 below entry at point."
 697   (interactive "P")
 698   (or (profiler-report-expand-entry arg)
 699       (profiler-report-collapse-entry)))
 700
 701 (defun profiler-report-find-entry (&optional event)
 702   "Find entry at point."
 703   (interactive (list last-nonmenu-event))
 704   (with-current-buffer
 705       (if event (window-buffer (posn-window (event-start event)))
 706         (current-buffer))
 707     (and event (setq event (event-end event))
 708          (posn-set-point event))
 709     (let ((tree (profiler-report-calltree-at-point)))
 710       (when tree
 711         (let ((entry (profiler-calltree-entry tree)))
 712           (find-function entry))))))
 713
 714 (defun profiler-report-describe-entry ()
 715   "Describe entry at point."
 716   (interactive)
 717   (let ((tree (profiler-report-calltree-at-point)))
 718     (when tree
 719       (let ((entry (profiler-calltree-entry tree)))
 720         (require 'help-fns)
 721         (describe-function entry)))))
 722
 723 (cl-defun profiler-report-render-calltree-1
 724     (profile &key reverse (order 'descending))
 725   (let ((calltree (profiler-calltree-build
 726                    (profiler-profile-log profile)
 727                    :reverse reverse)))
 728     (setq header-line-format
 729           (cl-ecase (profiler-profile-type profile)
 730             (cpu
 731              (profiler-report-header-line-format
 732               profiler-report-cpu-line-format
 733               "Function" (list "CPU samples" "%")))
 734             (memory
 735              (profiler-report-header-line-format
 736               profiler-report-memory-line-format
 737               "Function" (list "Bytes" "%")))))
 738     (let ((predicate (cl-ecase order
 739                        (ascending #'profiler-calltree-count<)
 740                        (descending #'profiler-calltree-count>))))
 741       (profiler-calltree-sort calltree predicate))
 742     (let ((inhibit-read-only t))
 743       (erase-buffer)
 744       (profiler-report-insert-calltree-children calltree)
 745       (goto-char (point-min))
 746       (profiler-report-move-to-entry))))
 747
 748 (defun profiler-report-rerender-calltree ()
 749   (profiler-report-render-calltree-1 profiler-report-profile
 750                                      :reverse profiler-report-reversed
 751                                      :order profiler-report-order))
 752
 753 (defun profiler-report-render-calltree ()
 754   "Render calltree view."
 755   (interactive)
 756   (setq profiler-report-reversed nil)
 757   (profiler-report-rerender-calltree))
 758
 759 (defun profiler-report-render-reversed-calltree ()
 760   "Render reversed calltree view."
 761   (interactive)
 762   (setq profiler-report-reversed t)
 763   (profiler-report-rerender-calltree))
 764
 765 (defun profiler-report-ascending-sort ()
 766   "Sort calltree view in ascending order."
 767   (interactive)
 768   (setq profiler-report-order 'ascending)
 769   (profiler-report-rerender-calltree))
 770
 771 (defun profiler-report-descending-sort ()
 772   "Sort calltree view in descending order."
 773   (interactive)
 774   (setq profiler-report-order 'descending)
 775   (profiler-report-rerender-calltree))
 776
 777 (defun profiler-report-profile (profile)
 778   (switch-to-buffer (profiler-report-setup-buffer profile)))
 779
 780 (defun profiler-report-profile-other-window (profile)
 781   (switch-to-buffer-other-window (profiler-report-setup-buffer profile)))
 782
 783 (defun profiler-report-profile-other-frame (profile)
 784   (switch-to-buffer-other-frame (profiler-report-setup-buffer profile)))
 785
 786 (defun profiler-report-compare-profile (buffer)
 787   "Compare the current profile with another."
 788   (interactive (list (read-buffer "Compare to: ")))
 789   (let* ((profile1 (with-current-buffer buffer profiler-report-profile))
 790          (profile2 profiler-report-profile)
 791          (diff-profile (profiler-compare-profiles profile1 profile2)))
 792     (profiler-report-profile diff-profile)))
 793
 794 (defun profiler-report-write-profile (filename &optional confirm)
 795   "Write the current profile into file FILENAME."
 796   (interactive
 797    (list (read-file-name "Write profile: " default-directory)
 798          (not current-prefix-arg)))
 799   (profiler-write-profile profiler-report-profile
 800                           filename
 801                           confirm))
 802
 803 \f
 804 ;;; Profiler commands
 805
 806 ;;;###autoload
 807 (defun profiler-start (mode)
 808   "Start/restart profilers.
 809 MODE can be one of `cpu', `mem', or `cpu+mem'.
 810 If MODE is `cpu' or `cpu+mem', time-based profiler will be started.
 811 Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started."
 812   (interactive
 813    (list (if (not (fboundp 'profiler-cpu-start)) 'mem
 814            (intern (completing-read "Mode (default cpu): "
 815                                     '("cpu" "mem" "cpu+mem")
 816                                     nil t nil nil "cpu")))))
 817   (cl-ecase mode
 818     (cpu
 819      (profiler-cpu-start profiler-sampling-interval)
 820      (message "CPU profiler started"))
 821     (mem
 822      (profiler-memory-start)
 823      (message "Memory profiler started"))
 824     (cpu+mem
 825      (profiler-cpu-start profiler-sampling-interval)
 826      (profiler-memory-start)
 827      (message "CPU and memory profiler started"))))
 828
 829 (defun profiler-stop ()
 830   "Stop started profilers.  Profiler logs will be kept."
 831   (interactive)
 832   (let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop)))
 833         (mem (profiler-memory-stop)))
 834     (message "%s profiler stopped"
 835              (cond ((and mem cpu) "CPU and memory")
 836                    (mem "Memory")
 837                    (cpu "CPU")
 838                    (t "No")))))
 839
 840 (defun profiler-reset ()
 841   "Reset profiler logs."
 842   (interactive)
 843   (when (fboundp 'profiler-cpu-log)
 844     (ignore (profiler-cpu-log)))
 845   (ignore (profiler-memory-log))
 846   t)
 847
 848 (defun profiler-report-cpu ()
 849   (let ((profile (profiler-cpu-profile)))
 850     (when profile
 851       (profiler-report-profile-other-window profile))))
 852
 853 (defun profiler-report-memory ()
 854   (let ((profile (profiler-memory-profile)))
 855     (when profile
 856       (profiler-report-profile-other-window profile))))
 857
 858 (defun profiler-report ()
 859   "Report profiling results."
 860   (interactive)
 861   (profiler-report-cpu)
 862   (profiler-report-memory))
 863
 864 ;;;###autoload
 865 (defun profiler-find-profile (filename)
 866   "Open profile FILENAME."
 867   (interactive
 868    (list (read-file-name "Find profile: " default-directory)))
 869   (profiler-report-profile (profiler-read-profile filename)))
 870
 871 ;;;###autoload
 872 (defun profiler-find-profile-other-window (filename)
 873   "Open profile FILENAME."
 874   (interactive
 875    (list (read-file-name "Find profile: " default-directory)))
 876   (profiler-report-profile-other-window (profiler-read-profile filename)))
 877
 878 ;;;###autoload
 879 (defun profiler-find-profile-other-frame (filename)
 880   "Open profile FILENAME."
 881   (interactive
 882    (list (read-file-name "Find profile: " default-directory)))
 883   (profiler-report-profile-other-frame(profiler-read-profile filename)))
 884
 885 \f
 886 ;;; Profiling helpers
 887
 888 ;; (cl-defmacro with-cpu-profiling ((&key sampling-interval) &rest body)
 889 ;;   `(unwind-protect
 890 ;;        (progn
 891 ;;          (ignore (profiler-cpu-log))
 892 ;;          (profiler-cpu-start ,sampling-interval)
 893 ;;          ,@body)
 894 ;;      (profiler-cpu-stop)
 895 ;;      (profiler--report-cpu)))
 896
 897 ;; (defmacro with-memory-profiling (&rest body)
 898 ;;   `(unwind-protect
 899 ;;        (progn
 900 ;;          (ignore (profiler-memory-log))
 901 ;;          (profiler-memory-start)
 902 ;;          ,@body)
 903 ;;      (profiler-memory-stop)
 904 ;;      (profiler--report-memory)))
 905
 906 (provide 'profiler)
 907 ;;; profiler.el ends here