X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=a37b26edb7fcd121f6dcbe205b55838f051bec5e;hb=b6bbf3fa3e9accb3710d8c05e0e3b107baaa1fee;hp=4bc252ef1534b6b237489b639199d11e5c85bdb7;hpb=ac1e784a7c71679a70a1ebe3997559be19c92895;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index 4bc252e..a37b26e 100644 --- a/hv.c +++ b/hv.c @@ -1,7 +1,7 @@ /* hv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -33,17 +33,20 @@ holds the key and hash value. #define HV_MAX_LENGTH_BEFORE_SPLIT 14 +static const char S_strtab_error[] + = "Cannot modify shared string table in hv_%s"; + STATIC void S_more_he(pTHX) { + dVAR; HE* he; HE* heend; - New(54, he, PERL_ARENA_SIZE/sizeof(HE), HE); - HeNEXT(he) = PL_he_arenaroot; - PL_he_arenaroot = he; + + he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE); heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1]; - PL_he_root = ++he; + PL_body_roots[HE_SVSLOT] = he; while (he < heend) { HeNEXT(he) = (HE*)(he + 1); he++; @@ -51,48 +54,50 @@ S_more_he(pTHX) HeNEXT(he) = 0; } +#ifdef PURIFY + +#define new_HE() (HE*)safemalloc(sizeof(HE)) +#define del_HE(p) safefree((char*)p) + +#else + STATIC HE* S_new_he(pTHX) { + dVAR; HE* he; + void ** const root = &PL_body_roots[HE_SVSLOT]; + LOCK_SV_MUTEX; - if (!PL_he_root) + if (!*root) S_more_he(aTHX); - he = PL_he_root; - PL_he_root = HeNEXT(he); + he = *root; + *root = HeNEXT(he); UNLOCK_SV_MUTEX; return he; } -STATIC void -S_del_he(pTHX_ HE *p) -{ - LOCK_SV_MUTEX; - HeNEXT(p) = (HE*)PL_he_root; - PL_he_root = p; - UNLOCK_SV_MUTEX; -} - -#ifdef PURIFY - -#define new_HE() (HE*)safemalloc(sizeof(HE)) -#define del_HE(p) safefree((char*)p) +#define new_HE() new_he() +#define del_HE(p) \ + STMT_START { \ + LOCK_SV_MUTEX; \ + HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \ + PL_body_roots[HE_SVSLOT] = p; \ + UNLOCK_SV_MUTEX; \ + } STMT_END -#else -#define new_HE() new_he() -#define del_HE(p) del_he(p) #endif STATIC HEK * -S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) +S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) { const int flags_masked = flags & HVhek_MASK; char *k; register HEK *hek; - New(54, k, HEK_BASESIZE + len + 2, char); + Newx(k, HEK_BASESIZE + len + 2, char); hek = (HEK*)k; Copy(str, HEK_KEY(hek), len, char); HEK_KEY(hek)[len] = 0; @@ -105,31 +110,51 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) return hek; } -/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent +/* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent * for tied hashes */ void Perl_free_tied_hv_pool(pTHX) { - HE *ohe; + dVAR; HE *he = PL_hv_fetch_ent_mh; while (he) { + HE * const ohe = he; Safefree(HeKEY_hek(he)); - ohe = he; he = HeNEXT(he); del_HE(ohe); } - PL_hv_fetch_ent_mh = Nullhe; + PL_hv_fetch_ent_mh = NULL; } #if defined(USE_ITHREADS) +HEK * +Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) +{ + HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); + + PERL_UNUSED_ARG(param); + + if (shared) { + /* We already shared this hash key. */ + (void)share_hek_hek(shared); + } + else { + shared + = share_hek_flags(HEK_KEY(source), HEK_LEN(source), + HEK_HASH(source), HEK_FLAGS(source)); + ptr_table_store(PL_ptr_table, source, shared); + } + return shared; +} + HE * -Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) +Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) { HE *ret; if (!e) - return Nullhe; + return NULL; /* look for it in the table first */ ret = (HE*)ptr_table_fetch(PL_ptr_table, e); if (ret) @@ -142,13 +167,28 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); if (HeKLEN(e) == HEf_SVKEY) { char *k; - New(54, k, HEK_BASESIZE + sizeof(SV*), char); + Newx(k, HEK_BASESIZE + sizeof(SV*), char); HeKEY_hek(ret) = (HEK*)k; HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param)); } - else if (shared) - HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), - HeKFLAGS(e)); + else if (shared) { + /* This is hek_dup inlined, which seems to be important for speed + reasons. */ + HEK * const source = HeKEY_hek(e); + HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); + + if (shared) { + /* We already shared this hash key. */ + (void)share_hek_hek(shared); + } + else { + shared + = share_hek_flags(HEK_KEY(source), HEK_LEN(source), + HEK_HASH(source), HEK_FLAGS(source)); + ptr_table_store(PL_ptr_table, source, shared); + } + HeKEY_hek(ret) = shared; + } else HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), HeKFLAGS(e)); @@ -161,7 +201,7 @@ static void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg) { - SV *sv = sv_newmortal(); + SV * const sv = sv_newmortal(); if (!(flags & HVhek_FREEKEY)) { sv_setpvn(sv, key, klen); } @@ -229,11 +269,12 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) return hek ? &HeVAL(hek) : NULL; } +/* XXX This looks like an ideal candidate to inline */ SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash, int flags) { - HE *hek = hv_fetch_common (hv, NULL, key, klen, flags, + HE * const hek = hv_fetch_common (hv, NULL, key, klen, flags, (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); return hek ? &HeVAL(hek) : NULL; } @@ -267,6 +308,7 @@ information on how to use this function on tied hashes. =cut */ +/* XXX This looks like an ideal candidate to inline */ HE * Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) { @@ -328,8 +370,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) flags = 0; } hek = hv_fetch_common (hv, NULL, key, klen, flags, - HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0), - Nullsv, 0); + lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) : HV_FETCH_JUST_SV, + NULL, 0); return hek ? &HeVAL(hek) : NULL; } @@ -343,6 +385,7 @@ computed. =cut */ +/* XXX This looks like an ideal candidate to inline */ bool Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) { @@ -373,7 +416,7 @@ HE * Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) { return hv_fetch_common(hv, keysv, NULL, 0, 0, - (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash); + (lval ? HV_FETCH_LVALUE : 0), NULL, hash); } STATIC HE * @@ -382,7 +425,6 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, { dVAR; XPVHV* xhv; - U32 n_links; HE *entry; HE **oentry; SV *sv; @@ -390,12 +432,12 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int masked_flags; if (!hv) - return 0; + return NULL; if (keysv) { if (flags & HVhek_FREEKEY) Safefree(key); - key = SvPV(keysv, klen); + key = SvPV_const(keysv, klen); flags = 0; is_utf8 = (SvUTF8(keysv) != 0); } else { @@ -404,8 +446,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { - if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) - { + if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { sv = sv_newmortal(); @@ -429,10 +470,10 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, else { char *k; entry = new_HE(); - New(54, k, HEK_BASESIZE + sizeof(SV*), char); + Newx(k, HEK_BASESIZE + sizeof(SV*), char); HeKEY_hek(entry) = (HEK*)k; } - HeNEXT(entry) = Nullhe; + HeNEXT(entry) = NULL; HeSVKEY_set(entry, keysv); HeVAL(entry) = sv; sv_upgrade(sv, SVt_PVLV); @@ -453,13 +494,13 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (isLOWER(key[i])) { /* Would be nice if we had a routine to do the copy and upercase in a single pass through. */ - const char *nkey = strupr(savepvn(key,klen)); + const char * const nkey = strupr(savepvn(key,klen)); /* Note that this fetch is for nkey (the uppercased key) whereas the store is for key (the original) */ - entry = hv_fetch_common(hv, Nullsv, nkey, klen, + entry = hv_fetch_common(hv, NULL, nkey, klen, HVhek_FREEKEY, /* free nkey */ 0 /* non-LVAL fetch */, - Nullsv /* no value */, + NULL /* no value */, 0 /* compute hash */); if (!entry && (action & HV_FETCH_LVALUE)) { /* This call will free key if necessary. @@ -467,7 +508,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, call optimise. */ entry = hv_fetch_common(hv, keysv, key, klen, flags, HV_FETCH_ISSTORE, - NEWSV(61,0), hash); + newSV(0), hash); } else { if (flags & HVhek_FREEKEY) Safefree(key); @@ -479,10 +520,9 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } /* ISFETCH */ else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { - SV* svret; /* I don't understand why hv_exists_ent has svret and sv, whereas hv_exists only had one. */ - svret = sv_newmortal(); + SV * const svret = sv_newmortal(); sv = sv_newmortal(); if (keysv || is_utf8) { @@ -507,11 +547,11 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { /* XXX This code isn't UTF8 clean. */ - const char *keysave = key; + char * const keysave = (char * const)key; /* Will need to free this, so set FREEKEY flag. */ key = savepvn(key,klen); key = (const char*)strupr((char*)key); - is_utf8 = 0; + is_utf8 = FALSE; hash = 0; keysv = 0; @@ -542,10 +582,10 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } TAINT_IF(save_taint); - if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) { + if (!needs_store) { if (flags & HVhek_FREEKEY) Safefree(key); - return Nullhe; + return NULL; } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { @@ -554,7 +594,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Will need to free this, so set FREEKEY flag. */ key = savepvn(key,klen); key = (const char*)strupr((char*)key); - is_utf8 = 0; + is_utf8 = FALSE; hash = 0; keysv = 0; @@ -568,15 +608,18 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } /* ISSTORE */ } /* SvMAGICAL */ - if (!xhv->xhv_array /* !HvARRAY(hv) */) { + if (!HvARRAY(hv)) { if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) #endif - ) - Newz(503, xhv->xhv_array /* HvARRAY(hv) */, + ) { + char *array; + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), char); + HvARRAY(hv) = (HE**)array; + } #ifdef DYNAMIC_ENV_FETCH else if (action & HV_FETCH_ISEXISTS) { /* for an %ENV exists, if we do an insert it's by a recursive @@ -593,7 +636,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } if (is_utf8) { - const char *keysave = key; + char * const keysave = (char *)key; key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) flags |= HVhek_UTF8; @@ -616,24 +659,22 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, flags |= HVhek_REHASH; } else if (!hash) { if (keysv && (SvIsCOW_shared_hash(keysv))) { - hash = SvUVX(keysv); + hash = SvSHARED_HASH(keysv); } else { PERL_HASH(hash, key, klen); } } masked_flags = (flags & HVhek_MASK); - n_links = 0; #ifdef DYNAMIC_ENV_FETCH - if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*); + if (!HvARRAY(hv)) entry = NULL; else #endif { - /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; + entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; } - for (; entry; ++n_links, entry = HeNEXT(entry)) { + for (; entry; entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) @@ -653,11 +694,19 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Need to swap the key we have for a key with the flags we need. As keys are shared we can't just write to the flag, so we share the new one, unshare the old one. */ - HEK *new_hek = share_hek_flags(key, klen, hash, + HEK * const new_hek = share_hek_flags(key, klen, hash, masked_flags); unshare_hek (HeKEY_hek(entry)); HeKEY_hek(entry) = new_hek; } + else if (hv == PL_strtab) { + /* PL_strtab is usually the only hash without HvSHAREKEYS, + so putting this test here is cheap */ + if (flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, + action & HV_FETCH_LVALUE ? "fetch" : "store"); + } else HeKFLAGS(entry) = masked_flags; if (masked_flags & HVhek_ENABLEHVKFLAGS) @@ -679,7 +728,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, break; } /* LVAL fetch which actaully needs a store. */ - val = NEWSV(61,0); + val = newSV(0); HvPLACEHOLDERS(hv)--; } else { /* store */ @@ -704,7 +753,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (!(action & HV_FETCH_ISSTORE) && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { unsigned long len; - char *env = PerlEnv_ENVgetenv_len(key,&len); + const char * const env = PerlEnv_ENVgetenv_len(key,&len); if (env) { sv = newSVpvn(env,len); SvTAINTED_on(sv); @@ -715,7 +764,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #endif if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { - S_hv_notallowed(aTHX_ flags, key, klen, + hv_notallowed(flags, key, klen, "Attempt to access disallowed key '%"SVf"' in" " a restricted hash"); } @@ -726,7 +775,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return 0; } if (action & HV_FETCH_LVALUE) { - val = NEWSV(61,0); + val = newSV(0); if (SvMAGICAL(hv)) { /* At this point the old hv_fetch code would call to hv_store, which in turn might do some tied magic. So we need to make that @@ -741,22 +790,32 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Welcome to hv_store... */ - if (!xhv->xhv_array) { + if (!HvARRAY(hv)) { /* Not sure if we can get here. I think the only case of oentry being NULL is for %ENV with dynamic env fetch. But that should disappear with magic in the previous code. */ - Newz(503, xhv->xhv_array /* HvARRAY(hv) */, + char *array; + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), char); + HvARRAY(hv) = (HE**)array; } - oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; + oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max]; entry = new_HE(); /* share_hek_flags will do the free for us. This might be considered bad API design. */ if (HvSHAREKEYS(hv)) HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); + else if (hv == PL_strtab) { + /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting + this test here is cheap */ + if (flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, + action & HV_FETCH_LVALUE ? "fetch" : "store"); + } else /* gotta do the real thing */ HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); HeVAL(entry) = val; @@ -768,25 +827,37 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (masked_flags & HVhek_ENABLEHVKFLAGS) HvHASKFLAGS_on(hv); - xhv->xhv_keys++; /* HvKEYS(hv)++ */ - if (!n_links) { /* initial entry? */ - xhv->xhv_fill++; /* HvFILL(hv)++ */ - } else if ((xhv->xhv_keys > (IV)xhv->xhv_max) - || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) { - /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket - splits on a rehashed hash, as we're not going to split it again, - and if someone is lucky (evil) enough to get all the keys in one - list they could exhaust our memory as we repeatedly double the - number of buckets on every entry. Linear search feels a less worse - thing to do. */ - hsplit(hv); + { + const HE *counter = HeNEXT(entry); + + xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ + if (!counter) { /* initial entry? */ + xhv->xhv_fill++; /* HvFILL(hv)++ */ + } else if (xhv->xhv_keys > (IV)xhv->xhv_max) { + hsplit(hv); + } else if(!HvREHASH(hv)) { + U32 n_links = 1; + + while ((counter = HeNEXT(counter))) + n_links++; + + if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) { + /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit + bucket splits on a rehashed hash, as we're not going to + split it again, and if someone is lucky (evil) enough to + get all the keys in one list they could exhaust our memory + as we repeatedly double the number of buckets on every + entry. Linear search feels a less worse thing to do. */ + hsplit(hv); + } + } } return entry; } STATIC void -S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) +S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) { const MAGIC *mg = SvMAGIC(hv); *needs_copy = FALSE; @@ -794,10 +865,9 @@ S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) while (mg) { if (isUPPER(mg->mg_type)) { *needs_copy = TRUE; - switch (mg->mg_type) { - case PERL_MAGIC_tied: - case PERL_MAGIC_sig: + if (mg->mg_type == PERL_MAGIC_tied) { *needs_store = FALSE; + return; /* We've set all there is to set. */ } } mg = mg->mg_moremagic; @@ -815,13 +885,13 @@ Evaluates the hash in scalar context and returns the result. Handles magic when SV * Perl_hv_scalar(pTHX_ HV *hv) { - MAGIC *mg; SV *sv; - - if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) { - sv = magic_scalarpack(hv, mg); - return sv; - } + + if (SvRMAGICAL(hv)) { + MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied); + if (mg) + return magic_scalarpack(hv, mg); + } sv = sv_newmortal(); if (HvFILL((HV*)hv)) @@ -848,13 +918,14 @@ SV * Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) { STRLEN klen; - int k_flags = 0; + int k_flags; if (klen_i32 < 0) { klen = -klen_i32; - k_flags |= HVhek_UTF8; + k_flags = HVhek_UTF8; } else { klen = klen_i32; + k_flags = 0; } return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0); } @@ -870,6 +941,7 @@ precomputed hash value, or 0 to ask for it to be computed. =cut */ +/* XXX This looks like an ideal candidate to inline */ SV * Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) { @@ -882,20 +954,19 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, { dVAR; register XPVHV* xhv; - register I32 i; register HE *entry; register HE **oentry; - SV *sv; + HE *const *first_entry; bool is_utf8; int masked_flags; if (!hv) - return Nullsv; + return NULL; if (keysv) { if (k_flags & HVhek_FREEKEY) Safefree(key); - key = SvPV(keysv, klen); + key = SvPV_const(keysv, klen); k_flags = 0; is_utf8 = (SvUTF8(keysv) != 0); } else { @@ -908,9 +979,10 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, hv_magic_check (hv, &needs_copy, &needs_store); if (needs_copy) { + SV *sv; entry = hv_fetch_common(hv, keysv, key, klen, k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE, - Nullsv, hash); + NULL, hash); sv = entry ? HeVAL(entry) : NULL; if (sv) { if (SvMAGICAL(sv)) { @@ -922,7 +994,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, sv_unmagic(sv, PERL_MAGIC_tiedelem); return sv; } - return Nullsv; /* element cannot be deleted */ + return NULL; /* element cannot be deleted */ } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { @@ -941,12 +1013,12 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } } xhv = (XPVHV*)SvANY(hv); - if (!xhv->xhv_array /* !HvARRAY(hv) */) - return Nullsv; + if (!HvARRAY(hv)) + return NULL; if (is_utf8) { - const char *keysave = key; - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + const char * const keysave = key; + key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) k_flags |= HVhek_UTF8; @@ -967,7 +1039,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, PERL_HASH_INTERNAL(hash, key, klen); } else if (!hash) { if (keysv && (SvIsCOW_shared_hash(keysv))) { - hash = SvUVX(keysv); + hash = SvSHARED_HASH(keysv); } else { PERL_HASH(hash, key, klen); } @@ -975,11 +1047,10 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, masked_flags = (k_flags & HVhek_MASK); - /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; + first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; entry = *oentry; - i = 1; - for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { + for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { + SV *sv; if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) @@ -989,15 +1060,20 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) continue; + if (hv == PL_strtab) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, "delete"); + } + /* if placeholder is here, it's already been deleted.... */ - if (HeVAL(entry) == &PL_sv_placeholder) - { - if (k_flags & HVhek_FREEKEY) - Safefree(key); - return Nullsv; + if (HeVAL(entry) == &PL_sv_placeholder) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); + return NULL; } - else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - S_hv_notallowed(aTHX_ k_flags, key, klen, + if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { + hv_notallowed(k_flags, key, klen, "Attempt to delete readonly key '%"SVf"' from" " a restricted hash"); } @@ -1005,7 +1081,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, Safefree(key); if (d_flags & G_DISCARD) - sv = Nullsv; + sv = NULL; else { sv = sv_2mortal(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; @@ -1025,38 +1101,39 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HvPLACEHOLDERS(hv)++; } else { *oentry = HeNEXT(entry); - if (i && !*oentry) + if(!*first_entry) { xhv->xhv_fill--; /* HvFILL(hv)-- */ - if (xhv->xhv_aux && entry - == ((struct xpvhv_aux *)xhv->xhv_aux)->xhv_eiter /* HvEITER(hv) */) + } + if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); - xhv->xhv_keys--; /* HvKEYS(hv)-- */ + xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ if (xhv->xhv_keys == 0) HvHASKFLAGS_off(hv); } return sv; } if (SvREADONLY(hv)) { - S_hv_notallowed(aTHX_ k_flags, key, klen, + hv_notallowed(k_flags, key, klen, "Attempt to delete disallowed key '%"SVf"' from" " a restricted hash"); } if (k_flags & HVhek_FREEKEY) Safefree(key); - return Nullsv; + return NULL; } STATIC void S_hsplit(pTHX_ HV *hv) { + dVAR; register XPVHV* xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ register I32 newsize = oldsize * 2; register I32 i; - register char *a = xhv->xhv_array; /* HvARRAY(hv) */ + char *a = (char*) HvARRAY(hv); register HE **aep; register HE **oentry; int longest_chain = 0; @@ -1065,7 +1142,7 @@ S_hsplit(pTHX_ HV *hv) /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n", hv, (int) oldsize);*/ - if (HvPLACEHOLDERS(hv) && !SvREADONLY(hv)) { + if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) { /* Can make this clear any placeholders first for non-restricted hashes, even though Storable rebuilds restricted hashes by putting in all the placeholders (first) before turning on the readonly flag, because @@ -1075,30 +1152,39 @@ S_hsplit(pTHX_ HV *hv) PL_nomemok = TRUE; #if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); + Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } + if (SvOOK(hv)) { + Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); + } #else - New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); + Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } - Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char); + Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char); + if (SvOOK(hv)) { + Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); + } if (oldsize >= 64) { - offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */, - PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); + offer_nice_chunk(HvARRAY(hv), + PERL_HV_ARRAY_ALLOC_BYTES(oldsize) + + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); } else - Safefree(xhv->xhv_array /* HvARRAY(hv) */); + Safefree(HvARRAY(hv)); #endif PL_nomemok = FALSE; Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ - xhv->xhv_array = a; /* HvARRAY(hv) = a */ + HvARRAY(hv) = (HE**) a; aep = (HE**)a; for (i=0; ixhv_fill = 0; HvSHAREKEYS_off(hv); HvREHASH_on(hv); - aep = (HE **) xhv->xhv_array; + aep = HvARRAY(hv); for (i=0; ixhv_array); - xhv->xhv_array = a; /* HvARRAY(hv) = a */ + Safefree (HvARRAY(hv)); + HvARRAY(hv) = (HE **)a; } void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) { + dVAR; register XPVHV* xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ register I32 newsize; @@ -1227,37 +1319,46 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) if (newsize < newmax) return; /* overflow detection */ - a = xhv->xhv_array; /* HvARRAY(hv) */ + a = (char *) HvARRAY(hv); if (a) { PL_nomemok = TRUE; #if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); + Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } + if (SvOOK(hv)) { + Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); + } #else - New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); + Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; return; } - Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char); + Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char); + if (SvOOK(hv)) { + Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); + } if (oldsize >= 64) { - offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */, - PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); + offer_nice_chunk(HvARRAY(hv), + PERL_HV_ARRAY_ALLOC_BYTES(oldsize) + + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); } else - Safefree(xhv->xhv_array /* HvARRAY(hv) */); + Safefree(HvARRAY(hv)); #endif PL_nomemok = FALSE; Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ } else { - Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); + Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); } xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ - xhv->xhv_array = a; /* HvARRAY(hv) = a */ + HvARRAY(hv) = (HE **) a; if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */ return; @@ -1266,8 +1367,9 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) if (!*aep) /* non-existent */ continue; for (oentry = aep, entry = *aep; entry; entry = *oentry) { - register I32 j; - if ((j = (HeHASH(entry) & newsize)) != i) { + register I32 j = (HeHASH(entry) & newsize); + + if (j != i) { j -= i; *oentry = HeNEXT(entry); if (!(HeNEXT(entry) = aep[j])) @@ -1294,10 +1396,9 @@ Creates a new HV. The reference count is set to 1. HV * Perl_newHV(pTHX) { - register HV *hv; register XPVHV* xhv; + HV * const hv = (HV*)newSV(0); - hv = (HV*)NEWSV(502,0); sv_upgrade((SV *)hv, SVt_PVHV); xhv = (XPVHV*)SvANY(hv); SvPOK_off(hv); @@ -1308,14 +1409,13 @@ Perl_newHV(pTHX) xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */ xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ - xhv->xhv_aux = 0; return hv; } HV * Perl_newHVhv(pTHX_ HV *ohv) { - HV *hv = newHV(); + HV * const hv = newHV(); STRLEN hv_max, hv_fill; if (!ohv || (hv_fill = HvFILL(ohv)) == 0) @@ -1326,14 +1426,15 @@ Perl_newHVhv(pTHX_ HV *ohv) /* It's an ordinary hash, so copy it fast. AMS 20010804 */ STRLEN i; const bool shared = !!HvSHAREKEYS(ohv); - HE **ents, **oents = (HE **)HvARRAY(ohv); + HE **ents, ** const oents = (HE **)HvARRAY(ohv); char *a; - New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); + Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); ents = (HE**)a; /* In each bucket... */ for (i = 0; i <= hv_max; i++) { - HE *prev = NULL, *ent = NULL, *oent = oents[i]; + HE *prev = NULL; + HE *oent = oents[i]; if (!oent) { ents[i] = NULL; @@ -1341,13 +1442,13 @@ Perl_newHVhv(pTHX_ HV *ohv) } /* Copy the linked list of entries. */ - for (oent = oents[i]; oent; oent = HeNEXT(oent)) { + for (; oent; oent = HeNEXT(oent)) { const U32 hash = HeHASH(oent); const char * const key = HeKEY(oent); const STRLEN len = HeKLEN(oent); const int flags = HeKFLAGS(oent); + HE * const ent = new_HE(); - ent = new_HE(); HeVAL(ent) = newSVsv(HeVAL(oent)); HeKEY_hek(ent) = shared ? share_hek_flags(key, len, hash, flags) @@ -1365,7 +1466,7 @@ Perl_newHVhv(pTHX_ HV *ohv) HvFILL(hv) = hv_fill; HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); HvARRAY(hv) = ents; - } + } /* not magical */ else { /* Iterate over ohv, copying keys and values one at a time. */ HE *entry; @@ -1390,9 +1491,43 @@ Perl_newHVhv(pTHX_ HV *ohv) return hv; } +/* A rather specialised version of newHVhv for copying %^H, ensuring all the + magic stays on it. */ +HV * +Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) +{ + HV * const hv = newHV(); + STRLEN hv_fill; + + if (ohv && (hv_fill = HvFILL(ohv))) { + STRLEN hv_max = HvMAX(ohv); + HE *entry; + const I32 riter = HvRITER_get(ohv); + HE * const eiter = HvEITER_get(ohv); + + while (hv_max && hv_max + 1 >= hv_fill * 2) + hv_max = hv_max / 2; + HvMAX(hv) = hv_max; + + hv_iterinit(ohv); + while ((entry = hv_iternext_flags(ohv, 0))) { + SV *const sv = newSVsv(HeVAL(entry)); + sv_magic(sv, NULL, PERL_MAGIC_hintselem, + (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY); + hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), + sv, HeHASH(entry), HeKFLAGS(entry)); + } + HvRITER_set(ohv, riter); + HvEITER_set(ohv, eiter); + } + hv_magic(hv, NULL, PERL_MAGIC_hints); + return hv; +} + void Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) { + dVAR; SV *val; if (!entry) @@ -1415,20 +1550,15 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) void Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) { + dVAR; if (!entry) return; - if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME_get(hv)) - PL_sub_generation++; /* may be deletion of method from stash */ - sv_2mortal(HeVAL(entry)); /* free between statements */ + /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */ + sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */ if (HeKLEN(entry) == HEf_SVKEY) { - sv_2mortal(HeKEY_sv(entry)); - Safefree(HeKEY_hek(entry)); + sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry))); } - else if (HvSHAREKEYS(hv)) - unshare_hek(HeKEY_hek(entry)); - else - Safefree(HeKEY_hek(entry)); - del_HE(entry); + hv_free_ent(hv, entry); } /* @@ -1451,16 +1581,16 @@ Perl_hv_clear(pTHX_ HV *hv) xhv = (XPVHV*)SvANY(hv); - if (SvREADONLY(hv) && xhv->xhv_array != NULL) { + if (SvREADONLY(hv) && HvARRAY(hv) != NULL) { /* restricted hash: convert all keys to placeholders */ - I32 i; - for (i = 0; i <= (I32) xhv->xhv_max; i++) { - HE *entry = ((HE**)xhv->xhv_array)[i]; + STRLEN i; + for (i = 0; i <= xhv->xhv_max; i++) { + HE *entry = (HvARRAY(hv))[i]; for (; entry; entry = HeNEXT(entry)) { /* not already placeholder */ if (HeVAL(entry) != &PL_sv_placeholder) { if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - SV* keysv = hv_iterkeysv(entry); + SV* const keysv = hv_iterkeysv(entry); Perl_croak(aTHX_ "Attempt to delete readonly key '%"SVf"' from a restricted hash", keysv); @@ -1476,8 +1606,8 @@ Perl_hv_clear(pTHX_ HV *hv) hfreeentries(hv); HvPLACEHOLDERS_set(hv, 0); - if (xhv->xhv_array /* HvARRAY(hv) */) - (void)memzero(xhv->xhv_array /* HvARRAY(hv) */, + if (HvARRAY(hv)) + (void)memzero(HvARRAY(hv), (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*)); if (SvRMAGICAL(hv)) @@ -1486,7 +1616,7 @@ Perl_hv_clear(pTHX_ HV *hv) HvHASKFLAGS_off(hv); HvREHASH_off(hv); reset: - if (xhv->xhv_aux) { + if (SvOOK(hv)) { HvEITER_set(hv, NULL); } } @@ -1509,42 +1639,49 @@ void Perl_hv_clear_placeholders(pTHX_ HV *hv) { dVAR; - I32 items = (I32)HvPLACEHOLDERS(hv); - I32 i = HvMAX(hv); + const U32 items = (U32)HvPLACEHOLDERS_get(hv); + + if (items) + clear_placeholders(hv, items); +} + +static void +S_clear_placeholders(pTHX_ HV *hv, U32 items) +{ + dVAR; + I32 i; if (items == 0) return; + i = HvMAX(hv); do { /* Loop down the linked list heads */ - bool first = 1; + bool first = TRUE; HE **oentry = &(HvARRAY(hv))[i]; - HE *entry = *oentry; - - if (!entry) - continue; + HE *entry; - for (; entry; entry = *oentry) { + while ((entry = *oentry)) { if (HeVAL(entry) == &PL_sv_placeholder) { *oentry = HeNEXT(entry); if (first && !*oentry) HvFILL(hv)--; /* This linked list is now empty. */ - if (HvEITER_get(hv)) + if (entry == HvEITER_get(hv)) HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); if (--items == 0) { /* Finished. */ - HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS(hv); + HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv); if (HvKEYS(hv) == 0) HvHASKFLAGS_off(hv); - HvPLACEHOLDERS(hv) = 0; + HvPLACEHOLDERS_set(hv, 0); return; } } else { oentry = &HeNEXT(entry); - first = 0; + first = FALSE; } } } while (--i >= 0); @@ -1556,50 +1693,136 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) STATIC void S_hfreeentries(pTHX_ HV *hv) { - register HE **array; - register HE *entry; - I32 riter; - I32 max; - struct xpvhv_aux *iter; + /* This is the array that we're going to restore */ + HE **orig_array; + HEK *name; + int attempts = 100; - if (!hv) - return; if (!HvARRAY(hv)) return; - riter = 0; - max = HvMAX(hv); - array = HvARRAY(hv); - /* make everyone else think the array is empty, so that the destructors - * called for freed entries can't recusively mess with us */ - HvARRAY(hv) = Null(HE**); - HvFILL(hv) = 0; - ((XPVHV*) SvANY(hv))->xhv_keys = 0; - - entry = array[0]; - for (;;) { - if (entry) { - register HE *oentry = entry; - entry = HeNEXT(entry); - hv_free_ent(hv, oentry); + if (SvOOK(hv)) { + /* If the hash is actually a symbol table with a name, look after the + name. */ + struct xpvhv_aux *iter = HvAUX(hv); + + name = iter->xhv_name; + iter->xhv_name = NULL; + } else { + name = NULL; + } + + orig_array = HvARRAY(hv); + /* orig_array remains unchanged throughout the loop. If after freeing all + the entries it turns out that one of the little blighters has triggered + an action that has caused HvARRAY to be re-allocated, then we set + array to the new HvARRAY, and try again. */ + + while (1) { + /* This is the one we're going to try to empty. First time round + it's the original array. (Hopefully there will only be 1 time + round) */ + HE ** const array = HvARRAY(hv); + I32 i = HvMAX(hv); + + /* Because we have taken xhv_name out, the only allocated pointer + in the aux structure that might exist is the backreference array. + */ + + if (SvOOK(hv)) { + HE *entry; + struct xpvhv_aux *iter = HvAUX(hv); + /* If there are weak references to this HV, we need to avoid + freeing them up here. In particular we need to keep the AV + visible as what we're deleting might well have weak references + back to this HV, so the for loop below may well trigger + the removal of backreferences from this array. */ + + if (iter->xhv_backreferences) { + /* So donate them to regular backref magic to keep them safe. + The sv_magic will increase the reference count of the AV, + so we need to drop it first. */ + SvREFCNT_dec(iter->xhv_backreferences); + if (AvFILLp(iter->xhv_backreferences) == -1) { + /* Turns out that the array is empty. Just free it. */ + SvREFCNT_dec(iter->xhv_backreferences); + + } else { + sv_magic((SV*)hv, (SV*)iter->xhv_backreferences, + PERL_MAGIC_backref, NULL, 0); + } + iter->xhv_backreferences = NULL; + } + + entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ + HvLAZYDEL_off(hv); + hv_free_ent(hv, entry); + } + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + + /* There are now no allocated pointers in the aux structure. */ + + SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */ + /* What aux structure? */ } - if (!entry) { - if (++riter > max) - break; - entry = array[riter]; + + /* make everyone else think the array is empty, so that the destructors + * called for freed entries can't recusively mess with us */ + HvARRAY(hv) = NULL; + HvFILL(hv) = 0; + ((XPVHV*) SvANY(hv))->xhv_keys = 0; + + + do { + /* Loop down the linked list heads */ + HE *entry = array[i]; + + while (entry) { + register HE * const oentry = entry; + entry = HeNEXT(entry); + hv_free_ent(hv, oentry); + } + } while (--i >= 0); + + /* As there are no allocated pointers in the aux structure, it's now + safe to free the array we just cleaned up, if it's not the one we're + going to put back. */ + if (array != orig_array) { + Safefree(array); } - } - HvARRAY(hv) = array; - iter = ((XPVHV*) SvANY(hv))->xhv_aux; - if (iter) { - entry = iter->xhv_eiter; /* HvEITER(hv) */ - if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, entry); + if (!HvARRAY(hv)) { + /* Good. No-one added anything this time round. */ + break; + } + + if (SvOOK(hv)) { + /* Someone attempted to iterate or set the hash name while we had + the array set to 0. We'll catch backferences on the next time + round the while loop. */ + assert(HvARRAY(hv)); + + if (HvAUX(hv)->xhv_name) { + unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); + } + } + + if (--attempts == 0) { + Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries"); } - Safefree(iter); - ((XPVHV*) SvANY(hv))->xhv_aux = 0; + } + + HvARRAY(hv) = orig_array; + + /* If the hash was actually a symbol table, put the name back. */ + if (name) { + /* We have restored the original array. If name is non-NULL, then + the original array had an aux structure at the end. So this is + valid: */ + SvFLAGS(hv) |= SVf_OOK; + HvAUX(hv)->xhv_name = name; } } @@ -1614,38 +1837,52 @@ Undefines the hash. void Perl_hv_undef(pTHX_ HV *hv) { + dVAR; register XPVHV* xhv; const char *name; + if (!hv) return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); - Safefree(xhv->xhv_array /* HvARRAY(hv) */); if ((name = HvNAME_get(hv))) { - /* FIXME - strlen HvNAME */ if(PL_stashcache) - hv_delete(PL_stashcache, name, strlen(name), G_DISCARD); - Perl_hv_name_set(aTHX_ hv, 0, 0, 0); + hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); + hv_name_set(hv, NULL, 0, 0); } + SvFLAGS(hv) &= ~SVf_OOK; + Safefree(HvARRAY(hv)); xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ - xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */ + HvARRAY(hv) = 0; HvPLACEHOLDERS_set(hv, 0); if (SvRMAGICAL(hv)) mg_clear((SV*)hv); } -struct xpvhv_aux* -S_hv_auxinit(aTHX) { +static struct xpvhv_aux* +S_hv_auxinit(HV *hv) { struct xpvhv_aux *iter; + char *array; - New(0, iter, 1, struct xpvhv_aux); + if (!HvARRAY(hv)) { + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) + + sizeof(struct xpvhv_aux), char); + } else { + array = (char *) HvARRAY(hv); + Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) + + sizeof(struct xpvhv_aux), char); + } + HvARRAY(hv) = (HE**) array; + /* SvOOK_on(hv) attacks the IV flags. */ + SvFLAGS(hv) |= SVf_OOK; + iter = HvAUX(hv); iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ iter->xhv_name = 0; - + iter->xhv_backreferences = 0; return iter; } @@ -1667,29 +1904,24 @@ value, you can get it through the macro C. I32 Perl_hv_iterinit(pTHX_ HV *hv) { - register XPVHV* xhv; - HE *entry; - struct xpvhv_aux *iter; - if (!hv) Perl_croak(aTHX_ "Bad hash"); - xhv = (XPVHV*)SvANY(hv); - iter = xhv->xhv_aux; - if (iter) { - entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (SvOOK(hv)) { + struct xpvhv_aux * const 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->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ } else { - xhv->xhv_aux = S_hv_auxinit(aTHX); + hv_auxinit(hv); } /* used to be xhv->xhv_fill before 5.004_65 */ - return XHvTOTALKEYS(xhv); + return HvTOTALKEYS(hv); } I32 * @@ -1699,10 +1931,7 @@ Perl_hv_riter_p(pTHX_ HV *hv) { if (!hv) Perl_croak(aTHX_ "Bad hash"); - iter = ((XPVHV *)SvANY(hv))->xhv_aux; - if (!iter) { - ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); - } + iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); return &(iter->xhv_riter); } @@ -1713,10 +1942,7 @@ Perl_hv_eiter_p(pTHX_ HV *hv) { if (!hv) Perl_croak(aTHX_ "Bad hash"); - iter = ((XPVHV *)SvANY(hv))->xhv_aux; - if (!iter) { - ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); - } + iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); return &(iter->xhv_eiter); } @@ -1727,13 +1953,13 @@ Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { if (!hv) Perl_croak(aTHX_ "Bad hash"); - - iter = ((XPVHV *)SvANY(hv))->xhv_aux; - if (!iter) { + if (SvOOK(hv)) { + iter = HvAUX(hv); + } else { if (riter == -1) return; - ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + iter = hv_auxinit(hv); } iter->xhv_riter = riter; } @@ -1745,45 +1971,71 @@ Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { if (!hv) Perl_croak(aTHX_ "Bad hash"); - iter = ((XPVHV *)SvANY(hv))->xhv_aux; - if (!iter) { + if (SvOOK(hv)) { + iter = HvAUX(hv); + } else { /* 0 is the default so don't go malloc()ing a new structure just to hold 0. */ if (!eiter) return; - ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + iter = hv_auxinit(hv); } iter->xhv_eiter = eiter; } - -char ** -Perl_hv_name_p(pTHX_ HV *hv) +void +Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) { - struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux; + dVAR; + struct xpvhv_aux *iter; + U32 hash; + + PERL_UNUSED_ARG(flags); - if (!iter) { - ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); + + if (SvOOK(hv)) { + iter = HvAUX(hv); + if (iter->xhv_name) { + unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0); + } + } else { + if (name == 0) + return; + + iter = hv_auxinit(hv); } - return &(iter->xhv_name); + PERL_HASH(hash, name, len); + iter->xhv_name = name ? share_hek(name, len, hash) : 0; +} + +AV ** +Perl_hv_backreferences_p(pTHX_ HV *hv) { + struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); + PERL_UNUSED_CONTEXT; + return &(iter->xhv_backreferences); } void -Perl_hv_name_set(pTHX_ HV *hv, const char *name, STRLEN len, int flags) -{ - struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux; +Perl_hv_kill_backrefs(pTHX_ HV *hv) { + AV *av; - if (!iter) { - if (name == 0) - return; + if (!SvOOK(hv)) + return; + + av = HvAUX(hv)->xhv_backreferences; - ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + if (av) { + HvAUX(hv)->xhv_backreferences = 0; + Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av); } - iter->xhv_name = savepvn(name, len); } /* +hv_iternext is implemented as a macro in hv.h + =for apidoc hv_iternext Returns entries from a hash iterator. See C. @@ -1796,16 +2048,6 @@ to free the entry on the next call to C, so you must not discard your iterator immediately else the entry will leak - call C to trigger the resource deallocation. -=cut -*/ - -HE * -Perl_hv_iternext(pTHX_ HV *hv) -{ - return hv_iternext_flags(hv, 0); -} - -/* =for apidoc hv_iternext_flags Returns entries from a hash iterator. See C and C. @@ -1833,20 +2075,19 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) if (!hv) Perl_croak(aTHX_ "Bad hash"); xhv = (XPVHV*)SvANY(hv); - iter = xhv->xhv_aux; - if (!iter) { + if (!SvOOK(hv)) { /* Too many things (well, pp_each at least) merrily assume that you can call iv_iternext without calling hv_iterinit, so we'll have to deal with it. */ hv_iterinit(hv); - iter = ((XPVHV *)SvANY(hv))->xhv_aux; } + iter = HvAUX(hv); oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) { - SV *key = sv_newmortal(); + SV * const key = sv_newmortal(); if (entry) { sv_setsv(key, HeSVKEY_force(entry)); SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ @@ -1858,7 +2099,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* one HE per MAGICAL hash */ iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ Zero(entry, 1, HE); - Newz(54, k, HEK_BASESIZE + sizeof(SV*), char); + Newxz(k, HEK_BASESIZE + sizeof(SV*), char); hek = (HEK*)k; HeKEY_hek(entry) = hek; HeKLEN(entry) = HEf_SVKEY; @@ -1866,25 +2107,33 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { /* force key to stay around until next time */ - HeSVKEY_set(entry, SvREFCNT_inc(key)); + HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); return entry; /* beware, hent_val is not set */ } if (HeVAL(entry)) SvREFCNT_dec(HeVAL(entry)); Safefree(HeKEY_hek(entry)); del_HE(entry); - iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ - return Null(HE*); + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + return NULL; } #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */ - if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) + if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { prime_env_iter(); +#ifdef VMS + /* The prime_env_iter() on VMS just loaded up new hash values + * so the iteration count needs to be reset back to the beginning + */ + hv_iterinit(hv); + iter = HvAUX(hv); + oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ +#endif + } #endif - if (!xhv->xhv_array /* !HvARRAY(hv) */) - Newz(506, xhv->xhv_array /* HvARRAY(hv) */, - PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), - char); + /* hv_iterint now ensures this. */ + assert (HvARRAY(hv)); + /* At start of hash, entry is NULL. */ if (entry) { @@ -1908,8 +2157,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ break; } - /* entry = (HvARRAY(hv))[HvRITER(hv)]; */ - entry = ((HE**)xhv->xhv_array)[iter->xhv_riter]; + entry = (HvARRAY(hv))[iter->xhv_riter]; if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { /* If we have an entry, but it's a placeholder, don't count it. @@ -1948,7 +2196,7 @@ Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen) { if (HeKLEN(entry) == HEf_SVKEY) { STRLEN len; - char *p = SvPV(HeKEY_sv(entry), len); + char * const p = SvPV(HeKEY_sv(entry), len); *retlen = len; return p; } @@ -1972,39 +2220,7 @@ see C. SV * Perl_hv_iterkeysv(pTHX_ register HE *entry) { - if (HeKLEN(entry) != HEf_SVKEY) { - HEK *hek = HeKEY_hek(entry); - const int flags = HEK_FLAGS(hek); - SV *sv; - - if (flags & HVhek_WASUTF8) { - /* Trouble :-) - Andreas would like keys he put in as utf8 to come back as utf8 - */ - STRLEN utf8_len = HEK_LEN(hek); - U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); - - sv = newSVpvn ((char*)as_utf8, utf8_len); - SvUTF8_on (sv); - Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ - } else if (flags & HVhek_REHASH) { - /* We don't have a pointer to the hv, so we have to replicate the - flag into every HEK. This hv is using custom a hasing - algorithm. Hence we can't return a shared string scalar, as - that would contain the (wrong) hash value, and might get passed - into an hv routine with a regular hash */ - - sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); - if (HEK_UTF8(hek)) - SvUTF8_on (sv); - } else { - sv = newSVpvn_share(HEK_KEY(hek), - (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)), - HEK_HASH(hek)); - } - return sv_2mortal(sv); - } - return sv_mortalcopy(HeKEY_sv(entry)); + return sv_2mortal(newSVhek(HeKEY_hek(entry))); } /* @@ -2021,7 +2237,7 @@ Perl_hv_iterval(pTHX_ HV *hv, register HE *entry) { if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv, PERL_MAGIC_tied)) { - SV* sv = sv_newmortal(); + SV* const sv = sv_newmortal(); if (HeKLEN(entry) == HEf_SVKEY) mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY); else @@ -2044,14 +2260,18 @@ operation. SV * Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) { - HE *he; - if ( (he = hv_iternext_flags(hv, 0)) == NULL) + HE * const he = hv_iternext_flags(hv, 0); + + if (!he) return NULL; *key = hv_iterkey(he, retlen); return hv_iterval(hv, he); } /* + +Now a macro in hv.h + =for apidoc hv_magic Adds magic to a hash. See C. @@ -2059,22 +2279,6 @@ Adds magic to a hash. See C. =cut */ -void -Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how) -{ - sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0); -} - -#if 0 /* use the macro from hv.h instead */ - -char* -Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash) -{ - return HEK_KEY(share_hek(sv, len, hash)); -} - -#endif - /* possibly free a shared string if no one has access to it * len and hash must both be valid for str. */ @@ -2096,18 +2300,36 @@ Perl_unshare_hek(pTHX_ HEK *hek) are used. If so, len and hash must both be valid for str. */ STATIC void -S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) +S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) { + dVAR; register XPVHV* xhv; - register HE *entry; + HE *entry; register HE **oentry; - register I32 i = 1; - bool found = 0; + HE **first; bool is_utf8 = FALSE; int k_flags = 0; - const char *save = str; + const char * const save = str; + struct shared_he *he = NULL; if (hek) { + /* Find the shared he which is just before us in memory. */ + he = (struct shared_he *)(((char *)hek) + - STRUCT_OFFSET(struct shared_he, + shared_he_hek)); + + /* Assert that the caller passed us a genuine (or at least consistent) + shared hek */ + assert (he->shared_he_he.hent_hek == hek); + + LOCK_STRTAB_MUTEX; + if (he->shared_he_he.he_valu.hent_refcount - 1) { + --he->shared_he_he.he_valu.hent_refcount; + UNLOCK_STRTAB_MUTEX; + return; + } + UNLOCK_STRTAB_MUTEX; + hash = HEK_HASH(hek); } else if (len < 0) { STRLEN tmplen = -len; @@ -2121,26 +2343,24 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; } - /* what follows is the moral equivalent of: + /* what follows was the moral equivalent of: if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { - if (--*Svp == Nullsv) + if (--*Svp == NULL) hv_delete(PL_strtab, str, len, G_DISCARD, hash); } */ xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ LOCK_STRTAB_MUTEX; - /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - if (hek) { - for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { - if (HeKEY_hek(entry) != hek) - continue; - found = 1; - break; + first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; + if (he) { + const HE *const he_he = &(he->shared_he_he); + for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { + if (entry == he_he) + break; } } else { const int flags_masked = k_flags & HVhek_MASK; - for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { + for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != len) @@ -2149,24 +2369,24 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) continue; if (HeKFLAGS(entry) != flags_masked) continue; - found = 1; break; } } - if (found) { - if (--HeVAL(entry) == Nullsv) { + if (entry) { + if (--entry->he_valu.hent_refcount == 0) { *oentry = HeNEXT(entry); - if (i && !*oentry) + if (!*first) { + /* There are now no entries in our slot. */ xhv->xhv_fill--; /* HvFILL(hv)-- */ - Safefree(HeKEY_hek(entry)); - del_HE(entry); - xhv->xhv_keys--; /* HvKEYS(hv)-- */ + } + Safefree(entry); + xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ } } UNLOCK_STRTAB_MUTEX; - if (!found && ckWARN_d(WARN_INTERNAL)) + if (!entry && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent shared string '%s'%s" pTHX__FORMAT, @@ -2185,7 +2405,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) { bool is_utf8 = FALSE; int flags = 0; - const char *save = str; + const char * const save = str; if (len < 0) { STRLEN tmplen = -len; @@ -2210,27 +2430,24 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) STATIC HEK * S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) { - register XPVHV* xhv; + dVAR; register HE *entry; - register HE **oentry; - register I32 i = 1; - I32 found = 0; const int flags_masked = flags & HVhek_MASK; + const U32 hindex = hash & (I32) HvMAX(PL_strtab); /* what follows is the moral equivalent of: if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) - hv_store(PL_strtab, str, len, Nullsv, hash); + hv_store(PL_strtab, str, len, NULL, hash); Can't rehash the shared string table, so not sure if it's worth counting the number of entries in the linked list */ - xhv = (XPVHV*)SvANY(PL_strtab); + register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ LOCK_STRTAB_MUTEX; - /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) { + entry = (HvARRAY(PL_strtab))[hindex]; + for (;entry; entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != len) @@ -2239,24 +2456,53 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) continue; if (HeKFLAGS(entry) != flags_masked) continue; - found = 1; break; } - if (!found) { - entry = new_HE(); - HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked); - HeVAL(entry) = Nullsv; - HeNEXT(entry) = *oentry; - *oentry = entry; - xhv->xhv_keys++; /* HvKEYS(hv)++ */ - if (i) { /* initial entry? */ + + if (!entry) { + /* What used to be head of the list. + If this is NULL, then we're the first entry for this slot, which + means we need to increate fill. */ + struct shared_he *new_entry; + HEK *hek; + char *k; + HE **const head = &HvARRAY(PL_strtab)[hindex]; + HE *const next = *head; + + /* We don't actually store a HE from the arena and a regular HEK. + Instead we allocate one chunk of memory big enough for both, + and put the HEK straight after the HE. This way we can find the + HEK directly from the HE. + */ + + Newx(k, STRUCT_OFFSET(struct shared_he, + shared_he_hek.hek_key[0]) + len + 2, char); + new_entry = (struct shared_he *)k; + entry = &(new_entry->shared_he_he); + hek = &(new_entry->shared_he_hek); + + Copy(str, HEK_KEY(hek), len, char); + HEK_KEY(hek)[len] = 0; + HEK_LEN(hek) = len; + HEK_HASH(hek) = hash; + HEK_FLAGS(hek) = (unsigned char)flags_masked; + + /* Still "point" to the HEK, so that other code need not know what + we're up to. */ + HeKEY_hek(entry) = hek; + entry->he_valu.hent_refcount = 0; + HeNEXT(entry) = next; + *head = entry; + + xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ + if (!next) { /* initial entry? */ xhv->xhv_fill++; /* HvFILL(hv)++ */ } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { hsplit(PL_strtab); } } - ++HeVAL(entry); /* use value slot as REFCNT */ + ++entry->he_valu.hent_refcount; UNLOCK_STRTAB_MUTEX; if (flags & HVhek_FREEKEY) @@ -2286,7 +2532,7 @@ I32 Perl_hv_placeholders_get(pTHX_ HV *hv) { dVAR; - MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash); + MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash); return mg ? mg->mg_len : 0; } @@ -2295,7 +2541,7 @@ void Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) { dVAR; - MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash); + MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash); if (mg) { mg->mg_len = ph; @@ -2307,6 +2553,256 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) } /* +=for apidoc refcounted_he_chain_2hv + +Generates an returns a C by walking up the tree starting at the passed +in C. + +=cut +*/ +HV * +Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) +{ + HV *hv = newHV(); + U32 placeholders = 0; + /* We could chase the chain once to get an idea of the number of keys, + and call ksplit. But for now we'll make a potentially inefficient + hash with only 8 entries in its array. */ + const U32 max = HvMAX(hv); + + if (!HvARRAY(hv)) { + char *array; + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); + HvARRAY(hv) = (HE**)array; + } + + while (chain) { +#ifdef USE_ITHREADS + U32 hash = chain->refcounted_he_hash; +#else + U32 hash = HEK_HASH(chain->refcounted_he_hek); +#endif + HE **oentry = &((HvARRAY(hv))[hash & max]); + HE *entry = *oentry; + SV *value; + + for (; entry; entry = HeNEXT(entry)) { + if (HeHASH(entry) == hash) { + goto next_please; + } + } + assert (!entry); + entry = new_HE(); + +#ifdef USE_ITHREADS + HeKEY_hek(entry) + = share_hek_flags(/* A big expression to find the key offset */ + (((chain->refcounted_he_data[0] + & HVrhek_typemask) == HVrhek_PV) + ? chain->refcounted_he_val.refcounted_he_u_len + + 1 : 0) + 1 + chain->refcounted_he_data, + chain->refcounted_he_keylen, + chain->refcounted_he_hash, + (chain->refcounted_he_data[0] + & (HVhek_UTF8|HVhek_WASUTF8))); +#else + HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); +#endif + + switch(chain->refcounted_he_data[0] & HVrhek_typemask) { + case HVrhek_undef: + value = newSV(0); + break; + case HVrhek_delete: + value = &PL_sv_placeholder; + placeholders++; + break; + case HVrhek_IV: + value = (chain->refcounted_he_data[0] & HVrhek_UV) + ? newSViv(chain->refcounted_he_val.refcounted_he_u_iv) + : newSViv(chain->refcounted_he_val.refcounted_he_u_uv); + break; + case HVrhek_PV: + /* Create a string SV that directly points to the bytes in our + structure. */ + value = newSV(0); + sv_upgrade(value, SVt_PV); + SvPV_set(value, (char *) chain->refcounted_he_data + 1); + SvCUR_set(value, chain->refcounted_he_val.refcounted_he_u_len); + /* This stops anything trying to free it */ + SvLEN_set(value, 0); + SvPOK_on(value); + SvREADONLY_on(value); + if (chain->refcounted_he_data[0] & HVrhek_UTF8) + SvUTF8_on(value); + break; + default: + Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %x", + chain->refcounted_he_data[0]); + } + HeVAL(entry) = value; + + /* Link it into the chain. */ + HeNEXT(entry) = *oentry; + if (!HeNEXT(entry)) { + /* initial entry. */ + HvFILL(hv)++; + } + *oentry = entry; + + HvTOTALKEYS(hv)++; + + next_please: + chain = chain->refcounted_he_next; + } + + if (placeholders) { + clear_placeholders(hv, placeholders); + HvTOTALKEYS(hv) -= placeholders; + } + + /* We could check in the loop to see if we encounter any keys with key + flags, but it's probably not worth it, as this per-hash flag is only + really meant as an optimisation for things like Storable. */ + HvHASKFLAGS_on(hv); + DEBUG_A(Perl_hv_assert(aTHX_ hv)); + + return hv; +} + +/* +=for apidoc refcounted_he_new + +Creates a new C. Assumes ownership of one reference +to I. As S is copied into a shared hash key, all references remain +the property of the caller. The C is returned with a +reference count of 1. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, + SV *const key, SV *const value) { + struct refcounted_he *he; + STRLEN key_len; + const char *key_p = SvPV_const(key, key_len); + STRLEN value_len = 0; + const char *value_p; + char value_type; + char flags; + STRLEN key_offset; + U32 hash; + bool is_utf8 = SvUTF8(key); + + if (SvPOK(value)) { + value_type = HVrhek_PV; + } else if (SvIOK(value)) { + value_type = HVrhek_IV; + } else if (value == &PL_sv_placeholder) { + value_type = HVrhek_delete; + } else if (!SvOK(value)) { + value_type = HVrhek_undef; + } else { + value_type = HVrhek_PV; + } + + if (value_type == HVrhek_PV) { + value_p = SvPV_const(value, value_len); + key_offset = value_len + 2; + } else { + value_len = 0; + key_offset = 1; + } + flags = value_type; + + he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 +#ifdef USE_ITHREADS + + key_len +#endif + + key_offset); + + + he->refcounted_he_next = parent; + + if (value_type == HVrhek_PV) { + Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); + he->refcounted_he_val.refcounted_he_u_len = value_len; + if (SvUTF8(value)) { + flags |= HVrhek_UTF8; + } + } else if (value_type == HVrhek_IV) { + if (SvUOK(value)) { + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); + flags |= HVrhek_UV; + } else { + he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); + } + } + + 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 + he->refcounted_he_hash = hash; + he->refcounted_he_keylen = key_len; + Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); +#else + he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); +#endif + + if (flags & HVhek_WASUTF8) { + /* If it was downgraded from UTF-8, then the pointer returned from + bytes_from_utf8 is an allocated pointer that we must free. */ + Safefree(key_p); + } + + he->refcounted_he_data[0] = flags; + he->refcounted_he_refcnt = 1; + + return he; +} + +/* +=for apidoc refcounted_he_free + +Decrements the reference count of the passed in C +by one. If the reference count reaches zero the structure's memory is freed, +and C iterates onto the parent node. + +=cut +*/ + +void +Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { + while (he) { + struct refcounted_he *copy; + U32 new_count; + + HINTS_REFCNT_LOCK; + new_count = --he->refcounted_he_refcnt; + HINTS_REFCNT_UNLOCK; + + if (new_count) { + return; + } + +#ifndef USE_ITHREADS + unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); +#endif + copy = he; + he = he->refcounted_he_next; + PerlMemShared_free(copy); + } +} + +/* =for apidoc hv_assert Check that a hash is in an internally consistent state. @@ -2314,6 +2810,8 @@ Check that a hash is in an internally consistent state. =cut */ +#ifdef DEBUGGING + void Perl_hv_assert(pTHX_ HV *hv) { @@ -2337,7 +2835,7 @@ Perl_hv_assert(pTHX_ HV *hv) } /* sanity check the keys */ if (HeSVKEY(entry)) { - /* Don't know what to check on SV keys. */ + /*EMPTY*/ /* Don't know what to check on SV keys. */ } else if (HeKUTF8(entry)) { withflags++; if (HeKWASUTF8(entry)) { @@ -2356,10 +2854,10 @@ Perl_hv_assert(pTHX_ HV *hv) (int) real, (int) HvUSEDKEYS(hv)); bad = 1; } - if (HvPLACEHOLDERS(hv) != placeholders) { + if (HvPLACEHOLDERS_get(hv) != placeholders) { PerlIO_printf(Perl_debug_log, "Count %d placeholder(s), but hash reports %d\n", - (int) placeholders, (int) HvPLACEHOLDERS(hv)); + (int) placeholders, (int) HvPLACEHOLDERS_get(hv)); bad = 1; } } @@ -2376,6 +2874,8 @@ Perl_hv_assert(pTHX_ HV *hv) HvEITER_set(hv, eiter); } +#endif + /* * Local variables: * c-indentation-style: bsd