ext/threads/t/blocks.t Test threads in special blocks
ext/threads/t/context.t Explicit thread context
ext/threads/t/end.t Test end functions
+ext/threads/t/exit.t Test exit and die in threads
ext/threads/t/free2.t More ithread destruction tests
ext/threads/t/free.t Test ithread destruction
ext/threads/threads.pm ithreads
Revision history for Perl extension threads.
+1.33 Mon Jul 3 10:11:20 EDT 2006
+ - 'exit' inside a thread silently terminates thread only
+ - Added 'threads->exit()' (just calls CORE::exit(0))
+ - Handle 'die/exit' in thread warn handlers if thread terminates
+ with a warning
+ - Give exact accounting of unjoined threads on program termination
+ - Fix spurious 'failures' from t/blocks.t
+ - Set correct path to threads module in tests that use test.pl
+
1.32 Mon Jun 5 09:27:53 EDT 2006
- Fix for HP-UX 10.20 pthread_attr_getstacksize usage
- Check for threads::shared in tests
-threads version 1.32
+threads version 1.33
====================
This module needs perl 5.8.0 or later compiled with 'useithreads'.
print("1..5\n"); ### Number of tests that will be run ###
};
-my $TEST = 1;
-share($TEST);
+my ($TEST, $COUNT, $TOTAL);
+
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+ share($COUNT);
+ $COUNT = 0;
+ $TOTAL = 0;
+}
ok(1, 'Loaded');
} else {
print("not ok $id - $name\n");
printf("# Failed test at line %d\n", (caller)[2]);
+ print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
}
return ($ok);
$SIG{'__WARN__'} = sub { ok(0, "Warning: $_[0]"); };
-sub foo { }
+sub foo { lock($COUNT); $COUNT++; }
sub baz { 42 }
my $bthr;
BEGIN {
$SIG{'__WARN__'} = sub { ok(0, "BEGIN: $_[0]"); };
+ $TOTAL++;
threads->create('foo')->join();
+ $TOTAL++;
threads->create(\&foo)->join();
- threads->create(sub {})->join();
+ $TOTAL++;
+ threads->create(sub { lock($COUNT); $COUNT++; })->join();
+ $TOTAL++;
threads->create('foo')->detach();
+ $TOTAL++;
threads->create(\&foo)->detach();
- threads->create(sub {})->detach();
+ $TOTAL++;
+ threads->create(sub { lock($COUNT); $COUNT++; })->detach();
$bthr = threads->create('baz');
}
my $mthr;
MAIN: {
+ $TOTAL++;
threads->create('foo')->join();
+ $TOTAL++;
threads->create(\&foo)->join();
- threads->create(sub {})->join();
+ $TOTAL++;
+ threads->create(sub { lock($COUNT); $COUNT++; })->join();
+ $TOTAL++;
threads->create('foo')->detach();
+ $TOTAL++;
threads->create(\&foo)->detach();
- threads->create(sub {})->detach();
+ $TOTAL++;
+ threads->create(sub { lock($COUNT); $COUNT++; })->detach();
$mthr = threads->create('baz');
}
ok($mthr->join() == 42, 'Main join');
ok($bthr->join() == 42, 'BEGIN join');
-# make sure a still-running detached thread doesn't give a warning on exit
+# Wait for detached threads to finish
+{
+ threads->yield();
+ sleep(1);
+ lock($COUNT);
+ redo if ($COUNT < $TOTAL);
+}
-# *** add new tests above this one
-threads->create(sub { 1 while 1 })->detach();
-# *** add new tests above this one
+# EOF
print("1..13\n"); ### Number of tests that will be run ###
};
-my $TEST = 1;
-share($TEST);
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
ok(1, 'Loaded');
print("1..6\n"); ### Number of tests that will be run ###
};
-my $TEST = 1;
-share($TEST);
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
ok(1, 'Loaded');
--- /dev/null
+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;
+
+BEGIN {
+ eval {
+ require threads::shared;
+ import threads::shared;
+ };
+ if ($@ || ! $threads::shared::threads_shared) {
+ print("1..0 # Skip: threads::shared not available\n");
+ exit(0);
+ }
+
+ $| = 1;
+ print("1..226\n"); ### Number of tests that will be run ###
+};
+
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
+
+ok(1, 'Loaded');
+
+sub ok {
+ my ($ok, $name) = @_;
+ if (! defined($name)) {
+ # Bug in test
+ $name = $ok;
+ $ok = 0;
+ }
+ chomp($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]);
+ print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
+ }
+
+ return ($ok);
+}
+
+
+### Start of Testing ###
+
+$SIG{'__WARN__'} = sub {
+ my $msg = shift;
+ ok(0, "WARN in main: $msg");
+};
+$SIG{'__DIE__'} = sub {
+ my $msg = shift;
+ ok(0, "DIE in main: $msg");
+};
+
+
+sub nasty
+{
+ my ($term, $warn, $die) = @_;
+ my $tid = threads->tid();
+
+ $SIG{'__WARN__'} = sub {
+ my $msg = $_[0];
+ ok($msg =~ /Thread \d+ terminated abnormally/, "WARN: $msg");
+ if ($warn eq 'return') {
+ return ('# __WARN__ returned');
+ } elsif ($warn eq 'die') {
+ die('# __WARN__ dying');
+ } elsif ($warn eq 'exit') {
+ CORE::exit(20);
+ } else {
+ threads->exit(21);
+ }
+ };
+
+ $SIG{'__DIE__'} = sub {
+ my $msg = $_[0];
+ ok(1, "DIE: $msg");
+ if ($die eq 'return') {
+ return ('# __DIE__ returned');
+ } elsif ($die eq 'die') {
+ die('# __DIE__ dying');
+ } elsif ($die eq 'exit') {
+ CORE::exit(30);
+ } else {
+ threads->exit(31);
+ }
+ };
+
+ ok(1, "Thread $tid");
+ if ($term eq 'return') {
+ return ('# Thread returned');
+ } elsif ($term eq 'die') {
+ die('# Thread dying');
+ } elsif ($term eq 'exit') {
+ CORE::exit(10);
+ } else {
+ threads->exit(11);
+ }
+}
+
+
+my @exit_types = qw(return die exit threads->exit);
+
+# Test (non-trivial) combinations of termination methods
+# WRT the thread and its handlers
+foreach my $die (@exit_types) {
+ foreach my $wrn (@exit_types) {
+ foreach my $thr (@exit_types) {
+ # Things are well behaved if the thread just returns
+ next if ($thr eq 'return');
+
+ # Skip combos with the die handler
+ # if neither the thread nor the warn handler dies
+ next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
+
+ # Must send STDERR to file to filter out 'un-capturable' output
+ my $rc;
+ eval {
+ local *STDERR;
+ if (! open(STDERR, '>tmp.stderr')) {
+ die('Failed to create "tmp.stderr"');
+ }
+
+ $rc = threads->create('nasty', $thr, $wrn, $die)->join();
+
+ close(STDERR);
+ };
+
+ # Filter out 'un-capturable' output
+ if (open(IN, 'tmp.stderr')) {
+ while (my $line = <IN>) {
+ if ($line !~ /^#/) {
+ print(STDERR $line);
+ }
+ }
+ close(IN);
+ } else {
+ ok(0, "Failed to open 'tmp.stderr': $!");
+ }
+ unlink('tmp.stderr');
+
+ ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
+ ok(! defined($rc), "Thread returned 'undef'");
+ }
+ }
+}
+
+
+# Again with:
+no warnings 'threads';
+
+sub less_nasty
+{
+ my ($term, $warn, $die) = @_;
+ my $tid = threads->tid();
+
+ $SIG{'__WARN__'} = sub {
+ my $msg = $_[0];
+ ok(0, "WARN: $msg");
+ if ($warn eq 'return') {
+ return ('# __WARN__ returned');
+ } elsif ($warn eq 'die') {
+ die('# __WARN__ dying');
+ } elsif ($warn eq 'exit') {
+ CORE::exit(20);
+ } else {
+ threads->exit(21);
+ }
+ };
+
+ $SIG{'__DIE__'} = sub {
+ my $msg = $_[0];
+ ok(1, "DIE: $msg");
+ if ($die eq 'return') {
+ return ('# __DIE__ returned');
+ } elsif ($die eq 'die') {
+ die('# __DIE__ dying');
+ } elsif ($die eq 'exit') {
+ CORE::exit(30);
+ } else {
+ threads->exit(31);
+ }
+ };
+
+ ok(1, "Thread $tid");
+ if ($term eq 'return') {
+ return ('# Thread returned');
+ } elsif ($term eq 'die') {
+ die('# Thread dying');
+ } elsif ($term eq 'exit') {
+ CORE::exit(10);
+ } else {
+ threads->exit(11);
+ }
+}
+
+foreach my $die (@exit_types) {
+ foreach my $wrn (@exit_types) {
+ foreach my $thr (@exit_types) {
+ # Things are well behaved if the thread just returns
+ next if ($thr eq 'return');
+
+ # Skip combos with the die handler
+ # if neither the thread nor the warn handler dies
+ next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
+
+ my $rc;
+ eval { $rc = threads->create('less_nasty', $thr, $wrn, $die)->join() };
+ ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
+ ok(! defined($rc), "Thread returned 'undef'");
+ }
+ }
+}
+
+
+# Check termination warning concerning running threads
+$SIG{'__WARN__'} = sub {
+ my $msg = shift;
+ ok($msg =~ /1 running and unjoined/, '1 running and unjoined');
+ ok($msg =~ /2 finished and unjoined/, '2 finished and unjoined');
+ ok($msg =~ /3 running and detached/, '3 finished and detached');
+};
+
+threads->create(sub { sleep(100); });
+threads->create(sub {});
+threads->create(sub {});
+threads->create(sub { sleep(100); })->detach();
+threads->create(sub { sleep(100); })->detach();
+threads->create(sub { sleep(100); })->detach();
+threads->yield();
+sleep(1);
+
+# EOF
print("1..29\n"); ### Number of tests that will be run ###
};
-my $TEST = 1;
-share($TEST);
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
ok(1, 'Loaded');
print("1..74\n"); ### Number of tests that will be run ###
};
-my $TEST = 1;
-share($TEST);
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
ok(1, 'Loaded');
print("1..17\n"); ### Number of tests that will be run ###
};
-my $TEST = 1;
-share($TEST);
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
ok(1, 'Loaded');
ok($th->join());
}
{
- # There is a slight chance (<< 1%) this test case will falsely fail
+ # There is a miniscule chance this test case may falsely fail
# since it tests using rand()
my %rand : shared;
rand(10);
threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
$_->join foreach threads->list;
-# use Data::Dumper qw(Dumper);
-# print Dumper(\%rand);
- #$val = rand();
- ok((keys %rand >= 24), "Check that rand() works after a new thread");
+ ok((keys %rand >= 23), "Check that rand() is randomized in new threads");
}
# bugid #24165
-run_perl(prog =>
- 'use threads; sub a{threads->create(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid');
+run_perl(prog => 'use threads 1.33;
+ sub a{threads->create(shift)} $t = a sub{};
+ $t->tid; $t->join; $t->tid',
+ nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+ switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
is($?, 0, 'coredump in global destruction');
# test CLONE_SKIP() functionality
use strict;
use warnings;
-our $VERSION = '1.32';
+our $VERSION = '1.33';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
### Methods, etc. ###
+# Our own exit function/method
+sub exit
+{
+ CORE::exit(0);
+}
+
# 'new' is an alias for 'create'
*new = \&create;
=head1 VERSION
-This document describes threads version 1.32
+This document describes threads version 1.33
=head1 SYNOPSIS
$thr->kill('SIGUSR1');
+ threads->exit();
+
=head1 DESCRIPTION
Perl 5.6 introduced something called interpreter threads. Interpreter threads
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
-of the main thread, reaches the end of the main program file.)
+If the program exits without all threads having either been joined or
+detached, then a warning will be issued.
Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already joined thread will
cause an error to be thrown.
=item $thr->detach()
Makes the thread unjoinable, and causes any eventual return value to be
-discarded.
+discarded. When the program exits, any detached threads that are still
+running are silently terminated.
+
+If the program exits without all threads having either been joined or
+detached, then a warning will be issued.
Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already detached thread
will cause an error to be thrown.
Class method that allows a thread to detach itself.
+=item threads->exit()
+
+The usual method for terminating a thread is to
+L<return()|perlfunc/"return EXPR"> from the entry point function with the
+appropriate return value(s).
+
+If needed, a thread can be exited at any time by calling
+C<threads-E<gt>exit()>. This will cause the thread to return C<undef> in a
+scalar context, or the empty list in a list context.
+
+Calling C<die()> in a thread indicates an abnormal exit for the thread. Any
+C<$SIG{__DIE__}> handler in the thread will be called first, and then the
+thread will exit with a warning message that will contain any arguments passed
+in the C<die()> call.
+
+Calling C<exit()> in a thread is discouraged, but is equivalent to calling
+C<threads-E<gt>exit()>.
+
+If the desired affect is to truly terminate the application from a thread,
+then use L<POSIX::_exit()|POSIX/"_exit">, if available.
+
=item threads->self()
Class method that allows a thread to obtain its own I<threads> object.
=over 4
-=item A thread exited while # other threads were still running
+=item Perl exited with active threads:
-A thread (not necessarily the main thread) exited while there were still other
-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.
+If the program exits without all threads having either been joined or
+detached, then this warning will be issued.
+
+NOTE: This warning cannot be suppressed using C<no warnings 'threads';> as
+suggested below.
=item Thread creation failed: pthread_create returned #
=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>.
+point function. For example, the thread may have terminated using C<die>.
=item Using minimum thread stack size of #
$thr->set_stack_size($size);
-=item Cannot signal other threads without safe signals
+=item Cannot signal 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.
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.32/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.33/threads.pm>
L<threads::shared>, L<perlthrtut>
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+/* Workaround for XSUB.h bug under WIN32 */
+#ifdef WIN32
+# undef setjmp
+# define setjmp(x) _setjmp(x)
+#endif
#ifdef HAS_PPPORT_H
# define NEED_PL_signals
# define NEED_newRV_noinc
static perl_mutex create_destruct_mutex;
static UV tid_counter = 0;
-static IV active_threads = 0;
static IV joinable_threads = 0;
+static IV running_threads = 0;
+static IV detached_threads = 0;
#ifdef THREAD_CREATE_NEEDS_STACK
static IV default_stack_size = THREAD_CREATE_NEEDS_STACK;
#else
return;
}
- MUTEX_LOCK(&create_destruct_mutex);
/* Main thread (0) is immortal and should never get here */
assert(thread->tid != 0);
/* Remove from circular list of threads */
+ MUTEX_LOCK(&create_destruct_mutex);
thread->next->prev = thread->prev;
thread->prev->next = thread->next;
thread->next = NULL;
{
int veto_cleanup = 0;
MUTEX_LOCK(&create_destruct_mutex);
- if ((aTHX == PL_curinterp) && (joinable_threads != 1)) {
+ if ((aTHX == PL_curinterp) &&
+ (running_threads || joinable_threads))
+ {
if (ckWARN_d(WARN_THREADS)) {
- Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", joinable_threads);
+ Perl_warn(aTHX_ "Perl exited with active threads:\n\t%"
+ IVdf " running and unjoined\n\t%"
+ IVdf " finished and unjoined\n\t%"
+ IVdf " running and detached\n",
+ running_threads,
+ joinable_threads,
+ detached_threads);
}
veto_cleanup = 1;
}
#ifdef PTHREAD_STACK_MIN
/* Can't use less than minimum */
if (stack_size < PTHREAD_STACK_MIN) {
- if (ckWARN_d(WARN_THREADS)) {
+ if (ckWARN(WARN_THREADS)) {
Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN);
}
return (PTHREAD_STACK_MIN);
AV *params = (AV *)SvRV(thread->params);
int len = (int)av_len(params)+1;
int ii;
+ int jmp_rc = 0;
+ I32 oldscope;
+
+ dJMPENV;
dSP;
ENTER;
}
PUTBACK;
- /* Run the specified function */
- len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
+ oldscope = PL_scopestack_ix;
+ JMPENV_PUSH(jmp_rc);
+ if (jmp_rc == 0) {
+ /* Run the specified function */
+ len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
+ } else if (jmp_rc == 2) {
+ while (PL_scopestack_ix > oldscope) {
+ LEAVE;
+ }
+ }
+ JMPENV_POP;
/* Remove args from stack and put back in params array */
SPAGAIN;
for (ii=len-1; ii >= 0; ii--) {
SV *sv = POPs;
- av_store(params, ii, SvREFCNT_inc(sv));
+ if (jmp_rc == 0) {
+ av_store(params, ii, SvREFCNT_inc(sv));
+ }
}
+ FREETMPS;
+ LEAVE;
+
/* Check for failure */
if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
- Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
+ oldscope = PL_scopestack_ix;
+ JMPENV_PUSH(jmp_rc);
+ if (jmp_rc == 0) {
+ Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
+ } else if (jmp_rc == 2) {
+ while (PL_scopestack_ix > oldscope) {
+ LEAVE;
+ }
+ }
+ JMPENV_POP;
}
- FREETMPS;
- LEAVE;
-
/* Release function ref */
SvREFCNT_dec(thread->init_function);
thread->init_function = Nullsv;
cleanup = (thread->state & PERL_ITHR_DETACHED);
MUTEX_UNLOCK(&thread->mutex);
- if (cleanup)
+ if (cleanup) {
+ MUTEX_LOCK(&create_destruct_mutex);
+ detached_threads--;
+ MUTEX_UNLOCK(&create_destruct_mutex);
S_ithread_destruct(aTHX_ thread);
-
- MUTEX_LOCK(&create_destruct_mutex);
- active_threads--;
- if (!cleanup) {
- joinable_threads--;
+ } else {
+ MUTEX_LOCK(&create_destruct_mutex);
+ running_threads--;
+ joinable_threads++;
+ MUTEX_UNLOCK(&create_destruct_mutex);
}
- MUTEX_UNLOCK(&create_destruct_mutex);
#ifdef WIN32
return ((DWORD)0);
return (&PL_sv_undef);
}
- active_threads++;
- joinable_threads++;
+ running_threads++;
MUTEX_UNLOCK(&create_destruct_mutex);
sv_2mortal(params);
IV stack_size;
int context;
char *str;
- char ch;
int idx;
int ii;
CODE:
S_ithread_clear(aTHX_ thread);
MUTEX_UNLOCK(&thread->mutex);
+ MUTEX_LOCK(&create_destruct_mutex);
+ joinable_threads--;
+ MUTEX_UNLOCK(&create_destruct_mutex);
+
/* If no return values, then just return */
if (! params) {
XSRETURN_UNDEF;
cleanup = (thread->state & PERL_ITHR_FINISHED);
MUTEX_UNLOCK(&thread->mutex);
- if (cleanup)
+ MUTEX_LOCK(&create_destruct_mutex);
+ if (cleanup) {
+ joinable_threads--;
+ } else {
+ running_threads--;
+ detached_threads++;
+ }
+ MUTEX_UNLOCK(&create_destruct_mutex);
+
+ if (cleanup) {
S_ithread_destruct(aTHX_ thread);
- else {
- MUTEX_LOCK(&create_destruct_mutex);
- joinable_threads--;
- MUTEX_UNLOCK(&create_destruct_mutex);
- }
+ }
void
CODE:
/* Must have safe signals */
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
- Perl_croak(aTHX_ "Cannot signal other threads without safe signals");
+ Perl_croak(aTHX_ "Cannot signal 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)) {
signal = SvIV(ST(1));
/* Set the signal for the thread */
+ thread = SV_to_ithread(aTHX_ ST(0));
+ MUTEX_LOCK(&thread->mutex);
{
dTHXa(thread->interp);
PL_psig_pend[signal]++;
PL_sig_pending = 1;
}
+ MUTEX_UNLOCK(&thread->mutex);
/* Return the thread to allow for method chaining */
ST(0) = ST(0);
}
Zero(thread, 1, ithread);
- PL_perl_destruct_level = 2;
MUTEX_INIT(&thread->mutex);
thread->tid = tid_counter++; /* Thread 0 */
thread->thr = pthread_self();
# endif
- active_threads++;
- joinable_threads++;
-
S_ithread_set(aTHX_ thread);
MUTEX_UNLOCK(&create_destruct_mutex);
#endif /* USE_ITHREADS */
projects / p5sagit/p5-mst-13.2.git / commitdiff