Use ad-hoc comparison function for the profiler's hash-tables.

* src/profiler.c (Qprofiler_backtrace_equal, hashtest_profiler): New vars.
(make_log): Use them.
(handle_profiler_signal): Don't inhibit quit any longer since we don't
call Fequal any more.
(Ffunction_equal): New function.
(cmpfn_profiler, hashfn_profiler): New functions.
(syms_of_profiler): Initialize them.
* src/lisp.h (struct hash_table_test): New struct.
(struct Lisp_Hash_Table): Use it.
* src/alloc.c (mark_object): Mark hash_table_test fields of hash tables.
* src/fns.c (make_hash_table): Take a struct to describe the test.
(cmpfn_eql, cmpfn_equal, cmpfn_user_defined, hashfn_eq, hashfn_eql)
(hashfn_equal, hashfn_user_defined): Adjust to new calling convention.
(hash_lookup, hash_remove_from_table): Move assertion checking of
hashfn result here.  Check hash-equality before calling cmpfn.
(Fmake_hash_table): Adjust call to make_hash_table.
(hashtest_eq, hashtest_eql, hashtest_equal): New structs.
(syms_of_fns): Initialize them.
* src/emacs.c (main): Move syms_of_fns earlier.
* src/xterm.c (syms_of_xterm):
* src/category.c (hash_get_category_set): Adjust call to make_hash_table.
* src/print.c (print_object): Adjust to new hash-table struct.
* src/composite.c (composition_gstring_put_cache): Adjust to new hashfn.

1 files changed, 76 insertions, 15 deletions

diff --git a/src/profiler.c b/src/profiler.c
index 51580710f28..6f112440902 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -35,6 +35,9 @@ saturated_add (EMACS_INT a, EMACS_INT b)
 
 typedef struct Lisp_Hash_Table log_t;
 
+static Lisp_Object Qprofiler_backtrace_equal;
+static struct hash_table_test hashtest_profiler;
+
 static Lisp_Object
 make_log (int heap_size, int max_stack_depth)
 {
@@ -42,10 +45,11 @@ make_log (int heap_size, int max_stack_depth)
      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),
+  Lisp_Object log = make_hash_table (hashtest_profiler,
+                                     make_number (heap_size),
                                      make_float (DEFAULT_REHASH_SIZE),
                                      make_float (DEFAULT_REHASH_THRESHOLD),
-                                     Qnil, 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
@@ -238,8 +242,6 @@ handle_profiler_signal (int signal)
     cpu_gc_count = saturated_add (cpu_gc_count, 1);
   else
     {
-      Lisp_Object oquit;
-      bool saved_pending_signals;
       EMACS_INT count = 1;
 #ifdef HAVE_ITIMERSPEC
       if (profiler_timer_ok)
@@ -249,19 +251,8 @@ handle_profiler_signal (int signal)
           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;
     }
 }
 
@@ -515,6 +506,66 @@ malloc_probe (size_t size)
   record_backtrace (XHASH_TABLE (memory_log), min (size, MOST_POSITIVE_FIXNUM));
 }
 
+DEFUN ("function-equal", Ffunction_equal, Sfunction_equal, 2, 2, 0,
+       doc: /* Return non-nil if F1 and F2 come from the same source.
+Used to determine if different closures are just different instances of
+the same lambda expression, or are really unrelated function.  */)
+     (Lisp_Object f1, Lisp_Object f2)
+{
+  bool res;
+  if (EQ (f1, f2))
+    res = true;
+  else if (COMPILEDP (f1) && COMPILEDP (f2))
+    res = EQ (AREF (f1, COMPILED_BYTECODE), AREF (f2, COMPILED_BYTECODE));
+  else if (CONSP (f1) && CONSP (f2) && CONSP (XCDR (f1)) && CONSP (XCDR (f2))
+           && EQ (Qclosure, XCAR (f1))
+           && EQ (Qclosure, XCAR (f2)))
+    res = EQ (XCDR (XCDR (f1)), XCDR (XCDR (f2)));
+  else
+    res = false;
+  return res ? Qt : Qnil;
+}
+
+static bool
+cmpfn_profiler (struct hash_table_test *t,
+                Lisp_Object bt1, Lisp_Object bt2)
+{
+  if (VECTORP (bt1) && VECTORP (bt2))
+    {
+      ptrdiff_t i, l = ASIZE (bt1);
+      if (l != ASIZE (bt2))
+        return false;
+      for (i = 0; i < l; i++)
+        if (NILP (Ffunction_equal (AREF (bt1, i), AREF (bt2, i))))
+          return false;
+      return true;
+    }
+  else
+    return EQ (bt1, bt2);
+}
+
+static EMACS_UINT
+hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt)
+{
+  if (VECTORP (bt))
+    {
+      EMACS_UINT hash = 0;
+      ptrdiff_t i, l = ASIZE (bt);
+      for (i = 0; i < l; i++)
+        {
+          Lisp_Object f = AREF (bt, i);
+          EMACS_UINT hash1
+            = (COMPILEDP (f) ? XUINT (AREF (f, COMPILED_BYTECODE))
+               : (CONSP (f) && CONSP (XCDR (f)) && EQ (Qclosure, XCAR (f)))
+               ? XUINT (XCDR (XCDR (f))) : XUINT (f));
+          hash = hash1 + (hash << 1) + (hash == (EMACS_INT) hash);
+        }
+      return (hash & INTMASK);
+    }
+  else
+    return XUINT (bt);
+}
+
 void
 syms_of_profiler (void)
 {
@@ -527,6 +578,16 @@ 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;
 
+  DEFSYM (Qprofiler_backtrace_equal, "profiler-backtrace-equal");
+  {
+    struct hash_table_test test
+      = { Qprofiler_backtrace_equal, Qnil, Qnil,
+          cmpfn_profiler, hashfn_profiler };
+    hashtest_profiler = test;
+  }
+
+  defsubr (&Sfunction_equal);
+
 #ifdef PROFILER_CPU_SUPPORT
   profiler_cpu_running = NOT_RUNNING;
   cpu_log = Qnil;