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

@@ -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

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 ();

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

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);
 }

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 "<bob> 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)

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 ()