mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2011-11-26 22:27:32 +01:00
parent 4855c63441
commit 59a0273338
2 changed files with 20 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

6
libguile/foreign.c
View file

@ -1152,7 +1152,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
if (closure == executable) if (closure == executable)
{ {
pointer = scm_from_pointer (executable, ffi_closure_free); 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 else
{ {
@ -1166,7 +1167,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
pointer = scm_from_pointer (executable, NULL); pointer = scm_from_pointer (executable, NULL);
friend = scm_from_pointer (closure, ffi_closure_free); 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; return pointer;

16
test-suite/tests/foreign.test
View file

@ -272,6 +272,22 @@
(proc* (pointer->procedure void pointer '()))) (proc* (pointer->procedure void pointer '())))
(proc*) (proc*)
called?) 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)))) (throw 'unresolved))))