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 (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 [mouse-1] 'profiler-report-toggle-entry)
 538     (define-key map "f"     'profiler-report-find-entry)
 539     (define-key map "j"     'profiler-report-find-entry)
 540     (define-key map [mouse-2] 'profiler-report-find-entry)
 541     (define-key map "d"     'profiler-report-describe-entry)
 542     (define-key map "C"     'profiler-report-render-calltree)
 543     (define-key map "B"     'profiler-report-render-reversed-calltree)
 544     (define-key map "A"     'profiler-report-ascending-sort)
 545     (define-key map "D"     'profiler-report-descending-sort)
 546     (define-key map "="     'profiler-report-compare-profile)
 547     (define-key map (kbd "C-x C-w") 'profiler-report-write-profile)
 548     (easy-menu-define  profiler-report-menu map "Menu for Profiler Report mode."
 549       '("Profiler"
 550         ["Next Entry" profiler-report-next-entry :active t
 551          :help "Move to next entry"]
 552         ["Previous Entry" profiler-report-previous-entry :active t
 553          :help "Move to previous entry"]
 554         "--"
 555         ["Toggle Entry" profiler-report-toggle-entry
 556          :active (profiler-report-calltree-at-point)
 557          :help "Expand or collapse the current entry"]
 558         ["Find Entry" profiler-report-find-entry
 559          ;; FIXME should deactivate if not on a known function.
 560          :active (profiler-report-calltree-at-point)
 561          :help "Find the definition of the current entry"]
 562         ["Describe Entry" profiler-report-describe-entry
 563          :active (profiler-report-calltree-at-point)
 564          :help "Show the documentation of the current entry"]
 565         "--"
 566         ["Show Calltree" profiler-report-render-calltree
 567          :active profiler-report-reversed
 568          :help "Show calltree view"]
 569         ["Show Reversed Calltree" profiler-report-render-reversed-calltree
 570          :active (not profiler-report-reversed)
 571          :help "Show reversed calltree view"]
 572         ["Sort Ascending" profiler-report-ascending-sort
 573          :active (not (eq profiler-report-order 'ascending))
 574          :help "Sort calltree view in ascending order"]
 575         ["Sort Descending" profiler-report-descending-sort
 576          :active (not (eq profiler-report-order 'descending))
 577          :help "Sort calltree view in descending order"]
 578         "--"
 579         ["Compare Profile..." profiler-report-compare-profile :active t
 580          :help "Compare current profile with another"]
 581         ["Write Profile..." profiler-report-write-profile :active t
 582          :help "Write current profile to a file"]
 583         "--"
 584         ["Start Profiler" profiler-start :active (not (profiler-running-p))
 585          :help "Start profiling"]
 586         ["Stop Profiler" profiler-stop :active (profiler-running-p)
 587          :help "Stop profiling"]
 588         ["New Report" profiler-report :active (profiler-running-p)
 589          :help "Make a new report"]))
 590       map)
 591   "Keymap for `profiler-report-mode'.")
 592
 593 (defun profiler-report-make-buffer-name (profile)
 594   (format "*%s-Profiler-Report %s*"
 595           (cl-ecase (profiler-profile-type profile) (cpu 'CPU) (memory 'Memory))
 596           (format-time-string "%Y-%m-%d %T" (profiler-profile-timestamp profile))))
 597
 598 (defun profiler-report-setup-buffer-1 (profile)
 599   "Make a buffer for PROFILE and return it."
 600   (let* ((buf-name (profiler-report-make-buffer-name profile))
 601          (buffer (get-buffer-create buf-name)))
 602     (with-current-buffer buffer
 603       (profiler-report-mode)
 604       (setq profiler-report-profile profile
 605             profiler-report-reversed nil
 606             profiler-report-order 'descending))
 607     buffer))
 608
 609 (defun profiler-report-setup-buffer (profile)
 610   "Make a buffer for PROFILE with rendering the profile and
 611 return it."
 612   (let ((buffer (profiler-report-setup-buffer-1 profile)))
 613     (with-current-buffer buffer
 614       (profiler-report-render-calltree))
 615     buffer))
 616
 617 (define-derived-mode profiler-report-mode special-mode "Profiler-Report"
 618   "Profiler Report Mode."
 619   (add-to-invisibility-spec '(profiler . t))
 620   (setq buffer-read-only t
 621         buffer-undo-list t
 622         truncate-lines t))
 623
 624 \f
 625 ;;; Report commands
 626
 627 (defun profiler-report-calltree-at-point (&optional point)
 628   (get-text-property (or point (point)) 'calltree))
 629
 630 (defun profiler-report-move-to-entry ()
 631   (let ((point (next-single-property-change
 632                 (line-beginning-position) 'profiler-entry)))
 633     (if point
 634         (goto-char point)
 635       (back-to-indentation))))
 636
 637 (defun profiler-report-next-entry ()
 638   "Move cursor to next entry."
 639   (interactive)
 640   (forward-line)
 641   (profiler-report-move-to-entry))
 642
 643 (defun profiler-report-previous-entry ()
 644   "Move cursor to previous entry."
 645   (interactive)
 646   (forward-line -1)
 647   (profiler-report-move-to-entry))
 648
 649 (defun profiler-report-expand-entry (&optional full)
 650   "Expand entry at point.
 651 With a prefix argument, expand the whole subtree."
 652   (interactive "P")
 653   (save-excursion
 654     (beginning-of-line)
 655     (when (search-forward (concat profiler-report-closed-mark " ")
 656                           (line-end-position) t)
 657       (let ((tree (profiler-report-calltree-at-point)))
 658         (when tree
 659           (let ((inhibit-read-only t))
 660             (replace-match (concat profiler-report-open-mark " "))
 661             (forward-line)
 662             (let ((first (point))
 663                   (last (copy-marker (point) t)))
 664               (profiler-report-insert-calltree-children tree)
 665               (when full
 666                 (goto-char first)
 667                 (while (< (point) last)
 668                   (profiler-report-expand-entry)
 669                   (forward-line 1))))
 670             t))))))
 671
 672 (defun profiler-report-collapse-entry ()
 673   "Collapse entry at point."
 674   (interactive)
 675   (save-excursion
 676     (beginning-of-line)
 677     (when (search-forward (concat profiler-report-open-mark " ")
 678                           (line-end-position) t)
 679       (let* ((tree (profiler-report-calltree-at-point))
 680              (depth (profiler-calltree-depth tree))
 681              (start (line-beginning-position 2))
 682              d)
 683         (when tree
 684           (let ((inhibit-read-only t))
 685             (replace-match (concat profiler-report-closed-mark " "))
 686             (while (and (eq (forward-line) 0)
 687                         (let ((child (get-text-property (point) 'calltree)))
 688                           (and child
 689                                (numberp (setq d (profiler-calltree-depth child)))))
 690                         (> d depth)))
 691             (delete-region start (line-beginning-position)))))
 692       t)))
 693
 694 (defun profiler-report-toggle-entry (&optional arg)
 695   "Expand entry at point if the tree is collapsed,
 696 otherwise collapse.  With prefix argument, expand all subentries
 697 below entry at point."
 698   (interactive "P")
 699   (or (profiler-report-expand-entry arg)
 700       (profiler-report-collapse-entry)))
 701
 702 (defun profiler-report-find-entry (&optional event)
 703   "Find entry at point."
 704   (interactive (list last-nonmenu-event))
 705   (with-current-buffer
 706       (if event (window-buffer (posn-window (event-start event)))
 707         (current-buffer))
 708     (and event (setq event (event-end event))
 709          (posn-set-point event))
 710     (let ((tree (profiler-report-calltree-at-point)))
 711       (when tree
 712         (let ((entry (profiler-calltree-entry tree)))
 713           (find-function entry))))))
 714
 715 (defun profiler-report-describe-entry ()
 716   "Describe entry at point."
 717   (interactive)
 718   (let ((tree (profiler-report-calltree-at-point)))
 719     (when tree
 720       (let ((entry (profiler-calltree-entry tree)))
 721         (require 'help-fns)
 722         (describe-function entry)))))
 723
 724 (cl-defun profiler-report-render-calltree-1
 725     (profile &key reverse (order 'descending))
 726   (let ((calltree (profiler-calltree-build
 727                    (profiler-profile-log profile)
 728                    :reverse reverse)))
 729     (setq header-line-format
 730           (cl-ecase (profiler-profile-type profile)
 731             (cpu
 732              (profiler-report-header-line-format
 733               profiler-report-cpu-line-format
 734               "Function" (list "CPU samples" "%")))
 735             (memory
 736              (profiler-report-header-line-format
 737               profiler-report-memory-line-format
 738               "Function" (list "Bytes" "%")))))
 739     (let ((predicate (cl-ecase order
 740                        (ascending #'profiler-calltree-count<)
 741                        (descending #'profiler-calltree-count>))))
 742       (profiler-calltree-sort calltree predicate))
 743     (let ((inhibit-read-only t))
 744       (erase-buffer)
 745       (profiler-report-insert-calltree-children calltree)
 746       (goto-char (point-min))
 747       (profiler-report-move-to-entry))))
 748
 749 (defun profiler-report-rerender-calltree ()
 750   (profiler-report-render-calltree-1 profiler-report-profile
 751                                      :reverse profiler-report-reversed
 752                                      :order profiler-report-order))
 753
 754 (defun profiler-report-render-calltree ()
 755   "Render calltree view."
 756   (interactive)
 757   (setq profiler-report-reversed nil)
 758   (profiler-report-rerender-calltree))
 759
 760 (defun profiler-report-render-reversed-calltree ()
 761   "Render reversed calltree view."
 762   (interactive)
 763   (setq profiler-report-reversed t)
 764   (profiler-report-rerender-calltree))
 765
 766 (defun profiler-report-ascending-sort ()
 767   "Sort calltree view in ascending order."
 768   (interactive)
 769   (setq profiler-report-order 'ascending)
 770   (profiler-report-rerender-calltree))
 771
 772 (defun profiler-report-descending-sort ()
 773   "Sort calltree view in descending order."
 774   (interactive)
 775   (setq profiler-report-order 'descending)
 776   (profiler-report-rerender-calltree))
 777
 778 (defun profiler-report-profile (profile)
 779   (switch-to-buffer (profiler-report-setup-buffer profile)))
 780
 781 (defun profiler-report-profile-other-window (profile)
 782   (switch-to-buffer-other-window (profiler-report-setup-buffer profile)))
 783
 784 (defun profiler-report-profile-other-frame (profile)
 785   (switch-to-buffer-other-frame (profiler-report-setup-buffer profile)))
 786
 787 (defun profiler-report-compare-profile (buffer)
 788   "Compare the current profile with another."
 789   (interactive (list (read-buffer "Compare to: ")))
 790   (let* ((profile1 (with-current-buffer buffer profiler-report-profile))
 791          (profile2 profiler-report-profile)
 792          (diff-profile (profiler-compare-profiles profile1 profile2)))
 793     (profiler-report-profile diff-profile)))
 794
 795 (defun profiler-report-write-profile (filename &optional confirm)
 796   "Write the current profile into file FILENAME."
 797   (interactive
 798    (list (read-file-name "Write profile: " default-directory)
 799          (not current-prefix-arg)))
 800   (profiler-write-profile profiler-report-profile
 801                           filename
 802                           confirm))
 803
 804 \f
 805 ;;; Profiler commands
 806
 807 ;;;###autoload
 808 (defun profiler-start (mode)
 809   "Start/restart profilers.
 810 MODE can be one of `cpu', `mem', or `cpu+mem'.
 811 If MODE is `cpu' or `cpu+mem', time-based profiler will be started.
 812 Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started."
 813   (interactive
 814    (list (if (not (fboundp 'profiler-cpu-start)) 'mem
 815            (intern (completing-read "Mode (default cpu): "
 816                                     '("cpu" "mem" "cpu+mem")
 817                                     nil t nil nil "cpu")))))
 818   (cl-ecase mode
 819     (cpu
 820      (profiler-cpu-start profiler-sampling-interval)
 821      (message "CPU profiler started"))
 822     (mem
 823      (profiler-memory-start)
 824      (message "Memory profiler started"))
 825     (cpu+mem
 826      (profiler-cpu-start profiler-sampling-interval)
 827      (profiler-memory-start)
 828      (message "CPU and memory profiler started"))))
 829
 830 (defun profiler-stop ()
 831   "Stop started profilers.  Profiler logs will be kept."
 832   (interactive)
 833   (let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop)))
 834         (mem (profiler-memory-stop)))
 835     (message "%s profiler stopped"
 836              (cond ((and mem cpu) "CPU and memory")
 837                    (mem "Memory")
 838                    (cpu "CPU")
 839                    (t "No")))))
 840
 841 (defun profiler-reset ()
 842   "Reset profiler logs."
 843   (interactive)
 844   (when (fboundp 'profiler-cpu-log)
 845     (ignore (profiler-cpu-log)))
 846   (ignore (profiler-memory-log))
 847   t)
 848
 849 (defun profiler-report-cpu ()
 850   (let ((profile (profiler-cpu-profile)))
 851     (when profile
 852       (profiler-report-profile-other-window profile))))
 853
 854 (defun profiler-report-memory ()
 855   (let ((profile (profiler-memory-profile)))
 856     (when profile
 857       (profiler-report-profile-other-window profile))))
 858
 859 (defun profiler-report ()
 860   "Report profiling results."
 861   (interactive)
 862   (profiler-report-cpu)
 863   (profiler-report-memory))
 864
 865 ;;;###autoload
 866 (defun profiler-find-profile (filename)
 867   "Open profile FILENAME."
 868   (interactive
 869    (list (read-file-name "Find profile: " default-directory)))
 870   (profiler-report-profile (profiler-read-profile filename)))
 871
 872 ;;;###autoload
 873 (defun profiler-find-profile-other-window (filename)
 874   "Open profile FILENAME."
 875   (interactive
 876    (list (read-file-name "Find profile: " default-directory)))
 877   (profiler-report-profile-other-window (profiler-read-profile filename)))
 878
 879 ;;;###autoload
 880 (defun profiler-find-profile-other-frame (filename)
 881   "Open profile FILENAME."
 882   (interactive
 883    (list (read-file-name "Find profile: " default-directory)))
 884   (profiler-report-profile-other-frame(profiler-read-profile filename)))
 885
 886 \f
 887 ;;; Profiling helpers
 888
 889 ;; (cl-defmacro with-cpu-profiling ((&key sampling-interval) &rest body)
 890 ;;   `(unwind-protect
 891 ;;        (progn
 892 ;;          (ignore (profiler-cpu-log))
 893 ;;          (profiler-cpu-start ,sampling-interval)
 894 ;;          ,@body)
 895 ;;      (profiler-cpu-stop)
 896 ;;      (profiler--report-cpu)))
 897
 898 ;; (defmacro with-memory-profiling (&rest body)
 899 ;;   `(unwind-protect
 900 ;;        (progn
 901 ;;          (ignore (profiler-memory-log))
 902 ;;          (profiler-memory-start)
 903 ;;          ,@body)
 904 ;;      (profiler-memory-stop)
 905 ;;      (profiler--report-memory)))
 906
 907 (provide 'profiler)
 908 ;;; profiler.el ends here