From c7defd4faa72947ab077d3f0c75c4f92a48d9b4e Mon Sep 17 00:00:00 2001
From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sun, 14 Apr 2024 18:20:47 +0200
Subject: [PATCH] GC-mark temporary key values created when sorting (bug#69709)

Bug reported and fix proposed by Aris Spathis.

* src/sort.c (merge_markmem): Mark heap-allocated temporary key values.
(tim_sort): Delay key function calls to after marking function has been
registered.
* test/src/fns-tests.el (fns-tests-sort-gc): New test.

(cherry picked from commit 3d3602055264ca3095b7f28ca7e27a6f2782649a)
---
 src/sort.c            | 23 +++++++++++++++++------
 test/src/fns-tests.el | 21 +++++++++++++++++++++
 2 files changed, 38 insertions(+), 6 deletions(-)

diff --git a/src/sort.c b/src/sort.c
index 527d5550342..808cd187dcf 100644
--- a/src/sort.c
+++ b/src/sort.c
@@ -532,6 +532,9 @@ merge_markmem (void *arg)
   merge_state *ms = arg;
   eassume (ms != NULL);
 
+  if (ms->allocated_keys != NULL)
+    mark_objects (ms->allocated_keys, ms->listlen);
+
   if (ms->reloc.size != NULL && *ms->reloc.size > 0)
     {
       Lisp_Object *src = (ms->reloc.src->values
@@ -1107,21 +1110,29 @@ tim_sort (Lisp_Object predicate, Lisp_Object keyfunc,
       if (length < MERGESTATE_TEMP_SIZE / 2)
 	keys = &ms.temparray[length + 1];
       else
-	keys = allocated_keys = xmalloc (length * word_size);
-
-      for (ptrdiff_t i = 0; i < length; i++)
-	keys[i] = call1 (keyfunc, seq[i]);
+	{
+	  /* Fill with valid Lisp values in case a GC occurs before all
+	     keys have been computed.  */
+	  verify (NIL_IS_ZERO);
+	  keys = allocated_keys = xzalloc (length * word_size);
+	}
 
       lo.keys = keys;
       lo.values = seq;
     }
 
+  merge_init (&ms, length, allocated_keys, &lo, predicate);
+
+  /* Compute keys after merge_markmem has been registered by merge_init
+     (any call to keyfunc might trigger a GC).  */
+  if (!NILP (keyfunc))
+    for (ptrdiff_t i = 0; i < length; i++)
+      keys[i] = call1 (keyfunc, seq[i]);
+
   /* FIXME: This is where we would check the keys for interesting
      properties for more optimised comparison (such as all being fixnums
      etc).  */
 
-  merge_init (&ms, length, allocated_keys, &lo, predicate);
-
   /* March over the array once, left to right, finding natural runs,
      and extending short natural runs to minrun elements.  */
   const ptrdiff_t minrun = merge_compute_minrun (length);
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 4536816dc89..068daf893f1 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -418,6 +418,27 @@
                     (should-not (and (> size 0) (eq res seq)))
                     (should (equal seq input))))))))))))
 
+(ert-deftest fns-tests-sort-gc ()
+  ;; Make sure our temporary storage is traversed by the GC.
+  (let* ((n 1000)
+         (a (mapcar #'number-to-string (number-sequence 1 n)))
+         (i 0)
+         ;; Force frequent GCs in both the :key and :lessp functions.
+         (s (sort a
+                  :key (lambda (x)
+                         (setq i (1+ i))
+                         (when (> i 300)
+                           (garbage-collect)
+                           (setq i 0))
+                         (copy-sequence x))
+                  :lessp (lambda (a b)
+                           (setq i (1+ i))
+                           (when (> i 300)
+                             (garbage-collect)
+                             (setq i 0))
+                           (string< a b)))))
+    (should (equal (length s) (length a)))))
+
 (defvar w32-collate-ignore-punctuation)
 
 (ert-deftest fns-tests-collate-sort ()
-- 
2.39.5