From: Steffen Mueller Date: Thu, 15 Apr 2010 09:12:04 +0000 (+0200) Subject: Upgrade dist/threads to 1.77 from CPAN X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b91a79b929f6eca75f18124340d2f0f89b9588a9;p=p5sagit%2Fp5-mst-13.2.git Upgrade dist/threads to 1.77 from CPAN While doing so fix a tiny, little POD error to prevent breakage of core tests. (blead is upstream for threads.pm) --- diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 1608efa..5134cee 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1559,7 +1559,7 @@ use File::Glob qw(:case); 'threads' => { 'MAINTAINER' => 'jdhedden', - 'DISTRIBUTION' => 'JDHEDDEN/threads-1.75.tar.gz', + 'DISTRIBUTION' => 'JDHEDDEN/threads-1.77.tar.gz', 'FILES' => q[dist/threads], 'EXCLUDED' => [ qw(examples/pool.pl t/pod.t diff --git a/dist/threads/t/basic.t b/dist/threads/t/basic.t index 19ce793..f4d030b 100644 --- a/dist/threads/t/basic.t +++ b/dist/threads/t/basic.t @@ -27,7 +27,7 @@ sub ok { BEGIN { $| = 1; - print("1..33\n"); ### Number of tests that will be run ### + print("1..34\n"); ### Number of tests that will be run ### }; use threads; @@ -153,14 +153,17 @@ $thrx = threads->object(); ok(30, ! defined($thrx), 'No object'); $thrx = threads->object(undef); ok(31, ! defined($thrx), 'No object'); -$thrx = threads->object(0); -ok(32, ! defined($thrx), 'No object'); threads->import('stringify'); $thr1 = threads->create(sub {}); -ok(33, "$thr1" eq $thr1->tid(), 'Stringify'); +ok(32, "$thr1" eq $thr1->tid(), 'Stringify'); $thr1->join(); +# ->object($tid) works like ->self() when $tid is thread's TID +$thrx = threads->object(threads->tid()); +ok(33, defined($thrx), 'Main thread object'); +ok(34, 0 == $thrx->tid(), "Check so that tid for threads work for main thread"); + exit(0); # EOF diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t index bb1cec0..29c3dca 100644 --- a/dist/threads/t/exit.t +++ b/dist/threads/t/exit.t @@ -48,7 +48,7 @@ my $rc = $thr->join(); ok(! defined($rc), 'Exited: threads->exit()'); -run_perl(prog => 'use threads 1.75;' . +run_perl(prog => 'use threads 1.77;' . 'threads->exit(86);' . 'exit(99);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -98,7 +98,7 @@ $rc = $thr->join(); ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); -run_perl(prog => 'use threads 1.75 qw(exit thread_only);' . +run_perl(prog => 'use threads 1.77 qw(exit thread_only);' . 'threads->create(sub { exit(99); })->join();' . 'exit(86);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -108,7 +108,7 @@ run_perl(prog => 'use threads 1.75 qw(exit thread_only);' . is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); } -my $out = run_perl(prog => 'use threads 1.75;' . +my $out = run_perl(prog => 'use threads 1.77;' . 'threads->create(sub {' . ' exit(99);' . '});' . @@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.75;' . like($out, '1 finished and unjoined', "exit(status) in thread"); -$out = run_perl(prog => 'use threads 1.75 qw(exit thread_only);' . +$out = run_perl(prog => 'use threads 1.77 qw(exit thread_only);' . 'threads->create(sub {' . ' threads->set_thread_exit_only(0);' . ' exit(99);' . @@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 1.75 qw(exit thread_only);' . like($out, '1 finished and unjoined', "set_thread_exit_only(0)"); -run_perl(prog => 'use threads 1.75;' . +run_perl(prog => 'use threads 1.77;' . 'threads->create(sub {' . ' $SIG{__WARN__} = sub { exit(99); };' . ' die();' . diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t index 6f33cd4..b390215 100644 --- a/dist/threads/t/thread.t +++ b/dist/threads/t/thread.t @@ -20,7 +20,7 @@ BEGIN { } $| = 1; - print("1..34\n"); ### Number of tests that will be run ### + print("1..35\n"); ### Number of tests that will be run ### }; print("ok 1 - Loaded\n"); @@ -161,7 +161,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.75;' . +run_perl(prog => 'use threads 1.77;' . 'sub a{threads->create(shift)} $t = a sub{};' . '$t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -304,6 +304,26 @@ SKIP: { "counts of calls to DESTROY"); } +# Bug 73330 - Apply magic to arg to ->object() +{ + my @tids :shared; + + my $thr = threads->create(sub { + lock(@tids); + push(@tids, threads->tid()); + cond_signal(@tids); + }); + + { + lock(@tids); + cond_wait(@tids) while (! @tids); + } + + ok(threads->object($_), 'Got threads object') foreach (@tids); + + $thr->join(); +} + exit(0); # EOF diff --git a/dist/threads/threads.pm b/dist/threads/threads.pm index 4552e50..b0c8fe3 100644 --- a/dist/threads/threads.pm +++ b/dist/threads/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.75'; +our $VERSION = '1.77'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -134,7 +134,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.75 +This document describes threads version 1.77 =head1 SYNOPSIS @@ -361,9 +361,10 @@ key) will cause its ID to be used as the value: =item threads->object($tid) This will return the I object for the I thread associated -with the specified thread ID. Returns C if there is no thread -associated with the TID, if the thread is joined or detached, if no TID is -specified or if the specified TID is undef. +with the specified thread ID. If C<$tid> is the value for the current thread, +then this call works the same as C<-Eself()>. Otherwise, returns C +if there is no thread associated with the TID, if the thread is joined or +detached, if no TID is specified or if the specified TID is undef. =item threads->yield() @@ -902,6 +903,18 @@ 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. +=item Memory consumption + +On most systems, frequent and continual creation and destruction of threads +can lead to ever-increasing growth in the memory footprint of the Perl +interpreter. While it is simple to just launch threads and then +C<-Ejoin()> or C<-Edetach()> them, for long-lived applications, it is +better to maintain a pool of threads, and to reuse them for the work needed, +using L to notify threads of pending work. The CPAN +distribution of this module contains a simple example +(F) illustrating the creation, use and monitoring of a +pool of I threads. + =item Current working directory On all platforms except MSWin32, the setting for the current working directory @@ -975,7 +988,7 @@ involved, you may be able to work around this by returning a serialized version of the object (e.g., using L or L), and then reconstituting it in the joining thread. If you're using Perl 5.10.0 or later, and if the class supports L, -you can pass them via L. +you can pass them via L. =item END blocks in threads @@ -1021,7 +1034,7 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L Source repository: L diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index 9e602a1..b0f7dc8 100755 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -52,7 +52,7 @@ typedef perl_os_thread pthread_t; /* Values for 'state' member */ #define PERL_ITHR_DETACHED 1 /* Thread has been detached */ -#define PERL_ITHR_JOINED 2 /* Thread has been joined */ +#define PERL_ITHR_JOINED 2 /* Thread is being / has been joined */ #define PERL_ITHR_FINISHED 4 /* Thread has finished execution */ #define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */ #define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */ @@ -1409,6 +1409,7 @@ void ithread_object(...) PREINIT: char *classname; + SV *arg; UV tid; ithread *thread; int state; @@ -1421,34 +1422,47 @@ ithread_object(...) } classname = (char *)SvPV_nolen(ST(0)); - if ((items < 2) || ! SvOK(ST(1))) { + /* Turn $tid from PVLV to SV if needed (bug #73330) */ + arg = ST(1); + SvGETMAGIC(arg); + + if ((items < 2) || ! SvOK(arg)) { XSRETURN_UNDEF; } /* threads->object($tid) */ - tid = SvUV(ST(1)); + tid = SvUV(arg); - /* Walk through threads list */ - MUTEX_LOCK(&MY_POOL.create_destruct_mutex); - for (thread = MY_POOL.main_thread.next; - thread != &MY_POOL.main_thread; - thread = thread->next) - { - /* Look for TID */ - if (thread->tid == tid) { - /* Ignore if detached or joined */ - MUTEX_LOCK(&thread->mutex); - state = thread->state; - MUTEX_UNLOCK(&thread->mutex); - if (! (state & PERL_ITHR_UNCALLABLE)) { - /* Put object on stack */ - ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); - have_obj = 1; + /* If current thread wants its own object, then behave the same as + ->self() */ + thread = S_ithread_get(aTHX); + if (thread->tid == tid) { + ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); + have_obj = 1; + + } else { + /* Walk through threads list */ + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + for (thread = MY_POOL.main_thread.next; + thread != &MY_POOL.main_thread; + thread = thread->next) + { + /* Look for TID */ + if (thread->tid == tid) { + /* Ignore if detached or joined */ + MUTEX_LOCK(&thread->mutex); + state = thread->state; + MUTEX_UNLOCK(&thread->mutex); + if (! (state & PERL_ITHR_UNCALLABLE)) { + /* Put object on stack */ + ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); + have_obj = 1; + } + break; } - break; } + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); } - MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); if (! have_obj) { XSRETURN_UNDEF;