lisp/profiler.el

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