In perl.git, the branch smoke-me/nicholas/RT119089-variant has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/73bd662d0b6587f5623cb73b087576bef5bb1c92?hp=b52cde68813a958007c6d814f1890e762f75c8dc> - Log ----------------------------------------------------------------- commit 73bd662d0b6587f5623cb73b087576bef5bb1c92 Author: Nicholas Clark <[email protected]> Date: Mon Oct 7 12:22:50 2013 +0200 sharedsv_array_mg_free() and sharedsv_elem_mg_free() can be merged. Dave Mitchell noticed that as the data points used by arrays elements to track the shared aggregate are identical, than sharedsv_array_mg_free() and sharedsv_elem_mg_free() are performing the same job, and can be merged. M dist/threads-shared/shared.xs commit e3b61a634ddb7545a3fa4c4d8d63d403641c4f48 Author: Nicholas Clark <[email protected]> Date: Mon Oct 7 11:29:35 2013 +0200 Further tests for RT #119089, inspired by some code from Dave Mitchell. M dist/threads-shared/t/av_refs.t M dist/threads-shared/t/hv_refs.t commit d30a039007faf2b088b690f03d97dcb0b63ca9aa Author: Nicholas Clark <[email protected]> Date: Fri Aug 2 12:08:33 2013 +0200 threads::shared should not crash if shared elements outlive their aggregate. If an element of a shared aggregate is returned from a function, it is possible for it to outlive the aggregate itself. As the element has a pointer to the underlying shared aggregate and might use it, it is necessary for that pointer to remain valid. Hence threads::shared needs to ensure that cleanup of the shared aggregate is performed by the last proxy pointing to it, which is not necessarily the proxy for the aggregate itself. This can happen with lvalue subroutines. See the discussion in perl #119089 for more details. M dist/threads-shared/lib/threads/shared.pm M dist/threads-shared/shared.xs M dist/threads-shared/t/av_refs.t M dist/threads-shared/t/hv_refs.t ----------------------------------------------------------------------- Summary of changes: dist/threads-shared/lib/threads/shared.pm | 2 +- dist/threads-shared/shared.xs | 27 +++++++++++++++++-- dist/threads-shared/t/av_refs.t | 45 ++++++++++++++++++++++++++++++- dist/threads-shared/t/hv_refs.t | 42 ++++++++++++++++++++++++++++- 4 files changed, 111 insertions(+), 5 deletions(-) diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm index e5c3669..288215b 100644 --- a/dist/threads-shared/lib/threads/shared.pm +++ b/dist/threads-shared/lib/threads/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.44'; +our $VERSION = '1.45'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index d3e859d..c5b94e0 100644 --- a/dist/threads-shared/shared.xs +++ b/dist/threads-shared/shared.xs @@ -1027,6 +1027,9 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) return (0); } +/* This code can be shared between aggregates and their elements. */ +int sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg); + /* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new * thread */ @@ -1044,7 +1047,7 @@ MGVTBL sharedsv_elem_vtbl = { sharedsv_elem_mg_STORE, /* set */ 0, /* len */ sharedsv_elem_mg_DELETE, /* clear */ - 0, /* free */ + sharedsv_array_mg_free, /* free */ 0, /* copy */ sharedsv_elem_mg_dup, /* dup */ #ifdef MGf_LOCAL @@ -1110,11 +1113,31 @@ sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) /* Free magic for PERL_MAGIC_tied(P) */ +/* This routine is common to aggregates and their elements. */ + int sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) { PERL_UNUSED_ARG(sv); - S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); + if (!PL_dirty) { + assert(mg->mg_obj); + assert(SvROK(mg->mg_obj)); + if (mg->mg_type == PERL_MAGIC_tied) { + /* Only aggregates have this alternative shortcut. */ + assert(SvUV(SvRV(mg->mg_obj)) == PTR2UV(mg->mg_ptr)); + } + } + if (mg->mg_obj) { + if (SvREFCNT(mg->mg_obj) == 1) { + /* There is only one proxy object per thread, stored in mg->mg_obj, + which ends up being referenced by both the aggregate and any + elements. Perl_mg_free() drops the reference count on + mg->mg_obj, but if this is the last reference (and the proxy is + about to be freed) then we need to manually drop the reference + on the original aggregate in shared space. */ + S_sharedsv_dec(aTHX_ SHAREDSV_FROM_OBJ(mg->mg_obj)); + } + } return (0); } diff --git a/dist/threads-shared/t/av_refs.t b/dist/threads-shared/t/av_refs.t index 8106e32..104c578 100644 --- a/dist/threads-shared/t/av_refs.t +++ b/dist/threads-shared/t/av_refs.t @@ -27,7 +27,7 @@ sub ok { BEGIN { $| = 1; - print("1..14\n"); ### Number of tests that will be run ### + print("1..19\n"); ### Number of tests that will be run ### }; use threads; @@ -90,6 +90,49 @@ ok(13, is_shared(@av), "Check for sharing"); my $x :shared; ok(14, is_shared($x), "Check for sharing"); +# This is a reduction of the test case from perl #119089. Whilst the bug that +# this exposes was fixed by a core change in 5.15.7, the variant with lvalues +# below would still crash, and the fix for it also a fix for this bug on earlier +# perl versions: + +sub elem_on_stack { + my @a :shared; + $a[0] = 6; + $a[0]; +} + +ok(15, defined elem_on_stack(), "element on stack should be defined"); + +sub lvalue_elem_on_stack :lvalue { + my @a :shared; + $a[0]; +} + +if ($] >= 5.008008) { + lvalue_elem_on_stack() = 9; + ok(16, 1, "assigning to lvalue element on stack does not crash"); +} else { + print "ok 16 # skip $] can't return temporaries from lvalue subs\n"; +} + +my $r; +{ + my @a :shared; + $r = \$a[0]; +} +$$r = 1; +ok(17, 1, 'Assignment to a reference to an out-of-scope array does not crash'); + +my $a; +{ + my @a :shared; + $a = \@a; + $a->[0] = 2; +} +ok(18, $a->[0] == 2, 'Array has expected value'); +$$r = 3; +ok(19, $a->[0] == 2, 'Array was not changed by unrelated scalar'); + exit(0); # EOF diff --git a/dist/threads-shared/t/hv_refs.t b/dist/threads-shared/t/hv_refs.t index ecefdc6..abfc35a 100644 --- a/dist/threads-shared/t/hv_refs.t +++ b/dist/threads-shared/t/hv_refs.t @@ -27,7 +27,7 @@ sub ok { BEGIN { $| = 1; - print("1..20\n"); ### Number of tests that will be run ### + print("1..25\n"); ### Number of tests that will be run ### }; use threads; @@ -106,6 +106,46 @@ ok(10, keys %foo == 0, "And make sure we realy have deleted the values"); ok(19, is_shared($foo), "Check for sharing"); ok(20, is_shared(%foo), "Check for sharing"); +# See av_refs.t for a description. + +sub elem_on_stack { + my %h :shared; + $h{''} = 6; + $h{''}; +} + +ok(21, defined elem_on_stack(), "element on stack should be defined"); + +sub lvalue_elem_on_stack :lvalue { + my %h :shared; + $h{''}; +} + +if ($] >= 5.008008) { + lvalue_elem_on_stack() = 9; + ok(22, 1, "assigning to lvalue element on stack does not crash"); +} else { + print "ok 22 # skip $] can't return temporaries from lvalue subs\n"; +} + +my $r; +{ + my %h :shared; + $r = \$h{k}; +} +$$r = 1; +ok(23, 1, 'Assignment to a reference to an out-of-scope hash does not crash'); + +my $h; +{ + my %h :shared; + $h = \%h; + $h->{k} = 2; +} +ok(24, $h->{k} == 2, 'Hash has expected value'); +$$r = 3; +ok(25, $h->{k} == 2, 'Hash was not changed by unrelated scalar'); + exit(0); # EOF -- Perl5 Master Repository
