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 ###
### 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__
=head1 VERSION
-This document describes threads version 1.18
+This document describes threads version 1.24
=head1 SYNOPSIS
yield();
my @threads = threads->list();
+ my $thread_count = threads->list();
if ($thr1 == $thr2) {
...
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()
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()
=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
=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
=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.
=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
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>
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 */
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
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 */
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;
}
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
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
projects / platform / upstream / perl.git / commitdiff