From: Jerry D. Hedden Date: Wed, 26 Apr 2006 11:24:05 +0000 (-0700) Subject: threads - miscellaneous X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f2cba68dfbed8d8ba2bc905001d64997095d148a;p=p5sagit%2Fp5-mst-13.2.git threads - miscellaneous From: "Jerry D. Hedden" Message-ID: <20060426112405.fb30e530d17747c2b054d625b8945d88.4331e666e7.wbe@email.secureserver.net> p4raw-id: //depot/perl@27994 --- diff --git a/ext/threads/Changes b/ext/threads/Changes index 52b1623..2ab741e 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 349cb4b..8eb3893 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 8f84eed..47a483f 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 52cdf6a..f1ccbc0 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 51bc5d6..5af8f00 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 f590994..1772bea 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 bcbd908..72b4bdc 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);