From: Jerry D. Hedden Date: Thu, 14 Dec 2006 11:17:47 +0000 (-0800) Subject: threads 1.54 - Adds ->error() method X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=955c272e505839f6c86e2403961d6237672ec9af;p=p5sagit%2Fp5-mst-13.2.git threads 1.54 - Adds ->error() method From: "Jerry D. Hedden" Message-ID: <20061214191748.98286.qmail@web30209.mail.mud.yahoo.com> p4raw-id: //depot/perl@29557 --- diff --git a/MANIFEST b/MANIFEST index cd23a03..390e026 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1136,6 +1136,7 @@ ext/threads/t/basic.t ithreads 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/err.t Test $thr->error() 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 diff --git a/ext/threads/Changes b/ext/threads/Changes index 9e70741..698f337 100755 --- a/ext/threads/Changes +++ b/ext/threads/Changes @@ -1,5 +1,8 @@ Revision history for Perl extension threads. +1.54 Thu Dec 14 14:12:30 EST 2006 + - Added ->error() method + 1.53 Mon Nov 27 12:08:27 EST 2006 - Fix for a thread cloning bug - Fixes to test suite diff --git a/ext/threads/README b/ext/threads/README index 9fa2903..3803a26 100755 --- a/ext/threads/README +++ b/ext/threads/README @@ -1,4 +1,4 @@ -threads version 1.53 +threads version 1.54 ==================== This module exposes interpreter threads to the Perl level. diff --git a/ext/threads/t/err.t b/ext/threads/t/err.t new file mode 100644 index 0000000..a0df7a5 --- /dev/null +++ b/ext/threads/t/err.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + + require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl"); + + use Config; + if (! $Config{'useithreads'}) { + skip_all(q/Perl not compiled with 'useithreads'/); + } + + plan(10); +} + +use ExtUtils::testlib; + +use_ok('threads'); + +### Start of Testing ### + +no warnings 'threads'; + +# Create a thread that generates an error +my $thr = threads->create(sub { my $x = 5/0; }); + +# Check that thread returns 'undef' +my $result = $thr->join(); +ok(! defined($result), 'thread died'); + +# Check error +like($thr->error(), 'division by zero', 'thread error'); + + +# Create a thread that 'die's with an object +$thr = threads->create(sub { + threads->yield(); + sleep(1); + die(bless({ error => 'bogus' }, 'Err::Class')); + }); + +my $err = $thr->error(); +ok(! defined($err), 'no error yet'); + +# Check that thread returns 'undef' +$result = $thr->join(); +ok(! defined($result), 'thread died'); + +# Check that error object is retrieved +$err = $thr->error(); +isa_ok($err, 'Err::Class', 'error object'); +is($err->{error}, 'bogus', 'error field'); + +# Check that another thread can reference the error object +my $thrx = threads->create(sub { die(bless($thr->error(), 'Foo')); }); + +# Check that thread returns 'undef' +$result = $thrx->join(); +ok(! defined($result), 'thread died'); + +# Check that the rethrown error object is retrieved +$err = $thrx->error(); +isa_ok($err, 'Foo', 'error object'); +is($err->{error}, 'bogus', 'error field'); + +# EOF diff --git a/ext/threads/t/exit.t b/ext/threads/t/exit.t index 95a7610..25fba99 100644 --- a/ext/threads/t/exit.t +++ b/ext/threads/t/exit.t @@ -56,7 +56,7 @@ my $rc = $thr->join(); ok(! defined($rc), 'Exited: threads->exit()'); -run_perl(prog => 'use threads 1.53;' . +run_perl(prog => 'use threads 1.54;' . 'threads->exit(86);' . 'exit(99);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -104,7 +104,7 @@ $rc = $thr->join(); ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); -run_perl(prog => 'use threads 1.53 qw(exit thread_only);' . +run_perl(prog => 'use threads 1.54 qw(exit thread_only);' . 'threads->create(sub { exit(99); })->join();' . 'exit(86);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -112,7 +112,7 @@ run_perl(prog => 'use threads 1.53 qw(exit thread_only);' . is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); -my $out = run_perl(prog => 'use threads 1.53;' . +my $out = run_perl(prog => 'use threads 1.54;' . 'threads->create(sub {' . ' exit(99);' . '})->join();' . @@ -124,7 +124,7 @@ is($?>>8, 99, "exit(status) in thread"); like($out, '1 finished and unjoined', "exit(status) in thread"); -$out = run_perl(prog => 'use threads 1.53 qw(exit thread_only);' . +$out = run_perl(prog => 'use threads 1.54 qw(exit thread_only);' . 'threads->create(sub {' . ' threads->set_thread_exit_only(0);' . ' exit(99);' . @@ -137,7 +137,7 @@ is($?>>8, 99, "set_thread_exit_only(0)"); like($out, '1 finished and unjoined', "set_thread_exit_only(0)"); -run_perl(prog => 'use threads 1.53;' . +run_perl(prog => 'use threads 1.54;' . 'threads->create(sub {' . ' $SIG{__WARN__} = sub { exit(99); };' . ' die();' . diff --git a/ext/threads/t/libc.t b/ext/threads/t/libc.t index af6cc32..740588a 100644 --- a/ext/threads/t/libc.t +++ b/ext/threads/t/libc.t @@ -6,37 +6,20 @@ BEGIN { 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; -sub ok { - my ($id, $ok, $name) = @_; + require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl"); - # 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]); + use Config; + if (! $Config{'useithreads'}) { + skip_all(q/Perl not compiled with 'useithreads'/); } - return ($ok); + plan(11); } -use threads; - -BEGIN { - $| = 1; - print("1..12\n"); ### Number of tests that will be run ### -}; +use ExtUtils::testlib; -ok(1, 1, 'Loaded'); +use_ok('threads'); ### Start of Testing ### @@ -44,30 +27,28 @@ my $i = 10; my $y = 20000; my %localtime; -for (0..$i) { +for (1..$i) { $localtime{$_} = localtime($_); }; my @threads; -for (0..$i) { - my $thread = threads->create(sub { - my $arg = $_; - my $localtime = $localtime{$arg}; - my $error = 0; - for (0..$y) { - my $lt = localtime($arg); - if ($localtime ne $lt) { - $error++; +for (1..$i) { + $threads[$_] = threads->create(sub { + my $arg = shift; + my $localtime = $localtime{$arg}; + my $error = 0; + for (1..$y) { + my $lt = localtime($arg); + if ($localtime ne $lt) { + $error++; + } } - } - return $error; - }); - push @threads, $thread; + return $error; + }, $_); } -for (0..$i) { - my $result = $threads[$_]->join(); - ok($_ + 2, defined($result) && ("$result" eq '0'), 'localtime safe'); +for (1..$i) { + is($threads[$_]->join(), 0, 'localtime() thread-safe'); } # EOF diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t index 67882bd..cf3a232 100644 --- a/ext/threads/t/thread.t +++ b/ext/threads/t/thread.t @@ -171,7 +171,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.53;' . +run_perl(prog => 'use threads 1.54;' . 'sub a{threads->create(shift)} $t = a sub{};' . '$t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index ce74727..a718dcf 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.53'; +our $VERSION = '1.54'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -133,7 +133,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.53 +This document describes threads version 1.54 =head1 SYNOPSIS @@ -153,6 +153,9 @@ This document describes threads version 1.53 my $thr2 = async { foreach (@files) { ... } }; $thr2->join(); + if (my $err = $thr2->error()) { + warn("Thread error: $err\n"); + } # Invoke thread in list context (implicit) so it can return a list my ($thr) = threads->create(sub { return (qw/a b c/); }); @@ -398,6 +401,12 @@ it. This block is treated as an anonymous subroutine, and so must have a semi-colon after the closing brace. Like Ccreate()>, C returns a I object. +=item $thr->error() + +Threads are executed in an C context. This method will return C +if the thread terminates I. Otherwise, it returns the value of +C<$@> associated with the thread's execution status in its C context. + =item $thr->_handle() This I method returns the memory location of the internal thread @@ -781,7 +790,8 @@ 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 terminated using C. +point function, or by using Cexit()>. For example, the thread +may have terminated because of a error, or by using C. =item Using minimum thread stack size of # @@ -858,10 +868,10 @@ C if needed): .... } -If the module will only be used inside the I
thread, try modifying your -application so that the module is loaded (again using C and C) -after any threads are started, and in such a way that no other threads are -started afterwards. +If the module is needed inside the I
thread, try modifying your +application so that the module is loaded (again using C and +C) after any threads are started, and in such a way that no other +threads are started afterwards. If the above does not work, or is not adequate for your application, then file a bug report on L against the problematic module. @@ -918,6 +928,10 @@ Perl version and the application code, results may range from success, to (apparently harmless) warnings of leaked scalar, or all the way up to crashing of the Perl interpreter. +=item Returning objects from threads + +Returning objects from threads does not work. + =item Perl Bugs and the CPAN Version of L Support for threads extents beyond the code in this module (i.e., @@ -938,7 +952,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 65588b4..cc4e7c9 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -51,6 +51,7 @@ typedef perl_os_thread pthread_t; #define PERL_ITHR_THREAD_EXIT_ONLY 8 #define PERL_ITHR_NONVIABLE 16 #define PERL_ITHR_DESTROYED 32 +#define PERL_ITHR_DIED 64 typedef struct _ithread { struct _ithread *next; /* Next thread in the list */ @@ -70,6 +71,8 @@ typedef struct _ithread { pthread_t thr; /* OS's handle for the thread */ #endif IV stack_size; + SV *err; /* Error from abnormally terminated thread */ + char *err_class; /* Error object's classname if applicable */ } ithread; @@ -149,6 +152,11 @@ S_ithread_clear(pTHX_ ithread *thread) SvREFCNT_dec(thread->params); thread->params = Nullsv; + if (thread->err) { + SvREFCNT_dec(thread->err); + thread->err = Nullsv; + } + perl_destruct(interp); perl_free(interp); thread->interp = NULL; @@ -381,8 +389,9 @@ S_ithread_run(void * arg) ithread *thread = (ithread *)arg; int jmp_rc = 0; I32 oldscope; - int exit_app = 0; + int exit_app = 0; /* Thread terminated using 'exit' */ int exit_code = 0; + int died = 0; /* Thread terminated abnormally */ dJMPENV; @@ -442,22 +451,34 @@ S_ithread_run(void * arg) FREETMPS; LEAVE; - /* Check for failure */ - if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) { - 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; + /* Check for abnormal termination */ + if (SvTRUE(ERRSV)) { + died = PERL_ITHR_DIED; + thread->err = newSVsv(ERRSV); + /* If ERRSV is an object, remember the classname and then + * rebless into 'main' so it will survive 'cloning' + */ + if (sv_isobject(thread->err)) { + thread->err_class = HvNAME(SvSTASH(SvRV(thread->err))); + sv_bless(thread->err, gv_stashpv("main", 0)); + } + + if (ckWARN_d(WARN_THREADS)) { + 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; + } } + JMPENV_POP; } - JMPENV_POP; } /* Release function ref */ @@ -470,7 +491,7 @@ S_ithread_run(void * arg) MUTEX_LOCK(&MY_POOL.create_destruct_mutex); MUTEX_LOCK(&thread->mutex); /* Mark as finished */ - thread->state |= PERL_ITHR_FINISHED; + thread->state |= (PERL_ITHR_FINISHED | died); /* Clear exit flag if required */ if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) { exit_app = 0; @@ -1056,6 +1077,7 @@ ithread_join(...) thread->state |= PERL_ITHR_JOINED; /* Get the return value from the call_sv */ + /* Objects do not survive this process - FIXME */ { AV *params_copy; PerlInterpreter *other_perl; @@ -1081,8 +1103,10 @@ ithread_join(...) PL_ptr_table = NULL; } - /* We are finished with the thread */ - S_ithread_clear(aTHX_ thread); + /* If thread didn't die, then we can free its interpreter */ + if (! (thread->state & PERL_ITHR_DIED)) { + S_ithread_clear(aTHX_ thread); + } MUTEX_UNLOCK(&thread->mutex); MUTEX_LOCK(&MY_POOL.create_destruct_mutex); @@ -1091,6 +1115,9 @@ ithread_join(...) } MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + /* Try to cleanup thread */ + S_ithread_destruct(aTHX_ thread); + /* If no return values, then just return */ if (! params) { XSRETURN_UNDEF; @@ -1142,7 +1169,6 @@ ithread_detach(...) #else PERL_THREAD_DETACH(thread->thr); #endif - if (thread->state & PERL_ITHR_FINISHED) { MY_POOL.joinable_threads--; } else { @@ -1152,6 +1178,16 @@ ithread_detach(...) MUTEX_UNLOCK(&thread->mutex); MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + /* If thread is finished and didn't die, + * then we can free its interpreter */ + MUTEX_LOCK(&thread->mutex); + if ((thread->state & PERL_ITHR_FINISHED) && + ! (thread->state & PERL_ITHR_DIED)) + { + S_ithread_clear(aTHX_ thread); + } + MUTEX_UNLOCK(&thread->mutex); + /* Try to cleanup thread */ S_ithread_destruct(aTHX_ thread); @@ -1405,6 +1441,59 @@ ithread_set_thread_exit_only(...) } MUTEX_UNLOCK(&thread->mutex); + +void +ithread_error(...) + PREINIT: + ithread *thread; + SV *err = NULL; + CODE: + /* Object method only */ + if ((items != 1) || ! sv_isobject(ST(0))) { + Perl_croak(aTHX_ "Usage: $thr->err()"); + } + + thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&thread->mutex); + + /* If thread died, then clone the error into the calling thread */ + if (thread->state & PERL_ITHR_DIED) { + PerlInterpreter *other_perl; + CLONE_PARAMS clone_params; + ithread *current_thread; + + other_perl = thread->interp; + clone_params.stashes = newAV(); + clone_params.flags = CLONEf_JOIN_IN; + PL_ptr_table = ptr_table_new(); + current_thread = S_ithread_get(aTHX); + S_ithread_set(aTHX_ thread); + /* Ensure 'meaningful' addresses retain their meaning */ + ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); + ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); + ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); + err = sv_dup(thread->err, &clone_params); + S_ithread_set(aTHX_ current_thread); + SvREFCNT_dec(clone_params.stashes); + SvREFCNT_inc_void(err); + /* If error was an object, bless it into the correct class */ + if (thread->err_class) { + sv_bless(err, gv_stashpv(thread->err_class, 1)); + } + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } + + MUTEX_UNLOCK(&thread->mutex); + + if (! err) { + XSRETURN_UNDEF; + } + + ST(0) = sv_2mortal(err); + /* XSRETURN(1); - implied */ + + #endif /* USE_ITHREADS */