X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=2d6d84d8c16f17b2d0719435a40809a9663072f2;hb=2522aa67345a7f37d0050d70f341ab3a0b6165b0;hp=a14026dda718dd333f7097eb848c48a4e18124d5;hpb=4cbc76b1bf09108493ca657fbc5ed7ed7b09fdbc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index a14026d..2d6d84d 100644 --- a/sv.c +++ b/sv.c @@ -524,6 +524,43 @@ Perl_sv_free_arenas(pTHX) SV* sva; SV* svanext; void *arena, *arenanext; + int i; + void **arenaroots[] = { + (void**) &PL_xnv_arenaroot, + (void**) &PL_xpv_arenaroot, + (void**) &PL_xpviv_arenaroot, + (void**) &PL_xpvnv_arenaroot, + (void**) &PL_xpvcv_arenaroot, + (void**) &PL_xpvav_arenaroot, + (void**) &PL_xpvhv_arenaroot, + (void**) &PL_xpvmg_arenaroot, + (void**) &PL_xpvgv_arenaroot, + (void**) &PL_xpvlv_arenaroot, + (void**) &PL_xpvbm_arenaroot, + (void**) &PL_he_arenaroot, +#if defined(USE_ITHREADS) + (void**) &PL_pte_arenaroot, +#endif + (void**) 0 + }; + void **roots[] = { + (void**) &PL_xnv_root, + (void**) &PL_xpv_root, + (void**) &PL_xpviv_root, + (void**) &PL_xpvnv_root, + (void**) &PL_xpvcv_root, + (void**) &PL_xpvav_root, + (void**) &PL_xpvhv_root, + (void**) &PL_xpvmg_root, + (void**) &PL_xpvgv_root, + (void**) &PL_xpvlv_root, + (void**) &PL_xpvbm_root, + (void**) &PL_he_root, +#if defined(USE_ITHREADS) + (void**) &PL_pte_root, +#endif + (void**) 0 + }; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -536,107 +573,19 @@ Perl_sv_free_arenas(pTHX) if (!SvFAKE(sva)) Safefree(sva); } + + assert(sizeof(arenaroots) == sizeof(roots)); - for (arena = PL_xnv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xnv_arenaroot = 0; - PL_xnv_root = 0; - - for (arena = PL_xpv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpv_arenaroot = 0; - PL_xpv_root = 0; - - for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpviv_arenaroot = 0; - PL_xpviv_root = 0; - - for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvnv_arenaroot = 0; - PL_xpvnv_root = 0; - - for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvcv_arenaroot = 0; - PL_xpvcv_root = 0; - - for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvav_arenaroot = 0; - PL_xpvav_root = 0; - - for (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvhv_arenaroot = 0; - PL_xpvhv_root = 0; - - for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvmg_arenaroot = 0; - PL_xpvmg_root = 0; - - for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvgv_arenaroot = 0; - PL_xpvgv_root = 0; - - for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvlv_arenaroot = 0; - PL_xpvlv_root = 0; - - for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvbm_arenaroot = 0; - PL_xpvbm_root = 0; + for (i=0; arenaroots[i]; i++) { - { - HE *he; - HE *he_next; - for (he = PL_he_arenaroot; he; he = he_next) { - he_next = HeNEXT(he); - Safefree(he); + arena = *arenaroots[i]; + for (; arena; arena = arenanext) { + arenanext = *(void **)arena; + Safefree(arena); } + *arenaroots[i] = 0; + *roots[i] = 0; } - PL_he_arenaroot = 0; - PL_he_root = 0; - -#if defined(USE_ITHREADS) - { - struct ptr_tbl_ent *pte; - struct ptr_tbl_ent *pte_next; - for (pte = PL_pte_arenaroot; pte; pte = pte_next) { - pte_next = pte->next; - Safefree(pte); - } - } - PL_pte_arenaroot = 0; - PL_pte_root = 0; -#endif if (PL_nice_chunk) Safefree(PL_nice_chunk); @@ -1157,27 +1106,25 @@ S_more_bodies (pTHX_ void **arena_root, void **root, size_t size) /* grab a new thing from the free list, allocating more if necessary */ STATIC void * -S_new_body(pTHX_ void **arena_root, void **root, size_t size, size_t offset) +S_new_body(pTHX_ void **arena_root, void **root, size_t size) { void *xpv; LOCK_SV_MUTEX; xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size); *root = *(void**)xpv; UNLOCK_SV_MUTEX; - return (void*)((char*)xpv - offset); + return xpv; } /* return a thing to the free list */ -STATIC void -S_del_body(pTHX_ void *thing, void **root, size_t offset) -{ - void **real_thing = (void**)((char *)thing + offset); - LOCK_SV_MUTEX; - *real_thing = *root; - *root = (void*)real_thing; - UNLOCK_SV_MUTEX; -} +#define del_body(thing, root) \ + STMT_START { \ + LOCK_SV_MUTEX; \ + *(void **)thing = *root; \ + *root = (void*)thing; \ + UNLOCK_SV_MUTEX; \ + } STMT_END /* Conventionally we simply malloc() a big block of memory, then divide it up into lots of the thing that we're allocating. @@ -1192,8 +1139,10 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) #define new_body(TYPE,lctype) \ S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ (void**)&PL_ ## lctype ## _root, \ - sizeof(TYPE), \ - 0) + sizeof(TYPE)) + +#define del_body_type(p,TYPE,lctype) \ + del_body((void*)p, (void**)&PL_ ## lctype ## _root) /* But for some types, we cheat. The type starts with some members that are never accessed. So we allocate the substructure, starting at the first used @@ -1216,20 +1165,17 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) no longer allocated. */ #define new_body_allocated(TYPE,lctype,member) \ - S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ - (void**)&PL_ ## lctype ## _root, \ - sizeof(lctype ## _allocated), \ - STRUCT_OFFSET(TYPE, member) \ - - STRUCT_OFFSET(lctype ## _allocated, member)) - + (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ + (void**)&PL_ ## lctype ## _root, \ + sizeof(lctype ## _allocated)) - \ + STRUCT_OFFSET(TYPE, member) \ + + STRUCT_OFFSET(lctype ## _allocated, member)) -#define del_body(p,TYPE,lctype) \ - S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, 0) #define del_body_allocated(p,TYPE,lctype,member) \ - S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, \ - STRUCT_OFFSET(TYPE, member) \ - - STRUCT_OFFSET(lctype ## _allocated, member)) + del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \ + - STRUCT_OFFSET(lctype ## _allocated, member)), \ + (void**)&PL_ ## lctype ## _root) #define my_safemalloc(s) (void*)safemalloc(s) #define my_safefree(p) safefree((char*)p) @@ -1272,7 +1218,7 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) #else /* !PURIFY */ #define new_XNV() new_body(NV, xnv) -#define del_XNV(p) del_body(p, NV, xnv) +#define del_XNV(p) del_body_type(p, NV, xnv) #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur) #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur) @@ -1281,10 +1227,10 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) #define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur) #define new_XPVNV() new_body(XPVNV, xpvnv) -#define del_XPVNV(p) del_body(p, XPVNV, xpvnv) +#define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv) #define new_XPVCV() new_body(XPVCV, xpvcv) -#define del_XPVCV(p) del_body(p, XPVCV, xpvcv) +#define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv) #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill) #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill) @@ -1293,16 +1239,16 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) #define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill) #define new_XPVMG() new_body(XPVMG, xpvmg) -#define del_XPVMG(p) del_body(p, XPVMG, xpvmg) +#define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg) #define new_XPVGV() new_body(XPVGV, xpvgv) -#define del_XPVGV(p) del_body(p, XPVGV, xpvgv) +#define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv) #define new_XPVLV() new_body(XPVLV, xpvlv) -#define del_XPVLV(p) del_body(p, XPVLV, xpvlv) +#define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv) #define new_XPVBM() new_body(XPVBM, xpvbm) -#define del_XPVBM(p) del_body(p, XPVBM, xpvbm) +#define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm) #endif /* PURIFY */ @@ -1325,22 +1271,21 @@ You generally want to use the C macro wrapper. See also C. void Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) { - - char* pv; - U32 cur; - U32 len; - IV iv; - NV nv; - MAGIC* magic; - HV* stash; - void* old_body_arena; + void** old_body_arena; size_t old_body_offset; size_t old_body_length; /* Well, the length to copy. */ void* old_body; +#ifndef NV_ZERO_IS_ALLBITS_ZERO + /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct + 0.0 for us. */ bool zero_nv = TRUE; -#ifdef DEBUGGING - U32 old_type = SvTYPE(sv); #endif + void* new_body; + size_t new_body_length; + size_t new_body_offset; + void** new_body_arena; + void** new_body_arenaroot; + U32 old_type = SvTYPE(sv); if (mt != SVt_PV && SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -1353,24 +1298,54 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", (int)SvTYPE(sv), (int)mt); - pv = NULL; - cur = 0; - len = 0; - iv = 0; - nv = 0.0; - magic = NULL; - stash = Nullhv; old_body = SvANY(sv); old_body_arena = 0; old_body_offset = 0; old_body_length = 0; + new_body_offset = 0; + new_body_length = ~0; + + /* Copying structures onto other structures that have been neatly zeroed + has a subtle gotcha. Consider XPVMG + + +------+------+------+------+------+-------+-------+ + | NV | CUR | LEN | IV | MAGIC | STASH | + +------+------+------+------+------+-------+-------+ + 0 4 8 12 16 20 24 28 + + where NVs are aligned to 8 bytes, so that sizeof that structure is + actually 32 bytes long, with 4 bytes of padding at the end: + + +------+------+------+------+------+-------+-------+------+ + | NV | CUR | LEN | IV | MAGIC | STASH | ??? | + +------+------+------+------+------+-------+-------+------+ + 0 4 8 12 16 20 24 28 32 + + so what happens if you allocate memory for this structure: + + +------+------+------+------+------+-------+-------+------+------+... + | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | + +------+------+------+------+------+-------+-------+------+------+... + 0 4 8 12 16 20 24 28 32 36 + + zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you + expect, because you copy the area marked ??? onto GP. Now, ??? may have + started out as zero once, but it's quite possible that it isn't. So now, + rather than a nicely zeroed GP, you have it pointing somewhere random. + Bugs ensue. + + (In fact, GP ends up pointing at a previous GP structure, because the + principle cause of the padding in XPVMG getting garbage is a copy of + sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob) + + So we are careful and work out the size of used parts of all the + structures. */ switch (SvTYPE(sv)) { case SVt_NULL: break; case SVt_IV: - iv = SvIVX(sv); if (mt == SVt_NV) mt = SVt_PVNV; else if (mt < SVt_PVIV) @@ -1379,49 +1354,43 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) old_body_length = sizeof(IV); break; case SVt_NV: - nv = SvNVX(sv); - old_body_arena = PL_xnv_root; + old_body_arena = (void **) &PL_xnv_root; old_body_length = sizeof(NV); +#ifndef NV_ZERO_IS_ALLBITS_ZERO zero_nv = FALSE; - +#endif if (mt < SVt_PVNV) mt = SVt_PVNV; break; case SVt_RV: - pv = (char*)SvRV(sv); break; case SVt_PV: - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - old_body_arena = PL_xpv_root; + old_body_arena = (void **) &PL_xpv_root; old_body_offset = STRUCT_OFFSET(XPV, xpv_cur) - STRUCT_OFFSET(xpv_allocated, xpv_cur); - old_body_length = sizeof(XPV) - old_body_offset; + old_body_length = STRUCT_OFFSET(XPV, xpv_len) + + sizeof (((XPV*)SvANY(sv))->xpv_len) + - old_body_offset; if (mt <= SVt_IV) mt = SVt_PVIV; else if (mt == SVt_NV) mt = SVt_PVNV; break; case SVt_PVIV: - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - old_body_arena = PL_xpviv_root; + old_body_arena = (void **) &PL_xpviv_root; old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) - STRUCT_OFFSET(xpviv_allocated, xpv_cur); - old_body_length = sizeof(XPVIV) - old_body_offset; + old_body_length = STRUCT_OFFSET(XPVIV, xiv_u) + + sizeof (((XPVIV*)SvANY(sv))->xiv_u) + - old_body_offset; break; case SVt_PVNV: - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - nv = SvNVX(sv); - old_body_arena = PL_xpvnv_root; - old_body_length = sizeof(XPVNV); + old_body_arena = (void **) &PL_xpvnv_root; + old_body_length = STRUCT_OFFSET(XPVNV, xiv_u) + + sizeof (((XPVNV*)SvANY(sv))->xiv_u); +#ifndef NV_ZERO_IS_ALLBITS_ZERO zero_nv = FALSE; +#endif break; case SVt_PVMG: /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, @@ -1432,16 +1401,12 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) Given that it only has meaning inside the pad, it shouldn't be set on anything that can get upgraded. */ assert((SvFLAGS(sv) & SVpad_TYPED) == 0); - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - nv = SvNVX(sv); - magic = SvMAGIC(sv); - stash = SvSTASH(sv); - old_body_arena = PL_xpvmg_root; - old_body_length = sizeof(XPVMG); + old_body_arena = (void **) &PL_xpvmg_root; + old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash) + + sizeof (((XPVMG*)SvANY(sv))->xmg_stash); +#ifndef NV_ZERO_IS_ALLBITS_ZERO zero_nv = FALSE; +#endif break; default: Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); @@ -1456,17 +1421,17 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) case SVt_IV: assert(old_type == SVt_NULL); SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvIV_set(sv, iv); + SvIV_set(sv, 0); break; case SVt_NV: assert(old_type == SVt_NULL); SvANY(sv) = new_XNV(); - SvNV_set(sv, nv); + SvNV_set(sv, 0); break; case SVt_RV: assert(old_type == SVt_NULL); SvANY(sv) = &sv->sv_u.svu_rv; - SvRV_set(sv, (SV*)pv); + SvRV_set(sv, 0); break; case SVt_PVHV: SvANY(sv) = new_XPVHV(); @@ -1474,110 +1439,147 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) HvMAX(sv) = 0; HvTOTALKEYS(sv) = 0; - /* Fall through... */ - if (0) { - case SVt_PVAV: - SvANY(sv) = new_XPVAV(); - AvMAX(sv) = -1; - AvFILLp(sv) = -1; - AvALLOC(sv) = 0; - AvREAL_only(sv); - } - /* to here. */ - /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */ - assert(!pv); - /* FIXME. Should be able to remove all this if()... if the above - assertion is genuinely always true. */ - if(SvOOK(sv)) { - pv -= iv; - SvFLAGS(sv) &= ~SVf_OOK; - } - Safefree(pv); + goto hv_av_common; + + case SVt_PVAV: + SvANY(sv) = new_XPVAV(); + AvMAX(sv) = -1; + AvFILLp(sv) = -1; + AvALLOC(sv) = 0; + AvREAL_only(sv); + + hv_av_common: + /* SVt_NULL isn't the only thing upgraded to AV or HV. + The target created by newSVrv also is, and it can have magic. + However, it never has SvPVX set. + */ + if (old_type >= SVt_RV) { + assert(SvPVX_const(sv) == 0); + } + + /* Could put this in the else clause below, as PVMG must have SvPVX + 0 already (the assertion above) */ SvPV_set(sv, (char*)0); - SvMAGIC_set(sv, magic); - SvSTASH_set(sv, stash); + + if (old_type >= SVt_PVMG) { + SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic); + SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + SvMAGIC_set(sv, 0); + SvSTASH_set(sv, 0); + } break; case SVt_PVIO: - SvANY(sv) = new_XPVIO(); - Zero(SvANY(sv), 1, XPVIO); - IoPAGE_LEN(sv) = 60; - goto set_magic_common; + new_body = new_XPVIO(); + new_body_length = sizeof(XPVIO); + goto zero; case SVt_PVFM: - SvANY(sv) = new_XPVFM(); - Zero(SvANY(sv), 1, XPVFM); - goto set_magic_common; + new_body = new_XPVFM(); + new_body_length = sizeof(XPVFM); + goto zero; + case SVt_PVBM: - SvANY(sv) = new_XPVBM(); - BmRARE(sv) = 0; - BmUSEFUL(sv) = 0; - BmPREVIOUS(sv) = 0; - goto set_magic_common; + new_body_length = sizeof(XPVBM); + new_body_arena = (void **) &PL_xpvbm_root; + new_body_arenaroot = (void **) &PL_xpvbm_arenaroot; + goto new_body; case SVt_PVGV: - SvANY(sv) = new_XPVGV(); - GvGP(sv) = 0; - GvNAME(sv) = 0; - GvNAMELEN(sv) = 0; - GvSTASH(sv) = 0; - GvFLAGS(sv) = 0; - goto set_magic_common; + new_body_length = sizeof(XPVGV); + new_body_arena = (void **) &PL_xpvgv_root; + new_body_arenaroot = (void **) &PL_xpvgv_arenaroot; + goto new_body; case SVt_PVCV: - SvANY(sv) = new_XPVCV(); - Zero(SvANY(sv), 1, XPVCV); - goto set_magic_common; + new_body_length = sizeof(XPVCV); + new_body_arena = (void **) &PL_xpvcv_root; + new_body_arenaroot = (void **) &PL_xpvcv_arenaroot; + goto new_body; case SVt_PVLV: - SvANY(sv) = new_XPVLV(); - LvTARGOFF(sv) = 0; - LvTARGLEN(sv) = 0; - LvTARG(sv) = 0; - LvTYPE(sv) = 0; - GvGP(sv) = 0; - GvNAME(sv) = 0; - GvNAMELEN(sv) = 0; - GvSTASH(sv) = 0; - GvFLAGS(sv) = 0; - /* Fall through. */ - if (0) { - case SVt_PVMG: - SvANY(sv) = new_XPVMG(); - } - set_magic_common: - SvMAGIC_set(sv, magic); - SvSTASH_set(sv, stash); - /* Fall through. */ - if (0) { - case SVt_PVNV: - SvANY(sv) = new_XPVNV(); - } - SvNV_set(sv, nv); - /* Fall through. */ - if (0) { - case SVt_PVIV: - SvANY(sv) = new_XPVIV(); - if (SvNIOK(sv)) - (void)SvIOK_on(sv); - SvNOK_off(sv); - } - SvIV_set(sv, iv); - /* Fall through. */ - if (0) { - case SVt_PV: - SvANY(sv) = new_XPV(); + new_body_length = sizeof(XPVLV); + new_body_arena = (void **) &PL_xpvlv_root; + new_body_arenaroot = (void **) &PL_xpvlv_arenaroot; + goto new_body; + case SVt_PVMG: + new_body_length = sizeof(XPVMG); + new_body_arena = (void **) &PL_xpvmg_root; + new_body_arenaroot = (void **) &PL_xpvmg_arenaroot; + goto new_body; + case SVt_PVNV: + new_body_length = sizeof(XPVNV); + new_body_arena = (void **) &PL_xpvnv_root; + new_body_arenaroot = (void **) &PL_xpvnv_arenaroot; + goto new_body; + case SVt_PVIV: + new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) + - STRUCT_OFFSET(xpviv_allocated, xpv_cur); + new_body_length = sizeof(XPVIV) - new_body_offset; + new_body_arena = (void **) &PL_xpviv_root; + new_body_arenaroot = (void **) &PL_xpviv_arenaroot; + /* XXX Is this still needed? Was it ever needed? Surely as there is + no route from NV to PVIV, NOK can never be true */ + if (SvNIOK(sv)) + (void)SvIOK_on(sv); + SvNOK_off(sv); + goto new_body_no_NV; + case SVt_PV: + new_body_offset = STRUCT_OFFSET(XPV, xpv_cur) + - STRUCT_OFFSET(xpv_allocated, xpv_cur); + new_body_length = sizeof(XPV) - new_body_offset; + new_body_arena = (void **) &PL_xpv_root; + new_body_arenaroot = (void **) &PL_xpv_arenaroot; + new_body_no_NV: + /* PV and PVIV don't have an NV slot. */ +#ifndef NV_ZERO_IS_ALLBITS_ZERO + zero_nv = FALSE; +#endif + + new_body: + assert(new_body_length); +#ifndef PURIFY + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ new_body_arenaroot, new_body_arena, + new_body_length); +#else + /* We always allocated the full length item with PURIFY */ + new_body_length += new_body_offset; + new_body_offset = 0; + new_body = my_safemalloc(new_body_length); + +#endif + zero: + Zero(new_body, new_body_length, char); + new_body = ((char *)new_body) - new_body_offset; + SvANY(sv) = new_body; + + if (old_body_length) { + Copy((char *)old_body + old_body_offset, + (char *)new_body + old_body_offset, + old_body_length, char); } - SvPV_set(sv, pv); - SvCUR_set(sv, cur); - SvLEN_set(sv, len); + +#ifndef NV_ZERO_IS_ALLBITS_ZERO + if (zero_nv) + SvNV_set(sv, 0); +#endif + + if (mt == SVt_PVIO) + IoPAGE_LEN(sv) = 60; + if (old_type < SVt_RV) + SvPV_set(sv, 0); break; + default: + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt); } if (old_body_arena) { #ifdef PURIFY - my_safefree(old_body) + my_safefree(old_body); #else - S_del_body(aTHX_ old_body, old_body_arena, old_body_offset); + del_body((void*)((char*)old_body + old_body_offset), + old_body_arena); #endif -} + } } /* @@ -10101,7 +10103,7 @@ Perl_ptr_table_new(pTHX) #endif #define new_pte() new_body(struct ptr_tbl_ent, pte) -#define del_pte(p) del_body(p, struct ptr_tbl_ent, pte) +#define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte) /* map an existing pointer using a table */ @@ -10286,8 +10288,6 @@ S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param) return sstr; /* he_dup() will SvREFCNT_inc() */ } -/* duplicate an SV of any type (including AV, HV etc) */ - void Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) { @@ -10332,6 +10332,8 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) } } +/* duplicate an SV of any type (including AV, HV etc) */ + SV * Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) { @@ -10409,273 +10411,297 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = &(dstr->sv_u.svu_rv); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; - case SVt_PV: - SvANY(dstr) = new_XPV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - break; - case SVt_PVIV: - SvANY(dstr) = new_XPVIV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - break; - case SVt_PVNV: - SvANY(dstr) = new_XPVNV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - break; - case SVt_PVMG: - SvANY(dstr) = new_XPVMG(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - break; - case SVt_PVBM: - SvANY(dstr) = new_XPVBM(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - BmRARE(dstr) = BmRARE(sstr); - BmUSEFUL(dstr) = BmUSEFUL(sstr); - BmPREVIOUS(dstr)= BmPREVIOUS(sstr); - break; - case SVt_PVLV: - SvANY(dstr) = new_XPVLV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ - LvTARGLEN(dstr) = LvTARGLEN(sstr); - if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */ - LvTARG(dstr) = dstr; - else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */ - LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param); - else - LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); - LvTYPE(dstr) = LvTYPE(sstr); - break; - case SVt_PVGV: - if (GvUNIQUE((GV*)sstr)) { - SV *share; - if ((share = gv_share(sstr, param))) { - del_SV(dstr); - dstr = share; - ptr_table_store(PL_ptr_table, sstr, dstr); + default: + { + /* These are all the types that need complex bodies allocating. */ + size_t new_body_length; + size_t new_body_offset = 0; + void **new_body_arena; + void **new_body_arenaroot; + void *new_body; + + switch (SvTYPE(sstr)) { + default: + Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", + (IV)SvTYPE(sstr)); + break; + + case SVt_PVIO: + new_body = new_XPVIO(); + new_body_length = sizeof(XPVIO); + break; + case SVt_PVFM: + new_body = new_XPVFM(); + new_body_length = sizeof(XPVFM); + break; + + case SVt_PVHV: + new_body_arena = (void **) &PL_xpvhv_root; + new_body_arenaroot = (void **) &PL_xpvhv_arenaroot; + new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill) + - STRUCT_OFFSET(xpvhv_allocated, xhv_fill); + new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) + + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) + - new_body_offset; + goto new_body; + case SVt_PVAV: + new_body_arena = (void **) &PL_xpvav_root; + new_body_arenaroot = (void **) &PL_xpvav_arenaroot; + new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill) + - STRUCT_OFFSET(xpvav_allocated, xav_fill); + new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) + + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) + - new_body_offset; + goto new_body; + case SVt_PVBM: + new_body_length = sizeof(XPVBM); + new_body_arena = (void **) &PL_xpvbm_root; + new_body_arenaroot = (void **) &PL_xpvbm_arenaroot; + goto new_body; + case SVt_PVGV: + if (GvUNIQUE((GV*)sstr)) { + SV *share; + if ((share = gv_share(sstr, param))) { + del_SV(dstr); + dstr = share; + ptr_table_store(PL_ptr_table, sstr, dstr); #if 0 - PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n", - HvNAME_get(GvSTASH(share)), GvNAME(share)); + PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n", + HvNAME_get(GvSTASH(share)), GvNAME(share)); +#endif + goto done_share; + } + } + new_body_length = sizeof(XPVGV); + new_body_arena = (void **) &PL_xpvgv_root; + new_body_arenaroot = (void **) &PL_xpvgv_arenaroot; + goto new_body; + case SVt_PVCV: + new_body_length = sizeof(XPVCV); + new_body_arena = (void **) &PL_xpvcv_root; + new_body_arenaroot = (void **) &PL_xpvcv_arenaroot; + goto new_body; + case SVt_PVLV: + new_body_length = sizeof(XPVLV); + new_body_arena = (void **) &PL_xpvlv_root; + new_body_arenaroot = (void **) &PL_xpvlv_arenaroot; + goto new_body; + case SVt_PVMG: + new_body_length = sizeof(XPVMG); + new_body_arena = (void **) &PL_xpvmg_root; + new_body_arenaroot = (void **) &PL_xpvmg_arenaroot; + goto new_body; + case SVt_PVNV: + new_body_length = sizeof(XPVNV); + new_body_arena = (void **) &PL_xpvnv_root; + new_body_arenaroot = (void **) &PL_xpvnv_arenaroot; + goto new_body; + case SVt_PVIV: + new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) + - STRUCT_OFFSET(xpviv_allocated, xpv_cur); + new_body_length = sizeof(XPVIV) - new_body_offset; + new_body_arena = (void **) &PL_xpviv_root; + new_body_arenaroot = (void **) &PL_xpviv_arenaroot; + goto new_body; + case SVt_PV: + new_body_offset = STRUCT_OFFSET(XPV, xpv_cur) + - STRUCT_OFFSET(xpv_allocated, xpv_cur); + new_body_length = sizeof(XPV) - new_body_offset; + new_body_arena = (void **) &PL_xpv_root; + new_body_arenaroot = (void **) &PL_xpv_arenaroot; + new_body: + assert(new_body_length); +#ifndef PURIFY + new_body = (void*)((char*)S_new_body(aTHX_ new_body_arenaroot, + new_body_arena, + new_body_length) + - new_body_offset); +#else + /* We always allocated the full length item with PURIFY */ + new_body_length += new_body_offset; + new_body_offset = 0; + new_body = my_safemalloc(new_body_length); #endif - break; - } - } - SvANY(dstr) = new_XPVGV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - GvNAMELEN(dstr) = GvNAMELEN(sstr); - GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr)); - GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param); - GvFLAGS(dstr) = GvFLAGS(sstr); - GvGP(dstr) = gp_dup(GvGP(sstr), param); - (void)GpREFCNT_inc(GvGP(dstr)); - break; - case SVt_PVIO: - SvANY(dstr) = new_XPVIO(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param); - if (IoOFP(sstr) == IoIFP(sstr)) - IoOFP(dstr) = IoIFP(dstr); - else - IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param); - /* PL_rsfp_filters entries have fake IoDIRP() */ - if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) - IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); - else - IoDIRP(dstr) = IoDIRP(sstr); - IoLINES(dstr) = IoLINES(sstr); - IoPAGE(dstr) = IoPAGE(sstr); - IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); - IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); - if(IoFLAGS(sstr) & IOf_FAKE_DIRP) { - /* I have no idea why fake dirp (rsfps) - should be treaded differently but otherwise - we end up with leaks -- sky*/ - IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param); - IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param); - IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param); - } else { - IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); - IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); - IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); - } - IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); - IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); - IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); - IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); - IoTYPE(dstr) = IoTYPE(sstr); - IoFLAGS(dstr) = IoFLAGS(sstr); - break; - case SVt_PVAV: - SvANY(dstr) = new_XPVAV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - if (AvARRAY((AV*)sstr)) { - SV **dst_ary, **src_ary; - SSize_t items = AvFILLp((AV*)sstr) + 1; - - src_ary = AvARRAY((AV*)sstr); - Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); - ptr_table_store(PL_ptr_table, src_ary, dst_ary); - SvPV_set(dstr, (char*)dst_ary); - AvALLOC((AV*)dstr) = dst_ary; - if (AvREAL((AV*)sstr)) { - while (items-- > 0) - *dst_ary++ = sv_dup_inc(*src_ary++, param); - } - else { - while (items-- > 0) - *dst_ary++ = sv_dup(*src_ary++, param); } - items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); - while (items-- > 0) { - *dst_ary++ = &PL_sv_undef; + assert(new_body); + SvANY(dstr) = new_body; + + Copy(((char*)SvANY(sstr)) + new_body_offset, + ((char*)SvANY(dstr)) + new_body_offset, + new_body_length, char); + + if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV) + Perl_rvpv_dup(aTHX_ dstr, sstr, param); + + /* The Copy above means that all the source (unduplicated) pointers + are now in the destination. We can check the flags and the + pointers in either, but it's possible that there's less cache + missing by always going for the destination. + FIXME - instrument and check that assumption */ + if (SvTYPE(sstr) >= SVt_PVMG) { + if (SvMAGIC(dstr)) + SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); + if (SvSTASH(dstr)) + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); } - } - else { - SvPV_set(dstr, Nullch); - AvALLOC((AV*)dstr) = (SV**)NULL; - } - break; - case SVt_PVHV: - SvANY(dstr) = new_XPVHV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - { - HEK *hvname = 0; - - if (HvARRAY((HV*)sstr)) { - STRLEN i = 0; - const bool sharekeys = !!HvSHAREKEYS(sstr); - XPVHV * const dxhv = (XPVHV*)SvANY(dstr); - XPVHV * const sxhv = (XPVHV*)SvANY(sstr); - char *darray; - New(0, darray, - PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) - + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char); - HvARRAY(dstr) = (HE**)darray; - while (i <= sxhv->xhv_max) { - HE *source = HvARRAY(sstr)[i]; - HvARRAY(dstr)[i] - = source ? he_dup(source, sharekeys, param) : 0; - ++i; + + switch (SvTYPE(sstr)) { + case SVt_PV: + break; + case SVt_PVIV: + break; + case SVt_PVNV: + break; + case SVt_PVMG: + break; + case SVt_PVBM: + break; + case SVt_PVLV: + /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ + if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ + LvTARG(dstr) = dstr; + else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ + LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param); + else + LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); + break; + case SVt_PVGV: + GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr)); + GvSTASH(dstr) = hv_dup_inc(GvSTASH(dstr), param); + GvGP(dstr) = gp_dup(GvGP(dstr), param); + (void)GpREFCNT_inc(GvGP(dstr)); + break; + case SVt_PVIO: + IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param); + if (IoOFP(dstr) == IoIFP(sstr)) + IoOFP(dstr) = IoIFP(dstr); + else + IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); + /* PL_rsfp_filters entries have fake IoDIRP() */ + if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)) + IoDIRP(dstr) = dirp_dup(IoDIRP(dstr)); + if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { + /* I have no idea why fake dirp (rsfps) + should be treated differently but otherwise + we end up with leaks -- sky*/ + IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param); + IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param); + IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param); + } else { + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param); } - if (SvOOK(sstr)) { - struct xpvhv_aux *saux = HvAUX(sstr); - struct xpvhv_aux *daux = HvAUX(dstr); - /* This flag isn't copied. */ - /* SvOOK_on(hv) attacks the IV flags. */ - SvFLAGS(dstr) |= SVf_OOK; - - hvname = saux->xhv_name; - daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname; - - daux->xhv_riter = saux->xhv_riter; - daux->xhv_eiter = saux->xhv_eiter - ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr), - param) : 0; + IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr)); + IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr)); + IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); + break; + case SVt_PVAV: + if (AvARRAY((AV*)sstr)) { + SV **dst_ary, **src_ary; + SSize_t items = AvFILLp((AV*)sstr) + 1; + + src_ary = AvARRAY((AV*)sstr); + Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); + SvPV_set(dstr, (char*)dst_ary); + AvALLOC((AV*)dstr) = dst_ary; + if (AvREAL((AV*)sstr)) { + while (items-- > 0) + *dst_ary++ = sv_dup_inc(*src_ary++, param); + } + else { + while (items-- > 0) + *dst_ary++ = sv_dup(*src_ary++, param); + } + items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); + while (items-- > 0) { + *dst_ary++ = &PL_sv_undef; + } } + else { + SvPV_set(dstr, Nullch); + AvALLOC((AV*)dstr) = (SV**)NULL; + } + break; + case SVt_PVHV: + { + HEK *hvname = 0; + + if (HvARRAY((HV*)sstr)) { + STRLEN i = 0; + const bool sharekeys = !!HvSHAREKEYS(sstr); + XPVHV * const dxhv = (XPVHV*)SvANY(dstr); + XPVHV * const sxhv = (XPVHV*)SvANY(sstr); + char *darray; + New(0, darray, + PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), + char); + HvARRAY(dstr) = (HE**)darray; + while (i <= sxhv->xhv_max) { + HE *source = HvARRAY(sstr)[i]; + HvARRAY(dstr)[i] = source + ? he_dup(source, sharekeys, param) : 0; + ++i; + } + if (SvOOK(sstr)) { + struct xpvhv_aux *saux = HvAUX(sstr); + struct xpvhv_aux *daux = HvAUX(dstr); + /* This flag isn't copied. */ + /* SvOOK_on(hv) attacks the IV flags. */ + SvFLAGS(dstr) |= SVf_OOK; + + hvname = saux->xhv_name; + daux->xhv_name + = hvname ? hek_dup(hvname, param) : hvname; + + daux->xhv_riter = saux->xhv_riter; + daux->xhv_eiter = saux->xhv_eiter + ? he_dup(saux->xhv_eiter, + (bool)!!HvSHAREKEYS(sstr), param) : 0; + } + } + else { + SvPV_set(dstr, Nullch); + } + /* Record stashes for possible cloning in Perl_clone(). */ + if(hvname) + av_push(param->stashes, dstr); + } + break; + case SVt_PVFM: + case SVt_PVCV: + /* NOTE: not refcounted */ + CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param); + OP_REFCNT_LOCK; + CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); + OP_REFCNT_UNLOCK; + if (CvCONST(dstr)) { + CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ? + SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) : + sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param); + } + /* don't dup if copying back - CvGV isn't refcounted, so the + * duped GV may never be freed. A bit of a hack! DAPM */ + CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? + Nullgv : gv_dup(CvGV(dstr), param) ; + if (!(param->flags & CLONEf_COPY_STACKS)) { + CvDEPTH(dstr) = 0; + } + PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + CvOUTSIDE(dstr) = + CvWEAKOUTSIDE(sstr) + ? cv_dup( CvOUTSIDE(dstr), param) + : cv_dup_inc(CvOUTSIDE(dstr), param); + if (!CvXSUB(dstr)) + CvFILE(dstr) = SAVEPV(CvFILE(dstr)); + break; } - else { - SvPV_set(dstr, Nullch); - } - /* Record stashes for possible cloning in Perl_clone(). */ - if(hvname) - av_push(param->stashes, dstr); } - break; - case SVt_PVFM: - SvANY(dstr) = new_XPVFM(); - FmLINES(dstr) = FmLINES(sstr); - goto dup_pvcv; - /* NOTREACHED */ - case SVt_PVCV: - SvANY(dstr) = new_XPVCV(); - dup_pvcv: - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvIV_set(dstr, SvIVX(sstr)); - SvNV_set(dstr, SvNVX(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */ - CvSTART(dstr) = CvSTART(sstr); - OP_REFCNT_LOCK; - CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); - OP_REFCNT_UNLOCK; - CvXSUB(dstr) = CvXSUB(sstr); - CvXSUBANY(dstr) = CvXSUBANY(sstr); - if (CvCONST(sstr)) { - CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ? - SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) : - sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param); - } - /* don't dup if copying back - CvGV isn't refcounted, so the - * duped GV may never be freed. A bit of a hack! DAPM */ - CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? - Nullgv : gv_dup(CvGV(sstr), param) ; - if (param->flags & CLONEf_COPY_STACKS) { - CvDEPTH(dstr) = CvDEPTH(sstr); - } else { - CvDEPTH(dstr) = 0; - } - PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); - CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr); - CvOUTSIDE(dstr) = - CvWEAKOUTSIDE(sstr) - ? cv_dup( CvOUTSIDE(sstr), param) - : cv_dup_inc(CvOUTSIDE(sstr), param); - CvFLAGS(dstr) = CvFLAGS(sstr); - CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); - break; - default: - Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); - break; } + done_share: if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) ++PL_sv_objcount; @@ -11558,7 +11584,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_mess_sv = Nullsv; PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); - PL_ofmt = SAVEPV(proto_perl->Iofmt); /* interpreter atexit processing */ PL_exitlistlen = proto_perl->Iexitlistlen;