/* Profiler implementation.
-Copyright (C) 2012 Free Software Foundation, Inc.
+Copyright (C) 2012-2013 Free Software Foundation, Inc.
This file is part of GNU Emacs.
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"
+#include "syssignal.h"
+#include "systime.h"
-/* True if sampling profiler is running. */
+/* Return A + B, but return the maximum fixnum if the result would overflow.
+ Assume A and B are nonnegative and in fixnum range. */
-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)
+static EMACS_INT
+saturated_add (EMACS_INT a, EMACS_INT b)
{
- xfree (pattern->exact);
- xfree (pattern);
+ return min (a + b, MOST_POSITIVE_FIXNUM);
}
-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. */
+/* Logs. */
+typedef struct Lisp_Hash_Table log_t;
static Lisp_Object
-make_backtrace (int size)
-{
- return Fmake_vector (make_number (size), Qnil);
+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;
}
-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;
-}
+/* Evict the least used half of the hash_table.
-static int
-backtrace_equal (Lisp_Object a, Lisp_Object b)
-{
- int i, j;
+ 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).
- 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;
- }
+ 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 :-(
- return 1;
-}
+ 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 Lisp_Object
-backtrace_object_1 (Lisp_Object backtrace, int i)
+static EMACS_INT approximate_median (log_t *log,
+ ptrdiff_t start, ptrdiff_t size)
{
- if (i >= ASIZE (backtrace) || NILP (AREF (backtrace, i)))
- return Qnil;
+ 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
- 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;
+ 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)));
}
- 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)
+static void evict_lower_half (log_t *log)
{
- int i;
- struct slot_heap *heap;
- struct slot *data;
+ ptrdiff_t size = ASIZE (log->key_and_value) / 2;
+ EMACS_INT median = approximate_median (log, 0, size);
+ ptrdiff_t i;
- 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]);
+ /* 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, j, Qnil);
+ }
+ set_hash_key_slot (log, i, key);
+ }
}
-/* 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;
-}
+/* Record the current backtrace in LOG. COUNT is the weight of this
+ current backtrace: interrupt counts for CPU, and the allocation
+ size for memory. */
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)
+record_backtrace (log_t *log, EMACS_INT count)
{
- 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 backtrace *backlist = backtrace_list;
+ Lisp_Object backtrace;
+ ptrdiff_t index, i = 0;
+ ptrdiff_t asize;
-struct slot_table
-{
- /* Number of slot buckets. */
- unsigned int size;
- /* Buckets data area. */
- struct slot **data;
-};
+ if (!INTEGERP (log->next_free))
+ /* FIXME: transfer the evicted counts to a special entry rather
+ than dropping them on the floor. */
+ evict_lower_half (log);
+ index = XINT (log->next_free);
-static void
-clear_slot_table (struct slot_table *table)
-{
- int i;
- for (i = 0; i < table->size; i++)
- table->data[i] = 0;
-}
+ /* Get a "working memory" vector. */
+ backtrace = HASH_KEY (log, index);
+ asize = ASIZE (backtrace);
-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;
-}
+ /* Copy the backtrace contents into working memory. */
+ for (; i < asize && backlist; i++, backlist = backlist->next)
+ /* FIXME: For closures we should ignore the environment. */
+ ASET (backtrace, i, backlist->function);
-static void
-free_slot_table (struct slot_table *table)
-{
- xfree (table->data);
- xfree (table);
-}
+ /* Make sure that unused space of working memory is filled with nil. */
+ for (; i < asize; i++)
+ ASET (backtrace, i, Qnil);
-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;
+ { /* 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)
+ {
+ EMACS_INT old_val = XINT (HASH_VALUE (log, j));
+ EMACS_INT new_val = saturated_add (old_val, count);
+ set_hash_value_slot (log, j, make_number (new_val));
+ }
+ 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.
+ There are 2 ways to do that, AFAICT:
+ - Set a flag checked in QUIT, such that QUIT can then call
+ Fprofiler_cpu_log and stash the full log for later use.
+ - Set a flag check in post-gc-hook, so that Elisp code can call
+ profiler-cpu-log. That gives us more flexibility since that
+ Elisp code can then do all kinds of fun stuff like write
+ the log to disk. Or turn it right away into a call tree.
+ Of course, using Elisp is generally preferable, but it may
+ take longer until we get a chance to run the Elisp code, so
+ there's more risk that the table will get full before we
+ get there. */
+ }
+ }
}
-
\f
-/* Logs. */
+/* Sampling profiler. */
-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;
-}
+#ifdef PROFILER_CPU_SUPPORT
-static void
-free_log (struct log *log)
-{
- log->backtrace = Qnil;
- free_slot_heap (log->slot_heap);
- free_slot_table (log->slot_table);
-}
+/* The profiler timer and whether it was properly initialized, if
+ POSIX timers are available. */
+#ifdef HAVE_ITIMERSPEC
+static timer_t profiler_timer;
+static bool profiler_timer_ok;
+#endif
-static void
-mark_log (struct log *log)
-{
- mark_object (log->type);
- mark_object (log->backtrace);
- mark_slot_heap (log->slot_heap);
-}
+/* Status of sampling profiler. */
+static enum profiler_cpu_running
+ { NOT_RUNNING, TIMER_SETTIME_RUNNING, SETITIMER_RUNNING }
+ profiler_cpu_running;
-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;
-}
+/* Hash-table log of CPU profiler. */
+static Lisp_Object cpu_log;
-/* Evint SLOT from LOG and accumulate the slot counts into others
- counts. */
+/* Separate counter for the time spent in the GC. */
+static EMACS_INT cpu_gc_count;
-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);
-}
+/* The current sampling interval in nanoseconds. */
+static EMACS_INT current_sampling_interval;
-/* Evict a minimal slot from LOG. */
+/* Signal handler for sampling profiler. */
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;
- }
+handle_profiler_signal (int signal)
+{
+ 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 = saturated_add (cpu_gc_count, 1);
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;
+ Lisp_Object oquit;
+ bool saved_pending_signals;
+ EMACS_INT count = 1;
+#ifdef HAVE_ITIMERSPEC
+ if (profiler_timer_ok)
+ {
+ int overruns = timer_getoverrun (profiler_timer);
+ eassert (0 <= overruns);
+ count += overruns;
+ }
+#endif
+ /* record_backtrace uses hash functions that call Fequal, which
+ uses QUIT, which can call malloc, which can cause disaster in
+ a signal handler. So inhibit QUIT. */
+ oquit = Vinhibit_quit;
+ saved_pending_signals = pending_signals;
+ Vinhibit_quit = Qt;
+ pending_signals = 0;
+
+ eassert (HASH_TABLE_P (cpu_log));
+ record_backtrace (XHASH_TABLE (cpu_log), count);
+
+ Vinhibit_quit = oquit;
+ pending_signals = saved_pending_signals;
}
}
static void
-record_backtrace (struct log *log, size_t count, size_t elapsed)
+deliver_profiler_signal (int signal)
{
- record_backtrace_under (log, Qnil, count, elapsed);
+ deliver_process_signal (signal, handle_profiler_signal);
}
-/* Convert LOG to a list. */
-
-static Lisp_Object
-log_object (struct log *log)
+static enum profiler_cpu_running
+setup_cpu_timer (Lisp_Object sampling_interval)
{
- int i;
- Lisp_Object slots = Qnil;
-
- if (log->others_count != 0 || log->others_elapsed != 0)
+ struct sigaction action;
+ struct itimerval timer;
+ struct timespec interval;
+ int billion = 1000000000;
+
+ if (! RANGED_INTEGERP (1, sampling_interval,
+ (TYPE_MAXIMUM (time_t) < EMACS_INT_MAX / billion
+ ? ((EMACS_INT) TYPE_MAXIMUM (time_t) * billion
+ + (billion - 1))
+ : EMACS_INT_MAX)))
+ return NOT_RUNNING;
+
+ current_sampling_interval = XINT (sampling_interval);
+ interval = make_emacs_time (current_sampling_interval / billion,
+ current_sampling_interval % billion);
+ emacs_sigaction_init (&action, deliver_profiler_signal);
+ sigaction (SIGPROF, &action, 0);
+
+#ifdef HAVE_ITIMERSPEC
+ if (! profiler_timer_ok)
{
- /* Add others slot. */
- Lisp_Object others_slot
- = list3 (list1 (Qt),
- make_number (log->others_count),
- make_number (log->others_elapsed));
- slots = list1 (others_slot);
+ /* System clocks to try, in decreasing order of desirability. */
+ static clockid_t const system_clock[] = {
+#ifdef CLOCK_THREAD_CPUTIME_ID
+ CLOCK_THREAD_CPUTIME_ID,
+#endif
+#ifdef CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_PROCESS_CPUTIME_ID,
+#endif
+#ifdef CLOCK_MONOTONIC
+ CLOCK_MONOTONIC,
+#endif
+ CLOCK_REALTIME
+ };
+ int i;
+ struct sigevent sigev;
+ sigev.sigev_value.sival_ptr = &profiler_timer;
+ sigev.sigev_signo = SIGPROF;
+ sigev.sigev_notify = SIGEV_SIGNAL;
+
+ for (i = 0; i < sizeof system_clock / sizeof *system_clock; i++)
+ if (timer_create (system_clock[i], &sigev, &profiler_timer) == 0)
+ {
+ profiler_timer_ok = 1;
+ break;
+ }
}
- for (i = 0; i < log->slot_heap->size; i++)
+ if (profiler_timer_ok)
{
- struct slot *s = &log->slot_heap->data[i];
- if (s->used)
- {
- Lisp_Object slot = slot_object (s);
- slots = Fcons (slot, slots);
- }
+ struct itimerspec ispec;
+ ispec.it_value = ispec.it_interval = interval;
+ if (timer_settime (profiler_timer, 0, &ispec, 0) == 0)
+ return TIMER_SETTIME_RUNNING;
}
+#endif
- return list4 (log->type, Qnil, Fcurrent_time (), slots);
-}
-
-\f
-/* Sample profiler. */
-
-static struct log *sample_log;
-
-/* The current sample interval in millisecond. */
+#ifdef HAVE_SETITIMER
+ timer.it_value = timer.it_interval = make_timeval (interval);
+ if (setitimer (ITIMER_PROF, &timer, 0) == 0)
+ return SETITIMER_RUNNING;
+#endif
-static int current_sample_interval;
+ return NOT_RUNNING;
+}
-DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start,
+DEFUN ("profiler-cpu-start", Fprofiler_cpu_start, Sprofiler_cpu_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)
+ doc: /* Start or restart the cpu profiler.
+It takes call-stack samples each SAMPLING-INTERVAL nanoseconds, approximately.
+See also `profiler-log-size' and `profiler-max-stack-depth'. */)
+ (Lisp_Object sampling_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);
+ if (profiler_cpu_running)
+ error ("CPU profiler is already running");
- 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);
+ if (NILP (cpu_log))
+ {
+ cpu_gc_count = 0;
+ cpu_log = make_log (profiler_log_size,
+ profiler_max_stack_depth);
+ }
- sample_profiler_running = 1;
+ profiler_cpu_running = setup_cpu_timer (sampling_interval);
+ if (! profiler_cpu_running)
+ error ("Invalid sampling interval");
return Qt;
}
-DEFUN ("sample-profiler-stop", Fsample_profiler_stop, Ssample_profiler_stop,
+DEFUN ("profiler-cpu-stop", Fprofiler_cpu_stop, Sprofiler_cpu_stop,
0, 0, 0,
- doc: /* Stop sample profiler. Profiler log will be kept. */)
+ doc: /* Stop the cpu profiler. The profiler log is not affected.
+Return non-nil if the profiler was running. */)
(void)
{
- if (!sample_profiler_running)
- error ("Sample profiler is not running");
- sample_profiler_running = 0;
+ switch (profiler_cpu_running)
+ {
+ case NOT_RUNNING:
+ return Qnil;
+
+#ifdef HAVE_ITIMERSPEC
+ case TIMER_SETTIME_RUNNING:
+ {
+ struct itimerspec disable;
+ memset (&disable, 0, sizeof disable);
+ timer_settime (profiler_timer, 0, &disable, 0);
+ }
+ break;
+#endif
- setitimer (ITIMER_PROF, 0, 0);
+#ifdef HAVE_SETITIMER
+ case SETITIMER_RUNNING:
+ {
+ struct itimerval disable;
+ memset (&disable, 0, sizeof disable);
+ setitimer (ITIMER_PROF, &disable, 0);
+ }
+ break;
+#endif
+ }
+ signal (SIGPROF, SIG_IGN);
+ profiler_cpu_running = NOT_RUNNING;
return Qt;
}
-DEFUN ("sample-profiler-reset", Fsample_profiler_reset, Ssample_profiler_reset,
+DEFUN ("profiler-cpu-running-p",
+ Fprofiler_cpu_running_p, Sprofiler_cpu_running_p,
0, 0, 0,
- doc: /* Clear sample profiler log. */)
+ doc: /* Return non-nil iff cpu profiler is running. */)
(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;
+ return profiler_cpu_running ? Qt : Qnil;
}
-DEFUN ("sample-profiler-log",
- Fsample_profiler_log, Ssample_profiler_log,
+DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_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. */)
+ doc: /* Return the current cpu profiler log.
+The log is a hash-table mapping backtraces to counters which represent
+the amount of time spent at those points. Every backtrace is a vector
+of functions, where the last few elements may be nil.
+Before returning, a new log is allocated for future samples. */)
(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);
- }
-
+ 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 = (profiler_cpu_running
+ ? make_log (profiler_log_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;
}
-
+#endif /* PROFILER_CPU_SUPPORT */
\f
/* Memory profiler. */
-static struct log *memory_log;
+/* True if memory profiler is running. */
+bool profiler_memory_running;
+
+static Lisp_Object memory_log;
-DEFUN ("memory-profiler-start", Fmemory_profiler_start, Smemory_profiler_start,
+DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start,
0, 0, 0,
- doc: /* Start/restart memory profiler. See also
-`profiler-slot-heap-size' and `profiler-max-stack-depth'. */)
+ doc: /* Start/restart the memory profiler.
+The memory profiler will take samples of the call-stack whenever a new
+allocation takes place. Note that most small allocations only trigger
+the profiler occasionally.
+See also `profiler-log-size' and `profiler-max-stack-depth'. */)
(void)
{
- if (memory_profiler_running)
+ if (profiler_memory_running)
error ("Memory profiler is already running");
- if (!memory_log)
- memory_log = make_log ("memory",
- profiler_slot_heap_size,
+ if (NILP (memory_log))
+ memory_log = make_log (profiler_log_size,
profiler_max_stack_depth);
- memory_profiler_running = 1;
+ profiler_memory_running = true;
return Qt;
}
-DEFUN ("memory-profiler-stop",
- Fmemory_profiler_stop, Smemory_profiler_stop,
+DEFUN ("profiler-memory-stop",
+ Fprofiler_memory_stop, Sprofiler_memory_stop,
0, 0, 0,
- doc: /* Stop memory profiler. Profiler log will be kept. */)
+ doc: /* Stop the memory profiler. The profiler log is not affected.
+Return non-nil if the profiler was running. */)
(void)
{
- if (!memory_profiler_running)
- error ("Memory profiler is not running");
- memory_profiler_running = 0;
-
+ if (!profiler_memory_running)
+ return Qnil;
+ profiler_memory_running = false;
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,
+DEFUN ("profiler-memory-running-p",
+ Fprofiler_memory_running_p, Sprofiler_memory_running_p,
0, 0, 0,
- doc: /* Return t if memory profiler is running. */)
+ doc: /* Return non-nil if memory profiler is running. */)
(void)
{
- return memory_profiler_running ? Qt : Qnil;
+ return profiler_memory_running ? Qt : Qnil;
}
-DEFUN ("memory-profiler-log",
- Fmemory_profiler_log, Smemory_profiler_log,
+DEFUN ("profiler-memory-log",
+ Fprofiler_memory_log, Sprofiler_memory_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. */)
+ doc: /* Return the current memory profiler log.
+The log is a hash-table mapping backtraces to counters which represent
+the amount of memory allocated at those points. Every backtrace is a vector
+of functions, where the last few elements may be nil.
+Before returning, a new log is allocated for future samples. */)
(void)
{
- Lisp_Object result = Qnil;
-
- if (memory_log)
- result = log_object (memory_log);
-
+ 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 = (profiler_memory_running
+ ? make_log (profiler_log_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)
-{
- 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);
+ eassert (HASH_TABLE_P (memory_log));
+ record_backtrace (XHASH_TABLE (memory_log), min (size, MOST_POSITIVE_FIXNUM));
}
void
syms_of_profiler (void)
{
- DEFSYM (Qgc, "gc");
-
DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
- doc: /* FIXME */);
+ doc: /* Number of elements from the call-stack recorded in the log. */);
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);
+ DEFVAR_INT ("profiler-log-size", profiler_log_size,
+ doc: /* Number of distinct call-stacks that can be recorded in a profiler log.
+If the log gets full, some of the least-seen call-stacks will be evicted
+to make room for new entries. */);
+ profiler_log_size = 10000;
+
+#ifdef PROFILER_CPU_SUPPORT
+ profiler_cpu_running = NOT_RUNNING;
+ cpu_log = Qnil;
+ staticpro (&cpu_log);
+ defsubr (&Sprofiler_cpu_start);
+ defsubr (&Sprofiler_cpu_stop);
+ defsubr (&Sprofiler_cpu_running_p);
+ defsubr (&Sprofiler_cpu_log);
+#endif
+ profiler_memory_running = false;
+ memory_log = Qnil;
+ staticpro (&memory_log);
+ defsubr (&Sprofiler_memory_start);
+ defsubr (&Sprofiler_memory_stop);
+ defsubr (&Sprofiler_memory_running_p);
+ defsubr (&Sprofiler_memory_log);
}