From f332afc3dd691de3ef81299d0b968a281c02dad0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 20 Dec 2009 15:39:55 +0000
Subject: [PATCH] fix leak created by transitive thread-resume

svn: r17370
---
 collects/tests/mzscheme/thread.ss | 60 +++++++++++++++++++++++++++++++
 src/mzscheme/src/thread.c         | 34 +++++++++++++++---
 2 files changed, 89 insertions(+), 5 deletions(-)

diff --git a/collects/tests/mzscheme/thread.ss b/collects/tests/mzscheme/thread.ss
index 7ff1caf2f1..832f33f3d3 100644
--- a/collects/tests/mzscheme/thread.ss
+++ b/collects/tests/mzscheme/thread.ss
@@ -1288,4 +1288,64 @@
 
 ; --------------------
 
+;; Make sure that transitive thread-resume keeps a strong link
+;; when thread is explicitly suspended (instead of just blocked)
+(let ([run
+       (lambda (suspend-first?)
+         (let ([go (make-semaphore)]
+               [done (make-semaphore)])
+           (for ([i (in-range 100)])
+             (let ([t
+                    (thread (lambda ()
+                              (semaphore-wait go)
+                              (semaphore-post done)))])
+               (when suspend-first?
+                 (thread-suspend t))
+               (thread-resume t (current-thread))
+               (thread-suspend t)))
+           (let ([me (current-thread)])
+             (thread (lambda ()
+                       (sync (system-idle-evt))
+                       (collect-garbage)
+                       (collect-garbage)
+                       (thread-resume me)))
+             (thread-suspend me))
+           (for ([i (in-range 100)])
+             (semaphore-post go))
+           (for ([i (in-range 100)])
+             (semaphore-wait done))
+           (test 'resume-worked values 'resume-worked)))])
+  (run #f)
+  (run #t))
+
+;; Make sure that transitive thread-resume keeps a weak link
+;; when thread is blocked:
+(let ([run
+       (lambda (suspend-first?)
+         (let ([done (make-semaphore)])
+           (let ([boxes
+                  (for/list ([i (in-range 100)])
+                    (let ([t
+                           (thread (lambda ()
+                                     (semaphore-wait (make-semaphore))
+                                     (semaphore-post done)))])
+                      (when suspend-first?
+                        (sync (system-idle-evt))
+                        (thread-suspend t))
+                      (thread-resume t (current-thread))
+                      (make-weak-box t)))])
+             (sync (system-idle-evt))
+             (collect-garbage)
+             (collect-garbage)
+             (test #t > (apply + (map (lambda (b) (if (weak-box-value b)
+                                                      0
+                                                      1))
+                                      boxes))
+                   50)
+             (test #f sync/timeout 0.0 done))))])
+  (run #f)
+  (run #t))
+
+; --------------------
+
 (report-errs)
diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c
index 33341d05b8..6b82fdfd9b 100644
--- a/src/mzscheme/src/thread.c
+++ b/src/mzscheme/src/thread.c
@@ -4677,6 +4677,10 @@ static void suspend_thread(Scheme_Thread *p)
     SCHEME_PTR2_VAL(p->suspended_box) = (Scheme_Object *)p;
     scheme_post_sema_all(SCHEME_PTR1_VAL(p->suspended_box));
   }
+  if (p->running_box && (!(p->running & MZTHREAD_SUSPENDED))) {
+    /* Make transitive-resume link strong, instead of weak: */
+    SCHEME_PTR_VAL(p->running_box) = (Scheme_Object *)p;
+  }
 
   if (SAME_OBJ(p, scheme_main_thread)) {
     /* p is the main thread, which we're not allowed to
@@ -4712,10 +4716,15 @@ static void add_transitive_resume(Scheme_Thread *promote_to, Scheme_Thread *p)
   Scheme_Hash_Table *ht;
 
   if (!p->running_box) {
-    Scheme_Object *b;
+    Scheme_Object *b, *wb;
+    if ((p->running & MZTHREAD_USER_SUSPENDED)
+        && !(p->running & MZTHREAD_SUSPENDED))
+      wb = (Scheme_Object *)p;
+    else
+      wb = scheme_make_weak_box((Scheme_Object *)p);
     b = scheme_alloc_small_object();
     b->type = scheme_thread_dead_type;
-    SCHEME_PTR_VAL(b) = (Scheme_Object *)p;
+    SCHEME_PTR_VAL(b) = (Scheme_Object *)wb;
     p->running_box = b;
   }
   running_box = p->running_box;
@@ -4732,7 +4741,9 @@ static void add_transitive_resume(Scheme_Thread *promote_to, Scheme_Thread *p)
     ht = (Scheme_Hash_Table *)promote_to->transitive_resumes;
     for (i = ht->size; i--; ) {
       if (ht->vals[i]) {
-	if (!SCHEME_PTR_VAL(ht->keys[i])) {
+	if (!SCHEME_PTR_VAL(ht->keys[i])
+            || (SAME_TYPE(SCHEME_TYPE(ht->keys[i]), scheme_weak_box_type)
+                && !SCHEME_WEAK_BOX_VAL(ht->vals[i]))) {
 	  /* This one is dead */
 	  if (!gone)
 	    gone = scheme_make_hash_table(SCHEME_hash_ptr);
@@ -4794,8 +4805,12 @@ static void transitive_resume(Scheme_Object *resumes)
   for (i = ht->size; i--; ) {
     if (ht->vals[i]) {
       a[0] = SCHEME_PTR_VAL(ht->keys[i]);
-      if (a[0])
-	thread_resume(1, a);
+      if (a[0]) {
+        if (SAME_TYPE(SCHEME_TYPE(a[0]), scheme_weak_box_type))
+          a[0] = SCHEME_WEAK_BOX_VAL(a[0]);
+        if (a[0])
+          thread_resume(1, a);
+      }
     }
   }
 }
@@ -4846,6 +4861,8 @@ static void transitive_promote(Scheme_Thread *p, Scheme_Custodian *c)
   for (i = ht->size; i--; ) {
     if (ht->vals[i]) {
       t = SCHEME_PTR_VAL(ht->keys[i]);
+      if (SAME_TYPE(SCHEME_TYPE(t), scheme_weak_box_type))
+        t = SCHEME_WEAK_BOX_VAL(t);
       if (t)
 	promote_thread((Scheme_Thread *)t, c);
     }
@@ -5022,6 +5039,13 @@ static Scheme_Object *thread_resume(int argc, Scheme_Object *argv[])
       SCHEME_PTR2_VAL(p->resumed_box) = (Scheme_Object *)p;
       scheme_post_sema_all(SCHEME_PTR1_VAL(p->resumed_box));
     }
+
+    if (p->running_box && !(p->running & MZTHREAD_SUSPENDED)) {
+      /* Make transitive-resume weak: */
+      Scheme_Object *wb;
+      wb = scheme_make_weak_box((Scheme_Object *)p);
+      SCHEME_PTR_VAL(p->running_box) = wb;
+    }
     
     p->running -= MZTHREAD_USER_SUSPENDED;