Change 33657 by [EMAIL PROTECTED] on 2008/04/07 14:45:33
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.
Affected files ...
... //depot/perl/embed.fnc#610 edit
... //depot/perl/embed.h#757 edit
... //depot/perl/globvar.sym#13 edit
... //depot/perl/hv.c#373 edit
... //depot/perl/op.c#998 edit
... //depot/perl/pod/perltodo.pod#217 edit
... //depot/perl/proto.h#945 edit
Differences ...
==== //depot/perl/embed.fnc#610 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#609~33656~ 2008-04-07 04:29:51.000000000 -0700
+++ perl/embed.fnc 2008-04-07 07:45:33.000000000 -0700
@@ -344,6 +344,14 @@
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 @@
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
/*
==== //depot/perl/embed.h#757 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#756~33656~ 2008-04-07 04:29:51.000000000 -0700
+++ perl/embed.h 2008-04-07 07:45:33.000000000 -0700
@@ -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)
==== //depot/perl/hv.c#373 (text) ====
Index: perl/hv.c
--- perl/hv.c#372~33656~ 2008-04-07 04:29:51.000000000 -0700
+++ perl/hv.c 2008-04-07 07:45:33.000000000 -0700
@@ -2751,21 +2751,18 @@
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,13 +2772,42 @@
}
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*)
PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
@@ -2793,33 +2819,17 @@
+ 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 @@
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 @@
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
==== //depot/perl/op.c#998 (text) ====
Index: perl/op.c
--- perl/op.c#997~33656~ 2008-04-07 04:29:51.000000000 -0700
+++ perl/op.c 2008-04-07 07:45:33.000000000 -0700
@@ -4380,20 +4380,14 @@
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)
==== //depot/perl/pod/perltodo.pod#217 (text) ====
Index: perl/pod/perltodo.pod
--- perl/pod/perltodo.pod#216~33652~ 2008-04-06 12:32:03.000000000 -0700
+++ perl/pod/perltodo.pod 2008-04-07 07:45:33.000000000 -0700
@@ -720,28 +720,6 @@
These tasks would need C knowledge, and knowledge of how the interpreter works,
or a willingness to learn.
-=head2 Abolish cop_label?
-
-C<struct cop> 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<Perl_newSTATEOP> after the code to set up
-C<cop->cop_hints_hash>.
-
=head2 lexicals used only once
This warns:
==== //depot/perl/proto.h#945 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#944~33656~ 2008-04-07 04:29:51.000000000 -0700
+++ perl/proto.h 2008-04-07 07:45:33.000000000 -0700
@@ -1067,6 +1067,14 @@
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_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
/*
End of Patch.
