diff options
| -rwxr-xr-x | ext/threads/threads.pm | 129 | ||||
| -rwxr-xr-x | ext/threads/threads.xs | 228 |
2 files changed, 164 insertions, 193 deletions
diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index b5be201896..e217ddecee 100755 --- a/ext/threads/threads.pm +++ b/ext/threads/threads.pm @@ -1,50 +1,38 @@ package threads; use 5.008; + use strict; use warnings; -use Config; - -BEGIN { - unless ($Config{useithreads}) { - my @caller = caller(2); - die <<EOF; -$caller[1] line $caller[2]: -This Perl hasn't been configured and built properly for the threads -module to work. (The 'useithreads' configuration option hasn't been used.) +our $VERSION = '1.24_01'; +my $XS_VERSION = $VERSION; +$VERSION = eval $VERSION; -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 threads module. (In other words, threaded and non-threaded Perls -are binary incompatible.) -If you want to the use the threads module, please contact the people -who built your Perl. - -Cannot continue, aborting. -EOF +BEGIN { + # Verify this Perl supports threads + use Config; + if (! $Config{useithreads}) { + die("This Perl not built to support threads\n"); } -} - -use overload - '==' => \&equal, - '!=' => sub { !equal(@_) }, - 'fallback' => 1; -BEGIN { - warn "Warning, threads::shared has already been loaded. ". - "To enable shared variables for these modules 'use threads' ". - "must be called before any of those modules are loaded\n" - if($threads::shared::threads_shared); + # Declare that we have been loaded + $threads::threads = 1; + + # 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_ + } } -our $VERSION = '1.18_03'; - - # Load the XS code require XSLoader; -XSLoader::load('threads', $VERSION); +XSLoader::load('threads', $XS_VERSION); ### Export ### @@ -77,15 +65,24 @@ sub import ### Methods, etc. ### -# use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2) -# should also be faster -sub async (&;@) { unshift @_,'threads'; goto &new } - -$threads::threads = 1; - # '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__ @@ -96,7 +93,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.18 +This document describes threads version 1.24 =head1 SYNOPSIS @@ -131,6 +128,7 @@ This document describes threads version 1.18 yield(); my @threads = threads->list(); + my $thread_count = threads->list(); if ($thr1 == $thr2) { ... @@ -226,20 +224,24 @@ detached, then a warning will be issued. (A program exits either because one of its threads explicitly calls L<exit()|perlfunc/"exit EXPR">, or in the case of the main thread, reaches the end of the main program file.) -=item $thread->detach +Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already joined thread will +cause an error to be thrown. -Will make the thread unjoinable, and cause any eventual return value -to be discarded. +=item $thr->detach() -Calling C<-E<gt>join()> on a detached thread will cause an error to be thrown. +Makes the thread unjoinable, and causes any eventual return value to be +discarded. + +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 +=item threads->self() -This will return the thread object for the current thread. +Class method that allows a thread to obtain its own I<threads> object. =item $thr->tid() @@ -257,13 +259,13 @@ 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(); +=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)> then use just a bare C<yield> in your +You may do C<use threads qw(yield)>, and then just use C<yield()> in your code. =item threads->list() @@ -274,27 +276,32 @@ objects. In a scalar context, returns a count of the same. =item $thr1->equal($thr2) Tests if two threads objects are the same thread or not. This is overloaded -to the more natural form: +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 sub, and so must have a -semi-colon after the closing brace. Like C<< threads->new >>, C<async> -returns a thread object. +it. This block is treated as an anonymous subroutine, and so must have a +semi-colon after the closing brace. Like C<threads->create()>, C<async> +returns a I<threads> object. =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 the handle -returned by C<CreateThread>; for other platforms, it is the pointer returned -by C<pthread_create>. +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 @@ -311,7 +318,7 @@ Class method that allows a thread to obtain its own I<handle>. =over 4 -=item A thread exited while %d other threads were still running +=item A thread exited while # other threads were still running A thread (not necessarily the main thread) exited while there were still other threads running. Usually it's a good idea to first collect @@ -324,7 +331,7 @@ exit from the main thread. =over 4 -=item This Perl hasn't been configured and built properly for the threads... +=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. @@ -340,10 +347,10 @@ incompatible.) =over -=item Parent-Child threads. +=item Parent-child threads -On some platforms it might not be possible to destroy "parent" -threads while there are still existing 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 BEGIN blocks @@ -387,7 +394,7 @@ 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.18/shared.pm> +L<http://annocpan.org/~JDHEDDEN/threads-1.24/shared.pm> L<threads::shared>, L<perlthrtut> diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index bd4d7f575d..bcbd908415 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -192,28 +192,6 @@ Perl_ithread_hook(pTHX) return veto_cleanup; } -static void -S_ithread_detach(pTHX_ ithread *thread) -{ - MUTEX_LOCK(&thread->mutex); - if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) { - thread->state |= PERL_ITHR_DETACHED; -#ifdef WIN32 - CloseHandle(thread->handle); - thread->handle = 0; -#else - PERL_THREAD_DETACH(thread->thr); -#endif - } - if ((thread->state & PERL_ITHR_FINISHED) && - (thread->state & PERL_ITHR_DETACHED)) { - MUTEX_UNLOCK(&thread->mutex); - S_ithread_destruct(aTHX_ thread); - } - else { - MUTEX_UNLOCK(&thread->mutex); - } -} /* MAGIC (in mg.h sense) hooks */ @@ -571,112 +549,9 @@ S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params) return ithread_to_SV(aTHX_ obj, thread, classname, FALSE); } -static SV* -S_ithread_self (pTHX_ SV *obj, char* Class) -{ - ithread *thread = S_ithread_get(aTHX); - if (thread) - return ithread_to_SV(aTHX_ obj, thread, Class, TRUE); - else - Perl_croak(aTHX_ "panic: cannot find thread data"); - return NULL; /* silence compiler warning */ -} - - -/* Joins the thread. - * This code takes the return value from the call_sv and sends it back. - */ -static AV* -S_ithread_join(pTHX_ SV *obj) -{ - ithread *thread = SV_to_ithread(aTHX_ obj); - MUTEX_LOCK(&thread->mutex); - if (thread->state & PERL_ITHR_DETACHED) { - MUTEX_UNLOCK(&thread->mutex); - Perl_croak(aTHX_ "Cannot join a detached thread"); - } - else if (thread->state & PERL_ITHR_JOINED) { - MUTEX_UNLOCK(&thread->mutex); - Perl_croak(aTHX_ "Thread already joined"); - } - else { - AV* retparam; -#ifdef WIN32 - DWORD waitcode; -#else - void *retval; -#endif - MUTEX_UNLOCK(&thread->mutex); -#ifdef WIN32 - waitcode = WaitForSingleObject(thread->handle, INFINITE); - CloseHandle(thread->handle); - thread->handle = 0; -#else - pthread_join(thread->thr,&retval); -#endif - MUTEX_LOCK(&thread->mutex); - - /* sv_dup over the args */ - { - ithread* current_thread; - AV* params = (AV*) SvRV(thread->params); - PerlInterpreter *other_perl = thread->interp; - CLONE_PARAMS clone_params; - 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); - -#if 0 - { - I32 len = av_len(params)+1; - I32 i; - for(i = 0; i < len; i++) { - sv_dump(SvRV(AvARRAY(params)[i])); - } - } -#endif - retparam = (AV*) sv_dup((SV*)params, &clone_params); -#if 0 - { - I32 len = av_len(retparam)+1; - I32 i; - for(i = 0; i < len; i++) { - sv_dump(SvRV(AvARRAY(retparam)[i])); - } - } -#endif - S_ithread_set(aTHX_ current_thread); - SvREFCNT_dec(clone_params.stashes); - SvREFCNT_inc(retparam); - ptr_table_free(PL_ptr_table); - PL_ptr_table = NULL; - - } - /* We are finished with it */ - thread->state |= PERL_ITHR_JOINED; - S_ithread_clear(aTHX_ thread); - MUTEX_UNLOCK(&thread->mutex); - - return retparam; - } - return (AV*)NULL; -} - -static void -S_ithread_DESTROY(pTHX_ SV *sv) -{ - ithread *thread = SV_to_ithread(aTHX_ sv); - sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar); -} - #endif /* USE_ITHREADS */ + MODULE = threads PACKAGE = threads PREFIX = ithread_ PROTOTYPES: DISABLE @@ -755,13 +630,16 @@ void ithread_self(...) PREINIT: char *classname; + ithread *thread; CODE: /* Class method only */ if (SvROK(ST(0))) Perl_croak(aTHX_ "Usage: threads->self()"); classname = (char *)SvPV_nolen(ST(0)); - ST(0) = sv_2mortal(S_ithread_self(aTHX_ Nullsv, classname)); + thread = S_ithread_get(aTHX); + + ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); /* XSRETURN(1); - implied */ @@ -778,16 +656,76 @@ ithread_tid(...) void ithread_join(...) PREINIT: + ithread *thread; + int join_err; AV *params; int len; int ii; +#ifdef WIN32 + DWORD waitcode; +#else + void *retval; +#endif PPCODE: /* Object method only */ if (! sv_isobject(ST(0))) Perl_croak(aTHX_ "Usage: $thr->join()"); - /* Join thread and get return values */ - params = S_ithread_join(aTHX_ ST(0)); + /* Check if the thread is joinable */ + thread = SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)); + MUTEX_UNLOCK(&thread->mutex); + if (join_err) { + if (join_err & PERL_ITHR_DETACHED) { + Perl_croak(aTHX_ "Cannot join a detached thread"); + } else { + Perl_croak(aTHX_ "Thread already joined"); + } + } + + /* Join the thread */ +#ifdef WIN32 + waitcode = WaitForSingleObject(thread->handle, INFINITE); +#else + pthread_join(thread->thr, &retval); +#endif + + MUTEX_LOCK(&thread->mutex); + /* Mark as joined */ + thread->state |= PERL_ITHR_JOINED; + + /* Get the return value from the call_sv */ + { + AV *params_copy; + PerlInterpreter *other_perl; + CLONE_PARAMS clone_params; + ithread *current_thread; + + 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(); + 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); + params = (AV *)sv_dup((SV*)params_copy, &clone_params); + S_ithread_set(aTHX_ current_thread); + SvREFCNT_dec(clone_params.stashes); + SvREFCNT_inc(params); + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } + + /* We are finished with the thread */ + S_ithread_clear(aTHX_ thread); + MUTEX_UNLOCK(&thread->mutex); + + /* If no return values, then just return */ if (! params) { XSRETURN_UNDEF; } @@ -813,15 +751,41 @@ void ithread_detach(...) PREINIT: ithread *thread; + int detach_err; + int cleanup; CODE: thread = SV_to_ithread(aTHX_ ST(0)); - S_ithread_detach(aTHX_ thread); + MUTEX_LOCK(&thread->mutex); + + /* Check if the thread is detachable */ + if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) { + MUTEX_UNLOCK(&thread->mutex); + if (detach_err & PERL_ITHR_DETACHED) { + Perl_croak(aTHX_ "Thread already detached"); + } else { + Perl_croak(aTHX_ "Cannot detach a joined thread"); + } + } + + /* Detach the thread */ + thread->state |= PERL_ITHR_DETACHED; +#ifdef WIN32 + /* Windows has no 'detach thread' function */ +#else + PERL_THREAD_DETACH(thread->thr); +#endif + /* Cleanup if finished */ + cleanup = (thread->state & PERL_ITHR_FINISHED); + MUTEX_UNLOCK(&thread->mutex); + + if (cleanup) + S_ithread_destruct(aTHX_ thread); void ithread_DESTROY(...) CODE: - S_ithread_DESTROY(aTHX_ ST(0)); + sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar); void @@ -894,7 +858,7 @@ ithread__handle(...); CODE: thread = SV_to_ithread(aTHX_ ST(0)); #ifdef WIN32 - XST_mUV(0, PTR2UV(thread->handle)); + XST_mUV(0, PTR2UV(&thread->handle)); #else XST_mUV(0, PTR2UV(&thread->thr)); #endif |