I'm trying to come up with a fix for the 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.
My problem is that my code (provided below) seg faults, and
I can't figure out why. Any help, comments, suggestions,
etc. would be appreciated.
The following elicits the 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: [EMAIL PROTECTED]
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....
-----
A patch to blead for the above is attached.
bug.patch
Description: Binary data
