Explicit thread context

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

p4raw-id: //depot/perl@28290

5 files changed, 234 insertions, 35 deletions

diff --git a/ext/threads/Changes b/ext/threads/Changes
index 083507936b..157c094a1c 100755
--- a/ext/threads/Changes
+++ b/ext/threads/Changes
@@ -1,5 +1,8 @@
 Revision history for Perl extension threads.
 
+1.31 Fri May 19 16:06:42 EDT 2006
+	- Explicit thread context
+
 1.29 Thu May 18 16:09:28 EDT 2006
 	- Fix warning/core dump from ->create('foo') in BEGIN block
 
diff --git a/ext/threads/README b/ext/threads/README
index 6e33bdce93..f04153de70 100755
--- a/ext/threads/README
+++ b/ext/threads/README
@@ -1,4 +1,4 @@
-threads version 1.29
+threads version 1.31
 ====================
 
 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
new file mode 100644
index 0000000000..8843bdf943
--- /dev/null
+++ b/ext/threads/t/context.t
@@ -0,0 +1,93 @@
+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;
+use threads::shared;
+
+BEGIN {
+    $| = 1;
+    print("1..13\n");   ### Number of tests that will be run ###
+};
+
+my $TEST = 1;
+share($TEST);
+
+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 ###
+
+sub foo
+{
+    my $context = shift;
+    my $wantarray = 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;
+    }
+}
+
+my ($thr) = threads->create('foo', 'array');
+my ($res) = $thr->join();
+ok($res eq 'array', 'Implicit array context');
+
+$thr = threads->create('foo', 'scalar');
+$res = $thr->join();
+ok($res eq 'scalar', 'Implicit scalar context');
+
+threads->create('foo', 'void');
+($thr) = threads->list();
+$res = $thr->join();
+ok(! defined($res), 'Implicit void context');
+
+$thr = threads->create({'context' => 'array'}, 'foo', 'array');
+($res) = $thr->join();
+ok($res eq 'array', 'Explicit array context');
+
+($thr) = threads->create({'scalar' => 'scalar'}, 'foo', 'scalar');
+$res = $thr->join();
+ok($res eq 'scalar', 'Explicit scalar context');
+
+$thr = threads->create({'void' => 1}, 'foo', 'void');
+$res = $thr->join();
+ok(! defined($res), 'Explicit void context');
+
+# EOF
diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm
index 39416d3db9..b6211ba21d 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.29';
+our $VERSION = '1.31';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -102,7 +102,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 1.29
+This document describes threads version 1.31
 
 =head1 SYNOPSIS
 
@@ -110,7 +110,7 @@ This document describes threads version 1.29
 
     sub start_thread {
         my @args = @_;
-        print "Thread started: @args\n";
+        print('Thread started: ', join(' ', @args), "\n");
     }
     my $thread = threads->create('start_thread', 'argument');
     $thread->join();
@@ -120,8 +120,11 @@ This document describes threads version 1.29
     my $thread3 = async { foreach (@files) { ... } };
     $thread3->join();
 
-    # Invoke thread in list context so it can return a list
+    # Invoke thread in list context (implicit) so it can return a list
     my ($thr) = threads->create(sub { return (qw/a b c/); });
+    # or specify list context explicitly
+    my $thr = threads->create({'context' => 'list'},
+                              sub { return (qw/a b c/); });
     my @results = $thr->join();
 
     $thread->detach();
@@ -146,6 +149,12 @@ This document describes threads version 1.29
     $stack_size = threads->get_stack_size();
     $old_size = threads->set_stack_size(32*4096);
 
+    # Create a thread with a specific context and stack size
+    my $thr = threads->create({ 'context'    => 'list',
+                                'stack_size' => 32*4096 },
+                              \&foo);
+    my @results = $thr->join();
+
     $thr->kill('SIGUSR1');
 
 =head1 DESCRIPTION
@@ -187,22 +196,6 @@ a code ref.
         # or
     my $thr = threads->create(\&func, ...);
 
-The thread may be created in I<list> context, or I<scalar> context as follows:
-
-    # Create thread in list context
-    my ($thr) = threads->create(...);
-
-    # Create thread in scalar context
-    my $thr = threads->create(...);
-
-This has consequences for the C<-E<gt>join()> method describe below.
-
-Although a thread may be created in I<void> context, to do so you must
-I<chain> either the C<-E<gt>join()> or C<-E<gt>detach()> method to the
-C<-E<gt>create()> call:
-
-    threads->create(...)->join();
-
 The C<-E<gt>new()> method is an alias for C<-E<gt>create()>.
 
 =item $thr->join()
@@ -211,27 +204,39 @@ This will wait for the corresponding thread to complete its execution.  When
 the thread finishes, C<-E<gt>join()> will return the return value(s) of the
 entry point function.
 
-The context (void, scalar or list) of the thread creation is also the
-context for C<-E<gt>join()>.  This means that if you intend to return an array
-from a thread, you must use C<my ($thr) = threads->create(...)>, and that
-if you intend to return a scalar, you must use C<my $thr = ...>:
+The context (void, scalar or list) for the return value(s) for C<-E<gt>join()>
+is determined at the time of thread creation.
 
-    # Create thread in list context
+    # Create thread in list context (implicit)
     my ($thr1) = threads->create(sub {
                                     my @results = qw(a b c);
                                     return (@results);
-                                 };
+                                 });
+    #   or (explicit)
+    my $thr1 = threads->create({'context' => 'list'},
+                               sub {
+                                    my @results = qw(a b c);
+                                    return (@results);
+                               });
     # Retrieve list results from thread
     my @res1 = $thr1->join();
 
-    # Create thread in scalar context
+    # Create thread in scalar context (implicit)
     my $thr2 = threads->create(sub {
                                     my $result = 42;
                                     return ($result);
-                                 };
+                                 });
     # Retrieve scalar result from thread
     my $res2 = $thr2->join();
 
+    # Create a thread in void context (explicit)
+    my $thr3 = threads->create({'void' => 1},
+                               sub { print("Hello, world\n"); });
+    # Join the thread in void context (i.e., no return value)
+    $thr3->join();
+
+See L</"THREAD CONTEXT"> for more details.
+
 If the program exits without all other threads having been either joined or
 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
@@ -327,6 +332,58 @@ Class method that allows a thread to obtain its own I<handle>.
 
 =back
 
+=head1 THREAD CONTEXT
+
+As with subroutines, the type of value returned from a thread's entry point
+function may be determined by the thread's I<context>:  list, scalar or void.
+The thread's context is determined at thread creation.  This is necessary so
+that the context is available to the entry point function via
+L<wantarry()|perlfunc/"wantarray">.  The thread may then specify a value of
+the appropriate type to be returned from C<-E<gt>join()>.
+
+=head2 Explicit context
+
+Because thread creation and thread joining may occur in different contexts, it
+may be desirable to state the context explicitly to the thread's entry point
+function.  This may be done by calling C<-E<gt>create()> with a parameter hash
+as the first argument:
+
+    my $thr = threads->create({'context' => 'list'}, \&foo);
+    ...
+    my @results = $thr->join();
+
+In the above, the threads object is returned to the parent thread in scalar
+context, and the thread's entry point function C<foo> will be called in list
+context such that the parent thread can receive a list from the C<-E<gt>join()>
+call.  Similarly, if you need the threads object, but your thread will not be
+returning a value (i.e., I<void> context), you would do the following:
+
+    my $thr = threads->create({'context' => 'void'}, \&foo);
+    ...
+    $thr->join();
+
+The context type may also be used as the I<key> in the parameter hash followed
+by a I<true> value:
+
+    threads->create({'scalar' => 1}, \&foo);
+    ...
+    my ($thr) = threads->list();
+    my $result = $thr->join();
+
+=head2 Implicit context
+
+If not explicitly stated, the thread's context is implied from the context
+of the C<-E<gt>create()> call:
+
+    # Create thread in list context
+    my ($thr) = threads->create(...);
+
+    # Create thread in scalar context
+    my $thr = threads->create(...);
+
+    # Create thread in void context
+    threads->create(...);
+
 =head1 THREAD STACK SIZE
 
 The default per-thread stack size for different platforms varies
@@ -394,8 +451,10 @@ threaded applications.
 
 =item threads->create({'stack_size' => VALUE}, FUNCTION, ARGS)
 
-This change to the thread creation method permits specifying the stack size
-for an individual thread.
+The stack size an individual threads may also be specified.  This may be done
+by calling C<-E<gt>create()> with a parameter hash as the first argument:
+
+    my $thr = threads->create({'stack_size' => 32*4096}, \&foo, @args);
 
 =item $thr2 = $thr1->create(FUNCTION, ARGS)
 
@@ -409,7 +468,7 @@ existing thread (C<$thr1>).  This is shorthand for the following:
 
 =head1 THREAD SIGNALLING
 
-When safe signals is in effect (the default behavior - see L<Unsafe signals>
+When safe signals is in effect (the default behavior - see L</"Unsafe signals">
 for more details), then signals may be sent and acted upon by individual
 threads.
 
@@ -567,7 +626,7 @@ following results in the above error:
 =item Cannot signal other threads without safe signals
 
 Safe signals must be in effect to use the C<-E<gt>kill()> signalling method.
-See L<Unsafe signals> for more details.
+See L</"Unsafe signals"> for more details.
 
 =item Unrecognized signal name: ...
 
@@ -646,7 +705,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.29/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.31/shared.pm>
 
 L<threads::shared>, L<perlthrtut>
 
diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index 4d9ef4cf00..e85c6c7327 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -451,6 +451,7 @@ S_ithread_create(
         char     *classname,
         SV       *init_function,
         IV        stack_size,
+        int       gimme,
         SV       *params)
 {
     ithread     *thread;
@@ -489,7 +490,7 @@ S_ithread_create(
     MUTEX_INIT(&thread->mutex);
     thread->tid = tid_counter++;
     thread->stack_size = good_stack_size(aTHX_ stack_size);
-    thread->gimme = GIMME_V;
+    thread->gimme = gimme;
 
     /* "Clone" our interpreter into the thread's interpreter.
      * This gives thread access to "static data" and code.
@@ -674,6 +675,9 @@ ithread_create(...)
         AV *params;
         HV *specs;
         IV stack_size;
+        int context;
+        char *str;
+        char ch;
         int idx;
         int ii;
     CODE:
@@ -702,6 +706,7 @@ ithread_create(...)
 
         function_to_call = ST(idx+1);
 
+        context = -1;
         if (specs) {
             /* stack_size */
             if (hv_exists(specs, "stack", 5)) {
@@ -711,6 +716,44 @@ ithread_create(...)
             } else if (hv_exists(specs, "stack_size", 10)) {
                 stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
             }
+
+            /* context */
+            if (hv_exists(specs, "context", 7)) {
+                str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0));
+                switch (*str) {
+                    case 'a':
+                    case 'A':
+                        context = G_ARRAY;
+                        break;
+                    case 's':
+                    case 'S':
+                        context = G_SCALAR;
+                        break;
+                    case 'v':
+                    case 'V':
+                        context = G_VOID;
+                        break;
+                    default:
+                        Perl_croak(aTHX_ "Invalid context: %s", str);
+                }
+            } else if (hv_exists(specs, "array", 5)) {
+                if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
+                    context = G_ARRAY;
+                }
+            } else if (hv_exists(specs, "scalar", 6)) {
+                if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
+                    context = G_SCALAR;
+                }
+            } else if (hv_exists(specs, "void", 4)) {
+                if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
+                    context = G_VOID;
+                }
+            }
+        }
+        if (context == -1) {
+            context = GIMME_V;  /* Implicit context */
+        } else {
+            context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID)));
         }
 
         /* Function args */
@@ -726,6 +769,7 @@ ithread_create(...)
                                             classname,
                                             function_to_call,
                                             stack_size,
+                                            context,
                                             newRV_noinc((SV*)params)));
         /* XSRETURN(1); - implied */