Object destruction incomplete

[p5pRT]

Migrated from rt.perl.org#36347 (status was 'resolved')

Searchable as RT36347$

[p5pRT]

From @nwc10

Created by @nwc10

It's possible to create objects that never get destroyed.

Tersest example​:

#!perl -w
use strict;
use vars '@​a';

package M;
sub DESTROY {warn "Farewell $_[0]"}
package main;

bless \($a[0]), "M";
#undef @​a;
__END__

Without the undef @​​::a; it will never call the destructor, because
do_clean_objs only looks for references to objects and objects that typeglobs
point to, rather than objects themselves.

Should we replace the use of do_clean_named_objs() with a routine that
searches directly for any remaining objects, and directly reduces their
reference counts?

Nicholas Clark

Perl Info

Flags:
    category=core
    severity=low

Site configuration information for perl vv5.9.3:

Configured by nick at Sun Jun 19 15:22:28 BST 2005.

Summary of my perl5 (revision 5 version 9 subversion 3 patch 24148) configuration:
  Platform:
    osname=darwin, osvers=7.9.0, archname=darwin-thread-multi-2level
    uname='darwin ship-in-a-bottle 7.9.0 darwin kernel version 7.9.0: wed mar 30 20:11:17 pst 2005; root:xnuxnu-517.12.7.obj~1release_ppc power macintosh powerpc '
    config_args='-Dusedevel=y -Dcc=ccache gcc -Dld=gcc -Ubincompat5005 -Uinstallusrbinperl -Dcf_email=nick@ccl4.org -Dperladmin=nick@ccl4.org -Doptimize=-Os -Dusethreads=y -Uuse64bitint -Dprefix=~/Sandpit/blead-Os -de'
    hint=previous, useposix=true, d_sigaction=define
    usethreads=define useithreads=define usemultiplicity=define
    useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='ccache gcc', ccflags ='-fno-common -DPERL_DARWIN -no-cpp-precomp -fno-strict-aliasing -pipe',
    optimize='-Os',
    cppflags='-no-cpp-precomp -fno-common -DPERL_DARWIN -no-cpp-precomp -fno-strict-aliasing -pipe -fno-common -DPERL_DARWIN -no-cpp-precomp -fno-strict-aliasing -pipe'
    ccversion='', gccversion='3.3 20030304 (Apple Computer, Inc. build 1666)', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=4321
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=8
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='env MACOSX_DEPLOYMENT_TARGET=10.3 cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /usr/lib
    libs=-ldbm -ldl -lm -lc
    perllibs=-ldl -lm -lc
    libc=/usr/lib/libc.dylib, so=dylib, useshrplib=false, libperl=libperl.a
    gnulibc_version=''
  Dynamic Linking:
    dlsrc=dl_dyld.xs, dlext=bundle, d_dlsymun=undef, ccdlflags=' '
    cccdlflags=' ', lddlflags=' -bundle -undefined dynamic_lookup -L/usr/local/lib'

Locally applied patches:
    


@INC for perl vv5.9.3:
    lib
    /sw/lib/perl5
    /sw/lib/perl5/darwin
    /Users/nick/Sandpit/blead-Os/lib/perl5/5.9.3/darwin-thread-multi-2level
    /Users/nick/Sandpit/blead-Os/lib/perl5/5.9.3
    /Users/nick/Sandpit/blead-Os/lib/perl5/site_perl/5.9.3/darwin-thread-multi-2level
    /Users/nick/Sandpit/blead-Os/lib/perl5/site_perl/5.9.3
    /Users/nick/Sandpit/blead-Os/lib/perl5/site_perl
    .


Environment for perl vv5.9.3:
    DYLD_LIBRARY_PATH (unset)
    HOME=/Users/nick
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/Users/nick/bin:/sw/bin:/sw/sbin:/bin:/sbin:/usr/bin:/usr/sbin:/usr/X11R6/bin:/usr/local/sbin:/sbin:/usr/sbin
    PERL5LIB=/sw/lib/perl5:/sw/lib/perl5/darwin
    PERL_BADLANG (unset)
    SHELL=/bin/bash

[p5pRT]

From @cpansprout

On Tue Jun 21 06​:52​:36 2005, nicholas wrote​:

Should we replace the use of do_clean_named_objs() with a routine that
searches directly for any remaining objects, and directly reduces
their
reference counts?

Doing so would allow destructors to see freed SVs.

Instead, how’s this patch? It still needs tests and a commit message.

Watch​:

$ perl -le' sub DESTROY{warn aaa}bless\$a[0]'
$ ./perl -le' sub DESTROY{warn aaa}bless\$a[0]'
aaa at -e line 1 during global destruction.
$ perl -le' { bless \my@​x; *a=sub{@​x}}sub DESTROY{warn aaa}'
$ ./perl -le' { bless \my@​x; *a=sub{@​x}}sub DESTROY{warn aaa}'
aaa at -e line 1 during global destruction.

[p5pRT]

From @cpansprout

Inline Patch

diff --git a/embed.fnc b/embed.fnc
index fe8f43c..88e179b 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1167,6 +1167,9 @@ pd	|I32	|sv_clean_all
 : Used only in perl.c
 pd	|void	|sv_clean_objs
 Apd	|void	|sv_clear	|NN SV *const orig_sv
+#if defined(PERL_IN_SV_C)
+s	|bool	|curse		|NN SV * const sv|const bool check_refcnt
+#endif
 Aopd	|I32	|sv_cmp		|NULLOK SV *const sv1|NULLOK SV *const sv2
 Apd	|I32	|sv_cmp_flags	|NULLOK SV *const sv1|NULLOK SV *const sv2 \
 				|const U32 flags
diff --git a/embed.h b/embed.h
index d484a10..6a4e48e 100644
--- a/embed.h
+++ b/embed.h
@@ -1776,6 +1776,7 @@
 #define F0convert		S_F0convert
 #define anonymise_cv_maybe(a,b)	S_anonymise_cv_maybe(aTHX_ a,b)
 #define assert_uft8_cache_coherent(a,b,c,d)	S_assert_uft8_cache_coherent(aTHX_ a,b,c,d)
+#define curse(a,b)		S_curse(aTHX_ a,b)
 #define expect_number(a)	S_expect_number(aTHX_ a)
 #define find_array_subscript(a,b)	S_find_array_subscript(aTHX_ a,b)
 #define find_hash_subscript(a,b)	S_find_hash_subscript(aTHX_ a,b)
diff --git a/proto.h b/proto.h
index a05f2b9..92202de 100644
--- a/proto.h
+++ b/proto.h
@@ -6567,6 +6567,11 @@ STATIC void	S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN fr
 #define PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT	\
 	assert(func); assert(sv)
 
+STATIC bool	S_curse(pTHX_ SV * const sv, const bool check_refcnt)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CURSE	\
+	assert(sv)
+
 STATIC I32	S_expect_number(pTHX_ char **const pattern)
 			__attribute__warn_unused_result__
 			__attribute__nonnull__(pTHX_1);
diff --git a/sv.c b/sv.c
index 92634e1..598c29a 100644
--- a/sv.c
+++ b/sv.c
@@ -542,6 +542,15 @@ do_clean_named_io_objs(pTHX_ SV *const sv)
     SvREFCNT_dec(sv); /* undo the inc above */
 }
 
+/* Void wrapper to pass to visit() */
+static void
+do_curse(pTHX_ SV * const sv) {
+    if ((PL_stderrgv && GvGP(PL_stderrgv) && GvSV(PL_stderrgv) == sv)
+     || (PL_defoutgv && GvGP(PL_defoutgv) && GvSV(PL_defoutgv) == sv))
+	return;
+    (void)curse(sv, 0);
+}
+
 /*
 =for apidoc sv_clean_objs
 
@@ -562,6 +571,9 @@ Perl_sv_clean_objs(pTHX)
      * error messages, close files etc */
     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+    /* And if there are some very tenacious barnacles clinging to arrays,
+       closures, or what have you.... */
+    visit(do_curse, SVs_OBJECT, SVs_OBJECT);
     olddef = PL_defoutgv;
     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
     if (olddef && isGV_with_GP(olddef))
@@ -5948,65 +5960,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
 	}
 
 	if (SvOBJECT(sv)) {
-	    if (PL_defstash &&	/* Still have a symbol table? */
-		SvDESTROYABLE(sv))
-	    {
-		dSP;
-		HV* stash;
-		do {
-		    CV* destructor;
-		    stash = SvSTASH(sv);
-		    destructor = StashHANDLER(stash,DESTROY);
-		    if (destructor
-			/* A constant subroutine can have no side effects, so
-			   don't bother calling it.  */
-			&& !CvCONST(destructor)
-			/* Don't bother calling an empty destructor */
-			&& (CvISXSUB(destructor)
-			|| (CvSTART(destructor)
-			    && (CvSTART(destructor)->op_next->op_type
-						!= OP_LEAVESUB))))
-		    {
-			SV* const tmpref = newRV(sv);
-			SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
-			ENTER;
-			PUSHSTACKi(PERLSI_DESTROY);
-			EXTEND(SP, 2);
-			PUSHMARK(SP);
-			PUSHs(tmpref);
-			PUTBACK;
-			call_sv(MUTABLE_SV(destructor),
-				    G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
-			POPSTACK;
-			SPAGAIN;
-			LEAVE;
-			if(SvREFCNT(tmpref) < 2) {
-			    /* tmpref is not kept alive! */
-			    SvREFCNT(sv)--;
-			    SvRV_set(tmpref, NULL);
-			    SvROK_off(tmpref);
-			}
-			SvREFCNT_dec(tmpref);
-		    }
-		} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
-
-
-		if (SvREFCNT(sv)) {
-		    if (PL_in_clean_objs)
-			Perl_croak(aTHX_
-			    "DESTROY created new reference to dead object '%s'",
-			    HvNAME_get(stash));
-		    /* DESTROY gave object new lease on life */
-		    goto get_next_sv;
-		}
-	    }
-
-	    if (SvOBJECT(sv)) {
-		SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
-		SvOBJECT_off(sv);	/* Curse the object. */
-		if (type != SVt_PVIO)
-		    --PL_sv_objcount;/* XXX Might want something more general */
-	    }
+	    if (!curse(sv, 1)) goto get_next_sv;
 	}
 	if (type >= SVt_PVMG) {
 	    if (type == SVt_PVMG && SvPAD_OUR(sv)) {
@@ -6232,6 +6186,78 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
     } /* while sv */
 }
 
+/* This routine curses the sv itself, not the object referenced by sv. So
+   sv does not have to be ROK. */
+
+static bool
+S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
+    dVAR;
+
+    PERL_ARGS_ASSERT_CURSE;
+    assert(SvOBJECT(sv));
+
+    if (PL_defstash &&	/* Still have a symbol table? */
+	SvDESTROYABLE(sv))
+    {
+	dSP;
+	HV* stash;
+	do {
+	    CV* destructor;
+	    stash = SvSTASH(sv);
+	    destructor = StashHANDLER(stash,DESTROY);
+	    if (destructor
+		/* A constant subroutine can have no side effects, so
+		   don't bother calling it.  */
+		&& !CvCONST(destructor)
+		/* Don't bother calling an empty destructor */
+		&& (CvISXSUB(destructor)
+		|| (CvSTART(destructor)
+		    && (CvSTART(destructor)->op_next->op_type
+					!= OP_LEAVESUB))))
+	    {
+		SV* const tmpref = newRV(sv);
+		SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
+		ENTER;
+		PUSHSTACKi(PERLSI_DESTROY);
+		EXTEND(SP, 2);
+		PUSHMARK(SP);
+		PUSHs(tmpref);
+		PUTBACK;
+		call_sv(MUTABLE_SV(destructor),
+			    G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+		POPSTACK;
+		SPAGAIN;
+		LEAVE;
+		if(SvREFCNT(tmpref) < 2) {
+		    /* tmpref is not kept alive! */
+		    SvREFCNT(sv)--;
+		    SvRV_set(tmpref, NULL);
+		    SvROK_off(tmpref);
+		}
+		SvREFCNT_dec(tmpref);
+	    }
+	} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+
+
+	if (check_refcnt && SvREFCNT(sv)) {
+	    if (PL_in_clean_objs)
+		Perl_croak(aTHX_
+		    "DESTROY created new reference to dead object '%s'",
+		    HvNAME_get(stash));
+	    /* DESTROY gave object new lease on life */
+	    return FALSE;
+	}
+    }
+
+    if (SvOBJECT(sv)) {
+	SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+	SvOBJECT_off(sv);	/* Curse the object. */
+	if (SvTYPE(sv) != SVt_PVIO)
+	    --PL_sv_objcount;/* XXX Might want something more general */
+    }
+    return TRUE;
+}
+
 /*
 =for apidoc sv_newref
 

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From @iabyn

On Sun, Dec 12, 2010 at 01​:00​:17PM -0800, Father Chrysostomos via RT wrote​:

On Tue Jun 21 06​:52​:36 2005, nicholas wrote​:

Should we replace the use of do_clean_named_objs() with a routine that
searches directly for any remaining objects, and directly reduces
their
reference counts?

Doing so would allow destructors to see freed SVs.

Instead, how’s this patch? It still needs tests and a commit message.

Looks plausible. I don't understand why you skip $STDOUT and $STDERR
though.

--
A walk of a thousand miles begins with a single step...
then continues for another 1,999,999 or so.

[p5pRT]

From @cpansprout

On Tue Dec 14 15​:57​:54 2010, davem wrote​:

On Sun, Dec 12, 2010 at 01​:00​:17PM -0800, Father Chrysostomos via RT
wrote​:

On Tue Jun 21 06​:52​:36 2005, nicholas wrote​:

Should we replace the use of do_clean_named_objs() with a routine that
searches directly for any remaining objects, and directly reduces
their
reference counts?

Doing so would allow destructors to see freed SVs.

Instead, how’s this patch? It still needs tests and a commit message.

Looks plausible. I don't understand why you skip $STDOUT and $STDERR
though.

do_clean_named_io_objs does the same thing. I thought it was so that
destructors would be able to warn().
(And I thought you wrote that code, too.)

[p5pRT]

From @iabyn

On Sun, Dec 19, 2010 at 02​:31​:48PM -0800, Father Chrysostomos via RT wrote​:

On Tue Dec 14 15​:57​:54 2010, davem wrote​:

On Sun, Dec 12, 2010 at 01​:00​:17PM -0800, Father Chrysostomos via RT
wrote​:

On Tue Jun 21 06​:52​:36 2005, nicholas wrote​:

Should we replace the use of do_clean_named_objs() with a routine that
searches directly for any remaining objects, and directly reduces
their
reference counts?

Doing so would allow destructors to see freed SVs.

Instead, how’s this patch? It still needs tests and a commit message.

Looks plausible. I don't understand why you skip $STDOUT and $STDERR
though.

do_clean_named_io_objs does the same thing. I thought it was so that
destructors would be able to warn().

do_clean_named_io_objs() skips the STDOUT and STDERR filehandles; your
codes skips the $STDOUT and $STDERR *scalars*.

--
Overhead, without any fuss, the stars were going out.
  -- Arthur C Clarke

[p5pRT]

From @cpansprout

On Sun Dec 19 14​:54​:14 2010, davem wrote​:

On Sun, Dec 19, 2010 at 02​:31​:48PM -0800, Father Chrysostomos via RT
wrote​:

On Tue Dec 14 15​:57​:54 2010, davem wrote​:

On Sun, Dec 12, 2010 at 01​:00​:17PM -0800, Father Chrysostomos via
RT
wrote​:

On Tue Jun 21 06​:52​:36 2005, nicholas wrote​:

Should we replace the use of do_clean_named_objs() with a
routine that
searches directly for any remaining objects, and directly
reduces
their
reference counts?

Doing so would allow destructors to see freed SVs.

Instead, how’s this patch? It still needs tests and a commit
message.

Looks plausible. I don't understand why you skip $STDOUT and
$STDERR
though.

do_clean_named_io_objs does the same thing. I thought it was so that
destructors would be able to warn().

do_clean_named_io_objs() skips the STDOUT and STDERR filehandles; your
codes skips the $STDOUT and $STDERR *scalars*.

Oh dear. So it does. That was really, really stupid of me. :-)

If I change the each instance of GvSV to GvIO in that statement, does
the patch look good?

[p5pRT]

From @iabyn

On Sun, Dec 19, 2010 at 06​:05​:19PM -0800, Father Chrysostomos via RT wrote​:

On Sun Dec 19 14​:54​:14 2010, davem wrote​:

do_clean_named_io_objs() skips the STDOUT and STDERR filehandles; your
codes skips the $STDOUT and $STDERR *scalars*.

Oh dear. So it does. That was really, really stupid of me. :-)

If I change the each instance of GvSV to GvIO in that statement, does
the patch look good?

yes :-)

--
"Strange women lying in ponds distributing swords is no basis for a system
of government. Supreme executive power derives from a mandate from the
masses, not from some farcical aquatic ceremony."
  -- Dennis, "Monty Python and the Holy Grail"

[p5pRT]

From @cpansprout

On Mon Dec 20 02​:30​:37 2010, davem wrote​:

On Sun, Dec 19, 2010 at 06​:05​:19PM -0800, Father Chrysostomos via RT
wrote​:

On Sun Dec 19 14​:54​:14 2010, davem wrote​:

do_clean_named_io_objs() skips the STDOUT and STDERR filehandles; your
codes skips the $STDOUT and $STDERR *scalars*.

Oh dear. So it does. That was really, really stupid of me. :-)

If I change the each instance of GvSV to GvIO in that statement, does
the patch look good?

yes :-)

Now tweaked and applied as 4155e4f.

[p5pRT]

@cpansprout - Status changed from 'open' to 'resolved'

[p5pRT]

From @cpansprout

Re-opening this ticket, as the fix, which broke three CPAN modules, has
been disabled (by commit 7f586e4) until after 5.14.

[p5pRT]

@cpansprout - Status changed from 'resolved' to 'open'

[p5pRT]

From @cpansprout

On Sun Jan 30 19​:04​:03 2011, sprout wrote​:

Re-opening this ticket, as the fix, which broke three CPAN modules, has
been disabled (by commit 7f586e4) until after 5.14.

And now it has been re-enabled by commit 640c0c3.

[p5pRT]

@cpansprout - Status changed from 'open' to 'resolved'