From 2a5adbb807ddf3677b22e76fa660755fceaf235f Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Wed, 10 Jun 2026 10:49:31 +0200 Subject: [PATCH] Allow the GC to collect markers in the undo-list * src/undo.c (struct weak_marker_table): New struct. (weak_marker_table): New variable. (alloc_weak_marker_id, scrub_undo_lists, scrub_undo_list): New functions. (record_marker_adjustments)[MPS]: Instead of (MARKER . DISTANCE) entries, create entries of the form (apply undo--adjust-weak-marker HTAB ID DISTANCE). This avoids direct references to markers and hence allows the GC to collect markers. (Qundo__adjust_weak_marker): New symbol. (syms_of_undo): Initialize Qundo__adjust_weak_marker and weak_marker_table. * src/lisp.h (scrub_undo_lists): New prototype. * src/igc.c (process_one_message): Call scrub_undo_lists when a collection cycle has ended. * lisp/simple.el (primitive-undo): Handle the new entries. * test/src/editfns-tests.el (delete-region-undo-markers-1, delete-region-undo-markers-2): Adjust for new entries. * test/lisp/erc/erc-tests.el (erc-update-undo-list): Adjust for new entries. --- lisp/simple.el | 12 ++++ src/igc.c | 1 + src/lisp.h | 3 + src/undo.c | 123 +++++++++++++++++++++++++++++++++++++ test/lisp/erc/erc-tests.el | 46 +++++++++----- test/src/editfns-tests.el | 20 ++++-- 6 files changed, 187 insertions(+), 18 deletions(-) diff --git a/lisp/simple.el b/lisp/simple.el index fd9ba28c762..0577454b414 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3741,6 +3741,18 @@ Return what remains of the list." (and (eq (marker-buffer m) (current-buffer)) (= apos m) (push marker-adj valid-marker-adjustments)))) + ;; The same for weakly held markers + (while (pcase-exhaustive (car list) + (`(apply undo--adjust-weak-marker ,ht ,id ,distance) + (pop list) + (let ((m (gethash id ht))) + (when (and m + (eq (marker-buffer m) (current-buffer)) + (= apos m)) + (push (cons m distance) + valid-marker-adjustments))) + t) + (`,_ nil))) ;; Insert string and adjust point (if (< pos 0) (progn diff --git a/src/igc.c b/src/igc.c index df678e4b2f9..d6d5ecefc86 100644 --- a/src/igc.c +++ b/src/igc.c @@ -4706,6 +4706,7 @@ process_one_message (struct igc *gc) "not_condemned: %" pD "u", secs, condemned, live, not_condemned); } + scrub_undo_lists (); } else emacs_abort (); diff --git a/src/lisp.h b/src/lisp.h index b00ac52878d..5aab36fa844 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -5841,6 +5841,9 @@ extern void record_change (ptrdiff_t, ptrdiff_t); extern void record_property_change (ptrdiff_t, ptrdiff_t, Lisp_Object, Lisp_Object, Lisp_Object); +#ifdef HAVE_MPS +extern void scrub_undo_lists (void); +#endif extern void syms_of_undo (void); /* Defined in textprop.c. */ diff --git a/src/undo.c b/src/undo.c index 55245758b4d..f43ff0fb3e6 100644 --- a/src/undo.c +++ b/src/undo.c @@ -117,6 +117,108 @@ record_insert (ptrdiff_t beg, ptrdiff_t length) Fcons (Fcons (lbeg, lend), BVAR (current_buffer, undo_list))); } +#ifdef HAVE_MPS + +/* A weak_marker_table is a table of weakly held markers for the + undo-list. + + To allow the GC to collect markers from the undo-list, we avoid + direct references from the undo-list to markers. Instead, we + assign markers an integer id and record (id, marker) pairs in a + weak hash table (the id_to_marker field). Only the id is stored in + the undo-list. + + The marker_to_id field is another weak hash table that contains the + same pairs but in reverse order (marker, id). We use that to reuse + the id of markers that already have an id. + + The next_id field is a counter used to generate ids. + + The last_count field helps to detect removed markers. We record + the hash-table-count when a new entry is added to the id_to_marker + hash table. Later, we compare last_count with the then current + hash-table-count; if it smaller, then we know that the GC has + removed some entries. */ +struct weak_marker_table +{ + Lisp_Object id_to_marker; + Lisp_Object marker_to_id; + EMACS_INT next_id; + EMACS_INT last_count; +}; + +static struct weak_marker_table weak_marker_table; + +/* Remove (apply undo--adjust-weak-marker HASHTABLE KEY D) entries + where KEY is no longer in HASHTABLE. */ + +static Lisp_Object +scrub_undo_list (Lisp_Object list) +{ + Lisp_Object tail, *prev = &list; + + for (tail = list; CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object entry = XCAR (tail); + if (CONSP (entry) && EQ (Qapply, XCAR (entry)) + && EQ (Qundo__adjust_weak_marker, XCAR (XCDR (entry))) + && NILP (Fgethash (Fnth (make_fixnum (3), entry), + Fnth (make_fixnum (2), entry), Qnil))) + *prev = XCDR (tail); + else + prev = xcdr_addr (tail); + } + return list; +} + +void +scrub_undo_lists (void) +{ + struct weak_marker_table *t = &weak_marker_table; + + EMACS_INT count = XFIXNUM (Fhash_table_count (t->id_to_marker)); + + if (count == t->last_count) + return; + + eassert (count < t->last_count); + t->last_count = count; + + Lisp_Object tail, buffer; + FOR_EACH_LIVE_BUFFER (tail, buffer) + { + struct buffer *b = XBUFFER (buffer); + if (EQ (BVAR (b, undo_list), Qt)) + continue; + bset_undo_list (b, scrub_undo_list (BVAR (b, undo_list))); + } +} + +static Lisp_Object +alloc_weak_marker_id (struct weak_marker_table *t, Lisp_Object marker) +{ + EMACS_INT count = XFIXNUM (Fhash_table_count (t->id_to_marker)); + if (count < t->last_count) + scrub_undo_lists (); + + Lisp_Object id = Fgethash (marker, t->marker_to_id, Qnil); + if (!NILP (id) && EQ (Fgethash (id, t->id_to_marker, Qnil), marker)) + return id; + + do + { + id = make_fixnum (t->next_id); + t->next_id = (t->next_id + 1) % MOST_POSITIVE_FIXNUM; + } + while (!NILP (Fgethash (id, t->id_to_marker, Qnil))); + Fputhash (id, marker, t->id_to_marker); + Fputhash (marker, id, t->marker_to_id); + t->last_count = count + 1; + return id; +} + +#endif + /* Record the fact that markers in the region of FROM, TO are about to be adjusted. This is done only when a marker points within text being deleted, because that's the only case where an automatic @@ -147,10 +249,23 @@ record_marker_adjustments (ptrdiff_t from, ptrdiff_t to) if (adjustment) { Lisp_Object marker = make_lisp_ptr (m, Lisp_Vectorlike); +#ifdef HAVE_MPS + Lisp_Object id + = alloc_weak_marker_id (&weak_marker_table, marker); + Lisp_Object distance = make_fixnum (adjustment); + Lisp_Object entry + = list5 (Qapply, Qundo__adjust_weak_marker, + weak_marker_table.id_to_marker, id, + distance); + bset_undo_list (current_buffer, + Fcons (entry, BVAR (current_buffer, + undo_list))); +#else bset_undo_list (current_buffer, Fcons (Fcons (marker, make_fixnum (adjustment)), BVAR (current_buffer, undo_list))); +#endif } } } @@ -492,4 +607,12 @@ so it must make sure not to do a lot of consing. */); DEFVAR_BOOL ("undo-inhibit-record-point", undo_inhibit_record_point, doc: /* Non-nil means do not record `point' in `buffer-undo-list'. */); undo_inhibit_record_point = false; + + DEFSYM (Qundo__adjust_weak_marker, "undo--adjust-weak-marker"); + weak_marker_table.id_to_marker + = CALLN (Fmake_hash_table, QCweakness, Qvalue); + weak_marker_table.marker_to_id + = CALLN (Fmake_hash_table, QCweakness, Qkey); + staticpro (&weak_marker_table.id_to_marker); + staticpro (&weak_marker_table.marker_to_id); } diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index f2f874717e9..f36b26f55fd 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -3136,13 +3136,22 @@ (call-interactively #'delete-backward-char 1) (push nil buffer-undo-list) (should (= (point) 47)) - (should (equal buffer-undo-list `(nil - ("c" . -47) - (,marker . -1) - (nil face nil 46 . 47) - 48 - nil - (45 . 48)))) + (cond ((featurep 'mps) + (should + (pcase-exhaustive buffer-undo-list + (`(nil ("c" . -47) + (apply undo--adjust-weak-marker ,ht ,id -1) + (nil face nil 46 . 47) 48 nil (45 . 48)) + (eq (gethash id ht) marker)) + (`_ nil)))) + (t + (should (equal buffer-undo-list `(nil + ("c" . -47) + (,marker . -1) + (nil face nil 46 . 47) + 48 + nil + (45 . 48)))))) ;; The first char after the prompt is at buffer pos 45. (should (= 40 (- 45 (length (erc-prompt))) erc-insert-marker)) @@ -3154,13 +3163,22 @@ (should (= 11 (length " test\n") (- (point) 47))) ;; The list remains unchanged relative to the end of the buffer. - (should (equal buffer-undo-list `(nil - ("c" . -58) - (,marker . -1) - (nil face nil 57 . 58) - 59 - nil - (56 . 59)))) + (cond ((featurep 'mps) + (should + (pcase-exhaustive buffer-undo-list + (`(nil ("c" . -58) + (apply undo--adjust-weak-marker ,ht ,id -1) + (nil face nil 57 . 58) 59 nil (56 . 59)) + (eq (gethash id ht) marker)) + (`_ nil)))) + (t + (should (equal buffer-undo-list `(nil + ("c" . -58) + (,marker . -1) + (nil face nil 57 . 58) + 59 + nil + (56 . 59)))))) ;; Undo behavior works as expected. (undo nil) diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index e6f80d0ef48..971aaf3f64f 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -676,8 +676,14 @@ sufficiently large to avoid truncation." ;; `type-of' on them will cause Emacs to abort. Calling ;; `garbage-collect' will also abort if it finds any reachable ;; freed objects. - (should (eq (type-of (car (nth 1 buffer-undo-list))) 'marker)) - (should (eq (type-of (car (nth 2 buffer-undo-list))) 'marker)) + (cond ((featurep 'mps) + (dolist (i '(1 2)) + (should (pcase-exhaustive (nth i buffer-undo-list) + (`(apply undo--adjust-weak-marker . ,_) t) + (`,_ nil))))) + (t + (should (eq (type-of (car (nth 1 buffer-undo-list))) 'marker)) + (should (eq (type-of (car (nth 2 buffer-undo-list))) 'marker)))) (garbage-collect))) (ert-deftest delete-region-undo-markers-2 () @@ -701,8 +707,14 @@ sufficiently large to avoid truncation." ;; `type-of' on them will cause Emacs to abort. Calling ;; `garbage-collect' will also abort if it finds any reachable ;; freed objects. - (should (eq (type-of (car (nth 3 buffer-undo-list))) 'marker)) - (should (eq (type-of (car (nth 4 buffer-undo-list))) 'marker)) + (cond ((featurep 'mps) + (dolist (i '(3 4)) + (should (pcase-exhaustive (nth i buffer-undo-list) + (`(apply undo--adjust-weak-marker . ,_) t) + (`,_ nil))))) + (t + (should (eq (type-of (car (nth 3 buffer-undo-list))) 'marker)) + (should (eq (type-of (car (nth 4 buffer-undo-list))) 'marker)))) (garbage-collect))) (ert-deftest format-bignum ()