Thread signalling [REVISED]
Jerry D. Hedden [Thu, 11 May 2006 08:55:39 +0000 (01:55 -0700)]
From: "Jerry D. Hedden" <jerry@hedden.us>
Message-ID: <20060511085539.fb30e530d17747c2b054d625b8945d88.a90037f085.wbe@email.secureserver.net>

p4raw-id: //depot/perl@28168

MANIFEST
ext/threads/Changes
ext/threads/Makefile.PL
ext/threads/t/kill.t [new file with mode: 0644]
ext/threads/threads.pm
ext/threads/threads.xs

index c577752..5f06f81 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1136,6 +1136,7 @@ ext/threads/t/free2.t             More ithread destruction tests
 ext/threads/threads.pm         ithreads
 ext/threads/threads.xs         ithreads
 ext/threads/t/join.t           Testing the join function
+ext/threads/t/kill.t           Tests thread signalling
 ext/threads/t/libc.t           testing libc functions for threadsafety
 ext/threads/t/list.t           Test threads->list()
 ext/threads/t/problems.t       Test various memory problems
index 032bca8..9742543 100755 (executable)
@@ -1,5 +1,9 @@
 Revision history for Perl extension threads.
 
+1.27 Wed May 10 14:01:17 EDT 2006
+       - Added $thr->kill() method for thread signalling
+       - Check for 'C' compiler when building module
+
 1.26 Mon May  8 13:18:29 EDT 2006
        - Fix for Win32 build WRT page size
 
index 8eb3893..cec0662 100755 (executable)
@@ -8,6 +8,42 @@ use warnings;
 use ExtUtils::MakeMaker;
 
 
+# Used to check for a 'C' compiler
+sub check_cc
+{
+    require File::Spec;
+
+    my $cmd = $_[0];
+    if (-x $cmd or MM->maybe_command($cmd)) {
+        return (1);       # CC command found
+    }
+    for my $dir (File::Spec->path(), '.') {
+        my $abs = File::Spec->catfile($dir, $cmd);
+        if (-x $abs or MM->maybe_command($abs)) {
+            return (1);   # CC command found
+        }
+    }
+    return;
+}
+
+sub have_cc
+{
+    eval { require Config_m; };     # ExtUtils::FakeConfig (+ ActivePerl)
+    if ($@) {
+        eval { require Config; };   # Everyone else
+    }
+    my @chunks = split(/ /, $Config::Config{cc});
+    # $Config{cc} may contain args; try to find out the program part
+    while (@chunks) {
+        if (check_cc("@chunks")) {
+            return (1);   # CC command found
+        }
+        pop(@chunks);
+    }
+    return;
+}
+
+
 # Build options for different environments
 my @conditional_params;
 if (grep { $_ eq 'PERL_CORE=1' } @ARGV) {
@@ -16,10 +52,17 @@ if (grep { $_ eq 'PERL_CORE=1' } @ARGV) {
                               'NORECURS' => 1);
 } else {
     # CPAN
-    push(@conditional_params, 'DEFINE'   => '-DHAS_PPPORT_H');
+
+    # Verify that a 'C' compiler is available
+    if (! have_cc()) {
+        die("No 'C' compiler found to build 'threads'\n");
+    }
+
+    push(@conditional_params, 'DEFINE' => '-DHAS_PPPORT_H');
 }
 
 
+# Create Makefile
 WriteMakefile(
     'NAME'              => 'threads',
     'AUTHOR'            => 'Artur Bergman <sky AT crucially DOT net>',
diff --git a/ext/threads/t/kill.t b/ext/threads/t/kill.t
new file mode 100644 (file)
index 0000000..6f632bd
--- /dev/null
@@ -0,0 +1,185 @@
+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;
+
+{
+    package Thread::Semaphore;
+    use threads::shared;
+
+    sub new {
+        my $class = shift;
+        my $val : shared = @_ ? shift : 1;
+        bless \$val, $class;
+    }
+
+    sub down {
+        my $s = shift;
+        lock($$s);
+        my $inc = @_ ? shift : 1;
+        cond_wait $$s until $$s >= $inc;
+        $$s -= $inc;
+    }
+
+    sub up {
+        my $s = shift;
+        lock($$s);
+        my $inc = @_ ? shift : 1;
+        ($$s += $inc) > 0 and cond_broadcast $$s;
+    }
+}
+
+BEGIN {
+    $| = 1;
+    print("1..18\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 ###
+
+### Thread cancel ###
+
+# Set up to capture warning when thread terminates
+my @errs :shared;
+$SIG{__WARN__} = sub { push(@errs, @_); };
+
+
+sub thr_func {
+    # Thread 'cancellation' signal handler
+    $SIG{'KILL'} = sub {
+        ok(1, 'Thread received signal');
+        die("Thread killed\n");
+    };
+
+    # Thread sleeps until signalled
+    ok(1, 'Thread sleeping');
+    sleep(5);
+    # Should not go past here
+    ok(0, 'Thread terminated normally');
+    return ('ERROR');
+}
+
+
+# Create thread
+my $thr = threads->create('thr_func');
+ok($thr && $thr->tid() == 1, 'Created thread');
+threads->yield();
+sleep(1);
+
+# Signal thread
+ok($thr->kill('KILL'), 'Signalled thread');
+threads->yield();
+
+# Interrupt thread's sleep call
+{
+    local $SIG{'INT'} = sub {};
+    ok(kill('INT', $$) || $^O eq 'MSWin32', q/Interrupt thread's sleep call/);
+}
+
+# Cleanup
+my $rc = $thr->join();
+ok(! $rc, 'No thread return value');
+
+# Check for thread termination message
+ok(@errs && $errs[0] =~ /Thread killed/, 'Thread termination warning');
+
+
+### Thread suspend/resume ###
+
+sub thr_func2
+{
+    my $sema = shift;
+    ok($sema, 'Thread received semaphore');
+
+    # Set up the signal handler for suspension/resumption
+    $SIG{'STOP'} = sub {
+        ok(1, 'Thread suspending');
+        $sema->down();
+        ok(1, 'Thread resuming');
+        $sema->up();
+    };
+
+    # Set up the signal handler for graceful termination
+    my $term = 0;
+    $SIG{'TERM'} = sub {
+        ok(1, 'Thread caught termination signal');
+        $term = 1;
+    };
+
+    # Do work until signalled to terminate
+    while (! $term) {
+        sleep(1);
+    }
+
+    ok(1, 'Thread done');
+    return ('OKAY');
+}
+
+
+# Create a semaphore for use in suspending the thread
+my $sema = Thread::Semaphore->new();
+ok($sema, 'Semaphore created');
+
+# Create a thread and send it the semaphore
+$thr = threads->create('thr_func2', $sema);
+ok($thr && $thr->tid() == 2, 'Created thread');
+threads->yield();
+sleep(1);
+
+# Suspend the thread
+$sema->down();
+ok($thr->kill('STOP'), 'Suspended thread');
+
+threads->yield();
+sleep(1);
+
+# Allow the thread to continue
+$sema->up();
+
+threads->yield();
+sleep(1);
+
+# Terminate the thread
+ok($thr->kill('TERM'), 'Signalled thread to terminate');
+
+$rc = $thr->join();
+ok($rc eq 'OKAY', 'Thread return value');
+
+# EOF
index 6a28940..5c63d80 100755 (executable)
@@ -5,7 +5,7 @@ use 5.008;
 use strict;
 use warnings;
 
-our $VERSION = '1.26';
+our $VERSION = '1.27';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -102,7 +102,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 1.26
+This document describes threads version 1.27
 
 =head1 SYNOPSIS
 
@@ -146,6 +146,8 @@ This document describes threads version 1.26
     $stack_size = threads->get_stack_size();
     $old_size = threads->set_stack_size(32*4096);
 
+    $thr->kill('SIGUSR1');
+
 =head1 DESCRIPTION
 
 Perl 5.6 introduced something called interpreter threads.  Interpreter threads
@@ -405,6 +407,90 @@ existing thread (C<$thr1>).  This is shorthand for the following:
 
 =back
 
+=head1 THREAD SIGNALLING
+
+If Perl has been compiled to use safe signals (i.e., was not built with
+C<PERL_OLD_SIGNALS> - see C<perl -V>), then signals may be sent and acted upon
+by individual threads.
+
+=over 4
+
+=item $thr->kill('SIG...');
+
+Sends the specified signal to the thread.  Signal names and (positive) signal
+numbers are the same as those supported by
+L<kill()|perlfunc/"kill SIGNAL, LIST">.  For example, 'SIGTERM', 'TERM' and
+(depending on the OS) 15 are all valid arguments to C<-E<gt>kill()>.
+
+Returns the thread object to allow for method chaining:
+
+    $thr->kill('SIG...')->join();
+
+=back
+
+Signal handlers need to be set up in the threads for the signals they are
+expected to act upon.  Here's an example for I<cancelling> a thread:
+
+    use threads;
+
+    # Suppress warning message when thread is 'killed'
+    no warnings 'threads';
+
+    sub thr_func
+    {
+        # Thread 'cancellation' signal handler
+        $SIG{'KILL'} = sub { die("Thread killed\n"); };
+
+        ...
+    }
+
+    # Create a thread
+    my $thr = threads->create('thr_func');
+
+    ...
+
+    # Signal the thread to terminate, and then detach
+    # it so that it will get cleaned up automatically
+    $thr->kill('KILL')->detach();
+
+Here's another example that uses a semaphore to provide I<suspend> and
+I<resume> capabilities:
+
+    use threads;
+    use Thread::Semaphore;
+
+    sub thr_func
+    {
+        my $sema = shift;
+
+        # Thread 'suspend/resume' signal handler
+        $SIG{'STOP'} = sub {
+            $sema->down();      # Thread suspended
+            $sema->up();        # Thread resumes
+        };
+
+        ...
+    }
+
+    # Create a semaphore and send it to a thread
+    my $sema = Thread::Semaphore->new();
+    my $thr = threads->create('thr_func', $sema);
+
+    # Suspend the thread
+    $sema->down();
+    $thr->kill('STOP');
+
+    ...
+
+    # Allow the thread to continue
+    $sema->up();
+
+CAVEAT:  Sending a signal to a thread does not disrupt the operation the
+thread is currently working on:  The signal will be acted upon after the
+current operation has completed.  For instance, if the thread is I<stuck> on
+an I/O call, sending it a signal will not cause the I/O call to be interrupted
+such that the signal is acted up immediately.
+
 =head1 WARNINGS
 
 =over 4
@@ -416,14 +502,35 @@ threads running.  Usually, it's a good idea to first collect the return values
 of the created threads by joining them, and only then exit from the main
 thread.
 
+=item Thread creation failed: pthread_create returned #
+
+See the appropriate I<man> page for C<pthread_create> to determine the actual
+cause for the failure.
+
+=item Thread # terminated abnormally: ...
+
+A thread terminated in some manner other than just returning from its entry
+point function.  For example, the thread may have exited via C<die>.
+
 =item Using minimum thread stack size of #
 
 Some platforms have a minimum thread stack size.  Trying to set the stack size
 below this value will result in the above warning, and the stack size will be
 set to the minimum.
 
+=item Thread creation failed: pthread_attr_setstacksize(I<SIZE>) returned 22
+
+The specified I<SIZE> exceeds the system's maximum stack size.  Use a smaller
+value for the stack size.
+
 =back
 
+If needed, thread warnings can be suppressed by using:
+
+    no warnings 'threads';
+
+in the appropriate scope.
+
 =head1 ERRORS
 
 =over 4
@@ -445,10 +552,16 @@ following results in the above error:
 
     $thr->set_stack_size($size);
 
-=item Thread creation failed: pthread_attr_setstacksize(I<SIZE>) returned 22
+=item Cannot signal other threads without safe signals
 
-The specified I<SIZE> exceeds the system's maximum stack size.  Use a smaller
-value for the stack size.
+The particular copy of Perl that you're trying to use was built using
+C<PERL_OLD_SIGNALS>.  As a result, the C<-E<gt>kill()> signalling method
+cannot be used.
+
+=item Unrecognized signal name: ...
+
+The particular copy of Perl that you're trying to use does not support the
+specified signal being used in a C<-E<gt>kill()> call.
 
 =back
 
@@ -502,7 +615,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.26/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.27/shared.pm>
 
 L<threads::shared>, L<perlthrtut>
 
index 83d1afa..8c2eee1 100755 (executable)
@@ -368,7 +368,7 @@ S_ithread_run(void * arg)
 
         /* Check for failure */
         if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
-            Perl_warn(aTHX_ "Thread failed to start: %" SVf, ERRSV);
+            Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
         }
 
         FREETMPS;
@@ -919,6 +919,46 @@ ithread_detach(...)
 
 
 void
+ithread_kill(...)
+    PREINIT:
+        ithread *thread;
+        char *sig_name;
+        IV signal;
+    CODE:
+        /* Must have safe signals */
+        if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+            Perl_croak(aTHX_ "Cannot signal other threads without safe signals");
+
+        /* Object method only */
+        if (! sv_isobject(ST(0)))
+            Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
+
+        /* Get thread */
+        thread = SV_to_ithread(aTHX_ ST(0));
+
+        /* Get signal */
+        sig_name = SvPV_nolen(ST(1));
+        if (isALPHA(*sig_name)) {
+            if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G')
+                sig_name += 3;
+            if ((signal = Perl_whichsig(aTHX_ sig_name)) < 0)
+                Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
+        } else
+            signal = SvIV(ST(1));
+
+        /* Set the signal for the thread */
+        {
+            dTHXa(thread->interp);
+            PL_psig_pend[signal]++;
+            PL_sig_pending = 1;
+        }
+
+        /* Return the thread to allow for method chaining */
+        ST(0) = ST(0);
+        /* XSRETURN(1); - implied */
+
+
+void
 ithread_DESTROY(...)
     CODE:
         sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);