From: Jerry D. Hedden Date: Wed, 3 May 2006 12:34:34 +0000 (-0700) Subject: threads - formatting [REVISED] X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fc04eb160a90a82da7112a76ae84e7fb117eae45;p=p5sagit%2Fp5-mst-13.2.git threads - formatting [REVISED] From: "Jerry D. Hedden" Message-ID: <20060503123433.fb30e530d17747c2b054d625b8945d88.d352e5da51.wbe@email.secureserver.net> p4raw-id: //depot/perl@28099 --- diff --git a/ext/threads/README b/ext/threads/README index b469884..568ae07 100755 --- a/ext/threads/README +++ b/ext/threads/README @@ -1,4 +1,4 @@ -threads version 1.18 +threads version 1.24 ==================== This module needs perl 5.8.0 or later compiled with 'useithreads'. diff --git a/ext/threads/t/basic.t b/ext/threads/t/basic.t index 8892bce..1501d77 100755 --- a/ext/threads/t/basic.t +++ b/ext/threads/t/basic.t @@ -7,18 +7,34 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } use ExtUtils::testlib; -BEGIN { $| = 1; print "1..32\n" }; -use threads; +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..32\n"); ### Number of tests that will be run ### +}; + +use threads; if ($threads::VERSION && ! exists($ENV{'PERL_CORE'})) { print(STDERR "# Testing threads $threads::VERSION\n"); @@ -28,102 +44,88 @@ ok(1, 1, 'Loaded'); ### Start of Testing ### - - -sub ok { - my ($id, $ok, $name) = @_; - - # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - - return $ok; -} - +ok(2, 1 == $threads::threads, "Check that threads::threads is true"); sub test1 { - ok(2,'bar' eq $_[0],"Test that argument passing works"); + ok(3,'bar' eq $_[0], "Test that argument passing works"); } -threads->create('test1','bar')->join(); +threads->create('test1', 'bar')->join(); sub test2 { - ok(3,'bar' eq $_[0]->[0]->{foo},"Test that passing arguments as references work"); + ok(4,'bar' eq $_[0]->[0]->{'foo'}, "Test that passing arguments as references work"); } +threads->create(\&test2, [{'foo' => 'bar'}])->join(); -threads->create(\&test2,[{foo => 'bar'}])->join(); - - -#test execuion of normal sub -sub test3 { ok(4,shift() == 1,"Test a normal sub") } -threads->create(\&test3,1)->join(); - - -#check Config -ok(5, 1 == $threads::threads,"Check that threads::threads is true"); - -#test trying to detach thread +sub test3 { + ok(5, shift() == 1, "Test a normal sub"); +} +threads->create(\&test3, 1)->join(); -sub test4 { ok(6,1,"Detach test") } -my $thread1 = threads->create('test4'); +sub test4 { + ok(6, 1, "Detach test"); +} +{ + my $thread1 = threads->create('test4'); + $thread1->detach(); +} -$thread1->detach(); threads->yield; # help out non-preemptive thread implementations sleep 2; -ok(7,1,"Detach test"); +ok(7, 1, "Detach test"); sub test5 { - threads->create('test6')->join(); - ok(9,1,"Nested thread test"); + threads->create('test6')->join(); + ok(9, 1, "Nested thread test"); } sub test6 { - ok(8,1,"Nested thread test"); + ok(8, 1, "Nested thread test"); } threads->create('test5')->join(); + sub test7 { - my $self = threads->self(); - ok(10, $self->tid == 7, "Wanted 7, got ".$self->tid); - ok(11, threads->tid() == 7, "Wanted 7, got ".threads->tid()); + my $self = threads->self(); + ok(10, $self->tid == 7, "Wanted 7, got ".$self->tid); + ok(11, threads->tid() == 7, "Wanted 7, got ".threads->tid()); } - threads->create('test7')->join; sub test8 { - my $self = threads->self(); - ok(12, $self->tid == 8, "Wanted 8, got ".$self->tid); - ok(13, threads->tid() == 8, "Wanted 8, got ".threads->tid()); + my $self = threads->self(); + ok(12, $self->tid == 8, "Wanted 8, got ".$self->tid); + ok(13, threads->tid() == 8, "Wanted 8, got ".threads->tid()); } - threads->create('test8')->join; -#check support for threads->self() in main thread -ok(14, 0 == threads->self->tid(),"Check so that tid for threads work for main thread"); -ok(15, 0 == threads->tid(),"Check so that tid for threads work for main thread"); +ok(14, 0 == threads->self->tid(), "Check so that tid for threads work for main thread"); +ok(15, 0 == threads->tid(), "Check so that tid for threads work for main thread"); { - no warnings; - local *CLONE = sub { ok(16, threads->tid() == 9, "Tid should be correct in the clone")}; - threads->create(sub { ok(17, threads->tid() == 9, "And tid be 9 here too") })->join(); + no warnings; + local *CLONE = sub { + ok(16, threads->tid() == 9, "Tid should be correct in the clone"); + }; + threads->create(sub { + ok(17, threads->tid() == 9, "And tid be 9 here too"); + })->join(); } -{ - - sub Foo::DESTROY { - ok(19, threads->tid() == 10, "In destroy it should be correct too" ) - } +{ + sub Foo::DESTROY { + ok(19, threads->tid() == 10, "In destroy it should be correct too" ) + } my $foo; - threads->create(sub { ok(18, threads->tid() == 10, "And tid be 10 here"); - $foo = bless {}, 'Foo'; - return undef; - })->join(); - + threads->create(sub { + ok(18, threads->tid() == 10, "And tid be 10 here"); + $foo = bless {}, 'Foo'; + return undef; + })->join(); } diff --git a/ext/threads/t/end.t b/ext/threads/t/end.t index 47a483f..32b3f1a 100644 --- a/ext/threads/t/end.t +++ b/ext/threads/t/end.t @@ -1,49 +1,67 @@ use strict; use warnings; -# test that END blocks are run in the thread that created them and -# not in any child threads - BEGIN { if ($ENV{'PERL_CORE'}){ chdir 't'; unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } use ExtUtils::testlib; -BEGIN { print "1..6\n" }; use threads; use threads::shared; -my $test_id = 1; -share($test_id); +BEGIN { + $| = 1; + print("1..6\n"); ### Number of tests that will be run ### +}; + +my $TEST = 1; +share($TEST); + +ok(1, 'Loaded'); sub ok { my ($ok, $name) = @_; - lock($test_id); + lock($TEST); + my $id = $TEST++; # 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"; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - $test_id++; - return $ok; + return ($ok); } -ok(1,'Loaded'); -END { ok(1,"End block run once") } -threads->create(sub { eval "END { ok(1,'') }"})->join(); -threads->create(sub { eval "END { ok(1,'') }"})->join(); -threads->create(\&thread)->join(); + + +### Start of Testing ### + +# Test that END blocks are run in the thread that created them, +# and not in any child threads. + +END { + ok(1, 'Main END block') +} + +threads->create(sub { eval "END { ok(1, '1st thread END block') }"})->join(); +threads->create(sub { eval "END { ok(1, '2nd thread END block') }"})->join(); sub thread { - eval "END { ok(1,'') }"; - threads->create(sub { eval "END { ok(1,'') }"})->join(); + eval "END { ok(1, '4th thread END block') }"; + threads->create(sub { eval "END { ok(1, '5th thread END block') }"})->join(); } +threads->create(\&thread)->join(); + +# EOF diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t index f1ccbc0..498e5f1 100644 --- a/ext/threads/t/join.t +++ b/ext/threads/t/join.t @@ -7,40 +7,50 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } use ExtUtils::testlib; -BEGIN { print "1..17\n" }; use threads; use threads::shared; -my $test_id = 1; -share($test_id); +BEGIN { + $| = 1; + print("1..17\n"); ### Number of tests that will be run ### +}; + +my $TEST = 1; +share($TEST); + +ok(1, 'Loaded'); sub ok { my ($ok, $name) = @_; - lock $test_id; # make print and increment atomic + lock($TEST); + my $id = $TEST++; # 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"; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - $test_id++; - return $ok; + return ($ok); } sub skip { - ok(1, "# Skipped: @_"); + ok(1, '# Skipped: ' . $_[0]); } -ok(1,""); +### Start of Testing ### { my $retval = threads->create(sub { return ("hi") })->join(); @@ -61,14 +71,12 @@ ok(1,""); } { my $retval = threads->create( sub { - open(my $fh, "+>threadtest") || die $!; - print $fh "test\n"; - return $fh; + open(my $fh, "+>threadtest") || die $!; + print $fh "test\n"; + return $fh; })->join(); ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval"); print $retval "test2\n"; -# seek($retval,0,0); -# ok(<$retval> eq "test\n"); close($retval); unlink("threadtest"); } @@ -89,48 +97,48 @@ ok(1,""); my %foo; share(%foo); threads->create(sub { - my $foo; - share($foo); - $foo = "thread1"; - return $foo{bar} = \$foo; + my $foo; + share($foo); + $foo = "thread1"; + return $foo{bar} = \$foo; })->join(); ok(1,""); } # We parse ps output so this is OS-dependent. if ($^O eq 'linux') { - # First modify $0 in a subthread. - print "# mainthread: \$0 = $0\n"; - threads->create( sub { - print "# subthread: \$0 = $0\n"; - $0 = "foobar"; - print "# subthread: \$0 = $0\n" } )->join; - print "# mainthread: \$0 = $0\n"; - print "# pid = $$\n"; - if (open PS, "ps -f |") { # Note: must work in (all) systems. - my ($sawpid, $sawexe); - while () { - chomp; - print "# [$_]\n"; - if (/^\S+\s+$$\s/) { - $sawpid++; - if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces. - $sawexe++; + # First modify $0 in a subthread. + #print "# mainthread: \$0 = $0\n"; + threads->create(sub{ #print "# subthread: \$0 = $0\n"; + $0 = "foobar"; + #print "# subthread: \$0 = $0\n" + })->join; + #print "# mainthread: \$0 = $0\n"; + #print "# pid = $$\n"; + if (open PS, "ps -f |") { # Note: must work in (all) systems. + my ($sawpid, $sawexe); + while () { + chomp; + #print "# [$_]\n"; + if (/^\s*\S+\s+$$\s/) { + $sawpid++; + if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces. + $sawexe++; + } + last; + } + } + close PS or die; + if ($sawpid) { + ok($sawpid && $sawexe, 'altering $0 is effective'); + } else { + skip("\$0 check: did not see pid $$ in 'ps -f |'"); } - last; - } - } - close PS or die; - if ($sawpid) { - ok($sawpid && $sawexe, 'altering $0 is effective'); } else { - skip("\$0 check: did not see pid $$ in 'ps -f |'"); + skip("\$0 check: opening 'ps -f |' failed: $!"); } - } else { - skip("\$0 check: opening 'ps -f |' failed: $!"); - } } else { - skip("\$0 check: only on Linux"); + skip("\$0 check: only on Linux"); } { @@ -154,11 +162,12 @@ if ($^O eq 'linux') { } { - # The "use IO::File" is not actually used for anything; its only - # purpose is to incite a lot of calls to newCONSTSUB. See the p5p - # archives for the thread "maint@20974 or before broke mp2 ithreads test". + # The "use IO::File" is not actually used for anything; its only purpose + # is incite a lot of calls to newCONSTSUB. See the p5p archives for + # the thread "maint@20974 or before broke mp2 ithreads test". use IO::File; - # this coredumped between #20930 and #21000 + # This coredumped between #20930 and #21000 $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2; } +# EOF diff --git a/ext/threads/t/libc.t b/ext/threads/t/libc.t index 5af8f00..e7e0c9d 100644 --- a/ext/threads/t/libc.t +++ b/ext/threads/t/libc.t @@ -7,9 +7,9 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } @@ -29,45 +29,55 @@ sub ok { return ($ok); } -BEGIN { $| = 1; print "1..12\n"}; +BEGIN { + $| = 1; + print("1..12\n"); ### Number of tests that will be run ### +}; use threads; use threads::shared; ok(1, 1, 'Loaded'); +### Start of Testing ### + my $i = 10; my $y = 20000; + my %localtime; -for(0..$i) { - $localtime{$_} = localtime($_); +for (0..$i) { + $localtime{$_} = localtime($_); }; + my $mutex = 2; share($mutex); + sub localtime_r { - lock($mutex); - my $retval = localtime(shift()); - return $retval; + lock($mutex); + my $retval = localtime(shift()); + return $retval; } + my @threads; -for(0..$i) { - my $thread = threads->create(sub { - my $arg = $_; - my $localtime = $localtime{$arg}; - my $error = 0; - for(0..$y) { - my $lt = localtime($arg); - if($localtime ne $lt) { - $error++; - } - } - lock($mutex); - ok($mutex, ! $error, 'localtime safe'); - $mutex++; - }); - push @threads, $thread; +for (0..$i) { + my $thread = threads->create(sub { + my $arg = $_; + my $localtime = $localtime{$arg}; + my $error = 0; + for (0..$y) { + my $lt = localtime($arg); + if($localtime ne $lt) { + $error++; + } + } + lock($mutex); + ok($mutex, ! $error, 'localtime safe'); + $mutex++; + }); + push @threads, $thread; } -for(@threads) { - $_->join(); +for (@threads) { + $_->join(); } +# EOF diff --git a/ext/threads/t/list.t b/ext/threads/t/list.t index 4f5f276..28206df 100644 --- a/ext/threads/t/list.t +++ b/ext/threads/t/list.t @@ -7,36 +7,36 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } use ExtUtils::testlib; - - -BEGIN { $| = 1; print "1..15\n" }; -use threads; - - - -print "ok 1\n"; - - -######################### -sub ok { +sub ok { my ($id, $ok, $name) = @_; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + 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; + return ($ok); } +BEGIN { + $| = 1; + print("1..15\n"); ### Number of tests that will be run ### +}; + +use threads; +ok(1, 1, 'Loaded'); + ### Start of Testing ### ok(2, scalar @{[threads->list()]} == 0, 'No threads yet'); diff --git a/ext/threads/t/problems.t b/ext/threads/t/problems.t index 1772bea..747ede7 100644 --- a/ext/threads/t/problems.t +++ b/ext/threads/t/problems.t @@ -7,9 +7,9 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } @@ -34,56 +34,51 @@ no warnings 'deprecated'; # Suppress warnings related to :unique use Hash::Util 'lock_keys'; -# Note that we can't use Test::More here, as we would need to -# call is() from within the DESTROY() function at global destruction time, -# and parts of Test::* may have already been freed by then +my $test :shared = 2; -my $test : shared = 2; - -sub is($$$) { +# Note that we can't use Test::More here, as we would need to call is() +# from within the DESTROY() function at global destruction time, and +# parts of Test::* may have already been freed by then +sub is($$$) +{ my ($got, $want, $desc) = @_; lock($test); - unless ($got eq $want) { - print "# EXPECTED: $want\n"; - print "# GOT: $got\n"; - print "not "; + if ($got ne $want) { + print("# EXPECTED: $want\n"); + print("# GOT: $got\n"); + print("not "); } - print "ok $test - $desc\n"; + print("ok $test - $desc\n"); $test++; } -# -# This tests for too much destruction -# which was caused by cloning stashes -# on join which led to double the dataspace -# -######################### +# This tests for too much destruction which was caused by cloning stashes +# on join which led to double the dataspace under 5.8.0 if ($] != 5.008) -{ - sub Foo::DESTROY { - my $self = shift; - my ($package, $file, $line) = caller; - is(threads->tid(),$self->{tid}, - "In destroy[$self->{tid}] it should be correct too" ) +{ + sub Foo::DESTROY + { + my $self = shift; + my ($package, $file, $line) = caller; + is(threads->tid(), $self->{tid}, "In destroy[$self->{tid}] it should be correct too" ); } - my $foo; - $foo = bless {tid => 0}, 'Foo'; - my $bar = threads->create(sub { - is(threads->tid(),1, "And tid be 1 here"); - $foo->{tid} = 1; - return $foo; + + my $foo = bless {tid => 0}, 'Foo'; + my $bar = threads->create(sub { + is(threads->tid(), 1, "And tid be 1 here"); + $foo->{tid} = 1; + return ($foo); })->join(); $bar->{tid} = 0; } -# + # This tests whether we can call Config::myconfig after threads have been # started (interpreter cloned). 5.8.1 and 5.8.2 contained a bug that would -# disallow that too be done, because an attempt was made to change a variable -# with the : unique attribute. -# -######################### +# disallow that to be done because an attempt was made to change a variable +# with the :unique attribute. + { lock($test); if ($] == 5.008 || $] >= 5.008003) { @@ -96,24 +91,24 @@ if ($] != 5.008) $test++; } + # bugid 24383 - :unique hashes weren't being made readonly on interpreter # clone; check that they are. our $unique_scalar : unique; our @unique_array : unique; our %unique_hash : unique; -threads->create( - sub { +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/ - ? '' : 'not ', "ok $test # TODO $TODO unique_scalar\n"; - $test++; - eval { $unique_array[0] = 1 }; - print $@ =~ /read-only/ - ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n"; - $test++; + my $TODO = ":unique needs to be re-implemented in a non-broken way"; + eval { $unique_scalar = 1 }; + print $@ =~ /read-only/ + ? '' : 'not ', "ok $test # TODO $TODO - unique_scalar\n"; + $test++; + eval { $unique_array[0] = 1 }; + print $@ =~ /read-only/ + ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n"; + $test++; if ($] >= 5.008003 && $^O ne 'MSWin32') { eval { $unique_hash{abc} = 1 }; print $@ =~ /disallowed/ @@ -121,9 +116,8 @@ threads->create( } else { print("ok $test # Skip $TODO - unique_hash\n"); } - $test++; - } -)->join; + $test++; + })->join; # bugid #24940 :unique should fail on my and sub declarations @@ -162,17 +156,17 @@ for my $decl ('my $x : unique', 'sub foo : unique') { # Nothing is checking that total keys gets cloned correctly. my %h = (1,2,3,4); -is (keys %h, 2, "keys correct in parent"); +is(keys(%h), 2, "keys correct in parent"); -my $child = threads->create(sub { return scalar keys %h })->join; -is ($child, 2, "keys correct in child"); +my $child = threads->create(sub { return (scalar(keys(%h))); })->join; +is($child, 2, "keys correct in child"); -lock_keys (%h); -delete $h{1}; +lock_keys(%h); +delete($h{1}); -is (keys %h, 1, "keys correct in parent with restricted hash"); +is(keys(%h), 1, "keys correct in parent with restricted hash"); -$child = threads->create(sub { return scalar keys %h })->join; -is ($child, 1, "keys correct in child with restricted hash"); +$child = threads->create(sub { return (scalar(keys(%h))); })->join; +is($child, 1, "keys correct in child with restricted hash"); -1; +# EOF diff --git a/ext/threads/t/stress_cv.t b/ext/threads/t/stress_cv.t index 95686c1..d82d174 100644 --- a/ext/threads/t/stress_cv.t +++ b/ext/threads/t/stress_cv.t @@ -7,47 +7,51 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } use ExtUtils::testlib; -BEGIN { print "1..64\n" }; -use threads; - - -print "ok 1\n"; - - - - -sub ok { +sub ok { my ($id, $ok, $name) = @_; - + # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - - return $ok; + return ($ok); } +BEGIN { + $| = 1; + print("1..63\n"); ### Number of tests that will be run ### +}; -ok(2,1,""); +use threads; +ok(1, 1, 'Loaded'); +### Start of Testing ### my @threads; -for(3..33) { - ok($_,1,"Multiple thread test"); - push @threads ,threads->create(sub { my $i = shift; for(1..500000) { $i++}},$_); +for (2..32) { + ok($_, 1, "Multiple thread test"); + push(@threads , threads->create(sub { + my $i = shift; + for (1..500000) { $i++ } + }, $_)); } -my $i = 34; -for(@threads) { - $_->join; - ok($i++,1,"Thread joined"); +my $i = 33; +for (@threads) { + $_->join; + ok($i++, 1 ,"Thread joined"); } +# EOF diff --git a/ext/threads/t/stress_re.t b/ext/threads/t/stress_re.t index 5f8d910..09d1fd2 100644 --- a/ext/threads/t/stress_re.t +++ b/ext/threads/t/stress_re.t @@ -7,52 +7,54 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } use ExtUtils::testlib; -BEGIN { print "1..64\n" }; -use threads; - - -print "ok 1\n"; - - - - -sub ok { +sub ok { my ($id, $ok, $name) = @_; - + # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - - return $ok; + return ($ok); } +BEGIN { + $| = 1; + print("1..63\n"); ### Number of tests that will be run ### +}; + +use threads; +ok(1, 1, 'Loaded'); -ok(2,1,""); +### Start of Testing ### sub test9 { - my $s = "abcd" x (1000 + $_[0]); - my $t = ''; - while ($s =~ /(.)/g) { $t .= $1 } - print "not ok $_[0]\n" if $s ne $t; + my $s = "abcd" x (1000 + $_[0]); + my $t = ''; + while ($s =~ /(.)/g) { $t .= $1 } + print "not ok $_[0]\n" if $s ne $t; } my @threads; -for(3..33) { - ok($_,1,"Multiple thread test"); - push @threads ,threads->create('test9',$_); +for (2..32) { + ok($_, 1, "Multiple thread test"); + push(@threads, threads->create('test9',$_)); } -my $i = 34; -for(@threads) { - $_->join; - ok($i++,1,"Thread joined"); +my $i = 33; +for (@threads) { + $_->join; + ok($i++, 1, "Thread joined"); } +# EOF diff --git a/ext/threads/t/stress_string.t b/ext/threads/t/stress_string.t index 4055b66..2a744ea 100644 --- a/ext/threads/t/stress_string.t +++ b/ext/threads/t/stress_string.t @@ -7,50 +7,52 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } use ExtUtils::testlib; -BEGIN { print "1..64\n" }; -use threads; - - -print "ok 1\n"; - - - - -sub ok { +sub ok { my ($id, $ok, $name) = @_; - + # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - - return $ok; + return ($ok); } +BEGIN { + $| = 1; + print("1..63\n"); ### Number of tests that will be run ### +}; + +use threads; +ok(1, 1, 'Loaded'); -ok(2,1,""); +### Start of Testing ### sub test9 { - my $i = shift; - for(1..500000) { $i++}; + my $i = shift; + for (1..500000) { $i++ }; } my @threads; -for(3..33) { - ok($_,1,"Multiple thread test"); - push @threads ,threads->create('test9',$_); +for (2..32) { + ok($_, 1, "Multiple thread test"); + push(@threads, threads->create('test9', $_)); } -my $i = 34; -for(@threads) { - $_->join; - ok($i++,1,"Thread joined"); +my $i = 33; +for (@threads) { + $_->join; + ok($i++, 1, "Thread joined"); } +# EOF diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t index 15533a9..63ad1ac 100644 --- a/ext/threads/t/thread.t +++ b/ext/threads/t/thread.t @@ -7,9 +7,9 @@ BEGIN { unshift @INC, '../lib'; } use Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl"); @@ -17,11 +17,16 @@ BEGIN { use ExtUtils::testlib; -BEGIN { $| = 1; print "1..31\n" }; +BEGIN { + $| = 1; + print("1..31\n"); ### Number of tests that will be run ### +}; + use threads; use threads::shared; +print("ok 1 - Loaded\n"); -print "ok 1\n"; +### Start of Testing ### sub content { print shift; @@ -35,9 +40,9 @@ sub content { my $lock : shared; my $t; { - lock($lock); - $t = threads->create(sub { lock($lock); print "ok 5\n"}); - print "ok 4\n"; + lock($lock); + $t = threads->create(sub { lock($lock); print "ok 5\n"}); + print "ok 4\n"; } $t->join(); } @@ -47,8 +52,8 @@ sub dorecurse { my $ret; print $val; if(@_) { - $ret = threads->create(\&dorecurse, @_); - $ret->join; + $ret = threads->create(\&dorecurse, @_); + $ret->join; } } { @@ -67,14 +72,14 @@ sub dorecurse { { my $lock : shared; sub islocked { - lock($lock); - my $val = shift; - my $ret; - print $val; - if (@_) { - $ret = threads->create(\&islocked, shift); - } - return $ret; + lock($lock); + my $val = shift; + my $ret; + print $val; + if (@_) { + $ret = threads->create(\&islocked, shift); + } + return $ret; } my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n"); $t->join->join; @@ -147,7 +152,7 @@ package main; } { # there is a little chance this test case will falsly fail - # since it tests rand + # since it tests rand my %rand : shared; rand(10); threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25; @@ -222,56 +227,56 @@ if ($] >= 5.008007) { package main; { - my @objs; - for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) { - push @objs, bless [], $class; - } - - sub f { - my $depth = shift; - my $cloned = ""; # XXX due to recursion, doesn't get initialized - $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs; - is($cloned, ($depth ? '00010001111' : '11111111111'), - "objs clone skip at depth $depth"); - threads->create( \&f, $depth+1)->join if $depth < 2; - @objs = (); - } - f(0); + my @objs; + for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) { + push @objs, bless [], $class; + } + + sub f { + my $depth = shift; + my $cloned = ""; # XXX due to recursion, doesn't get initialized + $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs; + is($cloned, ($depth ? '00010001111' : '11111111111'), + "objs clone skip at depth $depth"); + threads->create( \&f, $depth+1)->join if $depth < 2; + @objs = (); + } + f(0); } curr_test(curr_test()+2); ok(eq_hash(\%c, - { - qw( - A-A 2 - A1-A1 2 - A1-A2 2 - B-B 2 - B1-B1 2 - B1-B2 2 - C-C 2 - C1-C1 2 - C1-C2 2 - ) - }), - "counts of calls to CLONE_SKIP"); + { + qw( + A-A 2 + A1-A1 2 + A1-A2 2 + B-B 2 + B1-B1 2 + B1-B2 2 + C-C 2 + C1-C1 2 + C1-C2 2 + ) + }), + "counts of calls to CLONE_SKIP"); ok(eq_hash(\%d, - { - qw( - A-A 1 - A1-A1 1 - A1-A2 1 - B-B 3 - B1-B1 1 - B1-B2 1 - C-C 1 - C1-C1 3 - C1-C2 3 - D-D 3 - D-D1 3 - ) - }), - "counts of calls to DESTROY"); + { + qw( + A-A 1 + A1-A1 1 + A1-A2 1 + B-B 3 + B1-B1 1 + B1-B2 1 + C-C 1 + C1-C1 3 + C1-C2 3 + D-D 3 + D-D1 3 + ) + }), + "counts of calls to DESTROY"); } else { print("ok 27 # Skip objs clone skip at depth 0\n"); diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index e217dde..fc62b90 100755 --- a/ext/threads/threads.pm +++ b/ext/threads/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.24_01'; +our $VERSION = '1.24_02'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -30,6 +30,7 @@ _MSG_ } } + # Load the XS code require XSLoader; XSLoader::load('threads', $XS_VERSION); @@ -136,26 +137,25 @@ This document describes threads version 1.24 =head1 DESCRIPTION -Perl 5.6 introduced something called interpreter threads. Interpreter -threads are different from "5005threads" (the thread model of Perl -5.005) by creating a new perl interpreter per thread and not sharing -any data or state between threads by default. +Perl 5.6 introduced something called interpreter threads. Interpreter threads +are different from I<5005threads> (the thread model of Perl 5.005) by creating +a new Perl interpreter per thread, and not sharing any data or state between +threads by default. -Prior to perl 5.8 this has only been available to people embedding -perl and for emulating fork() on windows. +Prior to Perl 5.8, this has only been available to people embedding Perl, and +for emulating fork() on Windows. -The threads API is loosely based on the old Thread.pm API. It is very -important to note that variables are not shared between threads, all -variables are per default thread local. To use shared variables one -must use threads::shared. +The I API is loosely based on the old Thread.pm API. It is very +important to note that variables are not shared between threads, all variables +are by default thread local. To use shared variables one must use +L. -It is also important to note that you must enable threads by doing -C as early as possible in the script itself and that it -is not possible to enable threading inside an C, C, -C, or C. In particular, if you are intending to share -variables with threads::shared, you must C before you -C and C will emit a warning if you do -it the other way around. +It is also important to note that you must enable threads by doing C as early as possible in the script itself, and that it is not +possible to enable threading inside an C, C, C, or +C. In particular, if you are intending to share variables with +L, you must C before you C. +(C will emit a warning if you do it the other way around.) =over @@ -320,10 +320,10 @@ Class method that allows a thread to obtain its own I. =item A thread exited while # other threads were still running -A thread (not necessarily the main thread) exited while there were -still other threads running. Usually it's a good idea to first collect -the return values of the created threads by joining them, and only then -exit from the main thread. +A thread (not necessarily the main thread) exited while there were still other +threads running. Usually, it's a good idea to first collect the return values +of the created threads by joining them, and only then exit from the main +thread. =back @@ -354,16 +354,15 @@ there are still existing I threads. =item Creating threads inside BEGIN blocks -Creating threads inside BEGIN blocks (or during the compilation phase -in general) does not work. (In Windows, trying to use fork() inside -BEGIN blocks is an equally losing proposition, since it has been -implemented in very much the same way as threads.) +Creating threads inside BEGIN blocks (or during the compilation phase in +general) does not work. (In Windows, trying to use fork() inside BEGIN blocks +is an equally losing proposition, since it has been implemented in very much +the same way as threads.) =item PERL_OLD_SIGNALS are not threadsafe, will not be. -If your Perl has been built with PERL_OLD_SIGNALS (one has -to explicitly add that symbol to ccflags, see C), -signal handling is not threadsafe. +If your Perl has been built with PERL_OLD_SIGNALS (one has to explicitly add +that symbol to I, see C), signal handling is not threadsafe. =item Returning closures from threads diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 72b4bdc..477bc21 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -11,53 +11,51 @@ #ifdef USE_ITHREADS - #ifdef WIN32 -#include -#include +# include +# include #else -#ifdef OS2 +# ifdef OS2 typedef perl_os_thread pthread_t; -#else -#include -#endif -#include -#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) -#ifdef OLD_PTHREADS_API -#define PERL_THREAD_DETACH(t) pthread_detach(&(t)) -#else -#define PERL_THREAD_DETACH(t) pthread_detach((t)) -#endif /* OLD_PTHREADS_API */ +# else +# include +# endif +# include +# define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) +# ifdef OLD_PTHREADS_API +# define PERL_THREAD_DETACH(t) pthread_detach(&(t)) +# else +# define PERL_THREAD_DETACH(t) pthread_detach((t)) +# endif #endif - - - /* Values for 'state' member */ -#define PERL_ITHR_JOINABLE 0 -#define PERL_ITHR_DETACHED 1 -#define PERL_ITHR_JOINED 2 -#define PERL_ITHR_FINISHED 4 - -typedef struct ithread_s { - struct ithread_s *next; /* Next thread in the list */ - struct ithread_s *prev; /* Prev thread in the list */ - PerlInterpreter *interp; /* The threads interpreter */ - UV tid; /* Threads module's thread id */ - perl_mutex mutex; /* Mutex for updating things in this struct */ +#define PERL_ITHR_JOINABLE 0 +#define PERL_ITHR_DETACHED 1 +#define PERL_ITHR_JOINED 2 +#define PERL_ITHR_FINISHED 4 + +typedef struct _ithread { + struct _ithread *next; /* Next thread in the list */ + struct _ithread *prev; /* Prev thread in the list */ + PerlInterpreter *interp; /* The threads interpreter */ + UV tid; /* Threads module's thread id */ + perl_mutex mutex; /* Mutex for updating things in this struct */ int count; /* How many SVs have a reference to us */ - int state; /* Are we detached ? */ - int gimme; /* Context of create */ - SV* init_function; /* Code to run */ - SV* params; /* Args to pass function */ + int state; /* Detached, joined, finished, etc. */ + int gimme; /* Context of create */ + SV *init_function; /* Code to run */ + SV *params; /* Args to pass function */ #ifdef WIN32 - DWORD thr; /* OS's idea if thread id */ - HANDLE handle; /* OS's waitable handle */ + DWORD thr; /* OS's idea if thread id */ + HANDLE handle; /* OS's waitable handle */ #else - pthread_t thr; /* OS's handle for the thread */ + pthread_t thr; /* OS's handle for the thread */ #endif } ithread; + +/* Used by Perl interpreter for thread context switching */ #define MY_CXT_KEY "threads::_guts" XS_VERSION typedef struct { @@ -67,124 +65,128 @@ typedef struct { START_MY_CXT +/* Linked list of all threads */ static ithread *threads; -static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/ +/* Protects the creation and destruction of threads*/ +static perl_mutex create_destruct_mutex; static UV tid_counter = 0; static IV active_threads = 0; +/* Used by Perl interpreter for thread context switching */ static void -S_ithread_set (pTHX_ ithread* thread) +S_ithread_set(pTHX_ ithread *thread) { dMY_CXT; MY_CXT.thread = thread; } -static ithread* -S_ithread_get (pTHX) { +static ithread * +S_ithread_get(pTHX) +{ dMY_CXT; - return MY_CXT.thread; + return (MY_CXT.thread); } -/* free any data (such as the perl interpreter) attached to an - * ithread structure. This is a bit like undef on SVs, where the SV - * isn't freed, but the PVX is. - * Must be called with thread->mutex already held +/* Free any data (such as the Perl interpreter) attached to an ithread + * structure. This is a bit like undef on SVs, where the SV isn't freed, + * but the PVX is. Must be called with thread->mutex already held. */ - static void -S_ithread_clear(pTHX_ ithread* thread) +S_ithread_clear(pTHX_ ithread *thread) { PerlInterpreter *interp; + assert(thread->state & PERL_ITHR_FINISHED && thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)); interp = thread->interp; if (interp) { - dTHXa(interp); + dTHXa(interp); + + PERL_SET_CONTEXT(interp); + S_ithread_set(aTHX_ thread); - PERL_SET_CONTEXT(interp); - S_ithread_set(aTHX_ thread); - - SvREFCNT_dec(thread->params); + SvREFCNT_dec(thread->params); + thread->params = Nullsv; - thread->params = Nullsv; - perl_destruct(interp); - thread->interp = NULL; + perl_destruct(interp); + thread->interp = NULL; } if (interp) - perl_free(interp); + perl_free(interp); + PERL_SET_CONTEXT(aTHX); } -/* - * free an ithread structure and any attached data if its count == 0 - */ +/* Free an ithread structure and any attached data if its count == 0 */ static void -S_ithread_destruct (pTHX_ ithread* thread) +S_ithread_destruct(pTHX_ ithread *thread) { #ifdef WIN32 - HANDLE handle; + HANDLE handle; #endif - MUTEX_LOCK(&thread->mutex); - - /* Thread is still in use */ - if (thread->count != 0) { - MUTEX_UNLOCK(&thread->mutex); - return; - } + MUTEX_LOCK(&thread->mutex); - MUTEX_LOCK(&create_destruct_mutex); - /* Main thread (0) is immortal and should never get here */ - assert(thread->tid != 0); + /* Thread is still in use */ + if (thread->count != 0) { + MUTEX_UNLOCK(&thread->mutex); + return; + } - /* Remove from circular list of threads */ - thread->next->prev = thread->prev; - thread->prev->next = thread->next; - thread->next = NULL; - thread->prev = NULL; - MUTEX_UNLOCK(&create_destruct_mutex); + MUTEX_LOCK(&create_destruct_mutex); + /* Main thread (0) is immortal and should never get here */ + assert(thread->tid != 0); + + /* Remove from circular list of threads */ + 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 */ - S_ithread_clear(aTHX_ thread); + /* Thread is now disowned */ + S_ithread_clear(aTHX_ thread); #ifdef WIN32 - handle = thread->handle; - thread->handle = NULL; + handle = thread->handle; + thread->handle = NULL; #endif - MUTEX_UNLOCK(&thread->mutex); - MUTEX_DESTROY(&thread->mutex); + MUTEX_UNLOCK(&thread->mutex); + MUTEX_DESTROY(&thread->mutex); #ifdef WIN32 - if (handle) - CloseHandle(handle); + 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); + /* 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); } + +/* Called on exit */ int Perl_ithread_hook(pTHX) { int veto_cleanup = 0; MUTEX_LOCK(&create_destruct_mutex); - if (aTHX == PL_curinterp && active_threads != 1) { - if (ckWARN_d(WARN_THREADS)) - Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", - active_threads); - veto_cleanup = 1; + if ((aTHX == PL_curinterp) && (active_threads != 1)) { + if (ckWARN_d(WARN_THREADS)) { + Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", active_threads); + } + veto_cleanup = 1; } MUTEX_UNLOCK(&create_destruct_mutex); - return veto_cleanup; + return (veto_cleanup); } @@ -193,10 +195,10 @@ Perl_ithread_hook(pTHX) int ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) { - ithread *thread = (ithread *) mg->mg_ptr; + ithread *thread = (ithread *)mg->mg_ptr; SvIV_set(sv, PTR2IV(thread)); SvIOK_on(sv); - return 0; + return (0); } int @@ -213,318 +215,336 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) if (cleanup) S_ithread_destruct(aTHX_ thread); - return 0; + return (0); } int ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { - ithread *thread = (ithread *) mg->mg_ptr; + ithread *thread = (ithread *)mg->mg_ptr; MUTEX_LOCK(&thread->mutex); thread->count++; MUTEX_UNLOCK(&thread->mutex); - return 0; + return (0); } MGVTBL ithread_vtbl = { - ithread_mg_get, /* get */ - 0, /* set */ - 0, /* len */ - 0, /* clear */ - ithread_mg_free, /* free */ - 0, /* copy */ - ithread_mg_dup /* dup */ + ithread_mg_get, /* get */ + 0, /* set */ + 0, /* len */ + 0, /* clear */ + ithread_mg_free, /* free */ + 0, /* copy */ + ithread_mg_dup /* dup */ }; -/* - * Starts executing the thread. Needs to clean up memory a tad better. - * Passed as the C level function to run in the new thread +/* Starts executing the thread. + * Passed as the C level function to run in the new thread. */ - #ifdef WIN32 static THREAD_RET_TYPE -S_ithread_run(LPVOID arg) { +S_ithread_run(LPVOID arg) #else -static void* -S_ithread_run(void * arg) { +static void * +S_ithread_run(void * arg) #endif - ithread* thread = (ithread*) arg; - int cleanup; +{ + ithread *thread = (ithread *)arg; + int cleanup; - dTHXa(thread->interp); - PERL_SET_CONTEXT(thread->interp); - S_ithread_set(aTHX_ thread); + dTHXa(thread->interp); + PERL_SET_CONTEXT(thread->interp); + S_ithread_set(aTHX_ thread); #if 0 - /* Far from clear messing with ->thr child-side is a good idea */ - MUTEX_LOCK(&thread->mutex); + /* Far from clear messing with ->thr child-side is a good idea */ + MUTEX_LOCK(&thread->mutex); #ifdef WIN32 - thread->thr = GetCurrentThreadId(); + thread->thr = GetCurrentThreadId(); #else - thread->thr = pthread_self(); + thread->thr = pthread_self(); #endif - MUTEX_UNLOCK(&thread->mutex); + MUTEX_UNLOCK(&thread->mutex); #endif - PL_perl_destruct_level = 2; - - { - AV* params = (AV*) SvRV(thread->params); - int len = (int)av_len(params)+1; - int ii; - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - for(ii = 0; ii < len; ii++) { - XPUSHs(av_shift(params)); - } - PUTBACK; - len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); - - SPAGAIN; - for (ii=len-1; ii >= 0; ii--) { - SV *sv = POPs; - av_store(params, ii, SvREFCNT_inc(sv)); - } - if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) { - Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV); - } - FREETMPS; - LEAVE; - - /* 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); + PL_perl_destruct_level = 2; - if (cleanup) - S_ithread_destruct(aTHX_ thread); + { + AV *params = (AV *)SvRV(thread->params); + int len = (int)av_len(params)+1; + int ii; + + dSP; + ENTER; + SAVETMPS; + + /* Put args on the stack */ + PUSHMARK(SP); + for (ii=0; ii < len; ii++) { + XPUSHs(av_shift(params)); + } + PUTBACK; + + /* Run the specified function */ + len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); + + /* Remove args from stack and put back in params array */ + SPAGAIN; + for (ii=len-1; ii >= 0; ii--) { + SV *sv = POPs; + av_store(params, ii, SvREFCNT_inc(sv)); + } + + /* Check for failure */ + if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) { + Perl_warn(aTHX_ "Thread failed to start: %" SVf, ERRSV); + } + + FREETMPS; + LEAVE; + + /* Release function ref */ + SvREFCNT_dec(thread->init_function); + thread->init_function = Nullsv; + } - MUTEX_LOCK(&create_destruct_mutex); - active_threads--; - MUTEX_UNLOCK(&create_destruct_mutex); + 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); + + MUTEX_LOCK(&create_destruct_mutex); + active_threads--; + MUTEX_UNLOCK(&create_destruct_mutex); #ifdef WIN32 - return (DWORD)0; + return ((DWORD)0); #else - return 0; + return (0); #endif } + +/* Type conversion helper functions */ static SV * ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) { SV *sv; MAGIC *mg; + if (inc) { - MUTEX_LOCK(&thread->mutex); - thread->count++; - MUTEX_UNLOCK(&thread->mutex); + MUTEX_LOCK(&thread->mutex); + thread->count++; + MUTEX_UNLOCK(&thread->mutex); + } + + if (! obj) { + obj = newSV(0); } - if (!obj) - obj = newSV(0); - sv = newSVrv(obj,classname); - sv_setiv(sv,PTR2IV(thread)); - mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0); + + sv = newSVrv(obj, classname); + sv_setiv(sv, PTR2IV(thread)); + mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0); mg->mg_flags |= MGf_DUP; SvREADONLY_on(sv); - return obj; + + return (obj); } static ithread * SV_to_ithread(pTHX_ SV *sv) { - if (SvROK(sv)) - { - return INT2PTR(ithread*, SvIV(SvRV(sv))); - } - else - { - return S_ithread_get(aTHX); - } + /* Argument is a thread */ + if (SvROK(sv)) { + return (INT2PTR(ithread *, SvIV(SvRV(sv)))); + } + /* Argument is classname, therefore return current thread */ + return (S_ithread_get(aTHX)); } -/* - * ithread->create(); ( aka ithread->new() ) - * Called in context of parent thread - */ +/* threads->create() + * Called in context of parent thread. + */ static SV * -S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params) +S_ithread_create( + pTHX_ SV *obj, + char *classname, + SV *init_function, + SV *params) { - ithread* thread; - CLONE_PARAMS clone_param; - ithread* current_thread = S_ithread_get(aTHX); + ithread *thread; + CLONE_PARAMS clone_param; + ithread *current_thread = S_ithread_get(aTHX); - SV** tmps_tmp = PL_tmps_stack; - IV tmps_ix = PL_tmps_ix; + SV **tmps_tmp = PL_tmps_stack; + IV tmps_ix = PL_tmps_ix; #ifndef WIN32 - int rc_stack_size = 0; - int rc_thread_create = 0; + int rc_stack_size = 0; + int rc_thread_create = 0; #endif + MUTEX_LOCK(&create_destruct_mutex); + + /* Allocate thread structure */ + thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); + if (!thread) { + MUTEX_UNLOCK(&create_destruct_mutex); + PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); + 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; - MUTEX_LOCK(&create_destruct_mutex); - thread = (ithread *) PerlMemShared_malloc(sizeof(ithread)); - if (!thread) { - MUTEX_UNLOCK(&create_destruct_mutex); - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - 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 ! - */ - thread->count = 1; - MUTEX_INIT(&thread->mutex); - thread->tid = tid_counter++; - thread->gimme = GIMME_V; - - /* "Clone" our interpreter into the thread's interpreter - * This gives thread access to "static data" and code. - */ - - PerlIO_flush((PerlIO*)NULL); - S_ithread_set(aTHX_ thread); - - SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct - value */ - PL_srand_called = FALSE; /* Set it to false so we can detect - if it gets set during the clone */ + /* Set count to 1 immediately in case thread exits before + * we return to caller! + */ + thread->count = 1; + + MUTEX_INIT(&thread->mutex); + thread->tid = tid_counter++; + thread->gimme = GIMME_V; + + /* "Clone" our interpreter into the thread's interpreter. + * This gives thread access to "static data" and code. + */ + PerlIO_flush((PerlIO *)NULL); + S_ithread_set(aTHX_ thread); + + SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */ + PL_srand_called = FALSE; /* Set it to false so we can detect if it gets + set during the clone */ #ifdef WIN32 - thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); + thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); #else - thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); + thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); #endif - /* perl_clone leaves us in new interpreter's context. - As it is tricky to spot an implicit aTHX, create a new scope - with aTHX matching the context for the duration of - our work for new interpreter. - */ - { - dTHXa(thread->interp); - - MY_CXT_CLONE; - - /* Here we remove END blocks since they should only run - in the thread they are created - */ - SvREFCNT_dec(PL_endav); - PL_endav = newAV(); - clone_param.flags = 0; - thread->init_function = sv_dup(init_function, &clone_param); - if (SvREFCNT(thread->init_function) == 0) { - SvREFCNT_inc(thread->init_function); - } - - - - thread->params = sv_dup(params, &clone_param); - SvREFCNT_inc(thread->params); - - - /* The code below checks that anything living on - the tmps stack and has been cloned (so it lives in the - ptr_table) has a refcount higher than 0 - - If the refcount is 0 it means that a something on the - stack/context was holding a reference to it and - since we init_stacks() in perl_clone that won't get - cleaned and we will get a leaked scalar. - The reason it was cloned was that it lived on the - @_ stack. - - Example of this can be found in bugreport 15837 - where calls in the parameter list end up as a temp - - One could argue that this fix should be in perl_clone - */ - - - while (tmps_ix > 0) { - SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); - tmps_ix--; - if (sv && SvREFCNT(sv) == 0) { - SvREFCNT_inc(sv); - SvREFCNT_dec(sv); - } - } - - - - SvTEMP_off(thread->init_function); - ptr_table_free(PL_ptr_table); - PL_ptr_table = NULL; - PL_exit_flags |= PERL_EXIT_DESTRUCT_END; - } - S_ithread_set(aTHX_ current_thread); - PERL_SET_CONTEXT(aTHX); - - /* Start the thread */ + /* perl_clone() leaves us in new interpreter's context. As it is tricky + * to spot an implicit aTHX, create a new scope with aTHX matching the + * context for the duration of our work for new interpreter. + */ + { + dTHXa(thread->interp); + + MY_CXT_CLONE; + + /* Here we remove END blocks since they should only run in the thread + * they are created + */ + SvREFCNT_dec(PL_endav); + PL_endav = newAV(); + clone_param.flags = 0; + thread->init_function = sv_dup(init_function, &clone_param); + if (SvREFCNT(thread->init_function) == 0) { + SvREFCNT_inc(thread->init_function); + } + + thread->params = sv_dup(params, &clone_param); + SvREFCNT_inc(thread->params); + + /* The code below checks that anything living on the tmps stack and + * has been cloned (so it lives in the ptr_table) has a refcount + * higher than 0. + * + * If the refcount is 0 it means that a something on the stack/context + * was holding a reference to it and since we init_stacks() in + * perl_clone that won't get cleaned and we will get a leaked scalar. + * The reason it was cloned was that it lived on the @_ stack. + * + * Example of this can be found in bugreport 15837 where calls in the + * parameter list end up as a temp. + * + * One could argue that this fix should be in perl_clone. + */ + while (tmps_ix > 0) { + SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); + tmps_ix--; + if (sv && SvREFCNT(sv) == 0) { + SvREFCNT_inc(sv); + SvREFCNT_dec(sv); + } + } + + SvTEMP_off(thread->init_function); + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + } + S_ithread_set(aTHX_ current_thread); + PERL_SET_CONTEXT(aTHX); + + /* Create/start the thread */ #ifdef WIN32 - thread->handle = CreateThread(NULL, 0, S_ithread_run, - (LPVOID)thread, 0, &thread->thr); + thread->handle = CreateThread(NULL, + (DWORD)0, + S_ithread_run, + (LPVOID)thread, + 0, + &thread->thr); #else - { - static pthread_attr_t attr; - static int attr_inited = 0; - static int attr_joinable = PTHREAD_CREATE_JOINABLE; - if (!attr_inited) { - attr_inited = 1; - pthread_attr_init(&attr); - } + { + static pthread_attr_t attr; + static int attr_inited = 0; + static int attr_joinable = PTHREAD_CREATE_JOINABLE; + if (! attr_inited) { + pthread_attr_init(&attr); + attr_inited = 1; + } + # ifdef PTHREAD_ATTR_SETDETACHSTATE - PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); + /* Threads start out joinable */ + PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); # endif + # ifdef THREAD_CREATE_NEEDS_STACK - rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK); + /* Set thread's stack size */ + rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK); # endif - if (! rc_stack_size) { -#ifdef OLD_PTHREADS_API - rc_thread_create = pthread_create( &thread->thr, attr, - S_ithread_run, (void *)thread); -#else -# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) - pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM ); + /* Create the thread */ + if (! rc_stack_size) { +# ifdef OLD_PTHREADS_API + rc_thread_create = pthread_create(&thread->thr, + attr, + S_ithread_run, + (void *)thread); +# else +# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) + pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); +# endif + rc_thread_create = pthread_create(&thread->thr, + &attr, + S_ithread_run, + (void *)thread); # endif - rc_thread_create = pthread_create( &thread->thr, &attr, - S_ithread_run, (void *)thread); -#endif - } - } + } + } #endif - /* Check for errors */ + /* Check for errors */ #ifdef WIN32 - if (thread->handle == NULL) { + if (thread->handle == NULL) { #else - if (rc_stack_size || rc_thread_create) { + if (rc_stack_size || rc_thread_create) { #endif - MUTEX_UNLOCK(&create_destruct_mutex); - sv_2mortal(params); - S_ithread_destruct(aTHX_ thread); + MUTEX_UNLOCK(&create_destruct_mutex); + sv_2mortal(params); + S_ithread_destruct(aTHX_ thread); #ifndef WIN32 if (ckWARN_d(WARN_THREADS)) { # ifdef THREAD_CREATE_NEEDS_STACK @@ -535,19 +555,21 @@ S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params) Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); } #endif - return &PL_sv_undef; - } - active_threads++; - MUTEX_UNLOCK(&create_destruct_mutex); - sv_2mortal(params); + return (&PL_sv_undef); + } + + active_threads++; + MUTEX_UNLOCK(&create_destruct_mutex); + + sv_2mortal(params); - return ithread_to_SV(aTHX_ obj, thread, classname, FALSE); + return (ithread_to_SV(aTHX_ obj, thread, classname, FALSE)); } #endif /* USE_ITHREADS */ -MODULE = threads PACKAGE = threads PREFIX = ithread_ +MODULE = threads PACKAGE = threads PREFIX = ithread_ PROTOTYPES: DISABLE #ifdef USE_ITHREADS @@ -586,7 +608,7 @@ void ithread_list(...) PREINIT: char *classname; - ithread *thr; + ithread *thread; int list_context; IV count = 0; PPCODE: @@ -600,17 +622,17 @@ ithread_list(...) /* Walk through threads list */ MUTEX_LOCK(&create_destruct_mutex); - for (thr = threads->next; - thr != threads; - thr = thr->next) + for (thread = threads->next; + thread != threads; + thread = thread->next) { /* Ignore detached or joined threads */ - if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { + if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { continue; } /* Push object on stack if list context */ if (list_context) { - XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE))); + XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); } count++; } @@ -785,19 +807,19 @@ ithread_DESTROY(...) void ithread_equal(...) + PREINIT: + int are_equal = 0; CODE: - /* Compares TIDs to determine thread equality. - * Return 0 on false for backward compatibility. - */ + /* Compares TIDs to determine thread equality */ if (sv_isobject(ST(0)) && sv_isobject(ST(1))) { ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1)))); - if (thr1->tid == thr2->tid) { - XST_mYES(0); - } else { - XST_mIV(0, 0); - } + are_equal = (thr1->tid == thr2->tid); + } + if (are_equal) { + XST_mYES(0); } else { + /* Return 0 on false for backward compatibility */ XST_mIV(0, 0); } /* XSRETURN(1); - implied */ @@ -808,7 +830,7 @@ ithread_object(...) PREINIT: char *classname; UV tid; - ithread *thr; + ithread *thread; int found = 0; CODE: /* Class method only */ @@ -820,22 +842,23 @@ ithread_object(...) XSRETURN_UNDEF; } + /* threads->object($tid) */ tid = SvUV(ST(1)); /* Walk through threads list */ MUTEX_LOCK(&create_destruct_mutex); - for (thr = threads->next; - thr != threads; - thr = thr->next) + for (thread = threads->next; + thread != threads; + thread = thread->next) { /* Look for TID, but ignore detached or joined threads */ - if ((thr->tid != tid) || - (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) + if ((thread->tid != tid) || + (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) { continue; } /* Put object on stack */ - ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)); + ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); found = 1; break; } @@ -861,47 +884,53 @@ ithread__handle(...); #endif /* USE_ITHREADS */ + BOOT: { #ifdef USE_ITHREADS - /* The 'main' thread is thread 0. - * It is detached (unjoinable) and immortal. - */ - ithread* thread; - MY_CXT_INIT; - - PL_perl_destruct_level = 2; - MUTEX_INIT(&create_destruct_mutex); - MUTEX_LOCK(&create_destruct_mutex); - PL_threadhook = &Perl_ithread_hook; - thread = (ithread *) PerlMemShared_malloc(sizeof(ithread)); - if (!thread) { - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); - } - 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++; - active_threads++; - thread->state = PERL_ITHR_DETACHED; -#ifdef WIN32 - thread->thr = GetCurrentThreadId(); -#else - thread->thr = pthread_self(); -#endif + /* The 'main' thread is thread 0. + * It is detached (unjoinable) and immortal. + */ - S_ithread_set(aTHX_ thread); - MUTEX_UNLOCK(&create_destruct_mutex); + ithread *thread; + MY_CXT_INIT; + + PL_perl_destruct_level = 2; + MUTEX_INIT(&create_destruct_mutex); + MUTEX_LOCK(&create_destruct_mutex); + + PL_threadhook = &Perl_ithread_hook; + + thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); + if (! thread) { + PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); + my_exit(1); + } + Zero(thread, 1, ithread); + + PL_perl_destruct_level = 2; + MUTEX_INIT(&thread->mutex); + + thread->tid = tid_counter++; /* Thread 0 */ + + /* Head of the threads list */ + threads = thread; + thread->next = thread; + thread->prev = thread; + + thread->count = 1; /* Immortal */ + + thread->interp = aTHX; + thread->state = PERL_ITHR_DETACHED; /* Detached */ +# ifdef WIN32 + thread->thr = GetCurrentThreadId(); +# else + thread->thr = pthread_self(); +# endif + + active_threads++; + + S_ithread_set(aTHX_ thread); + MUTEX_UNLOCK(&create_destruct_mutex); #endif /* USE_ITHREADS */ } -