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 . */ #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,