:group 'lisp
:prefix "profiler-")
-\f
+(defcustom profiler-sample-interval 1
+ "Default sample interval in millisecond."
+ :type 'integer
+ :group 'profiler)
+
;;; Utilities
(defun profiler-ensure-string (object)
\f
;;; 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)
+ (cond ((memq (car-safe entry) '(closure lambda))
+ (format "#<lambda 0x%x>" (sxhash entry)))
+ ((byte-code-function-p entry)
(format "#<compiled 0x%x>" (sxhash entry)))
- ((subrp entry)
- (subr-name entry))
- ((symbolp entry)
- (symbol-name entry))
- ((stringp entry)
- entry)
+ ((or (subrp entry) (symbolp entry) (stringp entry))
+ (format "%s" entry))
(t
(format "#<unknown 0x%x>" (sxhash entry)))))
-\f
-;;; 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))))
-
-\f
-;;; Slot data structure
-
-(cl-defstruct (profiler-slot (:type list)
- (:constructor profiler-make-slot))
- backtrace count elapsed)
-
-\f
;;; Log data structure
-(cl-defstruct (profiler-log (:type list)
- (:constructor profiler-make-log))
- type diff-p timestamp slots)
+;; The C code returns the log in the form of a hash-table where the keys are
+;; vectors (of size profiler-max-stack-depth, holding truncated
+;; backtraces, where the first element is the top of the stack) and
+;; the values are integers (which count how many times this backtrace
+;; has been seen, multiplied by a "weight factor" which is either the
+;; sample-interval or the memory being allocated).
+;; We extend it by adding a few other entries to the hash-table, most notably:
+;; - Key `type' has a value indicating the kind of log (`memory' or `cpu').
+;; - Key `timestamp' has a value giving the time when the log was obtained.
+;; - Key `diff-p' indicates if this log represents a diff between two logs.
+
+(defun profiler-log-timestamp (log) (gethash 'timestamp log))
+(defun profiler-log-type (log) (gethash 'type log))
+(defun profiler-log-diff-p (log) (gethash 'diff-p log))
(defun profiler-log-diff (log1 log2)
"Compare LOG1 with LOG2 and return a diff log. Both logs must
(unless (eq (profiler-log-type log1)
(profiler-log-type log2))
(error "Can't compare different type of logs"))
- (let ((slots (profiler-log-slots log2)))
- (dolist (slot (profiler-log-slots log1))
- (push (profiler-make-slot :backtrace (profiler-slot-backtrace slot)
- :count (- (profiler-slot-count slot))
- :elapsed (- (profiler-slot-elapsed slot)))
- slots))
- (profiler-make-log :type (profiler-log-type log1)
- :diff-p t
- :timestamp (current-time)
- :slots slots)))
+ (let ((newlog (make-hash-table :test 'equal)))
+ ;; Make a copy of `log1' into `newlog'.
+ (maphash (lambda (backtrace count) (puthash backtrace count newlog))
+ log1)
+ (puthash 'diff-p t newlog)
+ (maphash (lambda (backtrace count)
+ (when (vectorp backtrace)
+ (puthash backtrace (- (gethash backtrace log1 0) count)
+ newlog)))
+ log2)
+ newlog))
(defun profiler-log-fixup-entry (entry)
(if (symbolp 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."
- (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)))
+ (let ((newlog (make-hash-table :test 'equal)))
+ (maphash (lambda (backtrace count)
+ (puthash (if (not (vectorp backtrace))
+ backtrace
+ (profiler-log-fixup-backtrace backtrace))
+ count newlog))
+ log)
+ newlog))
(defun profiler-log-write-file (log filename &optional confirm)
"Write LOG into FILENAME."
(cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
entry
(count 0) (count-percent "")
- (elapsed 0) (elapsed-percent "")
parent children)
(defun profiler-calltree-leaf-p (tree)
(defun profiler-calltree-count< (a b)
(cond ((eq (profiler-calltree-entry a) t) t)
((eq (profiler-calltree-entry b) t) nil)
- ((eq (profiler-calltree-entry a) 'gc) t)
- ((eq (profiler-calltree-entry b) 'gc) nil)
(t (< (profiler-calltree-count a)
(profiler-calltree-count b)))))
(defun profiler-calltree-count> (a b)
(not (profiler-calltree-count< a b)))
-(defun profiler-calltree-elapsed< (a b)
- (cond ((eq (profiler-calltree-entry a) t) t)
- ((eq (profiler-calltree-entry b) t) nil)
- ((eq (profiler-calltree-entry a) 'gc) t)
- ((eq (profiler-calltree-entry b) 'gc) nil)
- (t (< (profiler-calltree-elapsed a)
- (profiler-calltree-elapsed b)))))
-
-(defun profiler-calltree-elapsed> (a b)
- (not (profiler-calltree-elapsed< a b)))
-
(defun profiler-calltree-depth (tree)
(let ((parent (profiler-calltree-parent tree)))
(if (null parent)
"Return a child tree of ENTRY under TREE."
;; OPTIMIZED
(let (result (children (profiler-calltree-children tree)))
+ ;; FIXME: Use `assoc'.
(while (and children (null result))
(let ((child (car children)))
- (when (profiler-entry= (profiler-calltree-entry child) entry)
+ (when (equal (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)
+(defun profiler-calltree-walk (calltree function)
+ (funcall function calltree)
(dolist (child (profiler-calltree-children calltree))
- (apply 'profiler-calltree-walk child function args)))
+ (profiler-calltree-walk child function)))
(defun profiler-calltree-build-1 (tree log &optional reverse)
- (dolist (slot (profiler-log-slots log))
- (let ((backtrace (profiler-slot-backtrace slot))
- (count (profiler-slot-count slot))
- (elapsed (profiler-slot-elapsed slot))
- (node tree))
- (dolist (entry (if reverse
- backtrace
- (profiler-backtrace-reverse backtrace)))
- (let ((child (profiler-calltree-find node entry)))
- (unless child
- (setq child (profiler-make-calltree :entry entry :parent node))
- (push child (profiler-calltree-children node)))
- (cl-incf (profiler-calltree-count child) count)
- (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))))
+ (maphash
+ (lambda (backtrace count)
+ (when (vectorp backtrace)
+ (let ((node tree)
+ (max (length backtrace)))
+ (dotimes (i max)
+ (let ((entry (aref backtrace (if reverse i (- max i 1)))))
+ (when entry
+ (let ((child (profiler-calltree-find node entry)))
+ (unless child
+ (setq child (profiler-make-calltree
+ :entry entry :parent node))
+ (push child (profiler-calltree-children node)))
+ (cl-incf (profiler-calltree-count child) count)
+ (setq node child))))))))
+ log))
(defun profiler-calltree-compute-percentages (tree)
- (let ((total-count 0)
- (total-elapsed 0))
+ (let ((total-count 0))
(dolist (child (profiler-calltree-children tree))
- (if (eq (profiler-calltree-entry child) 'gc)
- (profiler-calltree-compute-percentages child)
- (cl-incf total-count (profiler-calltree-count child))
- (cl-incf total-elapsed (profiler-calltree-elapsed child))))
- (dolist (child (profiler-calltree-children tree))
- (unless (eq (profiler-calltree-entry child) 'gc)
- (profiler-calltree-walk
- child 'profiler-calltree-compute-percentages-1
- total-count total-elapsed)))))
+ (cl-incf total-count (profiler-calltree-count child)))
+ (unless (zerop total-count)
+ (profiler-calltree-walk
+ tree (lambda (node)
+ (setf (profiler-calltree-count-percent node)
+ (profiler-format-percent (profiler-calltree-count node)
+ total-count)))))))
(cl-defun profiler-calltree-build (log &key reverse)
(let ((tree (profiler-make-calltree)))
(19 right ((14 right profiler-format-nbytes)
(5 right)))))
-(defvar profiler-report-log nil
+(defvar-local profiler-report-log nil
"The current profiler log.")
-(defvar profiler-report-reversed nil
+(defvar-local profiler-report-reversed nil
"True if calltree is rendered in bottom-up. Do not touch this
variable directly.")
-(defvar profiler-report-order nil
+(defvar-local profiler-report-order nil
"The value can be `ascending' or `descending'. Do not touch
this variable directly.")
(let ((string (cond
((eq entry t)
"Others")
- ((eq entry 'gc)
- "Garbage Collection")
((and (symbolp entry)
(fboundp entry))
(propertize (symbol-name entry)
'help-echo "mouse-2 or RET jumps to definition"))
(t
(profiler-entry-format entry)))))
- (propertize string 'entry entry)))
+ (propertize string 'profiler-entry entry)))
(defun profiler-report-make-name-part (tree)
(let* ((entry (profiler-calltree-entry tree))
(defun profiler-report-line-format (tree)
(let ((diff-p (profiler-log-diff-p profiler-report-log))
(name-part (profiler-report-make-name-part tree))
- (elapsed (profiler-calltree-elapsed tree))
- (elapsed-percent (profiler-calltree-elapsed-percent tree))
(count (profiler-calltree-count tree))
(count-percent (profiler-calltree-count-percent tree)))
- (cl-ecase (profiler-log-type profiler-report-log)
- (sample
- (if diff-p
- (profiler-format profiler-report-sample-line-format
- name-part
- (list (if (> elapsed 0)
- (format "+%s" elapsed)
- elapsed)
- ""))
- (profiler-format profiler-report-sample-line-format
- name-part (list elapsed elapsed-percent))))
- (memory
- (if diff-p
- (profiler-format profiler-report-memory-line-format
- name-part
- (list (if (> count 0)
- (format "+%s" count)
- count)
- ""))
- (profiler-format profiler-report-memory-line-format
- name-part (list count count-percent)))))))
+ (profiler-format (cl-ecase (profiler-log-type profiler-report-log)
+ (cpu profiler-report-sample-line-format)
+ (memory profiler-report-memory-line-format))
+ name-part
+ (if diff-p
+ (list (if (> count 0)
+ (format "+%s" count)
+ count)
+ "")
+ (list count count-percent)))))
(defun profiler-report-insert-calltree (tree)
(let ((line (profiler-report-line-format tree)))
(defvar profiler-report-mode-map
(let ((map (make-sparse-keymap)))
+ ;; FIXME: Add menu.
(define-key map "n" 'profiler-report-next-entry)
(define-key map "p" 'profiler-report-previous-entry)
- (define-key map [down] 'profiler-report-next-entry)
- (define-key map [up] 'profiler-report-previous-entry)
+ ;; I find it annoying more than helpful to not be able to navigate
+ ;; normally with the cursor keys. --Stef
+ ;; (define-key map [down] 'profiler-report-next-entry)
+ ;; (define-key map [up] 'profiler-report-previous-entry)
(define-key map "\r" 'profiler-report-toggle-entry)
(define-key map "\t" 'profiler-report-toggle-entry)
(define-key map "i" 'profiler-report-toggle-entry)
map))
(defun profiler-report-make-buffer-name (log)
- (let ((time (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log))))
- (cl-ecase (profiler-log-type log)
- (sample (format "*CPU-Profiler-Report %s*" time))
- (memory (format "*Memory-Profiler-Report %s*" time)))))
+ (format "*%s-Profiler-Report %s*"
+ (cl-ecase (profiler-log-type log) (cpu 'CPU) (memory 'Memory))
+ (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log))))
(defun profiler-report-setup-buffer (log)
"Make a buffer for LOG and return it."
(define-derived-mode profiler-report-mode special-mode "Profiler-Report"
"Profiler Report Mode."
- (make-local-variable 'profiler-report-log)
- (make-local-variable 'profiler-report-reversed)
- (make-local-variable 'profiler-report-order)
- (use-local-map profiler-report-mode-map)
(setq buffer-read-only t
buffer-undo-list t
truncate-lines t))
(get-text-property (point) 'calltree))
(defun profiler-report-move-to-entry ()
- (let ((point (next-single-property-change (line-beginning-position) 'entry)))
+ (let ((point (next-single-property-change (line-beginning-position)
+ 'profiler-entry)))
(if point
(goto-char point)
(back-to-indentation))))
(line-end-position) t)
(let ((tree (profiler-report-calltree-at-point)))
(when tree
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(replace-match (concat profiler-report-open-mark " "))
(forward-line)
(profiler-report-insert-calltree-children tree)
(start (line-beginning-position 2))
d)
(when tree
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(replace-match (concat profiler-report-closed-mark " "))
(while (and (eq (forward-line) 0)
(let ((child (get-text-property (point) 'calltree)))
(require 'help-fns)
(describe-function entry)))))
-(cl-defun profiler-report-render-calltree-1 (log &key reverse (order 'descending))
+(cl-defun profiler-report-render-calltree-1
+ (log &key reverse (order 'descending))
(let ((calltree (profiler-calltree-build profiler-report-log
:reverse reverse)))
- (cl-ecase (profiler-log-type log)
- (sample
- (setq header-line-format
+ (setq header-line-format
+ (cl-ecase (profiler-log-type log)
+ (cpu
(profiler-report-header-line-format
profiler-report-sample-line-format
"Function" (list "Time (ms)" "%")))
- (let ((predicate (cl-ecase order
- (ascending 'profiler-calltree-elapsed<)
- (descending 'profiler-calltree-elapsed>))))
- (profiler-calltree-sort calltree predicate)))
- (memory
- (setq header-line-format
+ (memory
(profiler-report-header-line-format
profiler-report-memory-line-format
- "Function" (list "Bytes" "%")))
- (let ((predicate (cl-ecase order
- (ascending 'profiler-calltree-count<)
- (descending 'profiler-calltree-count>))))
- (profiler-calltree-sort calltree predicate))))
- (let ((buffer-read-only nil))
+ "Function" (list "Bytes" "%")))))
+ (let ((predicate (cl-ecase order
+ (ascending #'profiler-calltree-count<)
+ (descending #'profiler-calltree-count>))))
+ (profiler-calltree-sort calltree predicate))
+ (let ((inhibit-read-only t))
(erase-buffer)
(profiler-report-insert-calltree-children calltree)
(goto-char (point-min))
\f
;;; Profiler commands
-(defcustom profiler-sample-interval 10
- "Default sample interval in millisecond."
- :type 'integer
- :group 'profiler)
-
;;;###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."
+ "Start/restart profilers.
+MODE can be one of `cpu', `mem', or `cpu+mem'.
+If MODE is `cpu' or `cpu+mem', time-based 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")
+ (list (intern (completing-read "Mode (default cpu): "
+ '("cpu" "mem" "cpu+mem")
nil t nil nil "cpu"))))
(cl-ecase mode
(cpu
(defun profiler-reset ()
"Reset profiler log."
(interactive)
- (sample-profiler-reset)
- (memory-profiler-reset)
+ (ignore (sample-profiler-log))
+ (ignore (memory-profiler-log))
t)
-(defun sample-profiler-report ()
- (let ((sample-log (sample-profiler-log)))
- (when sample-log
- (profiler-report-log sample-log))))
+(defun profiler--report-cpu ()
+ (let ((log (sample-profiler-log)))
+ (when log
+ (puthash 'type 'cpu log)
+ (puthash 'timestamp (current-time) log)
+ (profiler-report-log log))))
-(defun memory-profiler-report ()
- (let ((memory-log (memory-profiler-log)))
- (when memory-log
- (profiler-report-log memory-log))))
+(defun profiler--report-memory ()
+ (let ((log (memory-profiler-log)))
+ (when log
+ (puthash 'type 'memory log)
+ (puthash 'timestamp (current-time) log)
+ (profiler-report-log log))))
(defun profiler-report ()
"Report profiling results."
(interactive)
- (sample-profiler-report)
- (memory-profiler-report))
+ (profiler--report-cpu)
+ (profiler--report-memory))
;;;###autoload
(defun profiler-find-log (filename)
\f
;;; Profiling helpers
-(cl-defmacro with-sample-profiling ((&key (interval profiler-sample-interval)) &rest body)
- `(progn
- (sample-profiler-start ,interval)
- (sample-profiler-reset)
- (unwind-protect
- (progn ,@body)
- (sample-profiler-stop)
- (sample-profiler-report)
- (sample-profiler-reset))))
-
-(cl-defmacro with-memory-profiling (() &rest body)
- `(progn
- (memory-profiler-start)
- (memory-profiler-reset)
- (unwind-protect
- (progn ,@body)
- (memory-profiler-stop)
- (memory-profiler-report)
- (memory-profiler-reset))))
+(cl-defmacro with-sample-profiling ((&key interval) &rest body)
+ `(unwind-protect
+ (progn
+ (ignore (sample-profiler-log))
+ (sample-profiler-start ,interval)
+ ,@body)
+ (sample-profiler-stop)
+ (profiler--report-cpu)))
+
+(defmacro with-memory-profiling (&rest body)
+ `(unwind-protect
+ (progn
+ (ignore (memory-profiler-log))
+ (memory-profiler-start)
+ ,@body)
+ (memory-profiler-stop)
+ (profiler--report-memory)))
(provide 'profiler)
;;; profiler.el ends here
-/* Profiler implementation.
-
-Copyright (C) 2012 Free Software Foundation, Inc.
-
-This file is part of GNU Emacs.
-
-GNU Emacs is free software: you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation, either version 3 of the License, or
-(at your option) any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
-
-#include <config.h>
-#include <stdio.h>
-#include <limits.h>
-#include <sys/time.h>
-#include <signal.h>
-#include <setjmp.h>
-#include "lisp.h"
-
-/* 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);
-
-\f
-/* Pattern matching. */
-
-enum pattern_type
-{
- pattern_exact, /* foo */
- pattern_body_exact, /* *foo* */
- pattern_pre_any, /* *foo */
- pattern_post_any, /* foo* */
- pattern_body_any /* foo*bar */
-};
-
-struct pattern
-{
- enum pattern_type type;
- char *exact;
- char *extra;
- int exact_length;
- int extra_length;
-};
-
-static struct pattern *
-parse_pattern (const char *pattern)
-{
- int length = strlen (pattern);
- enum pattern_type type;
- char *exact;
- char *extra = 0;
- struct pattern *pat =
- (struct pattern *) xmalloc (sizeof (struct pattern));
-
- if (length > 1
- && *pattern == '*'
- && pattern[length - 1] == '*')
- {
- type = pattern_body_exact;
- exact = xstrdup (pattern + 1);
- exact[length - 2] = 0;
- }
- else if (*pattern == '*')
- {
- type = pattern_pre_any;
- exact = xstrdup (pattern + 1);
- }
- else if (pattern[length - 1] == '*')
- {
- type = pattern_post_any;
- exact = xstrdup (pattern);
- exact[length - 1] = 0;
- }
- else if (strchr (pattern, '*'))
- {
- type = pattern_body_any;
- exact = xstrdup (pattern);
- extra = strchr (exact, '*');
- *extra++ = 0;
- }
- else
- {
- type = pattern_exact;
- exact = xstrdup (pattern);
- }
-
- pat->type = type;
- pat->exact = exact;
- pat->extra = extra;
- pat->exact_length = strlen (exact);
- pat->extra_length = extra ? strlen (extra) : 0;
-
- return pat;
-}
-
-static void
-free_pattern (struct pattern *pattern)
-{
- xfree (pattern->exact);
- xfree (pattern);
-}
-
-static int
-pattern_match_1 (enum pattern_type type,
- const char *exact,
- int exact_length,
- const char *string,
- int length)
-{
- if (exact_length > length)
- return 0;
- switch (type)
- {
- case pattern_exact:
- return exact_length == length && !strncmp (exact, string, length);
- case pattern_body_exact:
- return strstr (string, exact) != 0;
- case pattern_pre_any:
- return !strncmp (exact, string + (length - exact_length), exact_length);
- case pattern_post_any:
- return !strncmp (exact, string, exact_length);
- case pattern_body_any:
- return 0;
- }
-}
-
-static int
-pattern_match (struct pattern *pattern, const char *string)
-{
- int length = strlen (string);
- switch (pattern->type)
- {
- case pattern_body_any:
- if (pattern->exact_length + pattern->extra_length > length)
- return 0;
- return pattern_match_1 (pattern_post_any,
- pattern->exact,
- pattern->exact_length,
- string, length)
- && pattern_match_1 (pattern_pre_any,
- pattern->extra,
- pattern->extra_length,
- string, length);
- default:
- return pattern_match_1 (pattern->type,
- pattern->exact,
- pattern->exact_length,
- string, length);
- }
-}
-
-#if 0
-static int
-match (const char *pattern, const char *string)
-{
- int res;
- struct pattern *pat = parse_pattern (pattern);
- res = pattern_match (pat, string);
- free_pattern (pat);
- return res;
-}
-
-static void
-should_match (const char *pattern, const char *string)
-{
- putchar (match (pattern, string) ? '.' : 'F');
-}
-
-static void
-should_not_match (const char *pattern, const char *string)
-{
- putchar (match (pattern, string) ? 'F' : '.');
-}
-
-static void
-pattern_match_tests (void)
-{
- should_match ("", "");
- should_not_match ("", "a");
- should_match ("a", "a");
- should_not_match ("a", "ab");
- should_not_match ("ab", "a");
- should_match ("*a*", "a");
- should_match ("*a*", "ab");
- should_match ("*a*", "ba");
- should_match ("*a*", "bac");
- should_not_match ("*a*", "");
- should_not_match ("*a*", "b");
- should_match ("*", "");
- should_match ("*", "a");
- should_match ("a*", "a");
- should_match ("a*", "ab");
- should_not_match ("a*", "");
- should_not_match ("a*", "ba");
- should_match ("*a", "a");
- should_match ("*a", "ba");
- should_not_match ("*a", "");
- should_not_match ("*a", "ab");
- should_match ("a*b", "ab");
- should_match ("a*b", "acb");
- should_match ("a*b", "aab");
- should_match ("a*b", "abb");
- should_not_match ("a*b", "");
- should_not_match ("a*b", "");
- should_not_match ("a*b", "abc");
- puts ("");
-}
-#endif
-
-\f
-/* 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)
-{
- if (sample_profiler_running)
- block_sigprof ();
-
- if (filter_pattern)
- {
- free_pattern (filter_pattern);
- filter_pattern = 0;
- }
- 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)
-{
- const char *name;
-
- if (!filter_pattern)
- return 1;
-
- if (SYMBOLP (function))
- name = SDATA (SYMBOL_NAME (function));
- else if (SUBRP (function))
- name = XSUBR (function)->symbol_name;
- else
- return 0;
-
- 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)
-{
- while (backlist)
- {
- if (apply_filter_1 (*backlist->function))
- return 1;
- backlist = backlist->next;
- }
- return 0;
-}
-
-DEFUN ("profiler-set-filter-pattern",
- Fprofiler_set_filter_pattern, Sprofiler_set_filter_pattern,
- 1, 1, "sPattern: ",
- 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)
- || (STRINGP (pattern) && !SREF (pattern, 0)))
- {
- set_filter_pattern (0);
- message ("Profiler filter pattern unset");
- return Qt;
- }
- else if (!STRINGP (pattern))
- error ("Invalid type of profiler filter pattern");
-
- set_filter_pattern (SDATA (pattern));
-
- return Qt;
-}
-
-\f
-/* Backtraces. */
-
-
-static Lisp_Object
-make_backtrace (int size)
-{
- return Fmake_vector (make_number (size), Qnil);
-}
-
-static EMACS_UINT
-backtrace_hash (Lisp_Object backtrace)
-{
- int i;
- EMACS_UINT hash = 0;
- for (i = 0; i < ASIZE (backtrace); i++)
- /* FIXME */
- hash = SXHASH_COMBINE (XUINT (AREF (backtrace, i)), hash);
- return hash;
-}
-
-static int
-backtrace_equal (Lisp_Object a, Lisp_Object b)
-{
- int i, j;
-
- for (i = 0, j = 0;; i++, j++)
- {
- Lisp_Object x = i < ASIZE (a) ? AREF (a, i) : Qnil;
- Lisp_Object y = j < ASIZE (b) ? AREF (b, j) : Qnil;
- if (NILP (x) && NILP (y))
- break;
- else if (!EQ (x, y))
- return 0;
- }
-
- return 1;
-}
-
-static Lisp_Object
-backtrace_object_1 (Lisp_Object backtrace, int i)
-{
- if (i >= ASIZE (backtrace) || NILP (AREF (backtrace, i)))
- return Qnil;
- else
- return Fcons (AREF (backtrace, i), backtrace_object_1 (backtrace, i + 1));
-}
-
-/* Convert BACKTRACE to a list. */
-
-static Lisp_Object
-backtrace_object (Lisp_Object backtrace)
-{
- backtrace_object_1 (backtrace, 0);
-}
-
-\f
-/* Slots. */
-
-/* Slot data structure. */
-
-struct slot
-{
- /* Point to next free slot or next hash table link. */
- struct slot *next;
- /* Point to previous hash table link. */
- struct slot *prev;
- /* Backtrace object with fixed size. */
- Lisp_Object backtrace;
- /* How many times a profiler sees the slot, or how much resouce
- allocated during profiling. */
- size_t count;
- /* How long the slot takes to execute. */
- size_t elapsed;
- /* True in used. */
- unsigned char used : 1;
-};
-
-static void
-mark_slot (struct slot *slot)
-{
- mark_object (slot->backtrace);
-}
-
-/* Convert SLOT to a list. */
-
-static Lisp_Object
-slot_object (struct slot *slot)
-{
- return list3 (backtrace_object (slot->backtrace),
- make_number (slot->count),
- make_number (slot->elapsed));
-}
-
-\f
-
-/* Slot heaps. */
-
-struct slot_heap
-{
- /* Number of slots allocated to the heap. */
- unsigned int size;
- /* Actual data area. */
- struct slot *data;
- /* Free list. */
- struct slot *free_list;
-};
-
-static void
-clear_slot_heap (struct slot_heap *heap)
-{
- int i;
- struct slot *data;
- struct slot *free_list;
-
- data = heap->data;
-
- /* Mark all slots unsused. */
- for (i = 0; i < heap->size; i++)
- data[i].used = 0;
-
- /* Rebuild a free list. */
- free_list = heap->free_list = heap->data;
- for (i = 1; i < heap->size; i++)
- {
- free_list->next = &data[i];
- free_list = free_list->next;
- }
- free_list->next = 0;
-}
-
-/* Make a slot heap with SIZE. MAX_STACK_DEPTH is a fixed size of
- allocated slots. */
-
-static struct slot_heap *
-make_slot_heap (unsigned int size, int max_stack_depth)
-{
- int i;
- struct slot_heap *heap;
- struct slot *data;
-
- data = (struct slot *) xmalloc (sizeof (struct slot) * size);
- for (i = 0; i < size; i++)
- data[i].backtrace = make_backtrace (max_stack_depth);
-
- heap = (struct slot_heap *) xmalloc (sizeof (struct slot_heap));
- heap->size = size;
- heap->data = data;
- clear_slot_heap (heap);
-
- return heap;
-}
-
-static void
-free_slot_heap (struct slot_heap *heap)
-{
- int i;
- struct slot *data = heap->data;
- for (i = 0; i < heap->size; i++)
- data[i].backtrace = Qnil;
- xfree (data);
- xfree (heap);
-}
-
-static void
-mark_slot_heap (struct slot_heap *heap)
-{
- int i;
- for (i = 0; i < heap->size; i++)
- mark_slot (&heap->data[i]);
-}
-
-/* Allocate one slot from HEAP. Return 0 if no free slot in HEAP. */
-
-static struct slot *
-allocate_slot (struct slot_heap *heap)
-{
- struct slot *slot;
- if (!heap->free_list)
- return 0;
- slot = heap->free_list;
- slot->count = 0;
- slot->elapsed = 0;
- slot->used = 1;
- heap->free_list = heap->free_list->next;
- return slot;
-}
-
-static void
-free_slot (struct slot_heap *heap, struct slot *slot)
-{
- eassert (slot->used);
- slot->used = 0;
- slot->next = heap->free_list;
- heap->free_list = slot;
-}
-
-/* Return a minimal slot from HEAP. "Minimal" means that such a slot
- is meaningless for profiling. */
-
-static struct slot *
-min_slot (struct slot_heap *heap)
-{
- int i;
- struct slot *min = 0;
- for (i = 0; i < heap->size; i++)
- {
- struct slot *slot = &heap->data[i];
- if (!min || (slot->used && slot->count < min->count))
- min = slot;
- }
- return min;
-}
-
-\f
-/* Slot hash tables. */
-
-struct slot_table
-{
- /* Number of slot buckets. */
- unsigned int size;
- /* Buckets data area. */
- struct slot **data;
-};
-
-static void
-clear_slot_table (struct slot_table *table)
-{
- int i;
- for (i = 0; i < table->size; i++)
- table->data[i] = 0;
-}
-
-static struct slot_table *
-make_slot_table (int size)
-{
- struct slot_table *table
- = (struct slot_table *) xmalloc (sizeof (struct slot_table));
- table->size = size;
- table->data = (struct slot **) xmalloc (sizeof (struct slot *) * size);
- clear_slot_table (table);
- return table;
-}
-
-static void
-free_slot_table (struct slot_table *table)
-{
- xfree (table->data);
- xfree (table);
-}
-
-static void
-remove_slot (struct slot_table *table, struct slot *slot)
-{
- if (slot->prev)
- slot->prev->next = slot->next;
- else
- {
- EMACS_UINT hash = backtrace_hash (slot->backtrace);
- table->data[hash % table->size] = slot->next;
- }
- if (slot->next)
- slot->next->prev = slot->prev;
-}
-
-\f
-/* Logs. */
-
-struct log
-{
- /* Type of log in symbol. `sample' or `memory'. */
- Lisp_Object type;
- /* Backtrace for working. */
- Lisp_Object backtrace;
- struct slot_heap *slot_heap;
- struct slot_table *slot_table;
- size_t others_count;
- size_t others_elapsed;
-};
-
-static struct log *
-make_log (const char *type, int heap_size, int max_stack_depth)
-{
- struct log *log =
- (struct log *) xmalloc (sizeof (struct log));
- log->type = intern (type);
- log->backtrace = make_backtrace (max_stack_depth);
- log->slot_heap = make_slot_heap (heap_size, max_stack_depth);
- /* Number of buckets of hash table will be 10% of HEAP_SIZE. */
- log->slot_table = make_slot_table (max (256, heap_size) / 10);
- log->others_count = 0;
- log->others_elapsed = 0;
- return log;
-}
-
-static void
-free_log (struct log *log)
-{
- log->backtrace = Qnil;
- free_slot_heap (log->slot_heap);
- free_slot_table (log->slot_table);
-}
-
-static void
-mark_log (struct log *log)
-{
- mark_object (log->type);
- mark_object (log->backtrace);
- mark_slot_heap (log->slot_heap);
-}
-
-static void
-clear_log (struct log *log)
-{
- clear_slot_heap (log->slot_heap);
- clear_slot_table (log->slot_table);
- log->others_count = 0;
- log->others_elapsed = 0;
-}
-
-/* Evint SLOT from LOG and accumulate the slot counts into others
- counts. */
-
-static void
-evict_slot (struct log *log, struct slot *slot)
-{
- log->others_count += slot->count;
- log->others_elapsed += slot->elapsed;
- remove_slot (log->slot_table, slot);
- free_slot (log->slot_heap, slot);
-}
-
-/* Evict a minimal slot from LOG. */
-
-static void
-evict_min_slot (struct log *log)
-{
- struct slot *min = min_slot (log->slot_heap);
- if (min)
- evict_slot (log, min);
-}
-
-/* Allocate a new slot for BACKTRACE from LOG. The returen value must
- be a valid pointer to the slot. */
-
-static struct slot *
-new_slot (struct log *log, Lisp_Object backtrace)
-{
- int i;
- struct slot *slot = allocate_slot (log->slot_heap);
-
- /* If failed to allocate a slot, free some slots to make a room in
- heap. */
- if (!slot)
- {
- evict_min_slot (log);
- slot = allocate_slot (log->slot_heap);
- /* Must be allocated. */
- eassert (slot);
- }
-
- slot->prev = 0;
- slot->next = 0;
-
- /* Assign BACKTRACE to the slot. */
- for (i = 0; i < ASIZE (backtrace); i++)
- ASET (slot->backtrace, i, AREF (backtrace, i));
-
- return slot;
-}
-
-/* Make sure that a slot for BACKTRACE is in LOG and return the
- slot. The return value must be a valid pointer to the slot. */
-
-static struct slot *
-ensure_slot (struct log *log, Lisp_Object backtrace)
-{
- EMACS_UINT hash = backtrace_hash (backtrace);
- int index = hash % log->slot_table->size;
- struct slot *slot = log->slot_table->data[index];
- struct slot *prev = slot;
-
- /* Looking up in hash table bucket. */
- while (slot)
- {
- if (backtrace_equal (backtrace, slot->backtrace))
- goto found;
- prev = slot;
- slot = slot->next;
- }
-
- /* If not found, allocate a new slot for BACKTRACE from LOG and link
- it with bucket chain. */
- slot = new_slot (log, backtrace);
- if (prev)
- {
- slot->prev = prev;
- prev->next = slot;
- }
- else
- log->slot_table->data[index] = slot;
-
- found:
- return slot;
-}
-
-/* Record the current backtrace in LOG. BASE is a special name for
- describing which the backtrace come from. BASE can be nil. COUNT is
- a number how many times the profiler sees the backtrace at the
- time. ELAPSED is a elapsed time in millisecond that the backtrace
- took. */
-
-static void
-record_backtrace_under (struct log *log, Lisp_Object base,
- size_t count, size_t elapsed)
-{
- int i = 0;
- Lisp_Object backtrace = log->backtrace;
- struct backtrace *backlist = backtrace_list;
-
- /* First of all, apply filter on the bactkrace. */
- if (!apply_filter (backlist)) return;
-
- /* Record BASE if necessary. */
- if (!NILP (base) && ASIZE (backtrace) > 0)
- ASET (backtrace, i++, base);
-
- /* Copy the backtrace contents into working memory. */
- for (; i < ASIZE (backtrace) && backlist; backlist = backlist->next)
- {
- Lisp_Object function = *backlist->function;
- if (FUNCTIONP (function))
- ASET (backtrace, i++, function);
- }
- /* Make sure that unused space of working memory is filled with
- nil. */
- for (; i < ASIZE (backtrace); i++)
- ASET (backtrace, i, Qnil);
-
- /* If the backtrace is not empty, */
- if (!NILP (AREF (backtrace, 0)))
- {
- /* then record counts. */
- struct slot *slot = ensure_slot (log, backtrace);
- slot->count += count;
- slot->elapsed += elapsed;
- }
-}
-
-static void
-record_backtrace (struct log *log, size_t count, size_t elapsed)
-{
- record_backtrace_under (log, Qnil, count, elapsed);
-}
-
-/* Convert LOG to a list. */
-
-static Lisp_Object
-log_object (struct log *log)
-{
- int i;
- Lisp_Object slots = Qnil;
-
- if (log->others_count != 0 || log->others_elapsed != 0)
- {
- /* Add others slot. */
- Lisp_Object others_slot
- = list3 (list1 (Qt),
- make_number (log->others_count),
- make_number (log->others_elapsed));
- slots = list1 (others_slot);
- }
-
- for (i = 0; i < log->slot_heap->size; i++)
- {
- struct slot *s = &log->slot_heap->data[i];
- if (s->used)
- {
- Lisp_Object slot = slot_object (s);
- slots = Fcons (slot, slots);
- }
- }
-
- return list4 (log->type, Qnil, Fcurrent_time (), slots);
-}
-
-\f
-/* Sample profiler. */
-
-static struct log *sample_log;
-
-/* The current sample interval in millisecond. */
-
-static int current_sample_interval;
-
-DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start,
- 1, 1, 0,
- doc: /* Start or restart sample profiler. Sample profiler will
-take samples each SAMPLE-INTERVAL in millisecond. See also
-`profiler-slot-heap-size' and `profiler-max-stack-depth'. */)
- (Lisp_Object sample_interval)
-{
- struct sigaction sa;
- struct itimerval timer;
-
- if (sample_profiler_running)
- error ("Sample profiler is already running");
-
- if (!sample_log)
- sample_log = make_log ("sample",
- profiler_slot_heap_size,
- profiler_max_stack_depth);
-
- current_sample_interval = XINT (sample_interval);
-
- sa.sa_sigaction = sigprof_handler;
- sa.sa_flags = SA_RESTART | SA_SIGINFO;
- sigemptyset (&sa.sa_mask);
- sigaction (SIGPROF, &sa, 0);
-
- timer.it_interval.tv_sec = 0;
- timer.it_interval.tv_usec = current_sample_interval * 1000;
- timer.it_value = timer.it_interval;
- setitimer (ITIMER_PROF, &timer, 0);
-
- sample_profiler_running = 1;
-
- return Qt;
-}
-
-DEFUN ("sample-profiler-stop", Fsample_profiler_stop, Ssample_profiler_stop,
- 0, 0, 0,
- doc: /* Stop sample profiler. Profiler log will be kept. */)
- (void)
-{
- if (!sample_profiler_running)
- error ("Sample profiler is not running");
- sample_profiler_running = 0;
-
- setitimer (ITIMER_PROF, 0, 0);
-
- return Qt;
-}
-
-DEFUN ("sample-profiler-reset", Fsample_profiler_reset, Ssample_profiler_reset,
- 0, 0, 0,
- doc: /* Clear sample profiler log. */)
- (void)
-{
- if (sample_log)
- {
- if (sample_profiler_running)
- {
- block_sigprof ();
- clear_log (sample_log);
- unblock_sigprof ();
- }
- else
- {
- free_log (sample_log);
- sample_log = 0;
- }
- }
-}
-
-DEFUN ("sample-profiler-running-p",
- Fsample_profiler_running_p, Ssample_profiler_running_p,
- 0, 0, 0,
- doc: /* Return t if sample profiler is running. */)
- (void)
-{
- return sample_profiler_running ? Qt : Qnil;
-}
-
-DEFUN ("sample-profiler-log",
- Fsample_profiler_log, Ssample_profiler_log,
- 0, 0, 0,
- doc: /* Return sample profiler log. The data is a list of
-(sample nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the
-log is collected and SLOTS is a list of slots. */)
- (void)
-{
- int i;
- Lisp_Object result = Qnil;
-
- if (sample_log)
- {
- if (sample_profiler_running)
- {
- block_sigprof ();
- result = log_object (sample_log);
- unblock_sigprof ();
- }
- else
- result = log_object (sample_log);
- }
-
- return result;
-}
-
-\f
-/* Memory profiler. */
-
-static struct log *memory_log;
-
-DEFUN ("memory-profiler-start", Fmemory_profiler_start, Smemory_profiler_start,
- 0, 0, 0,
- doc: /* Start/restart memory profiler. See also
-`profiler-slot-heap-size' and `profiler-max-stack-depth'. */)
- (void)
-{
- if (memory_profiler_running)
- error ("Memory profiler is already running");
-
- if (!memory_log)
- memory_log = make_log ("memory",
- profiler_slot_heap_size,
- profiler_max_stack_depth);
-
- memory_profiler_running = 1;
-
- return Qt;
-}
-
-DEFUN ("memory-profiler-stop",
- Fmemory_profiler_stop, Smemory_profiler_stop,
- 0, 0, 0,
- doc: /* Stop memory profiler. Profiler log will be kept. */)
- (void)
-{
- if (!memory_profiler_running)
- error ("Memory profiler is not running");
- memory_profiler_running = 0;
-
- return Qt;
-}
-
-DEFUN ("memory-profiler-reset",
- Fmemory_profiler_reset, Smemory_profiler_reset,
- 0, 0, 0,
- doc: /* Clear memory profiler log. */)
- (void)
-{
- if (memory_log)
- {
- if (memory_profiler_running)
- clear_log (memory_log);
- else
- {
- free_log (memory_log);
- memory_log = 0;
- }
- }
-}
-
-DEFUN ("memory-profiler-running-p",
- Fmemory_profiler_running_p, Smemory_profiler_running_p,
- 0, 0, 0,
- doc: /* Return t if memory profiler is running. */)
- (void)
-{
- return memory_profiler_running ? Qt : Qnil;
-}
-
-DEFUN ("memory-profiler-log",
- Fmemory_profiler_log, Smemory_profiler_log,
- 0, 0, 0,
- doc: /* Return memory profiler log. The data is a list of
-(memory nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the
-log is collected and SLOTS is a list of slots. */)
- (void)
-{
- Lisp_Object result = Qnil;
-
- if (memory_log)
- result = log_object (memory_log);
-
- return result;
-}
-
-\f
-/* Signals and probes. */
-
-/* Signal handler for sample profiler. */
-
-static void
-sigprof_handler (int signal, siginfo_t *info, void *ctx)
-{
- if (!is_in_trace && sample_log)
- record_backtrace (sample_log, 1, current_sample_interval);
-}
-
-static void
-block_sigprof (void)
-{
- sigset_t sigset;
- sigemptyset (&sigset);
- sigaddset (&sigset, SIGPROF);
- sigprocmask (SIG_BLOCK, &sigset, 0);
-}
-
-static void
-unblock_sigprof (void)
-{
- sigset_t sigset;
- sigemptyset (&sigset);
- sigaddset (&sigset, SIGPROF);
- sigprocmask (SIG_UNBLOCK, &sigset, 0);
-}
-
-/* Record that the current backtrace allocated SIZE bytes. */
-
-void
-malloc_probe (size_t size)
-{
- if (memory_log)
- record_backtrace (memory_log, size, 0);
-}
-
-/* Record that GC happened in the current backtrace. */
-
-void
-gc_probe (size_t size, size_t elapsed)
-{
- if (sample_log)
- record_backtrace_under (sample_log, Qgc, 1, elapsed);
- if (memory_log)
- record_backtrace_under (memory_log, Qgc, size, elapsed);
-}
-
-\f
-
-void
-mark_profiler (void)
-{
- if (sample_log)
- {
- if (sample_profiler_running)
- {
- block_sigprof ();
- mark_log (sample_log);
- unblock_sigprof ();
- }
- else
- mark_log (sample_log);
- }
- if (memory_log)
- mark_log (memory_log);
-}
-
-void
-syms_of_profiler (void)
-{
- DEFSYM (Qgc, "gc");
-
- DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
- doc: /* FIXME */);
- profiler_max_stack_depth = 16;
- DEFVAR_INT ("profiler-slot-heap-size", profiler_slot_heap_size,
- doc: /* FIXME */);
- profiler_slot_heap_size = 10000;
-
- defsubr (&Sprofiler_set_filter_pattern);
-
- defsubr (&Ssample_profiler_start);
- defsubr (&Ssample_profiler_stop);
- defsubr (&Ssample_profiler_reset);
- defsubr (&Ssample_profiler_running_p);
- defsubr (&Ssample_profiler_log);
-
- defsubr (&Smemory_profiler_start);
- defsubr (&Smemory_profiler_stop);
- defsubr (&Smemory_profiler_reset);
- defsubr (&Smemory_profiler_running_p);
- defsubr (&Smemory_profiler_log);
-}
+/* Profiler implementation.
+
+Copyright (C) 2012 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <stdio.h>
+#include <limits.h>
+#include <sys/time.h>
+#include <signal.h>
+#include <setjmp.h>
+#include "lisp.h"
+
+/* True if sampling profiler is running. */
+
+bool sample_profiler_running;
+
+/* True if memory profiler is running. */
+
+bool memory_profiler_running;
+
+static void sigprof_handler (int, siginfo_t *, void *);
+
+\f
+/* Logs. */
+
+typedef struct Lisp_Hash_Table log_t;
+
+static Lisp_Object
+make_log (int heap_size, int max_stack_depth)
+{
+ /* We use a standard Elisp hash-table object, but we use it in
+ a special way. This is OK as long as the object is not exposed
+ to Elisp, i.e. until it is returned by *-profiler-log, after which
+ it can't be used any more. */
+ Lisp_Object log = make_hash_table (Qequal, make_number (heap_size),
+ make_float (DEFAULT_REHASH_SIZE),
+ make_float (DEFAULT_REHASH_THRESHOLD),
+ Qnil, Qnil, Qnil);
+ struct Lisp_Hash_Table *h = XHASH_TABLE (log);
+
+ /* What is special about our hash-tables is that the keys are pre-filled
+ with the vectors we'll put in them. */
+ int i = ASIZE (h->key_and_value) / 2;
+ while (0 < i)
+ set_hash_key_slot (h, --i,
+ Fmake_vector (make_number (max_stack_depth), Qnil));
+ return log;
+}
+
+/* Evict the least used half of the hash_table.
+
+ When the table is full, we have to evict someone.
+ The easiest and most efficient is to evict the value we're about to add
+ (i.e. once the table is full, stop sampling).
+
+ We could also pick the element with the lowest count and evict it,
+ but finding it is O(N) and for that amount of work we get very
+ little in return: for the next sample, this latest sample will have
+ count==1 and will hence be a prime candidate for eviction :-(
+
+ So instead, we take O(N) time to eliminate more or less half of the
+ entries (the half with the lowest counts). So we get an amortized
+ cost of O(1) and we get O(N) time for a new entry to grow larger
+ than the other least counts before a new round of eviction. */
+
+static EMACS_INT approximate_median (log_t *log,
+ ptrdiff_t start, ptrdiff_t size)
+{
+ eassert (size > 0);
+ if (size < 2)
+ return XINT (HASH_VALUE (log, start));
+ if (size < 3)
+ /* Not an actual median, but better for our application than
+ choosing either of the two numbers. */
+ return ((XINT (HASH_VALUE (log, start))
+ + XINT (HASH_VALUE (log, start + 1)))
+ / 2);
+ else
+ {
+ ptrdiff_t newsize = size / 3;
+ ptrdiff_t start2 = start + newsize;
+ EMACS_INT i1 = approximate_median (log, start, newsize);
+ EMACS_INT i2 = approximate_median (log, start2, newsize);
+ EMACS_INT i3 = approximate_median (log, start2 + newsize,
+ size - 2 * newsize);
+ return (i1 < i2
+ ? (i2 < i3 ? i2 : (i1 < i3 ? i3 : i1))
+ : (i1 < i3 ? i1 : (i2 < i3 ? i3 : i2)));
+ }
+}
+
+static void evict_lower_half (log_t *log)
+{
+ ptrdiff_t size = ASIZE (log->key_and_value) / 2;
+ EMACS_INT median = approximate_median (log, 0, size);
+ ptrdiff_t i;
+
+ for (i = 0; i < size; i++)
+ /* Evict not only values smaller but also values equal to the median,
+ so as to make sure we evict something no matter what. */
+ if (XINT (HASH_VALUE (log, i)) <= median)
+ {
+ Lisp_Object key = HASH_KEY (log, i);
+ { /* FIXME: we could make this more efficient. */
+ Lisp_Object tmp;
+ XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */
+ Fremhash (key, tmp);
+ }
+ eassert (EQ (log->next_free, make_number (i)));
+ {
+ int j;
+ eassert (VECTORP (key));
+ for (j = 0; j < ASIZE (key); j++)
+ ASET (key, i, Qnil);
+ }
+ set_hash_key_slot (log, i, key);
+ }
+}
+
+/* Record the current backtrace in LOG. BASE is a special name for
+ describing which the backtrace come from. BASE can be nil. COUNT is
+ a number how many times the profiler sees the backtrace at the
+ time. ELAPSED is a elapsed time in millisecond that the backtrace
+ took. */
+
+static void
+record_backtrace (log_t *log, size_t count)
+{
+ struct backtrace *backlist = backtrace_list;
+ Lisp_Object backtrace;
+ ptrdiff_t index, i = 0;
+ ptrdiff_t asize;
+
+ if (!INTEGERP (log->next_free))
+ evict_lower_half (log);
+ index = XINT (log->next_free);
+
+ /* Get a "working memory" vector. */
+ backtrace = HASH_KEY (log, index);
+ asize = ASIZE (backtrace);
+
+ /* Copy the backtrace contents into working memory. */
+ for (; i < asize && backlist; i++, backlist = backlist->next)
+ ASET (backtrace, i, *backlist->function);
+
+ /* Make sure that unused space of working memory is filled with nil. */
+ for (; i < asize; i++)
+ ASET (backtrace, i, Qnil);
+
+ { /* We basically do a `gethash+puthash' here, except that we have to be
+ careful to avoid memory allocation since we're in a signal
+ handler, and we optimize the code to try and avoid computing the
+ hash+lookup twice. See fns.c:Fputhash for reference. */
+ EMACS_UINT hash;
+ ptrdiff_t j = hash_lookup (log, backtrace, &hash);
+ if (j >= 0)
+ set_hash_value_slot (log, j,
+ make_number (count + XINT (HASH_VALUE (log, j))));
+ else
+ { /* BEWARE! hash_put in general can allocate memory.
+ But currently it only does that if log->next_free is nil. */
+ int j;
+ eassert (!NILP (log->next_free));
+ j = hash_put (log, backtrace, make_number (count), hash);
+ /* Let's make sure we've put `backtrace' right where it
+ already was to start with. */
+ eassert (index == j);
+
+ /* FIXME: If the hash-table is almost full, we should set
+ some global flag so that some Elisp code can offload its
+ data elsewhere, so as to avoid the eviction code. */
+ }
+ }
+}
+\f
+/* Sample profiler. */
+
+static Lisp_Object cpu_log;
+/* Separate counter for the time spent in the GC. */
+static EMACS_INT cpu_gc_count;
+
+/* The current sample interval in millisecond. */
+
+static int current_sample_interval;
+
+DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start,
+ 1, 1, 0,
+ doc: /* Start or restart sample profiler. Sample profiler will
+take samples each SAMPLE-INTERVAL in millisecond. See also
+`profiler-slot-heap-size' and `profiler-max-stack-depth'. */)
+ (Lisp_Object sample_interval)
+{
+ struct sigaction sa;
+ struct itimerval timer;
+
+ if (sample_profiler_running)
+ error ("Sample profiler is already running");
+
+ if (NILP (cpu_log))
+ {
+ cpu_gc_count = 0;
+ cpu_log = make_log (profiler_slot_heap_size,
+ profiler_max_stack_depth);
+ }
+
+ current_sample_interval = XINT (sample_interval);
+
+ sa.sa_sigaction = sigprof_handler;
+ sa.sa_flags = SA_RESTART | SA_SIGINFO;
+ sigemptyset (&sa.sa_mask);
+ sigaction (SIGPROF, &sa, 0);
+
+ timer.it_interval.tv_sec = 0;
+ timer.it_interval.tv_usec = current_sample_interval * 1000;
+ timer.it_value = timer.it_interval;
+ setitimer (ITIMER_PROF, &timer, 0);
+
+ sample_profiler_running = 1;
+
+ return Qt;
+}
+
+DEFUN ("sample-profiler-stop", Fsample_profiler_stop, Ssample_profiler_stop,
+ 0, 0, 0,
+ doc: /* Stop sample profiler. Profiler log will be kept. */)
+ (void)
+{
+ if (!sample_profiler_running)
+ error ("Sample profiler is not running");
+ sample_profiler_running = 0;
+
+ setitimer (ITIMER_PROF, 0, 0);
+
+ return Qt;
+}
+
+DEFUN ("sample-profiler-running-p",
+ Fsample_profiler_running_p, Ssample_profiler_running_p,
+ 0, 0, 0,
+ doc: /* Return t if sample profiler is running. */)
+ (void)
+{
+ return sample_profiler_running ? Qt : Qnil;
+}
+
+DEFUN ("sample-profiler-log",
+ Fsample_profiler_log, Ssample_profiler_log,
+ 0, 0, 0,
+ doc: /* Return sample profiler log. The data is a list of
+(sample nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the
+log is collected and SLOTS is a list of slots. */)
+ (void)
+{
+ Lisp_Object result = cpu_log;
+ /* Here we're making the log visible to Elisp , so it's not safe any
+ more for our use afterwards since we can't rely on its special
+ pre-allocated keys anymore. So we have to allocate a new one. */
+ cpu_log = (sample_profiler_running
+ ? make_log (profiler_slot_heap_size, profiler_max_stack_depth)
+ : Qnil);
+ Fputhash (Fmake_vector (make_number (1), Qautomatic_gc),
+ make_number (cpu_gc_count),
+ result);
+ cpu_gc_count = 0;
+ return result;
+}
+
+\f
+/* Memory profiler. */
+
+static Lisp_Object memory_log;
+
+DEFUN ("memory-profiler-start", Fmemory_profiler_start, Smemory_profiler_start,
+ 0, 0, 0,
+ doc: /* Start/restart memory profiler. See also
+`profiler-slot-heap-size' and `profiler-max-stack-depth'. */)
+ (void)
+{
+ if (memory_profiler_running)
+ error ("Memory profiler is already running");
+
+ if (NILP (memory_log))
+ memory_log = make_log (profiler_slot_heap_size,
+ profiler_max_stack_depth);
+
+ memory_profiler_running = 1;
+
+ return Qt;
+}
+
+DEFUN ("memory-profiler-stop",
+ Fmemory_profiler_stop, Smemory_profiler_stop,
+ 0, 0, 0,
+ doc: /* Stop memory profiler. Profiler log will be kept. */)
+ (void)
+{
+ if (!memory_profiler_running)
+ error ("Memory profiler is not running");
+ memory_profiler_running = 0;
+
+ return Qt;
+}
+
+DEFUN ("memory-profiler-running-p",
+ Fmemory_profiler_running_p, Smemory_profiler_running_p,
+ 0, 0, 0,
+ doc: /* Return t if memory profiler is running. */)
+ (void)
+{
+ return memory_profiler_running ? Qt : Qnil;
+}
+
+DEFUN ("memory-profiler-log",
+ Fmemory_profiler_log, Smemory_profiler_log,
+ 0, 0, 0,
+ doc: /* Return memory profiler log. The data is a list of
+(memory nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the
+log is collected and SLOTS is a list of slots. */)
+ (void)
+{
+ Lisp_Object result = memory_log;
+ /* Here we're making the log visible to Elisp , so it's not safe any
+ more for our use afterwards since we can't rely on its special
+ pre-allocated keys anymore. So we have to allocate a new one. */
+ memory_log = (memory_profiler_running
+ ? make_log (profiler_slot_heap_size, profiler_max_stack_depth)
+ : Qnil);
+ return result;
+}
+
+\f
+/* Signals and probes. */
+
+/* Signal handler for sample profiler. */
+
+static void
+sigprof_handler (int signal, siginfo_t *info, void *ctx)
+{
+ eassert (HASH_TABLE_P (cpu_log));
+ if (backtrace_list && EQ (*backtrace_list->function, Qautomatic_gc))
+ /* Special case the time-count inside GC because the hash-table
+ code is not prepared to be used while the GC is running.
+ More specifically it uses ASIZE at many places where it does
+ not expect the ARRAY_MARK_FLAG to be set. We could try and
+ harden the hash-table code, but it doesn't seem worth the
+ effort. */
+ cpu_gc_count += current_sample_interval;
+ else
+ record_backtrace (XHASH_TABLE (cpu_log), current_sample_interval);
+}
+
+/* Record that the current backtrace allocated SIZE bytes. */
+/* FIXME: Inline it everywhere! */
+void
+malloc_probe (size_t size)
+{
+ if (HASH_TABLE_P (memory_log))
+ record_backtrace (XHASH_TABLE (memory_log), size);
+}
+
+void
+syms_of_profiler (void)
+{
+ DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
+ doc: /* FIXME */);
+ profiler_max_stack_depth = 16;
+ DEFVAR_INT ("profiler-slot-heap-size", profiler_slot_heap_size,
+ doc: /* FIXME */);
+ profiler_slot_heap_size = 10000;
+
+ cpu_log = memory_log = Qnil;
+ staticpro (&cpu_log);
+ staticpro (&memory_log);
+
+ /* FIXME: Rename things to start with "profiler-", to use "cpu" instead of
+ "sample", and to make them sound like they're internal or something. */
+ defsubr (&Ssample_profiler_start);
+ defsubr (&Ssample_profiler_stop);
+ defsubr (&Ssample_profiler_running_p);
+ defsubr (&Ssample_profiler_log);
+
+ defsubr (&Smemory_profiler_start);
+ defsubr (&Smemory_profiler_stop);
+ defsubr (&Smemory_profiler_running_p);
+ defsubr (&Smemory_profiler_log);
+}
HCoop / bpt / emacs.git / commitdiff