Allow arbitrary code in ASSOC procedures for weak hash tables (bug #29616).

* libguile/hashtab.c (struct t_assoc_args, do_weak_bucket_assoc):
  Remove.
  (struct t_fixup_args): New type.
  (do_weak_bucket_fixup): New function.
  (weak_bucket_assoc): Use it.  Keep strong references to BUCKET's
  entries in STRONG_REFS.  Call ASSOC once the alloc lock has been
  released.  This fixes bug #29616.

* test-suite/tests/weaks.test ("assoc can do anything"): New test.

libguile/hashtab.c

@@ -137,40 +137,35 @@ scm_fixup_weak_alist (SCM alist, size_t *removed_items)
    || (SCM_I_IS_VECTOR (table)))
 
 
-/* Packed arguments for `do_weak_bucket_assoc ()'.  */
+/* Packed arguments for `do_weak_bucket_fixup'.  */
-struct t_assoc_args
+struct t_fixup_args
 {
-  /* Input arguments.  */
+  SCM bucket;
-  SCM object;
+  SCM *bucket_copy;
-  SCM buckets;
-  size_t bucket_index;
-  scm_t_assoc_fn assoc_fn;
-  void *closure;
-
-  /* Output arguments.  */
-  SCM result;
   size_t removed_items;
 };
 
 static void *
-do_weak_bucket_assoc (void *data)
+do_weak_bucket_fixup (void *data)
 {
-  struct t_assoc_args *args;
+  struct t_fixup_args *args;
-  size_t removed;
+  SCM pair, *copy;
-  SCM bucket, result;
 
-  args = (struct t_assoc_args *) data;
+  args = (struct t_fixup_args *) data;
 
-  bucket = SCM_SIMPLE_VECTOR_REF (args->buckets, args->bucket_index);
+  args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items);
-  bucket = scm_fixup_weak_alist (bucket, &removed);
 
-  SCM_SIMPLE_VECTOR_SET (args->buckets, args->bucket_index, bucket);
+  for (pair = args->bucket, copy = args->bucket_copy;
+       scm_is_pair (pair);
+       pair = SCM_CDR (pair), copy += 2)
+    {
+      /* At this point, all weak pairs have been removed.  */
+      assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair)));
 
-  /* Run ASSOC_FN on the now clean BUCKET.  */
+      /* Copy the key and value.  */
-  result = args->assoc_fn (args->object, bucket, args->closure);
+      copy[0] = SCM_CAAR (pair);
-
+      copy[1] = SCM_CDAR (pair);
-  args->result = result;
+    }
-  args->removed_items = removed;
 
   return args;
 }
@@ -184,26 +179,38 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index,
 		   scm_t_assoc_fn assoc, SCM object, void *closure)
 {
   SCM result;
-  struct t_assoc_args args;
+  SCM bucket, *strong_refs;
+  struct t_fixup_args args;
 
-  args.object = object;
+  bucket = SCM_SIMPLE_VECTOR_REF (buckets, bucket_index);
-  args.buckets = buckets;
-  args.bucket_index = bucket_index;
-  args.assoc_fn = assoc;
-  args.closure = closure;
 
-  /* Fixup the bucket and pass the clean bucket to ASSOC.  Do that with the
+  /* Prepare STRONG_REFS as an array large enough to hold all the keys
-     allocation lock held to avoid seeing disappearing links pointing to
+     and values in BUCKET.  */
-     objects that have already been reclaimed (this happens when the
+  strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM));
-     disappearing links that point to it haven't yet been cleared.)
-     Thus, ASSOC must not take long, and it must not make any non-local
-     exit.  */
-  GC_call_with_alloc_lock (do_weak_bucket_assoc, &args);
 
-  result = args.result;
+  args.bucket = bucket;
+  args.bucket_copy = strong_refs;
+
+  /* Fixup BUCKET.  Do that with the allocation lock held to avoid
+     seeing disappearing links pointing to objects that have already
+     been reclaimed (this happens when the disappearing links that point
+     to it haven't yet been cleared.)
+
+     The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
+     of BUCKET's entries after it's been fixed up.  Thus, all the
+     entries kept in BUCKET are still reachable when ASSOC sees
+     them.  */
+  GC_call_with_alloc_lock (do_weak_bucket_fixup, &args);
+
+  bucket = args.bucket;
+  SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket);
+
+  result = assoc (object, bucket, closure);
   assert (!scm_is_pair (result) ||
 	  !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result)));
 
+  scm_remember_upto_here_1 (strong_refs);
+
   if (args.removed_items > 0 && SCM_HASHTABLE_P (table))
     {
       /* Update TABLE's item count and optionally trigger a rehash.  */

test-suite/tests/weaks.test

@@ -206,4 +206,41 @@
                             '("is" "test" "the" "weak" "hash system"))
                      (any not values)
                      (hash-ref z test-key)
-                     #t))))))
+                     #t))))
+
+   (pass-if "assoc can do anything"
+            ;; Until 1.9.12, as hash table's custom ASSOC procedure was
+            ;; called with the GC lock alloc held, which imposed severe
+            ;; restrictions on what it could do (bug #29616).  This test
+            ;; makes sure this is no longer the case.
+            (let ((h (make-doubly-weak-hash-table 2))
+                  (c 123)
+                  (k "GNU"))
+
+              (define (assoc-ci key bucket)
+                (make-list 123) ;; this should be possible
+                (gc)            ;; this too
+                (find (lambda (p)
+                        (string-ci=? key (car p)))
+                      bucket))
+
+              (hashx-set! string-hash-ci assoc-ci h
+                          (string-copy "hello") (string-copy "world"))
+              (hashx-set! string-hash-ci assoc-ci h
+                          k "Guile")
+
+              (and (every (cut valid? <> "Guile")
+                          (unfold (cut >= <> c)
+                                  (lambda (_)
+                                    (hashx-ref string-hash-ci assoc-ci
+                                               h "gnu"))
+                                  1+
+                                  0))
+                   (every (cut valid? <> "world")
+                          (unfold (cut >= <> c)
+                                  (lambda (_)
+                                    (hashx-ref string-hash-ci assoc-ci
+                                               h "HELLO"))
+                                  1+
+                                  0))
+                   #t)))))