#define UL_MAGIC_SIG 0x554C /* UL = user lock */
/*
- * The shared things need an intepreter to live in ...
+ * The shared things need an interpreter to live in ...
*/
PerlInterpreter *PL_sharedsv_space; /* The shared sv space */
/* To access shared space we fake aTHX in this scope and thread's context */
#endif
};
+
+/* Support for dual-valued variables */
+#ifdef SVf_IVisUV
+# define DUALVAR_FLAGS(sv) \
+ ((SvPOK(sv)) \
+ ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \
+ : ((SvIsUV(sv)) ? (SVf_IOK | SVf_IVisUV) \
+ : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0))) \
+ : 0)
+#else
+# define DUALVAR_FLAGS(sv) \
+ ((SvPOK(sv)) \
+ ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \
+ : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0)) \
+ : 0)
+#endif
+
+
/*
* Access to shared things is heavily based on MAGIC
* - in mg.h/mg.c/sv.c sense
/* Get shared aggregate SV pointed to by threads::shared::tie magic object */
-STATIC SV *
-S_sharedsv_from_obj(pTHX_ SV *sv)
-{
- return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL);
-}
+#define SHAREDSV_FROM_OBJ(sv) ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL)
/* Return the user_lock structure (if any) associated with a shared SV.
}
/* Just for tidyness of API also handle tie objects */
if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
- return (S_sharedsv_from_obj(aTHX_ sv));
+ return (SHAREDSV_FROM_OBJ(sv));
}
return (NULL);
}
bool
Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
{
-#if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
+#if defined(NETWARE) || defined(I_MACH_CTHREADS)
Perl_croak_nocontext("cond_timedwait not supported on this platform");
#else
# ifdef WIN32
return (got_it);
# endif /* OS2 */
# endif /* WIN32 */
-#endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
+#endif /* NETWARE || I_MACH_CTHREADS */
}
-/* Given a shared RV, copy it's value to a private RV, also copying the
- * object status of the referent.
+/* Given a thingy referenced by a shared RV, copy it's value to a private
+ * RV, also copying the object status of the referent.
* If the private side is already an appropriate RV->SV combination, keep
* it if possible.
*/
STATIC void
-S_get_RV(pTHX_ SV *sv, SV *ssv) {
- SV *sobj = SvRV(ssv);
+S_get_RV(pTHX_ SV *sv, SV *sobj) {
SV *obj;
if (! (SvROK(sv) &&
((obj = SvRV(sv))) &&
sv_setsv_nomg(sv, &PL_sv_undef);
SvROK_on(sv);
}
- obj = S_sharedsv_new_private(aTHX_ SvRV(ssv));
+ obj = S_sharedsv_new_private(aTHX_ sobj);
SvRV_set(sv, obj);
}
}
}
+/* Every caller of S_get_RV needs this incantation (which cannot go inside
+ S_get_RV itself, as we do not want recursion beyond one level): */
+#define get_RV(sv, sobj) \
+ S_get_RV(aTHX_ sv, sobj); \
+ /* Look ahead for refs of refs */ \
+ if (SvROK(sobj)) { \
+ SvROK_on(SvRV(sv)); \
+ S_get_RV(aTHX_ SvRV(sv), SvRV(sobj)); \
+ }
+
/* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */
ENTER_LOCK;
if (SvROK(ssv)) {
- S_get_RV(aTHX_ sv, ssv);
- /* Look ahead for refs of refs */
- if (SvROK(SvRV(ssv))) {
- SvROK_on(SvRV(sv));
- S_get_RV(aTHX_ SvRV(sv), SvRV(ssv));
- }
+ get_RV(sv, SvRV(ssv));
} else {
sv_setsv_nomg(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);
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);
}
sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
{
dTHXc;
- SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+ SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
SV** svp = NULL;
ENTER_LOCK;
if (svp) {
/* Exists in the array */
if (SvROK(*svp)) {
- S_get_RV(aTHX_ sv, *svp);
- /* Look ahead for refs of refs */
- if (SvROK(SvRV(*svp))) {
- SvROK_on(SvRV(sv));
- S_get_RV(aTHX_ SvRV(sv), SvRV(*svp));
- }
+ get_RV(sv, SvRV(*svp));
} else {
/* $ary->[elem] or $ary->{elem} is a scalar */
Perl_sharedsv_associate(aTHX_ sv, *svp);
sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
{
dTHXc;
- SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+ SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
SV **svp;
+ U32 dualvar_flags = DUALVAR_FLAGS(sv);
+
/* Theory - SV itself is magically shared - and we have ordered the
magic such that by the time we get here it has been stored
to its shared counterpart
CALLER_CONTEXT;
Perl_sharedsv_associate(aTHX_ sv, *svp);
sharedsv_scalar_store(aTHX_ sv, *svp);
+ SvFLAGS(*svp) |= dualvar_flags;
LEAVE_LOCK;
return (0);
}
{
dTHXc;
MAGIC *shmg;
- SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+ SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
/* Object may not exist during global destruction */
if (! saggregate) {
sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
PERL_UNUSED_ARG(param);
- SvREFCNT_inc_void(S_sharedsv_from_obj(aTHX_ mg->mg_obj));
+ SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj));
assert(mg->mg_flags & MGf_DUP);
return (0);
}
val = av_len((AV*) ssv);
} else {
/* Not actually defined by tie API but ... */
- val = HvKEYS((HV*) ssv);
+ val = HvUSEDKEYS((HV*) ssv);
}
SHARED_RELEASE;
return (val);
{
dTHXc;
SV *ssv = (SV *) mg->mg_ptr;
+ const bool isav = SvTYPE(ssv) == SVt_PVAV;
PERL_UNUSED_ARG(sv);
SHARED_EDIT;
- if (SvTYPE(ssv) == SVt_PVAV) {
- av_clear((AV*) ssv);
- } else {
- hv_clear((HV*) ssv);
+ if (!PL_dirty) {
+ SV **svp = isav ? AvARRAY((AV *)ssv) : NULL;
+ I32 items = isav ? AvFILLp((AV *)ssv) + 1 : 0;
+ HE *iter;
+ if (!isav) hv_iterinit((HV *)ssv);
+ while (isav ? items-- : !!(iter = hv_iternext((HV *)ssv))) {
+ SV *sv = isav ? *svp++ : 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));
+ }
+ }
}
+ if (isav) av_clear((AV*) ssv);
+ else hv_clear((HV*) ssv);
SHARED_RELEASE;
return (0);
}
sv = SvRV(sv);
ssv = Perl_sharedsv_find(aTHX_ sv);
if (!ssv)
- croak("lock can only be used on shared values");
+ croak("lock can only be used on shared values");
Perl_sharedsv_lock(aTHX_ ssv);
}
/* Can a shared object be destroyed?
* True if not a shared,
- * or if detroying last proxy on a shared object
+ * or if destroying last proxy on a shared object
*/
#ifdef PL_destroyhook
bool
}
#endif
-/* veto signal despatch if we have the lock */
+/* veto signal dispatch if we have the lock */
#ifdef PL_signalhook
us = (PL_sharedsv_lock.owner == aTHX);
MUTEX_UNLOCK(&PL_sharedsv_lock.mutex);
if (us)
- return; /* try again later */
+ return; /* try again later */
prev_signal_hook(aTHX);
}
#endif
#endif
#ifdef PL_signalhook
if (!prev_signal_hook) {
- prev_signal_hook = PL_signalhook;
- PL_signalhook = &S_shared_signal_hook;
+ prev_signal_hook = PL_signalhook;
+ PL_signalhook = &S_shared_signal_hook;
}
#endif
}
PUSH(SV *obj, ...)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
- int i;
- for (i = 1; i < items; i++) {
- SV* tmp = newSVsv(ST(i));
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
+ int ii;
+ for (ii = 1; ii < items; ii++) {
+ SV* tmp = newSVsv(ST(ii));
SV *stmp;
+ U32 dualvar_flags = DUALVAR_FLAGS(tmp);
ENTER_LOCK;
stmp = S_sharedsv_new_shared(aTHX_ tmp);
sharedsv_scalar_store(aTHX_ tmp, stmp);
+ SvFLAGS(stmp) |= dualvar_flags;
SHARED_CONTEXT;
av_push((AV*) sobj, stmp);
SvREFCNT_inc_void(stmp);
UNSHIFT(SV *obj, ...)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
- int i;
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
+ int ii;
ENTER_LOCK;
SHARED_CONTEXT;
av_unshift((AV*)sobj, items - 1);
CALLER_CONTEXT;
- for (i = 1; i < items; i++) {
- SV *tmp = newSVsv(ST(i));
+ for (ii = 1; ii < items; ii++) {
+ SV *tmp = newSVsv(ST(ii));
+ U32 dualvar_flags = DUALVAR_FLAGS(tmp);
SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
sharedsv_scalar_store(aTHX_ tmp, stmp);
SHARED_CONTEXT;
- av_store((AV*) sobj, i - 1, stmp);
+ SvFLAGS(stmp) |= dualvar_flags;
+ av_store((AV*) sobj, ii - 1, stmp);
SvREFCNT_inc_void(stmp);
CALLER_CONTEXT;
SvREFCNT_dec(tmp);
POP(SV *obj)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SV* ssv;
ENTER_LOCK;
SHARED_CONTEXT;
SHIFT(SV *obj)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SV* ssv;
ENTER_LOCK;
SHARED_CONTEXT;
EXTEND(SV *obj, IV count)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SHARED_EDIT;
av_extend((AV*)sobj, count);
SHARED_RELEASE;
STORESIZE(SV *obj,IV count)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SHARED_EDIT;
av_fill((AV*) sobj, count);
SHARED_RELEASE;
EXISTS(SV *obj, SV *index)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
bool exists;
if (SvTYPE(sobj) == SVt_PVAV) {
SHARED_EDIT;
FIRSTKEY(SV *obj)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
char* key = NULL;
I32 len = 0;
HE* entry;
NEXTKEY(SV *obj, SV *oldkey)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
char* key = NULL;
I32 len = 0;
HE* entry;
void
-bless(SV* myref, ...);
+bless(SV* myref, ...)
PROTOTYPE: $;$
PREINIT:
HV* stash;
https://perl5.git.perl.org / perl5.git / blobdiff