diff options
| author | Stefan Monnier | 2012-09-26 11:19:10 -0400 |
|---|---|---|
| committer | Stefan Monnier | 2012-09-26 11:19:10 -0400 |
| commit | 3a880af4a79688e90da45311a8d85bae2d59a811 (patch) | |
| tree | 178e2f4ac5889ad1de54fc02c967f7acb377ce64 /lisp | |
| parent | 9180598cb164cf32daf0e1761a8143e720460987 (diff) | |
| parent | 234148bf943ffce55121aefc8694889eb08b0daa (diff) | |
| download | emacs-3a880af4a79688e90da45311a8d85bae2d59a811.tar.gz emacs-3a880af4a79688e90da45311a8d85bae2d59a811.zip | |
Merge profiler branch
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ChangeLog | 5 | ||||
| -rw-r--r-- | lisp/profiler.el | 665 |
2 files changed, 670 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 4599855e28d..349d74aa7d7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,8 @@ | |||
| 1 | 2012-09-26 Tomohiro Matsuyama <tomo@cx4a.org> | ||
| 2 | Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 3 | |||
| 4 | * profiler.el: New file. | ||
| 5 | |||
| 1 | 2012-09-26 Stefan Monnier <monnier@iro.umontreal.ca> | 6 | 2012-09-26 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 7 | ||
| 3 | * emacs-lisp/testcover.el (testcover-after): Add gv-expander. | 8 | * emacs-lisp/testcover.el (testcover-after): Add gv-expander. |
diff --git a/lisp/profiler.el b/lisp/profiler.el new file mode 100644 index 00000000000..5fc74573262 --- /dev/null +++ b/lisp/profiler.el | |||
| @@ -0,0 +1,665 @@ | |||
| 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 | (defcustom profiler-sample-interval 1 | ||
| 36 | "Default sample interval in millisecond." | ||
| 37 | :type 'integer | ||
| 38 | :group 'profiler) | ||
| 39 | |||
| 40 | ;;; Utilities | ||
| 41 | |||
| 42 | (defun profiler-ensure-string (object) | ||
| 43 | (cond ((stringp object) | ||
| 44 | object) | ||
| 45 | ((symbolp object) | ||
| 46 | (symbol-name object)) | ||
| 47 | ((numberp object) | ||
| 48 | (number-to-string object)) | ||
| 49 | (t | ||
| 50 | (format "%s" object)))) | ||
| 51 | |||
| 52 | (defun profiler-format (fmt &rest args) | ||
| 53 | (cl-loop for (width align subfmt) in fmt | ||
| 54 | for arg in args | ||
| 55 | for str = (cond | ||
| 56 | ((consp subfmt) | ||
| 57 | (apply 'profiler-format subfmt arg)) | ||
| 58 | ((stringp subfmt) | ||
| 59 | (format subfmt arg)) | ||
| 60 | ((and (symbolp subfmt) | ||
| 61 | (fboundp subfmt)) | ||
| 62 | (funcall subfmt arg)) | ||
| 63 | (t | ||
| 64 | (profiler-ensure-string arg))) | ||
| 65 | for len = (length str) | ||
| 66 | if (< width len) | ||
| 67 | collect (substring str 0 width) into frags | ||
| 68 | else | ||
| 69 | collect | ||
| 70 | (let ((padding (make-string (- width len) ?\s))) | ||
| 71 | (cl-ecase align | ||
| 72 | (left (concat str padding)) | ||
| 73 | (right (concat padding str)))) | ||
| 74 | into frags | ||
| 75 | finally return (apply #'concat frags))) | ||
| 76 | |||
| 77 | (defun profiler-format-percent (number divisor) | ||
| 78 | (concat (number-to-string (/ (* number 100) divisor)) "%")) | ||
| 79 | |||
| 80 | (defun profiler-format-nbytes (nbytes) | ||
| 81 | "Format NBYTES in humarn readable string." | ||
| 82 | (if (and (integerp nbytes) (> nbytes 0)) | ||
| 83 | (cl-loop with i = (% (1+ (floor (log10 nbytes))) 3) | ||
| 84 | for c in (append (number-to-string nbytes) nil) | ||
| 85 | if (= i 0) | ||
| 86 | collect ?, into s | ||
| 87 | and do (setq i 3) | ||
| 88 | collect c into s | ||
| 89 | do (cl-decf i) | ||
| 90 | finally return | ||
| 91 | (apply 'string (if (eq (car s) ?,) (cdr s) s))) | ||
| 92 | (profiler-ensure-string nbytes))) | ||
| 93 | |||
| 94 | |||
| 95 | ;;; Entries | ||
| 96 | |||
| 97 | (defun profiler-entry-format (entry) | ||
| 98 | "Format ENTRY in human readable string. ENTRY would be a | ||
| 99 | function name of a function itself." | ||
| 100 | (cond ((memq (car-safe entry) '(closure lambda)) | ||
| 101 | (format "#<lambda 0x%x>" (sxhash entry))) | ||
| 102 | ((byte-code-function-p entry) | ||
| 103 | (format "#<compiled 0x%x>" (sxhash entry))) | ||
| 104 | ((or (subrp entry) (symbolp entry) (stringp entry)) | ||
| 105 | (format "%s" entry)) | ||
| 106 | (t | ||
| 107 | (format "#<unknown 0x%x>" (sxhash entry))))) | ||
| 108 | |||
| 109 | ;;; Log data structure | ||
| 110 | |||
| 111 | ;; The C code returns the log in the form of a hash-table where the keys are | ||
| 112 | ;; vectors (of size profiler-max-stack-depth, holding truncated | ||
| 113 | ;; backtraces, where the first element is the top of the stack) and | ||
| 114 | ;; the values are integers (which count how many times this backtrace | ||
| 115 | ;; has been seen, multiplied by a "weight factor" which is either the | ||
| 116 | ;; sample-interval or the memory being allocated). | ||
| 117 | ;; We extend it by adding a few other entries to the hash-table, most notably: | ||
| 118 | ;; - Key `type' has a value indicating the kind of log (`memory' or `cpu'). | ||
| 119 | ;; - Key `timestamp' has a value giving the time when the log was obtained. | ||
| 120 | ;; - Key `diff-p' indicates if this log represents a diff between two logs. | ||
| 121 | |||
| 122 | (defun profiler-log-timestamp (log) (gethash 'timestamp log)) | ||
| 123 | (defun profiler-log-type (log) (gethash 'type log)) | ||
| 124 | (defun profiler-log-diff-p (log) (gethash 'diff-p log)) | ||
| 125 | |||
| 126 | (defun profiler-log-diff (log1 log2) | ||
| 127 | "Compare LOG1 with LOG2 and return a diff log. Both logs must | ||
| 128 | be same type." | ||
| 129 | (unless (eq (profiler-log-type log1) | ||
| 130 | (profiler-log-type log2)) | ||
| 131 | (error "Can't compare different type of logs")) | ||
| 132 | (let ((newlog (make-hash-table :test 'equal))) | ||
| 133 | ;; Make a copy of `log1' into `newlog'. | ||
| 134 | (maphash (lambda (backtrace count) (puthash backtrace count newlog)) | ||
| 135 | log1) | ||
| 136 | (puthash 'diff-p t newlog) | ||
| 137 | (maphash (lambda (backtrace count) | ||
| 138 | (when (vectorp backtrace) | ||
| 139 | (puthash backtrace (- (gethash backtrace log1 0) count) | ||
| 140 | newlog))) | ||
| 141 | log2) | ||
| 142 | newlog)) | ||
| 143 | |||
| 144 | (defun profiler-log-fixup-entry (entry) | ||
| 145 | (if (symbolp entry) | ||
| 146 | entry | ||
| 147 | (profiler-entry-format entry))) | ||
| 148 | |||
| 149 | (defun profiler-log-fixup-backtrace (backtrace) | ||
| 150 | (mapcar 'profiler-log-fixup-entry backtrace)) | ||
| 151 | |||
| 152 | (defun profiler-log-fixup (log) | ||
| 153 | "Fixup LOG so that the log could be serialized into file." | ||
| 154 | (let ((newlog (make-hash-table :test 'equal))) | ||
| 155 | (maphash (lambda (backtrace count) | ||
| 156 | (puthash (if (not (vectorp backtrace)) | ||
| 157 | backtrace | ||
| 158 | (profiler-log-fixup-backtrace backtrace)) | ||
| 159 | count newlog)) | ||
| 160 | log) | ||
| 161 | newlog)) | ||
| 162 | |||
| 163 | (defun profiler-log-write-file (log filename &optional confirm) | ||
| 164 | "Write LOG into FILENAME." | ||
| 165 | (with-temp-buffer | ||
| 166 | (let (print-level print-length) | ||
| 167 | (print (profiler-log-fixup log) (current-buffer))) | ||
| 168 | (write-file filename confirm))) | ||
| 169 | |||
| 170 | (defun profiler-log-read-file (filename) | ||
| 171 | "Read log from FILENAME." | ||
| 172 | (with-temp-buffer | ||
| 173 | (insert-file-contents filename) | ||
| 174 | (goto-char (point-min)) | ||
| 175 | (read (current-buffer)))) | ||
| 176 | |||
| 177 | |||
| 178 | ;;; Calltree data structure | ||
| 179 | |||
| 180 | (cl-defstruct (profiler-calltree (:constructor profiler-make-calltree)) | ||
| 181 | entry | ||
| 182 | (count 0) (count-percent "") | ||
| 183 | parent children) | ||
| 184 | |||
| 185 | (defun profiler-calltree-leaf-p (tree) | ||
| 186 | (null (profiler-calltree-children tree))) | ||
| 187 | |||
| 188 | (defun profiler-calltree-count< (a b) | ||
| 189 | (cond ((eq (profiler-calltree-entry a) t) t) | ||
| 190 | ((eq (profiler-calltree-entry b) t) nil) | ||
| 191 | (t (< (profiler-calltree-count a) | ||
| 192 | (profiler-calltree-count b))))) | ||
| 193 | |||
| 194 | (defun profiler-calltree-count> (a b) | ||
| 195 | (not (profiler-calltree-count< a b))) | ||
| 196 | |||
| 197 | (defun profiler-calltree-depth (tree) | ||
| 198 | (let ((parent (profiler-calltree-parent tree))) | ||
| 199 | (if (null parent) | ||
| 200 | 0 | ||
| 201 | (1+ (profiler-calltree-depth parent))))) | ||
| 202 | |||
| 203 | (defun profiler-calltree-find (tree entry) | ||
| 204 | "Return a child tree of ENTRY under TREE." | ||
| 205 | ;; OPTIMIZED | ||
| 206 | (let (result (children (profiler-calltree-children tree))) | ||
| 207 | ;; FIXME: Use `assoc'. | ||
| 208 | (while (and children (null result)) | ||
| 209 | (let ((child (car children))) | ||
| 210 | (when (equal (profiler-calltree-entry child) entry) | ||
| 211 | (setq result child)) | ||
| 212 | (setq children (cdr children)))) | ||
| 213 | result)) | ||
| 214 | |||
| 215 | (defun profiler-calltree-walk (calltree function) | ||
| 216 | (funcall function calltree) | ||
| 217 | (dolist (child (profiler-calltree-children calltree)) | ||
| 218 | (profiler-calltree-walk child function))) | ||
| 219 | |||
| 220 | (defun profiler-calltree-build-1 (tree log &optional reverse) | ||
| 221 | ;; FIXME: Do a better job of reconstructing a complete call-tree | ||
| 222 | ;; when the backtraces have been truncated. Ideally, we should be | ||
| 223 | ;; able to reduce profiler-max-stack-depth to 3 or 4 and still | ||
| 224 | ;; get a meaningful call-tree. | ||
| 225 | (maphash | ||
| 226 | (lambda (backtrace count) | ||
| 227 | (when (vectorp backtrace) | ||
| 228 | (let ((node tree) | ||
| 229 | (max (length backtrace))) | ||
| 230 | (dotimes (i max) | ||
| 231 | (let ((entry (aref backtrace (if reverse i (- max i 1))))) | ||
| 232 | (when entry | ||
| 233 | (let ((child (profiler-calltree-find node entry))) | ||
| 234 | (unless child | ||
| 235 | (setq child (profiler-make-calltree | ||
| 236 | :entry entry :parent node)) | ||
| 237 | (push child (profiler-calltree-children node))) | ||
| 238 | (cl-incf (profiler-calltree-count child) count) | ||
| 239 | (setq node child)))))))) | ||
| 240 | log)) | ||
| 241 | |||
| 242 | (defun profiler-calltree-compute-percentages (tree) | ||
| 243 | (let ((total-count 0)) | ||
| 244 | ;; FIXME: the memory profiler's total wraps around all too easily! | ||
| 245 | (dolist (child (profiler-calltree-children tree)) | ||
| 246 | (cl-incf total-count (profiler-calltree-count child))) | ||
| 247 | (unless (zerop total-count) | ||
| 248 | (profiler-calltree-walk | ||
| 249 | tree (lambda (node) | ||
| 250 | (setf (profiler-calltree-count-percent node) | ||
| 251 | (profiler-format-percent (profiler-calltree-count node) | ||
| 252 | total-count))))))) | ||
| 253 | |||
| 254 | (cl-defun profiler-calltree-build (log &key reverse) | ||
| 255 | (let ((tree (profiler-make-calltree))) | ||
| 256 | (profiler-calltree-build-1 tree log reverse) | ||
| 257 | (profiler-calltree-compute-percentages tree) | ||
| 258 | tree)) | ||
| 259 | |||
| 260 | (defun profiler-calltree-sort (tree predicate) | ||
| 261 | (let ((children (profiler-calltree-children tree))) | ||
| 262 | (setf (profiler-calltree-children tree) (sort children predicate)) | ||
| 263 | (dolist (child (profiler-calltree-children tree)) | ||
| 264 | (profiler-calltree-sort child predicate)))) | ||
| 265 | |||
| 266 | |||
| 267 | ;;; Report rendering | ||
| 268 | |||
| 269 | (defcustom profiler-report-closed-mark "+" | ||
| 270 | "An indicator of closed calltrees." | ||
| 271 | :type 'string | ||
| 272 | :group 'profiler) | ||
| 273 | |||
| 274 | (defcustom profiler-report-open-mark "-" | ||
| 275 | "An indicator of open calltrees." | ||
| 276 | :type 'string | ||
| 277 | :group 'profiler) | ||
| 278 | |||
| 279 | (defcustom profiler-report-leaf-mark " " | ||
| 280 | "An indicator of calltree leaves." | ||
| 281 | :type 'string | ||
| 282 | :group 'profiler) | ||
| 283 | |||
| 284 | (defvar profiler-report-sample-line-format | ||
| 285 | '((60 left) | ||
| 286 | (14 right ((9 right) | ||
| 287 | (5 right))))) | ||
| 288 | |||
| 289 | (defvar profiler-report-memory-line-format | ||
| 290 | '((55 left) | ||
| 291 | (19 right ((14 right profiler-format-nbytes) | ||
| 292 | (5 right))))) | ||
| 293 | |||
| 294 | (defvar-local profiler-report-log nil | ||
| 295 | "The current profiler log.") | ||
| 296 | |||
| 297 | (defvar-local profiler-report-reversed nil | ||
| 298 | "True if calltree is rendered in bottom-up. Do not touch this | ||
| 299 | variable directly.") | ||
| 300 | |||
| 301 | (defvar-local profiler-report-order nil | ||
| 302 | "The value can be `ascending' or `descending'. Do not touch | ||
| 303 | this variable directly.") | ||
| 304 | |||
| 305 | (defun profiler-report-make-entry-part (entry) | ||
| 306 | (let ((string (cond | ||
| 307 | ((eq entry t) | ||
| 308 | "Others") | ||
| 309 | ((and (symbolp entry) | ||
| 310 | (fboundp entry)) | ||
| 311 | (propertize (symbol-name entry) | ||
| 312 | 'face 'link | ||
| 313 | 'mouse-face 'highlight | ||
| 314 | 'help-echo "mouse-2 or RET jumps to definition")) | ||
| 315 | (t | ||
| 316 | (profiler-entry-format entry))))) | ||
| 317 | (propertize string 'profiler-entry entry))) | ||
| 318 | |||
| 319 | (defun profiler-report-make-name-part (tree) | ||
| 320 | (let* ((entry (profiler-calltree-entry tree)) | ||
| 321 | (depth (profiler-calltree-depth tree)) | ||
| 322 | (indent (make-string (* (1- depth) 2) ?\s)) | ||
| 323 | (mark (if (profiler-calltree-leaf-p tree) | ||
| 324 | profiler-report-leaf-mark | ||
| 325 | profiler-report-closed-mark)) | ||
| 326 | (entry (profiler-report-make-entry-part entry))) | ||
| 327 | (format "%s%s %s" indent mark entry))) | ||
| 328 | |||
| 329 | (defun profiler-report-header-line-format (fmt &rest args) | ||
| 330 | (let* ((header (apply 'profiler-format fmt args)) | ||
| 331 | (escaped (replace-regexp-in-string "%" "%%" header))) | ||
| 332 | (concat " " escaped))) | ||
| 333 | |||
| 334 | (defun profiler-report-line-format (tree) | ||
| 335 | (let ((diff-p (profiler-log-diff-p profiler-report-log)) | ||
| 336 | (name-part (profiler-report-make-name-part tree)) | ||
| 337 | (count (profiler-calltree-count tree)) | ||
| 338 | (count-percent (profiler-calltree-count-percent tree))) | ||
| 339 | (profiler-format (cl-ecase (profiler-log-type profiler-report-log) | ||
| 340 | (cpu profiler-report-sample-line-format) | ||
| 341 | (memory profiler-report-memory-line-format)) | ||
| 342 | name-part | ||
| 343 | (if diff-p | ||
| 344 | (list (if (> count 0) | ||
| 345 | (format "+%s" count) | ||
| 346 | count) | ||
| 347 | "") | ||
| 348 | (list count count-percent))))) | ||
| 349 | |||
| 350 | (defun profiler-report-insert-calltree (tree) | ||
| 351 | (let ((line (profiler-report-line-format tree))) | ||
| 352 | (insert (propertize (concat line "\n") 'calltree tree)))) | ||
| 353 | |||
| 354 | (defun profiler-report-insert-calltree-children (tree) | ||
| 355 | (mapc 'profiler-report-insert-calltree | ||
| 356 | (profiler-calltree-children tree))) | ||
| 357 | |||
| 358 | |||
| 359 | ;;; Report mode | ||
| 360 | |||
| 361 | (defvar profiler-report-mode-map | ||
| 362 | (let ((map (make-sparse-keymap))) | ||
| 363 | ;; FIXME: Add menu. | ||
| 364 | (define-key map "n" 'profiler-report-next-entry) | ||
| 365 | (define-key map "p" 'profiler-report-previous-entry) | ||
| 366 | ;; I find it annoying more than helpful to not be able to navigate | ||
| 367 | ;; normally with the cursor keys. --Stef | ||
| 368 | ;; (define-key map [down] 'profiler-report-next-entry) | ||
| 369 | ;; (define-key map [up] 'profiler-report-previous-entry) | ||
| 370 | (define-key map "\r" 'profiler-report-toggle-entry) | ||
| 371 | (define-key map "\t" 'profiler-report-toggle-entry) | ||
| 372 | (define-key map "i" 'profiler-report-toggle-entry) | ||
| 373 | (define-key map "f" 'profiler-report-find-entry) | ||
| 374 | (define-key map "j" 'profiler-report-find-entry) | ||
| 375 | (define-key map [mouse-2] 'profiler-report-find-entry) | ||
| 376 | (define-key map "d" 'profiler-report-describe-entry) | ||
| 377 | (define-key map "C" 'profiler-report-render-calltree) | ||
| 378 | (define-key map "B" 'profiler-report-render-reversed-calltree) | ||
| 379 | (define-key map "A" 'profiler-report-ascending-sort) | ||
| 380 | (define-key map "D" 'profiler-report-descending-sort) | ||
| 381 | (define-key map "=" 'profiler-report-compare-log) | ||
| 382 | (define-key map (kbd "C-x C-w") 'profiler-report-write-log) | ||
| 383 | (define-key map "q" 'quit-window) | ||
| 384 | map)) | ||
| 385 | |||
| 386 | (defun profiler-report-make-buffer-name (log) | ||
| 387 | (format "*%s-Profiler-Report %s*" | ||
| 388 | (cl-ecase (profiler-log-type log) (cpu 'CPU) (memory 'Memory)) | ||
| 389 | (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log)))) | ||
| 390 | |||
| 391 | (defun profiler-report-setup-buffer (log) | ||
| 392 | "Make a buffer for LOG and return it." | ||
| 393 | (let* ((buf-name (profiler-report-make-buffer-name log)) | ||
| 394 | (buffer (get-buffer-create buf-name))) | ||
| 395 | (with-current-buffer buffer | ||
| 396 | (profiler-report-mode) | ||
| 397 | (setq profiler-report-log log | ||
| 398 | profiler-report-reversed nil | ||
| 399 | profiler-report-order 'descending)) | ||
| 400 | buffer)) | ||
| 401 | |||
| 402 | (define-derived-mode profiler-report-mode special-mode "Profiler-Report" | ||
| 403 | "Profiler Report Mode." | ||
| 404 | (setq buffer-read-only t | ||
| 405 | buffer-undo-list t | ||
| 406 | truncate-lines t)) | ||
| 407 | |||
| 408 | |||
| 409 | ;;; Report commands | ||
| 410 | |||
| 411 | (defun profiler-report-calltree-at-point () | ||
| 412 | (get-text-property (point) 'calltree)) | ||
| 413 | |||
| 414 | (defun profiler-report-move-to-entry () | ||
| 415 | (let ((point (next-single-property-change (line-beginning-position) | ||
| 416 | 'profiler-entry))) | ||
| 417 | (if point | ||
| 418 | (goto-char point) | ||
| 419 | (back-to-indentation)))) | ||
| 420 | |||
| 421 | (defun profiler-report-next-entry () | ||
| 422 | "Move cursor to next entry." | ||
| 423 | (interactive) | ||
| 424 | (forward-line) | ||
| 425 | (profiler-report-move-to-entry)) | ||
| 426 | |||
| 427 | (defun profiler-report-previous-entry () | ||
| 428 | "Move cursor to previous entry." | ||
| 429 | (interactive) | ||
| 430 | (forward-line -1) | ||
| 431 | (profiler-report-move-to-entry)) | ||
| 432 | |||
| 433 | (defun profiler-report-expand-entry () | ||
| 434 | "Expand entry at point." | ||
| 435 | (interactive) | ||
| 436 | (save-excursion | ||
| 437 | (beginning-of-line) | ||
| 438 | (when (search-forward (concat profiler-report-closed-mark " ") | ||
| 439 | (line-end-position) t) | ||
| 440 | (let ((tree (profiler-report-calltree-at-point))) | ||
| 441 | (when tree | ||
| 442 | (let ((inhibit-read-only t)) | ||
| 443 | (replace-match (concat profiler-report-open-mark " ")) | ||
| 444 | (forward-line) | ||
| 445 | (profiler-report-insert-calltree-children tree) | ||
| 446 | t)))))) | ||
| 447 | |||
| 448 | (defun profiler-report-collapse-entry () | ||
| 449 | "Collpase entry at point." | ||
| 450 | (interactive) | ||
| 451 | (save-excursion | ||
| 452 | (beginning-of-line) | ||
| 453 | (when (search-forward (concat profiler-report-open-mark " ") | ||
| 454 | (line-end-position) t) | ||
| 455 | (let* ((tree (profiler-report-calltree-at-point)) | ||
| 456 | (depth (profiler-calltree-depth tree)) | ||
| 457 | (start (line-beginning-position 2)) | ||
| 458 | d) | ||
| 459 | (when tree | ||
| 460 | (let ((inhibit-read-only t)) | ||
| 461 | (replace-match (concat profiler-report-closed-mark " ")) | ||
| 462 | (while (and (eq (forward-line) 0) | ||
| 463 | (let ((child (get-text-property (point) 'calltree))) | ||
| 464 | (and child | ||
| 465 | (numberp (setq d (profiler-calltree-depth child))))) | ||
| 466 | (> d depth))) | ||
| 467 | (delete-region start (line-beginning-position))))) | ||
| 468 | t))) | ||
| 469 | |||
| 470 | (defun profiler-report-toggle-entry () | ||
| 471 | "Expand entry at point if the tree is collapsed, | ||
| 472 | otherwise collapse." | ||
| 473 | (interactive) | ||
| 474 | (or (profiler-report-expand-entry) | ||
| 475 | (profiler-report-collapse-entry))) | ||
| 476 | |||
| 477 | (defun profiler-report-find-entry (&optional event) | ||
| 478 | "Find entry at point." | ||
| 479 | (interactive (list last-nonmenu-event)) | ||
| 480 | (if event (posn-set-point (event-end event))) | ||
| 481 | (let ((tree (profiler-report-calltree-at-point))) | ||
| 482 | (when tree | ||
| 483 | (let ((entry (profiler-calltree-entry tree))) | ||
| 484 | (find-function entry))))) | ||
| 485 | |||
| 486 | (defun profiler-report-describe-entry () | ||
| 487 | "Describe entry at point." | ||
| 488 | (interactive) | ||
| 489 | (let ((tree (profiler-report-calltree-at-point))) | ||
| 490 | (when tree | ||
| 491 | (let ((entry (profiler-calltree-entry tree))) | ||
| 492 | (require 'help-fns) | ||
| 493 | (describe-function entry))))) | ||
| 494 | |||
| 495 | (cl-defun profiler-report-render-calltree-1 | ||
| 496 | (log &key reverse (order 'descending)) | ||
| 497 | (let ((calltree (profiler-calltree-build profiler-report-log | ||
| 498 | :reverse reverse))) | ||
| 499 | (setq header-line-format | ||
| 500 | (cl-ecase (profiler-log-type log) | ||
| 501 | (cpu | ||
| 502 | (profiler-report-header-line-format | ||
| 503 | profiler-report-sample-line-format | ||
| 504 | "Function" (list "Time (ms)" "%"))) | ||
| 505 | (memory | ||
| 506 | (profiler-report-header-line-format | ||
| 507 | profiler-report-memory-line-format | ||
| 508 | "Function" (list "Bytes" "%"))))) | ||
| 509 | (let ((predicate (cl-ecase order | ||
| 510 | (ascending #'profiler-calltree-count<) | ||
| 511 | (descending #'profiler-calltree-count>)))) | ||
| 512 | (profiler-calltree-sort calltree predicate)) | ||
| 513 | (let ((inhibit-read-only t)) | ||
| 514 | (erase-buffer) | ||
| 515 | (profiler-report-insert-calltree-children calltree) | ||
| 516 | (goto-char (point-min)) | ||
| 517 | (profiler-report-move-to-entry)))) | ||
| 518 | |||
| 519 | (defun profiler-report-rerender-calltree () | ||
| 520 | (profiler-report-render-calltree-1 profiler-report-log | ||
| 521 | :reverse profiler-report-reversed | ||
| 522 | :order profiler-report-order)) | ||
| 523 | |||
| 524 | (defun profiler-report-render-calltree () | ||
| 525 | "Render calltree view." | ||
| 526 | (interactive) | ||
| 527 | (setq profiler-report-reversed nil) | ||
| 528 | (profiler-report-rerender-calltree)) | ||
| 529 | |||
| 530 | (defun profiler-report-render-reversed-calltree () | ||
| 531 | "Render reversed calltree view." | ||
| 532 | (interactive) | ||
| 533 | (setq profiler-report-reversed t) | ||
| 534 | (profiler-report-rerender-calltree)) | ||
| 535 | |||
| 536 | (defun profiler-report-ascending-sort () | ||
| 537 | "Sort calltree view in ascending order." | ||
| 538 | (interactive) | ||
| 539 | (setq profiler-report-order 'ascending) | ||
| 540 | (profiler-report-rerender-calltree)) | ||
| 541 | |||
| 542 | (defun profiler-report-descending-sort () | ||
| 543 | "Sort calltree view in descending order." | ||
| 544 | (interactive) | ||
| 545 | (setq profiler-report-order 'descending) | ||
| 546 | (profiler-report-rerender-calltree)) | ||
| 547 | |||
| 548 | (defun profiler-report-log (log) | ||
| 549 | (let ((buffer (profiler-report-setup-buffer log))) | ||
| 550 | (with-current-buffer buffer | ||
| 551 | (profiler-report-render-calltree)) | ||
| 552 | (pop-to-buffer buffer))) | ||
| 553 | |||
| 554 | (defun profiler-report-compare-log (buffer) | ||
| 555 | "Compare the current profiler log with another." | ||
| 556 | (interactive (list (read-buffer "Compare to: "))) | ||
| 557 | (let* ((log1 (with-current-buffer buffer profiler-report-log)) | ||
| 558 | (log2 profiler-report-log) | ||
| 559 | (diff-log (profiler-log-diff log1 log2))) | ||
| 560 | (profiler-report-log diff-log))) | ||
| 561 | |||
| 562 | (defun profiler-report-write-log (filename &optional confirm) | ||
| 563 | "Write the current profiler log into FILENAME." | ||
| 564 | (interactive | ||
| 565 | (list (read-file-name "Write log: " default-directory) | ||
| 566 | (not current-prefix-arg))) | ||
| 567 | (profiler-log-write-file profiler-report-log | ||
| 568 | filename | ||
| 569 | confirm)) | ||
| 570 | |||
| 571 | |||
| 572 | ;;; Profiler commands | ||
| 573 | |||
| 574 | ;;;###autoload | ||
| 575 | (defun profiler-start (mode) | ||
| 576 | "Start/restart profilers. | ||
| 577 | MODE can be one of `cpu', `mem', or `cpu+mem'. | ||
| 578 | If MODE is `cpu' or `cpu+mem', time-based profiler will be started. | ||
| 579 | Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started." | ||
| 580 | (interactive | ||
| 581 | (list (if (not (fboundp 'profiler-cpu-start)) 'mem | ||
| 582 | (intern (completing-read "Mode (default cpu): " | ||
| 583 | '("cpu" "mem" "cpu+mem") | ||
| 584 | nil t nil nil "cpu"))))) | ||
| 585 | (cl-ecase mode | ||
| 586 | (cpu | ||
| 587 | (profiler-cpu-start profiler-sample-interval) | ||
| 588 | (message "CPU profiler started")) | ||
| 589 | (mem | ||
| 590 | (profiler-memory-start) | ||
| 591 | (message "Memory profiler started")) | ||
| 592 | (cpu+mem | ||
| 593 | (profiler-cpu-start profiler-sample-interval) | ||
| 594 | (profiler-memory-start) | ||
| 595 | (message "CPU and memory profiler started")))) | ||
| 596 | |||
| 597 | (defun profiler-stop () | ||
| 598 | "Stop started profilers. Profiler logs will be kept." | ||
| 599 | (interactive) | ||
| 600 | (let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop))) | ||
| 601 | (mem (profiler-memory-stop))) | ||
| 602 | (message "%s profiler stopped" | ||
| 603 | (cond ((and mem cpu) "CPU and memory") | ||
| 604 | (mem "Memory") | ||
| 605 | (cpu "CPU") | ||
| 606 | (t "No"))))) | ||
| 607 | |||
| 608 | (defun profiler-reset () | ||
| 609 | "Reset profiler log." | ||
| 610 | (interactive) | ||
| 611 | (when (fboundp 'profiler-cpu-log) | ||
| 612 | (ignore (profiler-cpu-log))) | ||
| 613 | (ignore (profiler-memory-log)) | ||
| 614 | t) | ||
| 615 | |||
| 616 | (defun profiler--report-cpu () | ||
| 617 | (let ((log (if (fboundp 'profiler-cpu-log) (profiler-cpu-log)))) | ||
| 618 | (when log | ||
| 619 | (puthash 'type 'cpu log) | ||
| 620 | (puthash 'timestamp (current-time) log) | ||
| 621 | (profiler-report-log log)))) | ||
| 622 | |||
| 623 | (defun profiler--report-memory () | ||
| 624 | (let ((log (profiler-memory-log))) | ||
| 625 | (when log | ||
| 626 | (puthash 'type 'memory log) | ||
| 627 | (puthash 'timestamp (current-time) log) | ||
| 628 | (profiler-report-log log)))) | ||
| 629 | |||
| 630 | (defun profiler-report () | ||
| 631 | "Report profiling results." | ||
| 632 | (interactive) | ||
| 633 | (profiler--report-cpu) | ||
| 634 | (profiler--report-memory)) | ||
| 635 | |||
| 636 | ;;;###autoload | ||
| 637 | (defun profiler-find-log (filename) | ||
| 638 | "Read a profiler log from FILENAME and report it." | ||
| 639 | (interactive | ||
| 640 | (list (read-file-name "Find log: " default-directory))) | ||
| 641 | (profiler-report-log (profiler-log-read-file filename))) | ||
| 642 | |||
| 643 | |||
| 644 | ;;; Profiling helpers | ||
| 645 | |||
| 646 | ;; (cl-defmacro with-sample-profiling ((&key interval) &rest body) | ||
| 647 | ;; `(unwind-protect | ||
| 648 | ;; (progn | ||
| 649 | ;; (ignore (profiler-cpu-log)) | ||
| 650 | ;; (profiler-cpu-start ,interval) | ||
| 651 | ;; ,@body) | ||
| 652 | ;; (profiler-cpu-stop) | ||
| 653 | ;; (profiler--report-cpu))) | ||
| 654 | |||
| 655 | ;; (defmacro with-memory-profiling (&rest body) | ||
| 656 | ;; `(unwind-protect | ||
| 657 | ;; (progn | ||
| 658 | ;; (ignore (profiler-memory-log)) | ||
| 659 | ;; (profiler-memory-start) | ||
| 660 | ;; ,@body) | ||
| 661 | ;; (profiler-memory-stop) | ||
| 662 | ;; (profiler--report-memory))) | ||
| 663 | |||
| 664 | (provide 'profiler) | ||
| 665 | ;;; profiler.el ends here | ||