sv_clear can manipulate the arena array directly too.
[p5sagit/p5-mst-13.2.git] / sv.c
diff --git a/sv.c b/sv.c
index 6c56409..3f70368 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1275,11 +1275,19 @@ static const struct body_details bodies_by_type[] = {
     /* 64 */
     {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
     /* 20 */
-    {sizeof(xpvav_allocated), sizeof(xpvav_allocated),
+    {sizeof(xpvav_allocated),
+     STRUCT_OFFSET(XPVAV, xmg_stash)
+     + sizeof (((XPVAV*)SvANY((SV *)0))->xmg_stash)
+     + STRUCT_OFFSET(xpvav_allocated, xav_fill)
+     - STRUCT_OFFSET(XPVAV, xav_fill),
      STRUCT_OFFSET(xpvav_allocated, xav_fill)
      - STRUCT_OFFSET(XPVAV, xav_fill), TRUE, HADNV, HASARENA},
     /* 20 */
-    {sizeof(xpvhv_allocated), sizeof(xpvhv_allocated), 
+    {sizeof(xpvhv_allocated),
+     STRUCT_OFFSET(XPVHV, xmg_stash)
+     + sizeof (((XPVHV*)SvANY((SV *)0))->xmg_stash)
+     + STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
+     - STRUCT_OFFSET(XPVHV, xhv_fill),
      STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
      - STRUCT_OFFSET(XPVHV, xhv_fill), TRUE, HADNV, HASARENA},
     /* 76 */
@@ -1384,7 +1392,10 @@ static const struct body_details bodies_by_type[] = {
 
 /* no arena for you! */
 
-#define new_NOARENA(s) my_safecalloc(s)
+#define new_NOARENA(details) \
+       my_safemalloc((details)->size - (details)->offset)
+#define new_NOARENAZ(details) \
+       my_safecalloc((details)->size - (details)->offset)
 
 #define new_XPVFM()    my_safemalloc(sizeof(XPVFM))
 #define del_XPVFM(p)   my_safefree(p)
@@ -1409,8 +1420,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
 {
     void*      old_body;
     void*      new_body;
-    size_t     new_body_length;
-    size_t     new_body_offset;
     const U32  old_type = SvTYPE(sv);
     const struct body_details *const old_type_details
        = bodies_by_type + old_type;
@@ -1429,8 +1438,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
 
 
     old_body = SvANY(sv);
-    new_body_offset = 0;
-    new_body_length = ~0;
 
     /* Copying structures onto other structures that have been neatly zeroed
        has a subtle gotcha. Consider XPVMG
@@ -1568,50 +1575,36 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
        }
        break;
 
+
+    case SVt_PVIV:
+       /* XXX Is this still needed?  Was it ever needed?   Surely as there is
+          no route from NV to PVIV, NOK can never be true  */
+       assert(!SvNOKp(sv));
+       assert(!SvNOK(sv));
     case SVt_PVIO:
     case SVt_PVFM:
-       new_body = new_NOARENA(new_type_details->size);
-       new_body_length = new_type_details->copy;
-       goto post_zero;
-
     case SVt_PVBM:
     case SVt_PVGV:
     case SVt_PVCV:
     case SVt_PVLV:
     case SVt_PVMG:
     case SVt_PVNV:
-       new_body_length = bodies_by_type[new_type].size;
-       goto new_body;
-
-    case SVt_PVIV:
-       new_body_offset = - bodies_by_type[SVt_PVIV].offset;
-       new_body_length = sizeof(XPVIV) - new_body_offset;
-       /* XXX Is this still needed?  Was it ever needed?   Surely as there is
-          no route from NV to PVIV, NOK can never be true  */
-       assert(!SvNOKp(sv));
-       assert(!SvNOK(sv));
-       goto new_body_no_NV; 
     case SVt_PV:
-       new_body_offset = - bodies_by_type[SVt_PV].offset;
-       new_body_length = sizeof(XPV) - new_body_offset;
-    new_body_no_NV:
-       /* PV and PVIV don't have an NV slot.  */
 
-    new_body:
-       assert(new_body_length);
+       assert(new_type_details->size);
 #ifndef PURIFY
-       /* This points to the start of the allocated area.  */
-       new_body_inline(new_body, new_body_length, new_type);
+       if(new_type_details->arena) {
+           /* This points to the start of the allocated area.  */
+           new_body_inline(new_body, new_type_details->size, new_type);
+           Zero(new_body, new_type_details->size, char);
+           new_body = ((char *)new_body) + new_type_details->offset;
+       } else {
+           new_body = new_NOARENAZ(new_type_details);
+       }
 #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);
-
+       new_body = new_NOARENAZ(new_type_details);
 #endif
-       Zero(new_body, new_body_length, char);
-    post_zero:
-       new_body = ((char *)new_body) - new_body_offset;
        SvANY(sv) = new_body;
 
        if (old_type_details->copy) {
@@ -5358,9 +5351,9 @@ void
 Perl_sv_clear(pTHX_ register SV *sv)
 {
     dVAR;
-    void** old_body_arena;
-    size_t old_body_offset;
     const U32 type = SvTYPE(sv);
+    const struct body_details *const sv_type_details
+       = bodies_by_type + type;
 
     assert(sv);
     assert(SvREFCNT(sv) == 0);
@@ -5368,9 +5361,6 @@ Perl_sv_clear(pTHX_ register SV *sv)
     if (type <= SVt_IV)
        return;
 
-    old_body_arena = 0;
-    old_body_offset = 0;
-
     if (SvOBJECT(sv)) {
        if (PL_defstash) {              /* Still have a symbol table? */
            dSP;
@@ -5442,26 +5432,18 @@ Perl_sv_clear(pTHX_ register SV *sv)
        Safefree(IoTOP_NAME(sv));
        Safefree(IoFMT_NAME(sv));
        Safefree(IoBOTTOM_NAME(sv));
-       /* PVIOs aren't from arenas  */
        goto freescalar;
     case SVt_PVBM:
-       old_body_arena = &PL_body_roots[SVt_PVBM];
        goto freescalar;
     case SVt_PVCV:
-       old_body_arena = &PL_body_roots[SVt_PVCV];
     case SVt_PVFM:
-       /* PVFMs aren't from arenas  */
        cv_undef((CV*)sv);
        goto freescalar;
     case SVt_PVHV:
        hv_undef((HV*)sv);
-       old_body_arena = &PL_body_roots[SVt_PVHV];
-       old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
        break;
     case SVt_PVAV:
        av_undef((AV*)sv);
-       old_body_arena = &PL_body_roots[SVt_PVAV];
-       old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
        break;
     case SVt_PVLV:
        if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
@@ -5471,7 +5453,6 @@ Perl_sv_clear(pTHX_ register SV *sv)
        }
        else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
            SvREFCNT_dec(LvTARG(sv));
-       old_body_arena = &PL_body_roots[SVt_PVLV];
        goto freescalar;
     case SVt_PVGV:
        gp_free((GV*)sv);
@@ -5480,29 +5461,17 @@ Perl_sv_clear(pTHX_ register SV *sv)
           have a back reference to us, which needs to be cleared.  */
        if (GvSTASH(sv))
            sv_del_backref((SV*)GvSTASH(sv), sv);
-       old_body_arena = &PL_body_roots[SVt_PVGV];
-       goto freescalar;
     case SVt_PVMG:
-       old_body_arena = &PL_body_roots[SVt_PVMG];
-       goto freescalar;
     case SVt_PVNV:
-       old_body_arena = &PL_body_roots[SVt_PVNV];
-       goto freescalar;
     case SVt_PVIV:
-       old_body_arena = &PL_body_roots[SVt_PVIV];
-       old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
       freescalar:
        /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
        if (SvOOK(sv)) {
            SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
            /* Don't even bother with turning off the OOK flag.  */
        }
-       goto pvrv_common;
     case SVt_PV:
-       old_body_arena = &PL_body_roots[SVt_PV];
-       old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
     case SVt_RV:
-    pvrv_common:
        if (SvROK(sv)) {
            SV *target = SvRV(sv);
            if (SvWEAKREF(sv))
@@ -5537,7 +5506,6 @@ Perl_sv_clear(pTHX_ register SV *sv)
 #endif
        break;
     case SVt_NV:
-       old_body_arena = PL_body_roots[SVt_NV];
        break;
     }
 
@@ -5545,14 +5513,18 @@ Perl_sv_clear(pTHX_ register SV *sv)
     SvFLAGS(sv) |= SVTYPEMASK;
 
 #ifndef PURIFY
-    if (old_body_arena) {
-       del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
+    if (sv_type_details->arena) {
+       del_body(((char *)SvANY(sv) - sv_type_details->offset),
+                &PL_body_roots[type]);
+    }
+    else if (sv_type_details->size) {
+       my_safefree(SvANY(sv));
+    }
+#else
+    if (sv_type_details->size) {
+       my_safefree(SvANY(sv));
     }
-    else
 #endif
-       if (type > SVt_RV) {
-           my_safefree(SvANY(sv));
-       }
 }
 
 /*
@@ -10063,10 +10035,10 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
     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;
-           svtype sv_type = SvTYPE(sstr);
+           const svtype sv_type = SvTYPE(sstr);
+           const struct body_details *const sv_type_details
+               = bodies_by_type + sv_type;
 
            switch (sv_type) {
            default:
@@ -10074,69 +10046,49 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
                           (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_offset = - bodies_by_type[SVt_PVHV].offset;
-
-               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_offset =  - bodies_by_type[SVt_PVAV].offset;
-
-               new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
-                   + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
-                   - new_body_offset;
-               goto new_body;
            case SVt_PVGV:
                if (GvUNIQUE((GV*)sstr)) {
                    /* Do sharing here, and fall through */
                }
+           case SVt_PVIO:
+           case SVt_PVFM:
+           case SVt_PVHV:
+           case SVt_PVAV:
            case SVt_PVBM:
            case SVt_PVCV:
            case SVt_PVLV:
            case SVt_PVMG:
            case SVt_PVNV:
-               new_body_length = bodies_by_type[sv_type].size;
-               goto new_body;
-
            case SVt_PVIV:
-               new_body_offset = - bodies_by_type[SVt_PVIV].offset;
-               new_body_length = sizeof(XPVIV) - new_body_offset;
-               goto new_body; 
            case SVt_PV:
-               new_body_offset = - bodies_by_type[SVt_PV].offset;
-               new_body_length = sizeof(XPV) - new_body_offset;
-           new_body:
-               assert(new_body_length);
+               assert(sv_type_details->copy);
 #ifndef PURIFY
-               new_body_inline(new_body, new_body_length, SvTYPE(sstr));
-
-               new_body = (void*)((char*)new_body - new_body_offset);
+               if (sv_type_details->arena) {
+                   new_body_inline(new_body, sv_type_details->copy, sv_type);
+                   new_body
+                       = (void*)((char*)new_body + sv_type_details->offset);
+               } else {
+                   new_body = new_NOARENA(sv_type_details);
+               }
 #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);
+               new_body = new_NOARENA(sv_type_details);
 #endif
            }
            assert(new_body);
            SvANY(dstr) = new_body;
 
-           Copy(((char*)SvANY(sstr)) + new_body_offset,
-                ((char*)SvANY(dstr)) + new_body_offset,
-                new_body_length, char);
+#ifndef PURIFY
+           Copy(((char*)SvANY(sstr)) - sv_type_details->offset,
+                ((char*)SvANY(dstr)) - sv_type_details->offset,
+                sv_type_details->copy, char);
+#else
+           Copy(((char*)SvANY(sstr)),
+                ((char*)SvANY(dstr)),
+                sv_type_details->size - sv_type_details->offset, char);
+#endif
 
-           if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
+           if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
                Perl_rvpv_dup(aTHX_ dstr, sstr, param);
 
            /* The Copy above means that all the source (unduplicated) pointers
@@ -10144,14 +10096,15 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
               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 (sv_type >= 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));
            }
 
-           switch (SvTYPE(sstr)) {
+           /* The cast silences a GCC warning about unhandled types.  */
+           switch ((int)sv_type) {
            case SVt_PV:
                break;
            case SVt_PVIV: