lisp/profiler.el

   1 ;;; profiler.el --- UI and helper functions for Emacs's native profiler -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomohiro Matsuyama <tomo@cx4a.org>
   6 ;; Keywords: lisp
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;
  24
  25 ;;; Code:
  26
  27 (eval-when-compile
  28   (require 'cl-lib))
  29
  30 (defgroup profiler nil
  31   "Emacs profiler."
  32   :group 'lisp
  33   :prefix "profiler-")
  34
  35 \f
  36
  37 ;;; Utilities
  38
  39 (defun profiler-ensure-string (object)
  40   (if (stringp object)
  41       object
  42     (format "%s" object)))
  43
  44 (defun profiler-format (fmt &rest args)
  45   (cl-loop for (width align subfmt) in fmt
  46            for arg in args
  47            for str = (cl-typecase subfmt
  48                        (cons   (apply 'profiler-format subfmt arg))
  49                        (string (format subfmt arg))
  50                        (t           (profiler-ensure-string arg)))
  51            for len = (length str)
  52            if (< width len)
  53            collect (substring str 0 width) into frags
  54            else
  55            collect
  56            (let ((padding (make-string (- width len) ?\s)))
  57              (cl-ecase align
  58                (left (concat str padding))
  59                (right (concat padding str))))
  60            into frags
  61            finally return (apply #'concat frags)))
  62
  63 \f
  64
  65 ;;; Slot data structure
  66
  67 (cl-defstruct (profiler-slot (:type list)
  68                              (:constructor profiler-make-slot))
  69   backtrace count elapsed)
  70
  71 \f
  72
  73 ;;; Log data structure
  74
  75 (cl-defstruct (profiler-log (:type list)
  76                             (:constructor profiler-make-log))
  77   type diff-p timestamp slots)
  78
  79 (defun profiler-log-diff (log1 log2)
  80   ;; FIXME zeros
  81   (unless (eq (profiler-log-type log1)
  82               (profiler-log-type log2))
  83     (error "Can't compare different type of logs"))
  84   (let ((slots (profiler-log-slots log2)))
  85     (dolist (slot (profiler-log-slots log1))
  86       (push (profiler-make-slot :backtrace (profiler-slot-backtrace slot)
  87                                 :count (- (profiler-slot-count slot))
  88                                 :elapsed (- (profiler-slot-elapsed slot)))
  89             slots))
  90     (profiler-make-log :type (profiler-log-type log1)
  91                        :diff-p t
  92                        :timestamp (current-time)
  93                        :slots slots)))
  94
  95 (defun profiler-log-fixup (log)
  96   "Fixup LOG so that the log could be serialized into file."
  97   (let ((fixup-entry
  98          (lambda (entry)
  99            (cond
 100             ((and (consp entry)
 101                   (or (eq (car entry) 'lambda)
 102                       (eq (car entry) 'closure)))
 103              (format "#<closure 0x%x>" (sxhash entry)))
 104             ((eq (type-of entry) 'compiled-function)
 105              (format "#<compiled 0x%x>" (sxhash entry)))
 106             ((subrp entry)
 107              (subr-name entry))
 108             ((symbolp entry)
 109              entry)
 110             (t
 111              (format "#<unknown 0x%x>" (sxhash entry)))))))
 112     (dolist (slot (profiler-log-slots log))
 113       (setf (profiler-slot-backtrace slot)
 114             (mapcar fixup-entry (profiler-slot-backtrace slot))))))
 115
 116 \f
 117
 118 ;;; Calltree data structure
 119
 120 (cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
 121   entry
 122   (count 0) count-percent
 123   (elapsed 0) elapsed-percent
 124   parent children)
 125
 126 (defun profiler-calltree-leaf-p (tree)
 127   (null (profiler-calltree-children tree)))
 128
 129 (defun profiler-calltree-count< (a b)
 130   (cond ((eq (profiler-calltree-entry a) t) t)
 131         ((eq (profiler-calltree-entry b) t) nil)
 132         (t (< (profiler-calltree-count a)
 133               (profiler-calltree-count b)))))
 134
 135 (defun profiler-calltree-count> (a b)
 136   (not (profiler-calltree-count< a b)))
 137
 138 (defun profiler-calltree-elapsed< (a b)
 139   (cond ((eq (profiler-calltree-entry a) t) t)
 140         ((eq (profiler-calltree-entry b) t) nil)
 141         (t (< (profiler-calltree-elapsed a)
 142               (profiler-calltree-elapsed b)))))
 143
 144 (defun profiler-calltree-elapsed> (a b)
 145   (not (profiler-calltree-elapsed< a b)))
 146
 147 (defun profiler-calltree-depth (tree)
 148   (let ((parent (profiler-calltree-parent tree)))
 149     (if (null parent)
 150         0
 151       (1+ (profiler-calltree-depth parent)))))
 152
 153 (defun profiler-calltree-find (tree entry)
 154   (cl-dolist (child (profiler-calltree-children tree))
 155     (when (equal (profiler-calltree-entry child) entry)
 156       (cl-return child))))
 157
 158 (defun profiler-calltree-walk (calltree function)
 159   (funcall function calltree)
 160   (dolist (child (profiler-calltree-children calltree))
 161     (profiler-calltree-walk child function)))
 162
 163 (defun profiler-calltree-build-1 (tree log &optional reverse)
 164   (dolist (slot (profiler-log-slots log))
 165     (let ((backtrace (profiler-slot-backtrace slot))
 166           (count (profiler-slot-count slot))
 167           (elapsed (profiler-slot-elapsed slot))
 168           (node tree))
 169       (dolist (entry (if reverse backtrace (reverse backtrace)))
 170         (let ((child (profiler-calltree-find node entry)))
 171           (unless child
 172             (setq child (profiler-make-calltree :entry entry :parent node))
 173             (push child (profiler-calltree-children node)))
 174           (cl-incf (profiler-calltree-count child) count)
 175           (cl-incf (profiler-calltree-elapsed child) elapsed)
 176           (setq node child))))))
 177
 178 (defun profiler-calltree-compute-percentages (tree)
 179   (let ((total-count 0)
 180         (total-elapsed 0))
 181     (dolist (child (profiler-calltree-children tree))
 182       (cl-incf total-count (profiler-calltree-count child))
 183       (cl-incf total-elapsed (profiler-calltree-elapsed child)))
 184     (profiler-calltree-walk
 185      tree (lambda (node)
 186             (unless (zerop total-count)
 187               (setf (profiler-calltree-count-percent node)
 188                     (format "%s%%"
 189                             (/ (* (profiler-calltree-count node) 100)
 190                                total-count))))
 191             (unless (zerop total-elapsed)
 192               (setf (profiler-calltree-elapsed-percent node)
 193                     (format "%s%%"
 194                             (/ (* (profiler-calltree-elapsed node) 100)
 195                                total-elapsed))))))))
 196
 197 (cl-defun profiler-calltree-build (log &key reverse)
 198   (let ((tree (profiler-make-calltree)))
 199     (profiler-calltree-build-1 tree log reverse)
 200     (profiler-calltree-compute-percentages tree)
 201     tree))
 202
 203 (defun profiler-calltree-sort (tree predicate)
 204   (let ((children (profiler-calltree-children tree)))
 205     (setf (profiler-calltree-children tree) (sort children predicate))
 206     (dolist (child (profiler-calltree-children tree))
 207       (profiler-calltree-sort child predicate))))
 208
 209 \f
 210
 211 ;;; Report rendering
 212
 213 (defcustom profiler-report-closed-mark "+"
 214   "An indicator of closed calltrees."
 215   :type 'string
 216   :group 'profiler)
 217
 218 (defcustom profiler-report-open-mark "-"
 219   "An indicator of open calltrees."
 220   :type 'string
 221   :group 'profiler)
 222
 223 (defcustom profiler-report-leaf-mark " "
 224   "An indicator of calltree leaves."
 225   :type 'string
 226   :group 'profiler)
 227
 228 (defvar profiler-report-sample-line-format
 229   '((60 left)
 230     (14 right ((9 right)
 231                (5 right)))))
 232
 233 (defvar profiler-report-memory-line-format
 234   '((60 left)
 235     (14 right ((9 right)
 236                (5 right)))))
 237
 238 (defvar profiler-report-log nil)
 239 (defvar profiler-report-reversed nil)
 240 (defvar profiler-report-order nil)
 241
 242 (defun profiler-report-make-entry-part (entry)
 243   (let ((string
 244          (cond
 245           ((eq entry t)
 246            "Others")
 247           ((and (symbolp entry)
 248                 (fboundp entry))
 249            (propertize (symbol-name entry)
 250                        'face 'link
 251                        'mouse-face 'highlight
 252                        'help-echo "mouse-2 or RET jumps to definition"))
 253           (t
 254            (profiler-ensure-string entry)))))
 255     (propertize string 'entry entry)))
 256
 257 (defun profiler-report-make-name-part (tree)
 258   (let* ((entry (profiler-calltree-entry tree))
 259          (depth (profiler-calltree-depth tree))
 260          (indent (make-string (* (1- depth) 2) ?\s))
 261          (mark (if (profiler-calltree-leaf-p tree)
 262                    profiler-report-leaf-mark
 263                  profiler-report-closed-mark))
 264          (entry (profiler-report-make-entry-part entry)))
 265     (format "%s%s %s" indent mark entry)))
 266
 267 (defun profiler-report-header-line-format (fmt &rest args)
 268   (let* ((header (apply 'profiler-format fmt args))
 269          (escaped (replace-regexp-in-string "%" "%%" header)))
 270     (concat " " escaped)))
 271
 272 (defun profiler-report-line-format (tree)
 273   (let ((diff-p (profiler-log-diff-p profiler-report-log))
 274         (name-part (profiler-report-make-name-part tree))
 275         (elapsed (profiler-calltree-elapsed tree))
 276         (elapsed-percent (profiler-calltree-elapsed-percent tree))
 277         (count (profiler-calltree-count tree))
 278         (count-percent (profiler-calltree-count-percent tree)))
 279     (cl-ecase (profiler-log-type profiler-report-log)
 280       (sample
 281        (if diff-p
 282            (profiler-format profiler-report-sample-line-format
 283                             name-part
 284                             (list (if (> elapsed 0)
 285                                       (format "+%s" elapsed)
 286                                     elapsed)
 287                                   ""))
 288          (profiler-format profiler-report-sample-line-format
 289                           name-part (list elapsed elapsed-percent))))
 290       (memory
 291        (if diff-p
 292            (profiler-format profiler-report-memory-line-format
 293                           name-part
 294                           (list (if (> count 0)
 295                                       (format "+%s" count)
 296                                     count)
 297                                 ""))
 298          (profiler-format profiler-report-memory-line-format
 299                           name-part (list count count-percent)))))))
 300
 301 (defun profiler-report-insert-calltree (tree)
 302   (let ((line (profiler-report-line-format tree)))
 303     (insert (propertize (concat line "\n") 'calltree tree))))
 304
 305 (defun profiler-report-insert-calltree-children (tree)
 306   (mapc 'profiler-report-insert-calltree
 307         (profiler-calltree-children tree)))
 308
 309 \f
 310
 311 ;;; Report mode
 312
 313 (defvar profiler-report-mode-map
 314   (let ((map (make-sparse-keymap)))
 315     (define-key map "n"     'profiler-report-next-entry)
 316     (define-key map "p"     'profiler-report-previous-entry)
 317     (define-key map [down]  'profiler-report-next-entry)
 318     (define-key map [up]    'profiler-report-previous-entry)
 319     (define-key map "\r"    'profiler-report-toggle-entry)
 320     (define-key map "\t"    'profiler-report-toggle-entry)
 321     (define-key map "i"     'profiler-report-toggle-entry)
 322     (define-key map "f"     'profiler-report-find-entry)
 323     (define-key map "j"     'profiler-report-find-entry)
 324     (define-key map [mouse-2] 'profiler-report-find-entry)
 325     (define-key map "d"     'profiler-report-describe-entry)
 326     (define-key map "C"     'profiler-report-render-calltree)
 327     (define-key map "B"     'profiler-report-render-reversed-calltree)
 328     (define-key map "A"     'profiler-report-ascending-sort)
 329     (define-key map "D"     'profiler-report-descending-sort)
 330     (define-key map "="     'profiler-report-compare-log)
 331     (define-key map (kbd "C-x C-w") 'profiler-report-write-log)
 332     (define-key map "q"     'quit-window)
 333     map))
 334
 335 (defun profiler-report-make-buffer-name (log)
 336   (let ((time (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log))))
 337     (cl-ecase (profiler-log-type log)
 338       (sample (format "*CPU-Profiler-Report %s*" time))
 339       (memory (format "*Memory-Profiler-Report %s*" time)))))
 340
 341 (defun profiler-report-setup-buffer (log)
 342   (let* ((buf-name (profiler-report-make-buffer-name log))
 343          (buffer (get-buffer-create buf-name)))
 344     (with-current-buffer buffer
 345       (profiler-report-mode)
 346       (setq profiler-report-log log
 347             profiler-report-reversed nil
 348             profiler-report-order 'descending))
 349     buffer))
 350
 351 (define-derived-mode profiler-report-mode special-mode "Profiler-Report"
 352   "Profiler Report Mode."
 353   (make-local-variable 'profiler-report-log)
 354   (make-local-variable 'profiler-report-reversed)
 355   (make-local-variable 'profiler-report-order)
 356   (use-local-map profiler-report-mode-map)
 357   (setq buffer-read-only t
 358         buffer-undo-list t
 359         truncate-lines t))
 360
 361 \f
 362
 363 ;;; Report commands
 364
 365 (defun profiler-report-calltree-at-point ()
 366   (get-text-property (point) 'calltree))
 367
 368 (defun profiler-report-move-to-entry ()
 369   (let ((point (next-single-property-change (line-beginning-position) 'entry)))
 370     (if point
 371         (goto-char point)
 372       (back-to-indentation))))
 373
 374 (defun profiler-report-next-entry ()
 375   "Move cursor to next profile entry."
 376   (interactive)
 377   (forward-line)
 378   (profiler-report-move-to-entry))
 379
 380 (defun profiler-report-previous-entry ()
 381   "Move cursor to previous profile entry."
 382   (interactive)
 383   (forward-line -1)
 384   (profiler-report-move-to-entry))
 385
 386 (defun profiler-report-expand-entry ()
 387   "Expand profile entry at point."
 388   (interactive)
 389   (save-excursion
 390     (beginning-of-line)
 391     (when (search-forward (concat profiler-report-closed-mark " ")
 392                           (line-end-position) t)
 393       (let ((tree (profiler-report-calltree-at-point)))
 394         (when tree
 395           (let ((buffer-read-only nil))
 396             (replace-match (concat profiler-report-open-mark " "))
 397             (forward-line)
 398             (profiler-report-insert-calltree-children tree)
 399             t))))))
 400
 401 (defun profiler-report-collapse-entry ()
 402   "Collpase profile entry at point."
 403   (interactive)
 404   (save-excursion
 405     (beginning-of-line)
 406     (when (search-forward (concat profiler-report-open-mark " ")
 407                           (line-end-position) t)
 408       (let* ((tree (profiler-report-calltree-at-point))
 409              (depth (profiler-calltree-depth tree))
 410              (start (line-beginning-position 2))
 411              d)
 412         (when tree
 413           (let ((buffer-read-only nil))
 414             (replace-match (concat profiler-report-closed-mark " "))
 415             (while (and (eq (forward-line) 0)
 416                         (let ((child (get-text-property (point) 'calltree)))
 417                           (and child
 418                                (numberp (setq d (profiler-calltree-depth child)))))
 419                         (> d depth)))
 420             (delete-region start (line-beginning-position)))))
 421       t)))
 422
 423 (defun profiler-report-toggle-entry ()
 424   "Expand profile entry at point if the tree is collapsed,
 425 otherwise collapse the entry."
 426   (interactive)
 427   (or (profiler-report-expand-entry)
 428       (profiler-report-collapse-entry)))
 429
 430 (defun profiler-report-find-entry (&optional event)
 431   "Find profile entry at point."
 432   (interactive (list last-nonmenu-event))
 433   (if event (posn-set-point (event-end event)))
 434   (let ((tree (profiler-report-calltree-at-point)))
 435     (when tree
 436       (let ((entry (profiler-calltree-entry tree)))
 437         (find-function entry)))))
 438
 439 (defun profiler-report-describe-entry ()
 440   "Describe profile entry at point."
 441   (interactive)
 442   (let ((tree (profiler-report-calltree-at-point)))
 443     (when tree
 444       (let ((entry (profiler-calltree-entry tree)))
 445         (require 'help-fns)
 446         (describe-function entry)))))
 447
 448 (cl-defun profiler-report-render-calltree-1 (log &key reverse (order 'descending))
 449   (let ((calltree (profiler-calltree-build profiler-report-log
 450                                            :reverse reverse)))
 451     (cl-ecase (profiler-log-type log)
 452       (sample
 453        (setq header-line-format
 454              (profiler-report-header-line-format
 455               profiler-report-sample-line-format
 456               "Function" (list "Time (ms)" "%")))
 457        (let ((predicate (cl-ecase order
 458                           (ascending 'profiler-calltree-elapsed<)
 459                           (descending 'profiler-calltree-elapsed>))))
 460          (profiler-calltree-sort calltree predicate)))
 461       (memory
 462        (setq header-line-format
 463              (profiler-report-header-line-format
 464               profiler-report-memory-line-format
 465               "Function" (list "Alloc" "%")))
 466        (let ((predicate (cl-ecase order
 467                           (ascending 'profiler-calltree-count<)
 468                           (descending 'profiler-calltree-count>))))
 469          (profiler-calltree-sort calltree predicate))))
 470     (let ((buffer-read-only nil))
 471       (erase-buffer)
 472       (profiler-report-insert-calltree-children calltree)
 473       (goto-char (point-min))
 474       (profiler-report-move-to-entry))))
 475
 476 (defun profiler-report-rerender-calltree ()
 477   (profiler-report-render-calltree-1 profiler-report-log
 478                                      :reverse profiler-report-reversed
 479                                      :order profiler-report-order))
 480
 481 (defun profiler-report-render-calltree ()
 482   "Render calltree view of the current profile."
 483   (interactive)
 484   (setq profiler-report-reversed nil)
 485   (profiler-report-rerender-calltree))
 486
 487 (defun profiler-report-render-reversed-calltree ()
 488   "Render reversed calltree view of the current profile."
 489   (interactive)
 490   (setq profiler-report-reversed t)
 491   (profiler-report-rerender-calltree))
 492
 493 (defun profiler-report-ascending-sort ()
 494   "Sort calltree view in ascending order."
 495   (interactive)
 496   (setq profiler-report-order 'ascending)
 497   (profiler-report-rerender-calltree))
 498
 499 (defun profiler-report-descending-sort ()
 500   "Sort calltree view in descending order."
 501   (interactive)
 502   (setq profiler-report-order 'descending)
 503   (profiler-report-rerender-calltree))
 504
 505 (defun profiler-report-log (log)
 506   (let ((buffer (profiler-report-setup-buffer log)))
 507     (with-current-buffer buffer
 508       (profiler-report-render-calltree))
 509     (pop-to-buffer buffer)))
 510
 511 (defun profiler-report-compare-log (buffer)
 512   "Compare current profiler log with another profiler log."
 513   (interactive (list (read-buffer "Compare to: ")))
 514   (let ((log1 (with-current-buffer buffer profiler-report-log))
 515         (log2 profiler-report-log))
 516     (profiler-report-log (profiler-log-diff log1 log2))))
 517
 518 (defun profiler-report-write-log (filename &optional confirm)
 519   "Write current profiler log into FILENAME."
 520   (interactive
 521    (list (read-file-name "Write log: " default-directory)
 522          (not current-prefix-arg)))
 523   (let ((log profiler-report-log))
 524     (with-temp-buffer
 525       (let (print-level print-length)
 526         (print log (current-buffer)))
 527       (write-file filename confirm))))
 528
 529 \f
 530
 531 ;;; Profiler commands
 532
 533 (defcustom profiler-sample-interval 10
 534   "Default sample interval in millisecond."
 535   :type 'integer
 536   :group 'profiler)
 537
 538 ;;;###autoload
 539 (defun profiler-start (mode)
 540   (interactive
 541    (list (intern (completing-read "Mode: " '("cpu" "memory" "cpu&memory")
 542                                   nil t nil nil "cpu"))))
 543   (cl-ecase mode
 544     (cpu
 545      (sample-profiler-start profiler-sample-interval)
 546      (message "CPU profiler started"))
 547     (memory
 548      (memory-profiler-start)
 549      (message "Memory profiler started"))
 550     (cpu&memory
 551      (sample-profiler-start profiler-sample-interval)
 552      (memory-profiler-start)
 553      (message "CPU and memory profiler started"))))
 554
 555 (defun profiler-stop ()
 556   (interactive)
 557   (cond
 558    ((and (sample-profiler-running-p)
 559          (memory-profiler-running-p))
 560     (sample-profiler-stop)
 561     (memory-profiler-stop)
 562     (message "CPU and memory profiler stopped"))
 563    ((sample-profiler-running-p)
 564     (sample-profiler-stop)
 565     (message "CPU profiler stopped"))
 566    ((memory-profiler-running-p)
 567     (memory-profiler-stop)
 568     (message "Memory profiler stopped"))
 569    (t
 570     (error "No profilers started"))))
 571
 572 (defun profiler-reset ()
 573   (interactive)
 574   (sample-profiler-reset)
 575   (memory-profiler-reset)
 576   t)
 577
 578 (defun profiler-report ()
 579   (interactive)
 580   (let ((sample-log (sample-profiler-log)))
 581     (when sample-log
 582       (profiler-log-fixup sample-log)
 583       (profiler-report-log sample-log)))
 584   (let ((memory-log (memory-profiler-log)))
 585     (when memory-log
 586       (profiler-log-fixup memory-log)
 587       (profiler-report-log memory-log))))
 588
 589 ;;;###autoload
 590 (defun profiler-find-log (filename)
 591   (interactive
 592    (list (read-file-name "Find log: " default-directory)))
 593   (with-temp-buffer
 594     (insert-file-contents filename)
 595     (goto-char (point-min))
 596     (let ((log (read (current-buffer))))
 597       (profiler-report-log log))))
 598
 599 (provide 'profiler)
 600 ;;; profiler.el ends here