Commit 0efc778b authored by Tomohiro Matsuyama's avatar Tomohiro Matsuyama
Browse files

profiler: Refactoring and documentation.

parent 12b3895d
......@@ -33,13 +33,17 @@
:prefix "profiler-")
;;; Utilities
(defun profiler-ensure-string (object)
(if (stringp object)
object
(format "%s" object)))
(cond ((stringp object)
object)
((symbolp object)
(symbol-name object))
((numberp object)
(number-to-string object))
(t
(format "%s" object))))
(defun profiler-format (fmt &rest args)
(cl-loop for (width align subfmt) in fmt
......@@ -66,7 +70,11 @@
into frags
finally return (apply #'concat frags)))
(defun profiler-format-percent (number divisor)
(concat (number-to-string (/ (* number 100) divisor)) "%"))
(defun profiler-format-nbytes (nbytes)
"Format NBYTES in humarn readable string."
(if (and (integerp nbytes) (> nbytes 0))
(cl-loop with i = (% (1+ (floor (log10 nbytes))) 3)
for c in (append (number-to-string nbytes) nil)
......@@ -80,18 +88,45 @@
(profiler-ensure-string nbytes)))
;;; Entries
(defun profiler-entry= (entry1 entry2)
"Return t if ENTRY1 and ENTRY2 are same."
(or (eq entry1 entry2)
(and (stringp entry1)
(stringp entry2)
(string= entry1 entry2))))
(defun profiler-entry-format (entry)
"Format ENTRY in human readable string. ENTRY would be a
function name of a function itself."
(cond ((and (consp entry)
(or (eq (car entry) 'lambda)
(eq (car entry) 'closure)))
(format "#<closure 0x%x>" (sxhash entry)))
((eq (type-of entry) 'compiled-function)
(format "#<compiled 0x%x>" (sxhash entry)))
((subrp entry)
(subr-name entry))
((symbolp entry)
(symbol-name entry))
((stringp entry)
entry)
(t
(format "#<unknown 0x%x>" (sxhash entry)))))
;;; Backtrace data structure
(defun profiler-backtrace-reverse (backtrace)
(cl-case (car backtrace)
((t gc)
;; Make sure Others node and GC node always be at top.
(cons (car backtrace)
(reverse (cdr backtrace))))
(t (reverse backtrace))))
;;; Slot data structure
(cl-defstruct (profiler-slot (:type list)
......@@ -99,7 +134,6 @@
backtrace count elapsed)
;;; Log data structure
(cl-defstruct (profiler-log (:type list)
......@@ -107,7 +141,8 @@
type diff-p timestamp slots)
(defun profiler-log-diff (log1 log2)
;; FIXME zeros
"Compare LOG1 with LOG2 and return a diff log. Both logs must
be same type."
(unless (eq (profiler-log-type log1)
(profiler-log-type log2))
(error "Can't compare different type of logs"))
......@@ -122,35 +157,51 @@
:timestamp (current-time)
:slots slots)))
(defun profiler-log-fixup-entry (entry)
(if (symbolp entry)
entry
(profiler-entry-format entry)))
(defun profiler-log-fixup-backtrace (backtrace)
(mapcar 'profiler-log-fixup-entry backtrace))
(defun profiler-log-fixup-slot (slot)
(let ((backtrace (profiler-slot-backtrace slot)))
(profiler-make-slot :backtrace (profiler-log-fixup-backtrace backtrace)
:count (profiler-slot-count slot)
:elapsed (profiler-slot-elapsed slot))))
(defun profiler-log-fixup (log)
"Fixup LOG so that the log could be serialized into file."
(let ((fixup-entry
(lambda (entry)
(cond
((and (consp entry)
(or (eq (car entry) 'lambda)
(eq (car entry) 'closure)))
(format "#<closure 0x%x>" (sxhash entry)))
((eq (type-of entry) 'compiled-function)
(format "#<compiled 0x%x>" (sxhash entry)))
((subrp entry)
(subr-name entry))
((or (symbolp entry) (stringp entry))
entry)
(t
(format "#<unknown 0x%x>" (sxhash entry)))))))
(dolist (slot (profiler-log-slots log))
(setf (profiler-slot-backtrace slot)
(mapcar fixup-entry (profiler-slot-backtrace slot))))))
(cl-loop for slot in (profiler-log-slots log)
collect (profiler-log-fixup-slot slot) into slots
finally return
(profiler-make-log :type (profiler-log-type log)
:diff-p (profiler-log-diff-p log)
:timestamp (profiler-log-timestamp log)
:slots slots)))
(defun profiler-log-write-file (log filename &optional confirm)
"Write LOG into FILENAME."
(with-temp-buffer
(let (print-level print-length)
(print (profiler-log-fixup log) (current-buffer)))
(write-file filename confirm)))
(defun profiler-log-read-file (filename)
"Read log from FILENAME."
(with-temp-buffer
(insert-file-contents filename)
(goto-char (point-min))
(read (current-buffer))))
;;; Calltree data structure
(cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
entry
(count 0) count-percent
(elapsed 0) elapsed-percent
(count 0) (count-percent "")
(elapsed 0) (elapsed-percent "")
parent children)
(defun profiler-calltree-leaf-p (tree)
......@@ -185,14 +236,20 @@
(1+ (profiler-calltree-depth parent)))))
(defun profiler-calltree-find (tree entry)
(cl-dolist (child (profiler-calltree-children tree))
(when (equal (profiler-calltree-entry child) entry)
(cl-return child))))
(defun profiler-calltree-walk (calltree function)
(funcall function calltree)
"Return a child tree of ENTRY under TREE."
;; OPTIMIZED
(let (result (children (profiler-calltree-children tree)))
(while (and children (null result))
(let ((child (car children)))
(when (profiler-entry= (profiler-calltree-entry child) entry)
(setq result child))
(setq children (cdr children))))
result))
(defun profiler-calltree-walk (calltree function &rest args)
(apply function calltree args)
(dolist (child (profiler-calltree-children calltree))
(profiler-calltree-walk child function)))
(apply 'profiler-calltree-walk child function args)))
(defun profiler-calltree-build-1 (tree log &optional reverse)
(dolist (slot (profiler-log-slots log))
......@@ -211,6 +268,16 @@
(cl-incf (profiler-calltree-elapsed child) elapsed)
(setq node child))))))
(defun profiler-calltree-compute-percentages-1 (node total-count total-elapsed)
(unless (zerop total-count)
(setf (profiler-calltree-count-percent node)
(profiler-format-percent (profiler-calltree-count node)
total-count)))
(unless (zerop total-elapsed)
(setf (profiler-calltree-elapsed-percent node)
(profiler-format-percent (profiler-calltree-elapsed node)
total-elapsed))))
(defun profiler-calltree-compute-percentages (tree)
(let ((total-count 0)
(total-elapsed 0))
......@@ -220,22 +287,10 @@
(cl-incf total-count (profiler-calltree-count child))
(cl-incf total-elapsed (profiler-calltree-elapsed child))))
(dolist (child (profiler-calltree-children tree))
(if (eq (profiler-calltree-entry child) 'gc)
(setf (profiler-calltree-count-percent child) ""
(profiler-calltree-elapsed-percent child) "")
(unless (eq (profiler-calltree-entry child) 'gc)
(profiler-calltree-walk
child
(lambda (node)
(unless (zerop total-count)
(setf (profiler-calltree-count-percent node)
(format "%s%%"
(/ (* (profiler-calltree-count node) 100)
total-count))))
(unless (zerop total-elapsed)
(setf (profiler-calltree-elapsed-percent node)
(format "%s%%"
(/ (* (profiler-calltree-elapsed node) 100)
total-elapsed))))))))))
child 'profiler-calltree-compute-percentages-1
total-count total-elapsed)))))
(cl-defun profiler-calltree-build (log &key reverse)
(let ((tree (profiler-make-calltree)))
......@@ -250,7 +305,6 @@
(profiler-calltree-sort child predicate))))
;;; Report rendering
(defcustom profiler-report-closed-mark "+"
......@@ -278,25 +332,31 @@
(19 right ((14 right profiler-format-nbytes)
(5 right)))))
(defvar profiler-report-log nil)
(defvar profiler-report-reversed nil)
(defvar profiler-report-order nil)
(defvar profiler-report-log nil
"The current profiler log.")
(defvar profiler-report-reversed nil
"True if calltree is rendered in bottom-up. Do not touch this
variable directly.")
(defvar profiler-report-order nil
"The value can be `ascending' or `descending'. Do not touch
this variable directly.")
(defun profiler-report-make-entry-part (entry)
(let ((string
(cond
((eq entry t)
"Others")
((eq entry 'gc)
"Garbage Collection")
((and (symbolp entry)
(fboundp entry))
(propertize (symbol-name entry)
'face 'link
'mouse-face 'highlight
'help-echo "mouse-2 or RET jumps to definition"))
(t
(profiler-ensure-string entry)))))
(let ((string (cond
((eq entry t)
"Others")
((eq entry 'gc)
"Garbage Collection")
((and (symbolp entry)
(fboundp entry))
(propertize (symbol-name entry)
'face 'link
'mouse-face 'highlight
'help-echo "mouse-2 or RET jumps to definition"))
(t
(profiler-entry-format entry)))))
(propertize string 'entry entry)))
(defun profiler-report-make-name-part (tree)
......@@ -352,7 +412,6 @@
(profiler-calltree-children tree)))
;;; Report mode
(defvar profiler-report-mode-map
......@@ -384,6 +443,7 @@
(memory (format "*Memory-Profiler-Report %s*" time)))))
(defun profiler-report-setup-buffer (log)
"Make a buffer for LOG and return it."
(let* ((buf-name (profiler-report-make-buffer-name log))
(buffer (get-buffer-create buf-name)))
(with-current-buffer buffer
......@@ -404,7 +464,6 @@
truncate-lines t))
;;; Report commands
(defun profiler-report-calltree-at-point ()
......@@ -417,19 +476,19 @@
(back-to-indentation))))
(defun profiler-report-next-entry ()
"Move cursor to next profile entry."
"Move cursor to next entry."
(interactive)
(forward-line)
(profiler-report-move-to-entry))
(defun profiler-report-previous-entry ()
"Move cursor to previous profile entry."
"Move cursor to previous entry."
(interactive)
(forward-line -1)
(profiler-report-move-to-entry))
(defun profiler-report-expand-entry ()
"Expand profile entry at point."
"Expand entry at point."
(interactive)
(save-excursion
(beginning-of-line)
......@@ -444,7 +503,7 @@
t))))))
(defun profiler-report-collapse-entry ()
"Collpase profile entry at point."
"Collpase entry at point."
(interactive)
(save-excursion
(beginning-of-line)
......@@ -466,14 +525,14 @@
t)))
(defun profiler-report-toggle-entry ()
"Expand profile entry at point if the tree is collapsed,
otherwise collapse the entry."
"Expand entry at point if the tree is collapsed,
otherwise collapse."
(interactive)
(or (profiler-report-expand-entry)
(profiler-report-collapse-entry)))
(defun profiler-report-find-entry (&optional event)
"Find profile entry at point."
"Find entry at point."
(interactive (list last-nonmenu-event))
(if event (posn-set-point (event-end event)))
(let ((tree (profiler-report-calltree-at-point)))
......@@ -482,7 +541,7 @@ otherwise collapse the entry."
(find-function entry)))))
(defun profiler-report-describe-entry ()
"Describe profile entry at point."
"Describe entry at point."
(interactive)
(let ((tree (profiler-report-calltree-at-point)))
(when tree
......@@ -524,13 +583,13 @@ otherwise collapse the entry."
:order profiler-report-order))
(defun profiler-report-render-calltree ()
"Render calltree view of the current profile."
"Render calltree view."
(interactive)
(setq profiler-report-reversed nil)
(profiler-report-rerender-calltree))
(defun profiler-report-render-reversed-calltree ()
"Render reversed calltree view of the current profile."
"Render reversed calltree view."
(interactive)
(setq profiler-report-reversed t)
(profiler-report-rerender-calltree))
......@@ -554,25 +613,23 @@ otherwise collapse the entry."
(pop-to-buffer buffer)))
(defun profiler-report-compare-log (buffer)
"Compare current profiler log with another profiler log."
"Compare the current profiler log with another."
(interactive (list (read-buffer "Compare to: ")))
(let ((log1 (with-current-buffer buffer profiler-report-log))
(log2 profiler-report-log))
(profiler-report-log (profiler-log-diff log1 log2))))
(let* ((log1 (with-current-buffer buffer profiler-report-log))
(log2 profiler-report-log)
(diff-log (profiler-log-diff log1 log2)))
(profiler-report-log diff-log)))
(defun profiler-report-write-log (filename &optional confirm)
"Write current profiler log into FILENAME."
"Write the current profiler log into FILENAME."
(interactive
(list (read-file-name "Write log: " default-directory)
(not current-prefix-arg)))
(let ((log profiler-report-log))
(with-temp-buffer
(let (print-level print-length)
(print log (current-buffer)))
(write-file filename confirm))))
(profiler-log-write-file profiler-report-log
filename
confirm))
;;; Profiler commands
(defcustom profiler-sample-interval 10
......@@ -582,6 +639,10 @@ otherwise collapse the entry."
;;;###autoload
(defun profiler-start (mode)
"Start/restart profilers. MODE can be one of `cpu', `mem',
and `cpu+mem'. If MODE is `cpu' or `cpu+mem', sample profiler
will be started. Also, if MODE is `mem' or `cpu+mem', then
memory profiler will be started."
(interactive
(list (intern (completing-read "Mode: " '("cpu" "mem" "cpu+mem")
nil t nil nil "cpu"))))
......@@ -598,6 +659,7 @@ otherwise collapse the entry."
(message "CPU and memory profiler started"))))
(defun profiler-stop ()
"Stop started profilers. Profiler logs will be kept."
(interactive)
(cond
((and (sample-profiler-running-p)
......@@ -615,6 +677,7 @@ otherwise collapse the entry."
(error "No profilers started"))))
(defun profiler-reset ()
"Reset profiler log."
(interactive)
(sample-profiler-reset)
(memory-profiler-reset)
......@@ -623,32 +686,27 @@ otherwise collapse the entry."
(defun sample-profiler-report ()
(let ((sample-log (sample-profiler-log)))
(when sample-log
(profiler-log-fixup sample-log)
(profiler-report-log sample-log))))
(defun memory-profiler-report ()
(let ((memory-log (memory-profiler-log)))
(when memory-log
(profiler-log-fixup memory-log)
(profiler-report-log memory-log))))
(defun profiler-report ()
"Report profiling results."
(interactive)
(sample-profiler-report)
(memory-profiler-report))
;;;###autoload
(defun profiler-find-log (filename)
"Read a profiler log from FILENAME and report it."
(interactive
(list (read-file-name "Find log: " default-directory)))
(with-temp-buffer
(insert-file-contents filename)
(goto-char (point-min))
(let ((log (read (current-buffer))))
(profiler-report-log log))))
(profiler-report-log (profiler-log-read-file filename)))
;;; Profiling helpers
(cl-defmacro with-sample-profiling ((&key (interval profiler-sample-interval)) &rest body)
......
......@@ -3530,9 +3530,9 @@ void syms_of_dbusbind (void);
#endif
/* Defined in profiler.c */
extern int sample_profiler_running;
extern int memory_profiler_running;
extern int is_in_trace;
extern bool sample_profiler_running;
extern bool memory_profiler_running;
extern bool is_in_trace;
extern Lisp_Object Qgc;
extern void malloc_probe (size_t);
extern void gc_probe (size_t, size_t);
......
/* GNU Emacs profiler implementation.
/* Profiler implementation.
Copyright (C) 2012 Free Software Foundation, Inc.
......@@ -25,19 +25,28 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#include <setjmp.h>
#include "lisp.h"
int is_in_trace;
/* True if sampling profiler is running. */
bool sample_profiler_running;
/* True if memory profiler is running. */
bool memory_profiler_running;
/* True during tracing. */
bool is_in_trace;
/* Tag for GC entry. */
Lisp_Object Qgc;
static void sigprof_handler (int, siginfo_t *, void *);
static void block_sigprof (void);
static void unblock_sigprof (void);
int sample_profiler_running;
int memory_profiler_running;
/* Filters */
/* Pattern matching. */
enum pattern_type
{
......@@ -164,6 +173,7 @@ pattern_match (struct pattern *pattern, const char *string)
}
}
#if 0
static int
match (const char *pattern, const char *string)
{
......@@ -174,7 +184,6 @@ match (const char *pattern, const char *string)
return res;
}
#if 0
static void
should_match (const char *pattern, const char *string)
{
......@@ -222,8 +231,14 @@ pattern_match_tests (void)
}
#endif
/* Filters. */
static struct pattern *filter_pattern;
/* Set the current filter pattern. If PATTERN is null, unset the
current filter pattern instead. */
static void
set_filter_pattern (const char *pattern)
{
......@@ -235,13 +250,17 @@ set_filter_pattern (const char *pattern)
free_pattern (filter_pattern);
filter_pattern = 0;
}
if (!pattern) return;
filter_pattern = parse_pattern (pattern);
if (pattern)
filter_pattern = parse_pattern (pattern);
if (sample_profiler_running)
unblock_sigprof ();
}
/* Return true if the current filter pattern is matched with FUNCTION.
FUNCTION should be a symbol or a subroutine, otherwise return
false. */
static int
apply_filter_1 (Lisp_Object function)
{
......@@ -260,6 +279,9 @@ apply_filter_1 (Lisp_Object function)
return pattern_match (filter_pattern, name);
}
/* Return true if the current filter pattern is matched with at least
one entry in BACKLIST. */
static int
apply_filter (struct backtrace *backlist)
{
......@@ -275,12 +297,24 @@ apply_filter (struct backtrace *backlist)
DEFUN ("profiler-set-filter-pattern",
Fprofiler_set_filter_pattern, Sprofiler_set_filter_pattern,
1, 1, "sPattern: ",
doc: /* FIXME */)
doc: /* Set the current filter pattern. PATTERN can contain
one or two wildcards (*) as follows:
- foo
- *foo
- foo*
- *foo*
- foo*bar
If PATTERN is nil or an empty string, then unset the current filter
pattern. */)
(Lisp_Object pattern)
{
if (NILP (pattern))
if (NILP (pattern)
|| (STRINGP (pattern) && !SREF (pattern, 0)))
{
set_filter_pattern (0);
message ("Profiler filter pattern unset");
return Qt;
}
else if (!STRINGP (pattern))
......@@ -292,8 +326,8 @@ DEFUN ("profiler-set-filter-pattern",
}
/* Backtraces. */
/* Backtraces */
static Lisp_Object
make_backtrace (int size)
......@@ -339,6 +373,8 @@ backtrace_object_1 (Lisp_Object backtrace, int i)
return Fcons (AREF (backtrace, i), backtrace_object_1 (backtrace, i + 1));
}
/* Convert BACKTRACE to a list. */
static Lisp_Object
backtrace_object (Lisp_Object backtrace)
{
......@@ -346,15 +382,24 @@ backtrace_object (Lisp_Object backtrace)
}
/* Slots. */