(defun profiler-format (fmt &rest args)
(cl-loop for (width align subfmt) in fmt
for arg in args
- for str = (cl-typecase subfmt
- (cons (apply 'profiler-format subfmt arg))
- (string (format subfmt arg))
- (t (profiler-ensure-string arg)))
+ for str = (cond
+ ((consp subfmt)
+ (apply 'profiler-format subfmt arg))
+ ((stringp subfmt)
+ (format subfmt arg))
+ ((and (symbolp subfmt)
+ (fboundp subfmt))
+ (funcall subfmt arg))
+ (t
+ (profiler-ensure-string arg)))
for len = (length str)
if (< width len)
collect (substring str 0 width) into frags
into frags
finally return (apply #'concat frags)))
+(defun profiler-format-nbytes (nbytes)
+ (if (and (integerp nbytes) (> nbytes 0))
+ (cl-loop with i = (% (1+ (floor (log10 nbytes))) 3)
+ for c in (append (number-to-string nbytes) nil)
+ if (= i 0)
+ collect ?, into s
+ and do (setq i 3)
+ collect c into s
+ do (cl-decf i)
+ finally return
+ (apply 'string (if (eq (car s) ?,) (cdr s) s)))
+ (profiler-ensure-string nbytes)))
+
+\f
+
+;;; Backtrace data structure
+
+(defun profiler-backtrace-reverse (backtrace)
+ (cl-case (car backtrace)
+ ((t gc)
+ (cons (car backtrace)
+ (reverse (cdr backtrace))))
+ (t (reverse backtrace))))
+
\f
;;; Slot data structure
(format "#<compiled 0x%x>" (sxhash entry)))
((subrp entry)
(subr-name entry))
- ((symbolp entry)
+ ((or (symbolp entry) (stringp entry))
entry)
(t
(format "#<unknown 0x%x>" (sxhash entry)))))))
(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-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)))))
(count (profiler-slot-count slot))
(elapsed (profiler-slot-elapsed slot))
(node tree))
- (dolist (entry (if reverse backtrace (reverse backtrace)))
+ (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))
(let ((total-count 0)
(total-elapsed 0))
(dolist (child (profiler-calltree-children tree))
- (cl-incf total-count (profiler-calltree-count child))
- (cl-incf total-elapsed (profiler-calltree-elapsed child)))
- (profiler-calltree-walk
- tree (lambda (node)
- (unless (zerop total-count)
- (setf (profiler-calltree-count-percent node)
- (format "%s%%"
- (/ (* (profiler-calltree-count node) 100)
- total-count))))
- (unless (zerop total-elapsed)
- (setf (profiler-calltree-elapsed-percent node)
- (format "%s%%"
- (/ (* (profiler-calltree-elapsed node) 100)
- total-elapsed))))))))
+ (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))
+ (if (eq (profiler-calltree-entry child) 'gc)
+ (setf (profiler-calltree-count-percent child) ""
+ (profiler-calltree-elapsed-percent child) "")
+ (profiler-calltree-walk
+ child
+ (lambda (node)
+ (unless (zerop total-count)
+ (setf (profiler-calltree-count-percent node)
+ (format "%s%%"
+ (/ (* (profiler-calltree-count node) 100)
+ total-count))))
+ (unless (zerop total-elapsed)
+ (setf (profiler-calltree-elapsed-percent node)
+ (format "%s%%"
+ (/ (* (profiler-calltree-elapsed node) 100)
+ total-elapsed))))))))))
(cl-defun profiler-calltree-build (log &key reverse)
(let ((tree (profiler-make-calltree)))
(5 right)))))
(defvar profiler-report-memory-line-format
- '((60 left)
- (14 right ((9 right)
+ '((55 left)
+ (19 right ((14 right profiler-format-nbytes)
(5 right)))))
(defvar profiler-report-log nil)
(cond
((eq entry t)
"Others")
+ ((eq entry 'gc)
+ "Garbage Collection")
((and (symbolp entry)
(fboundp entry))
(propertize (symbol-name entry)
(setq header-line-format
(profiler-report-header-line-format
profiler-report-memory-line-format
- "Function" (list "Alloc" "%")))
+ "Function" (list "Bytes" "%")))
(let ((predicate (cl-ecase order
(ascending 'profiler-calltree-count<)
(descending 'profiler-calltree-count>))))
return make_number (min (MOST_POSITIVE_FIXNUM, number));
}
+/* Calculate total bytes of live objects. */
+
+static size_t
+total_bytes_of_live_objects (void)
+{
+ size_t tot = 0;
+ tot += total_conses * sizeof (struct Lisp_Cons);
+ tot += total_symbols * sizeof (struct Lisp_Symbol);
+ tot += total_markers * sizeof (union Lisp_Misc);
+ tot += total_string_bytes;
+ tot += total_vector_slots * word_size;
+ tot += total_floats * sizeof (struct Lisp_Float);
+ tot += total_intervals * sizeof (struct interval);
+ tot += total_strings * sizeof (struct Lisp_String);
+ return tot;
+}
+
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: /* Reclaim storage for Lisp objects no longer needed.
Garbage collection happens automatically if you cons more than
ptrdiff_t count = SPECPDL_INDEX ();
EMACS_TIME start;
Lisp_Object retval = Qnil;
+ size_t tot_before = 0;
if (abort_on_gc)
abort ();
FOR_EACH_BUFFER (nextb)
compact_buffer (nextb);
+ if (memory_profiler_running)
+ tot_before = total_bytes_of_live_objects ();
+
start = current_emacs_time ();
/* In case user calls debug_print during GC,
shrink_regexp_cache ();
gc_in_progress = 1;
+ is_in_trace = 1;
/* Mark all the special slots that serve as the roots of accessibility. */
check_cons_list ();
gc_in_progress = 0;
+ is_in_trace = 0;
consing_since_gc = 0;
if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
gc_relative_threshold = 0;
if (FLOATP (Vgc_cons_percentage))
{ /* Set gc_cons_combined_threshold. */
- double tot = 0;
-
- tot += total_conses * sizeof (struct Lisp_Cons);
- tot += total_symbols * sizeof (struct Lisp_Symbol);
- tot += total_markers * sizeof (union Lisp_Misc);
- tot += total_string_bytes;
- tot += total_vector_slots * word_size;
- tot += total_floats * sizeof (struct Lisp_Float);
- tot += total_intervals * sizeof (struct interval);
- tot += total_strings * sizeof (struct Lisp_String);
+ double tot = total_bytes_of_live_objects ();
tot *= XFLOAT_DATA (Vgc_cons_percentage);
if (0 < tot)
gcs_done++;
+ /* Collect profiling data. */
+ if (sample_profiler_running || memory_profiler_running)
+ {
+ size_t swept = 0;
+ size_t elapsed = 0;
+ if (memory_profiler_running)
+ {
+ size_t tot_after = total_bytes_of_live_objects ();
+ if (tot_before > tot_after)
+ swept = tot_before - tot_after;
+ }
+ if (sample_profiler_running)
+ {
+ EMACS_TIME since_start = sub_emacs_time (current_emacs_time (), start);
+ elapsed = EMACS_TIME_TO_DOUBLE (since_start) * 1000;
+ }
+ gc_probe (swept, elapsed);
+ }
+
return retval;
}
/* Defined in profiler.c */
extern int sample_profiler_running;
extern int memory_profiler_running;
+extern int is_in_trace;
+extern Lisp_Object Qgc;
extern void malloc_probe (size_t);
-#define MALLOC_PROBE(size) \
- do { \
- if (memory_profiler_running) \
- malloc_probe (size); \
+extern void gc_probe (size_t, size_t);
+#define ENTER_TRACE (is_in_trace = 1)
+#define LEAVE_TRACE (is_in_trace = 0)
+#define MALLOC_PROBE(size) \
+ do { \
+ if (memory_profiler_running) \
+ malloc_probe (size); \
} while (0)
+
extern void mark_profiler (void);
extern void syms_of_profiler (void);
#include <setjmp.h>
#include "lisp.h"
+int is_in_trace;
+Lisp_Object Qgc;
+
static void sigprof_handler (int, siginfo_t *, void *);
static void block_sigprof (void);
static void unblock_sigprof (void);
{
struct slot *next, *prev;
Lisp_Object backtrace;
- unsigned int count;
- unsigned int elapsed;
+ size_t count;
+ size_t elapsed;
unsigned char used : 1;
};
Lisp_Object backtrace;
struct slot_heap *slot_heap;
struct slot_table *slot_table;
- unsigned int others_count;
- unsigned int others_elapsed;
+ size_t others_count;
+ size_t others_elapsed;
};
static struct log *
}
static void
-record_backtrace (struct log *log, unsigned int count, unsigned int elapsed)
+record_backtrace_under (struct log *log, Lisp_Object base,
+ size_t count, size_t elapsed)
{
- int i;
+ int i = 0;
Lisp_Object backtrace = log->backtrace;
struct backtrace *backlist = backtrace_list;
if (!apply_filter (backlist)) return;
- for (i = 0; i < ASIZE (backtrace) && backlist; backlist = backlist->next)
+ if (!NILP (base) && ASIZE (backtrace) > 0)
+ ASET (backtrace, i++, base);
+
+ for (; i < ASIZE (backtrace) && backlist; backlist = backlist->next)
{
Lisp_Object function = *backlist->function;
if (FUNCTIONP (function))
- {
- ASET (backtrace, i, function);
- i++;
- }
+ ASET (backtrace, i++, function);
}
for (; i < ASIZE (backtrace); i++)
ASET (backtrace, i, Qnil);
}
}
+static void
+record_backtrace (struct log *log, size_t count, size_t elapsed)
+{
+ record_backtrace_under (log, Qnil, count, elapsed);
+}
+
static Lisp_Object
log_object (struct log *log)
{
static void
sigprof_handler (int signal, siginfo_t *info, void *ctx)
{
- record_backtrace (sample_log, 1, current_sample_interval);
+ if (!is_in_trace && sample_log)
+ record_backtrace (sample_log, 1, current_sample_interval);
}
static void
void
malloc_probe (size_t size)
{
- record_backtrace (memory_log, size, 0);
+ 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);
}
\f
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;
projects / emacs.git / commitdiff