dTHR;
#endif /* DEBUGGING */
- DEBUG_L((fprintf(stderr, "0x%lx unsetting CvOWNER of 0x%lx:%s\n",
+ DEBUG_L((PerlIO_printf(PerlIO_stderr(), "0x%lx unsetting CvOWNER of 0x%lx:%s\n",
(unsigned long)thr, (unsigned long)cv, SvPEEK((SV*)cv))));
MUTEX_LOCK(CvMUTEXP(cv));
- /* assert(CvDEPTH(cv) == 0); */
+ DEBUG_L(if (CvDEPTH(cv) != 0)
+ PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ CvDEPTH(cv)););
assert(thr == CvOWNER(cv));
CvOWNER(cv) = 0;
- if (CvCONDP(cv))
- COND_SIGNAL(CvCONDP(cv)); /* next please */
MUTEX_UNLOCK(CvMUTEXP(cv));
SvREFCNT_dec(cv);
}
-
-#if 0
-void
-mutex_unlock(m)
-void *m;
-{
-#ifdef DEBUGGING
- dTHR;
- DEBUG_L((fprintf(stderr, "0x%lx unlocking mutex 0x%lx\n",
- (unsigned long) thr, (unsigned long) m)));
-#endif /* DEBUGGING */
- MUTEX_UNLOCK((pthread_mutex_t *) m);
-}
-#endif
#endif /* USE_THREADS */
PP(pp_const)
av = (AV*)SvRV(sv);
if (SvTYPE(av) != SVt_PVAV)
DIE("Not an ARRAY reference");
- if (op->op_private & OPpLVAL_INTRO)
- av = (AV*)save_svref((SV**)sv);
if (op->op_flags & OPf_REF) {
PUSHs((SV*)av);
RETURN;
hv = (HV*)SvRV(sv);
if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
DIE("Not a HASH reference");
- if (op->op_private & OPpLVAL_INTRO)
- hv = (HV*)save_svref((SV**)sv);
if (op->op_flags & OPf_REF) {
SETs((SV*)hv);
RETURN;
av_extend(ary, lastrelem - relem);
i = 0;
while (relem <= lastrelem) { /* gobble up all the rest */
+ SV **didstore;
sv = NEWSV(28,0);
assert(*relem);
sv_setsv(sv,*relem);
*(relem++) = sv;
- (void)av_store(ary,i++,sv);
- if (magic)
+ didstore = av_store(ary,i++,sv);
+ if (magic) {
mg_set(sv);
+ if (!didstore)
+ SvREFCNT_dec(sv);
+ }
TAINT_NOT;
}
break;
while (relem < lastrelem) { /* gobble up all the rest */
STRLEN len;
+ HE *didstore;
if (*relem)
sv = *(relem++);
else
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
*(relem++) = tmpstr;
- (void)hv_store_ent(hash,sv,tmpstr,0);
- if (magic)
+ didstore = hv_store_ent(hash,sv,tmpstr,0);
+ if (magic) {
mg_set(tmpstr);
+ if (!didstore)
+ SvREFCNT_dec(tmpstr);
+ }
TAINT_NOT;
}
if (relem == lastrelem)
#ifdef USE_THREADS
MUTEX_LOCK(CvMUTEXP(cv));
- if (!CvCONDP(cv)) {
-#ifdef DEBUGGING
- DEBUG_L((fprintf(stderr, "0x%lx entering fast %s\n",
- (unsigned long)thr, SvPEEK((SV*)cv))));
-#endif /* DEBUGGING */
- MUTEX_UNLOCK(CvMUTEXP(cv)); /* fast sub wants neither sync nor clone */
- }
- else if (SvFLAGS(cv) & SVp_SYNC) {
- /*
- * It's a synchronised CV. Wait until it's free unless
- * we own it already (in which case we're recursing).
- */
- if (CvOWNER(cv) && CvOWNER(cv) != thr) {
- do {
- DEBUG_L((fprintf(stderr, "0x%lx wait for 0x%lx to leave %s\n",
- (unsigned long)thr,(unsigned long)CvOWNER(cv),
- SvPEEK((SV*)cv))));
- COND_WAIT(CvCONDP(cv), CvMUTEXP(cv)); /* yawn */
- } while (CvOWNER(cv));
+ if (CvFLAGS(cv) & CVf_LOCKED) {
+ MAGIC *mg;
+ if (CvFLAGS(cv) & CVf_METHOD) {
+ if (SP > stack_base + TOPMARK)
+ sv = *(stack_base + TOPMARK + 1);
+ else {
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ croak("no argument for locked method call");
+ }
+ if (SvROK(sv))
+ sv = SvRV(sv);
}
+ else {
+ sv = (SV*)cv;
+ }
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ mg = condpair_magic(sv);
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) == thr)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ else {
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "0x%lx: pp_entersub lock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)sv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ save_destructor(unlock_condpair, sv);
+ }
+ MUTEX_LOCK(CvMUTEXP(cv));
+ assert(CvOWNER(cv) == 0);
CvOWNER(cv) = thr; /* Assert ownership */
SvREFCNT_inc(cv);
MUTEX_UNLOCK(CvMUTEXP(cv));
/* We already have a clone to use */
MUTEX_UNLOCK(CvMUTEXP(cv));
cv = *(CV**)svp;
- DEBUG_L(fprintf(stderr,
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"entersub: 0x%lx already has clone 0x%lx:%s\n",
(unsigned long) thr, (unsigned long) cv,
SvPEEK((SV*)cv)));
CvOWNER(cv) = thr;
SvREFCNT_inc(cv);
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_L(fprintf(stderr,
- "entersub: 0x%lx grabbing 0x%lx:%s\n",
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "entersub: 0x%lx grabbing 0x%lx:%s in stash %s\n",
(unsigned long) thr, (unsigned long) cv,
- SvPEEK((SV*)cv)));
+ SvPEEK((SV*)cv), CvSTASH(cv) ?
+ HvNAME(CvSTASH(cv)) : "(none)"));
} else {
/* Make a new clone. */
CV *clonecv;
SvREFCNT_inc(cv); /* don't let it vanish from under us */
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_L((fprintf(stderr,
+ DEBUG_L((PerlIO_printf(PerlIO_stderr(),
"entersub: 0x%lx cloning 0x%lx:%s\n",
(unsigned long) thr, (unsigned long) cv,
SvPEEK((SV*)cv))));
cv = clonecv;
SvREFCNT_inc(cv);
}
- assert(CvDEPTH(cv) == 0);
+ DEBUG_L(if (CvDEPTH(cv) != 0)
+ PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ CvDEPTH(cv)););
SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
}
}
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
if (CvDEPTH(cv) == 100 && dowarn
- && !(perldb && cv == GvCV(DBsub)))
+ && !(PERLDB_SUB && cv == GvCV(DBsub)))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *av;
AV* av;
SV** ary;
+#if 0
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub preparing @_\n", thr));
+#endif
av = (AV*)curpad[0];
if (AvREAL(av)) {
av_clear(av);
MARK++;
}
}
+#if 0
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub returning %p\n", thr, CvSTART(cv)));
+#endif
RETURNOP(CvSTART(cv));
}
}
projects / p5sagit/p5-mst-13.2.git / blobdiff