-/* sharedsv.c
+/* shared.xs
*
- * Copyright (c) 2001, Larry Wall
+ * Copyright (c) 2001-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
}
void
+recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
+{
+ MUTEX_DESTROY(&lock->mutex);
+ COND_DESTROY(&lock->cond);
+}
+
+void
recursive_lock_release(pTHX_ recursive_lock_t *lock)
{
MUTEX_LOCK(&lock->mutex);
shared_sv *shared = (shared_sv *) mg->mg_ptr;
assert( aTHX == PL_sharedsv_space );
if (shared) {
+ recursive_lock_destroy(aTHX_ &shared->lock);
+ COND_DESTROY(&shared->user_cond);
PerlMemShared_free(shared);
mg->mg_ptr = NULL;
}
/* If neither of those then create a new one */
if (!data) {
SHARED_CONTEXT;
- if (!ssv)
+ if (!ssv) {
ssv = newSV(0);
+ SvREFCNT(ssv) = 0;
+ }
data = PerlMemShared_malloc(sizeof(shared_sv));
Zero(data,1,shared_sv);
SHAREDSvPTR(data) = ssv;
if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
SHARED_CONTEXT;
sv_upgrade(ssv, SvTYPE(*psv));
+ if (SvTYPE(ssv) == SVt_PVAV) /* #24061 */
+ AvREAL_on(ssv);
CALLER_CONTEXT;
}
mg->mg_flags |= (MGf_COPY|MGf_DUP);
SvREFCNT_inc(ssv);
SvREFCNT_dec(obj);
+ if(SvOBJECT(ssv)) {
+ STRLEN len;
+ char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
+ HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
+ SvOBJECT_on(sv);
+ SvSTASH(sv) = (HV*)SvREFCNT_inc(stash);
+ }
}
break;
sv_setsv_nomg(sv, &PL_sv_undef);
SvRV(sv) = obj;
SvROK_on(sv);
+
}
else {
sv_setsv_nomg(sv, SHAREDSvPTR(shared));
if (target) {
SV *tmp;
SHARED_CONTEXT;
+ /* #24255: sv_setsv() (via sv_unref_flags()) may cause a
+ * deferred free with sv_2mortal(). Ensure that the free_tmps
+ * is done within this interpreter. DAPM.
+ */
+ ENTER;
+ SAVETMPS;
tmp = newRV(SHAREDSvPTR(target));
sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
SvREFCNT_dec(tmp);
+ if(SvOBJECT(SvRV(sv))) {
+ SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0);
+ SvOBJECT_on(SHAREDSvPTR(target));
+ SvSTASH(SHAREDSvPTR(target)) = (HV*)fake_stash;
+ }
+ FREETMPS;
+ LEAVE;
CALLER_CONTEXT;
}
else {
}
}
else {
- SvTEMP_off(sv);
+ SvTEMP_off(sv);
SHARED_CONTEXT;
sv_setsv_nomg(SHAREDSvPTR(shared), sv);
+ if(SvOBJECT(sv)) {
+ SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0);
+ SvOBJECT_on(SHAREDSvPTR(shared));
+ SvSTASH(SHAREDSvPTR(shared)) = (HV*)fake_stash;
+ }
CALLER_CONTEXT;
}
if (!allowed) {
assert ( SHAREDSvPTR(shared) );
ENTER_LOCK;
-
if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
assert ( mg->mg_ptr == 0 );
SHARED_CONTEXT;
MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
name, namlen);
+ ENTER_LOCK;
SvREFCNT_inc(SHAREDSvPTR(shared));
+ LEAVE_LOCK;
nmg->mg_flags |= MGf_DUP;
return 1;
}
recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
}
+/* handles calls from lock() builtin via PL_lockhook */
+
void
Perl_sharedsv_locksv(pTHX_ SV *sv)
{
- Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv));
+ shared_sv* shared;
+
+ if(SvROK(sv))
+ sv = SvRV(sv);
+ shared = Perl_sharedsv_find(aTHX_ sv);
+ if(!shared)
+ croak("lock can only be used on shared values");
+ Perl_sharedsv_lock(aTHX_ shared);
}
=head1 Shared SV Functions
=for apidoc sharedsv_init
Saves a space for keeping SVs wider than an interpreter,
-currently only stores a pointer to the first interpreter.
=cut
sharedsv_scalar_store(aTHX_ tmp, target);
SHARED_CONTEXT;
av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
+ SvREFCNT_inc(SHAREDSvPTR(target));
SHARED_RELEASE;
SvREFCNT_dec(tmp);
}
sharedsv_scalar_store(aTHX_ tmp, target);
SHARED_CONTEXT;
av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
+ SvREFCNT_inc(SHAREDSvPTR(target));
CALLER_CONTEXT;
SvREFCNT_dec(tmp);
}
SHARED_CONTEXT;
sv = av_pop((AV*)SHAREDSvPTR(shared));
CALLER_CONTEXT;
- ST(0) = Nullsv;
+ ST(0) = sv_newmortal();
Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
+ SvREFCNT_dec(sv);
LEAVE_LOCK;
XSRETURN(1);
SHARED_CONTEXT;
sv = av_shift((AV*)SHAREDSvPTR(shared));
CALLER_CONTEXT;
- ST(0) = Nullsv;
+ ST(0) = sv_newmortal();
Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
+ SvREFCNT_dec(sv);
LEAVE_LOCK;
XSRETURN(1);
PROTOTYPE: \[$@%]
CODE:
shared_sv *shared;
+ ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
PROTOTYPE: \[$@%]
CODE:
shared_sv *shared;
+ ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
}
XSRETURN_UNDEF;
-void
+SV*
share(SV *ref)
PROTOTYPE: \[$@%]
CODE:
+ if(!SvROK(ref))
+ Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
+ ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
- Perl_sharedsv_share(aTHX, ref);
+ Perl_sharedsv_share(aTHX_ ref);
+ RETVAL = newRV(ref);
+ OUTPUT:
+ RETVAL
void
lock_enabled(SV *ref)
PROTOTYPE: \[$@%]
CODE:
shared_sv* shared;
+ if(!SvROK(ref))
+ Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
+ ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
- shared = Perl_sharedsv_find(aTHX, ref);
+ shared = Perl_sharedsv_find(aTHX_ ref);
if(!shared)
croak("lock can only be used on shared values");
Perl_sharedsv_lock(aTHX_ shared);
CODE:
shared_sv* shared;
int locks;
+ if(!SvROK(ref))
+ Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
+ ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
shared = Perl_sharedsv_find(aTHX_ ref);
PROTOTYPE: \[$@%]
CODE:
shared_sv* shared;
+ if(!SvROK(ref))
+ Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
+ ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
shared = Perl_sharedsv_find(aTHX_ ref);
+ if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
+ Perl_warner(aTHX_ packWARN(WARN_THREADS),
+ "cond_signal() called on unlocked variable");
if(!shared)
croak("cond_signal can only be used on shared values");
COND_SIGNAL(&shared->user_cond);
PROTOTYPE: \[$@%]
CODE:
shared_sv* shared;
+ if(!SvROK(ref))
+ Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
+ ref = SvRV(ref);
if(SvROK(ref))
ref = SvRV(ref);
shared = Perl_sharedsv_find(aTHX_ ref);
if(!shared)
croak("cond_broadcast can only be used on shared values");
+ if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
+ Perl_warner(aTHX_ packWARN(WARN_THREADS),
+ "cond_broadcast() called on unlocked variable");
COND_BROADCAST(&shared->user_cond);
+
+SV*
+bless(SV* ref, ...);
+ PROTOTYPE: $;$
+ CODE:
+ {
+ HV* stash;
+ shared_sv* shared;
+ if (items == 1)
+ stash = CopSTASH(PL_curcop);
+ else {
+ SV* ssv = ST(1);
+ STRLEN len;
+ char *ptr;
+
+ if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
+ Perl_croak(aTHX_ "Attempt to bless into a reference");
+ ptr = SvPV(ssv,len);
+ if (ckWARN(WARN_MISC) && len == 0)
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Explicit blessing to '' (assuming package main)");
+ stash = gv_stashpvn(ptr, len, TRUE);
+ }
+ SvREFCNT_inc(ref);
+ (void)sv_bless(ref, stash);
+ RETVAL = ref;
+ shared = Perl_sharedsv_find(aTHX_ ref);
+ if(shared) {
+ dTHXc;
+ ENTER_LOCK;
+ SHARED_CONTEXT;
+ {
+ SV* fake_stash = newSVpv(HvNAME(stash),0);
+ (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
+ }
+ CALLER_CONTEXT;
+ LEAVE_LOCK;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
#endif /* USE_ITHREADS */
BOOT:
https://perl5.git.perl.org / perl5.git / blobdiff