Add GC profiler.

4 files changed, 157 insertions, 50 deletions

diff --git a/lisp/profiler.el b/lisp/profiler.el
index 9e94f0d078c..3f10735ccba 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -44,10 +44,16 @@
 (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
@@ -60,6 +66,30 @@
            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)))
+
+
+
+;;; Backtrace data structure
+
+(defun profiler-backtrace-reverse (backtrace)
+  (cl-case (car backtrace)
+    ((t gc)
+     (cons (car backtrace)
+           (reverse (cdr backtrace))))
+    (t (reverse backtrace))))
+
 
 
 ;;; Slot data structure
@@ -105,7 +135,7 @@
              (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)))))))
@@ -129,6 +159,8 @@
 (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)))))
 
@@ -138,6 +170,8 @@
 (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)))))
 
@@ -166,7 +200,9 @@
           (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))
@@ -179,20 +215,27 @@
   (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)))
@@ -231,8 +274,8 @@
                (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)
@@ -244,6 +287,8 @@
          (cond
           ((eq entry t)
            "Others")
+          ((eq entry 'gc)
+           "Garbage Collection")
           ((and (symbolp entry)
                 (fboundp entry))
            (propertize (symbol-name entry)
@@ -462,7 +507,7 @@ otherwise collapse the 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>))))
diff --git a/src/alloc.c b/src/alloc.c
index 3a4a8de90f5..389da29a533 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5380,6 +5380,23 @@ bounded_number (EMACS_INT number)
   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
@@ -5405,6 +5422,7 @@ See Info node `(elisp)Garbage Collection'.  */)
   ptrdiff_t count = SPECPDL_INDEX ();
   EMACS_TIME start;
   Lisp_Object retval = Qnil;
+  size_t tot_before = 0;
 
   if (abort_on_gc)
     abort ();
@@ -5421,6 +5439,9 @@ See Info node `(elisp)Garbage Collection'.  */)
   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,
@@ -5467,6 +5488,7 @@ See Info node `(elisp)Garbage Collection'.  */)
   shrink_regexp_cache ();
 
   gc_in_progress = 1;
+  is_in_trace = 1;
 
   /* Mark all the special slots that serve as the roots of accessibility.  */
 
@@ -5587,6 +5609,7 @@ See Info node `(elisp)Garbage Collection'.  */)
   check_cons_list ();
 
   gc_in_progress = 0;
+  is_in_trace = 0;
 
   consing_since_gc = 0;
   if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
@@ -5595,16 +5618,7 @@ See Info node `(elisp)Garbage Collection'.  */)
   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)
@@ -5707,6 +5721,25 @@ See Info node `(elisp)Garbage Collection'.  */)
 
   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;
 }
 
diff --git a/src/lisp.h b/src/lisp.h
index b4cead003c2..a979d45b49f 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3532,12 +3532,18 @@ void syms_of_dbusbind (void);
 /* 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);
 
diff --git a/src/profiler.c b/src/profiler.c
index 56458c64b85..c26761148df 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -25,6 +25,9 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #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);
@@ -350,8 +353,8 @@ struct slot
 {
   struct slot *next, *prev;
   Lisp_Object backtrace;
-  unsigned int count;
-  unsigned int elapsed;
+  size_t count;
+  size_t elapsed;
   unsigned char used : 1;
 };
 
@@ -536,8 +539,8 @@ struct log
   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 *
@@ -647,22 +650,23 @@ ensure_slot (struct log *log, Lisp_Object backtrace)
 }
 
 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);
@@ -675,6 +679,12 @@ record_backtrace (struct log *log, unsigned int count, unsigned int elapsed)
     }
 }
 
+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)
 {
@@ -892,7 +902,8 @@ DEFUN ("memory-profiler-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
@@ -916,7 +927,17 @@ unblock_sigprof (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);
 }
 
 
@@ -942,6 +963,8 @@ mark_profiler (void)
 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;