Merge from emacs-24; up to 2012-05-07T21:26:08Z!rgm@gnu.org
[bpt/emacs.git] / 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 (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 \f
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 \f
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 \f
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 \f
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 \f
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 \f
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 \f
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