Change 17740 by [EMAIL PROTECTED] on 2002/08/20 14:07:56
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?
From: Nicholas Clark <[EMAIL PROTECTED]>
Date: Sun, 18 Aug 2002 23:17:01 +0100
Message-id: <[EMAIL PROTECTED]>
Affected files ...
.... //depot/perl/hv.c#118 edit
.... //depot/perl/perl.c#446 edit
.... //depot/perl/perl.h#468 edit
.... //depot/perl/pod/perlrun.pod#66 edit
.... //depot/perl/sv.c#577 edit
.... //depot/perl/sv.h#120 edit
Differences ...
==== //depot/perl/hv.c#118 (text) ====
Index: perl/hv.c
--- perl/hv.c#117~16656~ Fri May 17 09:52:15 2002
+++ perl/hv.c Tue Aug 20 07:07:56 2002
@@ -409,8 +409,13 @@
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 @@
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) */,
==== //depot/perl/perl.c#446 (text) ====
Index: perl/perl.c
--- perl/perl.c#445~17718~ Mon Aug 12 04:57:17 2002
+++ perl/perl.c Tue Aug 20 07:07:56 2002
@@ -2338,7 +2338,7 @@
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++)
==== //depot/perl/perl.h#468 (text) ====
Index: perl/perl.h
--- perl/perl.h#467~17718~ Mon Aug 12 04:57:17 2002
+++ perl/perl.h Tue Aug 20 07:07:56 2002
@@ -2430,7 +2430,8 @@
#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 @@
# 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 @@
# 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 @@
# 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 @@
# 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 @@
# define DEBUG_T(a)
# define DEBUG_R(a)
# define DEBUG_v(a)
+# define DEBUG_C(a)
#endif /* DEBUGGING */
==== //depot/perl/pod/perlrun.pod#66 (text) ====
Index: perl/pod/perlrun.pod
--- perl/pod/perlrun.pod#65~17737~ Mon Aug 19 00:48:39 2002
+++ perl/pod/perlrun.pod Tue Aug 20 07:07:56 2002
@@ -329,6 +329,7 @@
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).
==== //depot/perl/sv.c#577 (text) ====
Index: perl/sv.c
--- perl/sv.c#576~17728~ Fri Aug 16 19:07:24 2002
+++ perl/sv.c Tue Aug 20 07:07:56 2002
@@ -3930,11 +3930,12 @@
#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 @@
} 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 @@
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 @@
*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 @@
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. */
==== //depot/perl/sv.h#120 (text) ====
Index: perl/sv.h
--- perl/sv.h#119~17728~ Fri Aug 16 19:07:24 2002
+++ perl/sv.h Tue Aug 20 07:07:56 2002
@@ -556,27 +556,16 @@
#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 @@
#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)
End of Patch.
