From 69a9b4b8cb205b3194738b7a08fc3fb9f858174f Mon Sep 17 00:00:00 2001 From: Rafael Garcia-Suarez Date: Thu, 20 Jul 2006 21:36:25 +0000 Subject: [PATCH] Upgrade to threads 1.37, by Jerry D. Hedden p4raw-id: //depot/perl@28602 --- ext/threads/Changes | 3 + ext/threads/README | 2 +- ext/threads/t/exit.t | 302 +++++++++++++++++-------------------------------- ext/threads/t/thread.t | 6 +- ext/threads/threads.pm | 145 +++++++++++++++++++----- ext/threads/threads.xs | 110 +++++++++++++++--- 6 files changed, 315 insertions(+), 253 deletions(-) diff --git a/ext/threads/Changes b/ext/threads/Changes index 71d6313..0dc2bf3 100755 --- a/ext/threads/Changes +++ b/ext/threads/Changes @@ -1,5 +1,8 @@ Revision history for Perl extension threads. +1.37 Thu Jul 20 13:33:33 EDT 2006 + - Revert 'exit' behavior with override + 1.36 Mon Jul 10 15:58:13 EDT 2006 - Ignore signals sent to terminated threads diff --git a/ext/threads/README b/ext/threads/README index 7269f37..03f5fb9 100755 --- a/ext/threads/README +++ b/ext/threads/README @@ -1,4 +1,4 @@ -threads version 1.36 +threads version 1.37 ==================== This module exposes interpreter threads to the Perl level. diff --git a/ext/threads/t/exit.t b/ext/threads/t/exit.t index fa395ee..021d751 100644 --- a/ext/threads/t/exit.t +++ b/ext/threads/t/exit.t @@ -11,6 +11,8 @@ BEGIN { print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); exit(0); } + + require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl"); } use ExtUtils::testlib; @@ -28,42 +30,11 @@ BEGIN { } $| = 1; - print("1..226\n"); ### Number of tests that will be run ### + print("1..18\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 { @@ -76,187 +47,118 @@ $SIG{'__DIE__'} = sub { }; -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 $thr = threads->create(sub { + threads->exit(); + return (99); # Not seen +}); +ok($thr, 'Created: threads->exit()'); +my $rc = $thr->join(); +ok(! defined($rc), 'Exited: threads->exit()'); -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'); +run_perl(prog => 'use threads 1.37; + threads->exit(86); + exit(99);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); +is($?>>8, 86, 'thread->exit(status) in main'); - # 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"'); - } +$thr = threads->create({'exit' => 'thread_only'}, sub { + exit(1); + return (99); # Not seen + }); +ok($thr, 'Created: thread_only'); +$rc = $thr->join(); +ok(! defined($rc), 'Exited: thread_only'); - $rc = threads->create('nasty', $thr, $wrn, $die)->join(); - close(STDERR); - }; +$thr = threads->create(sub { + threads->set_thread_exit_only(1); + exit(1); + return (99); # Not seen +}); +ok($thr, 'Created: threads->set_thread_exit_only'); +$rc = $thr->join(); +ok(! defined($rc), 'Exited: threads->set_thread_exit_only'); - # Filter out 'un-capturable' output - if (open(IN, 'tmp.stderr')) { - while (my $line = ) { - 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'"); - } +my $WAIT :shared = 1; +$thr = threads->create(sub { + lock($WAIT); + while ($WAIT) { + cond_wait($WAIT); } -} - - -# Again with: -no warnings 'threads'; - -sub less_nasty + exit(1); + return (99); # Not seen +}); +threads->yield(); +ok($thr, 'Created: $thr->set_thread_exit_only'); +$thr->set_thread_exit_only(1); { - 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); - } + lock($WAIT); + $WAIT = 0; + cond_broadcast($WAIT); } - -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'"); - } - } +$rc = $thr->join(); +ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); + + +run_perl(prog => 'use threads 1.37 qw(exit thread_only); + threads->create(sub { exit(99); })->join(); + exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); +is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); + + +SKIP: { + skip('run_perl+STDERR broken under MSWin32', 4) if ($^O eq 'MSWin32'); + + my $out = run_perl(prog => 'use threads 1.37; + threads->create(sub { + exit(99); + })->join(); + exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ], + stderr => 1); + is($?>>8, 99, "exit(status) in thread"); + like($out, '1 finished and unjoined', "exit(status) in thread"); + + + $out = run_perl(prog => 'use threads 1.37 qw(exit thread_only); + threads->create(sub { + threads->set_thread_exit_only(0); + exit(99); + })->join(); + exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ], + stderr => 1); + is($?>>8, 99, "set_thread_exit_only(0)"); + like($out, '1 finished and unjoined', "set_thread_exit_only(0)"); } -# Check termination warning concerning running threads -$SIG{'__WARN__'} = sub { - my $msg = shift; - if ($^O eq 'VMS') { - ok($msg =~ /0 running and unjoined/, '0 running and unjoined (VMS)'); - ok($msg =~ /3 finished and unjoined/, '3 finished and unjoined (VMS)'); - ok($msg =~ /0 running and detached/, '0 finished and detached (VMS)'); - } else { - 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); +run_perl(prog => 'use threads 1.37; + threads->create(sub { + $SIG{__WARN__} = sub { exit(99); }; + die(); + })->join(); + exit(86);', + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); +is($?>>8, 99, "exit(status) in thread warn handler"); + + +$thr = threads->create(sub { + $SIG{__WARN__} = sub { threads->exit(); }; + local $SIG{__DIE__} = 'DEFAULT'; + die('Died'); +}); +ok($thr, 'Created: threads->exit() in thread warn handler'); +$rc = $thr->join(); +ok(! defined($rc), 'Exited: threads->exit() in thread warn handler'); # EOF diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t index d29d523..b104616 100644 --- a/ext/threads/t/thread.t +++ b/ext/threads/t/thread.t @@ -171,11 +171,11 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.36; +run_perl(prog => 'use threads 1.37; 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' ]); + nolib => ($ENV{PERL_CORE}) ? 0 : 1, + switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); is($?, 0, 'coredump in global destruction'); # test CLONE_SKIP() functionality diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index 04e0692..bec14b6 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.36'; +our $VERSION = '1.37'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -47,9 +47,13 @@ sub import # Handle args while (my $sym = shift) { - if ($sym =~ /^stack/) { + if ($sym =~ /^stack/i) { threads->set_stack_size(shift); + } elsif ($sym =~ /^exit/i) { + my $flag = shift; + $threads::thread_exit_only = $flag =~ /^thread/i; + } elsif ($sym =~ /all/) { push(@EXPORT, qw(yield)); @@ -74,10 +78,22 @@ sub import ### Methods, etc. ### -# Our own exit function/method +# Exit from a thread (only) sub exit { - CORE::exit(0); + my ($class, $status) = @_; + if (! defined($status)) { + $status = 0; + } + + # Class method only + if (ref($class)) { + require Carp; + Carp::croak("Usage: threads->exit(status)"); + } + + $class->set_thread_exit_only(1); + CORE::exit($status); } # 'Constant' args for threads->list() @@ -113,11 +129,11 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.36 +This document describes threads version 1.37 =head1 SYNOPSIS - use threads ('yield', 'stack_size' => 64*4096); + use threads ('yield', 'stack_size' => 64*4096, 'exit' => 'threads_only'); sub start_thread { my @args = @_; @@ -140,32 +156,39 @@ This document describes threads version 1.36 $thread->detach(); + # Get a thread's object $thread = threads->self(); $thread = threads->object($tid); + # Get a thread's ID $tid = threads->tid(); $tid = threads->self->tid(); $tid = $thread->tid(); + # Give other threads a chance to run threads->yield(); yield(); + # Lists of non-detached threads my @threads = threads->list(); my $thread_count = threads->list(); my @running = threads->list(threads::running); my @joinable = threads->list(threads::joinable); + # Test thread objects if ($thr1 == $thr2) { ... } + # Manage thread stack size $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 }, + 'stack_size' => 32*4096, + 'exit' => 'thread_only' }, \&foo); # Get thread's context @@ -179,8 +202,10 @@ This document describes threads version 1.36 $thr->join(); } + # Send a signal to a thread $thr->kill('SIGUSR1'); + # Exit a thread threads->exit(); =head1 DESCRIPTION @@ -285,27 +310,6 @@ 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 from the entry point function with the -appropriate return value(s). - -If needed, a thread can be exited at any time by calling -Cexit()>. This will cause the thread to return C in a -scalar context, or the empty list in a list context. - -Calling C 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 call. - -Calling C in a thread is discouraged, but is equivalent to calling -Cexit()>. - -If the desired affect is to truly terminate the application from a thread, -then use L, if available. - =item threads->self() Class method that allows a thread to obtain its own I object. @@ -395,6 +399,83 @@ Class method that allows a thread to obtain its own I. =back +=head1 EXITING A THREAD + +The usual method for terminating a thread is to +L from the entry point function with the +appropriate return value(s). + +=over + +=item threads->exit() + +If needed, a thread can be exited at any time by calling +Cexit()>. This will cause the thread to return C in a +scalar context, or the empty list in a list context. + +When called from the I
thread, this behaves the same as C. + +=item threads->exit(status) + +When called from a thread, this behaves like Cexit()> (i.e., the +exit status code is ignored). + +When called from the I
thread, this behaves the same as C. + +=item die() + +Calling C 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 call. + +=item exit(status) + +Calling L inside a thread causes the whole +application to terminate. Because of this, the use of C inside +threaded code, or in modules that might be used in threaded applications, is +strongly discouraged. + +If C really is needed, then consider using the following: + + threads->exit() if $threads::threads; # Thread friendly + exit(status); + +=item use threads 'exit' => 'thread_only' + +This globally overrides the default behavior of calling C inside a +thread, and effectively causes such calls to behave the same as +Cexit()>. In other words, with this setting, calling C +causes only the thread to terminate. + +Because of its global effect, this setting should not be used inside modules +or the like. + +The I
thread is unaffected by this setting. + +=item threads->create({'exit' => 'thread_only'}, ...) + +This overrides the default behavior of C inside the newly created +thread only. + +=item $thr->set_thread_exit_only(boolean) + +This can be used to change the I behavior for a thread after +it has been created. With a I argument, C will cause the only +the thread to exit. With a I argument, C will terminate the +application. + +The I
thread is unaffected by this call. + +=item threads->set_thread_exit_only(boolean) + +Class method for use inside a thread to changes its own behavior for +C. + +The I
thread is unaffected by this call. + +=back + =head1 THREAD STATE The following boolean methods are useful in determining the I of a @@ -660,6 +741,8 @@ 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. +Sending a signal to a terminated thread is ignored. + =head1 WARNINGS =over 4 @@ -669,8 +752,8 @@ such that the signal is acted up immediately. 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 as -suggested below. +NOTE: If the I
thread exits, then this warning cannot be suppressed +using C as suggested below. =item Thread creation failed: pthread_create returned # @@ -804,7 +887,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 c648bcd..d0a8f4a 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -45,10 +45,11 @@ typedef perl_os_thread pthread_t; #endif /* Values for 'state' member */ -#define PERL_ITHR_JOINABLE 0 -#define PERL_ITHR_DETACHED 1 -#define PERL_ITHR_JOINED 2 -#define PERL_ITHR_FINISHED 4 +#define PERL_ITHR_JOINABLE 0 +#define PERL_ITHR_DETACHED 1 +#define PERL_ITHR_JOINED 2 +#define PERL_ITHR_FINISHED 4 +#define PERL_ITHR_THREAD_EXIT_ONLY 8 typedef struct _ithread { struct _ithread *next; /* Next thread in the list */ @@ -197,15 +198,14 @@ S_ithread_destruct(pTHX_ ithread *thread) } -/* Called on exit */ +/* Warn if exiting with any unjoined threads */ int -Perl_ithread_hook(pTHX) +S_exit_warning(pTHX) { int veto_cleanup = 0; + MUTEX_LOCK(&create_destruct_mutex); - if ((aTHX == PL_curinterp) && - (running_threads || joinable_threads)) - { + if (running_threads || joinable_threads) { if (ckWARN_d(WARN_THREADS)) { Perl_warn(aTHX_ "Perl exited with active threads:\n\t%" IVdf " running and unjoined\n\t%" @@ -218,9 +218,17 @@ Perl_ithread_hook(pTHX) veto_cleanup = 1; } MUTEX_UNLOCK(&create_destruct_mutex); + return (veto_cleanup); } +/* Called on exit from main thread */ +int +Perl_ithread_hook(pTHX) +{ + return ((aTHX == PL_curinterp) ? S_exit_warning(aTHX) : 0); +} + /* MAGIC (in mg.h sense) hooks */ @@ -339,8 +347,14 @@ S_ithread_run(void * arg) #endif { ithread *thread = (ithread *)arg; + int jmp_rc = 0; + I32 oldscope; + int exit_app = 0; + int exit_code = 0; int cleanup; + dJMPENV; + dTHXa(thread->interp); PERL_SET_CONTEXT(thread->interp); S_ithread_set(aTHX_ thread); @@ -362,10 +376,6 @@ S_ithread_run(void * arg) AV *params = (AV *)SvRV(thread->params); int len = (int)av_len(params)+1; int ii; - int jmp_rc = 0; - I32 oldscope; - - dJMPENV; dSP; ENTER; @@ -384,6 +394,9 @@ S_ithread_run(void * arg) /* Run the specified function */ len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); } else if (jmp_rc == 2) { + /* Thread exited */ + exit_app = 1; + exit_code = STATUS_CURRENT; while (PL_scopestack_ix > oldscope) { LEAVE; } @@ -407,8 +420,12 @@ S_ithread_run(void * arg) oldscope = PL_scopestack_ix; JMPENV_PUSH(jmp_rc); if (jmp_rc == 0) { + /* Warn that thread died */ Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV); } else if (jmp_rc == 2) { + /* Warn handler exited */ + exit_app = 1; + exit_code = STATUS_CURRENT; while (PL_scopestack_ix > oldscope) { LEAVE; } @@ -426,21 +443,45 @@ S_ithread_run(void * arg) MUTEX_LOCK(&thread->mutex); /* Mark as finished */ thread->state |= PERL_ITHR_FINISHED; + /* Clear exit flag if required */ + if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) + exit_app = 0; /* Cleanup if detached */ cleanup = (thread->state & PERL_ITHR_DETACHED); MUTEX_UNLOCK(&thread->mutex); + /* Adjust thread status counts */ + MUTEX_LOCK(&create_destruct_mutex); if (cleanup) { - MUTEX_LOCK(&create_destruct_mutex); detached_threads--; - MUTEX_UNLOCK(&create_destruct_mutex); - S_ithread_destruct(aTHX_ thread); } else { - MUTEX_LOCK(&create_destruct_mutex); running_threads--; joinable_threads++; - MUTEX_UNLOCK(&create_destruct_mutex); } + MUTEX_UNLOCK(&create_destruct_mutex); + + /* Exit application if required */ + if (exit_app) { + oldscope = PL_scopestack_ix; + JMPENV_PUSH(jmp_rc); + if (jmp_rc == 0) { + /* Warn if there are unjoined threads */ + S_exit_warning(aTHX); + } else if (jmp_rc == 2) { + /* Warn handler exited */ + exit_code = STATUS_CURRENT; + while (PL_scopestack_ix > oldscope) { + LEAVE; + } + } + JMPENV_POP; + + my_exit(exit_code); + } + + /* Clean up detached thread */ + if (cleanup) + S_ithread_destruct(aTHX_ thread); #ifdef WIN32 return ((DWORD)0); @@ -498,6 +539,7 @@ S_ithread_create( SV *init_function, IV stack_size, int gimme, + int exit_opt, SV *params) { ithread *thread; @@ -537,6 +579,7 @@ S_ithread_create( thread->tid = tid_counter++; thread->stack_size = good_stack_size(aTHX_ stack_size); thread->gimme = gimme; + thread->state = exit_opt; /* "Clone" our interpreter into the thread's interpreter. * This gives thread access to "static data" and code. @@ -725,6 +768,8 @@ ithread_create(...) HV *specs; IV stack_size; int context; + int exit_opt; + SV *thread_exit_only; char *str; int idx; int ii; @@ -746,10 +791,14 @@ ithread_create(...) classname = HvNAME(SvSTASH(SvRV(ST(0)))); thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); stack_size = thread->stack_size; + exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY; } else { /* threads->create() */ classname = (char *)SvPV_nolen(ST(0)); stack_size = default_stack_size; + thread_exit_only = get_sv("threads::thread_exit_only", TRUE); + exit_opt = (SvTRUE(thread_exit_only)) + ? PERL_ITHR_THREAD_EXIT_ONLY : 0; } function_to_call = ST(idx+1); @@ -797,6 +846,13 @@ ithread_create(...) context = G_VOID; } } + + /* exit => thread_only */ + if (hv_exists(specs, "exit", 4)) { + str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0)); + exit_opt = (*str == 't' || *str == 'T') + ? PERL_ITHR_THREAD_EXIT_ONLY : 0; + } } if (context == -1) { context = GIMME_V; /* Implicit context */ @@ -818,6 +874,7 @@ ithread_create(...) function_to_call, stack_size, context, + exit_opt, newRV_noinc((SV*)params))); /* XSRETURN(1); - implied */ @@ -1267,6 +1324,23 @@ ithread_wantarray(...) MUTEX_UNLOCK(&thread->mutex); /* XSRETURN(1); - implied */ + +void +ithread_set_thread_exit_only(...) + PREINIT: + ithread *thread; + CODE: + if (items != 2) + Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)"); + thread = SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + if (SvTRUE(ST(1))) { + thread->state |= PERL_ITHR_THREAD_EXIT_ONLY; + } else { + thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY; + } + MUTEX_UNLOCK(&thread->mutex); + #endif /* USE_ITHREADS */ -- 2.7.4