bug#36597: 27.0.50; rehash hash tables eagerly in pdumper

[Paul Eggert <eggert@cs.ucla.edu>]

[-- Attachment #1: Type: text/plain, Size: 699 bytes --]

Pip Cet wrote:
> I'm currently playing around with redefining hash tables not to have
> internal freelists. That makes the hash table code a lot simpler
> overall, but some of that simplicity would be lost trying to support
> lazy hash table rehashing.

While looking into this I discovered unlikely bugs in Emacs's hash table code 
and GC that can make Emacs dump core, along with some other unlikely hash-table 
bugs that can cause Emacs to report memory exhaustion when there should be 
plenty of memory. I installed the attached patches to fix these problems and to 
refactor to make this code easier to understand (at least for me :-). These 
patches will probably affect performance analysis.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Fix-hash-table-overallocation-etc.patch --]
[-- Type: text/x-patch; name="0001-Fix-hash-table-overallocation-etc.patch", Size: 5716 bytes --]

From b0908a0fe6dc4f878b05a8b26ed3ff0c702e26c7 Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sat, 20 Jul 2019 19:40:02 -0700
Subject: [PATCH 1/6] Fix hash table overallocation etc.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* src/fns.c (set_hash_key_and_value, set_hash_next)
(set_hash_hash, set_hash_index): Remove.  All uses removed.
(maybe_resize_hash_table): Don’t update h->next until it’s
known that all the allocations succeeded, to avoid trashing
the hash table if memory is exhausted.  Don’t overallocate the
other vectors.  Don’t output growth message if the hash table
didn’t actually grow due to allocation failure.  Assume C99
decls after statements.
---
 src/fns.c | 87 +++++++++++++++++++------------------------------------
 1 file changed, 29 insertions(+), 58 deletions(-)

diff --git a/src/fns.c b/src/fns.c
index 0497588689..4c99d974bd 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -3803,37 +3803,17 @@ CHECK_HASH_TABLE (Lisp_Object x)
   CHECK_TYPE (HASH_TABLE_P (x), Qhash_table_p, x);
 }
 
-static void
-set_hash_key_and_value (struct Lisp_Hash_Table *h, Lisp_Object key_and_value)
-{
-  h->key_and_value = key_and_value;
-}
-static void
-set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next)
-{
-  h->next = next;
-}
 static void
 set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
 {
   gc_aset (h->next, idx, make_fixnum (val));
 }
 static void
-set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash)
-{
-  h->hash = hash;
-}
-static void
 set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
 {
   gc_aset (h->hash, idx, val);
 }
 static void
-set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index)
-{
-  h->index = index;
-}
-static void
 set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
 {
   gc_aset (h->index, idx, make_fixnum (val));
@@ -4159,10 +4139,8 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
   if (h->next_free < 0)
     {
       ptrdiff_t old_size = HASH_TABLE_SIZE (h);
-      EMACS_INT new_size, index_size, nsize;
-      ptrdiff_t i;
+      EMACS_INT new_size;
       double rehash_size = h->rehash_size;
-      double index_float;
 
       if (rehash_size < 0)
 	new_size = old_size - rehash_size;
@@ -4177,50 +4155,38 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
       if (new_size <= old_size)
 	new_size = old_size + 1;
       double threshold = h->rehash_threshold;
-      index_float = new_size / threshold;
-      index_size = (index_float < INDEX_SIZE_BOUND + 1
-		    ? next_almost_prime (index_float)
-		    : INDEX_SIZE_BOUND + 1);
-      nsize = max (index_size, 2 * new_size);
-      if (INDEX_SIZE_BOUND < nsize)
+      double index_float = new_size / threshold;
+      EMACS_INT index_size = (index_float < INDEX_SIZE_BOUND + 1
+			      ? next_almost_prime (index_float)
+			      : INDEX_SIZE_BOUND + 1);
+      if (INDEX_SIZE_BOUND < max (index_size, 2 * new_size))
 	error ("Hash table too large to resize");
 
-#ifdef ENABLE_CHECKING
-      if (HASH_TABLE_P (Vpurify_flag)
-	  && XHASH_TABLE (Vpurify_flag) == h)
-	message ("Growing hash table to: %"pI"d", new_size);
-#endif
-
-      set_hash_key_and_value (h, larger_vector (h->key_and_value,
-						2 * (new_size - old_size), -1));
-      set_hash_hash (h, larger_vector (h->hash, new_size - old_size, -1));
-      set_hash_index (h, make_vector (index_size, make_fixnum (-1)));
-      set_hash_next (h, larger_vecalloc (h->next, new_size - old_size, -1));
+      /* Allocate all the new vectors before updating *H, to
+	 avoid problems if memory is exhausted.  larger_vecalloc
+	 finishes computing the size of the replacement vectors.  */
+      Lisp_Object next = larger_vecalloc (h->next, new_size - old_size, -1);
+      ptrdiff_t next_size = ASIZE (next);
+      Lisp_Object key_and_value
+	= larger_vector (h->key_and_value, 2 * (next_size - old_size),
+			 2 * next_size);
+      Lisp_Object hash = larger_vector (h->hash, next_size - old_size,
+					next_size);
+      h->index = make_vector (index_size, make_fixnum (-1));
+      h->key_and_value = key_and_value;
+      h->hash = hash;
+      h->next = next;
 
       /* Update the free list.  Do it so that new entries are added at
          the end of the free list.  This makes some operations like
          maphash faster.  */
-      for (i = old_size; i < new_size - 1; ++i)
+      for (ptrdiff_t i = old_size; i < next_size - 1; i++)
 	set_hash_next_slot (h, i, i + 1);
-      set_hash_next_slot (h, i, -1);
-
-      if (h->next_free < 0)
-	h->next_free = old_size;
-      else
-	{
-	  ptrdiff_t last = h->next_free;
-	  while (true)
-	    {
-	      ptrdiff_t next = HASH_NEXT (h, last);
-	      if (next < 0)
-		break;
-	      last = next;
-	    }
-	  set_hash_next_slot (h, last, old_size);
-	}
+      set_hash_next_slot (h, next_size - 1, -1);
+      h->next_free = old_size;
 
       /* Rehash.  */
-      for (i = 0; i < old_size; ++i)
+      for (ptrdiff_t i = 0; i < old_size; i++)
 	if (!NILP (HASH_HASH (h, i)))
 	  {
 	    EMACS_UINT hash_code = XUFIXNUM (HASH_HASH (h, i));
@@ -4228,6 +4194,11 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
 	    set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
 	    set_hash_index_slot (h, start_of_bucket, i);
 	  }
+
+#ifdef ENABLE_CHECKING
+      if (HASH_TABLE_P (Vpurify_flag) && XHASH_TABLE (Vpurify_flag) == h)
+	message ("Growing hash table to: %"pD"d", new_size);
+#endif
     }
 }
 
-- 
2.17.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-Rename-pure-to-purecopy.patch --]
[-- Type: text/x-patch; name="0002-Rename-pure-to-purecopy.patch", Size: 5390 bytes --]

From df5024dbaef5e1f7e39a2a8268523f9fc1af3118 Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sat, 20 Jul 2019 19:40:03 -0700
Subject: [PATCH 2/6] =?UTF-8?q?Rename=20=E2=80=98pure=E2=80=99=20to=20?=
 =?UTF-8?q?=E2=80=98purecopy=E2=80=99?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* src/lisp.h (struct Lisp_Hash_Table): Rename ‘pure’ member to
‘purecopy’, as the old name was quite confusing (it did not
mean the hash table was pure).  All uses changed.
---
 src/alloc.c   |  6 +++---
 src/fns.c     | 10 +++++-----
 src/lisp.h    |  2 +-
 src/pdumper.c |  2 +-
 src/print.c   |  4 ++--
 5 files changed, 12 insertions(+), 12 deletions(-)

diff --git a/src/alloc.c b/src/alloc.c
index 7a0611dd3e..8649d4e0f4 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5329,7 +5329,7 @@ make_pure_vector (ptrdiff_t len)
 purecopy_hash_table (struct Lisp_Hash_Table *table)
 {
   eassert (NILP (table->weak));
-  eassert (table->pure);
+  eassert (table->purecopy);
 
   struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
   struct hash_table_test pure_test = table->test;
@@ -5346,7 +5346,7 @@ purecopy_hash_table (struct Lisp_Hash_Table *table)
   pure->index = purecopy (table->index);
   pure->count = table->count;
   pure->next_free = table->next_free;
-  pure->pure = table->pure;
+  pure->purecopy = table->purecopy;
   pure->rehash_threshold = table->rehash_threshold;
   pure->rehash_size = table->rehash_size;
   pure->key_and_value = purecopy (table->key_and_value);
@@ -5410,7 +5410,7 @@ purecopy (Lisp_Object obj)
       /* Do not purify hash tables which haven't been defined with
          :purecopy as non-nil or are weak - they aren't guaranteed to
          not change.  */
-      if (!NILP (table->weak) || !table->pure)
+      if (!NILP (table->weak) || !table->purecopy)
         {
           /* Instead, add the hash table to the list of pinned objects,
              so that it will be marked during GC.  */
diff --git a/src/fns.c b/src/fns.c
index 4c99d974bd..d4f6842f27 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -4055,7 +4055,7 @@ #define INDEX_SIZE_BOUND \
 Lisp_Object
 make_hash_table (struct hash_table_test test, EMACS_INT size,
 		 float rehash_size, float rehash_threshold,
-		 Lisp_Object weak, bool pure)
+		 Lisp_Object weak, bool purecopy)
 {
   struct Lisp_Hash_Table *h;
   Lisp_Object table;
@@ -4094,7 +4094,7 @@ make_hash_table (struct hash_table_test test, EMACS_INT size,
   h->next = make_vector (size, make_fixnum (-1));
   h->index = make_vector (index_size, make_fixnum (-1));
   h->next_weak = NULL;
-  h->pure = pure;
+  h->purecopy = purecopy;
 
   /* Set up the free list.  */
   for (i = 0; i < size - 1; ++i)
@@ -4748,7 +4748,7 @@ DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
   (ptrdiff_t nargs, Lisp_Object *args)
 {
   Lisp_Object test, weak;
-  bool pure;
+  bool purecopy;
   struct hash_table_test testdesc;
   ptrdiff_t i;
   USE_SAFE_ALLOCA;
@@ -4784,7 +4784,7 @@ DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
 
   /* See if there's a `:purecopy PURECOPY' argument.  */
   i = get_key_arg (QCpurecopy, nargs, args, used);
-  pure = i && !NILP (args[i]);
+  purecopy = i && !NILP (args[i]);
   /* See if there's a `:size SIZE' argument.  */
   i = get_key_arg (QCsize, nargs, args, used);
   Lisp_Object size_arg = i ? args[i] : Qnil;
@@ -4835,7 +4835,7 @@ DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
 
   SAFE_FREE ();
   return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
-                          pure);
+			  purecopy);
 }
 
 
diff --git a/src/lisp.h b/src/lisp.h
index 13014c82dc..8f60963eb7 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2287,7 +2287,7 @@ #define DEFSYM(sym, name) /* empty */
 
   /* True if the table can be purecopied.  The table cannot be
      changed afterwards.  */
-  bool pure;
+  bool purecopy;
 
   /* Resize hash table when number of entries / table size is >= this
      ratio.  */
diff --git a/src/pdumper.c b/src/pdumper.c
index 03c00bf27b..206a196890 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -2741,7 +2741,7 @@ dump_hash_table (struct dump_context *ctx,
      them as close to the hash table as possible.  */
   DUMP_FIELD_COPY (out, hash, count);
   DUMP_FIELD_COPY (out, hash, next_free);
-  DUMP_FIELD_COPY (out, hash, pure);
+  DUMP_FIELD_COPY (out, hash, purecopy);
   DUMP_FIELD_COPY (out, hash, rehash_threshold);
   DUMP_FIELD_COPY (out, hash, rehash_size);
   dump_field_lv (ctx, out, hash, &hash->key_and_value, WEIGHT_STRONG);
diff --git a/src/print.c b/src/print.c
index 6623244c59..cb34090514 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1575,10 +1575,10 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
 	print_object (Fhash_table_rehash_threshold (obj),
 		      printcharfun, escapeflag);
 
-	if (h->pure)
+	if (h->purecopy)
 	  {
 	    print_c_string (" purecopy ", printcharfun);
-	    print_object (h->pure ? Qt : Qnil, printcharfun, escapeflag);
+	    print_object (h->purecopy ? Qt : Qnil, printcharfun, escapeflag);
 	  }
 
 	print_c_string (" data ", printcharfun);
-- 
2.17.1


[-- Attachment #4: 0003-Simplify-maybe_gc-implementation.patch --]
[-- Type: text/x-patch, Size: 7183 bytes --]

From 26de2d42d0460c5b193456950a568cb04a29dc00 Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sat, 20 Jul 2019 19:40:03 -0700
Subject: [PATCH 3/6] Simplify maybe_gc implementation

* src/alloc.c (consing_until_gc): New variable, replacing the
combination of consing_since_gc and gc_relative_threshold.
All uses changed.
(byte_ct): Move decl here from lisp.h.
(memory_full_cons_threshold): New an enum constant.
(free_cons): Check for integer overflow in
statistics calculation.
* src/lisp.h (object_ct): Move decl here from alloc.c.
(OBJECT_CT_MAX): New macro.
(maybe_gc): Simplify accordingly.
---
 src/alloc.c | 68 ++++++++++++++++++++++++++---------------------------
 src/lisp.h  | 12 ++++------
 2 files changed, 38 insertions(+), 42 deletions(-)

diff --git a/src/alloc.c b/src/alloc.c
index 8649d4e0f4..9d18fd918b 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -222,13 +222,9 @@ #define GC_DEFAULT_THRESHOLD (100000 * word_size)
 /* Global variables.  */
 struct emacs_globals globals;
 
-/* Number of bytes of consing done since the last gc.  */
+/* maybe_gc collects garbage if this goes negative.  */
 
-byte_ct consing_since_gc;
-
-/* Similar minimum, computed from Vgc_cons_percentage.  */
-
-byte_ct gc_relative_threshold;
+object_ct consing_until_gc;
 
 #ifdef HAVE_PDUMPER
 /* Number of finalizers run: used to loop over GC until we stop
@@ -240,10 +236,9 @@ #define GC_DEFAULT_THRESHOLD (100000 * word_size)
 
 bool gc_in_progress;
 
-/* Type of object counts reported by GC.  Unlike byte_ct, this can be
-   signed, e.g., it is less than 2**31 on a typical 32-bit machine.  */
+/* System byte counts reported by GC.  */
 
-typedef intptr_t object_ct;
+typedef uintptr_t byte_ct;
 
 /* Number of live and free conses etc.  */
 
@@ -1373,7 +1368,7 @@ make_interval (void)
 
   MALLOC_UNBLOCK_INPUT;
 
-  consing_since_gc += sizeof (struct interval);
+  consing_until_gc -= sizeof (struct interval);
   intervals_consed++;
   gcstat.total_free_intervals--;
   RESET_INTERVAL (val);
@@ -1745,7 +1740,7 @@ allocate_string (void)
   gcstat.total_free_strings--;
   gcstat.total_strings++;
   ++strings_consed;
-  consing_since_gc += sizeof *s;
+  consing_until_gc -= sizeof *s;
 
 #ifdef GC_CHECK_STRING_BYTES
   if (!noninteractive)
@@ -1865,7 +1860,7 @@ allocate_string_data (struct Lisp_String *s,
       old_data->string = NULL;
     }
 
-  consing_since_gc += needed;
+  consing_until_gc -= needed;
 }
 
 
@@ -2471,7 +2466,7 @@ make_float (double float_value)
 
   XFLOAT_INIT (val, float_value);
   eassert (!XFLOAT_MARKED_P (XFLOAT (val)));
-  consing_since_gc += sizeof (struct Lisp_Float);
+  consing_until_gc -= sizeof (struct Lisp_Float);
   floats_consed++;
   gcstat.total_free_floats--;
   return val;
@@ -2521,7 +2516,7 @@ #define XUNMARK_CONS(fptr) \
 /* Minimum number of bytes of consing since GC before next GC,
    when memory is full.  */
 
-byte_ct const memory_full_cons_threshold = sizeof (struct cons_block);
+enum { memory_full_cons_threshold = sizeof (struct cons_block) };
 
 /* Current cons_block.  */
 
@@ -2543,7 +2538,8 @@ free_cons (struct Lisp_Cons *ptr)
   ptr->u.s.u.chain = cons_free_list;
   ptr->u.s.car = dead_object ();
   cons_free_list = ptr;
-  consing_since_gc -= sizeof *ptr;
+  if (INT_ADD_WRAPV (consing_until_gc, sizeof *ptr, &consing_until_gc))
+    consing_until_gc = OBJECT_CT_MAX;
   gcstat.total_free_conses++;
 }
 
@@ -2594,7 +2590,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
   XSETCAR (val, car);
   XSETCDR (val, cdr);
   eassert (!XCONS_MARKED_P (XCONS (val)));
-  consing_since_gc += sizeof (struct Lisp_Cons);
+  consing_until_gc -= sizeof (struct Lisp_Cons);
   gcstat.total_free_conses--;
   cons_cells_consed++;
   return val;
@@ -3176,7 +3172,7 @@ allocate_vectorlike (ptrdiff_t len)
   if (find_suspicious_object_in_range (p, (char *) p + nbytes))
     emacs_abort ();
 
-  consing_since_gc += nbytes;
+  consing_until_gc -= nbytes;
   vector_cells_consed += len;
 
   MALLOC_UNBLOCK_INPUT;
@@ -3462,7 +3458,7 @@ DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
   MALLOC_UNBLOCK_INPUT;
 
   init_symbol (val, name);
-  consing_since_gc += sizeof (struct Lisp_Symbol);
+  consing_until_gc -= sizeof (struct Lisp_Symbol);
   symbols_consed++;
   gcstat.total_free_symbols--;
   return val;
@@ -3862,6 +3858,7 @@ memory_full (size_t nbytes)
   if (! enough_free_memory)
     {
       Vmemory_full = Qt;
+      consing_until_gc = memory_full_cons_threshold;
 
       /* The first time we get here, free the spare memory.  */
       for (int i = 0; i < ARRAYELTS (spare_memory); i++)
@@ -5802,7 +5799,7 @@ garbage_collect_1 (struct gcstat *gcst)
 
   /* In case user calls debug_print during GC,
      don't let that cause a recursive GC.  */
-  consing_since_gc = 0;
+  consing_until_gc = OBJECT_CT_MAX;
 
   /* Save what's currently displayed in the echo area.  Don't do that
      if we are GC'ing because we've run out of memory, since
@@ -5913,23 +5910,26 @@ garbage_collect_1 (struct gcstat *gcst)
 
   unblock_input ();
 
-  consing_since_gc = 0;
-  if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
-    gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
-
-  gc_relative_threshold = 0;
-  if (FLOATP (Vgc_cons_percentage))
-    { /* Set gc_cons_combined_threshold.  */
-      double tot = total_bytes_of_live_objects ();
-
-      tot *= XFLOAT_DATA (Vgc_cons_percentage);
-      if (0 < tot)
+  if (!NILP (Vmemory_full))
+    consing_until_gc = memory_full_cons_threshold;
+  else
+    {
+      intptr_t threshold = min (max (GC_DEFAULT_THRESHOLD,
+				     gc_cons_threshold >> 3),
+				OBJECT_CT_MAX);
+      if (FLOATP (Vgc_cons_percentage))
 	{
-	  if (tot < UINTPTR_MAX)
-	    gc_relative_threshold = tot;
-	  else
-	    gc_relative_threshold = UINTPTR_MAX;
+	  double tot = (XFLOAT_DATA (Vgc_cons_percentage)
+			* total_bytes_of_live_objects ());
+	  if (threshold < tot)
+	    {
+	      if (tot < OBJECT_CT_MAX)
+		threshold = tot;
+	      else
+		threshold = OBJECT_CT_MAX;
+	    }
 	}
+      consing_until_gc = threshold;
     }
 
   if (garbage_collection_messages && NILP (Vmemory_full))
diff --git a/src/lisp.h b/src/lisp.h
index 8f60963eb7..50a61cadd7 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3763,10 +3763,9 @@ #define CONS_TO_INTEGER(cons, type, var)				\
 extern void garbage_collect (void);
 extern const char *pending_malloc_warning;
 extern Lisp_Object zero_vector;
-typedef uintptr_t byte_ct;  /* System byte counts reported by GC.  */
-extern byte_ct consing_since_gc;
-extern byte_ct gc_relative_threshold;
-extern byte_ct const memory_full_cons_threshold;
+typedef intptr_t object_ct; /* Signed type of object counts reported by GC.  */
+#define OBJECT_CT_MAX INTPTR_MAX
+extern object_ct consing_until_gc;
 #ifdef HAVE_PDUMPER
 extern int number_finalizers_run;
 #endif
@@ -4993,10 +4992,7 @@ #define FOR_EACH_ALIST_VALUE(head_var, list_var, value_var)		\
 INLINE void
 maybe_gc (void)
 {
-  if ((consing_since_gc > gc_cons_threshold
-       && consing_since_gc > gc_relative_threshold)
-      || (!NILP (Vmemory_full)
-	  && consing_since_gc > memory_full_cons_threshold))
+  if (consing_until_gc < 0)
     garbage_collect ();
 }
 
-- 
2.17.1


[-- Attachment #5: 0004-Inhibit-GC-after-inhibit_garbage_collection.patch --]
[-- Type: text/x-patch, Size: 2626 bytes --]

From 5018b663c6c0d31f27fb44630a69d9e0bd73273d Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sat, 20 Jul 2019 19:40:03 -0700
Subject: [PATCH 4/6] Inhibit GC after inhibit_garbage_collection

Without this patch, there are unlikely ways that garbage
collection could occur (sometimes causing undefined behavior)
even when inhibit_garbage_collection is in effect.
* src/alloc.c (garbage_collection_inhibited): New var.
(pure_alloc): Increment it if pure space is exhausted, so that
garbage_collect_1 no longer needs to inspect
pure_bytes_used_before_overflow.
(allow_garbage_collection): New function.
(inhibit_garbage_collection): Increment the new variable rather
than specbinding a user variable.
(garbage_collect_1): Do not garbage collect if the new variable
is set, rather than if pure_bytes_used_before_overflow is set.
---
 src/alloc.c | 21 +++++++++++++++++----
 1 file changed, 17 insertions(+), 4 deletions(-)

diff --git a/src/alloc.c b/src/alloc.c
index 9d18fd918b..09b3a4ea7e 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -292,6 +292,10 @@ #define PUREBEG (char *) pure
 
 static ptrdiff_t pure_bytes_used_non_lisp;
 
+/* If positive, garbage collection is inhibited.  Otherwise, zero.  */
+
+static intptr_t garbage_collection_inhibited;
+
 /* If nonzero, this is a warning delivered by malloc and not yet
    displayed.  */
 
@@ -5120,6 +5124,10 @@ pure_alloc (size_t size, int type)
   pure_bytes_used_before_overflow += pure_bytes_used - size;
   pure_bytes_used = 0;
   pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
+
+  /* Can't GC if pure storage overflowed because we can't determine
+     if something is a pure object or not.  */
+  garbage_collection_inhibited++;
   goto again;
 }
 
@@ -5486,12 +5494,19 @@ staticpro (Lisp_Object const *varaddress)
 
 /* Temporarily prevent garbage collection.  */
 
+static void
+allow_garbage_collection (void)
+{
+  garbage_collection_inhibited--;
+}
+
 ptrdiff_t
 inhibit_garbage_collection (void)
 {
   ptrdiff_t count = SPECPDL_INDEX ();
 
-  specbind (Qgc_cons_threshold, make_fixnum (MOST_POSITIVE_FIXNUM));
+  record_unwind_protect_void (allow_garbage_collection);
+  garbage_collection_inhibited++;
   return count;
 }
 
@@ -5779,9 +5794,7 @@ garbage_collect_1 (struct gcstat *gcst)
 
   eassert (weak_hash_tables == NULL);
 
-  /* Can't GC if pure storage overflowed because we can't determine
-     if something is a pure object or not.  */
-  if (pure_bytes_used_before_overflow)
+  if (garbage_collection_inhibited)
     return false;
 
   /* Record this function, so it appears on the profiler's backtraces.  */
-- 
2.17.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: 0005-Simplify-hashfn-cmpfn-calling-convention.patch --]
[-- Type: text/x-patch; name="0005-Simplify-hashfn-cmpfn-calling-convention.patch", Size: 20741 bytes --]

From b6f194a0fb6dbd1b19aa01f95a955f5b8b23b40e Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sat, 20 Jul 2019 19:40:03 -0700
Subject: [PATCH 5/6] Simplify hashfn/cmpfn calling convention
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* src/fns.c (cmpfn_eql, cmpfn_equal, cmpfn_user_defined)
(hashfn_eq, hashfn_equal, hashfn_eql, hashfn_user_defined):
* src/profiler.c (cmpfn_profiler, hashfn_profiler):
Use new calling convention where the return value is a fixnum
instead of EMACS_UINT.  While we’re at it, put the hash table
at the end, since that’s a bit simpler and generates better
code (at least on the x86-64).  All callers changed.
* src/fns.c (hash_lookup): Store fixnum rather than EMACS_UINT.
All callers changed.
(hash_put): Take a fixnum rather than an EMACS_UINT.
All callers changed.  Remove unnecessary eassert (XUFIXNUM does it).
* src/lisp.h (struct hash_table_test):
Adjust signatures of cmpfn and hashfn.
---
 src/bytecode.c     |   8 ++--
 src/category.c     |   9 ++--
 src/charset.c      |   2 +-
 src/composite.c    |   5 +--
 src/emacs-module.c |   3 +-
 src/fns.c          | 103 ++++++++++++++++++++-------------------------
 src/image.c        |   3 +-
 src/json.c         |   3 +-
 src/lisp.h         |  12 +++---
 src/lread.c        |   3 +-
 src/macfont.m      |   3 +-
 src/profiler.c     |  34 +++++++--------
 12 files changed, 82 insertions(+), 106 deletions(-)

diff --git a/src/bytecode.c b/src/bytecode.c
index 29dff44f00..e82de026a8 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -1409,16 +1409,16 @@ #define DEFINE(name, value) LABEL (name) ,
             if (h->count <= 5)
               { /* Do a linear search if there are not many cases
                    FIXME: 5 is arbitrarily chosen.  */
-                Lisp_Object hash_code = h->test.cmpfn
-                  ? make_fixnum (h->test.hashfn (&h->test, v1)) : Qnil;
+		Lisp_Object hash_code
+		  = h->test.cmpfn ? h->test.hashfn (v1, &h->test) : Qnil;
 
                 for (i = h->count; 0 <= --i; )
                   if (EQ (v1, HASH_KEY (h, i))
                       || (h->test.cmpfn
                           && EQ (hash_code, HASH_HASH (h, i))
-                          && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i))))
+			  && !NILP (h->test.cmpfn (v1, HASH_KEY (h, i),
+						   &h->test))))
                     break;
-
               }
             else
               i = hash_lookup (h, v1, NULL);
diff --git a/src/category.c b/src/category.c
index 132fae9d40..9e460cfc64 100644
--- a/src/category.c
+++ b/src/category.c
@@ -48,18 +48,15 @@ bset_category_table (struct buffer *b, Lisp_Object val)
 static Lisp_Object
 hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
 {
-  struct Lisp_Hash_Table *h;
-  ptrdiff_t i;
-  EMACS_UINT hash;
-
   if (NILP (XCHAR_TABLE (table)->extras[1]))
     set_char_table_extras
       (table, 1,
        make_hash_table (hashtest_equal, DEFAULT_HASH_SIZE,
 			DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
 			Qnil, false));
-  h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
-  i = hash_lookup (h, category_set, &hash);
+  struct Lisp_Hash_Table *h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
+  Lisp_Object hash;
+  ptrdiff_t i = hash_lookup (h, category_set, &hash);
   if (i >= 0)
     return HASH_KEY (h, i);
   hash_put (h, category_set, Qnil, hash);
diff --git a/src/charset.c b/src/charset.c
index 85535e8bff..8c54381dc4 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -842,7 +842,7 @@ DEFUN ("define-charset-internal", Fdefine_charset_internal,
   /* Charset attr vector.  */
   Lisp_Object attrs;
   Lisp_Object val;
-  EMACS_UINT hash_code;
+  Lisp_Object hash_code;
   struct Lisp_Hash_Table *hash_table = XHASH_TABLE (Vcharset_hash_table);
   int i, j;
   struct charset charset;
diff --git a/src/composite.c b/src/composite.c
index 183062de46..c36663f8e9 100644
--- a/src/composite.c
+++ b/src/composite.c
@@ -164,11 +164,10 @@ #define MAX_AUTO_COMPOSITION_LOOKBACK 3
 get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
 		    Lisp_Object prop, Lisp_Object string)
 {
-  Lisp_Object id, length, components, key, *key_contents;
+  Lisp_Object id, length, components, key, *key_contents, hash_code;
   ptrdiff_t glyph_len;
   struct Lisp_Hash_Table *hash_table = XHASH_TABLE (composition_hash_table);
   ptrdiff_t hash_index;
-  EMACS_UINT hash_code;
   enum composition_method method;
   struct composition *cmp;
   ptrdiff_t i;
@@ -656,7 +655,7 @@ composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len)
   struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
   hash_rehash_if_needed (h);
   Lisp_Object header = LGSTRING_HEADER (gstring);
-  EMACS_UINT hash = h->test.hashfn (&h->test, header);
+  Lisp_Object hash = h->test.hashfn (header, &h->test);
   if (len < 0)
     {
       ptrdiff_t glyph_len = LGSTRING_GLYPH_LEN (gstring);
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 8c09ea6bb6..4b991a1c74 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -362,8 +362,7 @@ module_make_global_ref (emacs_env *env, emacs_value ref)
 {
   MODULE_FUNCTION_BEGIN (NULL);
   struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
-  Lisp_Object new_obj = value_to_lisp (ref);
-  EMACS_UINT hashcode;
+  Lisp_Object new_obj = value_to_lisp (ref), hashcode;
   ptrdiff_t i = hash_lookup (h, new_obj, &hashcode);
 
   if (i >= 0)
diff --git a/src/fns.c b/src/fns.c
index d4f6842f27..d9503c491e 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2373,7 +2373,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
 	case Lisp_Cons: case Lisp_Vectorlike:
 	  {
 	    struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
-	    EMACS_UINT hash;
+	    Lisp_Object hash;
 	    ptrdiff_t i = hash_lookup (h, o1, &hash);
 	    if (i >= 0)
 	      { /* `o1' was seen already.  */
@@ -3934,74 +3934,67 @@ HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
 /* Ignore HT and compare KEY1 and KEY2 using 'eql'.
    Value is true if KEY1 and KEY2 are the same.  */
 
-static bool
-cmpfn_eql (struct hash_table_test *ht,
-	   Lisp_Object key1,
-	   Lisp_Object key2)
+static Lisp_Object
+cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
 {
-  return !NILP (Feql (key1, key2));
+  return Feql (key1, key2);
 }
 
 /* Ignore HT and compare KEY1 and KEY2 using 'equal'.
    Value is true if KEY1 and KEY2 are the same.  */
 
-static bool
-cmpfn_equal (struct hash_table_test *ht,
-	     Lisp_Object key1,
-	     Lisp_Object key2)
+static Lisp_Object
+cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
 {
-  return !NILP (Fequal (key1, key2));
+  return Fequal (key1, key2);
 }
 
 
 /* Given HT, compare KEY1 and KEY2 using HT->user_cmp_function.
    Value is true if KEY1 and KEY2 are the same.  */
 
-static bool
-cmpfn_user_defined (struct hash_table_test *ht,
-		    Lisp_Object key1,
-		    Lisp_Object key2)
+static Lisp_Object
+cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2,
+		    struct hash_table_test *ht)
 {
-  return !NILP (call2 (ht->user_cmp_function, key1, key2));
+  return call2 (ht->user_cmp_function, key1, key2);
 }
 
-/* Ignore HT and return a hash code for KEY which uses 'eq' to compare keys.
-   The hash code is at most INTMASK.  */
+/* Ignore HT and return a hash code for KEY which uses 'eq' to compare
+   keys.  */
 
-static EMACS_UINT
-hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
+static Lisp_Object
+hashfn_eq (Lisp_Object key, struct hash_table_test *ht)
 {
-  return XHASH (key) ^ XTYPE (key);
+  return make_fixnum (XHASH (key) ^ XTYPE (key));
 }
 
 /* Ignore HT and return a hash code for KEY which uses 'equal' to compare keys.
    The hash code is at most INTMASK.  */
 
-EMACS_UINT
-hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
+Lisp_Object
+hashfn_equal (Lisp_Object key, struct hash_table_test *ht)
 {
-  return sxhash (key, 0);
+  return make_fixnum (sxhash (key, 0));
 }
 
 /* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys.
    The hash code is at most INTMASK.  */
 
-EMACS_UINT
-hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
+Lisp_Object
+hashfn_eql (Lisp_Object key, struct hash_table_test *ht)
 {
-  return ((FLOATP (key) || BIGNUMP (key))
-	  ? hashfn_equal (ht, key)
-	  : hashfn_eq (ht, key));
+  return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, ht);
 }
 
 /* Given HT, return a hash code for KEY which uses a user-defined
-   function to compare keys.  The hash code is at most INTMASK.  */
+   function to compare keys.  */
 
-static EMACS_UINT
-hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key)
+static Lisp_Object
+hashfn_user_defined (Lisp_Object key, struct hash_table_test *ht)
 {
   Lisp_Object hash = call1 (ht->user_hash_function, key);
-  return hashfn_eq (ht, hash);
+  return hashfn_eq (hash, ht);
 }
 
 struct hash_table_test const
@@ -4224,8 +4217,8 @@ hash_table_rehash (struct Lisp_Hash_Table *h)
     if (!NILP (HASH_HASH (h, i)))
       {
         Lisp_Object key = HASH_KEY (h, i);
-        EMACS_UINT hash_code = h->test.hashfn (&h->test, key);
-        set_hash_hash_slot (h, i, make_fixnum (hash_code));
+	Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+	set_hash_hash_slot (h, i, hash_code);
       }
 
   /* Reset the index so that any slot we don't fill below is marked
@@ -4256,25 +4249,23 @@ hash_table_rehash (struct Lisp_Hash_Table *h)
    matching KEY, or -1 if not found.  */
 
 ptrdiff_t
-hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
+hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
 {
-  EMACS_UINT hash_code;
   ptrdiff_t start_of_bucket, i;
 
   hash_rehash_if_needed (h);
 
-  hash_code = h->test.hashfn (&h->test, key);
-  eassert ((hash_code & ~INTMASK) == 0);
+  Lisp_Object hash_code = h->test.hashfn (key, &h->test);
   if (hash)
     *hash = hash_code;
 
-  start_of_bucket = hash_code % ASIZE (h->index);
+  start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
 
   for (i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i))
     if (EQ (key, HASH_KEY (h, i))
 	|| (h->test.cmpfn
-	    && hash_code == XUFIXNUM (HASH_HASH (h, i))
-	    && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
+	    && EQ (hash_code, HASH_HASH (h, i))
+	    && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), &h->test))))
       break;
 
   return i;
@@ -4287,14 +4278,12 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
 
 ptrdiff_t
 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
-	  EMACS_UINT hash)
+	  Lisp_Object hash)
 {
   ptrdiff_t start_of_bucket, i;
 
   hash_rehash_if_needed (h);
 
-  eassert ((hash & ~INTMASK) == 0);
-
   /* Increment count after resizing because resizing may fail.  */
   maybe_resize_hash_table (h);
   h->count++;
@@ -4306,10 +4295,10 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
   set_hash_value_slot (h, i, value);
 
   /* Remember its hash code.  */
-  set_hash_hash_slot (h, i, make_fixnum (hash));
+  set_hash_hash_slot (h, i, hash);
 
   /* Add new entry to its collision chain.  */
-  start_of_bucket = hash % ASIZE (h->index);
+  start_of_bucket = XUFIXNUM (hash) % ASIZE (h->index);
   set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
   set_hash_index_slot (h, start_of_bucket, i);
   return i;
@@ -4321,9 +4310,8 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
 void
 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
 {
-  EMACS_UINT hash_code = h->test.hashfn (&h->test, key);
-  eassert ((hash_code & ~INTMASK) == 0);
-  ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
+  Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+  ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
   ptrdiff_t prev = -1;
 
   hash_rehash_if_needed (h);
@@ -4334,8 +4322,8 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
     {
       if (EQ (key, HASH_KEY (h, i))
 	  || (h->test.cmpfn
-	      && hash_code == XUFIXNUM (HASH_HASH (h, i))
-	      && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
+	      && EQ (hash_code, HASH_HASH (h, i))
+	      && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), &h->test))))
 	{
 	  /* Take entry out of collision chain.  */
 	  if (prev < 0)
@@ -4685,7 +4673,7 @@ If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)).
 Hash codes are not guaranteed to be preserved across Emacs sessions.  */)
   (Lisp_Object obj)
 {
-  return make_fixnum (hashfn_eq (NULL, obj));
+  return hashfn_eq (obj, NULL);
 }
 
 DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
@@ -4695,7 +4683,7 @@ If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)).
 Hash codes are not guaranteed to be preserved across Emacs sessions.  */)
   (Lisp_Object obj)
 {
-  return make_fixnum (hashfn_eql (NULL, obj));
+  return hashfn_eql (obj, NULL);
 }
 
 DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
@@ -4705,7 +4693,7 @@ If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)).
 Hash codes are not guaranteed to be preserved across Emacs sessions.  */)
   (Lisp_Object obj)
 {
-  return make_fixnum (hashfn_equal (NULL, obj));
+  return hashfn_equal (obj, NULL);
 }
 
 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
@@ -4951,9 +4939,8 @@ DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
   struct Lisp_Hash_Table *h = check_hash_table (table);
   CHECK_IMPURE (table, h);
 
-  ptrdiff_t i;
-  EMACS_UINT hash;
-  i = hash_lookup (h, key, &hash);
+  Lisp_Object hash;
+  ptrdiff_t i = hash_lookup (h, key, &hash);
   if (i >= 0)
     set_hash_value_slot (h, i, value);
   else
diff --git a/src/image.c b/src/image.c
index b081d4b912..355c849491 100644
--- a/src/image.c
+++ b/src/image.c
@@ -4606,8 +4606,7 @@ xpm_put_color_table_h (Lisp_Object color_table,
                        Lisp_Object color)
 {
   struct Lisp_Hash_Table *table = XHASH_TABLE (color_table);
-  EMACS_UINT hash_code;
-  Lisp_Object chars = make_unibyte_string (chars_start, chars_len);
+  Lisp_Object chars = make_unibyte_string (chars_start, chars_len), hash_code;
 
   hash_lookup (table, chars, &hash_code);
   hash_put (table, chars, color, hash_code);
diff --git a/src/json.c b/src/json.c
index 21c4b946b4..d05f2c54e2 100644
--- a/src/json.c
+++ b/src/json.c
@@ -867,8 +867,7 @@ json_to_lisp (json_t *json, struct json_configuration *conf)
               json_t *value;
               json_object_foreach (json, key_str, value)
                 {
-                  Lisp_Object key = build_string_from_utf8 (key_str);
-                  EMACS_UINT hash;
+		  Lisp_Object key = build_string_from_utf8 (key_str), hash;
                   ptrdiff_t i = hash_lookup (h, key, &hash);
                   /* Keys in JSON objects are unique, so the key can't
                      be present yet.  */
diff --git a/src/lisp.h b/src/lisp.h
index 50a61cadd7..e5edb8fd12 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2237,10 +2237,10 @@ #define DEFSYM(sym, name) /* empty */
   Lisp_Object user_cmp_function;
 
   /* C function to compare two keys.  */
-  bool (*cmpfn) (struct hash_table_test *t, Lisp_Object, Lisp_Object);
+  Lisp_Object (*cmpfn) (Lisp_Object, Lisp_Object, struct hash_table_test *t);
 
   /* C function to compute hash code.  */
-  EMACS_UINT (*hashfn) (struct hash_table_test *t, Lisp_Object);
+  Lisp_Object (*hashfn) (Lisp_Object, struct hash_table_test *t);
 };
 
 struct Lisp_Hash_Table
@@ -3591,13 +3591,13 @@ #define CONS_TO_INTEGER(cons, type, var)				\
 extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *);
 EMACS_UINT hash_string (char const *, ptrdiff_t);
 EMACS_UINT sxhash (Lisp_Object, int);
-EMACS_UINT hashfn_eql (struct hash_table_test *ht, Lisp_Object key);
-EMACS_UINT hashfn_equal (struct hash_table_test *ht, Lisp_Object key);
+Lisp_Object hashfn_eql (Lisp_Object, struct hash_table_test *);
+Lisp_Object hashfn_equal (Lisp_Object, struct hash_table_test *);
 Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float,
                              Lisp_Object, bool);
-ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
+ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object *);
 ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
-		    EMACS_UINT);
+		    Lisp_Object);
 void hash_remove_from_table (struct Lisp_Hash_Table *, Lisp_Object);
 extern struct hash_table_test const hashtest_eq, hashtest_eql, hashtest_equal;
 extern void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object,
diff --git a/src/lread.c b/src/lread.c
index 3152fcf867..eecb5e141d 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3161,8 +3161,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 		      Lisp_Object placeholder = Fcons (Qnil, Qnil);
 		      struct Lisp_Hash_Table *h
 			= XHASH_TABLE (read_objects_map);
-		      EMACS_UINT hash;
-		      Lisp_Object number = make_fixnum (n);
+		      Lisp_Object number = make_fixnum (n), hash;
 
 		      ptrdiff_t i = hash_lookup (h, number, &hash);
 		      if (i >= 0)
diff --git a/src/macfont.m b/src/macfont.m
index 301951f34a..7170e80140 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -986,8 +986,7 @@ static void mac_font_get_glyphs_for_variants (CFDataRef, UTF32Char,
 {
   struct Lisp_Hash_Table *h;
   ptrdiff_t i;
-  EMACS_UINT hash;
-  Lisp_Object value;
+  Lisp_Object hash, value;
 
   if (!HASH_TABLE_P (macfont_family_cache))
     macfont_family_cache = CALLN (Fmake_hash_table, QCtest, Qeq);
diff --git a/src/profiler.c b/src/profiler.c
index 87be30acc3..e9b6a37d06 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -36,11 +36,9 @@ saturated_add (EMACS_INT a, EMACS_INT b)
 
 typedef struct Lisp_Hash_Table log_t;
 
-static bool cmpfn_profiler (
-  struct hash_table_test *, Lisp_Object, Lisp_Object);
-
-static EMACS_UINT hashfn_profiler (
-  struct hash_table_test *, Lisp_Object);
+static Lisp_Object cmpfn_profiler (Lisp_Object, Lisp_Object,
+				   struct hash_table_test *);
+static Lisp_Object hashfn_profiler (Lisp_Object, struct hash_table_test *);
 
 static const struct hash_table_test hashtest_profiler =
   {
@@ -165,7 +163,7 @@ record_backtrace (log_t *log, EMACS_INT count)
        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;
+    Lisp_Object hash;
     ptrdiff_t j = hash_lookup (log, backtrace, &hash);
     if (j >= 0)
       {
@@ -529,30 +527,30 @@ DEFUN ("function-equal", Ffunction_equal, Sfunction_equal, 2, 2, 0,
   return res ? Qt : Qnil;
 }
 
-static bool
-cmpfn_profiler (struct hash_table_test *t,
-		Lisp_Object bt1, Lisp_Object bt2)
+static Lisp_Object
+cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct hash_table_test *t)
 {
   if (VECTORP (bt1) && VECTORP (bt2))
     {
       ptrdiff_t l = ASIZE (bt1);
       if (l != ASIZE (bt2))
-	return false;
+	return Qnil;
       for (ptrdiff_t i = 0; i < l; i++)
 	if (NILP (Ffunction_equal (AREF (bt1, i), AREF (bt2, i))))
-	  return false;
-      return true;
+	  return Qnil;
+      return Qt;
     }
   else
-    return EQ (bt1, bt2);
+    return EQ (bt1, bt2) ? Qt : Qnil;
 }
 
-static EMACS_UINT
-hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt)
+static Lisp_Object
+hashfn_profiler (Lisp_Object bt, struct hash_table_test *ht)
 {
+  EMACS_UINT hash;
   if (VECTORP (bt))
     {
-      EMACS_UINT hash = 0;
+      hash = 0;
       ptrdiff_t l = ASIZE (bt);
       for (ptrdiff_t i = 0; i < l; i++)
 	{
@@ -563,10 +561,10 @@ hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt)
 	       ? XHASH (XCDR (XCDR (f))) : XHASH (f));
 	  hash = sxhash_combine (hash, hash1);
 	}
-      return SXHASH_REDUCE (hash);
     }
   else
-    return XHASH (bt);
+    hash = XHASH (bt);
+  return make_fixnum (SXHASH_REDUCE (hash));
 }
 
 static void syms_of_profiler_for_pdumper (void);
-- 
2.17.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #7: 0006-Fix-crash-if-user-test-munges-hash-table.patch --]
[-- Type: text/x-patch; name="0006-Fix-crash-if-user-test-munges-hash-table.patch", Size: 15190 bytes --]

From 515afc9c15870cd7bd6b96e2d8b89938116923ac Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sat, 20 Jul 2019 19:40:03 -0700
Subject: [PATCH 6/6] Fix crash if user test munges hash table
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* src/fns.c (restore_mutability)
(hash_table_user_defined_call): New functions.
(cmpfn_user_defined, hashfn_user_defined): Use them.
(make_hash_table, copy_hash_table):
Mark new hash table as mutable.
(check_mutable_hash_table): New function.
(Fclrhash, Fputhash, Fremhash): Use it instead of CHECK_IMPURE.
* src/lisp.h (struct hash_table_test): User-defined functions
now take pointers to struct Lisp_Hash_Table, not to struct
hash_table_test.  All uses changed.
(struct Lisp_Hash_Table): New member ‘mutable’.
* src/pdumper.c (dump_hash_table): Copy it.
* test/src/fns-tests.el (test-hash-function-that-mutates-hash-table):
New test, which tests for the bug.
---
 src/alloc.c           |  1 +
 src/bytecode.c        |  5 ++-
 src/composite.c       |  2 +-
 src/fns.c             | 74 ++++++++++++++++++++++++++++++++-----------
 src/lisp.h            | 15 ++++++---
 src/pdumper.c         |  1 +
 src/profiler.c        |  8 ++---
 test/src/fns-tests.el | 12 +++++++
 8 files changed, 87 insertions(+), 31 deletions(-)

diff --git a/src/alloc.c b/src/alloc.c
index 09b3a4ea7e..1718ce0faf 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5352,6 +5352,7 @@ purecopy_hash_table (struct Lisp_Hash_Table *table)
   pure->count = table->count;
   pure->next_free = table->next_free;
   pure->purecopy = table->purecopy;
+  eassert (!pure->mutable);
   pure->rehash_threshold = table->rehash_threshold;
   pure->rehash_size = table->rehash_size;
   pure->key_and_value = purecopy (table->key_and_value);
diff --git a/src/bytecode.c b/src/bytecode.c
index e82de026a8..d668a9a6a1 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -1410,14 +1410,13 @@ #define DEFINE(name, value) LABEL (name) ,
               { /* Do a linear search if there are not many cases
                    FIXME: 5 is arbitrarily chosen.  */
 		Lisp_Object hash_code
-		  = h->test.cmpfn ? h->test.hashfn (v1, &h->test) : Qnil;
+		  = h->test.cmpfn ? h->test.hashfn (v1, h) : Qnil;
 
                 for (i = h->count; 0 <= --i; )
                   if (EQ (v1, HASH_KEY (h, i))
                       || (h->test.cmpfn
                           && EQ (hash_code, HASH_HASH (h, i))
-			  && !NILP (h->test.cmpfn (v1, HASH_KEY (h, i),
-						   &h->test))))
+			  && !NILP (h->test.cmpfn (v1, HASH_KEY (h, i), h))))
                     break;
               }
             else
diff --git a/src/composite.c b/src/composite.c
index c36663f8e9..a6606d5fc4 100644
--- a/src/composite.c
+++ b/src/composite.c
@@ -655,7 +655,7 @@ composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len)
   struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
   hash_rehash_if_needed (h);
   Lisp_Object header = LGSTRING_HEADER (gstring);
-  Lisp_Object hash = h->test.hashfn (header, &h->test);
+  Lisp_Object hash = h->test.hashfn (header, h);
   if (len < 0)
     {
       ptrdiff_t glyph_len = LGSTRING_GLYPH_LEN (gstring);
diff --git a/src/fns.c b/src/fns.c
index d9503c491e..5f1ed07a12 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -3931,11 +3931,37 @@ HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
   return XFIXNUM (AREF (h->index, idx));
 }
 
+/* Restore a hash table's mutability after the critical section exits.  */
+
+static void
+restore_mutability (void *ptr)
+{
+  struct Lisp_Hash_Table *h = ptr;
+  h->mutable = true;
+}
+
+/* Return the result of calling a user-defined hash or comparison
+   function ARGS[0] with arguments ARGS[1] through ARGS[NARGS - 1].
+   Signal an error if the function attempts to modify H, which
+   otherwise might lead to undefined behavior.  */
+
+static Lisp_Object
+hash_table_user_defined_call (ptrdiff_t nargs, Lisp_Object *args,
+			      struct Lisp_Hash_Table *h)
+{
+  if (!h->mutable)
+    return Ffuncall (nargs, args);
+  ptrdiff_t count = inhibit_garbage_collection ();
+  record_unwind_protect_ptr (restore_mutability, h);
+  h->mutable = false;
+  return unbind_to (count, Ffuncall (nargs, args));
+}
+
 /* Ignore HT and compare KEY1 and KEY2 using 'eql'.
    Value is true if KEY1 and KEY2 are the same.  */
 
 static Lisp_Object
-cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
+cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct Lisp_Hash_Table *h)
 {
   return Feql (key1, key2);
 }
@@ -3944,7 +3970,7 @@ cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
    Value is true if KEY1 and KEY2 are the same.  */
 
 static Lisp_Object
-cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
+cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct Lisp_Hash_Table *h)
 {
   return Fequal (key1, key2);
 }
@@ -3955,16 +3981,17 @@ cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
 
 static Lisp_Object
 cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2,
-		    struct hash_table_test *ht)
+		    struct Lisp_Hash_Table *h)
 {
-  return call2 (ht->user_cmp_function, key1, key2);
+  Lisp_Object args[] = { h->test.user_cmp_function, key1, key2 };
+  return hash_table_user_defined_call (ARRAYELTS (args), args, h);
 }
 
 /* Ignore HT and return a hash code for KEY which uses 'eq' to compare
    keys.  */
 
 static Lisp_Object
-hashfn_eq (Lisp_Object key, struct hash_table_test *ht)
+hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
   return make_fixnum (XHASH (key) ^ XTYPE (key));
 }
@@ -3973,7 +4000,7 @@ hashfn_eq (Lisp_Object key, struct hash_table_test *ht)
    The hash code is at most INTMASK.  */
 
 Lisp_Object
-hashfn_equal (Lisp_Object key, struct hash_table_test *ht)
+hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
   return make_fixnum (sxhash (key, 0));
 }
@@ -3982,19 +4009,19 @@ hashfn_equal (Lisp_Object key, struct hash_table_test *ht)
    The hash code is at most INTMASK.  */
 
 Lisp_Object
-hashfn_eql (Lisp_Object key, struct hash_table_test *ht)
+hashfn_eql (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
-  return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, ht);
+  return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, h);
 }
 
 /* Given HT, return a hash code for KEY which uses a user-defined
    function to compare keys.  */
 
 static Lisp_Object
-hashfn_user_defined (Lisp_Object key, struct hash_table_test *ht)
+hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
-  Lisp_Object hash = call1 (ht->user_hash_function, key);
-  return hashfn_eq (hash, ht);
+  Lisp_Object args[] = { h->test.user_hash_function, key };
+  return hash_table_user_defined_call (ARRAYELTS (args), args, h);
 }
 
 struct hash_table_test const
@@ -4088,6 +4115,7 @@ make_hash_table (struct hash_table_test test, EMACS_INT size,
   h->index = make_vector (index_size, make_fixnum (-1));
   h->next_weak = NULL;
   h->purecopy = purecopy;
+  h->mutable = true;
 
   /* Set up the free list.  */
   for (i = 0; i < size - 1; ++i)
@@ -4113,6 +4141,7 @@ copy_hash_table (struct Lisp_Hash_Table *h1)
 
   h2 = allocate_hash_table ();
   *h2 = *h1;
+  h2->mutable = true;
   h2->key_and_value = Fcopy_sequence (h1->key_and_value);
   h2->hash = Fcopy_sequence (h1->hash);
   h2->next = Fcopy_sequence (h1->next);
@@ -4217,7 +4246,7 @@ hash_table_rehash (struct Lisp_Hash_Table *h)
     if (!NILP (HASH_HASH (h, i)))
       {
         Lisp_Object key = HASH_KEY (h, i);
-	Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+	Lisp_Object hash_code = h->test.hashfn (key, h);
 	set_hash_hash_slot (h, i, hash_code);
       }
 
@@ -4255,7 +4284,7 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
 
   hash_rehash_if_needed (h);
 
-  Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+  Lisp_Object hash_code = h->test.hashfn (key, h);
   if (hash)
     *hash = hash_code;
 
@@ -4265,12 +4294,19 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
     if (EQ (key, HASH_KEY (h, i))
 	|| (h->test.cmpfn
 	    && EQ (hash_code, HASH_HASH (h, i))
-	    && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), &h->test))))
+	    && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
       break;
 
   return i;
 }
 
+static void
+check_mutable_hash_table (Lisp_Object obj, struct Lisp_Hash_Table *h)
+{
+  if (!h->mutable)
+    signal_error ("hash table test modifies table", obj);
+  eassert (!PURE_P (h));
+}
 
 /* Put an entry into hash table H that associates KEY with VALUE.
    HASH is a previously computed hash code of KEY.
@@ -4310,7 +4346,7 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
 void
 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
 {
-  Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+  Lisp_Object hash_code = h->test.hashfn (key, h);
   ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
   ptrdiff_t prev = -1;
 
@@ -4323,7 +4359,7 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
       if (EQ (key, HASH_KEY (h, i))
 	  || (h->test.cmpfn
 	      && EQ (hash_code, HASH_HASH (h, i))
-	      && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), &h->test))))
+	      && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
 	{
 	  /* Take entry out of collision chain.  */
 	  if (prev < 0)
@@ -4912,7 +4948,7 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
   (Lisp_Object table)
 {
   struct Lisp_Hash_Table *h = check_hash_table (table);
-  CHECK_IMPURE (table, h);
+  check_mutable_hash_table (table, h);
   hash_clear (h);
   /* Be compatible with XEmacs.  */
   return table;
@@ -4937,7 +4973,7 @@ DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
   (Lisp_Object key, Lisp_Object value, Lisp_Object table)
 {
   struct Lisp_Hash_Table *h = check_hash_table (table);
-  CHECK_IMPURE (table, h);
+  check_mutable_hash_table (table, h);
 
   Lisp_Object hash;
   ptrdiff_t i = hash_lookup (h, key, &hash);
@@ -4955,7 +4991,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
   (Lisp_Object key, Lisp_Object table)
 {
   struct Lisp_Hash_Table *h = check_hash_table (table);
-  CHECK_IMPURE (table, h);
+  check_mutable_hash_table (table, h);
   hash_remove_from_table (h, key);
   return Qnil;
 }
diff --git a/src/lisp.h b/src/lisp.h
index e5edb8fd12..6d101fed90 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2225,6 +2225,8 @@ #define DEFSYM(sym, name) /* empty */
 
 /* The structure of a Lisp hash table.  */
 
+struct Lisp_Hash_Table;
+
 struct hash_table_test
 {
   /* Name of the function used to compare keys.  */
@@ -2237,10 +2239,10 @@ #define DEFSYM(sym, name) /* empty */
   Lisp_Object user_cmp_function;
 
   /* C function to compare two keys.  */
-  Lisp_Object (*cmpfn) (Lisp_Object, Lisp_Object, struct hash_table_test *t);
+  Lisp_Object (*cmpfn) (Lisp_Object, Lisp_Object, struct Lisp_Hash_Table *);
 
   /* C function to compute hash code.  */
-  Lisp_Object (*hashfn) (Lisp_Object, struct hash_table_test *t);
+  Lisp_Object (*hashfn) (Lisp_Object, struct Lisp_Hash_Table *);
 };
 
 struct Lisp_Hash_Table
@@ -2289,6 +2291,11 @@ #define DEFSYM(sym, name) /* empty */
      changed afterwards.  */
   bool purecopy;
 
+  /* True if the table is mutable.  Ordinarily tables are mutable, but
+     pure tables are not, and while a table is being mutated it is
+     immutable for recursive attempts to mutate it.  */
+  bool mutable;
+
   /* Resize hash table when number of entries / table size is >= this
      ratio.  */
   float rehash_threshold;
@@ -3591,8 +3598,8 @@ #define CONS_TO_INTEGER(cons, type, var)				\
 extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *);
 EMACS_UINT hash_string (char const *, ptrdiff_t);
 EMACS_UINT sxhash (Lisp_Object, int);
-Lisp_Object hashfn_eql (Lisp_Object, struct hash_table_test *);
-Lisp_Object hashfn_equal (Lisp_Object, struct hash_table_test *);
+Lisp_Object hashfn_eql (Lisp_Object, struct Lisp_Hash_Table *);
+Lisp_Object hashfn_equal (Lisp_Object, struct Lisp_Hash_Table *);
 Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float,
                              Lisp_Object, bool);
 ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object *);
diff --git a/src/pdumper.c b/src/pdumper.c
index 206a196890..2abac80a37 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -2742,6 +2742,7 @@ dump_hash_table (struct dump_context *ctx,
   DUMP_FIELD_COPY (out, hash, count);
   DUMP_FIELD_COPY (out, hash, next_free);
   DUMP_FIELD_COPY (out, hash, purecopy);
+  DUMP_FIELD_COPY (out, hash, mutable);
   DUMP_FIELD_COPY (out, hash, rehash_threshold);
   DUMP_FIELD_COPY (out, hash, rehash_size);
   dump_field_lv (ctx, out, hash, &hash->key_and_value, WEIGHT_STRONG);
diff --git a/src/profiler.c b/src/profiler.c
index e9b6a37d06..ed0e9ddd88 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -37,8 +37,8 @@ saturated_add (EMACS_INT a, EMACS_INT b)
 typedef struct Lisp_Hash_Table log_t;
 
 static Lisp_Object cmpfn_profiler (Lisp_Object, Lisp_Object,
-				   struct hash_table_test *);
-static Lisp_Object hashfn_profiler (Lisp_Object, struct hash_table_test *);
+				   struct Lisp_Hash_Table *);
+static Lisp_Object hashfn_profiler (Lisp_Object, struct Lisp_Hash_Table *);
 
 static const struct hash_table_test hashtest_profiler =
   {
@@ -528,7 +528,7 @@ DEFUN ("function-equal", Ffunction_equal, Sfunction_equal, 2, 2, 0,
 }
 
 static Lisp_Object
-cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct hash_table_test *t)
+cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct Lisp_Hash_Table *h)
 {
   if (VECTORP (bt1) && VECTORP (bt2))
     {
@@ -545,7 +545,7 @@ cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct hash_table_test *t)
 }
 
 static Lisp_Object
-hashfn_profiler (Lisp_Object bt, struct hash_table_test *ht)
+hashfn_profiler (Lisp_Object bt, struct Lisp_Hash_Table *h)
 {
   EMACS_UINT hash;
   if (VECTORP (bt))
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 9d4ae4fdf3..7d56da77cf 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -846,4 +846,16 @@ test-proper-list-p
   (should (not (proper-list-p (make-bool-vector 0 nil))))
   (should (not (proper-list-p (make-symbol "a")))))
 
+(ert-deftest test-hash-function-that-mutates-hash-table ()
+  (define-hash-table-test 'badeq 'eq 'bad-hash)
+  (let ((h (make-hash-table :test 'badeq :size 1 :rehash-size 1)))
+    (defun bad-hash (k)
+      (if (eq k 100)
+	  (clrhash h))
+      (sxhash-eq k))
+    (should-error
+     (dotimes (k 200)
+       (puthash k k h)))
+    (should (= 100 (hash-table-count h)))))
+
 (provide 'fns-tests)
-- 
2.17.1