diff options
Diffstat (limited to 'pp_hot.c')
| -rw-r--r-- | pp_hot.c | 211 |
1 files changed, 115 insertions, 96 deletions
@@ -1772,6 +1772,36 @@ PP(pp_leavesub) return pop_return(); } +static CV * +get_db_sub(sv) +SV *sv; +{ + dTHR; + SV *oldsv = sv; + GV *gv; + CV *cv; + + sv = GvSV(DBsub); + save_item(sv); + gv = CvGV(cv); + if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + || strEQ(GvNAME(gv), "END") + || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv) + && (gv = (GV*)oldsv) ))) { + /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ + sv_setsv(sv, newRV((SV*)cv)); + } + else { + gv_efullname3(sv, gv, Nullch); + } + cv = GvCV(DBsub); + if (CvXSUB(cv)) + curcopdb = curcop; + return cv; +} + PP(pp_entersub) { dSP; dPOPss; @@ -1853,29 +1883,18 @@ PP(pp_entersub) } gimme = GIMME_V; - if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) { - SV *oldsv = sv; - sv = GvSV(DBsub); - save_item(sv); - gv = CvGV(cv); - if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv) - && (gv = (GV*)oldsv) ))) { /* Use GV from the stack as a fallback. */ - /* GV is potentially non-unique, or contain different CV. */ - sv_setsv(sv, newRV((SV*)cv)); - } - else { - gv_efullname3(sv, gv, Nullch); - } - cv = GvCV(DBsub); - if (CvXSUB(cv)) curcopdb = curcop; - if (!cv) - DIE("No DBsub routine"); - } + if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) + cv = get_db_sub(sv); + if (!cv) + DIE("No DBsub routine"); #ifdef USE_THREADS + /* + * First we need to check if the sub or method requires locking. + * If so, we gain a lock on the CV or the first argument, as + * appropriate. This has to be inline because for FAKE_THREADS, + * COND_WAIT inlines code to reschedule by returning a new op. + */ MUTEX_LOCK(CvMUTEXP(cv)); if (CvFLAGS(cv) & CVf_LOCKED) { MAGIC *mg; @@ -1915,90 +1934,90 @@ PP(pp_entersub) if (CvDEPTH(cv) == 0) SAVEDESTRUCTOR(unset_cvowner, (void*) cv); } + /* + * Now we have permission to enter the sub, we must distinguish + * four cases. (0) It's an XSUB (in which case we don't care + * about ownership); (1) it's ours already (and we're recursing); + * (2) it's free (but we may already be using a cached clone); + * (3) another thread owns it. Case (1) is easy: we just use it. + * Case (2) means we look for a clone--if we have one, use it + * otherwise grab ownership of cv. Case (3) means we look for a + * clone (for non-XSUBs) and have to create one if we don't + * already have one. + * Why look for a clone in case (2) when we could just grab + * ownership of cv straight away? Well, we could be recursing, + * i.e. we originally tried to enter cv while another thread + * owned it (hence we used a clone) but it has been freed up + * and we're now recursing into it. It may or may not be "better" + * to use the clone but at least CvDEPTH can be trusted. + */ + if (CvOWNER(cv) == thr || CvXSUB(cv)) + MUTEX_UNLOCK(CvMUTEXP(cv)); else { + /* Case (2) or (3) */ + SV **svp; + /* - * It's an ordinary unsynchronised CV so we must distinguish - * three cases. (1) It's ours already (and we're recursing); - * (2) it's free (but we may already be using a cached clone); - * (3) another thread owns it. Case (1) is easy: we just use it. - * Case (2) means we look for a clone--if we have one, use it - * otherwise grab ownership of cv. Case (3) means look we for a - * clone and have to create one if we don't already have one. - * Why look for a clone in case (2) when we could just grab - * ownership of cv straight away? Well, we could be recursing, - * i.e. we originally tried to enter cv while another thread - * owned it (hence we used a clone) but it has been freed up - * and we're now recursing into it. It may or may not be "better" - * to use the clone but at least CvDEPTH can be trusted. - */ - if (CvOWNER(cv) == thr) + * XXX Might it be better to release CvMUTEXP(cv) while we + * do the hv_fetch? We might find someone has pinched it + * when we look again, in which case we would be in case + * (3) instead of (2) so we'd have to clone. Would the fact + * that we released the mutex more quickly make up for this? + */ + svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE); + if (svp) { + /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); + cv = *(CV**)svp; + 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); + if (CvDEPTH(cv) == 0) + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + } else { - /* Case (2) or (3) */ - SV **svp; - - /* - * XXX Might it be better to release CvMUTEXP(cv) while we - * do the hv_fetch? We might find someone has pinched it - * when we look again, in which case we would be in case - * (3) instead of (2) so we'd have to clone. Would the fact - * that we released the mutex more quickly make up for this? - */ - svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE); - if (svp) { - /* We already have a clone to use */ + /* (2) => grab ownership of cv. (3) => make clone */ + if (!CvOWNER(cv)) { + CvOWNER(cv) = thr; + SvREFCNT_inc(cv); MUTEX_UNLOCK(CvMUTEXP(cv)); - cv = *(CV**)svp; 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; + "entersub: 0x%lx grabbing 0x%lx:%s in stash %s\n", + (unsigned long) thr, (unsigned long) 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((PerlIO_printf(PerlIO_stderr(), + "entersub: 0x%lx cloning 0x%lx:%s\n", + (unsigned long) thr, (unsigned long) cv, + SvPEEK((SV*)cv)))); + /* + * We're creating a new clone so there's no race + * between the original MUTEX_UNLOCK and the + * SvREFCNT_inc since no one will be trying to undef + * it out from underneath us. At least, I don't think + * there's a race... + */ + clonecv = cv_clone(cv); + SvREFCNT_dec(cv); /* finished with this */ + hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); + CvOWNER(clonecv) = thr; + cv = clonecv; SvREFCNT_inc(cv); - if (CvDEPTH(cv) == 0) - SAVEDESTRUCTOR(unset_cvowner, (void*) cv); - } - else { - /* (2) => grab ownership of cv. (3) => make clone */ - if (!CvOWNER(cv)) { - CvOWNER(cv) = thr; - SvREFCNT_inc(cv); - MUTEX_UNLOCK(CvMUTEXP(cv)); - 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), 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((PerlIO_printf(PerlIO_stderr(), - "entersub: 0x%lx cloning 0x%lx:%s\n", - (unsigned long) thr, (unsigned long) cv, - SvPEEK((SV*)cv)))); - /* - * We're creating a new clone so there's no race - * between the original MUTEX_UNLOCK and the - * SvREFCNT_inc since no one will be trying to undef - * it out from underneath us. At least, I don't think - * there's a race... - */ - clonecv = cv_clone(cv); - SvREFCNT_dec(cv); /* finished with this */ - hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); - CvOWNER(clonecv) = thr; - cv = clonecv; - SvREFCNT_inc(cv); - } - DEBUG_L(if (CvDEPTH(cv) != 0) - PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", - CvDEPTH(cv));); - SAVEDESTRUCTOR(unset_cvowner, (void*) cv); } + DEBUG_L(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); } - } + } #endif /* USE_THREADS */ gimme = GIMME; |