summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/alloc.c76
-rw-r--r--src/category.c2
-rw-r--r--src/emacs-module.c2
-rw-r--r--src/fns.c33
-rw-r--r--src/image.c2
-rw-r--r--src/lisp.h6
-rw-r--r--src/lread.c8
-rw-r--r--src/print.c6
-rw-r--r--src/profiler.c2
-rw-r--r--src/xterm.c2
10 files changed, 123 insertions, 16 deletions
diff --git a/src/alloc.c b/src/alloc.c
index f7b6515f4e7..dd2b688f91e 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5434,6 +5434,37 @@ make_pure_vector (ptrdiff_t len)
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,
doc: /* Make a copy of object OBJ in pure storage.
Recursively copies contents of vectors and cons cells.
@@ -5442,14 +5473,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 +5516,27 @@ 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 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);
ptrdiff_t nbytes = vector_nbytes (objp);
@@ -5694,6 +5753,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 +5882,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 e5d261c1cff..ff287a4af3d 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 e22c7dc5b72..69fa5c8e64c 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 b8ebfe5b2e7..5769eac9987 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;
@@ -3796,6 +3802,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 +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
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) */)
(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 +4509,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 +4553,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 +4633,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 +4659,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 +4678,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 +5049,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 39677d2add9..ad0143be48b 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 84d53bb1eec..91c430fe98d 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 ea2a1d1d858..17806922a8c 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 36d68a452ec..db3d00f51f2 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 88825bebdb2..a223a7e7c07 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 80cf8ce1912..38229a5f31f 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,
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-19 09:43:14 +0000