Commit 9c4dfdd1 authored by Vibhav Pant's avatar Vibhav Pant

Fix hash tables not being purified correctly.

* src/alloc.c
(purecopy_hash_table) New function, makes a copy of the given hash
table in pure storage.
Add new struct `pinned_object' and `pinned_objects' linked list for
pinning objects.
(Fpurecopy) Allow purifying hash tables
(purecopy) Pin hash tables that are either weak or not declared with
`:purecopy t`, use purecopy_hash_table otherwise.
(marked_pinned_objects) New function, marks all objects in pinned_objects.
(garbage_collect_1) Use it. Mark all pinned objects before sweeping.
* src/lisp.h Add new field `pure' to struct `Lisp_Hash_Table'.
* src/fns.c: Add `purecopy' parameter to hash tables.
(Fmake_hash_table): Check for a `:purecopy PURECOPY' argument, pass it
to make_hash_table.
(make_hash_table): Add `pure' parameter, set h->pure to it.
(Fclrhash, Fremhash, Fputhash): Enforce that the table is impure with
CHECK_IMPURE.
* src/lread.c: (read1) Parse for `purecopy' parameter while reading
  hash tables.
* src/print.c: (print_object) add the `purecopy' parameter while
  printing hash tables.
* src/category.c, src/emacs-module.c, src/image.c, src/profiler.c,
  src/xterm.c: Use new (make_hash_table).
parent 8ba236e7
...@@ -5434,6 +5434,37 @@ make_pure_vector (ptrdiff_t len) ...@@ -5434,6 +5434,37 @@ make_pure_vector (ptrdiff_t len)
return new; return new;
} }
/* Copy all contents and parameters of TABLE to a new table allocated
from pure space, return the purified table. */
static struct Lisp_Hash_Table *
purecopy_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, DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
doc: /* Make a copy of object OBJ in pure storage. doc: /* Make a copy of object OBJ in pure storage.
Recursively copies contents of vectors and cons cells. Recursively copies contents of vectors and cons cells.
...@@ -5442,14 +5473,22 @@ Does not copy symbols. Copies strings without text properties. */) ...@@ -5442,14 +5473,22 @@ Does not copy symbols. Copies strings without text properties. */)
{ {
if (NILP (Vpurify_flag)) if (NILP (Vpurify_flag))
return obj; return obj;
else if (MARKERP (obj) || OVERLAYP (obj) else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj))
|| HASH_TABLE_P (obj) || SYMBOLP (obj))
/* Can't purify those. */ /* Can't purify those. */
return obj; return obj;
else else
return purecopy (obj); 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 static Lisp_Object
purecopy (Lisp_Object obj) purecopy (Lisp_Object obj)
{ {
...@@ -5477,7 +5516,27 @@ purecopy (Lisp_Object obj) ...@@ -5477,7 +5516,27 @@ purecopy (Lisp_Object obj)
obj = make_pure_string (SSDATA (obj), SCHARS (obj), obj = make_pure_string (SSDATA (obj), SCHARS (obj),
SBYTES (obj), SBYTES (obj),
STRING_MULTIBYTE (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 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) || 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; /* Don't hash cons it. */
}
struct Lisp_Hash_Table *h = purecopy_hash_table (table);
XSET_HASH_TABLE (obj, h);
}
else if (COMPILEDP (obj) || VECTORP (obj))
{ {
struct Lisp_Vector *objp = XVECTOR (obj); struct Lisp_Vector *objp = XVECTOR (obj);
ptrdiff_t nbytes = vector_nbytes (objp); ptrdiff_t nbytes = vector_nbytes (objp);
...@@ -5693,6 +5752,16 @@ compact_undo_list (Lisp_Object list) ...@@ -5693,6 +5752,16 @@ compact_undo_list (Lisp_Object list)
return list; return 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 static void
mark_pinned_symbols (void) mark_pinned_symbols (void)
{ {
...@@ -5813,6 +5882,7 @@ garbage_collect_1 (void *end) ...@@ -5813,6 +5882,7 @@ garbage_collect_1 (void *end)
for (i = 0; i < staticidx; i++) for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]); mark_object (*staticvec[i]);
mark_pinned_objects ();
mark_pinned_symbols (); mark_pinned_symbols ();
mark_terminals (); mark_terminals ();
mark_kboards (); mark_kboards ();
......
...@@ -67,7 +67,7 @@ hash_get_category_set (Lisp_Object table, Lisp_Object category_set) ...@@ -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_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD), make_float (DEFAULT_REHASH_THRESHOLD),
Qnil)); Qnil, Qnil));
h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]); h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
i = hash_lookup (h, category_set, &hash); i = hash_lookup (h, category_set, &hash);
if (i >= 0) if (i >= 0)
......
...@@ -1016,7 +1016,7 @@ syms_of_module (void) ...@@ -1016,7 +1016,7 @@ syms_of_module (void)
= make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE), = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD), make_float (DEFAULT_REHASH_THRESHOLD),
Qnil); Qnil, Qnil);
Funintern (Qmodule_refs_hash, Qnil); Funintern (Qmodule_refs_hash, Qnil);
DEFSYM (Qmodule_environments, "module-environments"); DEFSYM (Qmodule_environments, "module-environments");
......
...@@ -34,6 +34,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ ...@@ -34,6 +34,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#include "buffer.h" #include "buffer.h"
#include "intervals.h" #include "intervals.h"
#include "window.h" #include "window.h"
#include "puresize.h"
static void sort_vector_copy (Lisp_Object, ptrdiff_t, static void sort_vector_copy (Lisp_Object, ptrdiff_t,
Lisp_Object *restrict, Lisp_Object *restrict); Lisp_Object *restrict, Lisp_Object *restrict);
...@@ -3750,12 +3751,17 @@ allocate_hash_table (void) ...@@ -3750,12 +3751,17 @@ allocate_hash_table (void)
(table size) is >= REHASH_THRESHOLD. (table size) is >= REHASH_THRESHOLD.
WEAK specifies the weakness of the table. If non-nil, it must be 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 Lisp_Object
make_hash_table (struct hash_table_test test, make_hash_table (struct hash_table_test test,
Lisp_Object size, Lisp_Object rehash_size, 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; struct Lisp_Hash_Table *h;
Lisp_Object table; Lisp_Object table;
...@@ -3796,6 +3802,7 @@ make_hash_table (struct hash_table_test test, ...@@ -3796,6 +3802,7 @@ make_hash_table (struct hash_table_test test,
h->hash = Fmake_vector (size, Qnil); h->hash = Fmake_vector (size, Qnil);
h->next = Fmake_vector (size, Qnil); h->next = Fmake_vector (size, Qnil);
h->index = Fmake_vector (make_number (index_size), Qnil); h->index = Fmake_vector (make_number (index_size), Qnil);
h->pure = pure;
/* Set up the free list. */ /* Set up the free list. */
for (i = 0; i < sz - 1; ++i) for (i = 0; i < sz - 1; ++i)
...@@ -4460,10 +4467,15 @@ key, value, one of key or value, or both key and value, depending on ...@@ -4460,10 +4467,15 @@ 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 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
is nil. 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. Any further changes to purified tables will result
in an error.
usage: (make-hash-table &rest KEYWORD-ARGS) */) usage: (make-hash-table &rest KEYWORD-ARGS) */)
(ptrdiff_t nargs, Lisp_Object *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; struct hash_table_test testdesc;
ptrdiff_t i; ptrdiff_t i;
USE_SAFE_ALLOCA; USE_SAFE_ALLOCA;
...@@ -4497,6 +4509,9 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) ...@@ -4497,6 +4509,9 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
testdesc.cmpfn = cmpfn_user_defined; 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. */ /* See if there's a `:size SIZE' argument. */
i = get_key_arg (QCsize, nargs, args, used); i = get_key_arg (QCsize, nargs, args, used);
size = i ? args[i] : Qnil; size = i ? args[i] : Qnil;
...@@ -4538,7 +4553,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) ...@@ -4538,7 +4553,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
signal_error ("Invalid argument list", args[i]); signal_error ("Invalid argument list", args[i]);
SAFE_FREE (); 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 +4633,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0, ...@@ -4617,7 +4633,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
doc: /* Clear hash table TABLE and return it. */) doc: /* Clear hash table TABLE and return it. */)
(Lisp_Object table) (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. */ /* Be compatible with XEmacs. */
return table; return table;
} }
...@@ -4641,9 +4659,10 @@ VALUE. In any case, return VALUE. */) ...@@ -4641,9 +4659,10 @@ VALUE. In any case, return VALUE. */)
(Lisp_Object key, Lisp_Object value, Lisp_Object table) (Lisp_Object key, Lisp_Object value, Lisp_Object table)
{ {
struct Lisp_Hash_Table *h = check_hash_table (table); struct Lisp_Hash_Table *h = check_hash_table (table);
CHECK_IMPURE (table, h);
ptrdiff_t i; ptrdiff_t i;
EMACS_UINT hash; EMACS_UINT hash;
i = hash_lookup (h, key, &hash); i = hash_lookup (h, key, &hash);
if (i >= 0) if (i >= 0)
set_hash_value_slot (h, i, value); set_hash_value_slot (h, i, value);
...@@ -4659,6 +4678,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0, ...@@ -4659,6 +4678,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
(Lisp_Object key, Lisp_Object table) (Lisp_Object key, Lisp_Object table)
{ {
struct Lisp_Hash_Table *h = check_hash_table (table); struct Lisp_Hash_Table *h = check_hash_table (table);
CHECK_IMPURE (table, h);
hash_remove_from_table (h, key); hash_remove_from_table (h, key);
return Qnil; return Qnil;
} }
...@@ -5029,6 +5049,7 @@ syms_of_fns (void) ...@@ -5029,6 +5049,7 @@ syms_of_fns (void)
DEFSYM (Qequal, "equal"); DEFSYM (Qequal, "equal");
DEFSYM (QCtest, ":test"); DEFSYM (QCtest, ":test");
DEFSYM (QCsize, ":size"); DEFSYM (QCsize, ":size");
DEFSYM (QCpurecopy, ":purecopy");
DEFSYM (QCrehash_size, ":rehash-size"); DEFSYM (QCrehash_size, ":rehash-size");
DEFSYM (QCrehash_threshold, ":rehash-threshold"); DEFSYM (QCrehash_threshold, ":rehash-threshold");
DEFSYM (QCweakness, ":weakness"); DEFSYM (QCweakness, ":weakness");
......
...@@ -4020,7 +4020,7 @@ xpm_make_color_table_h (void (**put_func) (Lisp_Object, const char *, int, ...@@ -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), return make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD), make_float (DEFAULT_REHASH_THRESHOLD),
Qnil); Qnil, Qnil);
} }
static void static void
......
...@@ -1995,6 +1995,10 @@ struct Lisp_Hash_Table ...@@ -1995,6 +1995,10 @@ struct Lisp_Hash_Table
hash table size to reduce collisions. */ hash table size to reduce collisions. */
Lisp_Object index; 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 /* 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 `count' are special and are either ignored by the GC or traced in
a special way (e.g. because of weakness). */ a special way (e.g. because of weakness). */
...@@ -3364,7 +3368,7 @@ extern void sweep_weak_hash_tables (void); ...@@ -3364,7 +3368,7 @@ extern void sweep_weak_hash_tables (void);
EMACS_UINT hash_string (char const *, ptrdiff_t); EMACS_UINT hash_string (char const *, ptrdiff_t);
EMACS_UINT sxhash (Lisp_Object, int); EMACS_UINT sxhash (Lisp_Object, int);
Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object, 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_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
EMACS_UINT); EMACS_UINT);
......
...@@ -2599,7 +2599,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) ...@@ -2599,7 +2599,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
Lisp_Object val = Qnil; Lisp_Object val = Qnil;
/* The size is 2 * number of allowed keywords to /* The size is 2 * number of allowed keywords to
make-hash-table. */ make-hash-table. */
Lisp_Object params[10]; Lisp_Object params[12];
Lisp_Object ht; Lisp_Object ht;
Lisp_Object key = Qnil; Lisp_Object key = Qnil;
int param_count = 0; int param_count = 0;
...@@ -2636,6 +2636,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) ...@@ -2636,6 +2636,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (!NILP (params[param_count + 1])) if (!NILP (params[param_count + 1]))
param_count += 2; 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. */ /* This is the hash table data. */
data = Fplist_get (tmp, Qdata); data = Fplist_get (tmp, Qdata);
...@@ -4849,6 +4854,7 @@ that are loaded before your customizations are read! */); ...@@ -4849,6 +4854,7 @@ that are loaded before your customizations are read! */);
DEFSYM (Qdata, "data"); DEFSYM (Qdata, "data");
DEFSYM (Qtest, "test"); DEFSYM (Qtest, "test");
DEFSYM (Qsize, "size"); DEFSYM (Qsize, "size");
DEFSYM (Qpurecopy, "purecopy");
DEFSYM (Qweakness, "weakness"); DEFSYM (Qweakness, "weakness");
DEFSYM (Qrehash_size, "rehash-size"); DEFSYM (Qrehash_size, "rehash-size");
DEFSYM (Qrehash_threshold, "rehash-threshold"); DEFSYM (Qrehash_threshold, "rehash-threshold");
......
...@@ -1818,6 +1818,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) ...@@ -1818,6 +1818,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
print_object (h->rehash_threshold, printcharfun, 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_c_string (" data ", printcharfun);
/* Print the data here as a plist. */ /* Print the data here as a plist. */
......
...@@ -48,7 +48,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth) ...@@ -48,7 +48,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth)
make_number (heap_size), make_number (heap_size),
make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD), make_float (DEFAULT_REHASH_THRESHOLD),
Qnil); Qnil, Qnil);
struct Lisp_Hash_Table *h = XHASH_TABLE (log); struct Lisp_Hash_Table *h = XHASH_TABLE (log);
/* What is special about our hash-tables is that the keys are pre-filled /* What is special about our hash-tables is that the keys are pre-filled
......
...@@ -12877,7 +12877,7 @@ keysyms. The default is nil, which is the same as `super'. */); ...@@ -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), Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900),
make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD), make_float (DEFAULT_REHASH_THRESHOLD),
Qnil); Qnil, Qnil);
DEFVAR_BOOL ("x-frame-normalize-before-maximize", DEFVAR_BOOL ("x-frame-normalize-before-maximize",
x_frame_normalize_before_maximize, x_frame_normalize_before_maximize,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment