From c333fa8fb596f5e2acd2b017944d42f62f0fee38 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 2 Dec 2008 19:51:01 +0000
Subject: [PATCH] fix problems with custodian boxes, especially for a box whose
 custodian is shut down via an ancestor custodian

svn: r12680
---
 collects/tests/mzscheme/will.ss    |  9 ++++++++
 src/mzscheme/gc2/blame_the_child.c |  3 ++-
 src/mzscheme/src/schpriv.h         |  1 +
 src/mzscheme/src/thread.c          | 36 +++++++++++++++++++++++++++++-
 4 files changed, 47 insertions(+), 2 deletions(-)

diff --git a/collects/tests/mzscheme/will.ss b/collects/tests/mzscheme/will.ss
index e3ebb4d8be..a047468886 100644
--- a/collects/tests/mzscheme/will.ss
+++ b/collects/tests/mzscheme/will.ss
@@ -116,6 +116,15 @@
                       ((current-memory-use c) . >= . 100000))
           c)))
 
+(let ()
+  (define c1 (make-custodian (current-custodian)))
+  (define b1 (make-custodian-box c1 #t))
+  (define c2 (make-custodian c1))
+  (define b2 (make-custodian-box c2 #t))
+  (test '(#t #t) map custodian-box-value (list b1 b2))
+  (custodian-shutdown-all c1)
+  (test '(#f #f) map custodian-box-value (list b1 b2)))
+
 ;; ----------------------------------------
 
 (report-errs)
diff --git a/src/mzscheme/gc2/blame_the_child.c b/src/mzscheme/gc2/blame_the_child.c
index ca40591282..21fb5c08bf 100644
--- a/src/mzscheme/gc2/blame_the_child.c
+++ b/src/mzscheme/gc2/blame_the_child.c
@@ -264,10 +264,11 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
         SCHEME_CDR(prev) = next;
       else
         cur->cust_boxes = next;
+      --cur->num_cust_boxes;
     }
     pr = next;
   }
-  cur->cust_boxes = NULL;
+  cur->checked_cust_boxes = cur->num_cust_boxes;
 }
 
 int BTC_thread_mark(void *p)
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 7d28bfc77d..9bd90960ec 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -438,6 +438,7 @@ struct Scheme_Custodian {
 #ifdef MZ_PRECISE_GC
   int gc_owner_set;
   Scheme_Object *cust_boxes;
+  int num_cust_boxes, checked_cust_boxes;
 #endif
 };
 
diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c
index adbc13f86d..acef8eda8f 100644
--- a/src/mzscheme/src/thread.c
+++ b/src/mzscheme/src/thread.c
@@ -1467,12 +1467,27 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
       }
     }
 
+#ifdef MZ_PRECISE_GC
+    {
+      Scheme_Object *pr = m->cust_boxes, *wb;
+      Scheme_Custodian_Box *cb;
+      while (pr) {
+        wb = SCHEME_CAR(pr);
+        cb = (Scheme_Custodian_Box *)SCHEME_BOX_VAL(wb);
+        if (cb) cb->v = NULL;
+        pr = SCHEME_CDR(pr);
+      }
+      m->cust_boxes = NULL;
+    }
+#endif
+
     m->count = 0;
     m->alloc = 0;
     m->boxes = NULL;
     m->closers = NULL;
     m->data = NULL;
     m->mrefs = NULL;
+    m->shut_down = 1;
     
     if (SAME_OBJ(m, start))
       break;
@@ -1715,10 +1730,29 @@ static Scheme_Object *make_custodian_box(int argc, Scheme_Object *argv[])
 #ifdef MZ_PRECISE_GC
   /* 3m  */
   {
-    Scheme_Object *wb, *pr;
+    Scheme_Object *wb, *pr, *prev;
     wb = GC_malloc_weak_box(cb, NULL, 0);
     pr = scheme_make_raw_pair(wb, cb->cust->cust_boxes);
     cb->cust->cust_boxes = pr;
+    cb->cust->num_cust_boxes++;
+    
+    /* The GC prunes the list of custodian boxes in accounting mode,
+       but prune here in case accounting is never triggered. */
+    if (cb->cust->num_cust_boxes > 2 * cb->cust->checked_cust_boxes) {
+      prev = pr;
+      pr = SCHEME_CDR(pr);
+      while (pr) {
+        wb = SCHEME_CAR(pr);
+        if (!SCHEME_BOX_VAL(pr)) {
+          SCHEME_CDR(prev) = SCHEME_CDR(pr);
+          --cb->cust->num_cust_boxes;
+        } else {
+          prev = pr;
+        }
+        pr = SCHEME_CDR(pr);
+      } 
+      cb->cust->checked_cust_boxes = cb->cust->num_cust_boxes;
+    }
   }
 #else
   /* CGC */