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