Fix up locking/synchronisation for pp_entersub.
Malcolm Beattie [Fri, 10 Oct 1997 17:19:55 +0000 (17:19 +0000)]
p4raw-id: //depot/perl@119

pp_hot.c

index fcf3d22..f0bf7aa 100644 (file)
--- 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;