From c0003851814d129f1f5915f6ab5338e1932f66f4 Mon Sep 17 00:00:00 2001 From: "Jerry D. Hedden" Date: Thu, 11 May 2006 01:55:39 -0700 Subject: [PATCH] Thread signalling [REVISED] From: "Jerry D. Hedden" Message-ID: <20060511085539.fb30e530d17747c2b054d625b8945d88.a90037f085.wbe@email.secureserver.net> p4raw-id: //depot/perl@28168 --- MANIFEST | 1 + ext/threads/Changes | 4 + ext/threads/Makefile.PL | 45 +++++++++- ext/threads/t/kill.t | 185 ++++++++++++++++++++++++++++++++++++++++ ext/threads/threads.pm | 125 +++++++++++++++++++++++++-- ext/threads/threads.xs | 42 ++++++++- 6 files changed, 394 insertions(+), 8 deletions(-) create mode 100644 ext/threads/t/kill.t diff --git a/MANIFEST b/MANIFEST index c577752f3c..5f06f81276 100644 --- 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 diff --git a/ext/threads/Changes b/ext/threads/Changes index 032bca803d..974254362e 100755 --- a/ext/threads/Changes +++ b/ext/threads/Changes @@ -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 diff --git a/ext/threads/Makefile.PL b/ext/threads/Makefile.PL index 8eb38930b1..cec0662a05 100755 --- a/ext/threads/Makefile.PL +++ b/ext/threads/Makefile.PL @@ -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 ', diff --git a/ext/threads/t/kill.t b/ext/threads/t/kill.t new file mode 100644 index 0000000000..6f632bde80 --- /dev/null +++ b/ext/threads/t/kill.t @@ -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 diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index 6a28940bf5..5c63d804f2 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.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 - see C), 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. For example, 'SIGTERM', 'TERM' and +(depending on the OS) 15 are all valid arguments to C<-Ekill()>. + +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 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 and +I 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 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 page for C 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. + =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) returned 22 + +The specified I 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) returned 22 +=item Cannot signal other threads without safe signals -The specified I 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. As a result, the C<-Ekill()> 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<-Ekill()> call. =back @@ -502,7 +615,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 83d1afa353..8c2eee1d0b 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -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; @@ -918,6 +918,46 @@ ithread_detach(...) S_ithread_destruct(aTHX_ thread); +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: -- 2.34.1