From: Nicholas Clark Date: Sun, 18 Aug 2002 23:17:01 +0000 (+0100) Subject: Clean up copy-on-write macros and debug facilities (new flag 'C'). X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=46187eeb6d9336144ec364973ed57177c89816cf;p=p5sagit%2Fp5-mst-13.2.git 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 --- diff --git a/hv.c b/hv.c index 6d8461f..0d08767 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 224cc9c..58e2ac1 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 5c13a7d..0943e2f 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 3c1f159..ee80d38 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, L which may change this). diff --git a/sv.c b/sv.c index 08cddb7..54e7d03 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 3782cdf..da8c275 100644 --- a/sv.h +++ b/sv.h @@ -556,27 +556,16 @@ Set the length of the string which is in the SV. See C. #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)