FFI: Hold a weak reference to the procedure passed to `procedure->pointer'.

* libguile/foreign.c (scm_procedure_to_pointer): Keep a weak reference
  to PROC.

* test-suite/tests/foreign.test ("procedure->pointer")["procedure is
  retained"]: New test.

diff --git a/libguile/foreign.c b/libguile/foreign.c
index 021c183..f3af157 100644 (file)
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -1152,7 +1152,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
   if (closure == executable)
     {
       pointer = scm_from_pointer (executable, ffi_closure_free);
-      register_weak_reference (pointer, cif_pointer);
+      register_weak_reference (pointer,
+                              scm_list_2 (proc, cif_pointer));
     }
   else
     {
@@ -1166,7 +1167,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
       pointer = scm_from_pointer (executable, NULL);
       friend = scm_from_pointer (closure, ffi_closure_free);
 
-      register_weak_reference (pointer, scm_list_2 (cif_pointer, friend));
+      register_weak_reference (pointer,
+                              scm_list_3 (proc, cif_pointer, friend));
     }
 
   return pointer;

diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 5657977..2c326c9 100644 (file)
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -272,6 +272,22 @@
                (proc*   (pointer->procedure void pointer '())))
           (proc*)
           called?)
+        (throw 'unresolved)))
+
+  (pass-if "procedure is retained"
+    ;; The lambda passed to `procedure->pointer' must remain live.
+    (if (defined? 'procedure->pointer)
+        (let* ((ptr   (procedure->pointer int
+                                          (lambda (x) (+ x 7))
+                                          (list int)))
+               (procs (unfold (cut >= <> 10000)
+                              (lambda (i)
+                                (pointer->procedure int ptr (list int)))
+                              1+
+                              0)))
+          (gc) (gc) (gc)
+          (every (cut = <> 9)
+                 (map (lambda (f) (f 2)) procs)))
         (throw 'unresolved))))
 
 \f