From: Jerry D. Hedden Date: Thu, 6 Jul 2006 07:33:13 +0000 (-0700) Subject: threads 1.34 - state methods X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ead3295200d473d7e8131c8284d762c13903f6d8;p=p5sagit%2Fp5-mst-13.2.git threads 1.34 - state methods From: "Jerry D. Hedden" Message-ID: <20060706073313.fb30e530d17747c2b054d625b8945d88.baa39d91bc.wbe@email.secureserver.net> p4raw-id: //depot/perl@28501 --- diff --git a/MANIFEST b/MANIFEST index 473888b..5c8b6dc 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1178,6 +1178,7 @@ ext/threads/t/list.t Test threads->list() ext/threads/t/problems.t Test various memory problems ext/threads/t/stack_env.t Tests for stack limits ext/threads/t/stack.t Tests for stack limits +ext/threads/t/state.t Tests state methods ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument. ext/threads/t/stress_re.t Test with multiple threads, string cv argument and regexes. ext/threads/t/stress_string.t Test with multiple threads, string cv argument. diff --git a/ext/threads/Changes b/ext/threads/Changes index c86f243..5581b8f 100755 --- a/ext/threads/Changes +++ b/ext/threads/Changes @@ -1,5 +1,9 @@ Revision history for Perl extension threads. +1.34 Thu Jul 6 10:29:37 EDT 2006 + - Added ->is_running, ->is_detached, ->is_joinable, ->wantarray + - Enhanced ->list to return running or joinable threads + 1.33 Mon Jul 3 10:11:20 EDT 2006 - 'exit' inside a thread silently terminates thread only - Added 'threads->exit()' (just calls CORE::exit(0)) diff --git a/ext/threads/README b/ext/threads/README index d8706ac..a753098 100755 --- a/ext/threads/README +++ b/ext/threads/README @@ -1,4 +1,4 @@ -threads version 1.33 +threads version 1.34 ==================== This module needs perl 5.8.0 or later compiled with 'useithreads'. diff --git a/ext/threads/t/context.t b/ext/threads/t/context.t index fda0233..d23bbd0 100644 --- a/ext/threads/t/context.t +++ b/ext/threads/t/context.t @@ -28,7 +28,7 @@ BEGIN { } $| = 1; - print("1..13\n"); ### Number of tests that will be run ### + print("1..31\n"); ### Number of tests that will be run ### }; my $TEST; @@ -101,4 +101,59 @@ $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 'array', 'Array context'); + return ('array'); + } elsif (defined($wantarray)) { + ok($context eq 'scalar', 'Scalar context'); + return 'scalar'; + } else { + ok($context eq 'void', 'Void context'); + return; + } +} + +($thr) = threads->create('bar', 'array'); +my $ctx = $thr->wantarray(); +ok($ctx, 'Implicit array context'); +($res) = $thr->join(); +ok($res eq 'array', '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' => 'array'}, 'bar', 'array'); +$ctx = $thr->wantarray(); +ok($ctx, 'Explicit array context'); +($res) = $thr->join(); +ok($res eq 'array', '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'); + # EOF diff --git a/ext/threads/t/state.t b/ext/threads/t/state.t new file mode 100644 index 0000000..331cd8c --- /dev/null +++ b/ext/threads/t/state.t @@ -0,0 +1,190 @@ +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; + +BEGIN { + eval { + require threads::shared; + import threads::shared; + }; + if ($@ || ! $threads::shared::threads_shared) { + print("1..0 # Skip: threads::shared not available\n"); + exit(0); + } + + $| = 1; + print("1..53\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'); + +$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'); +})->join(); + +# EOF diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t index 73b7e3a..bd44660 100644 --- a/ext/threads/t/thread.t +++ b/ext/threads/t/thread.t @@ -171,7 +171,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.33; +run_perl(prog => 'use threads 1.34; sub a{threads->create(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index 7e5cffb..43a3be9 100755 --- a/ext/threads/threads.pm +++ b/ext/threads/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.33'; +our $VERSION = '1.34'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -80,6 +80,11 @@ sub exit CORE::exit(0); } +# 'Constant' args for threads->list() +sub threads::all { } +sub threads::running { 1 } +sub threads::joinable { 0 } + # 'new' is an alias for 'create' *new = \&create; @@ -108,7 +113,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.33 +This document describes threads version 1.34 =head1 SYNOPSIS @@ -148,6 +153,9 @@ This document describes threads version 1.33 my @threads = threads->list(); my $thread_count = threads->list(); + my @running = threads->list(threads::running); + my @joinable = threads->list(threads::joinable); + if ($thr1 == $thr2) { ... } @@ -159,7 +167,17 @@ This document describes threads version 1.33 my $thr = threads->create({ 'context' => 'list', 'stack_size' => 32*4096 }, \&foo); - my @results = $thr->join(); + + # Get thread's context + my $wantarray = $thr->wantarray(); + + # Check thread's state + if ($thr->is_running()) { + sleep(1); + } + if ($thr->is_joinable()) { + $thr->join(); + } $thr->kill('SIGUSR1'); @@ -319,8 +337,22 @@ code. =item threads->list() -In a list context, returns a list of all non-joined, non-detached I -objects. In a scalar context, returns a count of the same. +=item threads->list(threads::all) + +=item threads->list(threads::running) + +=item threads->list(threads::joinable) + +With no arguments (or using C) and in a list context, returns a +list of all non-joined, non-detached I objects. In a scalar context, +returns a count of the same. + +With a I argument (using C), returns a list of all +non-detached I objects that are still running. + +With a I argument (using C), returns a list of all +non-joined, non-detached I objects that have finished running (i.e., +for which C<-Ejoin()> will not I). =item $thr1->equal($thr2) @@ -363,6 +395,34 @@ Class method that allows a thread to obtain its own I. =back +=head1 THREAD STATE + +The following boolean methods are useful in determining the I 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/exited). + +=item $thr->is_joinable() + +Returns true if the thread has finished running, is not detached and has not +yet been joined. In other works, the thread is ready to be joined and will +not I. + +=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 @@ -415,6 +475,16 @@ of the C<-Ecreate()> call: # Create thread in void context threads->create(...); +=head2 $thr->wantarray() + +This returns the thread's context in the same manner as +L. + +=head2 threads->wantarray() + +Class method to return the current thread's context. This is the same as +running L in the current thread. + =head1 THREAD STACK SIZE The default per-thread stack size for different platforms varies @@ -737,7 +807,7 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L L, L diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 5e6d16c..40bd2d1 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -122,8 +122,8 @@ S_ithread_clear(pTHX_ ithread *thread) { PerlInterpreter *interp; - assert(thread->state & PERL_ITHR_FINISHED && - thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)); + assert((thread->state & PERL_ITHR_FINISHED) && + (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))); interp = thread->interp; if (interp) { @@ -827,15 +827,21 @@ ithread_list(...) ithread *thread; int list_context; IV count = 0; + int want_running; PPCODE: /* Class method only */ if (SvROK(ST(0))) - Perl_croak(aTHX_ "Usage: threads->list()"); + 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(&create_destruct_mutex); for (thread = threads->next; @@ -846,6 +852,20 @@ ithread_list(...) if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { continue; } + + /* Filter per parameter */ + if (items > 1) { + if (want_running) { + if (thread->state & PERL_ITHR_FINISHED) { + continue; /* Not running */ + } + } else { + if (! (thread->state & PERL_ITHR_FINISHED)) { + continue; /* Still running - not joinable yet */ + } + } + } + /* Push object on stack if list context */ if (list_context) { XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); @@ -1185,6 +1205,66 @@ ithread_set_stack_size(...) XST_mIV(0, old_size); /* XSRETURN(1); - implied */ + +void +ithread_is_running(...) + PREINIT: + ithread *thread; + CODE: + /* Object method only */ + if (! 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: + thread = 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 (! 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_DETACHED|PERL_ITHR_JOINED))) + ? &PL_sv_yes : &PL_sv_no; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + + +void +ithread_wantarray(...) + PREINIT: + ithread *thread; + CODE: + thread = SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes : + (thread->gimme & G_VOID) ? &PL_sv_undef + /* G_SCALAR */ : &PL_sv_no; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + #endif /* USE_ITHREADS */