Clean up copy-on-write macros and debug facilities (new flag 'C').

Handle CoW in hashes:
Subject: Re: why would tr/// be performing hash copies?
Message-id: <20020818221700.GD294@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@17740

6 files changed, 57 insertions, 42 deletions

diff --git a/hv.c b/hv.c
index 6d8461fe39..0d087676c5 100644
--- a/hv.c
+++ b/hv.c
@@ -409,8 +409,13 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
     }
 
-    if (!hash)
-	PERL_HASH(hash, key, klen);
+    if (!hash) {
+        if SvIsCOW_shared_hash(keysv) {
+            hash = SvUVX(keysv);
+        } else {
+            PERL_HASH(hash, key, klen);
+        }
+    }
 
     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
@@ -737,8 +742,13 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
         HvHASKFLAGS_on((SV*)hv);
     }
 
-    if (!hash)
-	PERL_HASH(hash, key, klen);
+    if (!hash) {
+        if SvIsCOW_shared_hash(keysv) {
+            hash = SvUVX(keysv);
+        } else {
+            PERL_HASH(hash, key, klen);
+        }
+    }
 
     if (!xhv->xhv_array /* !HvARRAY(hv) */)
 	Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
diff --git a/perl.c b/perl.c
index 224cc9c0de..58e2ac1fd8 100644
--- a/perl.c
+++ b/perl.c
@@ -2338,7 +2338,7 @@ Perl_moreswitches(pTHX_ char *s)
 	forbid_setid("-D");
 	if (isALPHA(s[1])) {
 	    /* if adding extra options, remember to update DEBUG_MASK */
-	    static char debopts[] = "psltocPmfrxuLHXDSTRJv";
+	    static char debopts[] = "psltocPmfrxuLHXDSTRJvC";
 	    char *d;
 
 	    for (s++; *s && (d = strchr(debopts,*s)); s++)
diff --git a/perl.h b/perl.h
index 5c13a7dae2..0943e2ff62 100644
--- a/perl.h
+++ b/perl.h
@@ -2430,7 +2430,8 @@ Gid_t getegid (void);
 #define DEBUG_R_FLAG		0x00040000 /* 262144 */
 #define DEBUG_J_FLAG		0x00080000 /* 524288 */
 #define DEBUG_v_FLAG		0x00100000 /*1048576 */
-#define DEBUG_MASK		0x001FFFFF /* mask of all the standard flags */
+#define DEBUG_C_FLAG		0x00200000 /*2097152 */
+#define DEBUG_MASK		0x003FFFFF /* mask of all the standard flags */
 
 #define DEBUG_DB_RECURSE_FLAG	0x40000000
 #define DEBUG_TOP_FLAG		0x80000000 /* XXX what's this for ??? Signal
@@ -2457,6 +2458,7 @@ Gid_t getegid (void);
 #  define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
 #  define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
 #  define DEBUG_v_TEST_ (PL_debug & DEBUG_v_FLAG)
+#  define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG)
 
 #ifdef DEBUGGING
 
@@ -2484,6 +2486,7 @@ Gid_t getegid (void);
 #  define DEBUG_R_TEST DEBUG_R_TEST_
 #  define DEBUG_J_TEST DEBUG_J_TEST_
 #  define DEBUG_v_TEST DEBUG_v_TEST_
+#  define DEBUG_C_TEST DEBUG_C_TEST_
 
 #  define DEB(a)     a
 #  define DEBUG(a)   if (PL_debug)   a
@@ -2525,6 +2528,7 @@ Gid_t getegid (void);
 #  define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
 #  define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
 #  define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a)
+#  define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a)
 
 #else /* DEBUGGING */
 
@@ -2549,6 +2553,7 @@ Gid_t getegid (void);
 #  define DEBUG_R_TEST (0)
 #  define DEBUG_J_TEST (0)
 #  define DEBUG_v_TEST (0)
+#  define DEBUG_C_TEST (0)
 
 #  define DEB(a)
 #  define DEBUG(a)
@@ -2572,6 +2577,7 @@ Gid_t getegid (void);
 #  define DEBUG_T(a)
 #  define DEBUG_R(a)
 #  define DEBUG_v(a)
+#  define DEBUG_C(a)
 #endif /* DEBUGGING */
 
 
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 3c1f159fd0..ee80d381f4 100644
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -329,6 +329,7 @@ B<-D14> is equivalent to B<-Dtls>):
    262144  R  Include reference counts of dumped variables (eg when using -Ds)
    524288  J  Do not s,t,P-debug (Jump over) opcodes within package DB
   1048576  v  Verbose: use in conjunction with other flags
+  2097152  C  Copy On Write
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
 executable (but see L<Devel::Peek>, L<re> which may change this).
diff --git a/sv.c b/sv.c
index 08cddb7644..54e7d03513 100644
--- a/sv.c
+++ b/sv.c
@@ -3930,11 +3930,12 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 #ifdef PERL_COPY_ON_WRITE
             /* Either it's a shared hash key, or it's suitable for
                copy-on-write or we can swipe the string.  */
-#ifdef DEBUG_COW
-            PerlIO_printf(PerlIO_stderr(),"sstr --> dstr\n");
+            if (DEBUG_C_TEST) {
+                PerlIO_printf(Perl_debug_log,
+                              "Copy on write: sstr --> dstr\n");
                 Perl_sv_dump(sstr);
                 Perl_sv_dump(dstr);
-#endif
+            }
             if (!isSwipe) {
                 /* I believe I should acquire a global SV mutex if
                    it's a COW sv (not a shared hash key) to stop
@@ -3977,9 +3978,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                 } else {
                     /* SvIsCOW_shared_hash */
                     UV hash = SvUVX(sstr);
-#ifdef DEBUG_COW
-                    PerlIO_printf(PerlIO_stderr(), "Sharing hash\n");
-#endif
+                    DEBUG_C(PerlIO_printf(Perl_debug_log,
+                                          "Copy on write: Sharing hash\n"));
                     SvPV_set(dstr,
                              sharepvn(SvPVX(sstr),
                                       (sflags & SVf_UTF8?-cur:cur), hash));
@@ -4298,10 +4298,12 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
             STRLEN cur = SvCUR(sv);
             U32 hash = SvUVX(sv);
             SV *next = SV_COW_NEXT_SV(sv);   /* next COW sv in the loop. */
-#ifdef DEBUG_COW
-        PerlIO_printf(PerlIO_stderr(), "Force normal %ld\n", flags);
-        Perl_sv_dump(sv);
-#endif
+            if (DEBUG_C_TEST) {
+                PerlIO_printf(Perl_debug_log,
+                              "Copy on write: Force normal %ld\n",
+                              (long) flags);
+                Perl_sv_dump(sv);
+            }
             SvFAKE_off(sv);
             SvREADONLY_off(sv);
             /* This SV doesn't own the buffer, so need to New() a new one:  */
@@ -4317,9 +4319,9 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
                 *SvEND(sv) = '\0';
             }
             S_sv_release_COW(sv, pvx, cur, len, hash, next);
-#ifdef DEBUG_COW
-        Perl_sv_dump(sv);
-#endif
+            if (DEBUG_C_TEST) {
+                Perl_sv_dump(sv);
+            }
 	}
 	else if (PL_curcop != &PL_compiling)
 	    Perl_croak(aTHX_ PL_no_modify);
@@ -5219,10 +5221,10 @@ Perl_sv_clear(pTHX_ register SV *sv)
             if (SvIsCOW(sv)) {
                 /* I believe I need to grab the global SV mutex here and
                    then recheck the COW status.  */
-#ifdef DEBUG_COW
-        PerlIO_printf(PerlIO_stderr(), "Clear\n");
-        Perl_sv_dump(sv);
-#endif
+                if (DEBUG_C_TEST) {
+                    PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
+                    Perl_sv_dump(sv);
+                }
                 S_sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
                                  SvUVX(sv), SV_COW_NEXT_SV(sv));
                 /* And drop it here.  */
diff --git a/sv.h b/sv.h
index 3782cdf06d..da8c2755f3 100644
--- a/sv.h
+++ b/sv.h
@@ -556,27 +556,16 @@ Set the length of the string which is in the SV.  See C<SvCUR>.
 
 #define SvOKp(sv)		(SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK))
 #define SvIOKp(sv)		(SvFLAGS(sv) & SVp_IOK)
-#ifdef PERL_COPY_ON_WRITE
-#define SvRELEASE_IVX(sv)   ((SvFLAGS(sv) & (SVf_OOK|SVf_READONLY|SVf_FAKE)) \
-				&& sv_release_IVX(sv))
-#define SvIOKp_on(sv)		((void)sv_release_IVX(sv), \
+#define SvIOKp_on(sv)		(SvRELEASE_IVX(sv), \
 				    SvFLAGS(sv) |= SVp_IOK)
-#else
-#define SvIOKp_on(sv)		((void)SvOOK_off(sv), SvFLAGS(sv) |= SVp_IOK)
-#endif
 #define SvNOKp(sv)		(SvFLAGS(sv) & SVp_NOK)
 #define SvNOKp_on(sv)		(SvFLAGS(sv) |= SVp_NOK)
 #define SvPOKp(sv)		(SvFLAGS(sv) & SVp_POK)
 #define SvPOKp_on(sv)		(SvFLAGS(sv) |= SVp_POK)
 
 #define SvIOK(sv)		(SvFLAGS(sv) & SVf_IOK)
-#ifdef PERL_COPY_ON_WRITE
-#define SvIOK_on(sv)		((void)sv_release_IVX(sv), \
+#define SvIOK_on(sv)		(SvRELEASE_IVX(sv), \
 				    SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
-#else
-#define SvIOK_on(sv)		((void)SvOOK_off(sv), \
-				    SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
-#endif
 #define SvIOK_off(sv)		(SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK|SVf_IVisUV))
 #define SvIOK_only(sv)		((void)SvOK_off(sv), \
 				    SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
@@ -1077,23 +1066,30 @@ otherwise.
 
 #define SvIsCOW(sv)		((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
 				    (SVf_FAKE | SVf_READONLY))
+#define SvIsCOW_shared_hash(sv)	(SvIsCOW(sv) && SvLEN(sv) == 0)
 
 /* flag values for sv_*_flags functions */
 #define SV_IMMEDIATE_UNREF	1
 #define SV_GMAGIC		2
-
-#ifdef PERL_COPY_ON_WRITE
 #define SV_COW_DROP_PV		4
 
-#define SvIsCOW_shared_hash(sv)	(SvIsCOW(sv) && SvLEN(sv) == 0)
-#define SvIsCOW_normal(sv)	(SvIsCOW(sv) && SvLEN(sv))
+/* We are about to replace the SV's current value. So if it's copy on write
+   we need to normalise it. Use the SV_COW_DROP_PV flag hint to say that
+   the value is about to get thrown away, so drop the PV rather than go to
+   the effort of making a read-write copy only for it to get immediately
+   discarded.  */
 
 #define SV_CHECK_THINKFIRST_COW_DROP(sv) if (SvTHINKFIRST(sv)) \
 				    sv_force_normal_flags(sv, SV_COW_DROP_PV)
+
+#ifdef PERL_COPY_ON_WRITE
+#  define SvRELEASE_IVX(sv)   ((void)((SvFLAGS(sv) & (SVf_OOK|SVf_READONLY|SVf_FAKE)) \
+				&& sv_release_IVX(sv)))
+#  define SvIsCOW_normal(sv)	(SvIsCOW(sv) && SvLEN(sv))
 #else
-#define SV_CHECK_THINKFIRST_COW_DROP(sv) if (SvTHINKFIRST(sv)) \
-				    sv_force_normal_flags(sv, 0)
+#  define SvRELEASE_IVX(sv)   ((void)SvOOK_off(sv))
 #endif /* PERL_COPY_ON_WRITE */
+
 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \
 				    sv_force_normal_flags(sv, 0)