From: Jerry D. Hedden <jdhedden@cpan.org>
Date: Thu, 20 Apr 2006 13:53:20 +0000 (-0700)
Subject: Rework threads destruct call
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=385d56e4959776c85d4b164b2a72253a12f817be;p=p5sagit%2Fp5-mst-13.2.git

Rework threads destruct call
From: "Jerry D. Hedden" <jerry@hedden.us>
Message-ID: <20060420135320.fb30e530d17747c2b054d625b8945d88.ef565d84db.wbe@email.secureserver.net>

p4raw-id: //depot/perl@27933
---

diff --git a/MANIFEST b/MANIFEST
index 0e71a39..f8ab411 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1129,6 +1129,8 @@ ext/threads/shared/t/wait.t	Test cond_wait and cond_timedwait
 ext/threads/shared/typemap	thread::shared types
 ext/threads/t/basic.t		ithreads
 ext/threads/t/end.t		Test end functions
+ext/threads/t/free.t		Test ithread destruction
+ext/threads/t/free2.t		More ithread destruction tests
 ext/threads/threads.pm		ithreads
 ext/threads/threads.xs		ithreads
 ext/threads/t/join.t		Testing the join function
diff --git a/ext/threads/t/free.t b/ext/threads/t/free.t
new file mode 100644
index 0000000..bf9e3a7
--- /dev/null
+++ b/ext/threads/t/free.t
@@ -0,0 +1,184 @@
+use strict;
+use warnings;
+
+BEGIN {
+    if ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
+    }
+}
+
+use ExtUtils::testlib;
+
+sub ok {
+    my ($id, $ok, $name) = @_;
+
+    # You have to do it this way or VMS will get confused.
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
+
+    return ($ok);
+}
+
+BEGIN {
+    $| = 1;
+    print("1..29\n");   ### Number of tests that will be run ###
+};
+
+use threads;
+use threads::shared;
+ok(1, 1, 'Loaded');
+
+### Start of Testing ###
+
+# Tests freeing the Perl interperter for each thread
+# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details
+
+my $COUNT;
+share($COUNT);
+my $TEST = 2;
+share($TEST);
+
+sub threading_1 {
+    my $tid = threads->tid();
+    ok($TEST++, $tid, "Thread $tid started");
+
+    if ($tid < 5) {
+        sleep(1);
+        threads->create('threading_1')->detach();
+    }
+
+    threads->yield();
+
+    if ($tid == 1) {
+        sleep(2);
+    } elsif ($tid == 2) {
+        sleep(6);
+    } elsif ($tid == 3) {
+        sleep(3);
+    } elsif ($tid == 4) {
+        sleep(1);
+    } else {
+        sleep(2);
+    }
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+    ok($TEST++, $tid, "Thread $tid done");
+}
+
+{
+    $COUNT = 0;
+    threads->create('threading_1')->detach();
+    {
+        lock($COUNT);
+        while ($COUNT < 3) {
+            cond_wait($COUNT);
+        }
+    }
+}
+{
+    {
+        lock($COUNT);
+        while ($COUNT < 5) {
+            cond_wait($COUNT);
+        }
+    }
+    threads->yield();
+    sleep(1);
+}
+ok($TEST++, $COUNT == 5, "Done - $COUNT threads");
+
+
+sub threading_2 {
+    my $tid = threads->tid();
+    ok($TEST++, $tid, "Thread $tid started");
+
+    if ($tid < 10) {
+        threads->create('threading_2')->detach();
+    }
+
+    threads->yield();
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+
+    ok($TEST++, $tid, "Thread $tid done");
+}
+
+{
+    $COUNT = 0;
+    threads->create('threading_2')->detach();
+    {
+        lock($COUNT);
+        while ($COUNT < 3) {
+            cond_wait($COUNT);
+        }
+    }
+    threads->yield();
+    sleep(1);
+}
+ok($TEST++, $COUNT == 5, "Done - $COUNT threads");
+
+
+{
+    threads->create(sub { })->join();
+}
+ok($TEST++, 1, 'Join');
+
+
+sub threading_3 {
+    my $tid = threads->tid();
+    ok($TEST++, $tid, "Thread $tid started");
+
+    {
+        threads->create(sub {
+            my $tid = threads->tid();
+            ok($TEST++, $tid, "Thread $tid started");
+
+            threads->yield();
+            sleep(1);
+
+            lock($COUNT);
+            $COUNT++;
+            cond_signal($COUNT);
+
+            ok($TEST++, $tid, "Thread $tid done");
+        })->join();
+    }
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+
+    ok($TEST++, $tid, "Thread $tid done");
+}
+
+{
+    $COUNT = 0;
+    threads->create(sub {
+        threads->create('threading_3')->detach();
+        {
+            lock($COUNT);
+            while ($COUNT < 2) {
+                cond_wait($COUNT);
+            }
+        }
+    })->join();
+    threads->yield();
+    sleep(1);
+}
+ok($TEST++, $COUNT == 2, "Done - $COUNT threads");
+
+# EOF
diff --git a/ext/threads/t/free2.t b/ext/threads/t/free2.t
new file mode 100644
index 0000000..d6af217
--- /dev/null
+++ b/ext/threads/t/free2.t
@@ -0,0 +1,287 @@
+use strict;
+use warnings;
+
+BEGIN {
+    if ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
+    }
+}
+
+use ExtUtils::testlib;
+
+use threads;
+use threads::shared;
+
+BEGIN {
+    if (($] < 5.008002) && ($threads::shared::VERSION < 0.92)) {
+        print("1..0 # Skip: Needs threads::shared 0.92 or later\n");
+        exit(0);
+    }
+
+    $| = 1;
+    print("1..74\n");   ### Number of tests that will be run ###
+};
+
+my $TEST = 1;
+share($TEST);
+
+ok(1, 'Loaded');
+
+sub ok {
+    my ($ok, $name) = @_;
+
+    lock($TEST);
+    my $id = $TEST++;
+
+    # You have to do it this way or VMS will get confused.
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
+
+    return ($ok);
+}
+
+
+### Start of Testing ###
+
+# Tests freeing the Perl interperter for each thread
+# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details
+
+my $COUNT;
+share($COUNT);
+my %READY;
+share(%READY);
+
+# Init a thread
+sub th_start {
+    my $tid = threads->tid();
+    ok($tid, "Thread $tid started");
+
+    # Create next thread
+    if ($tid < 17) {
+        my $next = 'th' . ($tid+1);
+        my $th = threads->create($next);
+    } else {
+        # Last thread signals first
+        th_signal(1);
+    }
+    th_wait();
+}
+
+# Thread terminating
+sub th_done {
+    my $tid = threads->tid();
+
+    lock($COUNT);
+    $COUNT++;
+    cond_signal($COUNT);
+
+    ok($tid, "Thread $tid done");
+}
+
+# Wait until signalled by another thread
+sub th_wait
+{
+    my $tid = threads->tid();
+
+    lock(%READY);
+    while (! exists($READY{$tid})) {
+        cond_wait(%READY);
+    }
+    my $other = delete($READY{$tid});
+    ok($tid, "Thread $tid received signal from $other");
+}
+
+# Signal another thread to go
+sub th_signal
+{
+    my $other = shift;
+    my $tid = threads->tid();
+
+    ok($tid, "Thread $tid signalling $other");
+
+    lock(%READY);
+    $READY{$other} = $tid;
+    cond_broadcast(%READY);
+}
+
+#####
+
+sub th1 {
+    th_start();
+
+    threads->detach();
+
+    th_signal(2);
+    th_signal(6);
+    th_signal(10);
+    th_signal(14);
+
+    th_done();
+}
+
+sub th2 {
+    th_start();
+    threads->detach();
+    th_signal(4);
+    th_done();
+}
+
+sub th6 {
+    th_start();
+    threads->detach();
+    th_signal(8);
+    th_done();
+}
+
+sub th10 {
+    th_start();
+    threads->detach();
+    th_signal(12);
+    th_done();
+}
+
+sub th14 {
+    th_start();
+    threads->detach();
+    th_signal(16);
+    th_done();
+}
+
+sub th4 {
+    th_start();
+    threads->detach();
+    th_signal(3);
+    th_done();
+}
+
+sub th8 {
+    th_start();
+    threads->detach();
+    th_signal(7);
+    th_done();
+}
+
+sub th12 {
+    th_start();
+    threads->detach();
+    th_signal(13);
+    th_done();
+}
+
+sub th16 {
+    th_start();
+    threads->detach();
+    th_signal(17);
+    th_done();
+}
+
+sub th3 {
+    my $other = 5;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    threads->yield();
+    sleep(1);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th5 {
+    th_start();
+    th_done();
+    return (threads->tid());
+}
+
+
+sub th7 {
+    my $other = 9;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th9 {
+    th_start();
+    threads->yield();
+    sleep(1);
+    th_done();
+    return (threads->tid());
+}
+
+
+sub th13 {
+    my $other = 11;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    threads->yield();
+    sleep(1);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th11 {
+    th_start();
+    th_done();
+    return (threads->tid());
+}
+
+
+sub th17 {
+    my $other = 15;
+
+    th_start();
+    threads->detach();
+    th_signal($other);
+    my $ret = threads->object($other)->join();
+    ok($ret == $other, "Thread $other returned $ret");
+    th_done();
+}
+
+sub th15 {
+    th_start();
+    threads->yield();
+    sleep(1);
+    th_done();
+    return (threads->tid());
+}
+
+
+
+
+
+
+TEST_STARTS_HERE:
+{
+    $COUNT = 0;
+    threads->create('th1');
+    {
+        lock($COUNT);
+        while ($COUNT < 17) {
+            cond_wait($COUNT);
+        }
+    }
+    threads->yield();
+    sleep(1);
+}
+ok($COUNT == 17, "Done - $COUNT threads");
+
+# EOF
diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index c63bd90..640bb31 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -130,45 +130,47 @@ S_ithread_clear(pTHX_ ithread* thread)
  *  free an ithread structure and any attached data if its count == 0
  */
 static void
-S_ithread_destruct (pTHX_ ithread* thread, const char *why)
+S_ithread_destruct (pTHX_ ithread* thread)
 {
+#ifdef WIN32
+        HANDLE handle;
+#endif
+
 	MUTEX_LOCK(&thread->mutex);
-	if (!thread->next) {
-	    MUTEX_UNLOCK(&thread->mutex);
-	    Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
-	}
+
+        /* Thread is still in use */
 	if (thread->count != 0) {
 		MUTEX_UNLOCK(&thread->mutex);
 		return;
 	}
-	MUTEX_LOCK(&create_destruct_mutex);
-	/* Remove from circular list of threads */
-	if (thread->next == thread) {
-	    /* last one should never get here ? */
-	    threads = NULL;
-        }
-	else {
-	    thread->next->prev = thread->prev;
-	    thread->prev->next = thread->next;
-	    if (threads == thread) {
-		threads = thread->next;
-	    }
-	    thread->next = NULL;
-	    thread->prev = NULL;
-	}
 
+	/* Remove from circular list of threads */
+	MUTEX_LOCK(&create_destruct_mutex);
+	thread->next->prev = thread->prev;
+	thread->prev->next = thread->next;
+	thread->next = NULL;
+	thread->prev = NULL;
 	MUTEX_UNLOCK(&create_destruct_mutex);
-	/* Thread is now disowned */
 
+	/* Thread is now disowned */
 	S_ithread_clear(aTHX_ thread);
-        aTHX = PL_curinterp;
+
+#ifdef WIN32
+        handle = thread->handle;
+        thread->handle = NULL;
+#endif
 	MUTEX_UNLOCK(&thread->mutex);
 	MUTEX_DESTROY(&thread->mutex);
+
 #ifdef WIN32
-	if (thread->handle)
-	    CloseHandle(thread->handle);
-	thread->handle = 0;
+        if (handle)
+            CloseHandle(handle);
 #endif
+
+        /* Call PerlMemShared_free() in the context of the "first" interpreter
+         * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
+         */
+        aTHX = PL_curinterp;
         PerlMemShared_free(thread);
 }
 
@@ -203,7 +205,7 @@ S_ithread_detach(pTHX_ ithread *thread)
     if ((thread->state & PERL_ITHR_FINISHED) &&
         (thread->state & PERL_ITHR_DETACHED)) {
 	MUTEX_UNLOCK(&thread->mutex);
-	S_ithread_destruct(aTHX_ thread, "detach");
+	S_ithread_destruct(aTHX_ thread);
     }
     else {
 	MUTEX_UNLOCK(&thread->mutex);
@@ -233,7 +235,7 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
            thread->state & PERL_ITHR_JOINED))
        {
             MUTEX_UNLOCK(&thread->mutex);
-            S_ithread_destruct(aTHX_ thread, "no reference");
+            S_ithread_destruct(aTHX_ thread);
        }
        else {
 	    MUTEX_UNLOCK(&thread->mutex);
@@ -329,7 +331,7 @@ S_ithread_run(void * arg) {
 
 	if (thread->state & PERL_ITHR_DETACHED) {
 		MUTEX_UNLOCK(&thread->mutex);
-		S_ithread_destruct(aTHX_ thread, "detached finish");
+		S_ithread_destruct(aTHX_ thread);
 	} else {
 		MUTEX_UNLOCK(&thread->mutex);
 	}
@@ -407,10 +409,13 @@ S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
 	    my_exit(1);
 	}
 	Zero(thread,1,ithread);
+
+        /* Add to threads list */
 	thread->next = threads;
 	thread->prev = threads->prev;
 	threads->prev = thread;
 	thread->prev->next = thread;
+
 	/* Set count to 1 immediately in case thread exits before
 	 * we return to caller !
 	 */
@@ -546,7 +551,7 @@ S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
 	    ) {
 	  MUTEX_UNLOCK(&create_destruct_mutex);
 	  sv_2mortal(params);
-	  S_ithread_destruct(aTHX_ thread, "create failed");
+	  S_ithread_destruct(aTHX_ thread);
 #ifndef WIN32
 	  if (panic)
 	    Perl_croak(aTHX_ panic);
@@ -909,9 +914,12 @@ BOOT:
 	Zero(thread,1,ithread);
 	PL_perl_destruct_level = 2;
 	MUTEX_INIT(&thread->mutex);
+
+        /* Head of the threads list */
 	threads = thread;
 	thread->next = thread;
         thread->prev = thread;
+
 	thread->interp = aTHX;
 	thread->count  = 1;  /* Immortal. */
 	thread->tid = tid_counter++;