diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-09-28 17:26:37 +0100 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-09-29 11:12:38 +0100 |
| commit | 72388ea1ff94f31ed9f6362cae7518adaaff4ee7 (patch) | |
| tree | 025aa6756b9e792f60025a81ab2aabf2c1baa78f /dist | |
| parent | 1fce97d89d6c84177437299edf550a454eb785ff (diff) | |
| download | perl-72388ea1ff94f31ed9f6362cae7518adaaff4ee7.tar.gz | |
Move threads from ext/ to dist/
Diffstat (limited to 'dist')
| -rwxr-xr-x | dist/threads/Makefile.PL | 111 | ||||
| -rw-r--r-- | dist/threads/hints/hpux.pl | 10 | ||||
| -rw-r--r-- | dist/threads/hints/linux.pl | 3 | ||||
| -rw-r--r-- | dist/threads/t/basic.t | 166 | ||||
| -rw-r--r-- | dist/threads/t/blocks.t | 120 | ||||
| -rw-r--r-- | dist/threads/t/context.t | 153 | ||||
| -rw-r--r-- | dist/threads/t/end.t | 72 | ||||
| -rw-r--r-- | dist/threads/t/err.t | 67 | ||||
| -rw-r--r-- | dist/threads/t/exit.t | 168 | ||||
| -rw-r--r-- | dist/threads/t/free.t | 214 | ||||
| -rw-r--r-- | dist/threads/t/free2.t | 338 | ||||
| -rw-r--r-- | dist/threads/t/join.t | 225 | ||||
| -rw-r--r-- | dist/threads/t/kill.t | 172 | ||||
| -rw-r--r-- | dist/threads/t/libc.t | 51 | ||||
| -rw-r--r-- | dist/threads/t/list.t | 70 | ||||
| -rw-r--r-- | dist/threads/t/no_threads.t | 39 | ||||
| -rw-r--r-- | dist/threads/t/problems.t | 175 | ||||
| -rw-r--r-- | dist/threads/t/stack.t | 103 | ||||
| -rw-r--r-- | dist/threads/t/stack_env.t | 49 | ||||
| -rw-r--r-- | dist/threads/t/state.t | 260 | ||||
| -rw-r--r-- | dist/threads/t/stress_cv.t | 59 | ||||
| -rw-r--r-- | dist/threads/t/stress_re.t | 65 | ||||
| -rw-r--r-- | dist/threads/t/stress_string.t | 63 | ||||
| -rw-r--r-- | dist/threads/t/thread.t | 309 | ||||
| -rw-r--r-- | dist/threads/threads.pm | 1066 | ||||
| -rwxr-xr-x | dist/threads/threads.xs | 1687 |
26 files changed, 5815 insertions, 0 deletions
diff --git a/dist/threads/Makefile.PL b/dist/threads/Makefile.PL new file mode 100755 index 0000000000..b251797a42 --- /dev/null +++ b/dist/threads/Makefile.PL @@ -0,0 +1,111 @@ +# Module makefile for threads (using ExtUtils::MakeMaker) + +require 5.008; + +use strict; +use warnings; + +use ExtUtils::MakeMaker; + + +# Used to check for a 'C' compiler +sub check_cc +{ + require File::Spec; + + my $cmd = $_[0]; + if (-x $cmd or MM->maybe_command($cmd)) { + return (1); # CC command found + } + for my $dir (File::Spec->path(), '.') { + my $abs = File::Spec->catfile($dir, $cmd); + if (-x $abs or MM->maybe_command($abs)) { + return (1); # CC command found + } + } + return; +} + +sub have_cc +{ + eval { require Config_m; }; # ExtUtils::FakeConfig (+ ActivePerl) + if ($@) { + eval { require Config; }; # Everyone else + } + my @chunks = split(/ /, $Config::Config{cc}); + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + if (check_cc("@chunks")) { + return (1); # CC command found + } + pop(@chunks); + } + return; +} + + +# Build options for different environments +my @conditional_params; +if (not grep { $_ eq 'PERL_CORE=1' } @ARGV) { + # CPAN + + # Verify that a 'C' compiler is available + if (! have_cc()) { + die("OS unsupported: ERROR: No 'C' compiler found to build 'threads'\n"); + } + + push(@conditional_params, 'DEFINE' => '-DHAS_PPPORT_H', + 'PREREQ_PM' => { + 'strict' => 0, + 'warnings' => 0, + 'overload' => 0, + 'Config' => 0, + 'Carp' => 0, + 'XSLoader' => 0, + + 'Test::More' => 0, + 'ExtUtils::testlib' => 0, + 'Hash::Util' => 0, + 'IO::File' => 0, + }); +} + + +# Create Makefile +WriteMakefile( + 'NAME' => 'threads', + 'AUTHOR' => 'Artur Bergman, Jerry D. Hedden <jdhedden AT cpan DOT org>', + 'VERSION_FROM' => 'threads.pm', + 'ABSTRACT_FROM' => 'threads.pm', + 'PM' => { + 'threads.pm' => '$(INST_LIBDIR)/threads.pm', + }, + 'INSTALLDIRS' => 'perl', + + ((ExtUtils::MakeMaker->VERSION() lt '6.25') ? + ('PL_FILES' => { }) : ()), + ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? + ('LICENSE' => 'perl') : ()), + + @conditional_params +); + +# Additional 'make' targets +sub MY::postamble +{ + return <<'_EXTRAS_'; +fixfiles: + @dos2unix `cat MANIFEST` + @$(CHMOD) 644 `cat MANIFEST` + @$(CHMOD) 755 examples/*.pl + +ppport: + @( cd /tmp; perl -e 'use Devel::PPPort; Devel::PPPort::WriteFile("ppport.h");' ) + @if ! cmp -s ppport.h /tmp/ppport.h; then \ + ( tkdiff ppport.h /tmp/ppport.h & ); \ + perl /tmp/ppport.h; \ + fi +_EXTRAS_ +} + +# EOF diff --git a/dist/threads/hints/hpux.pl b/dist/threads/hints/hpux.pl new file mode 100644 index 0000000000..0537ed810d --- /dev/null +++ b/dist/threads/hints/hpux.pl @@ -0,0 +1,10 @@ +# HP-UX 10.20 has different form for pthread_attr_getstacksize +my $ver = `uname -r`; +$ver =~ s/^\D*//; +if ($ver =~ /^10.20/) { + if (exists($self->{'DEFINE'})) { + $self->{'DEFINE'} .= " -DHPUX1020"; + } else { + $self->{'DEFINE'} = "-DHPUX1020"; + } +} diff --git a/dist/threads/hints/linux.pl b/dist/threads/hints/linux.pl new file mode 100644 index 0000000000..020f56d2f7 --- /dev/null +++ b/dist/threads/hints/linux.pl @@ -0,0 +1,3 @@ +# https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=101767 +# explicit linking is required to ensure the use of versioned symbols +$self->{LIBS} = ['-lpthread'] if $Config{libs} =~ /-lpthread/; diff --git a/dist/threads/t/basic.t b/dist/threads/t/basic.t new file mode 100644 index 0000000000..19ce793374 --- /dev/null +++ b/dist/threads/t/basic.t @@ -0,0 +1,166 @@ +use strict; +use warnings; + +BEGIN { + 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..33\n"); ### Number of tests that will be run ### +}; + +use threads; + +if ($threads::VERSION && ! $ENV{'PERL_CORE'}) { + print(STDERR "# Testing threads $threads::VERSION\n"); +} + +ok(1, 1, 'Loaded'); + +### Start of Testing ### + +ok(2, 1 == $threads::threads, "Check that threads::threads is true"); + +sub test1 { + ok(3,'bar' eq $_[0], "Test that argument passing works"); +} +threads->create('test1', 'bar')->join(); + +sub test2 { + ok(4,'bar' eq $_[0]->[0]->{'foo'}, "Test that passing arguments as references work"); +} +threads->create(\&test2, [{'foo' => 'bar'}])->join(); + +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'); + $thread1->detach(); + while ($thread1->is_running()) { + threads->yield(); + sleep 1; + } +} +ok(7, 1, "Detach test"); + + +sub test5 { + threads->create('test6')->join(); + ok(9, 1, "Nested thread test"); +} + +sub test6 { + 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()); +} +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()); +} +threads->create('test8')->join; + + +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(); +} + +{ + 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(); +} + + +my $thr1 = threads->create(sub {}); +my $thr2 = threads->create(sub {}); +my $thr3 = threads->object($thr1->tid()); + +# Make sure both overloaded '==' and '!=' are working correctly +ok(20, $thr1 != $thr2, 'Treads not equal'); +ok(21, !($thr1 == $thr2), 'Treads not equal'); +ok(22, $thr1 == $thr3, 'Threads equal'); +ok(23, !($thr1 != $thr3), 'Threads equal'); + +ok(24, $thr1->_handle(), 'Handle method'); +ok(25, $thr2->_handle(), 'Handle method'); + +ok(26, threads->object($thr1->tid())->tid() == 11, 'Object method'); +ok(27, threads->object($thr2->tid())->tid() == 12, 'Object method'); + +$thr1->join(); +$thr2->join(); + +my $sub = sub { ok(28, shift() == 1, "Test code ref"); }; +threads->create($sub, 1)->join(); + +my $thrx = threads->object(99); +ok(29, ! defined($thrx), 'No object'); +$thrx = threads->object(); +ok(30, ! defined($thrx), 'No object'); +$thrx = threads->object(undef); +ok(31, ! defined($thrx), 'No object'); +$thrx = threads->object(0); +ok(32, ! defined($thrx), 'No object'); + +threads->import('stringify'); +$thr1 = threads->create(sub {}); +ok(33, "$thr1" eq $thr1->tid(), 'Stringify'); +$thr1->join(); + +exit(0); + +# EOF diff --git a/dist/threads/t/blocks.t b/dist/threads/t/blocks.t new file mode 100644 index 0000000000..921679afae --- /dev/null +++ b/dist/threads/t/blocks.t @@ -0,0 +1,120 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + print("1..0 # SKIP threads::shared not available\n"); + exit(0); + } + + $| = 1; + print("1..5\n"); ### Number of tests that will be run ### +}; + +my ($TEST, $COUNT, $TOTAL); + +BEGIN { + share($TEST); + $TEST = 1; + share($COUNT); + $COUNT = 0; + $TOTAL = 0; +} + +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]); + print(STDERR "# FAIL: $name\n") if (! $ENV{'PERL_CORE'}); + } + + return ($ok); +} + + +### Start of Testing ### + +$SIG{'__WARN__'} = sub { ok(0, "Warning: $_[0]"); }; + +sub foo { lock($COUNT); $COUNT++; } +sub baz { 42 } + +my $bthr; +BEGIN { + $SIG{'__WARN__'} = sub { ok(0, "BEGIN: $_[0]"); }; + + $TOTAL++; + threads->create('foo')->join(); + $TOTAL++; + threads->create(\&foo)->join(); + $TOTAL++; + threads->create(sub { lock($COUNT); $COUNT++; })->join(); + + $TOTAL++; + threads->create('foo')->detach(); + $TOTAL++; + threads->create(\&foo)->detach(); + $TOTAL++; + threads->create(sub { lock($COUNT); $COUNT++; })->detach(); + + $bthr = threads->create('baz'); +} + +my $mthr; +MAIN: { + $TOTAL++; + threads->create('foo')->join(); + $TOTAL++; + threads->create(\&foo)->join(); + $TOTAL++; + threads->create(sub { lock($COUNT); $COUNT++; })->join(); + + $TOTAL++; + threads->create('foo')->detach(); + $TOTAL++; + threads->create(\&foo)->detach(); + $TOTAL++; + threads->create(sub { lock($COUNT); $COUNT++; })->detach(); + + $mthr = threads->create('baz'); +} + +ok($mthr, 'Main thread'); +ok($bthr, 'BEGIN thread'); + +ok($mthr->join() == 42, 'Main join'); +ok($bthr->join() == 42, 'BEGIN join'); + +# Wait for detached threads to finish +{ + threads->yield(); + sleep(1); + lock($COUNT); + redo if ($COUNT < $TOTAL); +} + +exit(0); + +# EOF diff --git a/dist/threads/t/context.t b/dist/threads/t/context.t new file mode 100644 index 0000000000..c2f3b22fd5 --- /dev/null +++ b/dist/threads/t/context.t @@ -0,0 +1,153 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + print("1..0 # SKIP threads::shared not available\n"); + exit(0); + } + + $| = 1; + print("1..31\n"); ### Number of tests that will be run ### +}; + +my $TEST; +BEGIN { + share($TEST); + $TEST = 1; +} + +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 ### + +sub foo +{ + my $context = shift; + my $wantarray = wantarray(); + + if ($wantarray) { + ok($context eq 'array', 'Array/list context'); + return ('array'); + } elsif (defined($wantarray)) { + ok($context eq 'scalar', 'Scalar context'); + return 'scalar'; + } else { + ok($context eq 'void', 'Void context'); + return; + } +} + +my ($thr) = threads->create('foo', 'array'); +my ($res) = $thr->join(); +ok($res eq 'array', 'Implicit array context'); + +$thr = threads->create('foo', 'scalar'); +$res = $thr->join(); +ok($res eq 'scalar', 'Implicit scalar context'); + +threads->create('foo', 'void'); +($thr) = threads->list(); +$res = $thr->join(); +ok(! defined($res), 'Implicit void context'); + +$thr = threads->create({'context' => 'array'}, 'foo', 'array'); +($res) = $thr->join(); +ok($res eq 'array', 'Explicit array context'); + +($thr) = threads->create({'scalar' => 'scalar'}, 'foo', 'scalar'); +$res = $thr->join(); +ok($res eq 'scalar', 'Explicit scalar context'); + +$thr = threads->create({'void' => 1}, 'foo', 'void'); +$res = $thr->join(); +ok(! defined($res), 'Explicit void context'); + + +sub bar +{ + my $context = shift; + my $wantarray = threads->wantarray(); + + if ($wantarray) { + ok($context eq 'list', 'Array/list context'); + return ('list'); + } elsif (defined($wantarray)) { + ok($context eq 'scalar', 'Scalar context'); + return 'scalar'; + } else { + ok($context eq 'void', 'Void context'); + return; + } +} + +($thr) = threads->create('bar', 'list'); +my $ctx = $thr->wantarray(); +ok($ctx, 'Implicit array context'); +($res) = $thr->join(); +ok($res eq 'list', 'Implicit array context'); + +$thr = threads->create('bar', 'scalar'); +$ctx = $thr->wantarray(); +ok(defined($ctx) && !$ctx, 'Implicit scalar context'); +$res = $thr->join(); +ok($res eq 'scalar', 'Implicit scalar context'); + +threads->create('bar', 'void'); +($thr) = threads->list(); +$ctx = $thr->wantarray(); +ok(! defined($ctx), 'Implicit void context'); +$res = $thr->join(); +ok(! defined($res), 'Implicit void context'); + +$thr = threads->create({'context' => 'list'}, 'bar', 'list'); +$ctx = $thr->wantarray(); +ok($ctx, 'Explicit array context'); +($res) = $thr->join(); +ok($res eq 'list', 'Explicit array context'); + +($thr) = threads->create({'scalar' => 'scalar'}, 'bar', 'scalar'); +$ctx = $thr->wantarray(); +ok(defined($ctx) && !$ctx, 'Explicit scalar context'); +$res = $thr->join(); +ok($res eq 'scalar', 'Explicit scalar context'); + +$thr = threads->create({'void' => 1}, 'bar', 'void'); +$ctx = $thr->wantarray(); +ok(! defined($ctx), 'Explicit void context'); +$res = $thr->join(); +ok(! defined($res), 'Explicit void context'); + +exit(0); + +# EOF diff --git a/dist/threads/t/end.t b/dist/threads/t/end.t new file mode 100644 index 0000000000..b18bacac00 --- /dev/null +++ b/dist/threads/t/end.t @@ -0,0 +1,72 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + print("1..0 # SKIP threads::shared not available\n"); + exit(0); + } + + $| = 1; + print("1..6\n"); ### Number of tests that will be run ### +}; + +my $TEST; +BEGIN { + share($TEST); + $TEST = 1; +} + +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 ### + +# 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, '4th thread END block') }"; + threads->create(sub { eval "END { ok(1, '5th thread END block') }"})->join(); +} +threads->create(\&thread)->join(); + +exit(0); + +# EOF diff --git a/dist/threads/t/err.t b/dist/threads/t/err.t new file mode 100644 index 0000000000..f5e0a19f82 --- /dev/null +++ b/dist/threads/t/err.t @@ -0,0 +1,67 @@ +use strict; +use warnings; + +BEGIN { + require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); + + use Config; + if (! $Config{'useithreads'}) { + skip_all(q/Perl not compiled with 'useithreads'/); + } + + plan(10); +} + +use ExtUtils::testlib; + +use_ok('threads'); + +### Start of Testing ### + +no warnings 'threads'; + +# Create a thread that generates an error +my $thr = threads->create(sub { my $x = Foo->new(); }); + +# Check that thread returns 'undef' +my $result = $thr->join(); +ok(! defined($result), 'thread died'); + +# Check error +like($thr->error(), q/Can't locate object method/, 'thread error'); + + +# Create a thread that 'die's with an object +$thr = threads->create(sub { + threads->yield(); + sleep(1); + die(bless({ error => 'bogus' }, 'Err::Class')); + }); + +my $err = $thr->error(); +ok(! defined($err), 'no error yet'); + +# Check that thread returns 'undef' +$result = $thr->join(); +ok(! defined($result), 'thread died'); + +# Check that error object is retrieved +$err = $thr->error(); +isa_ok($err, 'Err::Class', 'error object'); +is($err->{error}, 'bogus', 'error field'); + +# Check that another thread can reference the error object +my $thrx = threads->create(sub { die(bless($thr->error(), 'Foo')); }); + +# Check that thread returns 'undef' +$result = $thrx->join(); +ok(! defined($result), 'thread died'); + +# Check that the rethrown error object is retrieved +$err = $thrx->error(); +isa_ok($err, 'Foo', 'error object'); +is($err->{error}, 'bogus', 'error field'); + +exit(0); + +# EOF diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t new file mode 100644 index 0000000000..34f248a4db --- /dev/null +++ b/dist/threads/t/exit.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +BEGIN { + require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); + + use Config; + if (! $Config{'useithreads'}) { + skip_all(q/Perl not compiled with 'useithreads'/); + } +} + +our $TODO; + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + skip_all('threads::shared not available'); + } + + $| = 1; + print("1..18\n"); ### Number of tests that will be run ### +}; + +ok(1, 'Loaded'); + +### Start of Testing ### + +$SIG{'__WARN__'} = sub { + my $msg = shift; + ok(0, "WARN in main: $msg"); +}; +$SIG{'__DIE__'} = sub { + my $msg = shift; + ok(0, "DIE in main: $msg"); +}; + + +my $thr = threads->create(sub { + threads->exit(); + return (99); # Not seen +}); +ok($thr, 'Created: threads->exit()'); +my $rc = $thr->join(); +ok(! defined($rc), 'Exited: threads->exit()'); + + +run_perl(prog => 'use threads 1.74;' . + 'threads->exit(86);' . + 'exit(99);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); +{ + local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS'; + is($?>>8, 86, 'thread->exit(status) in main'); +} + +$thr = threads->create({'exit' => 'thread_only'}, sub { + exit(1); + return (99); # Not seen + }); +ok($thr, 'Created: thread_only'); +$rc = $thr->join(); +ok(! defined($rc), 'Exited: thread_only'); + + +$thr = threads->create(sub { + threads->set_thread_exit_only(1); + exit(1); + return (99); # Not seen +}); +ok($thr, 'Created: threads->set_thread_exit_only'); +$rc = $thr->join(); +ok(! defined($rc), 'Exited: threads->set_thread_exit_only'); + + +my $WAIT :shared = 1; +$thr = threads->create(sub { + lock($WAIT); + while ($WAIT) { + cond_wait($WAIT); + } + exit(1); + return (99); # Not seen +}); +threads->yield(); +ok($thr, 'Created: $thr->set_thread_exit_only'); +$thr->set_thread_exit_only(1); +{ + lock($WAIT); + $WAIT = 0; + cond_broadcast($WAIT); +} +$rc = $thr->join(); +ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); + + +run_perl(prog => 'use threads 1.74 qw(exit thread_only);' . + 'threads->create(sub { exit(99); })->join();' . + 'exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); +{ + local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS'; + is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); +} + +my $out = run_perl(prog => 'use threads 1.74;' . + 'threads->create(sub {' . + ' exit(99);' . + '});' . + 'sleep(1);' . + 'exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ], + stderr => 1); +{ + local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS'; + is($?>>8, 99, "exit(status) in thread"); +} +like($out, '1 finished and unjoined', "exit(status) in thread"); + + +$out = run_perl(prog => 'use threads 1.74 qw(exit thread_only);' . + 'threads->create(sub {' . + ' threads->set_thread_exit_only(0);' . + ' exit(99);' . + '});' . + 'sleep(1);' . + 'exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ], + stderr => 1); +{ + local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS'; + is($?>>8, 99, "set_thread_exit_only(0)"); +} +like($out, '1 finished and unjoined', "set_thread_exit_only(0)"); + + +run_perl(prog => 'use threads 1.74;' . + 'threads->create(sub {' . + ' $SIG{__WARN__} = sub { exit(99); };' . + ' die();' . + '})->join();' . + 'exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); +{ + local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS'; + is($?>>8, 99, "exit(status) in thread warn handler"); +} + +$thr = threads->create(sub { + $SIG{__WARN__} = sub { threads->exit(); }; + local $SIG{__DIE__} = 'DEFAULT'; + die('Died'); +}); +ok($thr, 'Created: threads->exit() in thread warn handler'); +$rc = $thr->join(); +ok(! defined($rc), 'Exited: threads->exit() in thread warn handler'); + +exit(0); + +# EOF diff --git a/dist/threads/t/free.t b/dist/threads/t/free.t new file mode 100644 index 0000000000..d41199af05 --- /dev/null +++ b/dist/threads/t/free.t @@ -0,0 +1,214 @@ +use strict; +use warnings; + +BEGIN { + # Import test.pl into its own package + { + package Test; + require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); + } + + use Config; + if (! $Config{'useithreads'}) { + Test::skip_all(q/Perl not compiled with 'useithreads'/); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + Test::skip_all(q/threads::shared not available/); + } + + require Thread::Queue; + + $| = 1; + print("1..29\n"); ### Number of tests that will be run ### +} + +Test::watchdog(120); # In case we get stuck + +my $q = Thread::Queue->new(); +my $TEST = 1; + +sub ok +{ + $q->enqueue(@_); + + while ($q->pending()) { + my $ok = $q->dequeue(); + my $name = $q->dequeue(); + my $id = $TEST++; + + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + } +} + + +### Start of Testing ### +ok(1, 'Loaded'); + +# Tests freeing the Perl interperter for each thread +# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details + +my ($COUNT, $STARTED) :shared; + +sub threading_1 { + my $q = shift; + + my $tid = threads->tid(); + $q->enqueue($tid, "Thread $tid started"); + + my $id; + { + lock($STARTED); + $STARTED++; + $id = $STARTED; + } + if ($STARTED < 5) { + sleep(1); + threads->create('threading_1', $q)->detach(); + } + + if ($id == 1) { + sleep(2); + } elsif ($id == 2) { + sleep(6); + } elsif ($id == 3) { + sleep(3); + } elsif ($id == 4) { + sleep(1); + } else { + sleep(2); + } + + lock($COUNT); + $COUNT++; + cond_signal($COUNT); + $q->enqueue($tid, "Thread $tid done"); +} + +{ + $STARTED = 0; + $COUNT = 0; + threads->create('threading_1', $q)->detach(); + { + my $cnt = 0; + while ($cnt < 5) { + { + lock($COUNT); + cond_wait($COUNT) if ($COUNT < 5); + $cnt = $COUNT; + } + threads->create(sub { + threads->create(sub { })->join(); + })->join(); + } + } + sleep(1); +} +ok($COUNT == 5, "Done - $COUNT threads"); + + +sub threading_2 { + my $q = shift; + + my $tid = threads->tid(); + $q->enqueue($tid, "Thread $tid started"); + + { + lock($STARTED); + $STARTED++; + } + if ($STARTED < 5) { + threads->create('threading_2', $q)->detach(); + } + threads->yield(); + + lock($COUNT); + $COUNT++; + cond_signal($COUNT); + + $q->enqueue($tid, "Thread $tid done"); +} + +{ + $STARTED = 0; + $COUNT = 0; + threads->create('threading_2', $q)->detach(); + threads->create(sub { + threads->create(sub { })->join(); + })->join(); + { + lock($COUNT); + while ($COUNT < 5) { + cond_wait($COUNT); + } + } + sleep(1); +} +ok($COUNT == 5, "Done - $COUNT threads"); + + +{ + threads->create(sub { })->join(); +} +ok(1, 'Join'); + + +sub threading_3 { + my $q = shift; + + my $tid = threads->tid(); + $q->enqueue($tid, "Thread $tid started"); + + { + threads->create(sub { + my $q = shift; + + my $tid = threads->tid(); + $q->enqueue($tid, "Thread $tid started"); + + sleep(1); + + lock($COUNT); + $COUNT++; + cond_signal($COUNT); + + $q->enqueue($tid, "Thread $tid done"); + }, $q)->detach(); + } + + lock($COUNT); + $COUNT++; + cond_signal($COUNT); + + $q->enqueue($tid, "Thread $tid done"); +} + +{ + $COUNT = 0; + threads->create(sub { + threads->create('threading_3', $q)->detach(); + { + lock($COUNT); + while ($COUNT < 2) { + cond_wait($COUNT); + } + } + })->join(); + sleep(1); +} +ok($COUNT == 2, "Done - $COUNT threads"); + +exit(0); + +# EOF diff --git a/dist/threads/t/free2.t b/dist/threads/t/free2.t new file mode 100644 index 0000000000..99761302c6 --- /dev/null +++ b/dist/threads/t/free2.t @@ -0,0 +1,338 @@ +use strict; +use warnings; + +BEGIN { + # Import test.pl into its own package + { + package Test; + require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); + } + + use Config; + if (! $Config{'useithreads'}) { + Test::skip_all(q/Perl not compiled with 'useithreads'/); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + Test::skip_all(q/threads::shared not available/); + } + + if (($] < 5.008002) && ($threads::shared::VERSION < 0.92)) { + Test::skip_all(q/Needs threads::shared 0.92 or later/); + } + + require Thread::Queue; + + $| = 1; + print("1..78\n"); ### Number of tests that will be run ### +} + +Test::watchdog(60); # In case we get stuck + +my $q = Thread::Queue->new(); +my $TEST = 1; + +sub ok +{ + $q->enqueue(@_) if @_; + + while ($q->pending()) { + my $ok = $q->dequeue(); + my $name = $q->dequeue(); + my $id = $TEST++; + + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + } +} + + + +### Start of Testing ### +ok(1, 'Loaded'); + +# 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 $q = shift; + my $tid = threads->tid(); + $q->enqueue($tid, "Thread $tid started"); + + threads->yield(); + + my $other; + { + lock(%READY); + + # Create next thread + if ($tid < 18) { + my $next = 'th' . $tid; + my $th = threads->create($next, $q); + } else { + # Last thread signals first + th_signal($q, 1); + } + + # Wait until signalled by another thread + while (! exists($READY{$tid})) { + cond_wait(%READY); + } + $other = delete($READY{$tid}); + } + $q->enqueue($tid, "Thread $tid received signal from $other"); + threads->yield(); +} + +# Thread terminating +sub th_done +{ + my $q = shift; + my $tid = threads->tid(); + + lock($COUNT); + $COUNT++; + cond_signal($COUNT); + + $q->enqueue($tid, "Thread $tid done"); +} + +# Signal another thread to go +sub th_signal +{ + my $q = shift; + my $other = shift; + $other++; + my $tid = threads->tid(); + + $q->enqueue($tid, "Thread $tid signalling $other"); + + lock(%READY); + $READY{$other} = $tid; + cond_broadcast(%READY); +} + +##### + +sub th1 +{ + my $q = shift; + th_start($q); + + threads->detach(); + + th_signal($q, 2); + th_signal($q, 6); + th_signal($q, 10); + th_signal($q, 14); + + th_done($q); +} + +sub th2 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 4); + th_done($q); +} + +sub th6 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 8); + th_done($q); +} + +sub th10 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 12); + th_done($q); +} + +sub th14 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 16); + th_done($q); +} + +sub th4 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 3); + th_done($q); +} + +sub th8 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 7); + th_done($q); +} + +sub th12 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 13); + th_done($q); +} + +sub th16 +{ + my $q = shift; + th_start($q); + threads->detach(); + th_signal($q, 17); + th_done($q); +} + +sub th3 +{ + my $q = shift; + my $tid = threads->tid(); + my $other = 5; + + th_start($q); + threads->detach(); + th_signal($q, $other); + sleep(1); + $q->enqueue(1, "Thread $tid getting return from thread $other"); + my $ret = threads->object($other+1)->join(); + $q->enqueue($ret == $other+1, "Thread $tid saw that thread $other returned $ret"); + th_done($q); +} + +sub th5 +{ + my $q = shift; + th_start($q); + th_done($q); + return (threads->tid()); +} + + +sub th7 +{ + my $q = shift; + my $tid = threads->tid(); + my $other = 9; + + th_start($q); + threads->detach(); + th_signal($q, $other); + $q->enqueue(1, "Thread $tid getting return from thread $other"); + my $ret = threads->object($other+1)->join(); + $q->enqueue($ret == $other+1, "Thread $tid saw that thread $other returned $ret"); + th_done($q); +} + +sub th9 +{ + my $q = shift; + th_start($q); + sleep(1); + th_done($q); + return (threads->tid()); +} + + +sub th13 +{ + my $q = shift; + my $tid = threads->tid(); + my $other = 11; + + th_start($q); + threads->detach(); + th_signal($q, $other); + sleep(1); + $q->enqueue(1, "Thread $tid getting return from thread $other"); + my $ret = threads->object($other+1)->join(); + $q->enqueue($ret == $other+1, "Thread $tid saw that thread $other returned $ret"); + th_done($q); +} + +sub th11 +{ + my $q = shift; + th_start($q); + th_done($q); + return (threads->tid()); +} + + +sub th17 +{ + my $q = shift; + my $tid = threads->tid(); + my $other = 15; + + th_start($q); + threads->detach(); + th_signal($q, $other); + $q->enqueue(1, "Thread $tid getting return from thread $other"); + my $ret = threads->object($other+1)->join(); + $q->enqueue($ret == $other+1, "Thread $tid saw that thread $other returned $ret"); + th_done($q); +} + +sub th15 +{ + my $q = shift; + th_start($q); + sleep(1); + th_done($q); + return (threads->tid()); +} + + +TEST_STARTS_HERE: +{ + $COUNT = 0; + threads->create('th1', $q); + { + lock($COUNT); + while ($COUNT < 17) { + cond_wait($COUNT); + ok(); # Prints out any intermediate results + } + } + sleep(1); +} +ok($COUNT == 17, "Done - $COUNT threads"); + +exit(0); + +# EOF diff --git a/dist/threads/t/join.t b/dist/threads/t/join.t new file mode 100644 index 0000000000..2272e079d4 --- /dev/null +++ b/dist/threads/t/join.t @@ -0,0 +1,225 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + print("1..0 # SKIP threads::shared not available\n"); + exit(0); + } + + $| = 1; + print("1..20\n"); ### Number of tests that will be run ### +}; + +my $TEST; +BEGIN { + share($TEST); + $TEST = 1; +} + +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); +} + +sub skip { + ok(1, '# SKIP ' . $_[0]); +} + + +### Start of Testing ### + +{ + my $retval = threads->create(sub { return ("hi") })->join(); + ok($retval eq 'hi', "Check basic returnvalue"); +} +{ + my ($thread) = threads->create(sub { return (1,2,3) }); + my @retval = $thread->join(); + ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,''); +} +{ + my $retval = threads->create(sub { return [1] })->join(); + ok($retval->[0] == 1,"Check that a array ref works",); +} +{ + my $retval = threads->create(sub { return { foo => "bar" }})->join(); + ok($retval->{foo} eq 'bar',"Check that hash refs work"); +} +{ + my $retval = threads->create( sub { + 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"; + close($retval); + unlink("threadtest"); +} +{ + my $test = "hi"; + my $retval = threads->create(sub { return $_[0]}, \$test)->join(); + ok($$retval eq 'hi',''); +} +{ + my $test = "hi"; + share($test); + my $retval = threads->create(sub { return $_[0]}, \$test)->join(); + ok($$retval eq 'hi',''); + $test = "foo"; + ok($$retval eq 'foo',''); +} +{ + my %foo; + share(%foo); + threads->create(sub { + 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 (<PS>) { + 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 |'"); + } + } else { + skip("\$0 check: opening 'ps -f |' failed: $!"); + } +} else { + skip("\$0 check: only on Linux"); +} + +{ + my $t = threads->create(sub {}); + $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"); +} + +{ + # 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 + $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2; +} + +{ + my $go : shared = 0; + + my $t = threads->create( sub { + lock($go); + cond_wait($go) until $go; + }); + + my $joiner = threads->create(sub { $_[0]->join }, $t); + + threads->yield(); + sleep 1; + eval { $t->join; }; + ok(($@ =~ /^Thread already joined at/)?1:0, "Join pending join"); + + { lock($go); $go = 1; cond_signal($go); } + $joiner->join; +} + +{ + my $go : shared = 0; + my $t = threads->create( sub { + eval { threads->self->join; }; + ok(($@ =~ /^Cannot join self/), "Join self"); + lock($go); $go = 1; cond_signal($go); + }); + + { lock ($go); cond_wait($go) until $go; } + $t->join; +} + +{ + my $go : shared = 0; + my $t = threads->create( sub { + lock($go); cond_wait($go) until $go; + }); + my $joiner = threads->create(sub { $_[0]->join; }, $t); + + threads->yield(); + sleep 1; + eval { $t->detach }; + ok(($@ =~ /^Cannot detach a joined thread at/)?1:0, "Detach pending join"); + + { lock($go); $go = 1; cond_signal($go); } + $joiner->join; +} + +exit(0); + +# EOF diff --git a/dist/threads/t/kill.t b/dist/threads/t/kill.t new file mode 100644 index 0000000000..f09303364b --- /dev/null +++ b/dist/threads/t/kill.t @@ -0,0 +1,172 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + print("1..0 # SKIP threads::shared not available\n"); + exit(0); + } + + local $SIG{'HUP'} = sub {}; + my $thr = threads->create(sub {}); + eval { $thr->kill('HUP') }; + $thr->join(); + if ($@ && $@ =~ /safe signals/) { + print("1..0 # SKIP Not using safe signals\n"); + exit(0); + } + + require Thread::Queue; + require Thread::Semaphore; + + $| = 1; + print("1..18\n"); ### Number of tests that will be run ### +}; + + +my $q = Thread::Queue->new(); +my $TEST = 1; + +sub ok +{ + $q->enqueue(@_); + + while ($q->pending()) { + my $ok = $q->dequeue(); + my $name = $q->dequeue(); + my $id = $TEST++; + + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + } +} + + +### Start of Testing ### +ok(1, 'Loaded'); + +### Thread cancel ### + +# Set up to capture warning when thread terminates +my @errs :shared; +$SIG{__WARN__} = sub { push(@errs, @_); }; + +sub thr_func { + my $q = shift; + + # Thread 'cancellation' signal handler + $SIG{'KILL'} = sub { + $q->enqueue(1, 'Thread received signal'); + die("Thread killed\n"); + }; + + # Thread sleeps until signalled + $q->enqueue(1, 'Thread sleeping'); + sleep(1) for (1..10); + # Should not go past here + $q->enqueue(0, 'Thread terminated normally'); + return ('ERROR'); +} + +# Create thread +my $thr = threads->create('thr_func', $q); +ok($thr && $thr->tid() == 2, 'Created thread'); +threads->yield(); +sleep(1); + +# Signal thread +ok($thr->kill('KILL') == $thr, 'Signalled thread'); +threads->yield(); + +# Cleanup +my $rc = $thr->join(); +ok(! $rc, 'No thread return value'); + +# Check for thread termination message +ok(@errs && $errs[0] =~ /Thread killed/, 'Thread termination warning'); + + +### Thread suspend/resume ### + +sub thr_func2 +{ + my $q = shift; + + my $sema = shift; + $q->enqueue($sema, 'Thread received semaphore'); + + # Set up the signal handler for suspension/resumption + $SIG{'STOP'} = sub { + $q->enqueue(1, 'Thread suspending'); + $sema->down(); + $q->enqueue(1, 'Thread resuming'); + $sema->up(); + }; + + # Set up the signal handler for graceful termination + my $term = 0; + $SIG{'TERM'} = sub { + $q->enqueue(1, 'Thread caught termination signal'); + $term = 1; + }; + + # Do work until signalled to terminate + while (! $term) { + sleep(1); + } + + $q->enqueue(1, 'Thread done'); + return ('OKAY'); +} + + +# Create a semaphore for use in suspending the thread +my $sema = Thread::Semaphore->new(); +ok($sema, 'Semaphore created'); + +# Create a thread and send it the semaphore +$thr = threads->create('thr_func2', $q, $sema); +ok($thr && $thr->tid() == 3, 'Created thread'); +threads->yield(); +sleep(1); + +# Suspend the thread +$sema->down(); +ok($thr->kill('STOP') == $thr, 'Suspended thread'); + +threads->yield(); +sleep(1); + +# Allow the thread to continue +$sema->up(); + +threads->yield(); +sleep(1); + +# Terminate the thread +ok($thr->kill('TERM') == $thr, 'Signalled thread to terminate'); + +$rc = $thr->join(); +ok($rc eq 'OKAY', 'Thread return value'); + +ok($thr->kill('TERM') == $thr, 'Ignore signal to terminated thread'); + +exit(0); + +# EOF diff --git a/dist/threads/t/libc.t b/dist/threads/t/libc.t new file mode 100644 index 0000000000..4f6f6ed3ae --- /dev/null +++ b/dist/threads/t/libc.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +BEGIN { + require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); + + use Config; + if (! $Config{'useithreads'}) { + skip_all(q/Perl not compiled with 'useithreads'/); + } + + plan(11); +} + +use ExtUtils::testlib; + +use_ok('threads'); + +### Start of Testing ### + +my $i = 10; +my $y = 20000; + +my %localtime; +for (1..$i) { + $localtime{$_} = localtime($_); +}; + +my @threads; +for (1..$i) { + $threads[$_] = threads->create(sub { + my $arg = shift; + my $localtime = $localtime{$arg}; + my $error = 0; + for (1..$y) { + my $lt = localtime($arg); + if ($localtime ne $lt) { + $error++; + } + } + return $error; + }, $_); +} + +for (1..$i) { + is($threads[$_]->join(), 0, 'localtime() thread-safe'); +} + +exit(0); + +# EOF diff --git a/dist/threads/t/list.t b/dist/threads/t/list.t new file mode 100644 index 0000000000..1ad0fadc80 --- /dev/null +++ b/dist/threads/t/list.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +BEGIN { + 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..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'); + +threads->create(sub {})->join(); +ok(3, scalar @{[threads->list()]} == 0, 'Empty thread list after join'); + +my $thread = threads->create(sub {}); +ok(4, scalar(threads->list()) == 1, 'Non-empty thread list'); +ok(5, threads->list() == 1, 'Non-empty thread list'); +$thread->join(); +ok(6, scalar @{[threads->list()]} == 0, 'Thread list empty again'); +ok(7, threads->list() == 0, 'Thread list empty again'); + +$thread = threads->create(sub { + ok(8, threads->list() == 1, 'Non-empty thread list in thread'); + ok(9, threads->self == (threads->list())[0], 'Self in thread list') +}); + +threads->yield; # help out non-preemptive thread implementations +sleep 1; + +ok(10, scalar(threads->list()) == 1, 'Thread count 1'); +ok(11, threads->list() == 1, 'Thread count 1'); +my $cnt = threads->list(); +ok(12, $cnt == 1, 'Thread count 1'); +my ($thr_x) = threads->list(); +ok(13, $thread == $thr_x, 'Thread in list'); +$thread->join(); +ok(14, scalar @{[threads->list()]} == 0, 'Thread list empty'); +ok(15, threads->list() == 0, 'Thread list empty'); + +exit(0); + +# EOF diff --git a/dist/threads/t/no_threads.t b/dist/threads/t/no_threads.t new file mode 100644 index 0000000000..1ed1e96dc4 --- /dev/null +++ b/dist/threads/t/no_threads.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if ($Config{'useithreads'}) { + print("1..0 # SKIP Perl 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..1\n"); ### Number of tests that will be run ### +}; + +eval 'use threads; 1'; + +ok(1, (($@ =~ /not built to support thread/)?1:0), "No threads support"); + +exit(0); + +# EOF diff --git a/dist/threads/t/problems.t b/dist/threads/t/problems.t new file mode 100644 index 0000000000..ec2bf0247a --- /dev/null +++ b/dist/threads/t/problems.t @@ -0,0 +1,175 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + print("1..0 # SKIP threads::shared not available\n"); + exit(0); + } + + $| = 1; + if ($] == 5.008) { + print("1..11\n"); ### Number of tests that will be run ### + } else { + print("1..15\n"); ### Number of tests that will be run ### + } +}; + +print("ok 1 - Loaded\n"); + +### Start of Testing ### + +no warnings 'deprecated'; # Suppress warnings related to :unique + +use Hash::Util 'lock_keys'; + +my $test :shared = 2; + +# 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); + if ($got ne $want) { + print("# EXPECTED: $want\n"); + print("# GOT: $got\n"); + print("not "); + } + 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 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" ); + } + + 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 to be done because an attempt was made to change a variable +# with the :unique attribute. + +{ + 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++; +} + + +# 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 { + 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++; + if ($] >= 5.008003 && $^O ne 'MSWin32') { + eval { $unique_hash{abc} = 1 }; + print $@ =~ /disallowed/ + ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n"; + } else { + print("ok $test # SKIP $TODO - unique_hash\n"); + } + $test++; + })->join; + +# bugid #24940 :unique should fail on my and sub declarations + +for my $decl ('my $x : unique', 'sub foo : unique') { + { + 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++; + } +} + + +# Returing a closure from a thread caused problems. If the last index in +# the anon sub's pad wasn't for a lexical, then a core dump could occur. +# Otherwise, there might be leaked scalars. + +# XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a +# thread seems to crash win32 + +# sub f { +# my $x = "foo"; +# sub { $x."bar" }; +# } +# +# my $string = threads->create(\&f)->join->(); +# print $string eq 'foobar' ? '' : 'not ', "ok $test - returning closure\n"; +# $test++; + + +# Nothing is checking that total keys gets cloned correctly. + +my %h = (1,2,3,4); +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"); + +lock_keys(%h); +delete($h{1}); + +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"); + +exit(0); + +# EOF diff --git a/dist/threads/t/stack.t b/dist/threads/t/stack.t new file mode 100644 index 0000000000..cfd6cf7c6d --- /dev/null +++ b/dist/threads/t/stack.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +BEGIN { + 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..18\n"); ### Number of tests that will be run ### +}; + +use threads ('stack_size' => 128*4096); +ok(1, 1, 'Loaded'); + +### Start of Testing ### + +ok(2, threads->get_stack_size() == 128*4096, + 'Stack size set in import'); +ok(3, threads->set_stack_size(160*4096) == 128*4096, + 'Set returns previous value'); +ok(4, threads->get_stack_size() == 160*4096, + 'Get stack size'); + +threads->create( + sub { + ok(5, threads->get_stack_size() == 160*4096, + 'Get stack size in thread'); + ok(6, threads->self()->get_stack_size() == 160*4096, + 'Thread gets own stack size'); + ok(7, threads->set_stack_size(128*4096) == 160*4096, + 'Thread changes stack size'); + ok(8, threads->get_stack_size() == 128*4096, + 'Get stack size in thread'); + ok(9, threads->self()->get_stack_size() == 160*4096, + 'Thread stack size unchanged'); + } +)->join(); + +ok(10, threads->get_stack_size() == 128*4096, + 'Default thread sized changed in thread'); + +threads->create( + { 'stack' => 160*4096 }, + sub { + ok(11, threads->get_stack_size() == 128*4096, + 'Get stack size in thread'); + ok(12, threads->self()->get_stack_size() == 160*4096, + 'Thread gets own stack size'); + } +)->join(); + +my $thr = threads->create( { 'stack' => 160*4096 }, sub { } ); + +$thr->create( + sub { + ok(13, threads->get_stack_size() == 128*4096, + 'Get stack size in thread'); + ok(14, threads->self()->get_stack_size() == 160*4096, + 'Thread gets own stack size'); + } +)->join(); + +$thr->create( + { 'stack' => 144*4096 }, + sub { + ok(15, threads->get_stack_size() == 128*4096, + 'Get stack size in thread'); + ok(16, threads->self()->get_stack_size() == 144*4096, + 'Thread gets own stack size'); + ok(17, threads->set_stack_size(160*4096) == 128*4096, + 'Thread changes stack size'); + } +)->join(); + +$thr->join(); + +ok(18, threads->get_stack_size() == 160*4096, + 'Default thread sized changed in thread'); + +exit(0); + +# EOF diff --git a/dist/threads/t/stack_env.t b/dist/threads/t/stack_env.t new file mode 100644 index 0000000000..e36812f361 --- /dev/null +++ b/dist/threads/t/stack_env.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +BEGIN { + 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..4\n"); ### Number of tests that will be run ### + + $ENV{'PERL5_ITHREADS_STACK_SIZE'} = 128*4096; +}; + +use threads; +ok(1, 1, 'Loaded'); + +### Start of Testing ### + +ok(2, threads->get_stack_size() == 128*4096, + '$ENV{PERL5_ITHREADS_STACK_SIZE}'); +ok(3, threads->set_stack_size(144*4096) == 128*4096, + 'Set returns previous value'); +ok(4, threads->get_stack_size() == 144*4096, + 'Get stack size'); + +exit(0); + +# EOF diff --git a/dist/threads/t/state.t b/dist/threads/t/state.t new file mode 100644 index 0000000000..8e4f58ebce --- /dev/null +++ b/dist/threads/t/state.t @@ -0,0 +1,260 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + print("1..0 # SKIP threads::shared not available\n"); + exit(0); + } + + $| = 1; + print("1..59\n"); ### Number of tests that will be run ### +}; + +my $TEST; +BEGIN { + share($TEST); + $TEST = 1; +} + +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 ### + +my ($READY, $GO, $DONE) :shared = (0, 0, 0); + +sub do_thread +{ + { + lock($DONE); + $DONE = 0; + lock($READY); + $READY = 1; + cond_signal($READY); + } + + lock($GO); + while (! $GO) { + cond_wait($GO); + } + $GO = 0; + + lock($READY); + $READY = 0; + lock($DONE); + $DONE = 1; + cond_signal($DONE); +} + +sub wait_until_ready +{ + lock($READY); + while (! $READY) { + cond_wait($READY); + } +} + +sub thread_go +{ + { + lock($GO); + $GO = 1; + cond_signal($GO); + } + + { + lock($DONE); + while (! $DONE) { + cond_wait($DONE); + } + } + threads->yield(); + sleep(1); +} + + +my $thr = threads->create('do_thread'); +wait_until_ready(); +ok($thr->is_running(), 'thread running'); +ok(threads->list(threads::running) == 1, 'thread running list'); +ok(! $thr->is_detached(), 'thread not detached'); +ok(! $thr->is_joinable(), 'thread not joinable'); +ok(threads->list(threads::joinable) == 0, 'thread joinable list'); +ok(threads->list(threads::all) == 1, 'thread list'); + +thread_go(); +ok(! $thr->is_running(), 'thread not running'); +ok(threads->list(threads::running) == 0, 'thread running list'); +ok(! $thr->is_detached(), 'thread not detached'); +ok($thr->is_joinable(), 'thread joinable'); +ok(threads->list(threads::joinable) == 1, 'thread joinable list'); +ok(threads->list(threads::all) == 1, 'thread list'); + +$thr->join(); +ok(! $thr->is_running(), 'thread not running'); +ok(threads->list(threads::running) == 0, 'thread running list'); +ok(! $thr->is_detached(), 'thread not detached'); +ok(! $thr->is_joinable(), 'thread not joinable'); +ok(threads->list(threads::joinable) == 0, 'thread joinable list'); +ok(threads->list(threads::all) == 0, 'thread list'); + +$thr = threads->create('do_thread'); +$thr->detach(); +ok($thr->is_running(), 'thread running'); +ok(threads->list(threads::running) == 0, 'thread running list'); +ok($thr->is_detached(), 'thread detached'); +ok(! $thr->is_joinable(), 'thread not joinable'); +ok(threads->list(threads::joinable) == 0, 'thread joinable list'); +ok(threads->list(threads::all) == 0, 'thread list'); + +thread_go(); +ok(! $thr->is_running(), 'thread not running'); +ok(threads->list(threads::running) == 0, 'thread running list'); +ok($thr->is_detached(), 'thread detached'); +ok(! $thr->is_joinable(), 'thread not joinable'); +ok(threads->list(threads::joinable) == 0, 'thread joinable list'); + +$thr = threads->create(sub { + ok(! threads->is_detached(), 'thread not detached'); + ok(threads->list(threads::running) == 1, 'thread running list'); + ok(threads->list(threads::joinable) == 0, 'thread joinable list'); + ok(threads->list(threads::all) == 1, 'thread list'); + threads->detach(); + do_thread(); + ok(threads->is_detached(), 'thread detached'); + ok(threads->list(threads::running) == 0, 'thread running list'); + ok(threads->list(threads::joinable) == 0, 'thread joinable list'); + ok(threads->list(threads::all) == 0, 'thread list'); +}); + +wait_until_ready(); +ok($thr->is_running(), 'thread running'); +ok(threads->list(threads::running) == 0, 'thread running list'); +ok($thr->is_detached(), 'thread detached'); +ok(! $thr->is_joinable(), 'thread not joinable'); +ok(threads->list(threads::joinable) == 0, 'thread joinable list'); +ok(threads->list(threads::all) == 0, 'thread list'); + +thread_go(); +ok(! $thr->is_running(), 'thread not running'); +ok(threads->list(threads::running) == 0, 'thread running list'); +ok($thr->is_detached(), 'thread detached'); +ok(! $thr->is_joinable(), 'thread not joinable'); +ok(threads->list(threads::joinable) == 0, 'thread joinable list'); + +{ + my $go : shared = 0; + my $t = threads->create( sub { + ok(! threads->is_detached(), 'thread not detached'); + ok(threads->list(threads::running) == 1, 'thread running list'); + ok(threads->list(threads::joinable) == 0, 'thread joinable list'); + ok(threads->list(threads::all) == 1, 'thread list'); + lock($go); $go = 1; cond_signal($go); + }); + + { lock ($go); cond_wait($go) until $go; } + $t->join; +} + +{ + my $rdy :shared = 0; + sub thr_ready + { + lock($rdy); + $rdy++; + cond_signal($rdy); + } + + my $go :shared = 0; + sub thr_wait + { + lock($go); + cond_wait($go) until $go; + } + + my $done :shared = 0; + sub thr_done + { + lock($done); + $done++; + cond_signal($done); + } + + my $thr_routine = sub { thr_ready(); thr_wait(); thr_done(); }; + + # Create 8 threads: + # 3 running, blocking on $go + # 2 running, blocking on $go, join pending + # 2 running, blocking on join of above + # 1 finished, unjoined + + for (1..3) { threads->create($thr_routine); } + + foreach my $t (map {threads->create($thr_routine)} 1..2) { + threads->create(sub { thr_ready(); $_[0]->join; thr_done(); }, $t); + } + threads->create(sub { thr_ready(); thr_done(); }); + { + lock($done); + cond_wait($done) until ($done == 1); + } + { + lock($rdy); + cond_wait($rdy) until ($rdy == 8); + } + threads->yield(); + sleep(1); + + ok(threads->list(threads::running) == 5, 'thread running list'); + ok(threads->list(threads::joinable) == 1, 'thread joinable list'); + ok(threads->list(threads::all) == 6, 'thread all list'); + + { lock($go); $go = 1; cond_broadcast($go); } + { + lock($done); + cond_wait($done) until ($done == 8); + } + threads->yield(); + sleep(1); + + ok(threads->list(threads::running) == 0, 'thread running list'); + # Two awaiting join() have completed + ok(threads->list(threads::joinable) == 6, 'thread joinable list'); + ok(threads->list(threads::all) == 6, 'thread all list'); + + for (threads->list) { $_->join; } +} + +exit(0); + +# EOF diff --git a/dist/threads/t/stress_cv.t b/dist/threads/t/stress_cv.t new file mode 100644 index 0000000000..17380567a7 --- /dev/null +++ b/dist/threads/t/stress_cv.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +my $test = 0; +sub ok { + my ($ok, $name) = @_; + $test++; + + # You have to do it this way or VMS will get confused. + if ($ok) { + print("ok $test - $name\n"); + } else { + print("not ok $test - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + + return ($ok); +} + +BEGIN { + $| = 1; + print("1..61\n"); ### Number of tests that will be run ### +}; + +use threads; +ok(1, 'Loaded'); + +### Start of Testing ### + +my $cnt = 30; + +my @threads; +for (1..$cnt) { + my $thr = threads->create(sub { my $ii = shift; + for (1..500000) { $ii++ } }, $_); + ok($thr, "Thread created - iter $_"); + push(@threads, $thr); +} + +for (1..$cnt) { + my ($result, $thr); + $thr = $threads[$_-1]; + $result = $thr->join if $thr; + ok($thr, "Thread joined - iter $_"); +} + +exit(0); + +# EOF diff --git a/dist/threads/t/stress_re.t b/dist/threads/t/stress_re.t new file mode 100644 index 0000000000..5c25dae736 --- /dev/null +++ b/dist/threads/t/stress_re.t @@ -0,0 +1,65 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +my $test = 0; +sub ok { + my ($ok, $name) = @_; + $test++; + + # You have to do it this way or VMS will get confused. + if ($ok) { + print("ok $test - $name\n"); + } else { + print("not ok $test - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + + return ($ok); +} + +BEGIN { + $| = 1; + print("1..61\n"); ### Number of tests that will be run ### +}; + +use threads; +ok(1, 'Loaded'); + +### Start of Testing ### + +my $cnt = 30; + +sub stress_re { + my $s = "abcd" x (1000 + $_[0]); + my $t = ''; + while ($s =~ /(.)/g) { $t .= $1 } + return ($s eq $t) ? 'ok' : 'not'; +} + +my @threads; +for (1..$cnt) { + my $thr = threads->create('stress_re', $_); + ok($thr, "Thread created - iter $_"); + push(@threads, $thr); +} + +for (1..$cnt) { + my ($result, $thr); + $thr = $threads[$_-1]; + $result = $thr->join if $thr; + ok($thr && defined($result) && ($result eq 'ok'), "Thread joined - iter $_"); +} + +exit(0); + +# EOF diff --git a/dist/threads/t/stress_string.t b/dist/threads/t/stress_string.t new file mode 100644 index 0000000000..7edbbcb8ab --- /dev/null +++ b/dist/threads/t/stress_string.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use ExtUtils::testlib; + +my $test = 0; +sub ok { + my ($ok, $name) = @_; + $test++; + + # You have to do it this way or VMS will get confused. + if ($ok) { + print("ok $test - $name\n"); + } else { + print("not ok $test - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + + return ($ok); +} + +BEGIN { + $| = 1; + print("1..61\n"); ### Number of tests that will be run ### +}; + +use threads; +ok(1, 'Loaded'); + +### Start of Testing ### + +my $cnt = 30; + +sub test9 { + my $i = shift; + for (1..500000) { $i++ }; +} + +my @threads; +for (1..$cnt) { + my $thr = threads->create('test9', $_); + ok($thr, "Thread created - iter $_"); + push(@threads, $thr); +} + +for (1..$cnt) { + my ($result, $thr); + $thr = $threads[$_-1]; + $result = $thr->join if $thr; + ok($thr, "Thread joined - iter $_"); +} + +exit(0); + +# EOF diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t new file mode 100644 index 0000000000..b980c625c0 --- /dev/null +++ b/dist/threads/t/thread.t @@ -0,0 +1,309 @@ +use strict; +use warnings; + +BEGIN { + require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); + + use Config; + if (! $Config{'useithreads'}) { + skip_all(q/Perl not compiled with 'useithreads'/); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + skip_all('threads::shared not available'); + } + + $| = 1; + print("1..34\n"); ### Number of tests that will be run ### +}; + +print("ok 1 - Loaded\n"); + +### Start of Testing ### + +sub content { + print shift; + return shift; +} +{ + my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000); + print $t->join(); +} +{ + my $lock : shared; + my $t; + { + lock($lock); + $t = threads->create(sub { lock($lock); print "ok 5\n"}); + print "ok 4\n"; + } + $t->join(); +} + +sub dorecurse { + my $val = shift; + my $ret; + print $val; + if(@_) { + $ret = threads->create(\&dorecurse, @_); + $ret->join; + } +} +{ + my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10); + $t->join(); +} + +{ + # test that sleep lets other thread run + my $t = threads->create(\&dorecurse, "ok 11\n"); + threads->yield; # help out non-preemptive thread implementations + sleep 1; + print "ok 12\n"; + $t->join(); +} +{ + my $lock : shared; + sub islocked { + 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; +} + + + +sub testsprintf { + my $testno = shift; + my $same = sprintf( "%0.f", $testno); + return $testno eq $same; +} + +sub threaded { + my ($string, $string_end) = @_; + + # Do the match, saving the output in appropriate variables + $string =~ /(.*)(is)(.*)/; + # Yield control, allowing the other thread to fill in the match variables + threads->yield(); + # Examine the match variable contents; on broken perls this fails + return $3 eq $string_end; +} + + +{ + curr_test(15); + + my $thr1 = threads->create(\&testsprintf, 15); + my $thr2 = threads->create(\&testsprintf, 16); + + my $short = "This is a long string that goes on and on."; + my $shorte = " a long string that goes on and on."; + my $long = "This is short."; + my $longe = " short."; + my $foo = "This is bar bar bar."; + my $fooe = " bar bar bar."; + my $thr3 = new threads \&threaded, $short, $shorte; + my $thr4 = new threads \&threaded, $long, $longe; + my $thr5 = new threads \&testsprintf, 19; + my $thr6 = new threads \&testsprintf, 20; + my $thr7 = new threads \&threaded, $foo, $fooe; + + ok($thr1->join()); + ok($thr2->join()); + ok($thr3->join()); + ok($thr4->join()); + ok($thr5->join()); + ok($thr6->join()); + ok($thr7->join()); +} + +# test that 'yield' is importable + +package Test1; + +use threads 'yield'; +yield; +main::ok(1); + +package main; + + +# test async + +{ + my $th = async {return 1 }; + ok($th); + ok($th->join()); +} +{ + # There is a miniscule chance this test case may falsely fail + # since it tests using rand() + my %rand : shared; + rand(10); + threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25; + $_->join foreach threads->list; + ok((keys %rand >= 23), "Check that rand() is randomized in new threads"); +} + +# bugid #24165 + +run_perl(prog => 'use threads 1.74;' . + 'sub a{threads->create(shift)} $t = a sub{};' . + '$t->tid; $t->join; $t->tid', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); +is($?, 0, 'coredump in global destruction'); + +# Attempt to free unreferenced scalar... +fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via scalar'); + use threads; + my $test = sub {}; + threads->create($test)->join(); + print 'ok'; +EOI + +# Attempt to free unreferenced scalar... +fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via $_[0]'); + use threads; + sub thr { threads->new($_[0]); } + thr(sub { })->join; + print 'ok'; +EOI + +# [perl #45053] Memory corruption from eval return in void context +fresh_perl_is(<<'EOI', 'ok', { }, 'void eval return'); + use threads; + threads->create(sub { eval '1' }); + $_->join() for threads->list; + print 'ok'; +EOI + +# test CLONE_SKIP() functionality +SKIP: { + skip('CLONE_SKIP not implemented in Perl < 5.8.7', 5) if ($] < 5.008007); + + my %c : shared; + my %d : shared; + + # --- + + package A; + sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; } + sub DESTROY { $d{"A-". ref $_[0]}++ } + + package A1; + our @ISA = qw(A); + sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; } + sub DESTROY { $d{"A1-". ref $_[0]}++ } + + package A2; + our @ISA = qw(A1); + + # --- + + package B; + sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; } + sub DESTROY { $d{"B-" . ref $_[0]}++ } + + package B1; + our @ISA = qw(B); + sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; } + sub DESTROY { $d{"B1-" . ref $_[0]}++ } + + package B2; + our @ISA = qw(B1); + + # --- + + package C; + sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; } + sub DESTROY { $d{"C-" . ref $_[0]}++ } + + package C1; + our @ISA = qw(C); + sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; } + sub DESTROY { $d{"C1-" . ref $_[0]}++ } + + package C2; + our @ISA = qw(C1); + + # --- + + package D; + sub DESTROY { $d{"D-" . ref $_[0]}++ } + + package D1; + our @ISA = qw(D); + + 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); + } + + 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"); + 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"); +} + +exit(0); + +# EOF diff --git a/dist/threads/threads.pm b/dist/threads/threads.pm new file mode 100644 index 0000000000..8b9b2d8990 --- /dev/null +++ b/dist/threads/threads.pm @@ -0,0 +1,1066 @@ +package threads; + +use 5.008; + +use strict; +use warnings; + +our $VERSION = '1.74'; +my $XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +# Verify this Perl supports threads +require Config; +if (! $Config::Config{useithreads}) { + die("This Perl not built to support threads\n"); +} + +# Complain if 'threads' is loaded after 'threads::shared' +if ($threads::shared::threads_shared) { + warn <<'_MSG_'; +Warning, threads::shared has already been loaded. To +enable shared variables, 'use threads' must be called +before threads::shared or any module that uses it. +_MSG_ +} + +# Declare that we have been loaded +$threads::threads = 1; + +# Load the XS code +require XSLoader; +XSLoader::load('threads', $XS_VERSION); + + +### Export ### + +sub import +{ + my $class = shift; # Not used + + # Exported subroutines + my @EXPORT = qw(async); + + # Handle args + while (my $sym = shift) { + if ($sym =~ /^(?:stack|exit)/i) { + if (defined(my $arg = shift)) { + if ($sym =~ /^stack/i) { + threads->set_stack_size($arg); + } else { + $threads::thread_exit_only = $arg =~ /^thread/i; + } + } else { + require Carp; + Carp::croak("threads: Missing argument for option: $sym"); + } + + } elsif ($sym =~ /^str/i) { + import overload ('""' => \&tid); + + } elsif ($sym =~ /^(?::all|yield)$/) { + push(@EXPORT, qw(yield)); + + } else { + require Carp; + Carp::croak("threads: Unknown import option: $sym"); + } + } + + # Export subroutine names + my $caller = caller(); + foreach my $sym (@EXPORT) { + no strict 'refs'; + *{$caller.'::'.$sym} = \&{$sym}; + } + + # Set stack size via environment variable + if (exists($ENV{'PERL5_ITHREADS_STACK_SIZE'})) { + threads->set_stack_size($ENV{'PERL5_ITHREADS_STACK_SIZE'}); + } +} + + +### Methods, etc. ### + +# Exit from a thread (only) +sub exit +{ + my ($class, $status) = @_; + if (! defined($status)) { + $status = 0; + } + + # Class method only + if (ref($class)) { + require Carp; + Carp::croak('Usage: threads->exit(status)'); + } + + $class->set_thread_exit_only(1); + CORE::exit($status); +} + +# 'Constant' args for threads->list() +sub threads::all { } +sub threads::running { 1 } +sub threads::joinable { 0 } + +# 'new' is an alias for 'create' +*new = \&create; + +# 'async' is a function alias for the 'threads->create()' method +sub async (&;@) +{ + unshift(@_, 'threads'); + # Use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2) + goto &create; +} + +# Thread object equality checking +use overload ( + '==' => \&equal, + '!=' => sub { ! equal(@_) }, + 'fallback' => 1 +); + +1; + +__END__ + +=head1 NAME + +threads - Perl interpreter-based threads + +=head1 VERSION + +This document describes threads version 1.74 + +=head1 SYNOPSIS + + use threads ('yield', + 'stack_size' => 64*4096, + 'exit' => 'threads_only', + 'stringify'); + + sub start_thread { + my @args = @_; + print('Thread started: ', join(' ', @args), "\n"); + } + my $thr = threads->create('start_thread', 'argument'); + $thr->join(); + + threads->create(sub { print("I am a thread\n"); })->join(); + + my $thr2 = async { foreach (@files) { ... } }; + $thr2->join(); + if (my $err = $thr2->error()) { + warn("Thread error: $err\n"); + } + + # Invoke thread in list context (implicit) so it can return a list + my ($thr) = threads->create(sub { return (qw/a b c/); }); + # or specify list context explicitly + my $thr = threads->create({'context' => 'list'}, + sub { return (qw/a b c/); }); + my @results = $thr->join(); + + $thr->detach(); + + # Get a thread's object + $thr = threads->self(); + $thr = threads->object($tid); + + # Get a thread's ID + $tid = threads->tid(); + $tid = $thr->tid(); + $tid = "$thr"; + + # Give other threads a chance to run + threads->yield(); + yield(); + + # Lists of non-detached threads + my @threads = threads->list(); + my $thread_count = threads->list(); + + my @running = threads->list(threads::running); + my @joinable = threads->list(threads::joinable); + + # Test thread objects + if ($thr1 == $thr2) { + ... + } + + # Manage thread stack size + $stack_size = threads->get_stack_size(); + $old_size = threads->set_stack_size(32*4096); + + # Create a thread with a specific context and stack size + my $thr = threads->create({ 'context' => 'list', + 'stack_size' => 32*4096, + 'exit' => 'thread_only' }, + \&foo); + + # Get thread's context + my $wantarray = $thr->wantarray(); + + # Check thread's state + if ($thr->is_running()) { + sleep(1); + } + if ($thr->is_joinable()) { + $thr->join(); + } + + # Send a signal to a thread + $thr->kill('SIGUSR1'); + + # Exit a thread + threads->exit(); + +=head1 DESCRIPTION + +Since Perl 5.8, thread programming has been available using a model called +I<interpreter threads> which provides a new Perl interpreter for each +thread, and, by default, results in no data or state information being shared +between threads. + +(Prior to Perl 5.8, I<5005threads> was available through the C<Thread.pm> API. +This threading model has been deprecated, and was removed as of Perl 5.10.0.) + +As just mentioned, all variables are, by default, thread local. To use shared +variables, you need to also load L<threads::shared>: + + use threads; + use threads::shared; + +When loading L<threads::shared>, you must C<use threads> before you +C<use threads::shared>. (C<threads> will emit a warning if you do it the +other way around.) + +It is strongly recommended that you enable threads via C<use threads> as early +as possible in your script. + +If needed, scripts can be written so as to run on both threaded and +non-threaded Perls: + + my $can_use_threads = eval 'use threads; 1'; + if ($can_use_threads) { + # Do processing using threads + ... + } else { + # Do it without using threads + ... + } + +=over + +=item $thr = threads->create(FUNCTION, ARGS) + +This will create a new thread that will begin execution with the specified +entry point function, and give it the I<ARGS> list as parameters. It will +return the corresponding threads object, or C<undef> if thread creation failed. + +I<FUNCTION> may either be the name of a function, an anonymous subroutine, or +a code ref. + + my $thr = threads->create('func_name', ...); + # or + my $thr = threads->create(sub { ... }, ...); + # or + my $thr = threads->create(\&func, ...); + +The C<-E<gt>new()> method is an alias for C<-E<gt>create()>. + +=item $thr->join() + +This will wait for the corresponding thread to complete its execution. When +the thread finishes, C<-E<gt>join()> will return the return value(s) of the +entry point function. + +The context (void, scalar or list) for the return value(s) for C<-E<gt>join()> +is determined at the time of thread creation. + + # Create thread in list context (implicit) + my ($thr1) = threads->create(sub { + my @results = qw(a b c); + return (@results); + }); + # or (explicit) + my $thr1 = threads->create({'context' => 'list'}, + sub { + my @results = qw(a b c); + return (@results); + }); + # Retrieve list results from thread + my @res1 = $thr1->join(); + + # Create thread in scalar context (implicit) + my $thr2 = threads->create(sub { + my $result = 42; + return ($result); + }); + # Retrieve scalar result from thread + my $res2 = $thr2->join(); + + # Create a thread in void context (explicit) + my $thr3 = threads->create({'void' => 1}, + sub { print("Hello, world\n"); }); + # Join the thread in void context (i.e., no return value) + $thr3->join(); + +See L</"THREAD CONTEXT"> for more details. + +If the program exits without all threads having either been joined or +detached, then a warning will be issued. + +Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already joined thread will +cause an error to be thrown. + +=item $thr->detach() + +Makes the thread unjoinable, and causes any eventual return value to be +discarded. When the program exits, any detached threads that are still +running are silently terminated. + +If the program exits without all threads having either been joined or +detached, then a warning will be issued. + +Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already detached thread +will cause an error to be thrown. + +=item threads->detach() + +Class method that allows a thread to detach itself. + +=item threads->self() + +Class method that allows a thread to obtain its own I<threads> object. + +=item $thr->tid() + +Returns the ID of the thread. Thread IDs are unique integers with the main +thread in a program being 0, and incrementing by 1 for every thread created. + +=item threads->tid() + +Class method that allows a thread to obtain its own ID. + +=item "$thr" + +If you add the C<stringify> import option to your C<use threads> declaration, +then using a threads object in a string or a string context (e.g., as a hash +key) will cause its ID to be used as the value: + + use threads qw(stringify); + + my $thr = threads->create(...); + print("Thread $thr started...\n"); # Prints out: Thread 1 started... + +=item threads->object($tid) + +This will return the I<threads> object for the I<active> thread associated +with the specified thread ID. Returns C<undef> if there is no thread +associated with the TID, if the thread is joined or detached, if no TID is +specified or if the specified TID is undef. + +=item threads->yield() + +This is a suggestion to the OS to let this thread yield CPU time to other +threads. What actually happens is highly dependent upon the underlying +thread implementation. + +You may do C<use threads qw(yield)>, and then just use C<yield()> in your +code. + +=item threads->list() + +=item threads->list(threads::all) + +=item threads->list(threads::running) + +=item threads->list(threads::joinable) + +With no arguments (or using C<threads::all>) and in a list context, returns a +list of all non-joined, non-detached I<threads> objects. In a scalar context, +returns a count of the same. + +With a I<true> argument (using C<threads::running>), returns a list of all +non-joined, non-detached I<threads> objects that are still running. + +With a I<false> argument (using C<threads::joinable>), returns a list of all +non-joined, non-detached I<threads> objects that have finished running (i.e., +for which C<-E<gt>join()> will not I<block>). + +=item $thr1->equal($thr2) + +Tests if two threads objects are the same thread or not. This is overloaded +to the more natural forms: + + if ($thr1 == $thr2) { + print("Threads are the same\n"); + } + # or + if ($thr1 != $thr2) { + print("Threads differ\n"); + } + +(Thread comparison is based on thread IDs.) + +=item async BLOCK; + +C<async> creates a thread to execute the block immediately following +it. This block is treated as an anonymous subroutine, and so must have a +semicolon after the closing brace. Like C<threads-E<gt>create()>, C<async> +returns a I<threads> object. + +=item $thr->error() + +Threads are executed in an C<eval> context. This method will return C<undef> +if the thread terminates I<normally>. Otherwise, it returns the value of +C<$@> associated with the thread's execution status in its C<eval> context. + +=item $thr->_handle() + +This I<private> method returns the memory location of the internal thread +structure associated with a threads object. For Win32, this is a pointer to +the C<HANDLE> value returned by C<CreateThread> (i.e., C<HANDLE *>); for other +platforms, it is a pointer to the C<pthread_t> structure used in the +C<pthread_create> call (i.e., C<pthread_t *>). + +This method is of no use for general Perl threads programming. Its intent is +to provide other (XS-based) thread modules with the capability to access, and +possibly manipulate, the underlying thread structure associated with a Perl +thread. + +=item threads->_handle() + +Class method that allows a thread to obtain its own I<handle>. + +=back + +=head1 EXITING A THREAD + +The usual method for terminating a thread is to +L<return()|perlfunc/"return EXPR"> from the entry point function with the +appropriate return value(s). + +=over + +=item threads->exit() + +If needed, a thread can be exited at any time by calling +C<threads-E<gt>exit()>. This will cause the thread to return C<undef> in a +scalar context, or the empty list in a list context. + +When called from the I<main> thread, this behaves the same as C<exit(0)>. + +=item threads->exit(status) + +When called from a thread, this behaves like C<threads-E<gt>exit()> (i.e., the +exit status code is ignored). + +When called from the I<main> thread, this behaves the same as C<exit(status)>. + +=item die() + +Calling C<die()> in a thread indicates an abnormal exit for the thread. Any +C<$SIG{__DIE__}> handler in the thread will be called first, and then the +thread will exit with a warning message that will contain any arguments passed +in the C<die()> call. + +=item exit(status) + +Calling L<exit()|perlfunc/"exit EXPR"> inside a thread causes the whole +application to terminate. Because of this, the use of C<exit()> inside +threaded code, or in modules that might be used in threaded applications, is +strongly discouraged. + +If C<exit()> really is needed, then consider using the following: + + threads->exit() if threads->can('exit'); # Thread friendly + exit(status); + +=item use threads 'exit' => 'threads_only' + +This globally overrides the default behavior of calling C<exit()> inside a +thread, and effectively causes such calls to behave the same as +C<threads-E<gt>exit()>. In other words, with this setting, calling C<exit()> +causes only the thread to terminate. + +Because of its global effect, this setting should not be used inside modules +or the like. + +The I<main> thread is unaffected by this setting. + +=item threads->create({'exit' => 'thread_only'}, ...) + +This overrides the default behavior of C<exit()> inside the newly created +thread only. + +=item $thr->set_thread_exit_only(boolean) + +This can be used to change the I<exit thread only> behavior for a thread after +it has been created. With a I<true> argument, C<exit()> will cause only the +thread to exit. With a I<false> argument, C<exit()> will terminate the +application. + +The I<main> thread is unaffected by this call. + +=item threads->set_thread_exit_only(boolean) + +Class method for use inside a thread to change its own behavior for C<exit()>. + +The I<main> thread is unaffected by this call. + +=back + +=head1 THREAD STATE + +The following boolean methods are useful in determining the I<state> of a +thread. + +=over + +=item $thr->is_running() + +Returns true if a thread is still running (i.e., if its entry point function +has not yet finished or exited). + +=item $thr->is_joinable() + +Returns true if the thread has finished running, is not detached and has not +yet been joined. In other words, the thread is ready to be joined, and a call +to C<$thr-E<gt>join()> will not I<block>. + +=item $thr->is_detached() + +Returns true if the thread has been detached. + +=item threads->is_detached() + +Class method that allows a thread to determine whether or not it is detached. + +=back + +=head1 THREAD CONTEXT + +As with subroutines, the type of value returned from a thread's entry point +function may be determined by the thread's I<context>: list, scalar or void. +The thread's context is determined at thread creation. This is necessary so +that the context is available to the entry point function via +L<wantarray()|perlfunc/"wantarray">. The thread may then specify a value of +the appropriate type to be returned from C<-E<gt>join()>. + +=head2 Explicit context + +Because thread creation and thread joining may occur in different contexts, it +may be desirable to state the context explicitly to the thread's entry point +function. This may be done by calling C<-E<gt>create()> with a hash reference +as the first argument: + + my $thr = threads->create({'context' => 'list'}, \&foo); + ... + my @results = $thr->join(); + +In the above, the threads object is returned to the parent thread in scalar +context, and the thread's entry point function C<foo> will be called in list +(array) context such that the parent thread can receive a list (array) from +the C<-E<gt>join()> call. (C<'array'> is synonymous with C<'list'>.) + +Similarly, if you need the threads object, but your thread will not be +returning a value (i.e., I<void> context), you would do the following: + + my $thr = threads->create({'context' => 'void'}, \&foo); + ... + $thr->join(); + +The context type may also be used as the I<key> in the hash reference followed +by a I<true> value: + + threads->create({'scalar' => 1}, \&foo); + ... + my ($thr) = threads->list(); + my $result = $thr->join(); + +=head2 Implicit context + +If not explicitly stated, the thread's context is implied from the context +of the C<-E<gt>create()> call: + + # Create thread in list context + my ($thr) = threads->create(...); + + # Create thread in scalar context + my $thr = threads->create(...); + + # Create thread in void context + threads->create(...); + +=head2 $thr->wantarray() + +This returns the thread's context in the same manner as +L<wantarray()|perlfunc/"wantarray">. + +=head2 threads->wantarray() + +Class method to return the current thread's context. This returns the same +value as running L<wantarray()|perlfunc/"wantarray"> inside the current +thread's entry point function. + +=head1 THREAD STACK SIZE + +The default per-thread stack size for different platforms varies +significantly, and is almost always far more than is needed for most +applications. On Win32, Perl's makefile explicitly sets the default stack to +16 MB; on most other platforms, the system default is used, which again may be +much larger than is needed. + +By tuning the stack size to more accurately reflect your application's needs, +you may significantly reduce your application's memory usage, and increase the +number of simultaneously running threads. + +Note that on Windows, address space allocation granularity is 64 KB, +therefore, setting the stack smaller than that on Win32 Perl will not save any +more memory. + +=over + +=item threads->get_stack_size(); + +Returns the current default per-thread stack size. The default is zero, which +means the system default stack size is currently in use. + +=item $size = $thr->get_stack_size(); + +Returns the stack size for a particular thread. A return value of zero +indicates the system default stack size was used for the thread. + +=item $old_size = threads->set_stack_size($new_size); + +Sets a new default per-thread stack size, and returns the previous setting. + +Some platforms have a minimum thread stack size. Trying to set the stack size +below this value will result in a warning, and the minimum stack size will be +used. + +Some Linux platforms have a maximum stack size. Setting too large of a stack +size will cause thread creation to fail. + +If needed, C<$new_size> will be rounded up to the next multiple of the memory +page size (usually 4096 or 8192). + +Threads created after the stack size is set will then either call +C<pthread_attr_setstacksize()> I<(for pthreads platforms)>, or supply the +stack size to C<CreateThread()> I<(for Win32 Perl)>. + +(Obviously, this call does not affect any currently extant threads.) + +=item use threads ('stack_size' => VALUE); + +This sets the default per-thread stack size at the start of the application. + +=item $ENV{'PERL5_ITHREADS_STACK_SIZE'} + +The default per-thread stack size may be set at the start of the application +through the use of the environment variable C<PERL5_ITHREADS_STACK_SIZE>: + + PERL5_ITHREADS_STACK_SIZE=1048576 + export PERL5_ITHREADS_STACK_SIZE + perl -e'use threads; print(threads->get_stack_size(), "\n")' + +This value overrides any C<stack_size> parameter given to C<use threads>. Its +primary purpose is to permit setting the per-thread stack size for legacy +threaded applications. + +=item threads->create({'stack_size' => VALUE}, FUNCTION, ARGS) + +To specify a particular stack size for any individual thread, call +C<-E<gt>create()> with a hash reference as the first argument: + + my $thr = threads->create({'stack_size' => 32*4096}, \&foo, @args); + +=item $thr2 = $thr1->create(FUNCTION, ARGS) + +This creates a new thread (C<$thr2>) that inherits the stack size from an +existing thread (C<$thr1>). This is shorthand for the following: + + my $stack_size = $thr1->get_stack_size(); + my $thr2 = threads->create({'stack_size' => $stack_size}, FUNCTION, ARGS); + +=back + +=head1 THREAD SIGNALLING + +When safe signals is in effect (the default behavior - see L</"Unsafe signals"> +for more details), then signals may be sent and acted upon by individual +threads. + +=over 4 + +=item $thr->kill('SIG...'); + +Sends the specified signal to the thread. Signal names and (positive) signal +numbers are the same as those supported by +L<kill()|perlfunc/"kill SIGNAL, LIST">. For example, 'SIGTERM', 'TERM' and +(depending on the OS) 15 are all valid arguments to C<-E<gt>kill()>. + +Returns the thread object to allow for method chaining: + + $thr->kill('SIG...')->join(); + +=back + +Signal handlers need to be set up in the threads for the signals they are +expected to act upon. Here's an example for I<cancelling> a thread: + + use threads; + + sub thr_func + { + # Thread 'cancellation' signal handler + $SIG{'KILL'} = sub { threads->exit(); }; + + ... + } + + # Create a thread + my $thr = threads->create('thr_func'); + + ... + + # Signal the thread to terminate, and then detach + # it so that it will get cleaned up automatically + $thr->kill('KILL')->detach(); + +Here's another simplistic example that illustrates the use of thread +signalling in conjunction with a semaphore to provide rudimentary I<suspend> +and I<resume> capabilities: + + use threads; + use Thread::Semaphore; + + sub thr_func + { + my $sema = shift; + + # Thread 'suspend/resume' signal handler + $SIG{'STOP'} = sub { + $sema->down(); # Thread suspended + $sema->up(); # Thread resumes + }; + + ... + } + + # Create a semaphore and pass it to a thread + my $sema = Thread::Semaphore->new(); + my $thr = threads->create('thr_func', $sema); + + # Suspend the thread + $sema->down(); + $thr->kill('STOP'); + + ... + + # Allow the thread to continue + $sema->up(); + +CAVEAT: The thread signalling capability provided by this module does not +actually send signals via the OS. It I<emulates> signals at the Perl-level +such that signal handlers are called in the appropriate thread. For example, +sending C<$thr-E<gt>kill('STOP')> does not actually suspend a thread (or the +whole process), but does cause a C<$SIG{'STOP'}> handler to be called in that +thread (as illustrated above). + +As such, signals that would normally not be appropriate to use in the +C<kill()> command (e.g., C<kill('KILL', $$)>) are okay to use with the +C<-E<gt>kill()> method (again, as illustrated above). + +Correspondingly, sending a signal to a thread does not disrupt the operation +the thread is currently working on: The signal will be acted upon after the +current operation has completed. For instance, if the thread is I<stuck> on +an I/O call, sending it a signal will not cause the I/O call to be interrupted +such that the signal is acted up immediately. + +Sending a signal to a terminated thread is ignored. + +=head1 WARNINGS + +=over 4 + +=item Perl exited with active threads: + +If the program exits without all threads having either been joined or +detached, then this warning will be issued. + +NOTE: If the I<main> thread exits, then this warning cannot be suppressed +using C<no warnings 'threads';> as suggested below. + +=item Thread creation failed: pthread_create returned # + +See the appropriate I<man> page for C<pthread_create> to determine the actual +cause for the failure. + +=item Thread # terminated abnormally: ... + +A thread terminated in some manner other than just returning from its entry +point function, or by using C<threads-E<gt>exit()>. For example, the thread +may have terminated because of an error, or by using C<die>. + +=item Using minimum thread stack size of # + +Some platforms have a minimum thread stack size. Trying to set the stack size +below this value will result in the above warning, and the stack size will be +set to the minimum. + +=item Thread creation failed: pthread_attr_setstacksize(I<SIZE>) returned 22 + +The specified I<SIZE> exceeds the system's maximum stack size. Use a smaller +value for the stack size. + +=back + +If needed, thread warnings can be suppressed by using: + + no warnings 'threads'; + +in the appropriate scope. + +=head1 ERRORS + +=over 4 + +=item This Perl not built to support threads + +The particular copy of Perl that you're trying to use was not built using the +C<useithreads> configuration option. + +Having threads support requires all of Perl and all of the XS modules in the +Perl installation to be rebuilt; it is not just a question of adding the +L<threads> module (i.e., threaded and non-threaded Perls are binary +incompatible.) + +=item Cannot change stack size of an existing thread + +The stack size of currently extant threads cannot be changed, therefore, the +following results in the above error: + + $thr->set_stack_size($size); + +=item Cannot signal threads without safe signals + +Safe signals must be in effect to use the C<-E<gt>kill()> signalling method. +See L</"Unsafe signals"> for more details. + +=item Unrecognized signal name: ... + +The particular copy of Perl that you're trying to use does not support the +specified signal being used in a C<-E<gt>kill()> call. + +=back + +=head1 BUGS AND LIMITATIONS + +Before you consider posting a bug report, please consult, and possibly post a +message to the discussion forum to see if what you've encountered is a known +problem. + +=over + +=item Thread-safe modules + +See L<perlmod/"Making your module threadsafe"> when creating modules that may +be used in threaded applications, especially if those modules use non-Perl +data, or XS code. + +=item Using non-thread-safe modules + +Unfortunately, you may encounter Perl modules that are not I<thread-safe>. +For example, they may crash the Perl interpreter during execution, or may dump +core on termination. Depending on the module and the requirements of your +application, it may be possible to work around such difficulties. + +If the module will only be used inside a thread, you can try loading the +module from inside the thread entry point function using C<require> (and +C<import> if needed): + + sub thr_func + { + require Unsafe::Module + # Unsafe::Module->import(...); + + .... + } + +If the module is needed inside the I<main> thread, try modifying your +application so that the module is loaded (again using C<require> and +C<-E<gt>import()>) after any threads are started, and in such a way that no +other threads are started afterwards. + +If the above does not work, or is not adequate for your application, then file +a bug report on L<http://rt.cpan.org/Public/> against the problematic module. + +=item Current working directory + +On all platforms except MSWin32, the setting for the current working directory +is shared among all threads such that changing it in one thread (e.g., using +C<chdir()>) will affect all the threads in the application. + +On MSWin32, each thread maintains its own the current working directory +setting. + +=item Environment variables + +Currently, on all platforms except MSWin32, all I<system> calls (e.g., using +C<system()> or back-ticks) made from threads use the environment variable +settings from the I<main> thread. In other words, changes made to C<%ENV> in +a thread will not be visible in I<system> calls made by that thread. + +To work around this, set environment variables as part of the I<system> call. +For example: + + my $msg = 'hello'; + system("FOO=$msg; echo \$FOO"); # Outputs 'hello' to STDOUT + +On MSWin32, each thread maintains its own set of environment variables. + +=item Parent-child threads + +On some platforms, it might not be possible to destroy I<parent> threads while +there are still existing I<child> threads. + +=item Creating threads inside special blocks + +Creating threads inside C<BEGIN>, C<CHECK> or C<INIT> blocks should not be +relied upon. Depending on the Perl version and the application code, results +may range from success, to (apparently harmless) warnings of leaked scalar, or +all the way up to crashing of the Perl interpreter. + +=item Unsafe signals + +Since Perl 5.8.0, signals have been made safer in Perl by postponing their +handling until the interpreter is in a I<safe> state. See +L<perl58delta/"Safe Signals"> and L<perlipc/"Deferred Signals (Safe Signals)"> +for more details. + +Safe signals is the default behavior, and the old, immediate, unsafe +signalling behavior is only in effect in the following situations: + +=over 4 + +=item * Perl has been built with C<PERL_OLD_SIGNALS> (see C<perl -V>). + +=item * The environment variable C<PERL_SIGNALS> is set to C<unsafe> (see L<perlrun/"PERL_SIGNALS">). + +=item * The module L<Perl::Unsafe::Signals> is used. + +=back + +If unsafe signals is in effect, then signal handling is not thread-safe, and +the C<-E<gt>kill()> signalling method cannot be used. + +=item Returning closures from threads + +Returning closures from threads should not be relied upon. Depending of the +Perl version and the application code, results may range from success, to +(apparently harmless) warnings of leaked scalar, or all the way up to crashing +of the Perl interpreter. + +=item Returning objects from threads + +Returning objects from threads does not work. Depending on the classes +involved, you may be able to work around this by returning a serialized +version of the object (e.g., using L<Data::Dumper> or L<Storable>), and then +reconstituting it in the joining thread. If you're using Perl 5.10.0 or +later, and if the class supports L<shared objects|threads::shared/"OBJECTS">, +you can pass them via L<shared queues| Thread::Queue>. + +=item END blocks in threads + +It is possible to add L<END blocks|perlmod/"BEGIN, UNITCHECK, CHECK, INIT and +END"> to threads by using L<require|perlfunc/"require VERSION"> or +L<eval|perlfunc/"eval EXPR"> with the appropriate code. These C<END> blocks +will then be executed when the thread's interpreter is destroyed (i.e., either +during a C<-E<gt>join()> call, or at program termination). + +However, calling any L<threads> methods in such an C<END> block will most +likely I<fail> (e.g., the application may hang, or generate an error) due to +mutexes that are needed to control functionality within the L<threads> module. + +For this reason, the use of C<END> blocks in threads is B<strongly> +discouraged. + +=item Perl Bugs and the CPAN Version of L<threads> + +Support for threads extends beyond the code in this module (i.e., +F<threads.pm> and F<threads.xs>), and into the Perl interpreter itself. Older +versions of Perl contain bugs that may manifest themselves despite using the +latest version of L<threads> from CPAN. There is no workaround for this other +than upgrading to the latest version of Perl. + +Even with the latest version of Perl, it is known that certain constructs +with threads may result in warning messages concerning leaked scalars or +unreferenced scalars. However, such warnings are harmless, and may safely be +ignored. + +You can search for L<threads> related bug reports at +L<http://rt.cpan.org/Public/>. If needed submit any new bugs, problems, +patches, etc. to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads> + +=back + +=head1 REQUIREMENTS + +Perl 5.8.0 or later + +=head1 SEE ALSO + +L<threads> Discussion Forum on CPAN: +L<http://www.cpanforum.com/dist/threads> + +Annotated POD for L<threads>: +L<http://annocpan.org/~JDHEDDEN/threads-1.74/threads.pm> + +Source repository: +L<http://code.google.com/p/threads-shared/> + +L<threads::shared>, L<perlthrtut> + +L<http://www.perl.com/pub/a/2002/06/11/threads.html> and +L<http://www.perl.com/pub/a/2002/09/04/threads.html> + +Perl threads mailing list: +L<http://lists.cpan.org/showlist.cgi?name=iThreads> + +Stack size discussion: +L<http://www.perlmonks.org/?node_id=532956> + +=head1 AUTHOR + +Artur Bergman E<lt>sky AT crucially DOT netE<gt> + +CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org> + +=head1 LICENSE + +threads is released under the same license as Perl. + +=head1 ACKNOWLEDGEMENTS + +Richard Soderberg E<lt>perl AT crystalflame DOT netE<gt> - +Helping me out tons, trying to find reasons for races and other weird bugs! + +Simon Cozens E<lt>simon AT brecon DOT co DOT ukE<gt> - +Being there to answer zillions of annoying questions + +Rocco Caputo E<lt>troc AT netrus DOT netE<gt> + +Vipul Ved Prakash E<lt>mail AT vipul DOT netE<gt> - +Helping with debugging + +Dean Arnold E<lt>darnold AT presicient DOT comE<gt> - +Stack size API + +=cut diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs new file mode 100755 index 0000000000..7d0ad23c31 --- /dev/null +++ b/dist/threads/threads.xs @@ -0,0 +1,1687 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +/* Workaround for XSUB.h bug under WIN32 */ +#ifdef WIN32 +# undef setjmp +# if !defined(__BORLANDC__) +# define setjmp(x) _setjmp(x) +# endif +#endif +#ifdef HAS_PPPORT_H +# define NEED_PL_signals +# define NEED_newRV_noinc +# define NEED_sv_2pv_flags +# include "ppport.h" +# include "threads.h" +#endif + +#ifdef USE_ITHREADS + +#ifdef WIN32 +# include <windows.h> + /* Supposed to be in Winbase.h */ +# ifndef STACK_SIZE_PARAM_IS_A_RESERVATION +# define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000 +# endif +# include <win32thread.h> +#else +# ifdef OS2 +typedef perl_os_thread pthread_t; +# else +# include <pthread.h> +# endif +# include <thread.h> +# 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 +#if !defined(HAS_GETPAGESIZE) && defined(I_SYS_PARAM) +# include <sys/param.h> +#endif + +/* Values for 'state' member */ +#define PERL_ITHR_DETACHED 1 /* Thread has been detached */ +#define PERL_ITHR_JOINED 2 /* Thread has been joined */ +#define PERL_ITHR_FINISHED 4 /* Thread has finished execution */ +#define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */ +#define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */ +#define PERL_ITHR_DIED 32 /* Thread finished by dying */ + +#define PERL_ITHR_UNCALLABLE (PERL_ITHR_DETACHED|PERL_ITHR_JOINED) + + +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; /* Reference count. See S_ithread_create. */ + 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 */ +#else + pthread_t thr; /* OS's handle for the thread */ +#endif + IV stack_size; + SV *err; /* Error from abnormally terminated thread */ + char *err_class; /* Error object's classname if applicable */ +#ifndef WIN32 + sigset_t initial_sigmask; /* Thread wakes up with signals blocked */ +#endif +} ithread; + + +#define MY_CXT_KEY "threads::_cxt" XS_VERSION + +typedef struct { + /* Used by Perl interpreter for thread context switching */ + ithread *context; +} my_cxt_t; + +START_MY_CXT + + +#define MY_POOL_KEY "threads::_pool" XS_VERSION + +typedef struct { + /* Structure for 'main' thread + * Also forms the 'base' for the doubly-linked list of threads */ + ithread main_thread; + + /* Protects the creation and destruction of threads*/ + perl_mutex create_destruct_mutex; + + UV tid_counter; + IV joinable_threads; + IV running_threads; + IV detached_threads; + IV total_threads; + IV default_stack_size; + IV page_size; +} my_pool_t; + +#define dMY_POOL \ + SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, \ + sizeof(MY_POOL_KEY)-1, TRUE); \ + my_pool_t *my_poolp = INT2PTR(my_pool_t*, SvUV(my_pool_sv)) + +#define MY_POOL (*my_poolp) + +#ifndef WIN32 +/* Block most signals for calling thread, setting the old signal mask to + * oldmask, if it is not NULL */ +STATIC int +S_block_most_signals(sigset_t *oldmask) +{ + sigset_t newmask; + + sigfillset(&newmask); + /* Don't block certain "important" signals (stolen from mg.c) */ +#ifdef SIGILL + sigdelset(&newmask, SIGILL); +#endif +#ifdef SIGBUS + sigdelset(&newmask, SIGBUS); +#endif +#ifdef SIGSEGV + sigdelset(&newmask, SIGSEGV); +#endif + +#if defined(VMS) + /* no per-thread blocking available */ + return sigprocmask(SIG_BLOCK, &newmask, oldmask); +#else + return pthread_sigmask(SIG_BLOCK, &newmask, oldmask); +#endif /* VMS */ +} + +/* Set the signal mask for this thread to newmask */ +STATIC int +S_set_sigmask(sigset_t *newmask) +{ +#if defined(VMS) + return sigprocmask(SIG_SETMASK, newmask, NULL); +#else + return pthread_sigmask(SIG_SETMASK, newmask, NULL); +#endif /* VMS */ +} +#endif /* WIN32 */ + +/* Used by Perl interpreter for thread context switching */ +STATIC void +S_ithread_set(pTHX_ ithread *thread) +{ + dMY_CXT; + MY_CXT.context = thread; +} + +STATIC ithread * +S_ithread_get(pTHX) +{ + dMY_CXT; + return (MY_CXT.context); +} + + +/* 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 locked. Also, + * must be called with MY_POOL.create_destruct_mutex unlocked as destruction + * of the interpreter can lead to recursive destruction calls that could + * lead to a deadlock on that mutex. + */ +STATIC void +S_ithread_clear(pTHX_ ithread *thread) +{ + PerlInterpreter *interp; +#ifndef WIN32 + sigset_t origmask; +#endif + + assert(((thread->state & PERL_ITHR_FINISHED) && + (thread->state & PERL_ITHR_UNCALLABLE)) + || + (thread->state & PERL_ITHR_NONVIABLE)); + +#ifndef WIN32 + /* We temporarily set the interpreter context to the interpreter being + * destroyed. It's in no condition to handle signals while it's being + * taken apart. + */ + S_block_most_signals(&origmask); +#endif + + interp = thread->interp; + if (interp) { + dTHXa(interp); + + PERL_SET_CONTEXT(interp); + S_ithread_set(aTHX_ thread); + + SvREFCNT_dec(thread->params); + thread->params = Nullsv; + + if (thread->err) { + SvREFCNT_dec(thread->err); + thread->err = Nullsv; + } + + perl_destruct(interp); + perl_free(interp); + thread->interp = NULL; + } + + PERL_SET_CONTEXT(aTHX); +#ifndef WIN32 + S_set_sigmask(&origmask); +#endif +} + + +/* Decrement the refcount of an ithread, and if it reaches zero, free it. + * Must be called with the mutex held. + * On return, mutex is released (or destroyed). + */ +STATIC void +S_ithread_free(pTHX_ ithread *thread) +{ +#ifdef WIN32 + HANDLE handle; +#endif + dMY_POOL; + + if (! (thread->state & PERL_ITHR_NONVIABLE)) { + assert(thread->count > 0); + if (--thread->count > 0) { + MUTEX_UNLOCK(&thread->mutex); + return; + } + assert((thread->state & PERL_ITHR_FINISHED) && + (thread->state & PERL_ITHR_UNCALLABLE)); + } + MUTEX_UNLOCK(&thread->mutex); + + /* Main thread (0) is immortal and should never get here */ + assert(thread->tid != 0); + + /* Remove from circular list of threads */ + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + assert(thread->prev && thread->next); + thread->next->prev = thread->prev; + thread->prev->next = thread->next; + thread->next = NULL; + thread->prev = NULL; + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + + /* Thread is now disowned */ + MUTEX_LOCK(&thread->mutex); + S_ithread_clear(aTHX_ thread); + +#ifdef WIN32 + handle = thread->handle; + thread->handle = NULL; +#endif + MUTEX_UNLOCK(&thread->mutex); + MUTEX_DESTROY(&thread->mutex); + +#ifdef WIN32 + if (handle) { + CloseHandle(handle); + } +#endif + + PerlMemShared_free(thread); + + /* total_threads >= 1 is used to veto cleanup by the main thread, + * should it happen to exit while other threads still exist. + * Decrement this as the very last thing in the thread's existence. + * Otherwise, MY_POOL and global state such as PL_op_mutex may get + * freed while we're still using it. + */ + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + MY_POOL.total_threads--; + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); +} + + +static void +S_ithread_count_inc(pTHX_ ithread *thread) +{ + MUTEX_LOCK(&thread->mutex); + thread->count++; + MUTEX_UNLOCK(&thread->mutex); +} + + +/* Warn if exiting with any unjoined threads */ +STATIC int +S_exit_warning(pTHX) +{ + int veto_cleanup, warn; + dMY_POOL; + + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + veto_cleanup = (MY_POOL.total_threads > 0); + warn = (MY_POOL.running_threads || MY_POOL.joinable_threads); + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + + if (warn) { + if (ckWARN_d(WARN_THREADS)) { + Perl_warn(aTHX_ "Perl exited with active threads:\n\t%" + IVdf " running and unjoined\n\t%" + IVdf " finished and unjoined\n\t%" + IVdf " running and detached\n", + MY_POOL.running_threads, + MY_POOL.joinable_threads, + MY_POOL.detached_threads); + } + } + + return (veto_cleanup); +} + + +/* Called from perl_destruct() in each thread. If it's the main thread, + * stop it from freeing everything if there are other threads still running. + */ +int +Perl_ithread_hook(pTHX) +{ + dMY_POOL; + return ((aTHX == MY_POOL.main_thread.interp) ? S_exit_warning(aTHX) : 0); +} + + +/* MAGIC (in mg.h sense) hooks */ + +int +ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) +{ + ithread *thread = (ithread *)mg->mg_ptr; + SvIV_set(sv, PTR2IV(thread)); + SvIOK_on(sv); + return (0); +} + +int +ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) +{ + ithread *thread = (ithread *)mg->mg_ptr; + MUTEX_LOCK(&thread->mutex); + S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + return (0); +} + +int +ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) +{ + S_ithread_count_inc(aTHX_ (ithread *)mg->mg_ptr); + 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 */ +}; + + +/* Provided default, minimum and rational stack sizes */ +STATIC IV +S_good_stack_size(pTHX_ IV stack_size) +{ + dMY_POOL; + + /* Use default stack size if no stack size specified */ + if (! stack_size) { + return (MY_POOL.default_stack_size); + } + +#ifdef PTHREAD_STACK_MIN + /* Can't use less than minimum */ + if (stack_size < PTHREAD_STACK_MIN) { + if (ckWARN(WARN_THREADS)) { + Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN); + } + return (PTHREAD_STACK_MIN); + } +#endif + + /* Round up to page size boundary */ + if (MY_POOL.page_size <= 0) { +#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) + SETERRNO(0, SS_NORMAL); +# ifdef _SC_PAGESIZE + MY_POOL.page_size = sysconf(_SC_PAGESIZE); +# else + MY_POOL.page_size = sysconf(_SC_MMAP_PAGE_SIZE); +# endif + if ((long)MY_POOL.page_size < 0) { + if (errno) { + SV * const error = get_sv("@", 0); + (void)SvUPGRADE(error, SVt_PV); + Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error)); + } else { + Perl_croak(aTHX_ "PANIC: sysconf: pagesize unknown"); + } + } +#else +# ifdef HAS_GETPAGESIZE + MY_POOL.page_size = getpagesize(); +# else +# if defined(I_SYS_PARAM) && defined(PAGESIZE) + MY_POOL.page_size = PAGESIZE; +# else + MY_POOL.page_size = 8192; /* A conservative default */ +# endif +# endif + if (MY_POOL.page_size <= 0) { + Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)MY_POOL.page_size); + } +#endif + } + stack_size = ((stack_size + (MY_POOL.page_size - 1)) / MY_POOL.page_size) * MY_POOL.page_size; + + return (stack_size); +} + + +/* 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) +#else +STATIC void * +S_ithread_run(void * arg) +#endif +{ + ithread *thread = (ithread *)arg; + int jmp_rc = 0; + I32 oldscope; + int exit_app = 0; /* Thread terminated using 'exit' */ + int exit_code = 0; + int died = 0; /* Thread terminated abnormally */ + + dJMPENV; + + dTHXa(thread->interp); + + dMY_POOL; + + /* Blocked until ->create() call finishes */ + MUTEX_LOCK(&thread->mutex); + MUTEX_UNLOCK(&thread->mutex); + + PERL_SET_CONTEXT(thread->interp); + S_ithread_set(aTHX_ thread); + +#ifndef WIN32 + /* Thread starts with most signals blocked - restore the signal mask from + * the ithread struct. + */ + S_set_sigmask(&thread->initial_sigmask); +#endif + + PL_perl_destruct_level = 2; + + { + 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; + + oldscope = PL_scopestack_ix; + JMPENV_PUSH(jmp_rc); + if (jmp_rc == 0) { + /* Run the specified function */ + len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); + } else if (jmp_rc == 2) { + /* Thread exited */ + exit_app = 1; + exit_code = STATUS_CURRENT; + while (PL_scopestack_ix > oldscope) { + LEAVE; + } + } + JMPENV_POP; + +#ifndef WIN32 + /* The interpreter is finished, so this thread can stop receiving + * signals. This way, our signal handler doesn't get called in the + * middle of our parent thread calling perl_destruct()... + */ + S_block_most_signals(NULL); +#endif + + /* Remove args from stack and put back in params array */ + SPAGAIN; + for (ii=len-1; ii >= 0; ii--) { + SV *sv = POPs; + if (jmp_rc == 0 && (thread->gimme & G_WANT) != G_VOID) { + av_store(params, ii, SvREFCNT_inc(sv)); + } + } + + FREETMPS; + LEAVE; + + /* Check for abnormal termination */ + if (SvTRUE(ERRSV)) { + died = PERL_ITHR_DIED; + thread->err = newSVsv(ERRSV); + /* If ERRSV is an object, remember the classname and then + * rebless into 'main' so it will survive 'cloning' + */ + if (sv_isobject(thread->err)) { + thread->err_class = HvNAME(SvSTASH(SvRV(thread->err))); + sv_bless(thread->err, gv_stashpv("main", 0)); + } + + if (ckWARN_d(WARN_THREADS)) { + oldscope = PL_scopestack_ix; + JMPENV_PUSH(jmp_rc); + if (jmp_rc == 0) { + /* Warn that thread died */ + Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV); + } else if (jmp_rc == 2) { + /* Warn handler exited */ + exit_app = 1; + exit_code = STATUS_CURRENT; + while (PL_scopestack_ix > oldscope) { + LEAVE; + } + } + JMPENV_POP; + } + } + + /* Release function ref */ + SvREFCNT_dec(thread->init_function); + thread->init_function = Nullsv; + } + + PerlIO_flush((PerlIO *)NULL); + + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + MUTEX_LOCK(&thread->mutex); + /* Mark as finished */ + thread->state |= (PERL_ITHR_FINISHED | died); + /* Clear exit flag if required */ + if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) { + exit_app = 0; + } + + /* Adjust thread status counts */ + if (thread->state & PERL_ITHR_DETACHED) { + MY_POOL.detached_threads--; + } else { + MY_POOL.running_threads--; + MY_POOL.joinable_threads++; + } + MUTEX_UNLOCK(&thread->mutex); + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + + /* Exit application if required */ + if (exit_app) { + oldscope = PL_scopestack_ix; + JMPENV_PUSH(jmp_rc); + if (jmp_rc == 0) { + /* Warn if there are unjoined threads */ + S_exit_warning(aTHX); + } else if (jmp_rc == 2) { + /* Warn handler exited */ + exit_code = STATUS_CURRENT; + while (PL_scopestack_ix > oldscope) { + LEAVE; + } + } + JMPENV_POP; + + my_exit(exit_code); + } + + /* At this point, the interpreter may have been freed, so call + * free in the the context of of the 'main' interpreter which + * can't have been freed due to the veto_cleanup mechanism. + */ + aTHX = MY_POOL.main_thread.interp; + + MUTEX_LOCK(&thread->mutex); + S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + +#ifdef WIN32 + return ((DWORD)0); +#else + return (0); +#endif +} + + +/* Type conversion helper functions */ + +STATIC SV * +S_ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) +{ + SV *sv; + MAGIC *mg; + + if (inc) + S_ithread_count_inc(aTHX_ thread); + + 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); + mg->mg_flags |= MGf_DUP; + SvREADONLY_on(sv); + + return (obj); +} + +STATIC ithread * +S_SV_to_ithread(pTHX_ SV *sv) +{ + /* 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)); +} + + +/* threads->create() + * Called in context of parent thread. + * Called with MY_POOL.create_destruct_mutex locked. (Unlocked on error.) + */ +STATIC ithread * +S_ithread_create( + pTHX_ SV *init_function, + IV stack_size, + int gimme, + int exit_opt, + SV *params) +{ + ithread *thread; + ithread *current_thread = S_ithread_get(aTHX); + + SV **tmps_tmp = PL_tmps_stack; + IV tmps_ix = PL_tmps_ix; +#ifndef WIN32 + int rc_stack_size = 0; + int rc_thread_create = 0; +#endif + dMY_POOL; + + /* Allocate thread structure in context of the main thread's interpreter */ + { + PERL_SET_CONTEXT(MY_POOL.main_thread.interp); + thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); + } + PERL_SET_CONTEXT(aTHX); + if (!thread) { + MUTEX_UNLOCK(&MY_POOL.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 = &MY_POOL.main_thread; + thread->prev = MY_POOL.main_thread.prev; + MY_POOL.main_thread.prev = thread; + thread->prev->next = thread; + MY_POOL.total_threads++; + + /* 1 ref to be held by the local var 'thread' in S_ithread_run(). + * 1 ref to be held by the threads object that we assume we will + * be embedded in upon our return. + * 1 ref to be the responsibility of join/detach, so we don't get + * freed until join/detach, even if no thread objects remain. + * This allows the following to work: + * { threads->create(sub{...}); } threads->object(1)->join; + */ + thread->count = 3; + + /* Block new thread until ->create() call finishes */ + MUTEX_INIT(&thread->mutex); + MUTEX_LOCK(&thread->mutex); + + thread->tid = MY_POOL.tid_counter++; + thread->stack_size = S_good_stack_size(aTHX_ stack_size); + thread->gimme = gimme; + thread->state = exit_opt; + + /* "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 */ + +#ifndef WIN32 + /* perl_clone() will leave us the new interpreter's context. This poses + * two problems for our signal handler. First, it sets the new context + * before the new interpreter struct is fully initialized, so our signal + * handler might find bogus data in the interpreter struct it gets. + * Second, even if the interpreter is initialized before a signal comes in, + * we would like to avoid that interpreter receiving notifications for + * signals (especially when they ought to be for the one running in this + * thread), until it is running in its own thread. Another problem is that + * the new thread will not have set the context until some time after it + * has started, so it won't be safe for our signal handler to run until + * that time. + * + * So we block most signals here, so the new thread will inherit the signal + * mask, and unblock them right after the thread creation. The original + * mask is saved in the thread struct so that the new thread can restore + * the original mask. + */ + S_block_most_signals(&thread->initial_sigmask); +#endif + +#ifdef WIN32 + thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); +#else + 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. + */ + { + CLONE_PARAMS clone_param; + + 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; + if (SvPOK(init_function)) { + thread->init_function = newSV(0); + sv_copypv(thread->init_function, init_function); + } else { + thread->init_function = + SvREFCNT_inc(sv_dup(init_function, &clone_param)); + } + + thread->params = sv_dup(params, &clone_param); + SvREFCNT_inc_void(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_void(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, + (DWORD)thread->stack_size, + S_ithread_run, + (LPVOID)thread, + STACK_SIZE_PARAM_IS_A_RESERVATION, + &thread->thr); +#else + { + 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 + /* Threads start out joinable */ + PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); +# endif + +# ifdef _POSIX_THREAD_ATTR_STACKSIZE + /* Set thread's stack size */ + if (thread->stack_size > 0) { + rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size); + } +# endif + + /* 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 + } + +#ifndef WIN32 + /* Now it's safe to accept signals, since we're in our own interpreter's + * context and we have created the thread. + */ + S_set_sigmask(&thread->initial_sigmask); +#endif + +# ifdef _POSIX_THREAD_ATTR_STACKSIZE + /* Try to get thread's actual stack size */ + { + size_t stacksize; +#ifdef HPUX1020 + stacksize = pthread_attr_getstacksize(attr); +#else + if (! pthread_attr_getstacksize(&attr, &stacksize)) +#endif + if (stacksize > 0) { + thread->stack_size = (IV)stacksize; + } + } +# endif + } +#endif + + /* Check for errors */ +#ifdef WIN32 + if (thread->handle == NULL) { +#else + if (rc_stack_size || rc_thread_create) { +#endif + /* Must unlock mutex for destruct call */ + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + sv_2mortal(params); + thread->state |= PERL_ITHR_NONVIABLE; + S_ithread_free(aTHX_ thread); /* Releases MUTEX */ +#ifndef WIN32 + if (ckWARN_d(WARN_THREADS)) { + if (rc_stack_size) { + Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size); + } else { + Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); + } + } +#endif + return (NULL); + } + + MY_POOL.running_threads++; + sv_2mortal(params); + return (thread); +} + +#endif /* USE_ITHREADS */ + + +MODULE = threads PACKAGE = threads PREFIX = ithread_ +PROTOTYPES: DISABLE + +#ifdef USE_ITHREADS + +void +ithread_create(...) + PREINIT: + char *classname; + ithread *thread; + SV *function_to_call; + AV *params; + HV *specs; + IV stack_size; + int context; + int exit_opt; + SV *thread_exit_only; + char *str; + int idx; + int ii; + dMY_POOL; + CODE: + if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) { + if (--items < 2) { + Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)"); + } + specs = (HV*)SvRV(ST(1)); + idx = 1; + } else { + if (items < 2) { + Perl_croak(aTHX_ "Usage: threads->create(function, ...)"); + } + specs = NULL; + idx = 0; + } + + if (sv_isobject(ST(0))) { + /* $thr->create() */ + classname = HvNAME(SvSTASH(SvRV(ST(0)))); + thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&thread->mutex); + stack_size = thread->stack_size; + exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY; + MUTEX_UNLOCK(&thread->mutex); + } else { + /* threads->create() */ + classname = (char *)SvPV_nolen(ST(0)); + stack_size = MY_POOL.default_stack_size; + thread_exit_only = get_sv("threads::thread_exit_only", GV_ADD); + exit_opt = (SvTRUE(thread_exit_only)) + ? PERL_ITHR_THREAD_EXIT_ONLY : 0; + } + + function_to_call = ST(idx+1); + + context = -1; + if (specs) { + /* stack_size */ + if (hv_exists(specs, "stack", 5)) { + stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0)); + } else if (hv_exists(specs, "stacksize", 9)) { + stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0)); + } else if (hv_exists(specs, "stack_size", 10)) { + stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0)); + } + + /* context */ + if (hv_exists(specs, "context", 7)) { + str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0)); + switch (*str) { + case 'a': + case 'A': + case 'l': + case 'L': + context = G_ARRAY; + break; + case 's': + case 'S': + context = G_SCALAR; + break; + case 'v': + case 'V': + context = G_VOID; + break; + default: + Perl_croak(aTHX_ "Invalid context: %s", str); + } + } else if (hv_exists(specs, "array", 5)) { + if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) { + context = G_ARRAY; + } + } else if (hv_exists(specs, "list", 4)) { + if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) { + context = G_ARRAY; + } + } else if (hv_exists(specs, "scalar", 6)) { + if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) { + context = G_SCALAR; + } + } else if (hv_exists(specs, "void", 4)) { + if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) { + context = G_VOID; + } + } + + /* exit => thread_only */ + if (hv_exists(specs, "exit", 4)) { + str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0)); + exit_opt = (*str == 't' || *str == 'T') + ? PERL_ITHR_THREAD_EXIT_ONLY : 0; + } + } + if (context == -1) { + context = GIMME_V; /* Implicit context */ + } else { + context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID))); + } + + /* Function args */ + params = newAV(); + if (items > 2) { + for (ii=2; ii < items ; ii++) { + av_push(params, SvREFCNT_inc(ST(idx+ii))); + } + } + + /* Create thread */ + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + thread = S_ithread_create(aTHX_ function_to_call, + stack_size, + context, + exit_opt, + newRV_noinc((SV*)params)); + if (! thread) { + XSRETURN_UNDEF; /* Mutex already unlocked */ + } + ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE)); + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + + /* Let thread run */ + MUTEX_UNLOCK(&thread->mutex); + + /* XSRETURN(1); - implied */ + + +void +ithread_list(...) + PREINIT: + char *classname; + ithread *thread; + int list_context; + IV count = 0; + int want_running = 0; + int state; + dMY_POOL; + PPCODE: + /* Class method only */ + if (SvROK(ST(0))) { + Perl_croak(aTHX_ "Usage: threads->list(...)"); + } + classname = (char *)SvPV_nolen(ST(0)); + + /* Calling context */ + list_context = (GIMME_V == G_ARRAY); + + /* Running or joinable parameter */ + if (items > 1) { + want_running = SvTRUE(ST(1)); + } + + /* Walk through threads list */ + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + for (thread = MY_POOL.main_thread.next; + thread != &MY_POOL.main_thread; + thread = thread->next) + { + MUTEX_LOCK(&thread->mutex); + state = thread->state; + MUTEX_UNLOCK(&thread->mutex); + + /* Ignore detached or joined threads */ + if (state & PERL_ITHR_UNCALLABLE) { + continue; + } + + /* Filter per parameter */ + if (items > 1) { + if (want_running) { + if (state & PERL_ITHR_FINISHED) { + continue; /* Not running */ + } + } else { + if (! (state & PERL_ITHR_FINISHED)) { + continue; /* Still running - not joinable yet */ + } + } + } + + /* Push object on stack if list context */ + if (list_context) { + XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); + } + count++; + } + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + /* If scalar context, send back count */ + if (! list_context) { + XSRETURN_IV(count); + } + + +void +ithread_self(...) + PREINIT: + char *classname; + ithread *thread; + CODE: + /* Class method only */ + if ((items != 1) || SvROK(ST(0))) { + Perl_croak(aTHX_ "Usage: threads->self()"); + } + classname = (char *)SvPV_nolen(ST(0)); + + thread = S_ithread_get(aTHX); + + ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); + /* XSRETURN(1); - implied */ + + +void +ithread_tid(...) + PREINIT: + ithread *thread; + CODE: + PERL_UNUSED_VAR(items); + thread = S_SV_to_ithread(aTHX_ ST(0)); + XST_mUV(0, thread->tid); + /* XSRETURN(1); - implied */ + + +void +ithread_join(...) + PREINIT: + ithread *thread; + ithread *current_thread; + int join_err; + AV *params = NULL; + int len; + int ii; +#ifndef WIN32 + int rc_join; + void *retval; +#endif + dMY_POOL; + PPCODE: + /* Object method only */ + if ((items != 1) || ! sv_isobject(ST(0))) { + Perl_croak(aTHX_ "Usage: $thr->join()"); + } + + /* Check if the thread is joinable and not ourselves */ + thread = S_SV_to_ithread(aTHX_ ST(0)); + current_thread = S_ithread_get(aTHX); + + MUTEX_LOCK(&thread->mutex); + if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) { + MUTEX_UNLOCK(&thread->mutex); + Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED) + ? "Cannot join a detached thread" + : "Thread already joined"); + } else if (thread->tid == current_thread->tid) { + MUTEX_UNLOCK(&thread->mutex); + Perl_croak(aTHX_ "Cannot join self"); + } + + /* Mark as joined */ + thread->state |= PERL_ITHR_JOINED; + MUTEX_UNLOCK(&thread->mutex); + + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + MY_POOL.joinable_threads--; + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + + /* Join the thread */ +#ifdef WIN32 + if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) { + /* Timeout/abandonment unexpected here; check $^E */ + Perl_croak(aTHX_ "PANIC: underlying join failed"); + }; +#else + if ((rc_join = pthread_join(thread->thr, &retval)) != 0) { + /* In progress/deadlock/unknown unexpected here; check $! */ + errno = rc_join; + Perl_croak(aTHX_ "PANIC: underlying join failed"); + }; +#endif + + MUTEX_LOCK(&thread->mutex); + /* Get the return value from the call_sv */ + /* Objects do not survive this process - FIXME */ + if ((thread->gimme & G_WANT) != G_VOID) { + AV *params_copy; + PerlInterpreter *other_perl; + CLONE_PARAMS clone_params; + + params_copy = (AV *)SvRV(thread->params); + other_perl = thread->interp; + clone_params.stashes = newAV(); + clone_params.flags = CLONEf_JOIN_IN; + PL_ptr_table = ptr_table_new(); + S_ithread_set(aTHX_ thread); + /* Ensure 'meaningful' addresses retain their meaning */ + ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); + ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); + ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); + params = (AV *)sv_dup((SV*)params_copy, &clone_params); + S_ithread_set(aTHX_ current_thread); + SvREFCNT_dec(clone_params.stashes); + SvREFCNT_inc_void(params); + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } + + /* If thread didn't die, then we can free its interpreter */ + if (! (thread->state & PERL_ITHR_DIED)) { + S_ithread_clear(aTHX_ thread); + } + S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + + /* If no return values, then just return */ + if (! params) { + XSRETURN_UNDEF; + } + + /* Put return values on stack */ + len = (int)AvFILL(params); + for (ii=0; ii <= len; ii++) { + SV* param = av_shift(params); + XPUSHs(sv_2mortal(param)); + } + + /* Free return value array */ + SvREFCNT_dec(params); + + +void +ithread_yield(...) + CODE: + PERL_UNUSED_VAR(items); + YIELD; + + +void +ithread_detach(...) + PREINIT: + ithread *thread; + int detach_err; + dMY_POOL; + CODE: + PERL_UNUSED_VAR(items); + + /* Detach the thread */ + thread = S_SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + MUTEX_LOCK(&thread->mutex); + if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) { + /* Thread is detachable */ + thread->state |= PERL_ITHR_DETACHED; +#ifdef WIN32 + /* Windows has no 'detach thread' function */ +#else + PERL_THREAD_DETACH(thread->thr); +#endif + if (thread->state & PERL_ITHR_FINISHED) { + MY_POOL.joinable_threads--; + } else { + MY_POOL.running_threads--; + MY_POOL.detached_threads++; + } + } + MUTEX_UNLOCK(&thread->mutex); + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + + if (detach_err) { + Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED) + ? "Thread already detached" + : "Cannot detach a joined thread"); + } + + /* If thread is finished and didn't die, + * then we can free its interpreter */ + MUTEX_LOCK(&thread->mutex); + if ((thread->state & PERL_ITHR_FINISHED) && + ! (thread->state & PERL_ITHR_DIED)) + { + S_ithread_clear(aTHX_ thread); + } + S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + + +void +ithread_kill(...) + PREINIT: + ithread *thread; + char *sig_name; + IV signal; + CODE: + /* Must have safe signals */ + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { + Perl_croak(aTHX_ "Cannot signal threads without safe signals"); + } + + /* Object method only */ + if ((items != 2) || ! sv_isobject(ST(0))) { + Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')"); + } + + /* Get signal */ + sig_name = SvPV_nolen(ST(1)); + if (isALPHA(*sig_name)) { + if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') { + sig_name += 3; + } + if ((signal = whichsig(sig_name)) < 0) { + Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name); + } + } else { + signal = SvIV(ST(1)); + } + + /* Set the signal for the thread */ + thread = S_SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + if (thread->interp) { + dTHXa(thread->interp); + PL_psig_pend[signal]++; + PL_sig_pending = 1; + } + MUTEX_UNLOCK(&thread->mutex); + + /* Return the thread to allow for method chaining */ + ST(0) = ST(0); + /* XSRETURN(1); - implied */ + + +void +ithread_DESTROY(...) + CODE: + PERL_UNUSED_VAR(items); + sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar); + + +void +ithread_equal(...) + PREINIT: + int are_equal = 0; + CODE: + PERL_UNUSED_VAR(items); + + /* 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)))); + 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 */ + + +void +ithread_object(...) + PREINIT: + char *classname; + UV tid; + ithread *thread; + int state; + int have_obj = 0; + dMY_POOL; + CODE: + /* Class method only */ + if (SvROK(ST(0))) { + Perl_croak(aTHX_ "Usage: threads->object($tid)"); + } + classname = (char *)SvPV_nolen(ST(0)); + + if ((items < 2) || ! SvOK(ST(1))) { + XSRETURN_UNDEF; + } + + /* threads->object($tid) */ + tid = SvUV(ST(1)); + + /* Walk through threads list */ + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + for (thread = MY_POOL.main_thread.next; + thread != &MY_POOL.main_thread; + thread = thread->next) + { + /* Look for TID */ + if (thread->tid == tid) { + /* Ignore if detached or joined */ + MUTEX_LOCK(&thread->mutex); + state = thread->state; + MUTEX_UNLOCK(&thread->mutex); + if (! (state & PERL_ITHR_UNCALLABLE)) { + /* Put object on stack */ + ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); + have_obj = 1; + } + break; + } + } + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + + if (! have_obj) { + XSRETURN_UNDEF; + } + /* XSRETURN(1); - implied */ + + +void +ithread__handle(...); + PREINIT: + ithread *thread; + CODE: + PERL_UNUSED_VAR(items); + thread = S_SV_to_ithread(aTHX_ ST(0)); +#ifdef WIN32 + XST_mUV(0, PTR2UV(&thread->handle)); +#else + XST_mUV(0, PTR2UV(&thread->thr)); +#endif + /* XSRETURN(1); - implied */ + + +void +ithread_get_stack_size(...) + PREINIT: + IV stack_size; + dMY_POOL; + CODE: + PERL_UNUSED_VAR(items); + if (sv_isobject(ST(0))) { + /* $thr->get_stack_size() */ + ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + stack_size = thread->stack_size; + } else { + /* threads->get_stack_size() */ + stack_size = MY_POOL.default_stack_size; + } + XST_mIV(0, stack_size); + /* XSRETURN(1); - implied */ + + +void +ithread_set_stack_size(...) + PREINIT: + IV old_size; + dMY_POOL; + CODE: + if (items != 2) { + Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)"); + } + if (sv_isobject(ST(0))) { + Perl_croak(aTHX_ "Cannot change stack size of an existing thread"); + } + if (! looks_like_number(ST(1))) { + Perl_croak(aTHX_ "Stack size must be numeric"); + } + + old_size = MY_POOL.default_stack_size; + MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1))); + XST_mIV(0, old_size); + /* XSRETURN(1); - implied */ + + +void +ithread_is_running(...) + PREINIT: + ithread *thread; + CODE: + /* Object method only */ + if ((items != 1) || ! sv_isobject(ST(0))) { + Perl_croak(aTHX_ "Usage: $thr->is_running()"); + } + + thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&thread->mutex); + ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + + +void +ithread_is_detached(...) + PREINIT: + ithread *thread; + CODE: + PERL_UNUSED_VAR(items); + thread = S_SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + + +void +ithread_is_joinable(...) + PREINIT: + ithread *thread; + CODE: + /* Object method only */ + if ((items != 1) || ! sv_isobject(ST(0))) { + Perl_croak(aTHX_ "Usage: $thr->is_joinable()"); + } + + thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&thread->mutex); + ST(0) = ((thread->state & PERL_ITHR_FINISHED) && + ! (thread->state & PERL_ITHR_UNCALLABLE)) + ? &PL_sv_yes : &PL_sv_no; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + + +void +ithread_wantarray(...) + PREINIT: + ithread *thread; + CODE: + PERL_UNUSED_VAR(items); + thread = S_SV_to_ithread(aTHX_ ST(0)); + ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes : + ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef + /* G_SCALAR */ : &PL_sv_no; + /* XSRETURN(1); - implied */ + + +void +ithread_set_thread_exit_only(...) + PREINIT: + ithread *thread; + CODE: + if (items != 2) { + Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)"); + } + thread = S_SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + if (SvTRUE(ST(1))) { + thread->state |= PERL_ITHR_THREAD_EXIT_ONLY; + } else { + thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY; + } + MUTEX_UNLOCK(&thread->mutex); + + +void +ithread_error(...) + PREINIT: + ithread *thread; + SV *err = NULL; + CODE: + /* Object method only */ + if ((items != 1) || ! sv_isobject(ST(0))) { + Perl_croak(aTHX_ "Usage: $thr->err()"); + } + + thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&thread->mutex); + + /* If thread died, then clone the error into the calling thread */ + if (thread->state & PERL_ITHR_DIED) { + PerlInterpreter *other_perl; + CLONE_PARAMS clone_params; + ithread *current_thread; + + other_perl = thread->interp; + clone_params.stashes = newAV(); + clone_params.flags = CLONEf_JOIN_IN; + PL_ptr_table = ptr_table_new(); + current_thread = S_ithread_get(aTHX); + S_ithread_set(aTHX_ thread); + /* Ensure 'meaningful' addresses retain their meaning */ + ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); + ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); + ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); + err = sv_dup(thread->err, &clone_params); + S_ithread_set(aTHX_ current_thread); + SvREFCNT_dec(clone_params.stashes); + SvREFCNT_inc_void(err); + /* If error was an object, bless it into the correct class */ + if (thread->err_class) { + sv_bless(err, gv_stashpv(thread->err_class, 1)); + } + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } + + MUTEX_UNLOCK(&thread->mutex); + + if (! err) { + XSRETURN_UNDEF; + } + + ST(0) = sv_2mortal(err); + /* XSRETURN(1); - implied */ + + +#endif /* USE_ITHREADS */ + + +BOOT: +{ +#ifdef USE_ITHREADS + SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, + sizeof(MY_POOL_KEY)-1, TRUE); + my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1)); + + MY_CXT_INIT; + + Zero(my_poolp, 1, my_pool_t); + sv_setuv(my_pool_sv, PTR2UV(my_poolp)); + + PL_perl_destruct_level = 2; + MUTEX_INIT(&MY_POOL.create_destruct_mutex); + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + + PL_threadhook = &Perl_ithread_hook; + + MY_POOL.tid_counter = 1; +# ifdef THREAD_CREATE_NEEDS_STACK + MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK; +# endif + + /* The 'main' thread is thread 0. + * It is detached (unjoinable) and immortal. + */ + + MUTEX_INIT(&MY_POOL.main_thread.mutex); + + /* Head of the threads list */ + MY_POOL.main_thread.next = &MY_POOL.main_thread; + MY_POOL.main_thread.prev = &MY_POOL.main_thread; + + MY_POOL.main_thread.count = 1; /* Immortal */ + + MY_POOL.main_thread.interp = aTHX; + MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */ + MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size; +# ifdef WIN32 + MY_POOL.main_thread.thr = GetCurrentThreadId(); +# else + MY_POOL.main_thread.thr = pthread_self(); +# endif + + S_ithread_set(aTHX_ &MY_POOL.main_thread); + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); +#endif /* USE_ITHREADS */ +} |