Fix up locking/synchronisation for pp_entersub.

p4raw-id: //depot/perl@119

1 files changed, 115 insertions, 96 deletions

diff --git a/pp_hot.c b/pp_hot.c
index fcf3d22501..f0bf7aa07a 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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;