On Sat, Dec 20, 2008 at 4:09 PM, Alejandro Forero Cuervo
<[email protected]> wrote:
>> I'm not sure I can follow your example completely (I always get
>> quickly confused with these scenarios), but I understand the
>> "weak"/"finalizable" GC-root suggestion. I have to think more about
>> it, but it should be possible.
>
> I think this should be implemented: right now it is *impossible* to
> store pointers to Scheme-data inside C-data without the potential for
> memory leaks.
>
Attached is a patch against chicken 4 (should work with chicken 3).
The new C function "CHICKEN_new_finalizable_gc_root" creates
gc roots that can refer to data which is about to be finalized.
cheers,
felix
Index: chicken.h
===================================================================
--- chicken.h (revision 12937)
+++ chicken.h (working copy)
@@ -549,6 +549,7 @@
{
C_word value;
struct C_gc_root_struct *next, *prev;
+ int finalizable;
} C_GC_ROOT;
typedef struct C_ptable_entry_struct
@@ -1161,6 +1162,8 @@
C_fctexport C_word CHICKEN_run(void *toplevel);
C_fctexport C_word CHICKEN_continue(C_word k);
C_fctexport void *CHICKEN_new_gc_root();
+C_fctexport void *CHICKEN_new_finalizable_gc_root();
+C_fctexport void *CHICKEN_new_gc_root_2(int finalizable);
C_fctexport void CHICKEN_delete_gc_root(void *root);
C_fctexport void *CHICKEN_global_lookup(char *name);
C_fctexport int CHICKEN_is_running();
Index: manual/Embedding
===================================================================
--- manual/Embedding (revision 12936)
+++ manual/Embedding (working copy)
@@ -279,6 +279,16 @@
an unspecified value.
+=== CHICKEN_new_finalizable_gc_root
+
+ [C function] void* CHICKEN_new_finalizable_gc_root ()
+
+Similar to {{CHICKEN_new_gc_root}}, but allows the stored value to
+be finalized: if this gc root holds reference to an otherwise
+unreferenced data object that has a finalizer, the finalizer is still
+invoked.
+
+
=== CHICKEN_delete_gc_root
[C function] void CHICKEN_delete_gc_root (void *root)
Index: tests/runtests.sh
===================================================================
--- tests/runtests.sh (revision 12936)
+++ tests/runtests.sh (working copy)
@@ -96,6 +96,9 @@
echo "======================================== finalizer tests ..."
$interpret -s test-finalizers.scm
+echo "======================================== finalizer tests (2) ..."
+$compile test-finalizers-2.scm && ./a.out
+
echo "======================================== locative stress test ..."
$compile locative-stress-test.scm && ./a.out
Index: tests/test-finalizers-2.scm
===================================================================
--- tests/test-finalizers-2.scm (revision 0)
+++ tests/test-finalizers-2.scm (revision 0)
@@ -0,0 +1,60 @@
+;;;; test-finalizers-2.scm - test finalizers + GC roots
+
+
+(use srfi-1)
+
+(define *n* 1000)
+(define *count* 0)
+
+#>
+static void *
+makef(int f, ___scheme_value x)
+{
+ void *r = f ? CHICKEN_new_finalizable_gc_root() : CHICKEN_new_gc_root();
+
+ CHICKEN_gc_root_set(r, x);
+ return r;
+}
+
+static void
+freef(void *r)
+{
+ CHICKEN_delete_gc_root(r);
+}
+<#
+
+
+(define makef (foreign-lambda c-pointer "makef" bool scheme-object))
+(define freef (foreign-lambda void "freef" c-pointer))
+
+(define ((fin f e) x)
+ (set! *count* (add1 *count*))
+ (assert ((if e even? odd?) (car x)))
+ (when e (freef f)))
+
+(print "creating gc roots")
+
+(let* ((x (list-tabulate *n* list))
+ (fs (circular-list #t #f))
+ (rs (map makef fs x)))
+ (for-each
+ (lambda (x f e)
+ (set-finalizer! x (fin f e)))
+ x rs fs)
+ (print "forcing finalizers")
+ (##sys#force-finalizers)
+ (assert (zero? *count*))
+ (print "dropping data")
+ (set! x #f)
+ (print "forcing finalizables")
+ (##sys#force-finalizers)
+ (print *count*)
+ (assert (= (quotient *n* 2) *count*))
+ (print "releasing non-finalizable gc roots")
+ (for-each
+ (lambda (f e)
+ (unless e (freef f)))
+ rs fs)
+ (print "forcing remaining")
+ (##sys#force-finalizers)
+ (assert (= *n* *count*)))
Index: runtime.c
===================================================================
--- runtime.c (revision 12937)
+++ runtime.c (working copy)
@@ -807,7 +807,7 @@
}
-void *CHICKEN_new_gc_root()
+void *CHICKEN_new_gc_root_2(int finalizable)
{
C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));
@@ -817,6 +817,7 @@
r->value = C_SCHEME_UNDEFINED;
r->next = gc_root_list;
r->prev = NULL;
+ r->finalizable = finalizable;
if(gc_root_list != NULL) gc_root_list->prev = r;
@@ -825,6 +826,18 @@
}
+void *CHICKEN_new_gc_root()
+{
+ return CHICKEN_new_gc_root_2(0);
+}
+
+
+void *CHICKEN_new_finalizable_gc_root()
+{
+ return CHICKEN_new_gc_root_2(1);
+}
+
+
void CHICKEN_delete_gc_root(void *root)
{
C_GC_ROOT *r = (C_GC_ROOT *)root;
@@ -2702,9 +2715,10 @@
for(msp = collectibles; msp < collectibles_top; ++msp)
if(*msp != NULL) mark(*msp);
- /* mark GC roots: */
- for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next)
- mark(&gcrp->value);
+ /* mark normal GC roots: */
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
+ if(!gcrp->finalizable) mark(&gcrp->value);
+ }
/* mark finalizer procedures: */
for(flist = finalizer_list; flist != NULL; flist = flist->next)
@@ -2777,6 +2791,11 @@
++fcount;
}
+ /* mark finalizable GC roots: */
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
+ if(gcrp->finalizable) mark(&gcrp->value);
+ }
+
if(gc_report_flag && fcount > 0)
C_printf(C_text("[GC] %d finalizer value(s) marked\n"), fcount);
}
@@ -2791,6 +2810,11 @@
mark(&flist->item);
}
+
+ /* mark finalizable GC roots: */
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
+ if(gcrp->finalizable) mark(&gcrp->value);
+ }
}
pending_finalizer_count = j;
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
