X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/12b3895d742e06ba3999773f0f02328ae7d9880f..207cb73c182d432a00fef797428d3b79ab519287:/src/profiler.c diff --git a/src/profiler.c b/src/profiler.c index c26761148d..51580710f2 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -1,4 +1,4 @@ -/* GNU Emacs profiler implementation. +/* Profiler implementation. Copyright (C) 2012 Free Software Foundation, Inc. @@ -18,971 +18,529 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ #include -#include -#include -#include -#include -#include #include "lisp.h" +#include "syssignal.h" +#include "systime.h" -int is_in_trace; -Lisp_Object Qgc; +/* Return A + B, but return the maximum fixnum if the result would overflow. + Assume A and B are nonnegative and in fixnum range. */ -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 */ - -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); -} - -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); - } -} - -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; -} - -#if 0 -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 - -static struct pattern *filter_pattern; - -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) return; - filter_pattern = parse_pattern (pattern); - - if (sample_profiler_running) - unblock_sigprof (); -} - -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); -} - -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: /* FIXME */) - (Lisp_Object pattern) -{ - if (NILP (pattern)) - { - set_filter_pattern (0); - return Qt; - } - else if (!STRINGP (pattern)) - error ("Invalid type of profiler filter pattern"); - - set_filter_pattern (SDATA (pattern)); - - return Qt; + return min (a + b, MOST_POSITIVE_FIXNUM); } - +/* Logs. */ -/* Backtraces */ +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)); -} - -static Lisp_Object -backtrace_object (Lisp_Object backtrace) -{ - backtrace_object_1 (backtrace, 0); -} - - - -/* Slots */ - -struct slot -{ - struct slot *next, *prev; - Lisp_Object backtrace; - size_t count; - size_t elapsed; - unsigned char used : 1; -}; - -static void -mark_slot (struct slot *slot) -{ - mark_object (slot->backtrace); -} - -static Lisp_Object -slot_object (struct slot *slot) -{ - return list3 (backtrace_object (slot->backtrace), - make_number (slot->count), - make_number (slot->elapsed)); -} - - - -/* Slot heaps */ - -struct slot_heap -{ - unsigned int size; - struct slot *data; - 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; - - for (i = 0; i < heap->size; i++) - data[i].used = 0; - - 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; } -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; + /* 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); + } } -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); -} +/* 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 -mark_slot_heap (struct slot_heap *heap) +record_backtrace (log_t *log, EMACS_INT count) { - int i; - for (i = 0; i < heap->size; i++) - mark_slot (&heap->data[i]); -} - -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; -} + struct backtrace *backlist = backtrace_list; + Lisp_Object backtrace; + ptrdiff_t index, i = 0; + ptrdiff_t asize; + + 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); + + /* 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) + /* FIXME: For closures we should ignore the environment. */ + 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); -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; + { /* 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. */ + } + } } + +/* Sampling profiler. */ -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; -} +#ifdef PROFILER_CPU_SUPPORT - +/* 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 -/* Slot tables */ +/* Status of sampling profiler. */ +static enum profiler_cpu_running + { NOT_RUNNING, TIMER_SETTIME_RUNNING, SETITIMER_RUNNING } + profiler_cpu_running; -struct slot_table -{ - unsigned int size; - struct slot **data; -}; +/* Hash-table log of CPU profiler. */ +static Lisp_Object cpu_log; -static void -clear_slot_table (struct slot_table *table) -{ - int i; - for (i = 0; i < table->size; i++) - table->data[i] = 0; -} +/* Separate counter for the time spent in the GC. */ +static EMACS_INT cpu_gc_count; -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; -} +/* The current sampling interval in nanoseconds. */ +static EMACS_INT current_sampling_interval; -static void -free_slot_table (struct slot_table *table) -{ - xfree (table->data); - xfree (table); -} +/* Signal handler for sampling profiler. */ static void -remove_slot (struct slot_table *table, struct slot *slot) -{ - if (slot->prev) - slot->prev->next = slot->next; +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 { - EMACS_UINT hash = backtrace_hash (slot->backtrace); - table->data[hash % table->size] = slot->next; + 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; } - if (slot->next) - slot->next->prev = slot->prev; -} - - - -/* Logs */ - -struct log -{ - Lisp_Object type; - 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); - 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) +deliver_profiler_signal (int signal) { - clear_slot_heap (log->slot_heap); - clear_slot_table (log->slot_table); - log->others_count = 0; - log->others_elapsed = 0; + deliver_process_signal (signal, handle_profiler_signal); } -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); -} - -static void -evict_min_slot (struct log *log) +static enum profiler_cpu_running +setup_cpu_timer (Lisp_Object sampling_interval) { - struct slot *min = min_slot (log->slot_heap); - if (min) - evict_slot (log, min); -} - -static struct slot * -new_slot (struct log *log, Lisp_Object backtrace) -{ - int i; - struct slot *slot = allocate_slot (log->slot_heap); - - if (!slot) - { - evict_min_slot (log); - slot = allocate_slot (log->slot_heap); - eassert (slot); - } - - slot->prev = 0; - slot->next = 0; - for (i = 0; i < ASIZE (backtrace); i++) - ASET (slot->backtrace, i, AREF (backtrace, i)); - - return 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; - - while (slot) - { - if (backtrace_equal (backtrace, slot->backtrace)) - goto found; - prev = slot; - slot = slot->next; - } - - slot = new_slot (log, backtrace); - if (prev) + 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) { - slot->prev = prev; - prev->next = 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; + } } - else - log->slot_table->data[index] = slot; - - found: - return slot; -} - -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; - - if (!apply_filter (backlist)) return; - - if (!NILP (base) && ASIZE (backtrace) > 0) - ASET (backtrace, i++, base); - for (; i < ASIZE (backtrace) && backlist; backlist = backlist->next) + if (profiler_timer_ok) { - Lisp_Object function = *backlist->function; - if (FUNCTIONP (function)) - ASET (backtrace, i++, function); + struct itimerspec ispec; + ispec.it_value = ispec.it_interval = interval; + if (timer_settime (profiler_timer, 0, &ispec, 0) == 0) + return TIMER_SETTIME_RUNNING; } - for (; i < ASIZE (backtrace); i++) - ASET (backtrace, i, Qnil); +#endif - if (!NILP (AREF (backtrace, 0))) - { - struct slot *slot = ensure_slot (log, backtrace); - slot->count += count; - slot->elapsed += elapsed; - } -} +#ifdef HAVE_SETITIMER + timer.it_value = timer.it_interval = make_timeval (interval); + if (setitimer (ITIMER_PROF, &timer, 0) == 0) + return SETITIMER_RUNNING; +#endif -static void -record_backtrace (struct log *log, size_t count, size_t elapsed) -{ - record_backtrace_under (log, Qnil, count, elapsed); + return NOT_RUNNING; } -static Lisp_Object -log_object (struct log *log) +DEFUN ("profiler-cpu-start", Fprofiler_cpu_start, Sprofiler_cpu_start, + 1, 1, 0, + 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) { - int i; - Lisp_Object slots = Qnil; - - if (log->others_count != 0 || log->others_elapsed != 0) - slots = list1 (list3 (list1 (Qt), - make_number (log->others_count), - make_number (log->others_elapsed))); + if (profiler_cpu_running) + error ("CPU profiler is already running"); - for (i = 0; i < log->slot_heap->size; i++) + if (NILP (cpu_log)) { - struct slot *s = &log->slot_heap->data[i]; - if (s->used) - { - Lisp_Object slot = slot_object (s); - slots = Fcons (slot, slots); - } + cpu_gc_count = 0; + cpu_log = make_log (profiler_log_size, + profiler_max_stack_depth); } - return list4 (log->type, Qnil, Fcurrent_time (), slots); -} - - - -/* Sample profiler */ - -static struct log *sample_log; -static int current_sample_interval; - -DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start, - 1, 1, 0, - doc: /* FIXME */) - (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; + 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: /* FIXME */) + 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, - 0, 0, 0, - doc: /* FIXME */) - (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, +DEFUN ("profiler-cpu-running-p", + Fprofiler_cpu_running_p, Sprofiler_cpu_running_p, 0, 0, 0, - doc: /* FIXME */) + doc: /* Return non-nil iff cpu 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: /* FIXME */) + 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 */ +/* Memory profiler. */ -/* Memory profiler */ +/* True if memory profiler is running. */ +bool profiler_memory_running; -static struct log *memory_log; +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: /* FIXME */) + 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: /* FIXME */) + 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, +DEFUN ("profiler-memory-running-p", + Fprofiler_memory_running_p, Sprofiler_memory_running_p, 0, 0, 0, - doc: /* FIXME */) + doc: /* Return non-nil if memory profiler is running. */) (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: /* FIXME */) - (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: /* FIXME */) + 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; } +/* Signals and probes. */ -/* Signals and probes */ - -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); -} - -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); -} - - - -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); }