X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=6f5dd2eaf7b26a603b43fada740167933ae798a8;hb=0bfa2a8afc04ca8a47987d5890bbbe751faf4444;hp=5f0f485b97aa0c8a0ac15f31dda83b1e4728ffce;hpb=7a9b70e91d2c0aa19f8cec5b0f8c133492a19280;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index 5f0f485..6f5dd2e 100644 --- a/hv.c +++ b/hv.c @@ -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) { HE* he; HE* heend; - New(54, he, PERL_ARENA_SIZE/sizeof(HE), HE); - HeNEXT(he) = PL_he_arenaroot; - PL_he_arenaroot = he; + Newx(he, PERL_ARENA_SIZE/sizeof(HE), HE); + HeNEXT(he) = (HE*) PL_body_arenaroots[HE_SVSLOT]; + PL_body_arenaroots[HE_SVSLOT] = he; 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,37 +54,38 @@ 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) { 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() 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 -#define new_HE() (HE*)safemalloc(sizeof(HE)) -#define del_HE(p) safefree((char*)p) -#else - -#define new_HE() new_he() -#define del_HE(p) del_he(p) #endif @@ -92,7 +96,7 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) 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,17 +109,16 @@ 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; 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); } @@ -126,22 +129,25 @@ Perl_free_tied_hv_pool(pTHX) HEK * Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) { - HE *shared = (HE*)ptr_table_fetch(PL_shared_hek_table, source); + HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); + + PERL_UNUSED_ARG(param); if (shared) { /* We already shared this hash key. */ - ++HeVAL(shared); + (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_shared_hek_table, source, shared); + 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 HeKEY_hek(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; @@ -159,26 +165,27 @@ 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) { /* This is hek_dup inlined, which seems to be important for speed reasons. */ - HEK *source = HeKEY_hek(e); - HE *shared = (HE*)ptr_table_fetch(PL_shared_hek_table, source); + HEK * const source = HeKEY_hek(e); + HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); if (shared) { /* We already shared this hash key. */ - ++HeVAL(shared); + (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_shared_hek_table, source, shared); + 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) = HeKEY_hek(shared); + HeKEY_hek(ret) = shared; } else HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), @@ -192,7 +199,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); } @@ -264,7 +271,7 @@ 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; } @@ -425,7 +432,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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 { @@ -459,7 +466,7 @@ 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; @@ -483,7 +490,7 @@ 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, @@ -509,10 +516,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) { @@ -537,7 +543,7 @@ 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); @@ -605,7 +611,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #endif ) { char *array; - Newz(503, array, + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), char); HvARRAY(hv) = (HE**)array; @@ -626,7 +632,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 * const)key; key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) flags |= HVhek_UTF8; @@ -649,7 +655,7 @@ 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); } @@ -684,11 +690,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 = HeKEY_hek(share_hek_flags(key, klen, hash, - masked_flags)); + HEK *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) @@ -735,7 +749,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); @@ -777,7 +791,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, NULL is for %ENV with dynamic env fetch. But that should disappear with magic in the previous code. */ char *array; - Newz(503, array, + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), char); HvARRAY(hv) = (HE**)array; @@ -789,7 +803,15 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* share_hek_flags will do the free for us. This might be considered bad API design. */ if (HvSHAREKEYS(hv)) - HeKEY_hek(entry) = HeKEY_hek(share_hek_flags(key, klen, hash, flags)); + 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; @@ -839,9 +861,7 @@ 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. */ } @@ -861,13 +881,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)) @@ -941,7 +961,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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 { @@ -991,8 +1011,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return Nullsv; if (is_utf8) { - const char *keysave = key; - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + const char *keysave = key; + key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) k_flags |= HVhek_UTF8; @@ -1013,7 +1033,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); } @@ -1033,6 +1053,12 @@ 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) { @@ -1129,7 +1155,7 @@ S_hsplit(pTHX_ HV *hv) Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } #else - New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; @@ -1207,7 +1233,7 @@ S_hsplit(pTHX_ HV *hv) longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/ ++newsize; - Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (SvOOK(hv)) { Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); @@ -1226,7 +1252,7 @@ S_hsplit(pTHX_ HV *hv) while (entry) { /* We're going to trash this HE's next pointer when we chain it into the new hash below, so store where we go next. */ - HE *next = HeNEXT(entry); + HE * const next = HeNEXT(entry); UV hash; HE **bep; @@ -1235,7 +1261,7 @@ S_hsplit(pTHX_ HV *hv) if (was_shared) { /* Unshare it. */ - HEK *new_hek + HEK * const new_hek = save_hek_flags(HeKEY(entry), HeKLEN(entry), hash, HeKFLAGS(entry)); unshare_hek (HeKEY_hek(entry)); @@ -1299,7 +1325,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } #else - New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); if (!a) { PL_nomemok = FALSE; @@ -1321,7 +1347,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) 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 */ HvARRAY(hv) = (HE **) a; @@ -1361,10 +1387,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(502,0); - hv = (HV*)NEWSV(502,0); sv_upgrade((SV *)hv, SVt_PVHV); xhv = (XPVHV*)SvANY(hv); SvPOK_off(hv); @@ -1381,7 +1406,7 @@ Perl_newHV(pTHX) 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) @@ -1392,14 +1417,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, *ent = NULL; + HE *oent = oents[i]; if (!oent) { ents[i] = NULL; @@ -1407,7 +1433,7 @@ 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); @@ -1416,7 +1442,7 @@ Perl_newHVhv(pTHX_ HV *ohv) ent = new_HE(); HeVAL(ent) = newSVsv(HeVAL(oent)); HeKEY_hek(ent) - = shared ? HeKEY_hek(share_hek_flags(key, len, hash, flags)) + = shared ? share_hek_flags(key, len, hash, flags) : save_hek_flags(key, len, hash, flags); if (prev) HeNEXT(prev) = ent; @@ -1431,7 +1457,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; @@ -1483,18 +1509,12 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) { 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); } /* @@ -1519,8 +1539,8 @@ Perl_hv_clear(pTHX_ HV *hv) if (SvREADONLY(hv) && HvARRAY(hv) != NULL) { /* restricted hash: convert all keys to placeholders */ - I32 i; - for (i = 0; i <= (I32) xhv->xhv_max; i++) { + STRLEN i; + for (i = 0; i <= xhv->xhv_max; i++) { HE *entry = (HvARRAY(hv))[i]; for (; entry; entry = HeNEXT(entry)) { /* not already placeholder */ @@ -1576,11 +1596,12 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) { dVAR; I32 items = (I32)HvPLACEHOLDERS_get(hv); - I32 i = HvMAX(hv); + I32 i; if (items == 0) return; + i = HvMAX(hv); do { /* Loop down the linked list heads */ bool first = 1; @@ -1627,8 +1648,7 @@ S_hfreeentries(pTHX_ HV *hv) I32 riter; I32 max; struct xpvhv_aux *iter; - if (!hv) - return; + if (!HvARRAY(hv)) return; @@ -1648,7 +1668,7 @@ S_hfreeentries(pTHX_ HV *hv) entry = array[0]; for (;;) { if (entry) { - register HE *oentry = entry; + register HE * const oentry = entry; entry = HeNEXT(entry); hv_free_ent(hv, oentry); } @@ -1710,7 +1730,7 @@ Perl_hv_undef(pTHX_ HV *hv) if ((name = HvNAME_get(hv))) { if(PL_stashcache) hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); - Perl_hv_name_set(aTHX_ hv, 0, 0, 0); + hv_name_set(hv, Nullch, 0, 0); } SvFLAGS(hv) &= ~SVf_OOK; Safefree(HvARRAY(hv)); @@ -1722,13 +1742,13 @@ Perl_hv_undef(pTHX_ HV *hv) mg_clear((SV*)hv); } -struct xpvhv_aux* +static struct xpvhv_aux* S_hv_auxinit(pTHX_ HV *hv) { struct xpvhv_aux *iter; char *array; if (!HvARRAY(hv)) { - Newz(0, array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) + sizeof(struct xpvhv_aux), char); } else { array = (char *) HvARRAY(hv); @@ -1765,16 +1785,12 @@ value, you can get it through the macro C. I32 Perl_hv_iterinit(pTHX_ HV *hv) { - register XPVHV* xhv; - HE *entry; - if (!hv) Perl_croak(aTHX_ "Bad hash"); - xhv = (XPVHV*)SvANY(hv); if (SvOOK(hv)) { struct xpvhv_aux *iter = HvAUX(hv); - entry = iter->xhv_eiter; /* HvEITER(hv) */ + HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ HvLAZYDEL_off(hv); hv_free_ent(hv, entry); @@ -1855,6 +1871,8 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags) struct xpvhv_aux *iter; U32 hash; + PERL_UNUSED_ARG(flags); + if (SvOOK(hv)) { iter = HvAUX(hv); if (iter->xhv_name) { @@ -1871,6 +1889,8 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags) } /* +hv_iternext is implemented as a macro in hv.h + =for apidoc hv_iternext Returns entries from a hash iterator. See C. @@ -1883,16 +1903,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. @@ -1932,7 +1942,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) 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 */ @@ -1944,7 +1954,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; @@ -1963,8 +1973,17 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) return Null(HE*); } #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 /* hv_iterint now ensures this. */ @@ -2032,7 +2051,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; } @@ -2056,39 +2075,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))); } /* @@ -2105,7 +2092,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 @@ -2128,14 +2115,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. @@ -2143,22 +2134,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. */ @@ -2180,18 +2155,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) { register XPVHV* xhv; - register HE *entry; + HE *entry; register HE **oentry; HE **first; bool found = 0; bool is_utf8 = FALSE; int k_flags = 0; - const char *save = str; + const char * const save = str; + struct shared_he *he = 0; 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.hent_val - 1) { + --he->shared_he_he.hent_val; + UNLOCK_STRTAB_MUTEX; + return; + } + UNLOCK_STRTAB_MUTEX; + hash = HEK_HASH(hek); } else if (len < 0) { STRLEN tmplen = -len; @@ -2214,9 +2207,10 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) /* assert(xhv_array != 0) */ LOCK_STRTAB_MUTEX; first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; - if (hek) { + if (he) { + const HE *const he_he = &(he->shared_he_he); for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { - if (HeKEY_hek(entry) != hek) + if (entry != he_he) continue; found = 1; break; @@ -2244,8 +2238,7 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) /* There are now no entries in our slot. */ xhv->xhv_fill--; /* HvFILL(hv)-- */ } - Safefree(HeKEY_hek(entry)); - del_HE(entry); + Safefree(entry); xhv->xhv_keys--; /* HvKEYS(hv)-- */ } } @@ -2270,7 +2263,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; @@ -2289,13 +2282,12 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) flags |= HVhek_WASUTF8 | HVhek_FREEKEY; } - return HeKEY_hek(share_hek_flags (str, len, hash, flags)); + return share_hek_flags (str, len, hash, flags); } -STATIC HE * +STATIC HEK * S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) { - register XPVHV* xhv; register HE *entry; register HE **oentry; I32 found = 0; @@ -2309,7 +2301,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) 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(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; @@ -2330,11 +2322,35 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) If this is NULL, then we're the first entry for this slot, which means we need to increate fill. */ const HE *old_first = *oentry; - entry = new_HE(); - HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked); + struct shared_he *new_entry; + HEK *hek; + char *k; + + /* 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; HeVAL(entry) = Nullsv; HeNEXT(entry) = *oentry; *oentry = entry; + xhv->xhv_keys++; /* HvKEYS(hv)++ */ if (!old_first) { /* initial entry? */ xhv->xhv_fill++; /* HvFILL(hv)++ */ @@ -2349,7 +2365,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) if (flags & HVhek_FREEKEY) Safefree(str); - return entry; + return HeKEY_hek(entry); } I32 * @@ -2373,7 +2389,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; } @@ -2382,7 +2398,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;