From: Jerry D. Hedden Date: Tue, 25 Apr 2006 07:50:05 +0000 (-0700) Subject: threads - consolidate XS functions X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fcea4b7c99fe376a2295931b658ba7f41a47470e;p=p5sagit%2Fp5-mst-13.2.git threads - consolidate XS functions From: "Jerry D. Hedden" Message-ID: <20060425075005.fb30e530d17747c2b054d625b8945d88.e23f2fed42.wbe@email.secureserver.net> p4raw-id: //depot/perl@27961 --- diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index b5be201..e217dde 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 < \&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, or in the case of the main thread, reaches the end of the main program file.) -=item $thread->detach +Calling C<-Ejoin()> or C<-Edetach()> 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<-Ejoin()> 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<-Ejoin()> or C<-Edetach()> 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 object. =item $thr->tid() @@ -257,13 +259,13 @@ with the specified thread ID. Returns C 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 then use just a bare C in your +You may do C, and then just use C 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 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 -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 Ccreate()>, C +returns a I object. =item $thr->_handle() This I method returns the memory location of the internal thread -structure associated with a threads object. For Win32, this is the handle -returned by C; for other platforms, it is the pointer returned -by C. +structure associated with a threads object. For Win32, this is a pointer to +the C value returned by C (i.e., C); for other +platforms, it is a pointer to the C structure used in the +C call (i.e., C. 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. =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 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 threads while +there are still existing I threads. =item Creating threads inside BEGIN blocks @@ -387,7 +394,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 bd4d7f5..bcbd908 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