Re: [PATCH] Make purecopy create hash tables properly

[Vibhav Pant]

On Sat, Jan 28, 2017 at 8:28 PM, Stefan Monnier
<address@hidden> wrote:
> Good point.  So we should check NILP (old->weak) and signal an
> error if set.  And thus old->next_weak should always be NULL and is
> trivial to copy.

> That would imply we can't purecopy any object which ends up referencing
> a hash-table.  Unless we arrange to keep track of those hash-tables
> which are referenced from purespace.  We already do that for symbols, so
> maybe we can extend/generalize that mechanism (probably a good idea).
>
> For cons cells we do:
>
>   CHECK_IMPURE (cell, XCONS (cell));
>
> in `setcar', so we can do the same for hash-tables.  Since purespace is
> contiguous, CHECK_IMPURE is pretty efficient, and since it only relies
> on the pointer value, the CPU can compute it in parallel with the access to
> the object (and the test itself is trivial to predict), so it should
> have a negligible impact on performance.

Based on these suggestions, I have made a few more modifications to the code:

* `gethash' now takes an additional :purecopy argument. If non-nil, the table
will/can be copied to pure storage when the Emacs binary is being dumped.
Since objects in pure storage are read only, gethash enforces that :weak and
:purecopy aren't non-nil at the same time, erroring out when the latter is true.

* All functions that modify hash tables (`puthash', `clrhash' and `remhash')
make sure that the table is not in pure storage (with CHECK_IMPURE).

* `make_pure_hash_table' now also purecopies the hash table test, and enforces
the checks above with `eassert'.

* A new struct, `pinned_object' is used as a linked list to store objects that
should be marked before every GC cycle. For now, this is only used when
a hash table with the :purecopy property set to nil is passed to purecopy (but
should be usable for other objects in the future).

Should this work, or is there anything else I need to do?

Thanks,
Vibhav
-- 
Vibhav Pant
address@hidden

diff --git a/src/alloc.c b/src/alloc.c
index f7b6515f4e..7d1132c953 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5434,6 +5434,35 @@ make_pure_vector (ptrdiff_t len)
   return new;
 }

+static struct Lisp_Hash_Table *
+make_pure_hash_table (struct Lisp_Hash_Table *table) {
+  eassert (NILP (table->weak));
+  eassert (!NILP (table->pure));
+
+  struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
+  struct hash_table_test pure_test = table->test;
+
+  /* Purecopy the hash table test.  */
+  pure_test.name = purecopy (table->test.name);
+  pure_test.user_hash_function = purecopy (table->test.user_hash_function);
+  pure_test.user_cmp_function = purecopy (table->test.user_cmp_function);
+
+  pure->test = pure_test;
+  pure->header = table->header;
+  pure->weak = purecopy (Qnil);
+  pure->rehash_size = purecopy (table->rehash_size);
+  pure->rehash_threshold = purecopy (table->rehash_threshold);
+  pure->hash = purecopy (table->hash);
+  pure->next = purecopy (table->next);
+  pure->next_free = purecopy (table->next_free);
+  pure->index = purecopy (table->index);
+  pure->count = table->count;
+  pure->key_and_value = purecopy (table->key_and_value);
+  pure->pure = purecopy (table->pure);
+
+  return pure;
+}
+
 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
        doc: /* Make a copy of object OBJ in pure storage.
 Recursively copies contents of vectors and cons cells.
@@ -5442,14 +5471,22 @@ Does not copy symbols.  Copies strings without
text properties.  */)
 {
   if (NILP (Vpurify_flag))
     return obj;
-  else if (MARKERP (obj) || OVERLAYP (obj)
-   || HASH_TABLE_P (obj) || SYMBOLP (obj))
+  else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj))
     /* Can't purify those.  */
     return obj;
   else
     return purecopy (obj);
 }

+struct pinned_object
+{
+  Lisp_Object object;
+  struct pinned_object *next;
+};
+
+/* Pinned objects are marked before every GC cycle.  */
+static struct pinned_object *pinned_objects;
+
 static Lisp_Object
 purecopy (Lisp_Object obj)
 {
@@ -5477,7 +5514,26 @@ purecopy (Lisp_Object obj)
     obj = make_pure_string (SSDATA (obj), SCHARS (obj),
     SBYTES (obj),
     STRING_MULTIBYTE (obj));
-  else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj))
+  else if (HASH_TABLE_P (obj))
+    {
+      struct Lisp_Hash_Table *table = XHASH_TABLE (obj);
+      /* We cannot purecopy hash tables which haven't been defined with
+         :purecopy as non-nil, they aren't guaranteed to not change.  */
+      if (NILP (table->pure))
+        {
+          /* Instead, the hash table is added to the list of pinned objects,
+             and is marked before GC.  */
+          struct pinned_object *o = xmalloc (sizeof *o);
+          o->object = obj;
+          o->next = pinned_objects;
+          pinned_objects = o;
+          return obj;
+        }
+
+      struct Lisp_Hash_Table *h = make_pure_hash_table (table);
+      XSET_HASH_TABLE (obj, h);
+    }
+  else if (COMPILEDP (obj) || VECTORP (obj))
     {
       struct Lisp_Vector *objp = XVECTOR (obj);
       ptrdiff_t nbytes = vector_nbytes (objp);
@@ -5694,6 +5750,16 @@ compact_undo_list (Lisp_Object list)
 }

 static void
+mark_pinned_objects (void)
+{
+  struct pinned_object *pobj;
+  for (pobj = pinned_objects; pobj; pobj = pobj->next)
+    {
+      mark_object (pobj->object);
+    }
+}
+
+static void
 mark_pinned_symbols (void)
 {
   struct symbol_block *sblk;
@@ -5813,6 +5879,7 @@ garbage_collect_1 (void *end)
   for (i = 0; i < staticidx; i++)
     mark_object (*staticvec[i]);

+  mark_pinned_objects ();
   mark_pinned_symbols ();
   mark_terminals ();
   mark_kboards ();
diff --git a/src/category.c b/src/category.c
index e5d261c1cf..ff287a4af3 100644
--- a/src/category.c
+++ b/src/category.c
@@ -67,7 +67,7 @@ hash_get_category_set (Lisp_Object table,
Lisp_Object category_set)
        make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
  make_float (DEFAULT_REHASH_SIZE),
  make_float (DEFAULT_REHASH_THRESHOLD),
- Qnil));
+ Qnil, Qnil));
   h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
   i = hash_lookup (h, category_set, &hash);
   if (i >= 0)
diff --git a/src/emacs-module.c b/src/emacs-module.c
index e22c7dc5b7..69fa5c8e64 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -1016,7 +1016,7 @@ syms_of_module (void)
     = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE),
        make_float (DEFAULT_REHASH_SIZE),
        make_float (DEFAULT_REHASH_THRESHOLD),
-       Qnil);
+       Qnil, Qnil);
   Funintern (Qmodule_refs_hash, Qnil);

   DEFSYM (Qmodule_environments, "module-environments");
diff --git a/src/fns.c b/src/fns.c
index b8ebfe5b2e..420bf6c1ee 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -34,6 +34,7 @@ along with GNU Emacs.  If not, see
<http://www.gnu.org/licenses/>.  */
 #include "buffer.h"
 #include "intervals.h"
 #include "window.h"
+#include "puresize.h"

 static void sort_vector_copy (Lisp_Object, ptrdiff_t,
       Lisp_Object *restrict, Lisp_Object *restrict);
@@ -3750,12 +3751,17 @@ allocate_hash_table (void)
    (table size) is >= REHASH_THRESHOLD.

    WEAK specifies the weakness of the table.  If non-nil, it must be
-   one of the symbols `key', `value', `key-or-value', or `key-and-value'.  */
+   one of the symbols `key', `value', `key-or-value', or `key-and-value'.
+
+   If PURECOPY is non-nil, the table can be copied to pure storage via
+   `purecopy' when Emacs is being dumped. Such tables can no longer be
+   changed after purecopy.  */

 Lisp_Object
 make_hash_table (struct hash_table_test test,
  Lisp_Object size, Lisp_Object rehash_size,
- Lisp_Object rehash_threshold, Lisp_Object weak)
+ Lisp_Object rehash_threshold, Lisp_Object weak,
+                 Lisp_Object pure)
 {
   struct Lisp_Hash_Table *h;
   Lisp_Object table;
@@ -3774,6 +3780,8 @@ make_hash_table (struct hash_table_test test,

   if (XFASTINT (size) == 0)
     size = make_number (1);
+  if (!NILP (weak) && !NILP (pure))
+    error ("Weak hash tables cannot be purecopied");

   sz = XFASTINT (size);
   index_float = sz / XFLOAT_DATA (rehash_threshold);
@@ -3796,6 +3804,7 @@ make_hash_table (struct hash_table_test test,
   h->hash = Fmake_vector (size, Qnil);
   h->next = Fmake_vector (size, Qnil);
   h->index = Fmake_vector (make_number (index_size), Qnil);
+  h->pure = pure;

   /* Set up the free list.  */
   for (i = 0; i < sz - 1; ++i)
@@ -4460,10 +4469,14 @@ key, value, one of key or value, or both key
and value, depending on
 WEAK.  WEAK t is equivalent to `key-and-value'.  Default value of WEAK
 is nil.

+:purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
+to pure storage when Emacs is being dumped, making the contents of the
+table read only. WEAK should be nil for such tables.
+
 usage: (make-hash-table &rest KEYWORD-ARGS)  */)
   (ptrdiff_t nargs, Lisp_Object *args)
 {
-  Lisp_Object test, size, rehash_size, rehash_threshold, weak;
+  Lisp_Object test, size, rehash_size, rehash_threshold, weak, pure;
   struct hash_table_test testdesc;
   ptrdiff_t i;
   USE_SAFE_ALLOCA;
@@ -4497,6 +4510,9 @@ usage: (make-hash-table &rest KEYWORD-ARGS)  */)
       testdesc.cmpfn = cmpfn_user_defined;
     }

+  /* See if there's a `:purecopy PURECOPY' argument.  */
+  i = get_key_arg (QCpurecopy, nargs, args, used);
+  pure = i ? args[i] : Qnil;
   /* See if there's a `:size SIZE' argument.  */
   i = get_key_arg (QCsize, nargs, args, used);
   size = i ? args[i] : Qnil;
@@ -4538,7 +4554,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS)  */)
       signal_error ("Invalid argument list", args[i]);

   SAFE_FREE ();
-  return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak);
+  return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
+                          pure);
 }


@@ -4617,7 +4634,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
        doc: /* Clear hash table TABLE and return it.  */)
   (Lisp_Object table)
 {
-  hash_clear (check_hash_table (table));
+  struct Lisp_Hash_Table *h = check_hash_table (table);
+  CHECK_IMPURE (table, h);
+  hash_clear (h);
   /* Be compatible with XEmacs.  */
   return table;
 }
@@ -4641,9 +4660,10 @@ VALUE.  In any case, return VALUE.  */)
   (Lisp_Object key, Lisp_Object value, Lisp_Object table)
 {
   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);
   if (i >= 0)
     set_hash_value_slot (h, i, value);
@@ -4659,6 +4679,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);
   hash_remove_from_table (h, key);
   return Qnil;
 }
@@ -5029,6 +5050,7 @@ syms_of_fns (void)
   DEFSYM (Qequal, "equal");
   DEFSYM (QCtest, ":test");
   DEFSYM (QCsize, ":size");
+  DEFSYM (QCpurecopy, ":purecopy");
   DEFSYM (QCrehash_size, ":rehash-size");
   DEFSYM (QCrehash_threshold, ":rehash-threshold");
   DEFSYM (QCweakness, ":weakness");
diff --git a/src/image.c b/src/image.c
index 39677d2add..ad0143be48 100644
--- a/src/image.c
+++ b/src/image.c
@@ -4020,7 +4020,7 @@ xpm_make_color_table_h (void (**put_func)
(Lisp_Object, const char *, int,
   return make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
   make_float (DEFAULT_REHASH_SIZE),
   make_float (DEFAULT_REHASH_THRESHOLD),
-  Qnil);
+  Qnil, Qnil);
 }

 static void
diff --git a/src/lisp.h b/src/lisp.h
index 84d53bb1ee..91c430fe98 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1995,6 +1995,10 @@ struct Lisp_Hash_Table
      hash table size to reduce collisions.  */
   Lisp_Object index;

+  /* Non-nil if the table can be purecopied. Any changes the table after
+     purecopy will result in an error.  */
+  Lisp_Object pure;
+
   /* Only the fields above are traced normally by the GC.  The ones below
      `count' are special and are either ignored by the GC or traced in
      a special way (e.g. because of weakness).  */
@@ -3364,7 +3368,7 @@ extern void sweep_weak_hash_tables (void);
 EMACS_UINT hash_string (char const *, ptrdiff_t);
 EMACS_UINT sxhash (Lisp_Object, int);
 Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object,
-                             Lisp_Object, Lisp_Object);
+                             Lisp_Object, Lisp_Object, Lisp_Object);
 ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
 ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
     EMACS_UINT);
diff --git a/src/lread.c b/src/lread.c
index ea2a1d1d85..17806922a8 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2599,7 +2599,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
       Lisp_Object val = Qnil;
       /* The size is 2 * number of allowed keywords to
  make-hash-table.  */
-      Lisp_Object params[10];
+      Lisp_Object params[12];
       Lisp_Object ht;
       Lisp_Object key = Qnil;
       int param_count = 0;
@@ -2636,6 +2636,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
       if (!NILP (params[param_count + 1]))
  param_count += 2;

+              params[param_count] = QCpurecopy;
+              params[param_count + 1] = Fplist_get (tmp, Qpurecopy);
+              if (!NILP (params[param_count + 1]))
+                param_count += 2;
+
       /* This is the hash table data.  */
       data = Fplist_get (tmp, Qdata);

@@ -4849,6 +4854,7 @@ that are loaded before your customizations are read!  */);
   DEFSYM (Qdata, "data");
   DEFSYM (Qtest, "test");
   DEFSYM (Qsize, "size");
+  DEFSYM (Qpurecopy, "purecopy");
   DEFSYM (Qweakness, "weakness");
   DEFSYM (Qrehash_size, "rehash-size");
   DEFSYM (Qrehash_threshold, "rehash-threshold");
diff --git a/src/print.c b/src/print.c
index 36d68a452e..db3d00f51f 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1818,6 +1818,12 @@ print_object (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag)
       print_object (h->rehash_threshold, printcharfun, escapeflag);
     }

+          if (!NILP (h->pure))
+            {
+              print_c_string (" purecopy ", printcharfun);
+      print_object (h->pure, printcharfun, escapeflag);
+            }
+
   print_c_string (" data ", printcharfun);

   /* Print the data here as a plist. */
diff --git a/src/profiler.c b/src/profiler.c
index 88825bebdb..a223a7e7c0 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -48,7 +48,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth)
      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
diff --git a/src/xterm.c b/src/xterm.c
index 80cf8ce191..38229a5f31 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -12877,7 +12877,7 @@ keysyms.  The default is nil, which is the
same as `super'.  */);
   Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900),
      make_float (DEFAULT_REHASH_SIZE),
      make_float (DEFAULT_REHASH_THRESHOLD),
-     Qnil);
+     Qnil, Qnil);

   DEFVAR_BOOL ("x-frame-normalize-before-maximize",
        x_frame_normalize_before_maximize,

purecopy_hash_table.patch
Description: Text Data