/*
=head1 Hash Manipulation Functions
-
A HV structure represents a Perl hash. It consists mainly of an array
of pointers, each of which points to a linked list of HE structures. The
array is indexed by the hash function of the key, so each linked list
#include "perl.h"
#define DO_HSPLIT(xhv) ((xhv)->xhv_keys > (xhv)->xhv_max) /* HvTOTALKEYS(hv) > HvMAX(hv) */
+#define HV_FILL_THRESHOLD 31
static const char S_strtab_error[]
= "Cannot modify shared string table in hv_%s";
STATIC HE*
S_new_he(pTHX)
{
- dVAR;
HE* he;
void ** const root = &PL_body_roots[HE_SVSLOT];
void
Perl_free_tied_hv_pool(pTHX)
{
- dVAR;
HE *he = PL_hv_fetch_ent_mh;
while (he) {
HE * const ohe = he;
bool is_utf8;
int masked_flags;
const int return_svp = action & HV_FETCH_JUST_SV;
+ HEK *keysv_hek = NULL;
if (!hv)
return NULL;
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
if (needs_copy) {
- const bool save_taint = TAINT_get; /* Unused var warning under NO_TAINT_SUPPORT */
+ const bool save_taint = TAINT_get;
if (keysv || is_utf8) {
if (!keysv) {
keysv = newSVpvn_utf8(key, klen, TRUE);
}
TAINT_IF(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
if (!needs_store) {
if (flags & HVhek_FREEKEY)
Safefree(key);
}
}
- if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv)))
- hash = SvSHARED_HASH(keysv);
- else
- PERL_HASH(hash, key, klen);
+ if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ if (HvSHAREKEYS(hv))
+ keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
+ hash = SvSHARED_HASH(keysv);
}
+ else if (!hash)
+ PERL_HASH(hash, key, klen);
masked_flags = (flags & HVhek_MASK);
{
entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
}
+
+ if (!entry)
+ goto not_found;
+
+ if (keysv_hek) {
+ /* keysv is actually a HEK in disguise, so we can match just by
+ * comparing the HEK pointers in the HE chain. There is a slight
+ * caveat: on something like "\x80", which has both plain and utf8
+ * representations, perl's hashes do encoding-insensitive lookups,
+ * but preserve the encoding of the stored key. Thus a particular
+ * key could map to two different HEKs in PL_strtab. We only
+ * conclude 'not found' if all the flags are the same; otherwise
+ * we fall back to a full search (this should only happen in rare
+ * cases).
+ */
+ int keysv_flags = HEK_FLAGS(keysv_hek);
+ HE *orig_entry = entry;
+
+ for (; entry; entry = HeNEXT(entry)) {
+ HEK *hek = HeKEY_hek(entry);
+ if (hek == keysv_hek)
+ goto found;
+ if (HEK_FLAGS(hek) != keysv_flags)
+ break; /* need to do full match */
+ }
+ if (!entry)
+ goto not_found;
+ /* failed on shortcut - do full search loop */
+ entry = orig_entry;
+ }
+
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != (I32)klen)
continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
continue;
+ found:
if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
if (HeKFLAGS(entry) != masked_flags) {
/* We match if HVhek_UTF8 bit in our flags and hash key's
}
return entry;
}
+
+ not_found:
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (!(action & HV_FETCH_ISSTORE)
&& SvRMAGICAL((const SV *)hv)
recursive call would call the key conversion routine again.
However, as we replace the original key with the converted
key, this would result in a double conversion, which would show
- up as a bug if the conversion routine is not idempotent. */
+ up as a bug if the conversion routine is not idempotent.
+ Hence the use of HV_DISABLE_UVAR_XKEY. */
return hv_common(hv, keysv, key, klen, flags,
HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
val, hash);
HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
HeVAL(entry) = val;
+ if (!*oentry && SvOOK(hv)) {
+ /* initial entry, and aux struct present. */
+ struct xpvhv_aux *const aux = HvAUX(hv);
+ if (aux->xhv_fill_lazy)
+ ++aux->xhv_fill_lazy;
+ }
+
+#ifdef PERL_HASH_RANDOMIZE_KEYS
/* This logic semi-randomizes the insert order in a bucket.
* Either we insert into the top, or the slot below the top,
* making it harder to see if there is a collision. We also
* reset the iterator randomizer if there is one.
*/
- PL_hash_rand_bits += (PTRV)entry ^ hash; /* we don't bother to use ptr_hash here */
- if ( !*oentry || (PL_hash_rand_bits & 1) ) {
+ if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
+ PL_hash_rand_bits++;
+ PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
+ if ( PL_hash_rand_bits & 1 ) {
+ HeNEXT(entry) = HeNEXT(*oentry);
+ HeNEXT(*oentry) = entry;
+ } else {
+ HeNEXT(entry) = *oentry;
+ *oentry = entry;
+ }
+ } else
+#endif
+ {
HeNEXT(entry) = *oentry;
*oentry = entry;
- } else {
- HeNEXT(entry) = HeNEXT(*oentry);
- HeNEXT(*oentry) = entry;
}
- PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
+#ifdef PERL_HASH_RANDOMIZE_KEYS
if (SvOOK(hv)) {
/* Currently this makes various tests warn in annoying ways.
* So Silenced for now. - Yves | bogus end of comment =>* /
pTHX__VALUE);
}
*/
+ if (PL_HASH_RAND_BITS_ENABLED) {
+ if (PL_HASH_RAND_BITS_ENABLED == 1)
+ PL_hash_rand_bits += (PTRV)entry + 1; /* we don't bother to use ptr_hash here */
+ PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
+ }
HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
}
+#endif
if (val == &PL_sv_placeholder)
HvPLACEHOLDERS(hv)++;
/*
=for apidoc hv_scalar
-Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
+Evaluates the hash in scalar context and returns the result. Handles magic
+when the hash is tied.
=cut
*/
XPVHV* xhv;
HE *entry;
HE **oentry;
+ HE **first_entry;
bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
int masked_flags;
+ HEK *keysv_hek = NULL;
+ U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
+ SV *sv;
+ GV *gv = NULL;
+ HV *stash = NULL;
if (SvRMAGICAL(hv)) {
bool needs_copy;
HvHASKFLAGS_on(MUTABLE_SV(hv));
}
- if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv)))
- hash = SvSHARED_HASH(keysv);
- else
- PERL_HASH(hash, key, klen);
+ if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ if (HvSHAREKEYS(hv))
+ keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
+ hash = SvSHARED_HASH(keysv);
}
+ else if (!hash)
+ PERL_HASH(hash, key, klen);
masked_flags = (k_flags & HVhek_MASK);
- oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
+ first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
entry = *oentry;
- for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
- SV *sv;
- U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
- GV *gv = NULL;
- HV *stash = NULL;
+ if (!entry)
+ goto not_found;
+
+ if (keysv_hek) {
+ /* keysv is actually a HEK in disguise, so we can match just by
+ * comparing the HEK pointers in the HE chain. There is a slight
+ * caveat: on something like "\x80", which has both plain and utf8
+ * representations, perl's hashes do encoding-insensitive lookups,
+ * but preserve the encoding of the stored key. Thus a particular
+ * key could map to two different HEKs in PL_strtab. We only
+ * conclude 'not found' if all the flags are the same; otherwise
+ * we fall back to a full search (this should only happen in rare
+ * cases).
+ */
+ int keysv_flags = HEK_FLAGS(keysv_hek);
+
+ for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
+ HEK *hek = HeKEY_hek(entry);
+ if (hek == keysv_hek)
+ goto found;
+ if (HEK_FLAGS(hek) != keysv_flags)
+ break; /* need to do full match */
+ }
+ if (!entry)
+ goto not_found;
+ /* failed on shortcut - do full search loop */
+ oentry = first_entry;
+ entry = *oentry;
+ }
+
+ for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != (I32)klen)
continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
continue;
+ found:
if (hv == PL_strtab) {
if (k_flags & HVhek_FREEKEY)
Safefree(key);
Safefree(key);
return NULL;
}
- if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))
- && !SvIsCOW(HeVAL(entry))) {
+ if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
hv_notallowed(k_flags, key, klen,
"Attempt to delete readonly key '%"SVf"' from"
" a restricted hash");
HvPLACEHOLDERS(hv)++;
else {
*oentry = HeNEXT(entry);
+ if(!*first_entry && SvOOK(hv)) {
+ /* removed last entry, and aux struct present. */
+ struct xpvhv_aux *const aux = HvAUX(hv);
+ if (aux->xhv_fill_lazy)
+ --aux->xhv_fill_lazy;
+ }
if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
else {
return sv;
}
+
+ not_found:
if (SvREADONLY(hv)) {
hv_notallowed(k_flags, key, klen,
"Attempt to delete disallowed key '%"SVf"' from"
return NULL;
}
+
STATIC void
S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
{
- dVAR;
STRLEN i = 0;
char *a = (char*) HvARRAY(hv);
HE **aep;
- PERL_ARGS_ASSERT_HSPLIT;
+ bool do_aux= (
+ /* already have an HvAUX(hv) so we have to move it */
+ SvOOK(hv) ||
+ /* no HvAUX() but array we are going to allocate is large enough
+ * there is no point in saving the space for the iterator, and
+ * speeds up later traversals. */
+ ( ( hv != PL_strtab ) && ( newsize >= PERL_HV_ALLOC_AUX_SIZE ) )
+ );
- /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
- (void*)hv, (int) oldsize);*/
+ PERL_ARGS_ASSERT_HSPLIT;
PL_nomemok = TRUE;
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
+ + (do_aux ? sizeof(struct xpvhv_aux) : 0), char);
+ PL_nomemok = FALSE;
if (!a) {
- PL_nomemok = FALSE;
return;
}
+
+#ifdef PERL_HASH_RANDOMIZE_KEYS
/* the idea of this is that we create a "random" value by hashing the address of
* the array, we then use the low bit to decide if we insert at the top, or insert
* second from top. After each such insert we rotate the hashed value. So we can
* use the same hashed value over and over, and in normal build environments use
* very few ops to do so. ROTL32() should produce a single machine operation. */
- PL_hash_rand_bits += ptr_hash((PTRV)a);
- PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
-
- if (SvOOK(hv)) {
+ if (PL_HASH_RAND_BITS_ENABLED) {
+ if (PL_HASH_RAND_BITS_ENABLED == 1)
+ PL_hash_rand_bits += ptr_hash((PTRV)a);
+ PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
+ }
+#endif
+ HvARRAY(hv) = (HE**) a;
+ HvMAX(hv) = newsize - 1;
+ /* before we zero the newly added memory, we
+ * need to deal with the aux struct that may be there
+ * or have been allocated by us*/
+ if (do_aux) {
struct xpvhv_aux *const dest
= (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
- Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
- /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
- dest->xhv_rand = (U32)PL_hash_rand_bits;
+ if (SvOOK(hv)) {
+ /* alread have an aux, copy the old one in place. */
+ Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
+ /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ dest->xhv_rand = (U32)PL_hash_rand_bits;
+#endif
+ /* For now, just reset the lazy fill counter.
+ It would be possible to update the counter in the code below
+ instead. */
+ dest->xhv_fill_lazy = 0;
+ } else {
+ /* no existing aux structure, but we allocated space for one
+ * so initialize it properly. This unrolls hv_auxinit() a bit,
+ * since we have to do the realloc anyway. */
+ /* first we set the iterator's xhv_rand so it can be copied into lastrand below */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ dest->xhv_rand = (U32)PL_hash_rand_bits;
+#endif
+ /* this is the "non realloc" part of the hv_auxinit() */
+ (void)hv_auxinit_internal(dest);
+ /* Turn on the OOK flag */
+ SvOOK_on(hv);
+ }
}
-
- PL_nomemok = FALSE;
+ /* now we can safely clear the second half */
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
- HvMAX(hv) = --newsize;
- HvARRAY(hv) = (HE**) a;
if (!HvTOTALKEYS(hv)) /* skip rest if no entries */
return;
+ newsize--;
aep = (HE**)a;
do {
HE **oentry = aep + i;
U32 j = (HeHASH(entry) & newsize);
if (j != (U32)i) {
*oentry = HeNEXT(entry);
- /* if the target cell is empty insert to top, otherwise
- * rotate the bucket rand 1 bit, and use the new low bit
- * to decide if we insert at top, or next from top.
- * IOW, we rotate only if we are dealing with colliding
- * elements. */
- if (!aep[j] || ((PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1)) & 1)) {
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
+ * insert to top, otherwise rotate the bucket rand 1 bit,
+ * and use the new low bit to decide if we insert at top,
+ * or next from top. IOW, we only rotate on a collision.*/
+ if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
+ PL_hash_rand_bits+= ROTL32(HeHASH(entry), 17);
+ PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
+ if (PL_hash_rand_bits & 1) {
+ HeNEXT(entry)= HeNEXT(aep[j]);
+ HeNEXT(aep[j])= entry;
+ } else {
+ /* Note, this is structured in such a way as the optimizer
+ * should eliminate the duplicated code here and below without
+ * us needing to explicitly use a goto. */
+ HeNEXT(entry) = aep[j];
+ aep[j] = entry;
+ }
+ } else
+#endif
+ {
+ /* see comment above about duplicated code */
HeNEXT(entry) = aep[j];
aep[j] = entry;
- } else {
- HeNEXT(entry)= HeNEXT(aep[j]);
- HeNEXT(aep[j])= entry;
}
}
else {
void
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
{
- dVAR;
XPVHV* xhv = (XPVHV*)SvANY(hv);
const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
I32 newsize;
}
}
+/* IMO this should also handle cases where hv_max is smaller than hv_keys
+ * as tied hashes could play silly buggers and mess us around. We will
+ * do the right thing during hv_store() afterwards, but still - Yves */
+#define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
+ /* Can we use fewer buckets? (hv_max is always 2^n-1) */ \
+ if (hv_max < PERL_HASH_DEFAULT_HvMAX) { \
+ hv_max = PERL_HASH_DEFAULT_HvMAX; \
+ } else { \
+ while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
+ hv_max = hv_max / 2; \
+ } \
+ HvMAX(hv) = hv_max; \
+} STMT_END
+
+
HV *
Perl_newHVhv(pTHX_ HV *ohv)
{
HE *entry;
const I32 riter = HvRITER_get(ohv);
HE * const eiter = HvEITER_get(ohv);
- STRLEN hv_fill = HvFILL(ohv);
+ STRLEN hv_keys = HvTOTALKEYS(ohv);
- /* Can we use fewer buckets? (hv_max is always 2^n-1) */
- while (hv_max && hv_max + 1 >= hv_fill * 2)
- hv_max = hv_max / 2;
- HvMAX(hv) = hv_max;
+ HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
hv_iterinit(ohv);
while ((entry = hv_iternext_flags(ohv, 0))) {
if (ohv) {
STRLEN hv_max = HvMAX(ohv);
- STRLEN hv_fill = HvFILL(ohv);
+ STRLEN hv_keys = HvTOTALKEYS(ohv);
HE *entry;
const I32 riter = HvRITER_get(ohv);
HE * const eiter = HvEITER_get(ohv);
ENTER;
SAVEFREESV(hv);
- while (hv_max && hv_max + 1 >= hv_fill * 2)
- hv_max = hv_max / 2;
- HvMAX(hv) = hv_max;
+ HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
hv_iterinit(ohv);
while ((entry = hv_iternext_flags(ohv, 0))) {
hv_magic(hv, NULL, PERL_MAGIC_hints);
return hv;
}
+#undef HV_SET_MAX_ADJUSTED_FOR_KEYS
/* like hv_free_ent, but returns the SV rather than freeing it */
STATIC SV*
S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
{
- dVAR;
SV *val;
PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
void
Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
{
- dVAR;
SV *val;
PERL_ARGS_ASSERT_HV_FREE_ENT;
void
Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
{
- dVAR;
-
PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
if (!entry)
/* not already placeholder */
if (HeVAL(entry) != &PL_sv_placeholder) {
if (HeVAL(entry)) {
- if (SvREADONLY(HeVAL(entry)) && !SvIsCOW(HeVAL(entry))) {
+ if (SvREADONLY(HeVAL(entry))) {
SV* const keysv = hv_iterkeysv(entry);
Perl_croak_nocontext(
"Attempt to delete readonly key '%"SVf"' from a restricted hash",
void
Perl_hv_clear_placeholders(pTHX_ HV *hv)
{
- dVAR;
const U32 items = (U32)HvPLACEHOLDERS_get(hv);
PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
if (--items == 0) {
/* Finished. */
- HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
- if (HvUSEDKEYS(hv) == 0)
+ I32 placeholders = HvPLACEHOLDERS_get(hv);
+ HvTOTALKEYS(hv) -= (IV)placeholders;
+ /* HvUSEDKEYS expanded */
+ if ((HvTOTALKEYS(hv) - placeholders) == 0)
HvHASKFLAGS_off(hv);
HvPLACEHOLDERS_set(hv, 0);
return;
} while (--i >= 0);
/* You can't get here, hence assertion should always fail. */
assert (items == 0);
- assert (0);
+ NOT_REACHED; /* NOTREACHED */
}
STATIC void
PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
- if (SvOOK(hv) && ((iter = HvAUX(hv)))
- && ((entry = iter->xhv_eiter)) )
- {
- /* the iterator may get resurrected after each
- * destructor call, so check each time */
- if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
- HvLAZYDEL_off(hv);
- hv_free_ent(hv, entry);
- /* warning: at this point HvARRAY may have been
- * re-allocated, HvMAX changed etc */
- }
- iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- iter->xhv_last_rand = iter->xhv_rand;
+ if (SvOOK(hv) && ((iter = HvAUX(hv)))) {
+ if ((entry = iter->xhv_eiter)) {
+ /* the iterator may get resurrected after each
+ * destructor call, so check each time */
+ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
+ HvLAZYDEL_off(hv);
+ hv_free_ent(hv, entry);
+ /* warning: at this point HvARRAY may have been
+ * re-allocated, HvMAX changed etc */
+ }
+ iter = HvAUX(hv); /* may have been realloced */
+ iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand;
+#endif
+ }
+ /* Reset any cached HvFILL() to "unknown". It's unlikely that anyone
+ will actually call HvFILL() on a hash under destruction, so it
+ seems pointless attempting to track the number of keys remaining.
+ But if they do, we want to reset it again. */
+ if (iter->xhv_fill_lazy)
+ iter->xhv_fill_lazy = 0;
}
if (!((XPVHV*)SvANY(hv))->xhv_keys)
void
Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
{
- dVAR;
XPVHV* xhv;
- const char *name;
- const bool save = !!SvREFCNT(hv);
+ bool save;
if (!hv)
return;
+ save = !!SvREFCNT(hv);
DEBUG_A(Perl_hv_assert(aTHX_ hv));
xhv = (XPVHV*)SvANY(hv);
if they will be freed anyway. */
/* note that the code following prior to hfreeentries is duplicated
* in sv_clear(), and changes here should be done there too */
- if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
+ if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) {
if (PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
- HEKf"'\n", HvNAME_HEK(hv)));
- (void)hv_delete(PL_stashcache, name,
- HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
- G_DISCARD
- );
+ HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
+ (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
}
hv_name_set(hv, NULL, 0, 0);
}
}
hfreeentries(hv);
if (SvOOK(hv)) {
- struct xpvhv_aux * const aux = HvAUX(hv);
struct mro_meta *meta;
+ const char *name;
- if ((name = HvENAME_get(hv))) {
+ if (HvENAME_get(hv)) {
if (PL_phase != PERL_PHASE_DESTRUCT)
mro_isa_changed_in(hv);
if (PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
- HEKf"'\n", HvENAME_HEK(hv)));
- (void)hv_delete(
- PL_stashcache, name,
- HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
- G_DISCARD
- );
+ HEKf"'\n", HEKfARG(HvENAME_HEK(hv))));
+ (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD);
}
}
/* If this call originated from sv_clear, then we must check for
* effective names that need freeing, as well as the usual name. */
name = HvNAME(hv);
- if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
+ if (flags & HV_NAME_SETALL ? !!HvAUX(hv)->xhv_name_u.xhvnameu_name : !!name) {
if (name && PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
- HEKf"'\n", HvNAME_HEK(hv)));
- (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
+ HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
+ (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
}
hv_name_set(hv, NULL, 0, flags);
}
- if((meta = aux->xhv_mro_meta)) {
+ if((meta = HvAUX(hv)->xhv_mro_meta)) {
if (meta->mro_linear_all) {
SvREFCNT_dec_NN(meta->mro_linear_all);
/* mro_linear_current is just acting as a shortcut pointer,
SvREFCNT_dec(meta->mro_linear_current);
SvREFCNT_dec(meta->mro_nextmethod);
SvREFCNT_dec(meta->isa);
+ SvREFCNT_dec(meta->super);
Safefree(meta);
- aux->xhv_mro_meta = NULL;
+ HvAUX(hv)->xhv_mro_meta = NULL;
}
- SvREFCNT_dec(aux->xhv_super);
- if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
+ if (!HvAUX(hv)->xhv_name_u.xhvnameu_name && ! HvAUX(hv)->xhv_backreferences)
SvFLAGS(hv) &= ~SVf_OOK;
}
if (!SvOOK(hv)) {
Safefree(HvARRAY(hv));
- xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
+ xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX; /* HvMAX(hv) = 7 (it's a normal hash) */
HvARRAY(hv) = 0;
}
/* if we're freeing the HV, the SvMAGIC field has been reused for
/*
=for apidoc hv_fill
-Returns the number of hash buckets that happen to be in use. This function is
+Returns the number of hash buckets that
+happen to be in use. This function is
wrapped by the macro C<HvFILL>.
-Previously this value was stored in the HV structure, rather than being
-calculated on demand.
+Previously this value was always stored in the HV structure, which created an
+overhead on every hash (and pretty much every object) for something that was
+rarely used. Now we calculate it on demand the first
+time that it is needed, and cache it if that calculation
+is going to be costly to repeat. The cached
+value is updated by insertions and deletions, but (currently) discarded if
+the hash is split.
=cut
*/
STRLEN
-Perl_hv_fill(pTHX_ HV const *const hv)
+Perl_hv_fill(pTHX_ HV *const hv)
{
STRLEN count = 0;
HE **ents = HvARRAY(hv);
+ struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : NULL;
PERL_ARGS_ASSERT_HV_FILL;
+ /* No keys implies no buckets used.
+ One key can only possibly mean one bucket used. */
+ if (HvTOTALKEYS(hv) < 2)
+ return HvTOTALKEYS(hv);
+
+#ifndef DEBUGGING
+ if (aux && aux->xhv_fill_lazy)
+ return aux->xhv_fill_lazy;
+#endif
+
if (ents) {
HE *const *const last = ents + HvMAX(hv);
count = last + 1 - ents;
--count;
} while (++ents <= last);
}
+ if (aux) {
+#ifdef DEBUGGING
+ if (aux->xhv_fill_lazy)
+ assert(aux->xhv_fill_lazy == count);
+#endif
+ aux->xhv_fill_lazy = count;
+ } else if (HvMAX(hv) >= HV_FILL_THRESHOLD) {
+ aux = hv_auxinit(hv);
+ aux->xhv_fill_lazy = count;
+ }
return count;
}
return (U32)u;
}
+static struct xpvhv_aux*
+S_hv_auxinit_internal(struct xpvhv_aux *iter) {
+ PERL_ARGS_ASSERT_HV_AUXINIT_INTERNAL;
+ iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand;
+#endif
+ iter->xhv_fill_lazy = 0;
+ iter->xhv_name_u.xhvnameu_name = 0;
+ iter->xhv_name_count = 0;
+ iter->xhv_backreferences = 0;
+ iter->xhv_mro_meta = NULL;
+ iter->xhv_aux_flags = 0;
+ return iter;
+}
+
static struct xpvhv_aux*
S_hv_auxinit(pTHX_ HV *hv) {
}
HvARRAY(hv) = (HE**)array;
SvOOK_on(hv);
- PL_hash_rand_bits += ptr_hash((PTRV)array);
- PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
iter = HvAUX(hv);
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ if (PL_HASH_RAND_BITS_ENABLED) {
+ /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
+ if (PL_HASH_RAND_BITS_ENABLED == 1)
+ PL_hash_rand_bits += ptr_hash((PTRV)array);
+ PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
+ }
iter->xhv_rand = (U32)PL_hash_rand_bits;
+#endif
} else {
iter = HvAUX(hv);
}
- iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- iter->xhv_last_rand = iter->xhv_rand;
- iter->xhv_name_u.xhvnameu_name = 0;
- iter->xhv_name_count = 0;
- iter->xhv_backreferences = 0;
- iter->xhv_mro_meta = NULL;
- iter->xhv_super = NULL;
- return iter;
+ return hv_auxinit_internal(iter);
}
/*
{
PERL_ARGS_ASSERT_HV_ITERINIT;
- /* FIXME: Are we not NULL, or do we croak? Place bets now! */
-
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
if (SvOOK(hv)) {
- struct xpvhv_aux * const iter = HvAUX(hv);
+ struct xpvhv_aux * iter = HvAUX(hv);
HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
hv_free_ent(hv, entry);
}
+ iter = HvAUX(hv); /* may have been reallocated */
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
iter->xhv_last_rand = iter->xhv_rand;
+#endif
} else {
hv_auxinit(hv);
}
PERL_ARGS_ASSERT_HV_RITER_P;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
return &(iter->xhv_riter);
}
PERL_ARGS_ASSERT_HV_EITER_P;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
return &(iter->xhv_eiter);
}
PERL_ARGS_ASSERT_HV_RITER_SET;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
if (SvOOK(hv)) {
iter = HvAUX(hv);
} else {
}
void
+Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
+ struct xpvhv_aux *iter;
+
+ PERL_ARGS_ASSERT_HV_RAND_SET;
+
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ if (SvOOK(hv)) {
+ iter = HvAUX(hv);
+ } else {
+ iter = hv_auxinit(hv);
+ }
+ iter->xhv_rand = new_xhv_rand;
+#else
+ Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
+#endif
+}
+
+void
Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
struct xpvhv_aux *iter;
PERL_ARGS_ASSERT_HV_EITER_SET;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
if (SvOOK(hv)) {
iter = HvAUX(hv);
} else {
/* The first elem may be null. */
if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
Safefree(name);
+ iter = HvAUX(hv); /* may been realloced */
spot = &iter->xhv_name_u.xhvnameu_name;
iter->xhv_name_count = 0;
}
}
else if (flags & HV_NAME_SETALL) {
unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
+ iter = HvAUX(hv); /* may been realloced */
spot = &iter->xhv_name_u.xhvnameu_name;
}
else {
PERL_HASH(hash, name, len);
if (aux->xhv_name_count) {
- HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
I32 count = aux->xhv_name_count;
- HEK **hekp = xhv_name + (count < 0 ? -count : count);
+ HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
+ HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
while (hekp-- > xhv_name)
+ {
+ assert(*hekp);
if (
(HEK_UTF8(*hekp) || (flags & SVf_UTF8))
? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
aux->xhv_name_count = -count;
return;
}
+ }
if (count < 0) aux->xhv_name_count--, count = -count;
else aux->xhv_name_count++;
Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
void
Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
{
- dVAR;
struct xpvhv_aux *aux;
PERL_ARGS_ASSERT_HV_ENAME_DELETE;
: (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
) {
unshare_hek_or_pvn(*victim, 0, 0, 0);
+ aux = HvAUX(hv); /* may been realloced */
if (count < 0) ++aux->xhv_name_count;
else --aux->xhv_name_count;
if (
AV **
Perl_hv_backreferences_p(pTHX_ HV *hv) {
- struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
-
PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
- PERL_UNUSED_CONTEXT;
-
- return &(iter->xhv_backreferences);
+ /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
+ {
+ struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
+ return &(iter->xhv_backreferences);
+ }
}
void
Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
set the placeholders keys (for restricted hashes) will be returned in addition
-to normal keys. By default placeholders are automatically skipped over.
+to normal keys. By default placeholders are automatically skipped over.
Currently a placeholder is implemented with a value that is
C<&PL_sv_placeholder>. Note that the implementation of placeholders and
restricted hashes may change, and the implementation currently is
PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
xhv = (XPVHV*)SvANY(hv);
if (!SvOOK(hv)) {
SvREFCNT_dec(HeVAL(entry));
Safefree(HeKEY_hek(entry));
del_HE(entry);
+ iter = HvAUX(hv); /* may been realloced */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
HvLAZYDEL_off(hv);
return NULL;
}
}
}
+
+#ifdef PERL_HASH_RANDOMIZE_KEYS
if (iter->xhv_last_rand != iter->xhv_rand) {
if (iter->xhv_riter != -1) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
pTHX__FORMAT
pTHX__VALUE);
}
+ iter = HvAUX(hv); /* may been realloced */
iter->xhv_last_rand = iter->xhv_rand;
}
+#endif
/* Skip the entire loop if the hash is empty. */
if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
/* There is no next one. End of the hash. */
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_last_rand = iter->xhv_rand;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
+#endif
break;
}
- entry = (HvARRAY(hv))[(iter->xhv_riter ^ iter->xhv_rand) & xhv->xhv_max];
+ entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
/* If we have an entry, but it's a placeholder, don't count it.
}
else {
iter->xhv_riter = -1;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
iter->xhv_last_rand = iter->xhv_rand;
+#endif
}
if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
hv_free_ent(hv, oldentry);
}
+ iter = HvAUX(hv); /* may been realloced */
iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
}
STATIC void
S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
{
- dVAR;
XPVHV* xhv;
HE *entry;
HE **oentry;
STATIC HEK *
S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
- dVAR;
HE *entry;
const int flags_masked = flags & HVhek_MASK;
const U32 hindex = hash & (I32) HvMAX(PL_strtab);
return HeKEY_hek(entry);
}
-I32 *
+SSize_t *
Perl_hv_placeholders_p(pTHX_ HV *hv)
{
- dVAR;
MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
I32
Perl_hv_placeholders_get(pTHX_ const HV *hv)
{
- dVAR;
MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
+ PERL_UNUSED_CONTEXT;
return mg ? mg->mg_len : 0;
}
void
Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
{
- dVAR;
MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
const char *keyend = keypv + keylen, *p;
STRLEN nonascii_count = 0;
for (p = keypv; p != keyend; p++) {
- U8 c = (U8)*p;
- if (c & 0x80) {
- if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
- (((U8)*p) & 0xc0) == 0x80))
+ if (! UTF8_IS_INVARIANT(*p)) {
+ if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
goto canonicalised_key;
+ }
nonascii_count++;
+ p++;
}
}
if (nonascii_count) {
keypv = q;
for (; p != keyend; p++, q++) {
U8 c = (U8)*p;
- *q = (char)
- ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
+ if (UTF8_IS_INVARIANT(c)) {
+ *q = (char) c;
+ }
+ else {
+ p++;
+ *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
+ }
}
}
flags &= ~REFCOUNTED_HE_KEY_UTF8;
const char *keyend = keypv + keylen, *p;
STRLEN nonascii_count = 0;
for (p = keypv; p != keyend; p++) {
- U8 c = (U8)*p;
- if (c & 0x80) {
- if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
- (((U8)*p) & 0xc0) == 0x80))
+ if (! UTF8_IS_INVARIANT(*p)) {
+ if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
goto canonicalised_key;
+ }
nonascii_count++;
+ p++;
}
}
if (nonascii_count) {
keypv = q;
for (; p != keyend; p++, q++) {
U8 c = (U8)*p;
- *q = (char)
- ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
+ if (UTF8_IS_INVARIANT(c)) {
+ *q = (char) c;
+ }
+ else {
+ p++;
+ *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
+ }
}
}
flags &= ~REFCOUNTED_HE_KEY_UTF8;
void
Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+#ifdef USE_ITHREADS
dVAR;
+#endif
PERL_UNUSED_CONTEXT;
while (he) {
struct refcounted_he *
Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
+ PERL_UNUSED_CONTEXT;
if (he) {
HINTS_REFCNT_LOCK;
he->refcounted_he_refcnt++;
struct refcounted_he *const chain = cop->cop_hints_hash;
PERL_ARGS_ASSERT_COP_FETCH_LABEL;
+ PERL_UNUSED_CONTEXT;
if (!chain)
return NULL;
/*
=for apidoc cop_store_label
-Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
+Save a label into a C<cop_hints_hash>.
+You need to set flags to C<SVf_UTF8>
for a utf-8 label.
=cut
https://perl5.git.perl.org / perl5.git / blobdiff