develooper Front page | perl.perl5.porters | Postings from October 2007

BUG: Storing shared objects in shared structures

From:
Jerry D. Hedden
Date:
October 31, 2007 06:00
Subject:
BUG: Storing shared objects in shared structures
Message ID:
1ff86f510710310559k51425093k54e8da5ba5e85b87@mail.gmail.com
There is a bug related to storing shared objects inside of
shared structures.  The bug is that when any proxy objects
for the shared object are destroyed, the object's DESTROY
routine is called even thought the object itself should not
yet be destroyed.  The following elicits this bug:
-----
#!/usr/bin/perl

use strict;
use warnings;

use threads;
use threads::shared;

package Jar; {
    my @jar :shared;

    sub new {
        bless(&threads::shared::share({}), shift);
    }

    sub store {
        my ($self, $cookie) = @_;
        push(@jar, $cookie);
        print("JAR   : Cookie stored\n");
        return $jar[-1];        # BUG: The cookie is destroyed here
    }
}

package Cookie; {
    my $destruction_count = 0;

    sub new {
        bless(&threads::shared::share({}), shift);
    }

    sub DESTROY {
        $destruction_count++;
        print("COOKIE: destruction count = $destruction_count\n");
    }
}

package main;

MAIN:
{
    my $jar = Jar->new();
    my $cookie = Cookie->new();

    print("MAIN  : Storing cookie\n");
    $jar->store($cookie);

    print("\nMAIN  : Cookie should not have been destroyed yet\n");

    print("\nMAIN  : Exiting scope\n")
}

print("\nDONE\n");
-----
The above outputs:
    MAIN  : Storing cookie
    JAR   : Cookie stored
    COOKIE: destruction count = 1

    MAIN  : Cookie should not have been destroyed yet

    MAIN  : Exiting scope
    COOKIE: destruction count = 2

    DONE

which shows that DESTROY is called twice - the first time by
the destruction of a proxy object.

I am attempting to fix this bug by first providing a call in
threads::shared (ext/threads/shared/shared.xs) to report on
whether or not a shared object should be destroyed:  If the
ref is shared, and its refcnt is greater than one, then it
should NOT be destroyed.
-----
void
_is_destroyable(SV *shared_var)
    PROTOTYPE: \[$@%]
    PREINIT:
        SV *ssv;
    CODE:
        shared_var = SvRV(shared_var);
        if (SvROK(shared_var))
            shared_var = SvRV(shared_var);
        ssv = Perl_sharedsv_find(aTHX_ shared_var);
        ST(0) = (ssv && (SvREFCNT(ssv) > 1)) ? &PL_sv_no : &PL_sv_yes;
        /* XSRETURN(1); - implied */
-----
I then use this call inside of Perl_sv_clear (in sv.c) to
control the execution of destructors for shared objects.

My code is in the '#ifdef USE_ITHREADS' block, and follows
the example for "Returning a Scalar" in 'perlcall' (which is
the same as used in do_mark_cloneable_stash in sv.c).

The idea is that a shared object's DESTROY routine should
not be called unless it's the last proxy object being
destroyed (i.e., the refcnt on the "private SV" is 1).
-----
void
Perl_sv_clear(pTHX_ register SV *sv)
{
    dVAR;
    const U32 type = SvTYPE(sv);
    const struct body_details *const sv_type_details
	= bodies_by_type + type;
    HV *stash;

    assert(sv);
    assert(SvREFCNT(sv) == 0);

    if (type <= SVt_IV) {
	/* See the comment in sv.h about the collusion between this early
	   return and the overloading of the NULL and IV slots in the size
	   table.  */
	return;
    }

    if (SvOBJECT(sv)) {
	if (PL_defstash) {		/* Still have a symbol table? */
#ifdef USE_ITHREADS
	    IV destroyable;
	    CV *check_destroyable = get_cv("threads::shared::_is_destroyable", 0);
	    if (check_destroyable) {
		dSP;
		int count;
		ENTER;
		SAVETMPS;
		PUSHMARK(SP);
		XPUSHs(sv);
		PUTBACK;
		count = call_sv((SV*)check_destroyable, G_SCALAR);
		SPAGAIN;
		if (count != 1)
		    Perl_croak(aTHX_ "'threads::shared::_is_destroyable' failed to
return result");
		destroyable = POPi;
		PUTBACK;
		FREETMPS;
		LEAVE;
	    } else {
		destroyable = 1;
	    }

	    if (destroyable) {
#endif
		HV* stash;
		do {
		    dSP;
		    CV* destructor;
		    stash = SvSTASH(sv);
		    destructor = StashHANDLER(stash,DESTROY);
		    if (destructor) {
			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((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 */
		    return;
		}
#ifdef USE_ITHREADS
	    }
#endif
	}

	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 */
	}
    }

    and so on....
-----
My problem is that my code seg faults, and I can't figure
out why.  Any ideas?

Also, if anyone has any other thoughts regarding my
approach, that would be helpful.

Thanks.

P.S., I've attached a patch to blead for convenience.



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About