[perl #98204] Shared objects not destoryed

Jerry wrote:
> threads::shared objects stored inside other
> threads::shared structures are not properly destroyed.
>  When a threads::shared object is 'removed' from a
> threads::shared structure (e.g., a hash), the object's
> DESTROY method is not called.

Later, he said:
> When PL_destroyhook and Perl_shared_object_destroy were
> added, the problem they were overcoming was that the
> destruction of each threads::shared proxy was causing the
> underlying shared object's DESTROY method to be called. The
> fix provided a refcount check on the shared object so that
> the DESTROY method was only called with the shared object
> was no longer in use.
>
> The above works fine when delete() and pop() are used,
> because a proxy is created for the stored shared object that
> is being deleted (i.e., the value returned by the delete()
> call), and when the proxy is destroyed, the object's DESTROY
> method is called.
>
> However, when the stored shared object is 'removed' in some
> other manner (e.g., setting the storage location to
> 'undef'), there is no proxy involved, and hence DESTROY does
> not get called for the object.

This commit fixes that by modifying sharedsv_scalar_store,
sharedsv_scalar_mg_free and sharedsv_array_mg_CLEAR.

Each of those functions now checks whether the current item being
freed has sub-items with reference counts of 1.  If so, that means the
sub-item will be freed as a result of the outer SV’s being freed.  It
also means that there are no proxy objects and that destructors will
hence not be called.  So it pushes a new proxy on to the calling con-
text’s mortals stack.  If there are multiple levels of nested objects,
then, when the proxy on the mortals stack is freed, it triggers
sharedsv_scalar_mg_free, which goes through the process again.

This does not fix the problem for shared objects that still exist
(without proxies) at global destruction time.  I cannot make that
work, as circularities will cause new proxies to be created continu-
ously and pushed on to the mortals stack.  Also, the proxies may end
up being created too late during global destruction, after the mor-
tals stack has been emptied, and when there is not enough of the run-
time environment left for destructors to run.  That will happen if
the shared object is referenced by a shared SV that is not an object.
The calling context doesn’t know about the object, so it won’t fire
the destructor at the object-destroying stage of global destruction.
Detecting circularities is also problematic: We would have to keep
a hash of ‘seen’ objects in the shared space, but then how would we
know when to free that?  Letting it leak would affect embedded
environments.

So this whole trick of creating mortal proxy objects is skipped during
global destruction.

3 files changed, 85 insertions, 55 deletions

diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm
index 49fd7c3930..d4d62b22c7 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.39';
+our $VERSION = '1.40';
 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.39
+This document describes threads::shared version 1.40
 
 =head1 SYNOPSIS
 
@@ -527,31 +527,10 @@ 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.
 
-When storing shared objects in other shared structures, remove objects from
-the structure using C<delete> (for arrays and hashes) or C<pop> (for arrays)
-in order to ensure the object's destructor is called, if needed.
-
-  # Add shared objects to shared hash
-  my %hsh : shared;
-  $hsh{'obj1'} = SharedObj->new();
-  $hsh{'obj2'} = SharedObj->new();
-  $hsh{'obj3'} = SharedObj->new();
-
-  # Remove object from hash
-  delete($hsh{'obj1'});      # First object's destructor is called
-  $hsh{'obj2'} = undef;      # Second object's destructor is NOT called
-  %hsh = ();                 # Third object's destructor is NOT called
-
-  # Add shared objects to shared array
-  my @arr : shared;
-  $arr[0] = SharedObj->new();
-  $arr[1] = SharedObj->new();
-  $arr[2] = SharedObj->new();
-
-  # Remove object from array
-  pop(@arr);            # Third object's destructor is called
-  $arr[1] = undef;      # Second object's destructor is NOT called
-  undef(@arr);          # First object's destructor is NOT called
+Destructors may not be called on objects if those objects still exist at
+global destruction time.  If the destructors must be called, make sure
+there are no circular references and that nothing is referencing the
+objects, before the program ends.
 
 Does not support C<splice> on arrays.  Does not support explicitly changing
 array lengths via $#array -- use C<push> and C<pop> instead.
diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs
index aea148ea97..17cb645d43 100644
--- a/dist/threads-shared/shared.xs
+++ b/dist/threads-shared/shared.xs
@@ -743,6 +743,11 @@ sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
     bool allowed = TRUE;
 
     assert(PL_sharedsv_lock.owner == aTHX);
+    if (!PL_dirty && SvROK(ssv) && SvREFCNT(SvRV(ssv)) == 1) {
+        SV *sv = sv_newmortal();
+        sv_upgrade(sv, SVt_RV);
+        get_RV(sv, SvRV(ssv));
+    }
     if (SvROK(sv)) {
         SV *obj = SvRV(sv);
         SV *sobj = Perl_sharedsv_find(aTHX_ obj);
@@ -813,7 +818,15 @@ int
 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_UNUSED_ARG(sv);
+    ENTER_LOCK;
+    if (!PL_dirty
+     && SvROK((SV *)mg->mg_ptr) && SvREFCNT(SvRV((SV *)mg->mg_ptr)) == 1) {
+        SV *sv = sv_newmortal();
+        sv_upgrade(sv, SVt_RV);
+        get_RV(sv, SvRV((SV *)mg->mg_ptr));
+    }
     S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
+    LEAVE_LOCK;
     return (0);
 }
 
@@ -1054,8 +1067,40 @@ sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
     PERL_UNUSED_ARG(sv);
     SHARED_EDIT;
     if (SvTYPE(ssv) == SVt_PVAV) {
+        if (!PL_dirty) {
+            SV **svp = AvARRAY((AV *)ssv);
+            I32 items = AvFILLp((AV *)ssv) + 1;
+            while (items--) {
+                SV *sv = *svp++;
+                if (!sv) continue;
+                if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
+                  && SvREFCNT(sv) == 1 ) {
+                    SV *tmp = Perl_sv_newmortal(caller_perl);
+                    PERL_SET_CONTEXT((aTHX = caller_perl));
+                    sv_upgrade(tmp, SVt_RV);
+                    get_RV(tmp, sv);
+                    PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
+                }
+            }
+        }
         av_clear((AV*) ssv);
     } else {
+        if (!PL_dirty) {
+            HE *iter;
+            hv_iterinit((HV *)ssv);
+            while ((iter = hv_iternext((HV *)ssv))) {
+                SV *sv = HeVAL(iter);
+                if (!sv) continue;
+                if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
+                  && SvREFCNT(sv) == 1 ) {
+                    SV *tmp = Perl_sv_newmortal(caller_perl);
+                    PERL_SET_CONTEXT((aTHX = caller_perl));
+                    sv_upgrade(tmp, SVt_RV);
+                    get_RV(tmp, sv);
+                    PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
+                }
+            }
+        }
         hv_clear((HV*) ssv);
     }
     SHARED_RELEASE;
diff --git a/dist/threads-shared/t/object2.t b/dist/threads-shared/t/object2.t
index b1eafd7ec2..f59bad8d27 100644
--- a/dist/threads-shared/t/object2.t
+++ b/dist/threads-shared/t/object2.t
@@ -17,7 +17,7 @@ use ExtUtils::testlib;
 
 BEGIN {
     $| = 1;
-    print("1..121\n");   ### Number of tests that will be run ###
+    print("1..122\n");   ### Number of tests that will be run ###
 };
 
 use threads;
@@ -50,7 +50,7 @@ ok(1, 'Loaded');
 
 ### Start of Testing ###
 
-my $ID = -1;
+my $ID :shared = -1;
 my (@created, @destroyed);
 
 { package HashObj;
@@ -251,8 +251,6 @@ ok($destroyed[$ID], 'Scalar object removed from undef normal hash');
 # Testing with shared array
 my @shared_ary :shared;
 
-my $TODO = ' # TODO perl #98204';
-
 # Testing with hash object
 $shared_ary[0] = HashObj->new();
 ok($created[$ID], 'Created hash object in shared array');
@@ -262,20 +260,20 @@ ok($destroyed[$ID], 'Deleted hash object in shared array');
 $shared_ary[0] = HashObj->new();
 ok($created[$ID], 'Created hash object in shared array');
 $shared_ary[0] = undef;
-ok($destroyed[$ID], 'Undef hash object in shared array' . $TODO);
+ok($destroyed[$ID], 'Undef hash object in shared array');
 
 $shared_ary[0] = HashObj->new();
 ok($created[$ID], 'Created hash object in shared array');
 $shared_ary[0] = HashObj->new();
 ok($created[$ID], 'Created hash object in shared array');
-ok($destroyed[$ID-1], 'Replaced hash object in shared array' . $TODO);
+ok($destroyed[$ID-1], 'Replaced hash object in shared array');
 @shared_ary = ();
-ok($destroyed[$ID], 'Hash object removed from cleared shared array' . $TODO);
+ok($destroyed[$ID], 'Hash object removed from cleared shared array');
 
 $shared_ary[0] = HashObj->new();
 ok($created[$ID], 'Created hash object in shared array');
 undef(@shared_ary);
-ok($destroyed[$ID], 'Hash object removed from undef shared array' . $TODO);
+ok($destroyed[$ID], 'Hash object removed from undef shared array');
 
 # Testing with array object
 $shared_ary[0] = AryObj->new();
@@ -286,20 +284,20 @@ ok($destroyed[$ID], 'Deleted array object in shared array');
 $shared_ary[0] = AryObj->new();
 ok($created[$ID], 'Created array object in shared array');
 $shared_ary[0] = undef;
-ok($destroyed[$ID], 'Undef array object in shared array' . $TODO);
+ok($destroyed[$ID], 'Undef array object in shared array');
 
 $shared_ary[0] = AryObj->new();
 ok($created[$ID], 'Created array object in shared array');
 $shared_ary[0] = AryObj->new();
 ok($created[$ID], 'Created array object in shared array');
-ok($destroyed[$ID-1], 'Replaced array object in shared array' . $TODO);
+ok($destroyed[$ID-1], 'Replaced array object in shared array');
 @shared_ary = ();
-ok($destroyed[$ID], 'Array object removed from cleared shared array' . $TODO);
+ok($destroyed[$ID], 'Array object removed from cleared shared array');
 
 $shared_ary[0] = AryObj->new();
 ok($created[$ID], 'Created array object in shared array');
 undef(@shared_ary);
-ok($destroyed[$ID], 'Array object removed from undef shared array' . $TODO);
+ok($destroyed[$ID], 'Array object removed from undef shared array');
 
 # Testing with scalar object
 $shared_ary[0] = SclrObj->new();
@@ -310,20 +308,20 @@ ok($destroyed[$ID], 'Deleted scalar object in shared array');
 $shared_ary[0] = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared array');
 $shared_ary[0] = undef;
-ok($destroyed[$ID], 'Undef scalar object in shared array' . $TODO);
+ok($destroyed[$ID], 'Undef scalar object in shared array');
 
 $shared_ary[0] = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared array');
 $shared_ary[0] = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared array');
-ok($destroyed[$ID-1], 'Replaced scalar object in shared array' . $TODO);
+ok($destroyed[$ID-1], 'Replaced scalar object in shared array');
 @shared_ary = ();
-ok($destroyed[$ID], 'Scalar object removed from cleared shared array' . $TODO);
+ok($destroyed[$ID], 'Scalar object removed from cleared shared array');
 
 $shared_ary[0] = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared array');
 undef(@shared_ary);
-ok($destroyed[$ID], 'Scalar object removed from undef shared array' . $TODO);
+ok($destroyed[$ID], 'Scalar object removed from undef shared array');
 
 # Testing with shared hash
 my %shared_hash :shared;
@@ -337,20 +335,20 @@ ok($destroyed[$ID], 'Deleted hash object in shared hash');
 $shared_hash{'obj'} = HashObj->new();
 ok($created[$ID], 'Created hash object in shared hash');
 $shared_hash{'obj'} = undef;
-ok($destroyed[$ID], 'Undef hash object in shared hash' . $TODO);
+ok($destroyed[$ID], 'Undef hash object in shared hash');
 
 $shared_hash{'obj'} = HashObj->new();
 ok($created[$ID], 'Created hash object in shared hash');
 $shared_hash{'obj'} = HashObj->new();
 ok($created[$ID], 'Created hash object in shared hash');
-ok($destroyed[$ID-1], 'Replaced hash object in shared hash' . $TODO);
+ok($destroyed[$ID-1], 'Replaced hash object in shared hash');
 %shared_hash = ();
-ok($destroyed[$ID], 'Hash object removed from cleared shared hash' . $TODO);
+ok($destroyed[$ID], 'Hash object removed from cleared shared hash');
 
 $shared_hash{'obj'} = HashObj->new();
 ok($created[$ID], 'Created hash object in shared hash');
 undef(%shared_hash);
-ok($destroyed[$ID], 'Hash object removed from undef shared hash' . $TODO);
+ok($destroyed[$ID], 'Hash object removed from undef shared hash');
 
 # Testing with array object
 $shared_hash{'obj'} = AryObj->new();
@@ -361,20 +359,20 @@ ok($destroyed[$ID], 'Deleted array object in shared hash');
 $shared_hash{'obj'} = AryObj->new();
 ok($created[$ID], 'Created array object in shared hash');
 $shared_hash{'obj'} = undef;
-ok($destroyed[$ID], 'Undef array object in shared hash' . $TODO);
+ok($destroyed[$ID], 'Undef array object in shared hash');
 
 $shared_hash{'obj'} = AryObj->new();
 ok($created[$ID], 'Created array object in shared hash');
 $shared_hash{'obj'} = AryObj->new();
 ok($created[$ID], 'Created array object in shared hash');
-ok($destroyed[$ID-1], 'Replaced array object in shared hash' . $TODO);
+ok($destroyed[$ID-1], 'Replaced array object in shared hash');
 %shared_hash = ();
-ok($destroyed[$ID], 'Array object removed from cleared shared hash' . $TODO);
+ok($destroyed[$ID], 'Array object removed from cleared shared hash');
 
 $shared_hash{'obj'} = AryObj->new();
 ok($created[$ID], 'Created array object in shared hash');
 undef(%shared_hash);
-ok($destroyed[$ID], 'Array object removed from undef shared hash' . $TODO);
+ok($destroyed[$ID], 'Array object removed from undef shared hash');
 
 # Testing with scalar object
 $shared_hash{'obj'} = SclrObj->new();
@@ -385,19 +383,27 @@ ok($destroyed[$ID], 'Deleted scalar object in shared hash');
 $shared_hash{'obj'} = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared hash');
 $shared_hash{'obj'} = undef;
-ok($destroyed[$ID], 'Undef scalar object in shared hash' . $TODO);
+ok($destroyed[$ID], 'Undef scalar object in shared hash');
 
 $shared_hash{'obj'} = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared hash');
 $shared_hash{'obj'} = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared hash');
-ok($destroyed[$ID-1], 'Replaced scalar object in shared hash' . $TODO);
+ok($destroyed[$ID-1], 'Replaced scalar object in shared hash');
 %shared_hash = ();
-ok($destroyed[$ID], 'Scalar object removed from cleared shared hash' . $TODO);
+ok($destroyed[$ID], 'Scalar object removed from cleared shared hash');
 
 $shared_hash{'obj'} = SclrObj->new();
 ok($created[$ID], 'Created scalar object in shared hash');
 undef(%shared_hash);
-ok($destroyed[$ID], 'Scalar object removed from undef shared hash' . $TODO);
+ok($destroyed[$ID], 'Scalar object removed from undef shared hash');
+
+# Testing with shared scalar
+{
+    my $shared_scalar : shared;
+    # Use a separate thread to make sure we have no private SV
+    async { $shared_scalar = SclrObj->new(); }->join();
+}
+ok($destroyed[$ID], 'Scalar object removed from shared scalar');
 
 # EOF