threads - miscellaneous

From: "Jerry D. Hedden" <jerry@hedden.us>
Message-ID: <20060426112405.fb30e530d17747c2b054d625b8945d88.4331e666e7.wbe@email.secureserver.net>

p4raw-id: //depot/perl@27994

7 files changed, 109 insertions, 86 deletions

diff --git a/ext/threads/Changes b/ext/threads/Changes
index 52b1623890..2ab741e8f5 100755
--- a/ext/threads/Changes
+++ b/ext/threads/Changes
@@ -1,5 +1,24 @@
 Revision history for Perl extension threads.
 
+1.24 Mon Apr 24 10:29:11 EDT 2006
+	- assert() that thread 0 is never destructed
+	- Determinancy in free.t
+
+1.23 Thu Apr 13 16:57:00 EDT 2006
+	- BUG (RE)FIX: Properly free thread's Perl interpreter
+	- It's an error to detach a thread twice
+	- More XS code cleanups
+
+1.22 Fri Apr  7 21:35:06 EDT 2006
+	- Documented maximum stack size error
+
+1.21 Tue Apr  4 13:57:23 EDT 2006
+	- Corrected ->_handle() to return a pointer
+	- Overload !=
+
+1.19 Sat Mar 25 18:46:02 EST 2006
+	- Use 'DEFINE' instead of 'CCFLAGS' in Makefile.PL
+
 1.18 Fri Mar 24 14:21:36 EST 2006
 	- ->equal returns 0 on false for backwards compatibility
 	- Changed UVs to IVs in XS code (except for TID)
@@ -24,7 +43,7 @@ Revision history for Perl extension threads.
 	- Use $ENV{PERL_CORE} in tests
 
 1.11 Fri Mar 17 13:24:35 EST 2006
-	- BUG FIX: Proper freeing thread's Perl interpreter
+	- BUG FIX: Properly free thread's Perl interpreter
 	- Removed BUGS POD item regarding returning objects from threads
 	- Enabled closure return test in t/problems.t
 	- Handle deprecation of :unique in tests
diff --git a/ext/threads/Makefile.PL b/ext/threads/Makefile.PL
index 349cb4bd04..8eb38930b1 100755
--- a/ext/threads/Makefile.PL
+++ b/ext/threads/Makefile.PL
@@ -16,7 +16,7 @@ if (grep { $_ eq 'PERL_CORE=1' } @ARGV) {
                               'NORECURS' => 1);
 } else {
     # CPAN
-    push(@conditional_params, 'CCFLAGS'  => '-DHAS_PPPORT_H');
+    push(@conditional_params, 'DEFINE'   => '-DHAS_PPPORT_H');
 }
 
 
@@ -42,19 +42,4 @@ WriteMakefile(
     @conditional_params
 );
 
-
-# Add additional target(s) to Makefile for use by module maintainer
-sub MY::postamble
-{
-    return <<'_EXTRAS_';
-ppport:
-	@( cd /tmp; perl -e 'use Devel::PPPort; Devel::PPPort::WriteFile("ppport.h");' )
-	@if ! cmp -s ppport.h /tmp/ppport.h; then \
-	    diff ppport.h /tmp/ppport.h ; \
-	    echo; \
-	    perl /tmp/ppport.h; \
-	fi
-_EXTRAS_
-}
-
 # EOF
diff --git a/ext/threads/t/end.t b/ext/threads/t/end.t
index 8f84eedda9..47a483f3bd 100644
--- a/ext/threads/t/end.t
+++ b/ext/threads/t/end.t
@@ -28,6 +28,8 @@ share($test_id);
 sub ok {
     my ($ok, $name) = @_;
 
+    lock($test_id);
+
     # You have to do it this way or VMS will get confused.
     print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
 
diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t
index 52cdf6a299..f1ccbc0136 100644
--- a/ext/threads/t/join.t
+++ b/ext/threads/t/join.t
@@ -15,13 +15,12 @@ BEGIN {
 
 use ExtUtils::testlib;
 
-BEGIN { print "1..14\n" };
+BEGIN { print "1..17\n" };
 use threads;
 use threads::shared;
 
 my $test_id = 1;
 share($test_id);
-use Devel::Peek qw(Dump);
 
 sub ok {
     my ($ok, $name) = @_;
@@ -136,15 +135,22 @@ if ($^O eq 'linux') {
 
 {
     my $t = threads->create(sub {});
-    $t->join;
-    my $x = threads->create(sub {});
-    $x->join;
-    eval {
-      $t->join;
-    };
-    my $ok = 0;
-    $ok++ if($@ =~/Thread already joined/);
-    ok($ok, "Double join works");
+    $t->join();
+    threads->create(sub {})->join();
+    eval { $t->join(); };
+    ok(($@ =~ /Thread already joined/), "Double join works");
+    eval { $t->detach(); };
+    ok(($@ =~ /Cannot detach a joined thread/), "Detach joined thread");
+}
+
+{
+    my $t = threads->create(sub {});
+    $t->detach();
+    threads->create(sub {})->join();
+    eval { $t->detach(); };
+    ok(($@ =~ /Thread already detached/), "Double detach works");
+    eval { $t->join(); };
+    ok(($@ =~ /Cannot join a detached thread/), "Join detached thread");
 }
 
 {
diff --git a/ext/threads/t/libc.t b/ext/threads/t/libc.t
index 51bc5d611c..5af8f001fb 100644
--- a/ext/threads/t/libc.t
+++ b/ext/threads/t/libc.t
@@ -15,24 +15,37 @@ BEGIN {
 
 use ExtUtils::testlib;
 
-BEGIN { $| = 1; print "1..11\n"};
+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..12\n"};
 
 use threads;
 use threads::shared;
+ok(1, 1, 'Loaded');
+
 my $i = 10;
 my $y = 20000;
 my %localtime;
 for(0..$i) {
 	$localtime{$_} = localtime($_);
 };
-my $mutex = 1;
+my $mutex = 2;
 share($mutex);
 sub localtime_r {
-#  print "Waiting for lock\n";
   lock($mutex);
-#  print "foo\n";
   my $retval = localtime(shift());
-#  unlock($mutex);
   return $retval;
 }
 my @threads;
@@ -48,11 +61,7 @@ for(0..$i) {
 		      }	
 		    }
 				 lock($mutex);
-				 if($error) {
-				   print "not ok $mutex # not a safe localtime\n";
-				 } else {
-				   print "ok $mutex\n";
-				 }
+                                 ok($mutex, ! $error, 'localtime safe');
 				 $mutex++;
 		  });	
   push @threads, $thread;
diff --git a/ext/threads/t/problems.t b/ext/threads/t/problems.t
index f5909948f8..1772bea40e 100644
--- a/ext/threads/t/problems.t
+++ b/ext/threads/t/problems.t
@@ -18,7 +18,7 @@ use ExtUtils::testlib;
 BEGIN {
     $| = 1;
     if ($] == 5.008) {
-        print("1..14\n");   ### Number of tests that will be run ###
+        print("1..11\n");   ### Number of tests that will be run ###
     } else {
         print("1..15\n");   ### Number of tests that will be run ###
     }
@@ -42,6 +42,7 @@ my $test : shared = 2;
 
 sub is($$$) {
     my ($got, $want, $desc) = @_;
+    lock($test);
     unless ($got eq $want) {
 	print "# EXPECTED: $want\n";
 	print "# GOT:      $got\n";
@@ -58,7 +59,7 @@ sub is($$$) {
 # on join which led to double the dataspace
 #
 #########################
-
+if ($] != 5.008)
 { 
     sub Foo::DESTROY { 
 	my $self = shift;
@@ -83,15 +84,17 @@ sub is($$$) {
 # with the : unique attribute.
 #
 #########################
-
-if ($] == 5.008 || $] >= 5.008003) {
-    threads->create( sub {1} )->join;
-    my $not = eval { Config::myconfig() } ? '' : 'not ';
-    print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
-} else {
-    print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
+{
+    lock($test);
+    if ($] == 5.008 || $] >= 5.008003) {
+        threads->create( sub {1} )->join;
+        my $not = eval { Config::myconfig() } ? '' : 'not ';
+        print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
+    } else {
+        print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
+    }
+    $test++;
 }
-$test++;
 
 # bugid 24383 - :unique hashes weren't being made readonly on interpreter
 # clone; check that they are.
@@ -101,6 +104,7 @@ our @unique_array : unique;
 our %unique_hash : unique;
 threads->create(
     sub {
+        lock($test);
 	my $TODO = ":unique needs to be re-implemented in a non-broken way";
 	eval { $unique_scalar = 1 };
 	print $@ =~ /read-only/
@@ -124,14 +128,17 @@ threads->create(
 # bugid #24940 :unique should fail on my and sub declarations
 
 for my $decl ('my $x : unique', 'sub foo : unique') {
-    if ($] >= 5.008005) {
-        eval $decl;
-        print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
-                ? '' : 'not ', "ok $test - $decl\n";
-    } else {
-        print("ok $test # Skip $decl\n");
+    {
+        lock($test);
+        if ($] >= 5.008005) {
+            eval $decl;
+            print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
+                    ? '' : 'not ', "ok $test - $decl\n";
+        } else {
+            print("ok $test # Skip $decl\n");
+        }
+        $test++;
     }
-    $test++;
 }
 
 
diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index bcbd908415..72b4bdc8a6 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -100,18 +100,13 @@ S_ithread_clear(pTHX_ ithread* thread)
 {
     PerlInterpreter *interp;
     assert(thread->state & PERL_ITHR_FINISHED &&
-    	    (thread->state & PERL_ITHR_DETACHED ||
-	    thread->state & PERL_ITHR_JOINED));
+           thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
 
     interp = thread->interp;
     if (interp) {
 	dTHXa(interp);
-	ithread* current_thread;
-#ifdef OEMVS
-	void *ptr;
-#endif
+
 	PERL_SET_CONTEXT(interp);
-	current_thread = S_ithread_get(aTHX);
 	S_ithread_set(aTHX_ thread);
 	
 	SvREFCNT_dec(thread->params);
@@ -207,24 +202,17 @@ ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
 int
 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
-    ithread *thread = (ithread *) mg->mg_ptr;
+    ithread *thread = (ithread *)mg->mg_ptr;
+    int cleanup;
+
     MUTEX_LOCK(&thread->mutex);
-    thread->count--;
-    if (thread->count == 0) {
-       if(thread->state & PERL_ITHR_FINISHED &&
-          (thread->state & PERL_ITHR_DETACHED ||
-           thread->state & PERL_ITHR_JOINED))
-       {
-            MUTEX_UNLOCK(&thread->mutex);
-            S_ithread_destruct(aTHX_ thread);
-       }
-       else {
-	    MUTEX_UNLOCK(&thread->mutex);
-       }    
-    }
-    else {
-	MUTEX_UNLOCK(&thread->mutex);
-    }
+    cleanup = ((--thread->count == 0) &&
+               (thread->state & PERL_ITHR_FINISHED) &&
+               (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)));
+    MUTEX_UNLOCK(&thread->mutex);
+
+    if (cleanup)
+        S_ithread_destruct(aTHX_ thread);
     return 0;
 }
 
@@ -262,6 +250,8 @@ static void*
 S_ithread_run(void * arg) {
 #endif
 	ithread* thread = (ithread*) arg;
+        int cleanup;
+
 	dTHXa(thread->interp);
 	PERL_SET_CONTEXT(thread->interp);
 	S_ithread_set(aTHX_ thread);
@@ -303,19 +293,24 @@ S_ithread_run(void * arg) {
 		}
 		FREETMPS;
 		LEAVE;
-		SvREFCNT_dec(thread->init_function);
+
+                /* Release function ref */
+                SvREFCNT_dec(thread->init_function);
+                thread->init_function = Nullsv;
 	}
 
 	PerlIO_flush((PerlIO*)NULL);
+
 	MUTEX_LOCK(&thread->mutex);
+        /* Mark as finished */
 	thread->state |= PERL_ITHR_FINISHED;
+        /* Cleanup if detached */
+        cleanup = (thread->state & PERL_ITHR_DETACHED);
+        MUTEX_UNLOCK(&thread->mutex);
+
+        if (cleanup)
+            S_ithread_destruct(aTHX_ thread);
 
-	if (thread->state & PERL_ITHR_DETACHED) {
-		MUTEX_UNLOCK(&thread->mutex);
-		S_ithread_destruct(aTHX_ thread);
-	} else {
-		MUTEX_UNLOCK(&thread->mutex);
-	}
 	MUTEX_LOCK(&create_destruct_mutex);
 	active_threads--;
 	MUTEX_UNLOCK(&create_destruct_mutex);