From: Nicholas Clark Date: Mon, 7 Apr 2008 14:45:33 +0000 (+0000) Subject: Split out S_refcounted_he_new_common() from X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=012da8e581e60270322b8deba22fdfab9df5db1b;p=p5sagit%2Fp5-mst-13.2.git Split out S_refcounted_he_new_common() from Perl_refcounted_he_new_common(), so that Perl_store_cop_label() can call it without needing to create two temporary SVs. Use it in newSTATEOP() and eliminate the two temporary SVs. Make Perl_fetch_cop_label() more defensive by not assuming that the value for ":" is always a PV. Remove its "compatibility" macro. p4raw-id: //depot/perl@33657 --- diff --git a/embed.fnc b/embed.fnc index 316cfe5..a536cb7 100644 --- a/embed.fnc +++ b/embed.fnc @@ -344,6 +344,14 @@ dpoM |void |refcounted_he_free|NULLOK struct refcounted_he *he XEdpoM |struct refcounted_he *|refcounted_he_new \ |NULLOK struct refcounted_he *const parent \ |NULLOK SV *const key|NULLOK SV *const value +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +s |struct refcounted_he * |refcounted_he_new_common \ + |NULLOK struct refcounted_he *const parent \ + |NN const char *const key_p \ + |const STRLEN key_len|const char flags \ + |char value_type|NN const void *value \ + |const STRLEN value_len +#endif Abmd |SV** |hv_store |NULLOK HV *hv|NULLOK const char *key \ |I32 klen|NULLOK SV *val|U32 hash Abmd |HE* |hv_store_ent |NULLOK HV *hv|NULLOK SV *key|NULLOK SV *val\ @@ -1979,8 +1987,10 @@ p |void |boot_core_mro Apon |void |sys_init |NN int* argc|NN char*** argv Apon |void |sys_init3 |NN int* argc|NN char*** argv|NN char*** env Apon |void |sys_term -ApM |const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \ +ApoM |const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \ |NULLOK STRLEN *len|NULLOK U32 *flags +ApoM |struct refcounted_he *|store_cop_label \ + |NULLOK struct refcounted_he *const chain|NN const char *label END_EXTERN_C /* diff --git a/embed.h b/embed.h index 117da37..cb2a66d 100644 --- a/embed.h +++ b/embed.h @@ -295,6 +295,11 @@ #define hv_iternext_flags Perl_hv_iternext_flags #define hv_iterval Perl_hv_iterval #define hv_ksplit Perl_hv_ksplit +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define refcounted_he_new_common S_refcounted_he_new_common +#endif +#endif #define hv_undef Perl_hv_undef #define ibcmp Perl_ibcmp #define ibcmp_locale Perl_ibcmp_locale @@ -1934,7 +1939,6 @@ #ifdef PERL_CORE #define boot_core_mro Perl_boot_core_mro #endif -#define fetch_cop_label Perl_fetch_cop_label #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_chdir Perl_ck_chdir @@ -2603,6 +2607,11 @@ #endif #if defined(PERL_CORE) || defined(PERL_EXT) #endif +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define refcounted_he_new_common(a,b,c,d,e,f,g) S_refcounted_he_new_common(aTHX_ a,b,c,d,e,f,g) +#endif +#endif #define hv_undef(a) Perl_hv_undef(aTHX_ a) #define ibcmp(a,b,c) Perl_ibcmp(aTHX_ a,b,c) #define ibcmp_locale(a,b,c) Perl_ibcmp_locale(aTHX_ a,b,c) @@ -4254,7 +4263,6 @@ #ifdef PERL_CORE #define boot_core_mro() Perl_boot_core_mro(aTHX) #endif -#define fetch_cop_label(a,b,c) Perl_fetch_cop_label(aTHX_ a,b,c) #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_chdir(a) Perl_ck_chdir(aTHX_ a) diff --git a/hv.c b/hv.c index 98cdc31..6b54681 100644 --- a/hv.c +++ b/hv.c @@ -2751,21 +2751,18 @@ struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value) { dVAR; - struct refcounted_he *he; STRLEN key_len; const char *key_p = SvPV_const(key, key_len); STRLEN value_len = 0; const char *value_p = NULL; char value_type; char flags; - STRLEN key_offset; - U32 hash; bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; if (SvPOK(value)) { value_type = HVrhek_PV; } else if (SvIOK(value)) { - value_type = HVrhek_IV; + value_type = SvUOK((SV*)value) ? HVrhek_UV : HVrhek_IV; } else if (value == &PL_sv_placeholder) { value_type = HVrhek_delete; } else if (!SvOK(value)) { @@ -2775,12 +2772,41 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, } if (value_type == HVrhek_PV) { + /* Do it this way so that the SvUTF8() test is after the SvPV, in case + the value is overloaded, and doesn't yet have the UTF-8flag set. */ value_p = SvPV_const(value, value_len); - key_offset = value_len + 2; - } else { - value_len = 0; - key_offset = 1; + if (SvUTF8(value)) + value_type = HVrhek_PV_UTF8; } + flags = value_type; + + if (is_utf8) { + /* Hash keys are always stored normalised to (yes) ISO-8859-1. + As we're going to be building hash keys from this value in future, + normalise it now. */ + key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); + flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; + } + + return refcounted_he_new_common(parent, key_p, key_len, flags, value_type, + ((value_type == HVrhek_PV + || value_type == HVrhek_PV_UTF8) ? + (void *)value_p : (void *)value), + value_len); +} + +struct refcounted_he * +S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, + const char *const key_p, const STRLEN key_len, + const char flags, char value_type, + const void *value, const STRLEN value_len) { + dVAR; + struct refcounted_he *he; + U32 hash; + const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8; + STRLEN key_offset = is_pv ? value_len + 2 : 1; + + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON; #ifdef USE_ITHREADS he = (struct refcounted_he*) @@ -2793,33 +2819,17 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, + key_offset); #endif - he->refcounted_he_next = parent; - if (value_type == HVrhek_PV) { - Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); + if (is_pv) { + Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char); he->refcounted_he_val.refcounted_he_u_len = value_len; - /* Do it this way so that the SvUTF8() test is after the SvPV, in case - the value is overloaded, and doesn't yet have the UTF-8flag set. */ - if (SvUTF8(value)) - value_type = HVrhek_PV_UTF8; } else if (value_type == HVrhek_IV) { - if (SvUOK(value)) { - he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); - value_type = HVrhek_UV; - } else { - he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); - } + he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); + } else if (value_type == HVrhek_UV) { + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); } - flags = value_type; - if (is_utf8) { - /* Hash keys are always stored normalised to (yes) ISO-8859-1. - As we're going to be building hash keys from this value in future, - normalise it now. */ - key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); - flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; - } PERL_HASH(hash, key_p, key_len); #ifdef USE_ITHREADS @@ -2894,6 +2904,12 @@ Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, if (*HEK_KEY(chain->refcounted_he_hek) != ':') return NULL; #endif + /* Stop anyone trying to really mess us up by adding their own value for + ':' into %^H */ + if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV + && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8) + return NULL; + if (len) *len = chain->refcounted_he_val.refcounted_he_u_len; if (flags) { @@ -2903,6 +2919,16 @@ Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, return chain->refcounted_he_data + 1; } +/* As newSTATEOP currently gets passed plain char* labels, we will only provide + that interface. Once it works out how to pass in length and UTF-8 ness, this + function will need superseding. */ +struct refcounted_he * +Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label) +{ + return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV, + label, strlen(label)); +} + /* =for apidoc hv_assert diff --git a/op.c b/op.c index 3997fac..11b29d8 100644 --- a/op.c +++ b/op.c @@ -4380,20 +4380,14 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) HINTS_REFCNT_UNLOCK; } if (label) { - /* Proof of concept for now - for efficiency reasons these are likely - to end up being replaced by a custom function in hv.c */ - SV *const key = newSVpvs(":"); - SV *const value = newSVpv(label, 0); cop->cop_hints_hash - = Perl_refcounted_he_new(aTHX_ cop->cop_hints_hash, key, value); + = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label); PL_hints |= HINT_BLOCK_SCOPE; /* It seems that we need to defer freeing this pointer, as other parts of the grammar end up wanting to copy it after this op has been created. */ SAVEFREEPV(label); - SvREFCNT_dec(key); - SvREFCNT_dec(value); } if (PL_parser && PL_parser->copline == NOLINE) diff --git a/pod/perltodo.pod b/pod/perltodo.pod index 35ee02a..227fd6b 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -720,28 +720,6 @@ also the warning messages (see L, C). These tasks would need C knowledge, and knowledge of how the interpreter works, or a willingness to learn. -=head2 Abolish cop_label? - -C contains - - char * cop_label; /* label for this construct */ - -Most statements don't have labels. It might be possible to eliminate this -member and instead store the label, if present, in - - struct refcounted_he * cop_hints_hash; - -(with a hint bit, similar to - - #define HINT_ARYBASE 0x00000010 /* $[ is non-zero */ - #define HINT_LEXICAL_IO_IN 0x00040000 /* ${^OPEN} is set for input */ - #define HINT_LEXICAL_IO_OUT 0x00080000 /* ${^OPEN} is set for output */ - -). The trick would be ensuring that this faked lexical hint doesn't get -propagated to nested scopes. It might be as simple as moving the setting of -"cop_label" in C after the code to set up -Ccop_hints_hash>. - =head2 lexicals used only once This warns: diff --git a/proto.h b/proto.h index 6773000..603d526 100644 --- a/proto.h +++ b/proto.h @@ -1067,6 +1067,14 @@ PERL_CALLCONV HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he PERL_CALLCONV SV * Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, const char *key, STRLEN klen, int flags, U32 hash); PERL_CALLCONV void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he); PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value); +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +STATIC struct refcounted_he * S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, const char *const key_p, const STRLEN key_len, const char flags, char value_type, const void *value, const STRLEN value_len) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_6); +#define PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON \ + assert(key_p); assert(value) + +#endif /* PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash); */ /* PERL_CALLCONV HE* Perl_hv_store_ent(pTHX_ HV *hv, SV *key, SV *val, U32 hash); */ /* PERL_CALLCONV SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, int flags); */ @@ -6567,6 +6575,11 @@ PERL_CALLCONV void Perl_sys_init3(int* argc, char*** argv, char*** env) PERL_CALLCONV void Perl_sys_term(void); PERL_CALLCONV const char * Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, U32 *flags); +PERL_CALLCONV struct refcounted_he * Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_STORE_COP_LABEL \ + assert(label) + END_EXTERN_C /*