This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to threads 1.37, by Jerry D. Hedden
authorRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Thu, 20 Jul 2006 21:36:25 +0000 (21:36 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Thu, 20 Jul 2006 21:36:25 +0000 (21:36 +0000)
p4raw-id: //depot/perl@28602

ext/threads/Changes
ext/threads/README
ext/threads/t/exit.t
ext/threads/t/thread.t
ext/threads/threads.pm
ext/threads/threads.xs

index 71d6313..0dc2bf3 100755 (executable)
@@ -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
 
index 7269f37..03f5fb9 100755 (executable)
@@ -1,4 +1,4 @@
-threads version 1.36
+threads version 1.37
 ====================
 
 This module exposes interpreter threads to the Perl level.
index fa395ee..021d751 100644 (file)
@@ -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 = <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'");
-        }
+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
index d29d523..b104616 100644 (file)
@@ -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
index 04e0692..bec14b6 100755 (executable)
@@ -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<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.
@@ -395,6 +399,83 @@ Class method that allows a thread to obtain its own I<handle>.
 
 =back
 
+=head1 EXITING A THREAD
+
+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).
+
+=over
+
+=item threads->exit()
+
+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.
+
+When called from the I<main> thread, this behaves the same as C<exit(0)>.
+
+=item threads->exit(status)
+
+When called from a thread, this behaves like C<threads-E<gt>exit()> (i.e., the
+exit status code is ignored).
+
+When called from the I<main> thread, this behaves the same as C<exit(status)>.
+
+=item die()
+
+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.
+
+=item exit(status)
+
+Calling L<exit()|perlfunc/"exit EXPR"> inside a thread causes the whole
+application to terminate.  Because of this, the use of C<exit()> inside
+threaded code, or in modules that might be used in threaded applications, is
+strongly discouraged.
+
+If C<exit()> 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<exit()> inside a
+thread, and effectively causes such calls to behave the same as
+C<threads-E<gt>exit()>.  In other words, with this setting, calling C<exit()>
+causes only the thread to terminate.
+
+Because of its global effect, this setting should not be used inside modules
+or the like.
+
+The I<main> thread is unaffected by this setting.
+
+=item threads->create({'exit' => 'thread_only'}, ...)
+
+This overrides the default behavior of C<exit()> inside the newly created
+thread only.
+
+=item $thr->set_thread_exit_only(boolean)
+
+This can be used to change the I<exit thread only> behavior for a thread after
+it has been created.  With a I<true> argument, C<exit()> will cause the only
+the thread to exit.  With a I<false> argument, C<exit()> will terminate the
+application.
+
+The I<main> 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<exit()>.
+
+The I<main> thread is unaffected by this call.
+
+=back
+
 =head1 THREAD STATE
 
 The following boolean methods are useful in determining the I<state> of a
@@ -660,6 +741,8 @@ 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.
 
+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<no warnings 'threads';> as
-suggested below.
+NOTE:  If the I<main> thread exits, then this warning cannot be suppressed
+using C<no warnings 'threads';> as suggested below.
 
 =item Thread creation failed: pthread_create returned #
 
@@ -804,7 +887,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.36/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.37/threads.pm>
 
 L<threads::shared>, L<perlthrtut>
 
index c648bcd..d0a8f4a 100755 (executable)
@@ -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 */