In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/30b05491367d1fecbb231575d1112420d410cafb?hp=208edbfe01f1e20448c7416e83a314e3969961c9>
- Log ----------------------------------------------------------------- commit 30b05491367d1fecbb231575d1112420d410cafb Author: Steffen Mueller <[email protected]> Date: Thu Apr 15 16:42:48 2010 +0200 Bump threads version to 1.77_01 This is due to the POD fix of b91a79b929f6eca75f18124340d2f0f89b9588a9. M dist/threads/threads.pm commit 1a3f0f1d129333944296d9bd29d1641e7de1a13e Author: Steffen Mueller <[email protected]> Date: Thu Apr 15 15:24:57 2010 +0200 Upgrade to threads-shared-1.33 M Porting/Maintainers.pl M dist/threads-shared/shared.pm M dist/threads-shared/shared.xs commit b91a79b929f6eca75f18124340d2f0f89b9588a9 Author: Steffen Mueller <[email protected]> Date: Thu Apr 15 11:12:04 2010 +0200 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) M Porting/Maintainers.pl M dist/threads/t/basic.t M dist/threads/t/exit.t M dist/threads/t/thread.t M dist/threads/threads.pm M dist/threads/threads.xs ----------------------------------------------------------------------- Summary of changes: Porting/Maintainers.pl | 4 +- dist/threads-shared/shared.pm | 9 +++--- dist/threads-shared/shared.xs | 45 +++++++++++++++++++------------- dist/threads/t/basic.t | 11 +++++--- dist/threads/t/exit.t | 10 +++--- dist/threads/t/thread.t | 24 ++++++++++++++++- dist/threads/threads.pm | 27 ++++++++++++++----- dist/threads/threads.xs | 56 +++++++++++++++++++++++++--------------- 8 files changed, 123 insertions(+), 63 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 1608efa..771aade 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 @@ -1573,7 +1573,7 @@ use File::Glob qw(:case); 'threads::shared' => { 'MAINTAINER' => 'jdhedden', - 'DISTRIBUTION' => 'JDHEDDEN/threads-shared-1.32.tar.gz', + 'DISTRIBUTION' => 'JDHEDDEN/threads-shared-1.33.tar.gz', 'FILES' => q[dist/threads-shared], 'EXCLUDED' => [ qw(examples/class.pl shared.h diff --git a/dist/threads-shared/shared.pm b/dist/threads-shared/shared.pm index 72192bc..15e7a02 100644 --- a/dist/threads-shared/shared.pm +++ b/dist/threads-shared/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.32'; +our $VERSION = '1.33'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -187,7 +187,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.32 +This document describes threads::shared version 1.33 =head1 SYNOPSIS @@ -527,7 +527,8 @@ that the contents of hash-based objects will be lost due to the above mentioned limitation. See F<examples/class.pl> (in the CPAN distribution of this module) for how to create a class that supports object sharing. -Does not support C<splice> on arrays! +Does not support C<splice> on arrays. Does not support explicitly changing +array lengths via $#array -- use C<push> and C<pop> instead. Taking references to the elements of shared arrays and hashes does not autovivify the elements, and neither does slicing a shared array/hash over @@ -588,7 +589,7 @@ L<threads::shared> Discussion Forum on CPAN: L<http://www.cpanforum.com/dist/threads-shared> Annotated POD for L<threads::shared>: -L<http://annocpan.org/~JDHEDDEN/threads-shared-1.32/shared.pm> +L<http://annocpan.org/~JDHEDDEN/threads-shared-1.33/shared.pm> Source repository: L<http://code.google.com/p/threads-shared/> diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index 7c9526e..a1c6925 100644 --- a/dist/threads-shared/shared.xs +++ b/dist/threads-shared/shared.xs @@ -864,29 +864,32 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) { dTHXc; SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); - SV** svp; + SV** svp = NULL; ENTER_LOCK; - if (SvTYPE(saggregate) == SVt_PVAV) { - assert ( mg->mg_ptr == 0 ); - SHARED_CONTEXT; - svp = av_fetch((AV*) saggregate, mg->mg_len, 0); - } else { - char *key = mg->mg_ptr; - I32 len = mg->mg_len; - assert ( mg->mg_ptr != 0 ); - if (mg->mg_len == HEf_SVKEY) { - STRLEN slen; - key = SvPV((SV *)mg->mg_ptr, slen); - len = slen; - if (SvUTF8((SV *)mg->mg_ptr)) { - len = -len; + if (saggregate) { /* During global destruction, underlying + aggregate may no longer exist */ + if (SvTYPE(saggregate) == SVt_PVAV) { + assert ( mg->mg_ptr == 0 ); + SHARED_CONTEXT; + svp = av_fetch((AV*) saggregate, mg->mg_len, 0); + } else { + char *key = mg->mg_ptr; + I32 len = mg->mg_len; + assert ( mg->mg_ptr != 0 ); + if (mg->mg_len == HEf_SVKEY) { + STRLEN slen; + key = SvPV((SV *)mg->mg_ptr, slen); + len = slen; + if (SvUTF8((SV *)mg->mg_ptr)) { + len = -len; + } } + SHARED_CONTEXT; + svp = hv_fetch((HV*) saggregate, key, len, 0); } - SHARED_CONTEXT; - svp = hv_fetch((HV*) saggregate, key, len, 0); + CALLER_CONTEXT; } - CALLER_CONTEXT; if (svp) { /* Exists in the array */ if (SvROK(*svp)) { @@ -957,6 +960,12 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) dTHXc; MAGIC *shmg; SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); + + /* Object may not exist during global destruction */ + if (! saggregate) { + return (0); + } + ENTER_LOCK; sharedsv_elem_mg_FETCH(aTHX_ sv, mg); if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) 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..8836789 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_01'; 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<threads> object for the I<active> thread associated -with the specified thread ID. Returns C<undef> 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<-E<gt>self()>. Otherwise, returns C<undef> +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<http://rt.cpan.org/Public/> 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<-E<gt>join()> or C<-E<gt>detach()> them, for long-lived applications, it is +better to maintain a pool of threads, and to reuse them for the work needed, +using L<queues|Thread::Queue> to notify threads of pending work. The CPAN +distribution of this module contains a simple example +(F<examples/pool_reuse.pl>) illustrating the creation, use and monitoring of a +pool of I<reusable> 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<Data::Dumper> or L<Storable>), and then reconstituting it in the joining thread. If you're using Perl 5.10.0 or later, and if the class supports L<shared objects|threads::shared/"OBJECTS">, -you can pass them via L<shared queues| Thread::Queue>. +you can pass them via L<shared queues|Thread::Queue>. =item END blocks in threads @@ -1021,7 +1034,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.75/threads.pm> +L<http://annocpan.org/~JDHEDDEN/threads-1.77/threads.pm> Source repository: L<http://code.google.com/p/threads-shared/> 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; -- Perl5 Master Repository
