threads - consolidate XS functions

From: "Jerry D. Hedden" <jerry@hedden.us>
Message-ID: <20060425075005.fb30e530d17747c2b054d625b8945d88.e23f2fed42.wbe@email.secureserver.net>

p4raw-id: //depot/perl@27961

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