Move report_uninit() and its static supporting functions to the end of
Nicholas Clark [Fri, 25 Nov 2005 15:12:02 +0000 (15:12 +0000)]
sv.c, so that they are not sandwiched between the two halves of the
SV allocation code. However, the diff looks far more evil than it
should given that this is just moving a single albeit large hunk.

p4raw-id: //depot/perl@26205

sv.c

diff --git a/sv.c b/sv.c
index 206cd2e..add0e9b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -602,1280 +602,807 @@ Perl_sv_free_arenas(pTHX)
     PL_sv_root = 0;
 }
 
-/* ---------------------------------------------------------------------
- *
- * support functions for report_uninit()
- */
+/*
+  Here are mid-level routines that manage the allocation of bodies out
+  of the various arenas.  There are 5 kinds of arenas:
 
-/* the maxiumum size of array or hash where we will scan looking
- * for the undefined element that triggered the warning */
+  1. SV-head arenas, which are discussed and handled above
+  2. regular body arenas
+  3. arenas for reduced-size bodies
+  4. Hash-Entry arenas
+  5. pte arenas (thread related)
 
-#define FUV_MAX_SEARCH_SIZE 1000
+  Arena types 2 & 3 are chained by body-type off an array of
+  arena-root pointers, which is indexed by svtype.  Some of the
+  larger/less used body types are malloced singly, since a large
+  unused block of them is wasteful.  Also, several svtypes dont have
+  bodies; the data fits into the sv-head itself.  The arena-root
+  pointer thus has a few unused root-pointers (which may be hijacked
+  later for arena types 4,5)
 
-/* Look for an entry in the hash whose value has the same SV as val;
- * If so, return a mortal copy of the key. */
+  3 differs from 2 as an optimization; some body types have several
+  unused fields in the front of the structure (which are kept in-place
+  for consistency).  These bodies can be allocated in smaller chunks,
+  because the leading fields arent accessed.  Pointers to such bodies
+  are decremented to point at the unused 'ghost' memory, knowing that
+  the pointers are used with offsets to the real memory.
 
-STATIC SV*
-S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+  HE, HEK arenas are managed separately, with separate code, but may
+  be merge-able later..
+
+  PTE arenas are not sv-bodies, but they share these mid-level
+  mechanics, so are considered here.  The new mid-level mechanics rely
+  on the sv_type of the body being allocated, so we just reserve one
+  of the unused body-slots for PTEs, then use it in those (2) PTE
+  contexts below (line ~10k)
+*/
+
+STATIC void *
+S_more_bodies (pTHX_ size_t size, svtype sv_type)
 {
-    dVAR;
-    register HE **array;
-    I32 i;
+    void **arena_root  = &PL_body_arenaroots[sv_type];
+    void **root                = &PL_body_roots[sv_type];
+    char *start;
+    const char *end;
+    const size_t count = PERL_ARENA_SIZE / size;
 
-    if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
-                       (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
-       return Nullsv;
+    Newx(start, count*size, char);
+    *((void **) start) = *arena_root;
+    *arena_root = (void *)start;
 
-    array = HvARRAY(hv);
+    end = start + (count-1) * size;
 
-    for (i=HvMAX(hv); i>0; i--) {
-       register HE *entry;
-       for (entry = array[i]; entry; entry = HeNEXT(entry)) {
-           if (HeVAL(entry) != val)
-               continue;
-           if (    HeVAL(entry) == &PL_sv_undef ||
-                   HeVAL(entry) == &PL_sv_placeholder)
-               continue;
-           if (!HeKEY(entry))
-               return Nullsv;
-           if (HeKLEN(entry) == HEf_SVKEY)
-               return sv_mortalcopy(HeKEY_sv(entry));
-           return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
-       }
-    }
-    return Nullsv;
-}
+    /* The initial slot is used to link the arenas together, so it isn't to be
+       linked into the list of ready-to-use bodies.  */
 
-/* Look for an entry in the array whose value has the same SV as val;
- * If so, return the index, otherwise return -1. */
+    start += size;
 
-STATIC I32
-S_find_array_subscript(pTHX_ AV *av, SV* val)
-{
-    SV** svp;
-    I32 i;
-    if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
-                       (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
-       return -1;
+    *root = (void *)start;
 
-    svp = AvARRAY(av);
-    for (i=AvFILLp(av); i>=0; i--) {
-       if (svp[i] == val && svp[i] != &PL_sv_undef)
-           return i;
+    while (start < end) {
+       char * const next = start + size;
+       *(void**) start = (void *)next;
+       start = next;
     }
-    return -1;
+    *(void **)start = 0;
+
+    return *root;
 }
 
-/* S_varname(): return the name of a variable, optionally with a subscript.
- * If gv is non-zero, use the name of that global, along with gvtype (one
- * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
- * targ.  Depending on the value of the subscript_type flag, return:
- */
+/* grab a new thing from the free list, allocating more if necessary */
 
-#define FUV_SUBSCRIPT_NONE     1       /* "@foo"          */
-#define FUV_SUBSCRIPT_ARRAY    2       /* "$foo[aindex]"  */
-#define FUV_SUBSCRIPT_HASH     3       /* "$foo{keyname}" */
-#define FUV_SUBSCRIPT_WITHIN   4       /* "within @foo"   */
+/* 1st, the inline version  */
 
-STATIC SV*
-S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
-       SV* keyname, I32 aindex, int subscript_type)
-{
+#define new_body_inline(xpv, size, sv_type) \
+    STMT_START { \
+       void **r3wt = &PL_body_roots[sv_type]; \
+       LOCK_SV_MUTEX; \
+       xpv = *((void **)(r3wt)) \
+         ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
+       *(r3wt) = *(void**)(xpv); \
+       UNLOCK_SV_MUTEX; \
+    } STMT_END
 
-    SV * const name = sv_newmortal();
-    if (gv) {
-       char buffer[2];
-       buffer[0] = gvtype;
-       buffer[1] = 0;
+/* now use the inline version in the proper function */
 
-       /* as gv_fullname4(), but add literal '^' for $^FOO names  */
+#ifndef PURIFY
 
-       gv_fullname4(name, gv, buffer, 0);
+/* This isn't being used with -DPURIFY, so don't declare it. Otherwise
+   compilers issue warnings.  */
 
-       if ((unsigned int)SvPVX(name)[1] <= 26) {
-           buffer[0] = '^';
-           buffer[1] = SvPVX(name)[1] + 'A' - 1;
+STATIC void *
+S_new_body(pTHX_ size_t size, svtype sv_type)
+{
+    void *xpv;
+    new_body_inline(xpv, size, sv_type);
+    return xpv;
+}
 
-           /* Swap the 1 unprintable control character for the 2 byte pretty
-              version - ie substr($name, 1, 1) = $buffer; */
-           sv_insert(name, 1, 1, buffer, 2);
-       }
-    }
-    else {
-       U32 unused;
-       CV * const cv = find_runcv(&unused);
-       SV *sv;
-       AV *av;
+#endif
 
-       if (!cv || !CvPADLIST(cv))
-           return Nullsv;
-       av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
-       sv = *av_fetch(av, targ, FALSE);
-       /* SvLEN in a pad name is not to be trusted */
-       sv_setpv(name, SvPV_nolen_const(sv));
-    }
+/* return a thing to the free list */
 
-    if (subscript_type == FUV_SUBSCRIPT_HASH) {
-       SV * const sv = NEWSV(0,0);
-       *SvPVX(name) = '$';
-       Perl_sv_catpvf(aTHX_ name, "{%s}",
-           pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
-       SvREFCNT_dec(sv);
-    }
-    else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
-       *SvPVX(name) = '$';
-       Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
-    }
-    else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
-       sv_insert(name, 0, 0,  "within ", 7);
+#define del_body(thing, root)                  \
+    STMT_START {                               \
+       void **thing_copy = (void **)thing;     \
+       LOCK_SV_MUTEX;                          \
+       *thing_copy = *root;                    \
+       *root = (void*)thing_copy;              \
+       UNLOCK_SV_MUTEX;                        \
+    } STMT_END
 
-    return name;
-}
+/* 
+   Revisiting type 3 arenas, there are 4 body-types which have some
+   members that are never accessed.  They are XPV, XPVIV, XPVAV,
+   XPVHV, which have corresponding types: xpv_allocated,
+   xpviv_allocated, xpvav_allocated, xpvhv_allocated,
 
+   For these types, the arenas are carved up into *_allocated size
+   chunks, we thus avoid wasted memory for those unaccessed members.
+   When bodies are allocated, we adjust the pointer back in memory by
+   the size of the bit not allocated, so it's as if we allocated the
+   full structure.  (But things will all go boom if you write to the
+   part that is "not there", because you'll be overwriting the last
+   members of the preceding structure in memory.)
 
-/*
-=for apidoc find_uninit_var
+   We calculate the correction using the STRUCT_OFFSET macro. For example, if
+   xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
+   and the pointer is unchanged. If the allocated structure is smaller (no
+   initial NV actually allocated) then the net effect is to subtract the size
+   of the NV from the pointer, to return a new pointer as if an initial NV were
+   actually allocated.
 
-Find the name of the undefined variable (if any) that caused the operator o
-to issue a "Use of uninitialized value" warning.
-If match is true, only return a name if it's value matches uninit_sv.
-So roughly speaking, if a unary operator (such as OP_COS) generates a
-warning, then following the direct child of the op may yield an
-OP_PADSV or OP_GV that gives the name of the undefined variable. On the
-other hand, with OP_ADD there are two branches to follow, so we only print
-the variable name if we get an exact match.
+   This is the same trick as was used for NV and IV bodies. Ironically it
+   doesn't need to be used for NV bodies any more, because NV is now at the
+   start of the structure. IV bodies don't need it either, because they are
+   no longer allocated.  */
 
-The name is returned as a mortal SV.
+/* The following 2 arrays hide the above details in a pair of
+   lookup-tables, allowing us to be body-type agnostic.
 
-Assumes that PL_op is the op that originally triggered the error, and that
-PL_comppad/PL_curpad points to the currently executing pad.
+   size maps svtype to its body's allocated size.
+   offset maps svtype to the body-pointer adjustment needed
 
-=cut
+   NB: elements in latter are 0 or <0, and are added during
+   allocation, and subtracted during deallocation.  It may be clearer
+   to invert the values, and call it shrinkage_by_svtype.
 */
 
-STATIC SV *
-S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
-{
-    dVAR;
-    SV *sv;
-    AV *av;
-    GV *gv;
-    OP *o, *o2, *kid;
-
-    if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
-                           uninit_sv == &PL_sv_placeholder)))
-       return Nullsv;
+struct body_details {
+    size_t size;       /* Size to allocate  */
+    size_t copy;       /* Size of structure to copy (may be shorter)  */
+    size_t offset;
+    bool cant_upgrade; /* Can upgrade this type */
+    bool zero_nv;      /* zero the NV when upgrading from this */
+    bool arena;                /* Allocated from an arena */
+};
 
-    switch (obase->op_type) {
+#define HADNV FALSE
+#define NONV TRUE
 
-    case OP_RV2AV:
-    case OP_RV2HV:
-    case OP_PADAV:
-    case OP_PADHV:
-      {
-       const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
-       const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
-       I32 index = 0;
-       SV *keysv = Nullsv;
-       int subscript_type = FUV_SUBSCRIPT_WITHIN;
+#ifdef PURIFY
+/* With -DPURFIY we allocate everything directly, and don't use arenas.
+   This seems a rather elegant way to simplify some of the code below.  */
+#define HASARENA FALSE
+#else
+#define HASARENA TRUE
+#endif
+#define NOARENA FALSE
 
-       if (pad) { /* @lex, %lex */
-           sv = PAD_SVl(obase->op_targ);
-           gv = Nullgv;
-       }
-       else {
-           if (cUNOPx(obase)->op_first->op_type == OP_GV) {
-           /* @global, %global */
-               gv = cGVOPx_gv(cUNOPx(obase)->op_first);
-               if (!gv)
-                   break;
-               sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
-           }
-           else /* @{expr}, %{expr} */
-               return find_uninit_var(cUNOPx(obase)->op_first,
-                                                   uninit_sv, match);
-       }
+/* A macro to work out the offset needed to subtract from a pointer to (say)
 
-       /* attempt to find a match within the aggregate */
-       if (hash) {
-           keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
-           if (keysv)
-               subscript_type = FUV_SUBSCRIPT_HASH;
-       }
-       else {
-           index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
-           if (index >= 0)
-               subscript_type = FUV_SUBSCRIPT_ARRAY;
-       }
+typedef struct {
+    STRLEN     xpv_cur;
+    STRLEN     xpv_len;
+} xpv_allocated;
 
-       if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
-           break;
+to make its members accessible via a pointer to (say)
 
-       return varname(gv, hash ? '%' : '@', obase->op_targ,
-                                   keysv, index, subscript_type);
-      }
+struct xpv {
+    NV         xnv_nv;
+    STRLEN     xpv_cur;
+    STRLEN     xpv_len;
+};
 
-    case OP_PADSV:
-       if (match && PAD_SVl(obase->op_targ) != uninit_sv)
-           break;
-       return varname(Nullgv, '$', obase->op_targ,
-                                   Nullsv, 0, FUV_SUBSCRIPT_NONE);
+*/
 
-    case OP_GVSV:
-       gv = cGVOPx_gv(obase);
-       if (!gv || (match && GvSV(gv) != uninit_sv))
-           break;
-       return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
+#define relative_STRUCT_OFFSET(longer, shorter, member) \
+    (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
 
-    case OP_AELEMFAST:
-       if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
-           if (match) {
-               SV **svp;
-               av = (AV*)PAD_SV(obase->op_targ);
-               if (!av || SvRMAGICAL(av))
-                   break;
-               svp = av_fetch(av, (I32)obase->op_private, FALSE);
-               if (!svp || *svp != uninit_sv)
-                   break;
-           }
-           return varname(Nullgv, '$', obase->op_targ,
-                   Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
-       }
-       else {
-           gv = cGVOPx_gv(obase);
-           if (!gv)
-               break;
-           if (match) {
-               SV **svp;
-               av = GvAV(gv);
-               if (!av || SvRMAGICAL(av))
-                   break;
-               svp = av_fetch(av, (I32)obase->op_private, FALSE);
-               if (!svp || *svp != uninit_sv)
-                   break;
-           }
-           return varname(gv, '$', 0,
-                   Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
-       }
-       break;
+/* Calculate the length to copy. Specifically work out the length less any
+   final padding the compiler needed to add.  See the comment in sv_upgrade
+   for why copying the padding proved to be a bug.  */
 
-    case OP_EXISTS:
-       o = cUNOPx(obase)->op_first;
-       if (!o || o->op_type != OP_NULL ||
-               ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
-           break;
-       return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
+#define copy_length(type, last_member) \
+       STRUCT_OFFSET(type, last_member) \
+       + sizeof (((type*)SvANY((SV*)0))->last_member)
 
-    case OP_AELEM:
-    case OP_HELEM:
-       if (PL_op == obase)
-           /* $a[uninit_expr] or $h{uninit_expr} */
-           return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
+static const struct body_details bodies_by_type[] = {
+    {0, 0, 0, FALSE, NONV, NOARENA},
+    /* IVs are in the head, so the allocation size is 0  */
+    {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
+    /* 8 bytes on most ILP32 with IEEE doubles */
+    {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
+    /* RVs are in the head now */
+    /* However, this slot is overloaded and used by the pte  */
+    {0, 0, 0, FALSE, NONV, NOARENA},
+    /* 8 bytes on most ILP32 with IEEE doubles */
+    {sizeof(xpv_allocated),
+     copy_length(XPV, xpv_len)
+     + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
+     - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
+     FALSE, NONV, HASARENA},
+    /* 12 */
+    {sizeof(xpviv_allocated),
+     copy_length(XPVIV, xiv_u)
+     + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
+     - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
+     FALSE, NONV, HASARENA},
+    /* 20 */
+    {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA},
+    /* 28 */
+    {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA},
+    /* 36 */
+    {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
+    /* 48 */
+    {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
+    /* 64 */
+    {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
+    /* 20 */
+    {sizeof(xpvav_allocated),
+     copy_length(XPVAV, xmg_stash)
+     + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
+     - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
+     TRUE, HADNV, HASARENA},
+    /* 20 */
+    {sizeof(xpvhv_allocated),
+     copy_length(XPVHV, xmg_stash)
+     + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
+     - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
+     TRUE, HADNV, HASARENA},
+    /* 76 */
+    {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
+    /* 80 */
+    {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
+    /* 84 */
+    {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
+};
 
-       gv = Nullgv;
-       o = cBINOPx(obase)->op_first;
-       kid = cBINOPx(obase)->op_last;
+#define new_body_type(sv_type)                 \
+    (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
+            - bodies_by_type[sv_type].offset)
 
-       /* get the av or hv, and optionally the gv */
-       sv = Nullsv;
-       if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
-           sv = PAD_SV(o->op_targ);
-       }
-       else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
-               && cUNOPo->op_first->op_type == OP_GV)
-       {
-           gv = cGVOPx_gv(cUNOPo->op_first);
-           if (!gv)
-               break;
-           sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
-       }
-       if (!sv)
-           break;
+#define del_body_type(p, sv_type)      \
+    del_body(p, &PL_body_roots[sv_type])
 
-       if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
-           /* index is constant */
-           if (match) {
-               if (SvMAGICAL(sv))
-                   break;
-               if (obase->op_type == OP_HELEM) {
-                   HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
-                   if (!he || HeVAL(he) != uninit_sv)
-                       break;
-               }
-               else {
-                   SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
-                   if (!svp || *svp != uninit_sv)
-                       break;
-               }
-           }
-           if (obase->op_type == OP_HELEM)
-               return varname(gv, '%', o->op_targ,
-                           cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
-           else
-               return varname(gv, '@', o->op_targ, Nullsv,
-                           SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
-           ;
-       }
-       else  {
-           /* index is an expression;
-            * attempt to find a match within the aggregate */
-           if (obase->op_type == OP_HELEM) {
-               SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
-               if (keysv)
-                   return varname(gv, '%', o->op_targ,
-                                               keysv, 0, FUV_SUBSCRIPT_HASH);
-           }
-           else {
-               const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
-               if (index >= 0)
-                   return varname(gv, '@', o->op_targ,
-                                       Nullsv, index, FUV_SUBSCRIPT_ARRAY);
-           }
-           if (match)
-               break;
-           return varname(gv,
-               (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
-               ? '@' : '%',
-               o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
-       }
 
-       break;
+#define new_body_allocated(sv_type)            \
+    (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
+            - bodies_by_type[sv_type].offset)
 
-    case OP_AASSIGN:
-       /* only examine RHS */
-       return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+#define del_body_allocated(p, sv_type)         \
+    del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
 
-    case OP_OPEN:
-       o = cUNOPx(obase)->op_first;
-       if (o->op_type == OP_PUSHMARK)
-           o = o->op_sibling;
 
-       if (!o->op_sibling) {
-           /* one-arg version of open is highly magical */
+#define my_safemalloc(s)       (void*)safemalloc(s)
+#define my_safecalloc(s)       (void*)safecalloc(s, 1)
+#define my_safefree(p) safefree((char*)p)
 
-           if (o->op_type == OP_GV) { /* open FOO; */
-               gv = cGVOPx_gv(o);
-               if (match && GvSV(gv) != uninit_sv)
-                   break;
-               return varname(gv, '$', 0,
-                           Nullsv, 0, FUV_SUBSCRIPT_NONE);
-           }
-           /* other possibilities not handled are:
-            * open $x; or open my $x;  should return '${*$x}'
-            * open expr;               should return '$'.expr ideally
-            */
-            break;
-       }
-       goto do_op;
+#ifdef PURIFY
 
-    /* ops where $_ may be an implicit arg */
-    case OP_TRANS:
-    case OP_SUBST:
-    case OP_MATCH:
-       if ( !(obase->op_flags & OPf_STACKED)) {
-           if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
-                                ? PAD_SVl(obase->op_targ)
-                                : DEFSV))
-           {
-               sv = sv_newmortal();
-               sv_setpvn(sv, "$_", 2);
-               return sv;
-           }
-       }
-       goto do_op;
+#define new_XNV()      my_safemalloc(sizeof(XPVNV))
+#define del_XNV(p)     my_safefree(p)
 
-    case OP_PRTF:
-    case OP_PRINT:
-       /* skip filehandle as it can't produce 'undef' warning  */
-       o = cUNOPx(obase)->op_first;
-       if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
-           o = o->op_sibling->op_sibling;
-       goto do_op2;
+#define new_XPVNV()    my_safemalloc(sizeof(XPVNV))
+#define del_XPVNV(p)   my_safefree(p)
 
+#define new_XPVAV()    my_safemalloc(sizeof(XPVAV))
+#define del_XPVAV(p)   my_safefree(p)
 
-    case OP_RV2SV:
-    case OP_CUSTOM:
-    case OP_ENTERSUB:
-       match = 1; /* XS or custom code could trigger random warnings */
-       goto do_op;
+#define new_XPVHV()    my_safemalloc(sizeof(XPVHV))
+#define del_XPVHV(p)   my_safefree(p)
 
-    case OP_SCHOMP:
-    case OP_CHOMP:
-       if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
-           return sv_2mortal(newSVpvn("${$/}", 5));
-       /* FALL THROUGH */
+#define new_XPVMG()    my_safemalloc(sizeof(XPVMG))
+#define del_XPVMG(p)   my_safefree(p)
 
-    default:
-    do_op:
-       if (!(obase->op_flags & OPf_KIDS))
-           break;
-       o = cUNOPx(obase)->op_first;
-       
-    do_op2:
-       if (!o)
-           break;
+#define new_XPVGV()    my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p)   my_safefree(p)
 
-       /* if all except one arg are constant, or have no side-effects,
-        * or are optimized away, then it's unambiguous */
-       o2 = Nullop;
-       for (kid=o; kid; kid = kid->op_sibling) {
-           if (kid &&
-               (    (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
-                 || (kid->op_type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
-                 || (kid->op_type == OP_PUSHMARK)
-               )
-           )
-               continue;
-           if (o2) { /* more than one found */
-               o2 = Nullop;
-               break;
-           }
-           o2 = kid;
-       }
-       if (o2)
-           return find_uninit_var(o2, uninit_sv, match);
+#else /* !PURIFY */
 
-       /* scan all args */
-       while (o) {
-           sv = find_uninit_var(o, uninit_sv, 1);
-           if (sv)
-               return sv;
-           o = o->op_sibling;
-       }
-       break;
-    }
-    return Nullsv;
-}
+#define new_XNV()      new_body_type(SVt_NV)
+#define del_XNV(p)     del_body_type(p, SVt_NV)
 
+#define new_XPVNV()    new_body_type(SVt_PVNV)
+#define del_XPVNV(p)   del_body_type(p, SVt_PVNV)
 
-/*
-=for apidoc report_uninit
+#define new_XPVAV()    new_body_allocated(SVt_PVAV)
+#define del_XPVAV(p)   del_body_allocated(p, SVt_PVAV)
 
-Print appropriate "Use of uninitialized variable" warning
+#define new_XPVHV()    new_body_allocated(SVt_PVHV)
+#define del_XPVHV(p)   del_body_allocated(p, SVt_PVHV)
 
-=cut
-*/
+#define new_XPVMG()    new_body_type(SVt_PVMG)
+#define del_XPVMG(p)   del_body_type(p, SVt_PVMG)
 
-void
-Perl_report_uninit(pTHX_ SV* uninit_sv)
-{
-    if (PL_op) {
-       SV* varname = Nullsv;
-       if (uninit_sv) {
-           varname = find_uninit_var(PL_op, uninit_sv,0);
-           if (varname)
-               sv_insert(varname, 0, 0, " ", 1);
-       }
-       Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
-               varname ? SvPV_nolen_const(varname) : "",
-               " in ", OP_DESC(PL_op));
-    }
-    else
-       Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
-                   "", "", "");
-}
+#define new_XPVGV()    new_body_type(SVt_PVGV)
+#define del_XPVGV(p)   del_body_type(p, SVt_PVGV)
 
-/*
-  Here are mid-level routines that manage the allocation of bodies out
-  of the various arenas.  There are 5 kinds of arenas:
+#endif /* PURIFY */
 
-  1. SV-head arenas, which are discussed and handled above
-  2. regular body arenas
-  3. arenas for reduced-size bodies
-  4. Hash-Entry arenas
-  5. pte arenas (thread related)
+/* no arena for you! */
 
-  Arena types 2 & 3 are chained by body-type off an array of
-  arena-root pointers, which is indexed by svtype.  Some of the
-  larger/less used body types are malloced singly, since a large
-  unused block of them is wasteful.  Also, several svtypes dont have
-  bodies; the data fits into the sv-head itself.  The arena-root
-  pointer thus has a few unused root-pointers (which may be hijacked
-  later for arena types 4,5)
+#define new_NOARENA(details) \
+       my_safemalloc((details)->size + (details)->offset)
+#define new_NOARENAZ(details) \
+       my_safecalloc((details)->size + (details)->offset)
 
-  3 differs from 2 as an optimization; some body types have several
-  unused fields in the front of the structure (which are kept in-place
-  for consistency).  These bodies can be allocated in smaller chunks,
-  because the leading fields arent accessed.  Pointers to such bodies
-  are decremented to point at the unused 'ghost' memory, knowing that
-  the pointers are used with offsets to the real memory.
+/*
+=for apidoc sv_upgrade
 
-  HE, HEK arenas are managed separately, with separate code, but may
-  be merge-able later..
+Upgrade an SV to a more complex form.  Generally adds a new body type to the
+SV, then copies across as much information as possible from the old body.
+You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
 
-  PTE arenas are not sv-bodies, but they share these mid-level
-  mechanics, so are considered here.  The new mid-level mechanics rely
-  on the sv_type of the body being allocated, so we just reserve one
-  of the unused body-slots for PTEs, then use it in those (2) PTE
-  contexts below (line ~10k)
+=cut
 */
 
-STATIC void *
-S_more_bodies (pTHX_ size_t size, svtype sv_type)
+void
+Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
 {
-    void **arena_root  = &PL_body_arenaroots[sv_type];
-    void **root                = &PL_body_roots[sv_type];
-    char *start;
-    const char *end;
-    const size_t count = PERL_ARENA_SIZE / size;
-
-    Newx(start, count*size, char);
-    *((void **) start) = *arena_root;
-    *arena_root = (void *)start;
+    void*      old_body;
+    void*      new_body;
+    const U32  old_type = SvTYPE(sv);
+    const struct body_details *const old_type_details
+       = bodies_by_type + old_type;
+    const struct body_details *new_type_details = bodies_by_type + new_type;
 
-    end = start + (count-1) * size;
+    if (new_type != SVt_PV && SvIsCOW(sv)) {
+       sv_force_normal_flags(sv, 0);
+    }
 
-    /* The initial slot is used to link the arenas together, so it isn't to be
-       linked into the list of ready-to-use bodies.  */
+    if (old_type == new_type)
+       return;
 
-    start += size;
+    if (old_type > new_type)
+       Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
+               (int)old_type, (int)new_type);
 
-    *root = (void *)start;
 
-    while (start < end) {
-       char * const next = start + size;
-       *(void**) start = (void *)next;
-       start = next;
-    }
-    *(void **)start = 0;
+    old_body = SvANY(sv);
 
-    return *root;
-}
+    /* Copying structures onto other structures that have been neatly zeroed
+       has a subtle gotcha. Consider XPVMG
 
-/* grab a new thing from the free list, allocating more if necessary */
+       +------+------+------+------+------+-------+-------+
+       |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
+       +------+------+------+------+------+-------+-------+
+       0      4      8     12     16     20      24      28
 
-/* 1st, the inline version  */
+       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:
 
-#define new_body_inline(xpv, size, sv_type) \
-    STMT_START { \
-       void **r3wt = &PL_body_roots[sv_type]; \
-       LOCK_SV_MUTEX; \
-       xpv = *((void **)(r3wt)) \
-         ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
-       *(r3wt) = *(void**)(xpv); \
-       UNLOCK_SV_MUTEX; \
-    } STMT_END
+       +------+------+------+------+------+-------+-------+------+
+       |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
+       +------+------+------+------+------+-------+-------+------+
+       0      4      8     12     16     20      24      28     32
 
-/* now use the inline version in the proper function */
+       so what happens if you allocate memory for this structure:
 
-#ifndef PURIFY
+       +------+------+------+------+------+-------+-------+------+------+...
+       |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
+       +------+------+------+------+------+-------+-------+------+------+...
+       0      4      8     12     16     20      24      28     32     36
 
-/* This isn't being used with -DPURIFY, so don't declare it. Otherwise
-   compilers issue warnings.  */
+       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.
 
-STATIC void *
-S_new_body(pTHX_ size_t size, svtype sv_type)
-{
-    void *xpv;
-    new_body_inline(xpv, size, sv_type);
-    return xpv;
-}
+       (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)
 
-#endif
+       So we are careful and work out the size of used parts of all the
+       structures.  */
 
-/* return a thing to the free list */
+    switch (old_type) {
+    case SVt_NULL:
+       break;
+    case SVt_IV:
+       if (new_type < SVt_PVIV) {
+           new_type = (new_type == SVt_NV)
+               ? SVt_PVNV : SVt_PVIV;
+           new_type_details = bodies_by_type + new_type;
+       }
+       break;
+    case SVt_NV:
+       if (new_type < SVt_PVNV) {
+           new_type = SVt_PVNV;
+           new_type_details = bodies_by_type + new_type;
+       }
+       break;
+    case SVt_RV:
+       break;
+    case SVt_PV:
+       assert(new_type > SVt_PV);
+       assert(SVt_IV < SVt_PV);
+       assert(SVt_NV < SVt_PV);
+       break;
+    case SVt_PVIV:
+       break;
+    case SVt_PVNV:
+       break;
+    case SVt_PVMG:
+       /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
+          there's no way that it can be safely upgraded, because perl.c
+          expects to Safefree(SvANY(PL_mess_sv))  */
+       assert(sv != PL_mess_sv);
+       /* This flag bit is used to mean other things in other scalar types.
+          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);
+       break;
+    default:
+       if (old_type_details->cant_upgrade)
+           Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
+    }
 
-#define del_body(thing, root)                  \
-    STMT_START {                               \
-       void **thing_copy = (void **)thing;     \
-       LOCK_SV_MUTEX;                          \
-       *thing_copy = *root;                    \
-       *root = (void*)thing_copy;              \
-       UNLOCK_SV_MUTEX;                        \
-    } STMT_END
+    SvFLAGS(sv) &= ~SVTYPEMASK;
+    SvFLAGS(sv) |= new_type;
 
-/* 
-   Revisiting type 3 arenas, there are 4 body-types which have some
-   members that are never accessed.  They are XPV, XPVIV, XPVAV,
-   XPVHV, which have corresponding types: xpv_allocated,
-   xpviv_allocated, xpvav_allocated, xpvhv_allocated,
+    switch (new_type) {
+    case SVt_NULL:
+       Perl_croak(aTHX_ "Can't upgrade to undef");
+    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, 0);
+       return;
+    case SVt_NV:
+       assert(old_type == SVt_NULL);
+       SvANY(sv) = new_XNV();
+       SvNV_set(sv, 0);
+       return;
+    case SVt_RV:
+       assert(old_type == SVt_NULL);
+       SvANY(sv) = &sv->sv_u.svu_rv;
+       SvRV_set(sv, 0);
+       return;
+    case SVt_PVHV:
+       SvANY(sv) = new_XPVHV();
+       HvFILL(sv)      = 0;
+       HvMAX(sv)       = 0;
+       HvTOTALKEYS(sv) = 0;
 
-   For these types, the arenas are carved up into *_allocated size
-   chunks, we thus avoid wasted memory for those unaccessed members.
-   When bodies are allocated, we adjust the pointer back in memory by
-   the size of the bit not allocated, so it's as if we allocated the
-   full structure.  (But things will all go boom if you write to the
-   part that is "not there", because you'll be overwriting the last
-   members of the preceding structure in memory.)
+       goto hv_av_common;
 
-   We calculate the correction using the STRUCT_OFFSET macro. For example, if
-   xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
-   and the pointer is unchanged. If the allocated structure is smaller (no
-   initial NV actually allocated) then the net effect is to subtract the size
-   of the NV from the pointer, to return a new pointer as if an initial NV were
-   actually allocated.
+    case SVt_PVAV:
+       SvANY(sv) = new_XPVAV();
+       AvMAX(sv)       = -1;
+       AvFILLp(sv)     = -1;
+       AvALLOC(sv)     = 0;
+       AvREAL_only(sv);
 
-   This is the same trick as was used for NV and IV bodies. Ironically it
-   doesn't need to be used for NV bodies any more, because NV is now at the
-   start of the structure. IV bodies don't need it either, because they are
-   no longer allocated.  */
+    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);
+       }
 
-/* The following 2 arrays hide the above details in a pair of
-   lookup-tables, allowing us to be body-type agnostic.
+       /* Could put this in the else clause below, as PVMG must have SvPVX
+          0 already (the assertion above)  */
+       SvPV_set(sv, (char*)0);
 
-   size maps svtype to its body's allocated size.
-   offset maps svtype to the body-pointer adjustment needed
+       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;
 
-   NB: elements in latter are 0 or <0, and are added during
-   allocation, and subtracted during deallocation.  It may be clearer
-   to invert the values, and call it shrinkage_by_svtype.
-*/
 
-struct body_details {
-    size_t size;       /* Size to allocate  */
-    size_t copy;       /* Size of structure to copy (may be shorter)  */
-    size_t offset;
-    bool cant_upgrade; /* Can upgrade this type */
-    bool zero_nv;      /* zero the NV when upgrading from this */
-    bool arena;                /* Allocated from an arena */
-};
+    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:
+    case SVt_PVBM:
+    case SVt_PVGV:
+    case SVt_PVCV:
+    case SVt_PVLV:
+    case SVt_PVMG:
+    case SVt_PVNV:
+    case SVt_PV:
 
-#define HADNV FALSE
-#define NONV TRUE
+       assert(new_type_details->size);
+       /* We always allocated the full length item with PURIFY. To do this
+          we fake things so that arena is false for all 16 types..  */
+       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);
+       }
+       SvANY(sv) = new_body;
 
-#ifdef PURIFY
-/* With -DPURFIY we allocate everything directly, and don't use arenas.
-   This seems a rather elegant way to simplify some of the code below.  */
-#define HASARENA FALSE
-#else
-#define HASARENA TRUE
+       if (old_type_details->copy) {
+           Copy((char *)old_body + old_type_details->offset,
+                (char *)new_body + old_type_details->offset,
+                old_type_details->copy, char);
+       }
+
+#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.  */
+       if (old_type_details->zero_nv)
+           SvNV_set(sv, 0);
 #endif
-#define NOARENA FALSE
 
-/* A macro to work out the offset needed to subtract from a pointer to (say)
+       if (new_type == 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", new_type);
+    }
 
-typedef struct {
-    STRLEN     xpv_cur;
-    STRLEN     xpv_len;
-} xpv_allocated;
+    if (old_type_details->size) {
+       /* If the old body had an allocated size, then we need to free it.  */
+#ifdef PURIFY
+       my_safefree(old_body);
+#else
+       del_body((void*)((char*)old_body + old_type_details->offset),
+                &PL_body_roots[old_type]);
+#endif
+    }
+}
 
-to make its members accessible via a pointer to (say)
+/*
+=for apidoc sv_backoff
 
-struct xpv {
-    NV         xnv_nv;
-    STRLEN     xpv_cur;
-    STRLEN     xpv_len;
-};
+Remove any string offset. You should normally use the C<SvOOK_off> macro
+wrapper instead.
 
+=cut
 */
 
-#define relative_STRUCT_OFFSET(longer, shorter, member) \
-    (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
+int
+Perl_sv_backoff(pTHX_ register SV *sv)
+{
+    assert(SvOOK(sv));
+    assert(SvTYPE(sv) != SVt_PVHV);
+    assert(SvTYPE(sv) != SVt_PVAV);
+    if (SvIVX(sv)) {
+       const char * const s = SvPVX_const(sv);
+       SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
+       SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
+       SvIV_set(sv, 0);
+       Move(s, SvPVX(sv), SvCUR(sv)+1, char);
+    }
+    SvFLAGS(sv) &= ~SVf_OOK;
+    return 0;
+}
 
-/* Calculate the length to copy. Specifically work out the length less any
-   final padding the compiler needed to add.  See the comment in sv_upgrade
-   for why copying the padding proved to be a bug.  */
+/*
+=for apidoc sv_grow
 
-#define copy_length(type, last_member) \
-       STRUCT_OFFSET(type, last_member) \
-       + sizeof (((type*)SvANY((SV*)0))->last_member)
-
-static const struct body_details bodies_by_type[] = {
-    {0, 0, 0, FALSE, NONV, NOARENA},
-    /* IVs are in the head, so the allocation size is 0  */
-    {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
-    /* 8 bytes on most ILP32 with IEEE doubles */
-    {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
-    /* RVs are in the head now */
-    /* However, this slot is overloaded and used by the pte  */
-    {0, 0, 0, FALSE, NONV, NOARENA},
-    /* 8 bytes on most ILP32 with IEEE doubles */
-    {sizeof(xpv_allocated),
-     copy_length(XPV, xpv_len)
-     + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
-     - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
-     FALSE, NONV, HASARENA},
-    /* 12 */
-    {sizeof(xpviv_allocated),
-     copy_length(XPVIV, xiv_u)
-     + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
-     - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
-     FALSE, NONV, HASARENA},
-    /* 20 */
-    {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA},
-    /* 28 */
-    {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA},
-    /* 36 */
-    {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
-    /* 48 */
-    {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
-    /* 64 */
-    {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
-    /* 20 */
-    {sizeof(xpvav_allocated),
-     copy_length(XPVAV, xmg_stash)
-     + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
-     - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
-     TRUE, HADNV, HASARENA},
-    /* 20 */
-    {sizeof(xpvhv_allocated),
-     copy_length(XPVHV, xmg_stash)
-     + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
-     - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
-     TRUE, HADNV, HASARENA},
-    /* 76 */
-    {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
-    /* 80 */
-    {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
-    /* 84 */
-    {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
-};
-
-#define new_body_type(sv_type)                 \
-    (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
-            - bodies_by_type[sv_type].offset)
+Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
+upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
+Use the C<SvGROW> wrapper instead.
 
-#define del_body_type(p, sv_type)      \
-    del_body(p, &PL_body_roots[sv_type])
+=cut
+*/
 
+char *
+Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
+{
+    register char *s;
 
-#define new_body_allocated(sv_type)            \
-    (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
-            - bodies_by_type[sv_type].offset)
+#ifdef HAS_64K_LIMIT
+    if (newlen >= 0x10000) {
+       PerlIO_printf(Perl_debug_log,
+                     "Allocation too large: %"UVxf"\n", (UV)newlen);
+       my_exit(1);
+    }
+#endif /* HAS_64K_LIMIT */
+    if (SvROK(sv))
+       sv_unref(sv);
+    if (SvTYPE(sv) < SVt_PV) {
+       sv_upgrade(sv, SVt_PV);
+       s = SvPVX_mutable(sv);
+    }
+    else if (SvOOK(sv)) {      /* pv is offset? */
+       sv_backoff(sv);
+       s = SvPVX_mutable(sv);
+       if (newlen > SvLEN(sv))
+           newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
+#ifdef HAS_64K_LIMIT
+       if (newlen >= 0x10000)
+           newlen = 0xFFFF;
+#endif
+    }
+    else
+       s = SvPVX_mutable(sv);
 
-#define del_body_allocated(p, sv_type)         \
-    del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
+    if (newlen > SvLEN(sv)) {          /* need more room? */
+       newlen = PERL_STRLEN_ROUNDUP(newlen);
+       if (SvLEN(sv) && s) {
+#ifdef MYMALLOC
+           const STRLEN l = malloced_size((void*)SvPVX_const(sv));
+           if (newlen <= l) {
+               SvLEN_set(sv, l);
+               return s;
+           } else
+#endif
+           s = saferealloc(s, newlen);
+       }
+       else {
+           s = safemalloc(newlen);
+           if (SvPVX_const(sv) && SvCUR(sv)) {
+               Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
+           }
+       }
+       SvPV_set(sv, s);
+        SvLEN_set(sv, newlen);
+    }
+    return s;
+}
 
+/*
+=for apidoc sv_setiv
 
-#define my_safemalloc(s)       (void*)safemalloc(s)
-#define my_safecalloc(s)       (void*)safecalloc(s, 1)
-#define my_safefree(p) safefree((char*)p)
+Copies an integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic.  See also C<sv_setiv_mg>.
 
-#ifdef PURIFY
+=cut
+*/
 
-#define new_XNV()      my_safemalloc(sizeof(XPVNV))
-#define del_XNV(p)     my_safefree(p)
+void
+Perl_sv_setiv(pTHX_ register SV *sv, IV i)
+{
+    SV_CHECK_THINKFIRST_COW_DROP(sv);
+    switch (SvTYPE(sv)) {
+    case SVt_NULL:
+       sv_upgrade(sv, SVt_IV);
+       break;
+    case SVt_NV:
+       sv_upgrade(sv, SVt_PVNV);
+       break;
+    case SVt_RV:
+    case SVt_PV:
+       sv_upgrade(sv, SVt_PVIV);
+       break;
 
-#define new_XPVNV()    my_safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p)   my_safefree(p)
+    case SVt_PVGV:
+    case SVt_PVAV:
+    case SVt_PVHV:
+    case SVt_PVCV:
+    case SVt_PVFM:
+    case SVt_PVIO:
+       Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
+                  OP_DESC(PL_op));
+    }
+    (void)SvIOK_only(sv);                      /* validate number */
+    SvIV_set(sv, i);
+    SvTAINT(sv);
+}
 
-#define new_XPVAV()    my_safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p)   my_safefree(p)
+/*
+=for apidoc sv_setiv_mg
 
-#define new_XPVHV()    my_safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p)   my_safefree(p)
+Like C<sv_setiv>, but also handles 'set' magic.
 
-#define new_XPVMG()    my_safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p)   my_safefree(p)
+=cut
+*/
 
-#define new_XPVGV()    my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p)   my_safefree(p)
+void
+Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
+{
+    sv_setiv(sv,i);
+    SvSETMAGIC(sv);
+}
 
-#else /* !PURIFY */
+/*
+=for apidoc sv_setuv
 
-#define new_XNV()      new_body_type(SVt_NV)
-#define del_XNV(p)     del_body_type(p, SVt_NV)
+Copies an unsigned integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic.  See also C<sv_setuv_mg>.
 
-#define new_XPVNV()    new_body_type(SVt_PVNV)
-#define del_XPVNV(p)   del_body_type(p, SVt_PVNV)
+=cut
+*/
 
-#define new_XPVAV()    new_body_allocated(SVt_PVAV)
-#define del_XPVAV(p)   del_body_allocated(p, SVt_PVAV)
+void
+Perl_sv_setuv(pTHX_ register SV *sv, UV u)
+{
+    /* With these two if statements:
+       u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
 
-#define new_XPVHV()    new_body_allocated(SVt_PVHV)
-#define del_XPVHV(p)   del_body_allocated(p, SVt_PVHV)
+       without
+       u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
 
-#define new_XPVMG()    new_body_type(SVt_PVMG)
-#define del_XPVMG(p)   del_body_type(p, SVt_PVMG)
+       If you wish to remove them, please benchmark to see what the effect is
+    */
+    if (u <= (UV)IV_MAX) {
+       sv_setiv(sv, (IV)u);
+       return;
+    }
+    sv_setiv(sv, 0);
+    SvIsUV_on(sv);
+    SvUV_set(sv, u);
+}
 
-#define new_XPVGV()    new_body_type(SVt_PVGV)
-#define del_XPVGV(p)   del_body_type(p, SVt_PVGV)
+/*
+=for apidoc sv_setuv_mg
 
-#endif /* PURIFY */
+Like C<sv_setuv>, but also handles 'set' magic.
 
-/* no arena for you! */
+=cut
+*/
 
-#define new_NOARENA(details) \
-       my_safemalloc((details)->size + (details)->offset)
-#define new_NOARENAZ(details) \
-       my_safecalloc((details)->size + (details)->offset)
+void
+Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
+{
+    sv_setiv(sv, 0);
+    SvIsUV_on(sv);
+    sv_setuv(sv,u);
+    SvSETMAGIC(sv);
+}
 
 /*
-=for apidoc sv_upgrade
+=for apidoc sv_setnv
 
-Upgrade an SV to a more complex form.  Generally adds a new body type to the
-SV, then copies across as much information as possible from the old body.
-You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
+Copies a double into the given SV, upgrading first if necessary.
+Does not handle 'set' magic.  See also C<sv_setnv_mg>.
 
 =cut
 */
 
 void
-Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
+Perl_sv_setnv(pTHX_ register SV *sv, NV num)
 {
-    void*      old_body;
-    void*      new_body;
-    const U32  old_type = SvTYPE(sv);
-    const struct body_details *const old_type_details
-       = bodies_by_type + old_type;
-    const struct body_details *new_type_details = bodies_by_type + new_type;
-
-    if (new_type != SVt_PV && SvIsCOW(sv)) {
-       sv_force_normal_flags(sv, 0);
-    }
-
-    if (old_type == new_type)
-       return;
-
-    if (old_type > new_type)
-       Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
-               (int)old_type, (int)new_type);
-
-
-    old_body = SvANY(sv);
-
-    /* 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 (old_type) {
+    SV_CHECK_THINKFIRST_COW_DROP(sv);
+    switch (SvTYPE(sv)) {
     case SVt_NULL:
-       break;
     case SVt_IV:
-       if (new_type < SVt_PVIV) {
-           new_type = (new_type == SVt_NV)
-               ? SVt_PVNV : SVt_PVIV;
-           new_type_details = bodies_by_type + new_type;
-       }
-       break;
-    case SVt_NV:
-       if (new_type < SVt_PVNV) {
-           new_type = SVt_PVNV;
-           new_type_details = bodies_by_type + new_type;
-       }
+       sv_upgrade(sv, SVt_NV);
        break;
     case SVt_RV:
-       break;
     case SVt_PV:
-       assert(new_type > SVt_PV);
-       assert(SVt_IV < SVt_PV);
-       assert(SVt_NV < SVt_PV);
-       break;
     case SVt_PVIV:
-       break;
-    case SVt_PVNV:
-       break;
-    case SVt_PVMG:
-       /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
-          there's no way that it can be safely upgraded, because perl.c
-          expects to Safefree(SvANY(PL_mess_sv))  */
-       assert(sv != PL_mess_sv);
-       /* This flag bit is used to mean other things in other scalar types.
-          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);
-       break;
-    default:
-       if (old_type_details->cant_upgrade)
-           Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
-    }
-
-    SvFLAGS(sv) &= ~SVTYPEMASK;
-    SvFLAGS(sv) |= new_type;
-
-    switch (new_type) {
-    case SVt_NULL:
-       Perl_croak(aTHX_ "Can't upgrade to undef");
-    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, 0);
-       return;
-    case SVt_NV:
-       assert(old_type == SVt_NULL);
-       SvANY(sv) = new_XNV();
-       SvNV_set(sv, 0);
-       return;
-    case SVt_RV:
-       assert(old_type == SVt_NULL);
-       SvANY(sv) = &sv->sv_u.svu_rv;
-       SvRV_set(sv, 0);
-       return;
-    case SVt_PVHV:
-       SvANY(sv) = new_XPVHV();
-       HvFILL(sv)      = 0;
-       HvMAX(sv)       = 0;
-       HvTOTALKEYS(sv) = 0;
-
-       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);
-
-       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);
-       }
+       sv_upgrade(sv, SVt_PVNV);
        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:
-    case SVt_PVBM:
     case SVt_PVGV:
+    case SVt_PVAV:
+    case SVt_PVHV:
     case SVt_PVCV:
-    case SVt_PVLV:
-    case SVt_PVMG:
-    case SVt_PVNV:
-    case SVt_PV:
-
-       assert(new_type_details->size);
-       /* We always allocated the full length item with PURIFY. To do this
-          we fake things so that arena is false for all 16 types..  */
-       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);
-       }
-       SvANY(sv) = new_body;
-
-       if (old_type_details->copy) {
-           Copy((char *)old_body + old_type_details->offset,
-                (char *)new_body + old_type_details->offset,
-                old_type_details->copy, char);
-       }
-
-#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.  */
-       if (old_type_details->zero_nv)
-           SvNV_set(sv, 0);
-#endif
-
-       if (new_type == 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", new_type);
-    }
-
-    if (old_type_details->size) {
-       /* If the old body had an allocated size, then we need to free it.  */
-#ifdef PURIFY
-       my_safefree(old_body);
-#else
-       del_body((void*)((char*)old_body + old_type_details->offset),
-                &PL_body_roots[old_type]);
-#endif
+    case SVt_PVFM:
+    case SVt_PVIO:
+       Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
+                  OP_NAME(PL_op));
     }
+    SvNV_set(sv, num);
+    (void)SvNOK_only(sv);                      /* validate number */
+    SvTAINT(sv);
 }
 
 /*
-=for apidoc sv_backoff
+=for apidoc sv_setnv_mg
 
-Remove any string offset. You should normally use the C<SvOOK_off> macro
-wrapper instead.
+Like C<sv_setnv>, but also handles 'set' magic.
 
 =cut
 */
 
-int
-Perl_sv_backoff(pTHX_ register SV *sv)
+void
+Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
 {
-    assert(SvOOK(sv));
-    assert(SvTYPE(sv) != SVt_PVHV);
-    assert(SvTYPE(sv) != SVt_PVAV);
-    if (SvIVX(sv)) {
-       const char * const s = SvPVX_const(sv);
-       SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
-       SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
-       SvIV_set(sv, 0);
-       Move(s, SvPVX(sv), SvCUR(sv)+1, char);
-    }
-    SvFLAGS(sv) &= ~SVf_OOK;
-    return 0;
+    sv_setnv(sv,num);
+    SvSETMAGIC(sv);
 }
 
-/*
-=for apidoc sv_grow
-
-Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
-upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
-Use the C<SvGROW> wrapper instead.
-
-=cut
-*/
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
 
-char *
-Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
+STATIC void
+S_not_a_number(pTHX_ SV *sv)
 {
-    register char *s;
-
-#ifdef HAS_64K_LIMIT
-    if (newlen >= 0x10000) {
-       PerlIO_printf(Perl_debug_log,
-                     "Allocation too large: %"UVxf"\n", (UV)newlen);
-       my_exit(1);
-    }
-#endif /* HAS_64K_LIMIT */
-    if (SvROK(sv))
-       sv_unref(sv);
-    if (SvTYPE(sv) < SVt_PV) {
-       sv_upgrade(sv, SVt_PV);
-       s = SvPVX_mutable(sv);
-    }
-    else if (SvOOK(sv)) {      /* pv is offset? */
-       sv_backoff(sv);
-       s = SvPVX_mutable(sv);
-       if (newlen > SvLEN(sv))
-           newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
-#ifdef HAS_64K_LIMIT
-       if (newlen >= 0x10000)
-           newlen = 0xFFFF;
-#endif
-    }
-    else
-       s = SvPVX_mutable(sv);
-
-    if (newlen > SvLEN(sv)) {          /* need more room? */
-       newlen = PERL_STRLEN_ROUNDUP(newlen);
-       if (SvLEN(sv) && s) {
-#ifdef MYMALLOC
-           const STRLEN l = malloced_size((void*)SvPVX_const(sv));
-           if (newlen <= l) {
-               SvLEN_set(sv, l);
-               return s;
-           } else
-#endif
-           s = saferealloc(s, newlen);
-       }
-       else {
-           s = safemalloc(newlen);
-           if (SvPVX_const(sv) && SvCUR(sv)) {
-               Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
-           }
-       }
-       SvPV_set(sv, s);
-        SvLEN_set(sv, newlen);
-    }
-    return s;
-}
-
-/*
-=for apidoc sv_setiv
-
-Copies an integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic.  See also C<sv_setiv_mg>.
-
-=cut
-*/
-
-void
-Perl_sv_setiv(pTHX_ register SV *sv, IV i)
-{
-    SV_CHECK_THINKFIRST_COW_DROP(sv);
-    switch (SvTYPE(sv)) {
-    case SVt_NULL:
-       sv_upgrade(sv, SVt_IV);
-       break;
-    case SVt_NV:
-       sv_upgrade(sv, SVt_PVNV);
-       break;
-    case SVt_RV:
-    case SVt_PV:
-       sv_upgrade(sv, SVt_PVIV);
-       break;
-
-    case SVt_PVGV:
-    case SVt_PVAV:
-    case SVt_PVHV:
-    case SVt_PVCV:
-    case SVt_PVFM:
-    case SVt_PVIO:
-       Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
-                  OP_DESC(PL_op));
-    }
-    (void)SvIOK_only(sv);                      /* validate number */
-    SvIV_set(sv, i);
-    SvTAINT(sv);
-}
-
-/*
-=for apidoc sv_setiv_mg
-
-Like C<sv_setiv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
-{
-    sv_setiv(sv,i);
-    SvSETMAGIC(sv);
-}
-
-/*
-=for apidoc sv_setuv
-
-Copies an unsigned integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic.  See also C<sv_setuv_mg>.
-
-=cut
-*/
-
-void
-Perl_sv_setuv(pTHX_ register SV *sv, UV u)
-{
-    /* With these two if statements:
-       u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
-
-       without
-       u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
-
-       If you wish to remove them, please benchmark to see what the effect is
-    */
-    if (u <= (UV)IV_MAX) {
-       sv_setiv(sv, (IV)u);
-       return;
-    }
-    sv_setiv(sv, 0);
-    SvIsUV_on(sv);
-    SvUV_set(sv, u);
-}
-
-/*
-=for apidoc sv_setuv_mg
-
-Like C<sv_setuv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
-{
-    sv_setiv(sv, 0);
-    SvIsUV_on(sv);
-    sv_setuv(sv,u);
-    SvSETMAGIC(sv);
-}
-
-/*
-=for apidoc sv_setnv
-
-Copies a double into the given SV, upgrading first if necessary.
-Does not handle 'set' magic.  See also C<sv_setnv_mg>.
-
-=cut
-*/
-
-void
-Perl_sv_setnv(pTHX_ register SV *sv, NV num)
-{
-    SV_CHECK_THINKFIRST_COW_DROP(sv);
-    switch (SvTYPE(sv)) {
-    case SVt_NULL:
-    case SVt_IV:
-       sv_upgrade(sv, SVt_NV);
-       break;
-    case SVt_RV:
-    case SVt_PV:
-    case SVt_PVIV:
-       sv_upgrade(sv, SVt_PVNV);
-       break;
-
-    case SVt_PVGV:
-    case SVt_PVAV:
-    case SVt_PVHV:
-    case SVt_PVCV:
-    case SVt_PVFM:
-    case SVt_PVIO:
-       Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
-                  OP_NAME(PL_op));
-    }
-    SvNV_set(sv, num);
-    (void)SvNOK_only(sv);                      /* validate number */
-    SvTAINT(sv);
-}
-
-/*
-=for apidoc sv_setnv_mg
-
-Like C<sv_setnv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
-{
-    sv_setnv(sv,num);
-    SvSETMAGIC(sv);
-}
-
-/* Print an "isn't numeric" warning, using a cleaned-up,
- * printable version of the offending string
- */
-
-STATIC void
-S_not_a_number(pTHX_ SV *sv)
-{
-     SV *dsv;
-     char tmpbuf[64];
-     const char *pv;
+     SV *dsv;
+     char tmpbuf[64];
+     const char *pv;
 
      if (DO_UTF8(sv)) {
           dsv = sv_2mortal(newSVpvn("", 0));
@@ -10676,981 +10203,1455 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
        }
     }
 
-    return nss;
-}
+    return nss;
+}
+
+
+/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
+ * flag to the result. This is done for each stash before cloning starts,
+ * so we know which stashes want their objects cloned */
+
+static void
+do_mark_cloneable_stash(pTHX_ SV *sv)
+{
+    const HEK * const hvname = HvNAME_HEK((HV*)sv);
+    if (hvname) {
+       GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
+       SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
+       if (cloner && GvCV(cloner)) {
+           dSP;
+           UV status;
+
+           ENTER;
+           SAVETMPS;
+           PUSHMARK(SP);
+           XPUSHs(sv_2mortal(newSVhek(hvname)));
+           PUTBACK;
+           call_sv((SV*)GvCV(cloner), G_SCALAR);
+           SPAGAIN;
+           status = POPu;
+           PUTBACK;
+           FREETMPS;
+           LEAVE;
+           if (status)
+               SvFLAGS(sv) &= ~SVphv_CLONEABLE;
+       }
+    }
+}
+
+
+
+/*
+=for apidoc perl_clone
+
+Create and return a new interpreter by cloning the current one.
+
+perl_clone takes these flags as parameters:
+
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
+threads->new doesn't.
+
+CLONEf_KEEP_PTR_TABLE
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
+code is in threads.xs create
+
+CLONEf_CLONE_HOST
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
+you don't need to do anything.
+
+=cut
+*/
+
+/* XXX the above needs expanding by someone who actually understands it ! */
+EXTERN_C PerlInterpreter *
+perl_clone_host(PerlInterpreter* proto_perl, UV flags);
+
+PerlInterpreter *
+perl_clone(PerlInterpreter *proto_perl, UV flags)
+{
+   dVAR;
+#ifdef PERL_IMPLICIT_SYS
+
+   /* perlhost.h so we need to call into it
+   to clone the host, CPerlHost should have a c interface, sky */
+
+   if (flags & CLONEf_CLONE_HOST) {
+       return perl_clone_host(proto_perl,flags);
+   }
+   return perl_clone_using(proto_perl, flags,
+                           proto_perl->IMem,
+                           proto_perl->IMemShared,
+                           proto_perl->IMemParse,
+                           proto_perl->IEnv,
+                           proto_perl->IStdIO,
+                           proto_perl->ILIO,
+                           proto_perl->IDir,
+                           proto_perl->ISock,
+                           proto_perl->IProc);
+}
+
+PerlInterpreter *
+perl_clone_using(PerlInterpreter *proto_perl, UV flags,
+                struct IPerlMem* ipM, struct IPerlMem* ipMS,
+                struct IPerlMem* ipMP, struct IPerlEnv* ipE,
+                struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
+                struct IPerlDir* ipD, struct IPerlSock* ipS,
+                struct IPerlProc* ipP)
+{
+    /* XXX many of the string copies here can be optimized if they're
+     * constants; they need to be allocated as common memory and just
+     * their pointers copied. */
+
+    IV i;
+    CLONE_PARAMS clone_params;
+    CLONE_PARAMS* param = &clone_params;
+
+    PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+    /* for each stash, determine whether its objects should be cloned */
+    S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
+    PERL_SET_THX(my_perl);
+
+#  ifdef DEBUGGING
+    Poison(my_perl, 1, PerlInterpreter);
+    PL_op = Nullop;
+    PL_curcop = (COP *)Nullop;
+    PL_markstack = 0;
+    PL_scopestack = 0;
+    PL_savestack = 0;
+    PL_savestack_ix = 0;
+    PL_savestack_max = -1;
+    PL_sig_pending = 0;
+    Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+#  else        /* !DEBUGGING */
+    Zero(my_perl, 1, PerlInterpreter);
+#  endif       /* DEBUGGING */
+
+    /* host pointers */
+    PL_Mem             = ipM;
+    PL_MemShared       = ipMS;
+    PL_MemParse                = ipMP;
+    PL_Env             = ipE;
+    PL_StdIO           = ipStd;
+    PL_LIO             = ipLIO;
+    PL_Dir             = ipD;
+    PL_Sock            = ipS;
+    PL_Proc            = ipP;
+#else          /* !PERL_IMPLICIT_SYS */
+    IV i;
+    CLONE_PARAMS clone_params;
+    CLONE_PARAMS* param = &clone_params;
+    PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+    /* for each stash, determine whether its objects should be cloned */
+    S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
+    PERL_SET_THX(my_perl);
+
+#    ifdef DEBUGGING
+    Poison(my_perl, 1, PerlInterpreter);
+    PL_op = Nullop;
+    PL_curcop = (COP *)Nullop;
+    PL_markstack = 0;
+    PL_scopestack = 0;
+    PL_savestack = 0;
+    PL_savestack_ix = 0;
+    PL_savestack_max = -1;
+    PL_sig_pending = 0;
+    Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+#    else      /* !DEBUGGING */
+    Zero(my_perl, 1, PerlInterpreter);
+#    endif     /* DEBUGGING */
+#endif         /* PERL_IMPLICIT_SYS */
+    param->flags = flags;
+    param->proto_perl = proto_perl;
+
+    Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
+    Zero(&PL_body_roots, 1, PL_body_roots);
+    
+    PL_nice_chunk      = NULL;
+    PL_nice_chunk_size = 0;
+    PL_sv_count                = 0;
+    PL_sv_objcount     = 0;
+    PL_sv_root         = Nullsv;
+    PL_sv_arenaroot    = Nullsv;
+
+    PL_debug           = proto_perl->Idebug;
+
+    PL_hash_seed       = proto_perl->Ihash_seed;
+    PL_rehash_seed     = proto_perl->Irehash_seed;
+
+#ifdef USE_REENTRANT_API
+    /* XXX: things like -Dm will segfault here in perlio, but doing
+     *  PERL_SET_CONTEXT(proto_perl);
+     * breaks too many other things
+     */
+    Perl_reentrant_init(aTHX);
+#endif
+
+    /* create SV map for pointer relocation */
+    PL_ptr_table = ptr_table_new();
+
+    /* initialize these special pointers as early as possible */
+    SvANY(&PL_sv_undef)                = NULL;
+    SvREFCNT(&PL_sv_undef)     = (~(U32)0)/2;
+    SvFLAGS(&PL_sv_undef)      = SVf_READONLY|SVt_NULL;
+    ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
+
+    SvANY(&PL_sv_no)           = new_XPVNV();
+    SvREFCNT(&PL_sv_no)                = (~(U32)0)/2;
+    SvFLAGS(&PL_sv_no)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+                                 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+    SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
+    SvCUR_set(&PL_sv_no, 0);
+    SvLEN_set(&PL_sv_no, 1);
+    SvIV_set(&PL_sv_no, 0);
+    SvNV_set(&PL_sv_no, 0);
+    ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
+
+    SvANY(&PL_sv_yes)          = new_XPVNV();
+    SvREFCNT(&PL_sv_yes)       = (~(U32)0)/2;
+    SvFLAGS(&PL_sv_yes)                = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+                                 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+    SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
+    SvCUR_set(&PL_sv_yes, 1);
+    SvLEN_set(&PL_sv_yes, 2);
+    SvIV_set(&PL_sv_yes, 1);
+    SvNV_set(&PL_sv_yes, 1);
+    ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+
+    /* create (a non-shared!) shared string table */
+    PL_strtab          = newHV();
+    HvSHAREKEYS_off(PL_strtab);
+    hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
+    ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+
+    PL_compiling = proto_perl->Icompiling;
+
+    /* These two PVs will be free'd special way so must set them same way op.c does */
+    PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
+    ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
+
+    PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
+    ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+
+    ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
+    if (!specialWARN(PL_compiling.cop_warnings))
+       PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+    if (!specialCopIO(PL_compiling.cop_io))
+       PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
+    PL_curcop          = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
+
+    /* pseudo environmental stuff */
+    PL_origargc                = proto_perl->Iorigargc;
+    PL_origargv                = proto_perl->Iorigargv;
+
+    param->stashes      = newAV();  /* Setup array of objects to call clone on */
+
+    /* Set tainting stuff before PerlIO_debug can possibly get called */
+    PL_tainting                = proto_perl->Itainting;
+    PL_taint_warn      = proto_perl->Itaint_warn;
+
+#ifdef PERLIO_LAYERS
+    /* Clone PerlIO tables as soon as we can handle general xx_dup() */
+    PerlIO_clone(aTHX_ proto_perl, param);
+#endif
+
+    PL_envgv           = gv_dup(proto_perl->Ienvgv, param);
+    PL_incgv           = gv_dup(proto_perl->Iincgv, param);
+    PL_hintgv          = gv_dup(proto_perl->Ihintgv, param);
+    PL_origfilename    = SAVEPV(proto_perl->Iorigfilename);
+    PL_diehook         = sv_dup_inc(proto_perl->Idiehook, param);
+    PL_warnhook                = sv_dup_inc(proto_perl->Iwarnhook, param);
+
+    /* switches */
+    PL_minus_c         = proto_perl->Iminus_c;
+    PL_patchlevel      = sv_dup_inc(proto_perl->Ipatchlevel, param);
+    PL_localpatches    = proto_perl->Ilocalpatches;
+    PL_splitstr                = proto_perl->Isplitstr;
+    PL_preprocess      = proto_perl->Ipreprocess;
+    PL_minus_n         = proto_perl->Iminus_n;
+    PL_minus_p         = proto_perl->Iminus_p;
+    PL_minus_l         = proto_perl->Iminus_l;
+    PL_minus_a         = proto_perl->Iminus_a;
+    PL_minus_F         = proto_perl->Iminus_F;
+    PL_doswitches      = proto_perl->Idoswitches;
+    PL_dowarn          = proto_perl->Idowarn;
+    PL_doextract       = proto_perl->Idoextract;
+    PL_sawampersand    = proto_perl->Isawampersand;
+    PL_unsafe          = proto_perl->Iunsafe;
+    PL_inplace         = SAVEPV(proto_perl->Iinplace);
+    PL_e_script                = sv_dup_inc(proto_perl->Ie_script, param);
+    PL_perldb          = proto_perl->Iperldb;
+    PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
+    PL_exit_flags       = proto_perl->Iexit_flags;
+
+    /* magical thingies */
+    /* XXX time(&PL_basetime) when asked for? */
+    PL_basetime                = proto_perl->Ibasetime;
+    PL_formfeed                = sv_dup(proto_perl->Iformfeed, param);
+
+    PL_maxsysfd                = proto_perl->Imaxsysfd;
+    PL_multiline       = proto_perl->Imultiline;
+    PL_statusvalue     = proto_perl->Istatusvalue;
+#ifdef VMS
+    PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
+#else
+    PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
+#endif
+    PL_encoding                = sv_dup(proto_perl->Iencoding, param);
+
+    sv_setpvn(PERL_DEBUG_PAD(0), "", 0);       /* For regex debugging. */
+    sv_setpvn(PERL_DEBUG_PAD(1), "", 0);       /* ext/re needs these */
+    sv_setpvn(PERL_DEBUG_PAD(2), "", 0);       /* even without DEBUGGING. */
+
+    /* Clone the regex array */
+    PL_regex_padav = newAV();
+    {
+       const I32 len = av_len((AV*)proto_perl->Iregex_padav);
+       SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+       IV i;
+       av_push(PL_regex_padav,
+               sv_dup_inc(regexen[0],param));
+       for(i = 1; i <= len; i++) {
+            if(SvREPADTMP(regexen[i])) {
+             av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
+            } else {
+               av_push(PL_regex_padav,
+                    SvREFCNT_inc(
+                        newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
+                             SvIVX(regexen[i])), param)))
+                       ));
+           }
+       }
+    }
+    PL_regex_pad = AvARRAY(PL_regex_padav);
+
+    /* shortcuts to various I/O objects */
+    PL_stdingv         = gv_dup(proto_perl->Istdingv, param);
+    PL_stderrgv                = gv_dup(proto_perl->Istderrgv, param);
+    PL_defgv           = gv_dup(proto_perl->Idefgv, param);
+    PL_argvgv          = gv_dup(proto_perl->Iargvgv, param);
+    PL_argvoutgv       = gv_dup(proto_perl->Iargvoutgv, param);
+    PL_argvout_stack   = av_dup_inc(proto_perl->Iargvout_stack, param);
 
+    /* shortcuts to regexp stuff */
+    PL_replgv          = gv_dup(proto_perl->Ireplgv, param);
 
-/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
- * flag to the result. This is done for each stash before cloning starts,
- * so we know which stashes want their objects cloned */
+    /* shortcuts to misc objects */
+    PL_errgv           = gv_dup(proto_perl->Ierrgv, param);
 
-static void
-do_mark_cloneable_stash(pTHX_ SV *sv)
-{
-    const HEK * const hvname = HvNAME_HEK((HV*)sv);
-    if (hvname) {
-       GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
-       SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
-       if (cloner && GvCV(cloner)) {
-           dSP;
-           UV status;
+    /* shortcuts to debugging objects */
+    PL_DBgv            = gv_dup(proto_perl->IDBgv, param);
+    PL_DBline          = gv_dup(proto_perl->IDBline, param);
+    PL_DBsub           = gv_dup(proto_perl->IDBsub, param);
+    PL_DBsingle                = sv_dup(proto_perl->IDBsingle, param);
+    PL_DBtrace         = sv_dup(proto_perl->IDBtrace, param);
+    PL_DBsignal                = sv_dup(proto_perl->IDBsignal, param);
+    PL_DBassertion      = sv_dup(proto_perl->IDBassertion, param);
+    PL_lineary         = av_dup(proto_perl->Ilineary, param);
+    PL_dbargs          = av_dup(proto_perl->Idbargs, param);
 
-           ENTER;
-           SAVETMPS;
-           PUSHMARK(SP);
-           XPUSHs(sv_2mortal(newSVhek(hvname)));
-           PUTBACK;
-           call_sv((SV*)GvCV(cloner), G_SCALAR);
-           SPAGAIN;
-           status = POPu;
-           PUTBACK;
-           FREETMPS;
-           LEAVE;
-           if (status)
-               SvFLAGS(sv) &= ~SVphv_CLONEABLE;
-       }
+    /* symbol tables */
+    PL_defstash                = hv_dup_inc(proto_perl->Tdefstash, param);
+    PL_curstash                = hv_dup(proto_perl->Tcurstash, param);
+    PL_debstash                = hv_dup(proto_perl->Idebstash, param);
+    PL_globalstash     = hv_dup(proto_perl->Iglobalstash, param);
+    PL_curstname       = sv_dup_inc(proto_perl->Icurstname, param);
+
+    PL_beginav         = av_dup_inc(proto_perl->Ibeginav, param);
+    PL_beginav_save    = av_dup_inc(proto_perl->Ibeginav_save, param);
+    PL_checkav_save    = av_dup_inc(proto_perl->Icheckav_save, param);
+    PL_endav           = av_dup_inc(proto_perl->Iendav, param);
+    PL_checkav         = av_dup_inc(proto_perl->Icheckav, param);
+    PL_initav          = av_dup_inc(proto_perl->Iinitav, param);
+
+    PL_sub_generation  = proto_perl->Isub_generation;
+
+    /* funky return mechanisms */
+    PL_forkprocess     = proto_perl->Iforkprocess;
+
+    /* subprocess state */
+    PL_fdpid           = av_dup_inc(proto_perl->Ifdpid, param);
+
+    /* internal state */
+    PL_maxo            = proto_perl->Imaxo;
+    if (proto_perl->Iop_mask)
+       PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
+    else
+       PL_op_mask      = Nullch;
+    /* PL_asserting        = proto_perl->Iasserting; */
+
+    /* current interpreter roots */
+    PL_main_cv         = cv_dup_inc(proto_perl->Imain_cv, param);
+    PL_main_root       = OpREFCNT_inc(proto_perl->Imain_root);
+    PL_main_start      = proto_perl->Imain_start;
+    PL_eval_root       = proto_perl->Ieval_root;
+    PL_eval_start      = proto_perl->Ieval_start;
+
+    /* runtime control stuff */
+    PL_curcopdb                = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
+    PL_copline         = proto_perl->Icopline;
+
+    PL_filemode                = proto_perl->Ifilemode;
+    PL_lastfd          = proto_perl->Ilastfd;
+    PL_oldname         = proto_perl->Ioldname;         /* XXX not quite right */
+    PL_Argv            = NULL;
+    PL_Cmd             = Nullch;
+    PL_gensym          = proto_perl->Igensym;
+    PL_preambled       = proto_perl->Ipreambled;
+    PL_preambleav      = av_dup_inc(proto_perl->Ipreambleav, param);
+    PL_laststatval     = proto_perl->Ilaststatval;
+    PL_laststype       = proto_perl->Ilaststype;
+    PL_mess_sv         = Nullsv;
+
+    PL_ors_sv          = sv_dup_inc(proto_perl->Iors_sv, param);
+
+    /* interpreter atexit processing */
+    PL_exitlistlen     = proto_perl->Iexitlistlen;
+    if (PL_exitlistlen) {
+       Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+       Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
     }
-}
+    else
+       PL_exitlist     = (PerlExitListEntry*)NULL;
+    PL_modglobal       = hv_dup_inc(proto_perl->Imodglobal, param);
+    PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
+    PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+
+    PL_profiledata     = NULL;
+    PL_rsfp            = fp_dup(proto_perl->Irsfp, '<', param);
+    /* PL_rsfp_filters entries have fake IoDIRP() */
+    PL_rsfp_filters    = av_dup_inc(proto_perl->Irsfp_filters, param);
 
+    PL_compcv                  = cv_dup(proto_perl->Icompcv, param);
 
+    PAD_CLONE_VARS(proto_perl, param);
 
-/*
-=for apidoc perl_clone
+#ifdef HAVE_INTERP_INTERN
+    sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
+#endif
 
-Create and return a new interpreter by cloning the current one.
+    /* more statics moved here */
+    PL_generation      = proto_perl->Igeneration;
+    PL_DBcv            = cv_dup(proto_perl->IDBcv, param);
 
-perl_clone takes these flags as parameters:
+    PL_in_clean_objs   = proto_perl->Iin_clean_objs;
+    PL_in_clean_all    = proto_perl->Iin_clean_all;
 
-CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
-without it we only clone the data and zero the stacks,
-with it we copy the stacks and the new perl interpreter is
-ready to run at the exact same point as the previous one.
-The pseudo-fork code uses COPY_STACKS while the
-threads->new doesn't.
+    PL_uid             = proto_perl->Iuid;
+    PL_euid            = proto_perl->Ieuid;
+    PL_gid             = proto_perl->Igid;
+    PL_egid            = proto_perl->Iegid;
+    PL_nomemok         = proto_perl->Inomemok;
+    PL_an              = proto_perl->Ian;
+    PL_evalseq         = proto_perl->Ievalseq;
+    PL_origenviron     = proto_perl->Iorigenviron;     /* XXX not quite right */
+    PL_origalen                = proto_perl->Iorigalen;
+#ifdef PERL_USES_PL_PIDSTATUS
+    PL_pidstatus       = newHV();                      /* XXX flag for cloning? */
+#endif
+    PL_osname          = SAVEPV(proto_perl->Iosname);
+    PL_sighandlerp     = proto_perl->Isighandlerp;
 
-CLONEf_KEEP_PTR_TABLE
-perl_clone keeps a ptr_table with the pointer of the old
-variable as a key and the new variable as a value,
-this allows it to check if something has been cloned and not
-clone it again but rather just use the value and increase the
-refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
-the ptr_table using the function
-C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
-reason to keep it around is if you want to dup some of your own
-variable who are outside the graph perl scans, example of this
-code is in threads.xs create
+    PL_runops          = proto_perl->Irunops;
 
-CLONEf_CLONE_HOST
-This is a win32 thing, it is ignored on unix, it tells perls
-win32host code (which is c++) to clone itself, this is needed on
-win32 if you want to run two threads at the same time,
-if you just want to do some stuff in a separate perl interpreter
-and then throw it away and return to the original one,
-you don't need to do anything.
+    Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
 
-=cut
-*/
+#ifdef CSH
+    PL_cshlen          = proto_perl->Icshlen;
+    PL_cshname         = proto_perl->Icshname; /* XXX never deallocated */
+#endif
 
-/* XXX the above needs expanding by someone who actually understands it ! */
-EXTERN_C PerlInterpreter *
-perl_clone_host(PerlInterpreter* proto_perl, UV flags);
+    PL_lex_state       = proto_perl->Ilex_state;
+    PL_lex_defer       = proto_perl->Ilex_defer;
+    PL_lex_expect      = proto_perl->Ilex_expect;
+    PL_lex_formbrack   = proto_perl->Ilex_formbrack;
+    PL_lex_dojoin      = proto_perl->Ilex_dojoin;
+    PL_lex_starts      = proto_perl->Ilex_starts;
+    PL_lex_stuff       = sv_dup_inc(proto_perl->Ilex_stuff, param);
+    PL_lex_repl                = sv_dup_inc(proto_perl->Ilex_repl, param);
+    PL_lex_op          = proto_perl->Ilex_op;
+    PL_lex_inpat       = proto_perl->Ilex_inpat;
+    PL_lex_inwhat      = proto_perl->Ilex_inwhat;
+    PL_lex_brackets    = proto_perl->Ilex_brackets;
+    i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
+    PL_lex_brackstack  = SAVEPVN(proto_perl->Ilex_brackstack,i);
+    PL_lex_casemods    = proto_perl->Ilex_casemods;
+    i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
+    PL_lex_casestack   = SAVEPVN(proto_perl->Ilex_casestack,i);
 
-PerlInterpreter *
-perl_clone(PerlInterpreter *proto_perl, UV flags)
-{
-   dVAR;
-#ifdef PERL_IMPLICIT_SYS
+    Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
+    Copy(proto_perl->Inexttype, PL_nexttype, 5,        I32);
+    PL_nexttoke                = proto_perl->Inexttoke;
 
-   /* perlhost.h so we need to call into it
-   to clone the host, CPerlHost should have a c interface, sky */
+    /* XXX This is probably masking the deeper issue of why
+     * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
+     * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
+     * (A little debugging with a watchpoint on it may help.)
+     */
+    if (SvANY(proto_perl->Ilinestr)) {
+       PL_linestr              = sv_dup_inc(proto_perl->Ilinestr, param);
+       i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
+       PL_bufptr               = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+       i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
+       PL_oldbufptr    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+       i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
+       PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+       i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
+       PL_linestart    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+    }
+    else {
+        PL_linestr = NEWSV(65,79);
+        sv_upgrade(PL_linestr,SVt_PVIV);
+        sv_setpvn(PL_linestr,"",0);
+       PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+    }
+    PL_bufend          = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+    PL_pending_ident   = proto_perl->Ipending_ident;
+    PL_sublex_info     = proto_perl->Isublex_info;     /* XXX not quite right */
+
+    PL_expect          = proto_perl->Iexpect;
+
+    PL_multi_start     = proto_perl->Imulti_start;
+    PL_multi_end       = proto_perl->Imulti_end;
+    PL_multi_open      = proto_perl->Imulti_open;
+    PL_multi_close     = proto_perl->Imulti_close;
+
+    PL_error_count     = proto_perl->Ierror_count;
+    PL_subline         = proto_perl->Isubline;
+    PL_subname         = sv_dup_inc(proto_perl->Isubname, param);
 
-   if (flags & CLONEf_CLONE_HOST) {
-       return perl_clone_host(proto_perl,flags);
-   }
-   return perl_clone_using(proto_perl, flags,
-                           proto_perl->IMem,
-                           proto_perl->IMemShared,
-                           proto_perl->IMemParse,
-                           proto_perl->IEnv,
-                           proto_perl->IStdIO,
-                           proto_perl->ILIO,
-                           proto_perl->IDir,
-                           proto_perl->ISock,
-                           proto_perl->IProc);
-}
+    /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
+    if (SvANY(proto_perl->Ilinestr)) {
+       i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
+       PL_last_uni             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+       i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
+       PL_last_lop             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+       PL_last_lop_op  = proto_perl->Ilast_lop_op;
+    }
+    else {
+       PL_last_uni     = SvPVX(PL_linestr);
+       PL_last_lop     = SvPVX(PL_linestr);
+       PL_last_lop_op  = 0;
+    }
+    PL_in_my           = proto_perl->Iin_my;
+    PL_in_my_stash     = hv_dup(proto_perl->Iin_my_stash, param);
+#ifdef FCRYPT
+    PL_cryptseen       = proto_perl->Icryptseen;
+#endif
 
-PerlInterpreter *
-perl_clone_using(PerlInterpreter *proto_perl, UV flags,
-                struct IPerlMem* ipM, struct IPerlMem* ipMS,
-                struct IPerlMem* ipMP, struct IPerlEnv* ipE,
-                struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
-                struct IPerlDir* ipD, struct IPerlSock* ipS,
-                struct IPerlProc* ipP)
-{
-    /* XXX many of the string copies here can be optimized if they're
-     * constants; they need to be allocated as common memory and just
-     * their pointers copied. */
+    PL_hints           = proto_perl->Ihints;
 
-    IV i;
-    CLONE_PARAMS clone_params;
-    CLONE_PARAMS* param = &clone_params;
+    PL_amagic_generation       = proto_perl->Iamagic_generation;
 
-    PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
-    /* for each stash, determine whether its objects should be cloned */
-    S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
-    PERL_SET_THX(my_perl);
+#ifdef USE_LOCALE_COLLATE
+    PL_collation_ix    = proto_perl->Icollation_ix;
+    PL_collation_name  = SAVEPV(proto_perl->Icollation_name);
+    PL_collation_standard      = proto_perl->Icollation_standard;
+    PL_collxfrm_base   = proto_perl->Icollxfrm_base;
+    PL_collxfrm_mult   = proto_perl->Icollxfrm_mult;
+#endif /* USE_LOCALE_COLLATE */
 
-#  ifdef DEBUGGING
-    Poison(my_perl, 1, PerlInterpreter);
-    PL_op = Nullop;
-    PL_curcop = (COP *)Nullop;
-    PL_markstack = 0;
-    PL_scopestack = 0;
-    PL_savestack = 0;
-    PL_savestack_ix = 0;
-    PL_savestack_max = -1;
-    PL_sig_pending = 0;
-    Zero(&PL_debug_pad, 1, struct perl_debug_pad);
-#  else        /* !DEBUGGING */
-    Zero(my_perl, 1, PerlInterpreter);
-#  endif       /* DEBUGGING */
+#ifdef USE_LOCALE_NUMERIC
+    PL_numeric_name    = SAVEPV(proto_perl->Inumeric_name);
+    PL_numeric_standard        = proto_perl->Inumeric_standard;
+    PL_numeric_local   = proto_perl->Inumeric_local;
+    PL_numeric_radix_sv        = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
+#endif /* !USE_LOCALE_NUMERIC */
 
-    /* host pointers */
-    PL_Mem             = ipM;
-    PL_MemShared       = ipMS;
-    PL_MemParse                = ipMP;
-    PL_Env             = ipE;
-    PL_StdIO           = ipStd;
-    PL_LIO             = ipLIO;
-    PL_Dir             = ipD;
-    PL_Sock            = ipS;
-    PL_Proc            = ipP;
-#else          /* !PERL_IMPLICIT_SYS */
-    IV i;
-    CLONE_PARAMS clone_params;
-    CLONE_PARAMS* param = &clone_params;
-    PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
-    /* for each stash, determine whether its objects should be cloned */
-    S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
-    PERL_SET_THX(my_perl);
+    /* utf8 character classes */
+    PL_utf8_alnum      = sv_dup_inc(proto_perl->Iutf8_alnum, param);
+    PL_utf8_alnumc     = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
+    PL_utf8_ascii      = sv_dup_inc(proto_perl->Iutf8_ascii, param);
+    PL_utf8_alpha      = sv_dup_inc(proto_perl->Iutf8_alpha, param);
+    PL_utf8_space      = sv_dup_inc(proto_perl->Iutf8_space, param);
+    PL_utf8_cntrl      = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
+    PL_utf8_graph      = sv_dup_inc(proto_perl->Iutf8_graph, param);
+    PL_utf8_digit      = sv_dup_inc(proto_perl->Iutf8_digit, param);
+    PL_utf8_upper      = sv_dup_inc(proto_perl->Iutf8_upper, param);
+    PL_utf8_lower      = sv_dup_inc(proto_perl->Iutf8_lower, param);
+    PL_utf8_print      = sv_dup_inc(proto_perl->Iutf8_print, param);
+    PL_utf8_punct      = sv_dup_inc(proto_perl->Iutf8_punct, param);
+    PL_utf8_xdigit     = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
+    PL_utf8_mark       = sv_dup_inc(proto_perl->Iutf8_mark, param);
+    PL_utf8_toupper    = sv_dup_inc(proto_perl->Iutf8_toupper, param);
+    PL_utf8_totitle    = sv_dup_inc(proto_perl->Iutf8_totitle, param);
+    PL_utf8_tolower    = sv_dup_inc(proto_perl->Iutf8_tolower, param);
+    PL_utf8_tofold     = sv_dup_inc(proto_perl->Iutf8_tofold, param);
+    PL_utf8_idstart    = sv_dup_inc(proto_perl->Iutf8_idstart, param);
+    PL_utf8_idcont     = sv_dup_inc(proto_perl->Iutf8_idcont, param);
 
-#    ifdef DEBUGGING
-    Poison(my_perl, 1, PerlInterpreter);
-    PL_op = Nullop;
-    PL_curcop = (COP *)Nullop;
-    PL_markstack = 0;
-    PL_scopestack = 0;
-    PL_savestack = 0;
-    PL_savestack_ix = 0;
-    PL_savestack_max = -1;
-    PL_sig_pending = 0;
-    Zero(&PL_debug_pad, 1, struct perl_debug_pad);
-#    else      /* !DEBUGGING */
-    Zero(my_perl, 1, PerlInterpreter);
-#    endif     /* DEBUGGING */
-#endif         /* PERL_IMPLICIT_SYS */
-    param->flags = flags;
-    param->proto_perl = proto_perl;
+    /* Did the locale setup indicate UTF-8? */
+    PL_utf8locale      = proto_perl->Iutf8locale;
+    /* Unicode features (see perlrun/-C) */
+    PL_unicode         = proto_perl->Iunicode;
 
-    Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
-    Zero(&PL_body_roots, 1, PL_body_roots);
-    
-    PL_nice_chunk      = NULL;
-    PL_nice_chunk_size = 0;
-    PL_sv_count                = 0;
-    PL_sv_objcount     = 0;
-    PL_sv_root         = Nullsv;
-    PL_sv_arenaroot    = Nullsv;
+    /* Pre-5.8 signals control */
+    PL_signals         = proto_perl->Isignals;
 
-    PL_debug           = proto_perl->Idebug;
+    /* times() ticks per second */
+    PL_clocktick       = proto_perl->Iclocktick;
 
-    PL_hash_seed       = proto_perl->Ihash_seed;
-    PL_rehash_seed     = proto_perl->Irehash_seed;
+    /* Recursion stopper for PerlIO_find_layer */
+    PL_in_load_module  = proto_perl->Iin_load_module;
 
-#ifdef USE_REENTRANT_API
-    /* XXX: things like -Dm will segfault here in perlio, but doing
-     *  PERL_SET_CONTEXT(proto_perl);
-     * breaks too many other things
-     */
-    Perl_reentrant_init(aTHX);
-#endif
+    /* sort() routine */
+    PL_sort_RealCmp    = proto_perl->Isort_RealCmp;
 
-    /* create SV map for pointer relocation */
-    PL_ptr_table = ptr_table_new();
+    /* Not really needed/useful since the reenrant_retint is "volatile",
+     * but do it for consistency's sake. */
+    PL_reentrant_retint        = proto_perl->Ireentrant_retint;
 
-    /* initialize these special pointers as early as possible */
-    SvANY(&PL_sv_undef)                = NULL;
-    SvREFCNT(&PL_sv_undef)     = (~(U32)0)/2;
-    SvFLAGS(&PL_sv_undef)      = SVf_READONLY|SVt_NULL;
-    ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
+    /* Hooks to shared SVs and locks. */
+    PL_sharehook       = proto_perl->Isharehook;
+    PL_lockhook                = proto_perl->Ilockhook;
+    PL_unlockhook      = proto_perl->Iunlockhook;
+    PL_threadhook      = proto_perl->Ithreadhook;
 
-    SvANY(&PL_sv_no)           = new_XPVNV();
-    SvREFCNT(&PL_sv_no)                = (~(U32)0)/2;
-    SvFLAGS(&PL_sv_no)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
-                                 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
-    SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
-    SvCUR_set(&PL_sv_no, 0);
-    SvLEN_set(&PL_sv_no, 1);
-    SvIV_set(&PL_sv_no, 0);
-    SvNV_set(&PL_sv_no, 0);
-    ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
+    PL_runops_std      = proto_perl->Irunops_std;
+    PL_runops_dbg      = proto_perl->Irunops_dbg;
 
-    SvANY(&PL_sv_yes)          = new_XPVNV();
-    SvREFCNT(&PL_sv_yes)       = (~(U32)0)/2;
-    SvFLAGS(&PL_sv_yes)                = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
-                                 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
-    SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
-    SvCUR_set(&PL_sv_yes, 1);
-    SvLEN_set(&PL_sv_yes, 2);
-    SvIV_set(&PL_sv_yes, 1);
-    SvNV_set(&PL_sv_yes, 1);
-    ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+#ifdef THREADS_HAVE_PIDS
+    PL_ppid            = proto_perl->Ippid;
+#endif
 
-    /* create (a non-shared!) shared string table */
-    PL_strtab          = newHV();
-    HvSHAREKEYS_off(PL_strtab);
-    hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
-    ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+    /* swatch cache */
+    PL_last_swash_hv   = Nullhv;       /* reinits on demand */
+    PL_last_swash_klen = 0;
+    PL_last_swash_key[0]= '\0';
+    PL_last_swash_tmps = (U8*)NULL;
+    PL_last_swash_slen = 0;
 
-    PL_compiling = proto_perl->Icompiling;
+    PL_glob_index      = proto_perl->Iglob_index;
+    PL_srand_called    = proto_perl->Isrand_called;
+    PL_uudmap['M']     = 0;            /* reinits on demand */
+    PL_bitcount                = Nullch;       /* reinits on demand */
 
-    /* These two PVs will be free'd special way so must set them same way op.c does */
-    PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
-    ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
+    if (proto_perl->Ipsig_pend) {
+       Newxz(PL_psig_pend, SIG_SIZE, int);
+    }
+    else {
+       PL_psig_pend    = (int*)NULL;
+    }
 
-    PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
-    ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+    if (proto_perl->Ipsig_ptr) {
+       Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
+       Newxz(PL_psig_name, SIG_SIZE, SV*);
+       for (i = 1; i < SIG_SIZE; i++) {
+           PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
+           PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
+       }
+    }
+    else {
+       PL_psig_ptr     = (SV**)NULL;
+       PL_psig_name    = (SV**)NULL;
+    }
 
-    ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
-    if (!specialWARN(PL_compiling.cop_warnings))
-       PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
-    if (!specialCopIO(PL_compiling.cop_io))
-       PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
-    PL_curcop          = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
+    /* thrdvar.h stuff */
 
-    /* pseudo environmental stuff */
-    PL_origargc                = proto_perl->Iorigargc;
-    PL_origargv                = proto_perl->Iorigargv;
+    if (flags & CLONEf_COPY_STACKS) {
+       /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
+       PL_tmps_ix              = proto_perl->Ttmps_ix;
+       PL_tmps_max             = proto_perl->Ttmps_max;
+       PL_tmps_floor           = proto_perl->Ttmps_floor;
+       Newxz(PL_tmps_stack, PL_tmps_max, SV*);
+       i = 0;
+       while (i <= PL_tmps_ix) {
+           PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
+           ++i;
+       }
 
-    param->stashes      = newAV();  /* Setup array of objects to call clone on */
+       /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
+       i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
+       Newxz(PL_markstack, i, I32);
+       PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
+                                                 - proto_perl->Tmarkstack);
+       PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
+                                                 - proto_perl->Tmarkstack);
+       Copy(proto_perl->Tmarkstack, PL_markstack,
+            PL_markstack_ptr - PL_markstack + 1, I32);
 
-    /* Set tainting stuff before PerlIO_debug can possibly get called */
-    PL_tainting                = proto_perl->Itainting;
-    PL_taint_warn      = proto_perl->Itaint_warn;
+       /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
+        * NOTE: unlike the others! */
+       PL_scopestack_ix        = proto_perl->Tscopestack_ix;
+       PL_scopestack_max       = proto_perl->Tscopestack_max;
+       Newxz(PL_scopestack, PL_scopestack_max, I32);
+       Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
 
-#ifdef PERLIO_LAYERS
-    /* Clone PerlIO tables as soon as we can handle general xx_dup() */
-    PerlIO_clone(aTHX_ proto_perl, param);
-#endif
+       /* NOTE: si_dup() looks at PL_markstack */
+       PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);
 
-    PL_envgv           = gv_dup(proto_perl->Ienvgv, param);
-    PL_incgv           = gv_dup(proto_perl->Iincgv, param);
-    PL_hintgv          = gv_dup(proto_perl->Ihintgv, param);
-    PL_origfilename    = SAVEPV(proto_perl->Iorigfilename);
-    PL_diehook         = sv_dup_inc(proto_perl->Idiehook, param);
-    PL_warnhook                = sv_dup_inc(proto_perl->Iwarnhook, param);
+       /* PL_curstack          = PL_curstackinfo->si_stack; */
+       PL_curstack             = av_dup(proto_perl->Tcurstack, param);
+       PL_mainstack            = av_dup(proto_perl->Tmainstack, param);
 
-    /* switches */
-    PL_minus_c         = proto_perl->Iminus_c;
-    PL_patchlevel      = sv_dup_inc(proto_perl->Ipatchlevel, param);
-    PL_localpatches    = proto_perl->Ilocalpatches;
-    PL_splitstr                = proto_perl->Isplitstr;
-    PL_preprocess      = proto_perl->Ipreprocess;
-    PL_minus_n         = proto_perl->Iminus_n;
-    PL_minus_p         = proto_perl->Iminus_p;
-    PL_minus_l         = proto_perl->Iminus_l;
-    PL_minus_a         = proto_perl->Iminus_a;
-    PL_minus_F         = proto_perl->Iminus_F;
-    PL_doswitches      = proto_perl->Idoswitches;
-    PL_dowarn          = proto_perl->Idowarn;
-    PL_doextract       = proto_perl->Idoextract;
-    PL_sawampersand    = proto_perl->Isawampersand;
-    PL_unsafe          = proto_perl->Iunsafe;
-    PL_inplace         = SAVEPV(proto_perl->Iinplace);
-    PL_e_script                = sv_dup_inc(proto_perl->Ie_script, param);
-    PL_perldb          = proto_perl->Iperldb;
-    PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
-    PL_exit_flags       = proto_perl->Iexit_flags;
+       /* next PUSHs() etc. set *(PL_stack_sp+1) */
+       PL_stack_base           = AvARRAY(PL_curstack);
+       PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
+                                                  - proto_perl->Tstack_base);
+       PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
 
-    /* magical thingies */
-    /* XXX time(&PL_basetime) when asked for? */
-    PL_basetime                = proto_perl->Ibasetime;
-    PL_formfeed                = sv_dup(proto_perl->Iformfeed, param);
+       /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
+        * NOTE: unlike the others! */
+       PL_savestack_ix         = proto_perl->Tsavestack_ix;
+       PL_savestack_max        = proto_perl->Tsavestack_max;
+       /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
+       PL_savestack            = ss_dup(proto_perl, param);
+    }
+    else {
+       init_stacks();
+       ENTER;                  /* perl_destruct() wants to LEAVE; */
+    }
 
-    PL_maxsysfd                = proto_perl->Imaxsysfd;
-    PL_multiline       = proto_perl->Imultiline;
-    PL_statusvalue     = proto_perl->Istatusvalue;
-#ifdef VMS
-    PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
-#else
-    PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
-#endif
-    PL_encoding                = sv_dup(proto_perl->Iencoding, param);
+    PL_start_env       = proto_perl->Tstart_env;       /* XXXXXX */
+    PL_top_env         = &PL_start_env;
 
-    sv_setpvn(PERL_DEBUG_PAD(0), "", 0);       /* For regex debugging. */
-    sv_setpvn(PERL_DEBUG_PAD(1), "", 0);       /* ext/re needs these */
-    sv_setpvn(PERL_DEBUG_PAD(2), "", 0);       /* even without DEBUGGING. */
+    PL_op              = proto_perl->Top;
 
-    /* Clone the regex array */
-    PL_regex_padav = newAV();
-    {
-       const I32 len = av_len((AV*)proto_perl->Iregex_padav);
-       SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
-       IV i;
-       av_push(PL_regex_padav,
-               sv_dup_inc(regexen[0],param));
-       for(i = 1; i <= len; i++) {
-            if(SvREPADTMP(regexen[i])) {
-             av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
-            } else {
-               av_push(PL_regex_padav,
-                    SvREFCNT_inc(
-                        newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
-                             SvIVX(regexen[i])), param)))
-                       ));
-           }
-       }
-    }
-    PL_regex_pad = AvARRAY(PL_regex_padav);
+    PL_Sv              = Nullsv;
+    PL_Xpv             = (XPV*)NULL;
+    PL_na              = proto_perl->Tna;
 
-    /* shortcuts to various I/O objects */
-    PL_stdingv         = gv_dup(proto_perl->Istdingv, param);
-    PL_stderrgv                = gv_dup(proto_perl->Istderrgv, param);
-    PL_defgv           = gv_dup(proto_perl->Idefgv, param);
-    PL_argvgv          = gv_dup(proto_perl->Iargvgv, param);
-    PL_argvoutgv       = gv_dup(proto_perl->Iargvoutgv, param);
-    PL_argvout_stack   = av_dup_inc(proto_perl->Iargvout_stack, param);
+    PL_statbuf         = proto_perl->Tstatbuf;
+    PL_statcache       = proto_perl->Tstatcache;
+    PL_statgv          = gv_dup(proto_perl->Tstatgv, param);
+    PL_statname                = sv_dup_inc(proto_perl->Tstatname, param);
+#ifdef HAS_TIMES
+    PL_timesbuf                = proto_perl->Ttimesbuf;
+#endif
 
-    /* shortcuts to regexp stuff */
-    PL_replgv          = gv_dup(proto_perl->Ireplgv, param);
+    PL_tainted         = proto_perl->Ttainted;
+    PL_curpm           = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
+    PL_rs              = sv_dup_inc(proto_perl->Trs, param);
+    PL_last_in_gv      = gv_dup(proto_perl->Tlast_in_gv, param);
+    PL_ofs_sv          = sv_dup_inc(proto_perl->Tofs_sv, param);
+    PL_defoutgv                = gv_dup_inc(proto_perl->Tdefoutgv, param);
+    PL_chopset         = proto_perl->Tchopset; /* XXX never deallocated */
+    PL_toptarget       = sv_dup_inc(proto_perl->Ttoptarget, param);
+    PL_bodytarget      = sv_dup_inc(proto_perl->Tbodytarget, param);
+    PL_formtarget      = sv_dup(proto_perl->Tformtarget, param);
 
-    /* shortcuts to misc objects */
-    PL_errgv           = gv_dup(proto_perl->Ierrgv, param);
+    PL_restartop       = proto_perl->Trestartop;
+    PL_in_eval         = proto_perl->Tin_eval;
+    PL_delaymagic      = proto_perl->Tdelaymagic;
+    PL_dirty           = proto_perl->Tdirty;
+    PL_localizing      = proto_perl->Tlocalizing;
 
-    /* shortcuts to debugging objects */
-    PL_DBgv            = gv_dup(proto_perl->IDBgv, param);
-    PL_DBline          = gv_dup(proto_perl->IDBline, param);
-    PL_DBsub           = gv_dup(proto_perl->IDBsub, param);
-    PL_DBsingle                = sv_dup(proto_perl->IDBsingle, param);
-    PL_DBtrace         = sv_dup(proto_perl->IDBtrace, param);
-    PL_DBsignal                = sv_dup(proto_perl->IDBsignal, param);
-    PL_DBassertion      = sv_dup(proto_perl->IDBassertion, param);
-    PL_lineary         = av_dup(proto_perl->Ilineary, param);
-    PL_dbargs          = av_dup(proto_perl->Idbargs, param);
+    PL_errors          = sv_dup_inc(proto_perl->Terrors, param);
+    PL_hv_fetch_ent_mh = Nullhe;
+    PL_modcount                = proto_perl->Tmodcount;
+    PL_lastgotoprobe   = Nullop;
+    PL_dumpindent      = proto_perl->Tdumpindent;
 
-    /* symbol tables */
-    PL_defstash                = hv_dup_inc(proto_perl->Tdefstash, param);
-    PL_curstash                = hv_dup(proto_perl->Tcurstash, param);
-    PL_debstash                = hv_dup(proto_perl->Idebstash, param);
-    PL_globalstash     = hv_dup(proto_perl->Iglobalstash, param);
-    PL_curstname       = sv_dup_inc(proto_perl->Icurstname, param);
+    PL_sortcop         = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
+    PL_sortstash       = hv_dup(proto_perl->Tsortstash, param);
+    PL_firstgv         = gv_dup(proto_perl->Tfirstgv, param);
+    PL_secondgv                = gv_dup(proto_perl->Tsecondgv, param);
+    PL_efloatbuf       = Nullch;               /* reinits on demand */
+    PL_efloatsize      = 0;                    /* reinits on demand */
 
-    PL_beginav         = av_dup_inc(proto_perl->Ibeginav, param);
-    PL_beginav_save    = av_dup_inc(proto_perl->Ibeginav_save, param);
-    PL_checkav_save    = av_dup_inc(proto_perl->Icheckav_save, param);
-    PL_endav           = av_dup_inc(proto_perl->Iendav, param);
-    PL_checkav         = av_dup_inc(proto_perl->Icheckav, param);
-    PL_initav          = av_dup_inc(proto_perl->Iinitav, param);
+    /* regex stuff */
 
-    PL_sub_generation  = proto_perl->Isub_generation;
+    PL_screamfirst     = NULL;
+    PL_screamnext      = NULL;
+    PL_maxscream       = -1;                   /* reinits on demand */
+    PL_lastscream      = Nullsv;
 
-    /* funky return mechanisms */
-    PL_forkprocess     = proto_perl->Iforkprocess;
+    PL_watchaddr       = NULL;
+    PL_watchok         = Nullch;
 
-    /* subprocess state */
-    PL_fdpid           = av_dup_inc(proto_perl->Ifdpid, param);
+    PL_regdummy                = proto_perl->Tregdummy;
+    PL_regprecomp      = Nullch;
+    PL_regnpar         = 0;
+    PL_regsize         = 0;
+    PL_colorset                = 0;            /* reinits PL_colors[] */
+    /*PL_colors[6]     = {0,0,0,0,0,0};*/
+    PL_reginput                = Nullch;
+    PL_regbol          = Nullch;
+    PL_regeol          = Nullch;
+    PL_regstartp       = (I32*)NULL;
+    PL_regendp         = (I32*)NULL;
+    PL_reglastparen    = (U32*)NULL;
+    PL_reglastcloseparen       = (U32*)NULL;
+    PL_regtill         = Nullch;
+    PL_reg_start_tmp   = (char**)NULL;
+    PL_reg_start_tmpl  = 0;
+    PL_regdata         = (struct reg_data*)NULL;
+    PL_bostr           = Nullch;
+    PL_reg_flags       = 0;
+    PL_reg_eval_set    = 0;
+    PL_regnarrate      = 0;
+    PL_regprogram      = (regnode*)NULL;
+    PL_regindent       = 0;
+    PL_regcc           = (CURCUR*)NULL;
+    PL_reg_call_cc     = (struct re_cc_state*)NULL;
+    PL_reg_re          = (regexp*)NULL;
+    PL_reg_ganch       = Nullch;
+    PL_reg_sv          = Nullsv;
+    PL_reg_match_utf8  = FALSE;
+    PL_reg_magic       = (MAGIC*)NULL;
+    PL_reg_oldpos      = 0;
+    PL_reg_oldcurpm    = (PMOP*)NULL;
+    PL_reg_curpm       = (PMOP*)NULL;
+    PL_reg_oldsaved    = Nullch;
+    PL_reg_oldsavedlen = 0;
+#ifdef PERL_OLD_COPY_ON_WRITE
+    PL_nrs             = Nullsv;
+#endif
+    PL_reg_maxiter     = 0;
+    PL_reg_leftiter    = 0;
+    PL_reg_poscache    = Nullch;
+    PL_reg_poscache_size= 0;
 
-    /* internal state */
-    PL_maxo            = proto_perl->Imaxo;
-    if (proto_perl->Iop_mask)
-       PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
-    else
-       PL_op_mask      = Nullch;
-    /* PL_asserting        = proto_perl->Iasserting; */
+    /* RE engine - function pointers */
+    PL_regcompp                = proto_perl->Tregcompp;
+    PL_regexecp                = proto_perl->Tregexecp;
+    PL_regint_start    = proto_perl->Tregint_start;
+    PL_regint_string   = proto_perl->Tregint_string;
+    PL_regfree         = proto_perl->Tregfree;
 
-    /* current interpreter roots */
-    PL_main_cv         = cv_dup_inc(proto_perl->Imain_cv, param);
-    PL_main_root       = OpREFCNT_inc(proto_perl->Imain_root);
-    PL_main_start      = proto_perl->Imain_start;
-    PL_eval_root       = proto_perl->Ieval_root;
-    PL_eval_start      = proto_perl->Ieval_start;
+    PL_reginterp_cnt   = 0;
+    PL_reg_starttry    = 0;
 
-    /* runtime control stuff */
-    PL_curcopdb                = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
-    PL_copline         = proto_perl->Icopline;
+    /* Pluggable optimizer */
+    PL_peepp           = proto_perl->Tpeepp;
 
-    PL_filemode                = proto_perl->Ifilemode;
-    PL_lastfd          = proto_perl->Ilastfd;
-    PL_oldname         = proto_perl->Ioldname;         /* XXX not quite right */
-    PL_Argv            = NULL;
-    PL_Cmd             = Nullch;
-    PL_gensym          = proto_perl->Igensym;
-    PL_preambled       = proto_perl->Ipreambled;
-    PL_preambleav      = av_dup_inc(proto_perl->Ipreambleav, param);
-    PL_laststatval     = proto_perl->Ilaststatval;
-    PL_laststype       = proto_perl->Ilaststype;
-    PL_mess_sv         = Nullsv;
+    PL_stashcache       = newHV();
 
-    PL_ors_sv          = sv_dup_inc(proto_perl->Iors_sv, param);
+    if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+        ptr_table_free(PL_ptr_table);
+        PL_ptr_table = NULL;
+    }
 
-    /* interpreter atexit processing */
-    PL_exitlistlen     = proto_perl->Iexitlistlen;
-    if (PL_exitlistlen) {
-       Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
-       Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+    /* Call the ->CLONE method, if it exists, for each of the stashes
+       identified by sv_dup() above.
+    */
+    while(av_len(param->stashes) != -1) {
+       HV* const stash = (HV*) av_shift(param->stashes);
+       GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
+       if (cloner && GvCV(cloner)) {
+           dSP;
+           ENTER;
+           SAVETMPS;
+           PUSHMARK(SP);
+           XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
+           PUTBACK;
+           call_sv((SV*)GvCV(cloner), G_DISCARD);
+           FREETMPS;
+           LEAVE;
+       }
     }
-    else
-       PL_exitlist     = (PerlExitListEntry*)NULL;
-    PL_modglobal       = hv_dup_inc(proto_perl->Imodglobal, param);
-    PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
-    PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
 
-    PL_profiledata     = NULL;
-    PL_rsfp            = fp_dup(proto_perl->Irsfp, '<', param);
-    /* PL_rsfp_filters entries have fake IoDIRP() */
-    PL_rsfp_filters    = av_dup_inc(proto_perl->Irsfp_filters, param);
+    SvREFCNT_dec(param->stashes);
 
-    PL_compcv                  = cv_dup(proto_perl->Icompcv, param);
+    /* orphaned? eg threads->new inside BEGIN or use */
+    if (PL_compcv && ! SvREFCNT(PL_compcv)) {
+       (void)SvREFCNT_inc(PL_compcv);
+       SAVEFREESV(PL_compcv);
+    }
 
-    PAD_CLONE_VARS(proto_perl, param);
+    return my_perl;
+}
 
-#ifdef HAVE_INTERP_INTERN
-    sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
-#endif
+#endif /* USE_ITHREADS */
 
-    /* more statics moved here */
-    PL_generation      = proto_perl->Igeneration;
-    PL_DBcv            = cv_dup(proto_perl->IDBcv, param);
+/*
+=head1 Unicode Support
 
-    PL_in_clean_objs   = proto_perl->Iin_clean_objs;
-    PL_in_clean_all    = proto_perl->Iin_clean_all;
+=for apidoc sv_recode_to_utf8
 
-    PL_uid             = proto_perl->Iuid;
-    PL_euid            = proto_perl->Ieuid;
-    PL_gid             = proto_perl->Igid;
-    PL_egid            = proto_perl->Iegid;
-    PL_nomemok         = proto_perl->Inomemok;
-    PL_an              = proto_perl->Ian;
-    PL_evalseq         = proto_perl->Ievalseq;
-    PL_origenviron     = proto_perl->Iorigenviron;     /* XXX not quite right */
-    PL_origalen                = proto_perl->Iorigalen;
-#ifdef PERL_USES_PL_PIDSTATUS
-    PL_pidstatus       = newHV();                      /* XXX flag for cloning? */
-#endif
-    PL_osname          = SAVEPV(proto_perl->Iosname);
-    PL_sighandlerp     = proto_perl->Isighandlerp;
+The encoding is assumed to be an Encode object, on entry the PV
+of the sv is assumed to be octets in that encoding, and the sv
+will be converted into Unicode (and UTF-8).
 
-    PL_runops          = proto_perl->Irunops;
+If the sv already is UTF-8 (or if it is not POK), or if the encoding
+is not a reference, nothing is done to the sv.  If the encoding is not
+an C<Encode::XS> Encoding object, bad things will happen.
+(See F<lib/encoding.pm> and L<Encode>).
 
-    Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
+The PV of the sv is returned.
 
-#ifdef CSH
-    PL_cshlen          = proto_perl->Icshlen;
-    PL_cshname         = proto_perl->Icshname; /* XXX never deallocated */
-#endif
+=cut */
 
-    PL_lex_state       = proto_perl->Ilex_state;
-    PL_lex_defer       = proto_perl->Ilex_defer;
-    PL_lex_expect      = proto_perl->Ilex_expect;
-    PL_lex_formbrack   = proto_perl->Ilex_formbrack;
-    PL_lex_dojoin      = proto_perl->Ilex_dojoin;
-    PL_lex_starts      = proto_perl->Ilex_starts;
-    PL_lex_stuff       = sv_dup_inc(proto_perl->Ilex_stuff, param);
-    PL_lex_repl                = sv_dup_inc(proto_perl->Ilex_repl, param);
-    PL_lex_op          = proto_perl->Ilex_op;
-    PL_lex_inpat       = proto_perl->Ilex_inpat;
-    PL_lex_inwhat      = proto_perl->Ilex_inwhat;
-    PL_lex_brackets    = proto_perl->Ilex_brackets;
-    i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
-    PL_lex_brackstack  = SAVEPVN(proto_perl->Ilex_brackstack,i);
-    PL_lex_casemods    = proto_perl->Ilex_casemods;
-    i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
-    PL_lex_casestack   = SAVEPVN(proto_perl->Ilex_casestack,i);
+char *
+Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
+{
+    dVAR;
+    if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
+       SV *uni;
+       STRLEN len;
+       const char *s;
+       dSP;
+       ENTER;
+       SAVETMPS;
+       save_re_context();
+       PUSHMARK(sp);
+       EXTEND(SP, 3);
+       XPUSHs(encoding);
+       XPUSHs(sv);
+/*
+  NI-S 2002/07/09
+  Passing sv_yes is wrong - it needs to be or'ed set of constants
+  for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+  remove converted chars from source.
 
-    Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
-    Copy(proto_perl->Inexttype, PL_nexttype, 5,        I32);
-    PL_nexttoke                = proto_perl->Inexttoke;
+  Both will default the value - let them.
 
-    /* XXX This is probably masking the deeper issue of why
-     * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
-     * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
-     * (A little debugging with a watchpoint on it may help.)
-     */
-    if (SvANY(proto_perl->Ilinestr)) {
-       PL_linestr              = sv_dup_inc(proto_perl->Ilinestr, param);
-       i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
-       PL_bufptr               = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
-       i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
-       PL_oldbufptr    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
-       i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
-       PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
-       i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
-       PL_linestart    = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
-    }
-    else {
-        PL_linestr = NEWSV(65,79);
-        sv_upgrade(PL_linestr,SVt_PVIV);
-        sv_setpvn(PL_linestr,"",0);
-       PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+       XPUSHs(&PL_sv_yes);
+*/
+       PUTBACK;
+       call_method("decode", G_SCALAR);
+       SPAGAIN;
+       uni = POPs;
+       PUTBACK;
+       s = SvPV_const(uni, len);
+       if (s != SvPVX_const(sv)) {
+           SvGROW(sv, len + 1);
+           Move(s, SvPVX(sv), len + 1, char);
+           SvCUR_set(sv, len);
+       }
+       FREETMPS;
+       LEAVE;
+       SvUTF8_on(sv);
+       return SvPVX(sv);
     }
-    PL_bufend          = SvPVX(PL_linestr) + SvCUR(PL_linestr);
-    PL_pending_ident   = proto_perl->Ipending_ident;
-    PL_sublex_info     = proto_perl->Isublex_info;     /* XXX not quite right */
+    return SvPOKp(sv) ? SvPVX(sv) : NULL;
+}
 
-    PL_expect          = proto_perl->Iexpect;
+/*
+=for apidoc sv_cat_decode
 
-    PL_multi_start     = proto_perl->Imulti_start;
-    PL_multi_end       = proto_perl->Imulti_end;
-    PL_multi_open      = proto_perl->Imulti_open;
-    PL_multi_close     = proto_perl->Imulti_close;
+The encoding is assumed to be an Encode object, the PV of the ssv is
+assumed to be octets in that encoding and decoding the input starts
+from the position which (PV + *offset) pointed to.  The dsv will be
+concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
+when the string tstr appears in decoding output or the input ends on
+the PV of the ssv. The value which the offset points will be modified
+to the last input position on the ssv.
 
-    PL_error_count     = proto_perl->Ierror_count;
-    PL_subline         = proto_perl->Isubline;
-    PL_subname         = sv_dup_inc(proto_perl->Isubname, param);
+Returns TRUE if the terminator was found, else returns FALSE.
 
-    /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
-    if (SvANY(proto_perl->Ilinestr)) {
-       i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
-       PL_last_uni             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
-       i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
-       PL_last_lop             = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
-       PL_last_lop_op  = proto_perl->Ilast_lop_op;
-    }
-    else {
-       PL_last_uni     = SvPVX(PL_linestr);
-       PL_last_lop     = SvPVX(PL_linestr);
-       PL_last_lop_op  = 0;
+=cut */
+
+bool
+Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
+                  SV *ssv, int *offset, char *tstr, int tlen)
+{
+    dVAR;
+    bool ret = FALSE;
+    if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
+       SV *offsv;
+       dSP;
+       ENTER;
+       SAVETMPS;
+       save_re_context();
+       PUSHMARK(sp);
+       EXTEND(SP, 6);
+       XPUSHs(encoding);
+       XPUSHs(dsv);
+       XPUSHs(ssv);
+       XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
+       XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
+       PUTBACK;
+       call_method("cat_decode", G_SCALAR);
+       SPAGAIN;
+       ret = SvTRUE(TOPs);
+       *offset = SvIV(offsv);
+       PUTBACK;
+       FREETMPS;
+       LEAVE;
     }
-    PL_in_my           = proto_perl->Iin_my;
-    PL_in_my_stash     = hv_dup(proto_perl->Iin_my_stash, param);
-#ifdef FCRYPT
-    PL_cryptseen       = proto_perl->Icryptseen;
-#endif
+    else
+        Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
+    return ret;
 
-    PL_hints           = proto_perl->Ihints;
+}
 
-    PL_amagic_generation       = proto_perl->Iamagic_generation;
+/* ---------------------------------------------------------------------
+ *
+ * support functions for report_uninit()
+ */
 
-#ifdef USE_LOCALE_COLLATE
-    PL_collation_ix    = proto_perl->Icollation_ix;
-    PL_collation_name  = SAVEPV(proto_perl->Icollation_name);
-    PL_collation_standard      = proto_perl->Icollation_standard;
-    PL_collxfrm_base   = proto_perl->Icollxfrm_base;
-    PL_collxfrm_mult   = proto_perl->Icollxfrm_mult;
-#endif /* USE_LOCALE_COLLATE */
+/* the maxiumum size of array or hash where we will scan looking
+ * for the undefined element that triggered the warning */
 
-#ifdef USE_LOCALE_NUMERIC
-    PL_numeric_name    = SAVEPV(proto_perl->Inumeric_name);
-    PL_numeric_standard        = proto_perl->Inumeric_standard;
-    PL_numeric_local   = proto_perl->Inumeric_local;
-    PL_numeric_radix_sv        = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
-#endif /* !USE_LOCALE_NUMERIC */
+#define FUV_MAX_SEARCH_SIZE 1000
 
-    /* utf8 character classes */
-    PL_utf8_alnum      = sv_dup_inc(proto_perl->Iutf8_alnum, param);
-    PL_utf8_alnumc     = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
-    PL_utf8_ascii      = sv_dup_inc(proto_perl->Iutf8_ascii, param);
-    PL_utf8_alpha      = sv_dup_inc(proto_perl->Iutf8_alpha, param);
-    PL_utf8_space      = sv_dup_inc(proto_perl->Iutf8_space, param);
-    PL_utf8_cntrl      = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
-    PL_utf8_graph      = sv_dup_inc(proto_perl->Iutf8_graph, param);
-    PL_utf8_digit      = sv_dup_inc(proto_perl->Iutf8_digit, param);
-    PL_utf8_upper      = sv_dup_inc(proto_perl->Iutf8_upper, param);
-    PL_utf8_lower      = sv_dup_inc(proto_perl->Iutf8_lower, param);
-    PL_utf8_print      = sv_dup_inc(proto_perl->Iutf8_print, param);
-    PL_utf8_punct      = sv_dup_inc(proto_perl->Iutf8_punct, param);
-    PL_utf8_xdigit     = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
-    PL_utf8_mark       = sv_dup_inc(proto_perl->Iutf8_mark, param);
-    PL_utf8_toupper    = sv_dup_inc(proto_perl->Iutf8_toupper, param);
-    PL_utf8_totitle    = sv_dup_inc(proto_perl->Iutf8_totitle, param);
-    PL_utf8_tolower    = sv_dup_inc(proto_perl->Iutf8_tolower, param);
-    PL_utf8_tofold     = sv_dup_inc(proto_perl->Iutf8_tofold, param);
-    PL_utf8_idstart    = sv_dup_inc(proto_perl->Iutf8_idstart, param);
-    PL_utf8_idcont     = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+/* Look for an entry in the hash whose value has the same SV as val;
+ * If so, return a mortal copy of the key. */
 
-    /* Did the locale setup indicate UTF-8? */
-    PL_utf8locale      = proto_perl->Iutf8locale;
-    /* Unicode features (see perlrun/-C) */
-    PL_unicode         = proto_perl->Iunicode;
+STATIC SV*
+S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+{
+    dVAR;
+    register HE **array;
+    I32 i;
 
-    /* Pre-5.8 signals control */
-    PL_signals         = proto_perl->Isignals;
+    if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
+                       (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
+       return Nullsv;
 
-    /* times() ticks per second */
-    PL_clocktick       = proto_perl->Iclocktick;
+    array = HvARRAY(hv);
 
-    /* Recursion stopper for PerlIO_find_layer */
-    PL_in_load_module  = proto_perl->Iin_load_module;
+    for (i=HvMAX(hv); i>0; i--) {
+       register HE *entry;
+       for (entry = array[i]; entry; entry = HeNEXT(entry)) {
+           if (HeVAL(entry) != val)
+               continue;
+           if (    HeVAL(entry) == &PL_sv_undef ||
+                   HeVAL(entry) == &PL_sv_placeholder)
+               continue;
+           if (!HeKEY(entry))
+               return Nullsv;
+           if (HeKLEN(entry) == HEf_SVKEY)
+               return sv_mortalcopy(HeKEY_sv(entry));
+           return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
+       }
+    }
+    return Nullsv;
+}
 
-    /* sort() routine */
-    PL_sort_RealCmp    = proto_perl->Isort_RealCmp;
+/* Look for an entry in the array whose value has the same SV as val;
+ * If so, return the index, otherwise return -1. */
 
-    /* Not really needed/useful since the reenrant_retint is "volatile",
-     * but do it for consistency's sake. */
-    PL_reentrant_retint        = proto_perl->Ireentrant_retint;
+STATIC I32
+S_find_array_subscript(pTHX_ AV *av, SV* val)
+{
+    SV** svp;
+    I32 i;
+    if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
+                       (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
+       return -1;
 
-    /* Hooks to shared SVs and locks. */
-    PL_sharehook       = proto_perl->Isharehook;
-    PL_lockhook                = proto_perl->Ilockhook;
-    PL_unlockhook      = proto_perl->Iunlockhook;
-    PL_threadhook      = proto_perl->Ithreadhook;
+    svp = AvARRAY(av);
+    for (i=AvFILLp(av); i>=0; i--) {
+       if (svp[i] == val && svp[i] != &PL_sv_undef)
+           return i;
+    }
+    return -1;
+}
 
-    PL_runops_std      = proto_perl->Irunops_std;
-    PL_runops_dbg      = proto_perl->Irunops_dbg;
+/* S_varname(): return the name of a variable, optionally with a subscript.
+ * If gv is non-zero, use the name of that global, along with gvtype (one
+ * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
+ * targ.  Depending on the value of the subscript_type flag, return:
+ */
 
-#ifdef THREADS_HAVE_PIDS
-    PL_ppid            = proto_perl->Ippid;
-#endif
+#define FUV_SUBSCRIPT_NONE     1       /* "@foo"          */
+#define FUV_SUBSCRIPT_ARRAY    2       /* "$foo[aindex]"  */
+#define FUV_SUBSCRIPT_HASH     3       /* "$foo{keyname}" */
+#define FUV_SUBSCRIPT_WITHIN   4       /* "within @foo"   */
 
-    /* swatch cache */
-    PL_last_swash_hv   = Nullhv;       /* reinits on demand */
-    PL_last_swash_klen = 0;
-    PL_last_swash_key[0]= '\0';
-    PL_last_swash_tmps = (U8*)NULL;
-    PL_last_swash_slen = 0;
+STATIC SV*
+S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
+       SV* keyname, I32 aindex, int subscript_type)
+{
 
-    PL_glob_index      = proto_perl->Iglob_index;
-    PL_srand_called    = proto_perl->Isrand_called;
-    PL_uudmap['M']     = 0;            /* reinits on demand */
-    PL_bitcount                = Nullch;       /* reinits on demand */
+    SV * const name = sv_newmortal();
+    if (gv) {
+       char buffer[2];
+       buffer[0] = gvtype;
+       buffer[1] = 0;
 
-    if (proto_perl->Ipsig_pend) {
-       Newxz(PL_psig_pend, SIG_SIZE, int);
-    }
-    else {
-       PL_psig_pend    = (int*)NULL;
-    }
+       /* as gv_fullname4(), but add literal '^' for $^FOO names  */
 
-    if (proto_perl->Ipsig_ptr) {
-       Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
-       Newxz(PL_psig_name, SIG_SIZE, SV*);
-       for (i = 1; i < SIG_SIZE; i++) {
-           PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
-           PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
-       }
-    }
-    else {
-       PL_psig_ptr     = (SV**)NULL;
-       PL_psig_name    = (SV**)NULL;
-    }
+       gv_fullname4(name, gv, buffer, 0);
 
-    /* thrdvar.h stuff */
+       if ((unsigned int)SvPVX(name)[1] <= 26) {
+           buffer[0] = '^';
+           buffer[1] = SvPVX(name)[1] + 'A' - 1;
 
-    if (flags & CLONEf_COPY_STACKS) {
-       /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
-       PL_tmps_ix              = proto_perl->Ttmps_ix;
-       PL_tmps_max             = proto_perl->Ttmps_max;
-       PL_tmps_floor           = proto_perl->Ttmps_floor;
-       Newxz(PL_tmps_stack, PL_tmps_max, SV*);
-       i = 0;
-       while (i <= PL_tmps_ix) {
-           PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
-           ++i;
+           /* Swap the 1 unprintable control character for the 2 byte pretty
+              version - ie substr($name, 1, 1) = $buffer; */
+           sv_insert(name, 1, 1, buffer, 2);
        }
+    }
+    else {
+       U32 unused;
+       CV * const cv = find_runcv(&unused);
+       SV *sv;
+       AV *av;
 
-       /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
-       i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
-       Newxz(PL_markstack, i, I32);
-       PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
-                                                 - proto_perl->Tmarkstack);
-       PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
-                                                 - proto_perl->Tmarkstack);
-       Copy(proto_perl->Tmarkstack, PL_markstack,
-            PL_markstack_ptr - PL_markstack + 1, I32);
+       if (!cv || !CvPADLIST(cv))
+           return Nullsv;
+       av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
+       sv = *av_fetch(av, targ, FALSE);
+       /* SvLEN in a pad name is not to be trusted */
+       sv_setpv(name, SvPV_nolen_const(sv));
+    }
 
-       /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
-        * NOTE: unlike the others! */
-       PL_scopestack_ix        = proto_perl->Tscopestack_ix;
-       PL_scopestack_max       = proto_perl->Tscopestack_max;
-       Newxz(PL_scopestack, PL_scopestack_max, I32);
-       Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
+    if (subscript_type == FUV_SUBSCRIPT_HASH) {
+       SV * const sv = NEWSV(0,0);
+       *SvPVX(name) = '$';
+       Perl_sv_catpvf(aTHX_ name, "{%s}",
+           pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
+       SvREFCNT_dec(sv);
+    }
+    else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
+       *SvPVX(name) = '$';
+       Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
+    }
+    else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
+       sv_insert(name, 0, 0,  "within ", 7);
 
-       /* NOTE: si_dup() looks at PL_markstack */
-       PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);
+    return name;
+}
 
-       /* PL_curstack          = PL_curstackinfo->si_stack; */
-       PL_curstack             = av_dup(proto_perl->Tcurstack, param);
-       PL_mainstack            = av_dup(proto_perl->Tmainstack, param);
 
-       /* next PUSHs() etc. set *(PL_stack_sp+1) */
-       PL_stack_base           = AvARRAY(PL_curstack);
-       PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
-                                                  - proto_perl->Tstack_base);
-       PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
+/*
+=for apidoc find_uninit_var
 
-       /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
-        * NOTE: unlike the others! */
-       PL_savestack_ix         = proto_perl->Tsavestack_ix;
-       PL_savestack_max        = proto_perl->Tsavestack_max;
-       /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
-       PL_savestack            = ss_dup(proto_perl, param);
-    }
-    else {
-       init_stacks();
-       ENTER;                  /* perl_destruct() wants to LEAVE; */
-    }
+Find the name of the undefined variable (if any) that caused the operator o
+to issue a "Use of uninitialized value" warning.
+If match is true, only return a name if it's value matches uninit_sv.
+So roughly speaking, if a unary operator (such as OP_COS) generates a
+warning, then following the direct child of the op may yield an
+OP_PADSV or OP_GV that gives the name of the undefined variable. On the
+other hand, with OP_ADD there are two branches to follow, so we only print
+the variable name if we get an exact match.
 
-    PL_start_env       = proto_perl->Tstart_env;       /* XXXXXX */
-    PL_top_env         = &PL_start_env;
+The name is returned as a mortal SV.
 
-    PL_op              = proto_perl->Top;
+Assumes that PL_op is the op that originally triggered the error, and that
+PL_comppad/PL_curpad points to the currently executing pad.
 
-    PL_Sv              = Nullsv;
-    PL_Xpv             = (XPV*)NULL;
-    PL_na              = proto_perl->Tna;
+=cut
+*/
 
-    PL_statbuf         = proto_perl->Tstatbuf;
-    PL_statcache       = proto_perl->Tstatcache;
-    PL_statgv          = gv_dup(proto_perl->Tstatgv, param);
-    PL_statname                = sv_dup_inc(proto_perl->Tstatname, param);
-#ifdef HAS_TIMES
-    PL_timesbuf                = proto_perl->Ttimesbuf;
-#endif
+STATIC SV *
+S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
+{
+    dVAR;
+    SV *sv;
+    AV *av;
+    GV *gv;
+    OP *o, *o2, *kid;
 
-    PL_tainted         = proto_perl->Ttainted;
-    PL_curpm           = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
-    PL_rs              = sv_dup_inc(proto_perl->Trs, param);
-    PL_last_in_gv      = gv_dup(proto_perl->Tlast_in_gv, param);
-    PL_ofs_sv          = sv_dup_inc(proto_perl->Tofs_sv, param);
-    PL_defoutgv                = gv_dup_inc(proto_perl->Tdefoutgv, param);
-    PL_chopset         = proto_perl->Tchopset; /* XXX never deallocated */
-    PL_toptarget       = sv_dup_inc(proto_perl->Ttoptarget, param);
-    PL_bodytarget      = sv_dup_inc(proto_perl->Tbodytarget, param);
-    PL_formtarget      = sv_dup(proto_perl->Tformtarget, param);
+    if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
+                           uninit_sv == &PL_sv_placeholder)))
+       return Nullsv;
 
-    PL_restartop       = proto_perl->Trestartop;
-    PL_in_eval         = proto_perl->Tin_eval;
-    PL_delaymagic      = proto_perl->Tdelaymagic;
-    PL_dirty           = proto_perl->Tdirty;
-    PL_localizing      = proto_perl->Tlocalizing;
+    switch (obase->op_type) {
 
-    PL_errors          = sv_dup_inc(proto_perl->Terrors, param);
-    PL_hv_fetch_ent_mh = Nullhe;
-    PL_modcount                = proto_perl->Tmodcount;
-    PL_lastgotoprobe   = Nullop;
-    PL_dumpindent      = proto_perl->Tdumpindent;
+    case OP_RV2AV:
+    case OP_RV2HV:
+    case OP_PADAV:
+    case OP_PADHV:
+      {
+       const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
+       const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+       I32 index = 0;
+       SV *keysv = Nullsv;
+       int subscript_type = FUV_SUBSCRIPT_WITHIN;
 
-    PL_sortcop         = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
-    PL_sortstash       = hv_dup(proto_perl->Tsortstash, param);
-    PL_firstgv         = gv_dup(proto_perl->Tfirstgv, param);
-    PL_secondgv                = gv_dup(proto_perl->Tsecondgv, param);
-    PL_efloatbuf       = Nullch;               /* reinits on demand */
-    PL_efloatsize      = 0;                    /* reinits on demand */
+       if (pad) { /* @lex, %lex */
+           sv = PAD_SVl(obase->op_targ);
+           gv = Nullgv;
+       }
+       else {
+           if (cUNOPx(obase)->op_first->op_type == OP_GV) {
+           /* @global, %global */
+               gv = cGVOPx_gv(cUNOPx(obase)->op_first);
+               if (!gv)
+                   break;
+               sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
+           }
+           else /* @{expr}, %{expr} */
+               return find_uninit_var(cUNOPx(obase)->op_first,
+                                                   uninit_sv, match);
+       }
 
-    /* regex stuff */
+       /* attempt to find a match within the aggregate */
+       if (hash) {
+           keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+           if (keysv)
+               subscript_type = FUV_SUBSCRIPT_HASH;
+       }
+       else {
+           index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+           if (index >= 0)
+               subscript_type = FUV_SUBSCRIPT_ARRAY;
+       }
 
-    PL_screamfirst     = NULL;
-    PL_screamnext      = NULL;
-    PL_maxscream       = -1;                   /* reinits on demand */
-    PL_lastscream      = Nullsv;
+       if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
+           break;
 
-    PL_watchaddr       = NULL;
-    PL_watchok         = Nullch;
+       return varname(gv, hash ? '%' : '@', obase->op_targ,
+                                   keysv, index, subscript_type);
+      }
 
-    PL_regdummy                = proto_perl->Tregdummy;
-    PL_regprecomp      = Nullch;
-    PL_regnpar         = 0;
-    PL_regsize         = 0;
-    PL_colorset                = 0;            /* reinits PL_colors[] */
-    /*PL_colors[6]     = {0,0,0,0,0,0};*/
-    PL_reginput                = Nullch;
-    PL_regbol          = Nullch;
-    PL_regeol          = Nullch;
-    PL_regstartp       = (I32*)NULL;
-    PL_regendp         = (I32*)NULL;
-    PL_reglastparen    = (U32*)NULL;
-    PL_reglastcloseparen       = (U32*)NULL;
-    PL_regtill         = Nullch;
-    PL_reg_start_tmp   = (char**)NULL;
-    PL_reg_start_tmpl  = 0;
-    PL_regdata         = (struct reg_data*)NULL;
-    PL_bostr           = Nullch;
-    PL_reg_flags       = 0;
-    PL_reg_eval_set    = 0;
-    PL_regnarrate      = 0;
-    PL_regprogram      = (regnode*)NULL;
-    PL_regindent       = 0;
-    PL_regcc           = (CURCUR*)NULL;
-    PL_reg_call_cc     = (struct re_cc_state*)NULL;
-    PL_reg_re          = (regexp*)NULL;
-    PL_reg_ganch       = Nullch;
-    PL_reg_sv          = Nullsv;
-    PL_reg_match_utf8  = FALSE;
-    PL_reg_magic       = (MAGIC*)NULL;
-    PL_reg_oldpos      = 0;
-    PL_reg_oldcurpm    = (PMOP*)NULL;
-    PL_reg_curpm       = (PMOP*)NULL;
-    PL_reg_oldsaved    = Nullch;
-    PL_reg_oldsavedlen = 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
-    PL_nrs             = Nullsv;
-#endif
-    PL_reg_maxiter     = 0;
-    PL_reg_leftiter    = 0;
-    PL_reg_poscache    = Nullch;
-    PL_reg_poscache_size= 0;
+    case OP_PADSV:
+       if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+           break;
+       return varname(Nullgv, '$', obase->op_targ,
+                                   Nullsv, 0, FUV_SUBSCRIPT_NONE);
 
-    /* RE engine - function pointers */
-    PL_regcompp                = proto_perl->Tregcompp;
-    PL_regexecp                = proto_perl->Tregexecp;
-    PL_regint_start    = proto_perl->Tregint_start;
-    PL_regint_string   = proto_perl->Tregint_string;
-    PL_regfree         = proto_perl->Tregfree;
+    case OP_GVSV:
+       gv = cGVOPx_gv(obase);
+       if (!gv || (match && GvSV(gv) != uninit_sv))
+           break;
+       return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
 
-    PL_reginterp_cnt   = 0;
-    PL_reg_starttry    = 0;
+    case OP_AELEMFAST:
+       if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
+           if (match) {
+               SV **svp;
+               av = (AV*)PAD_SV(obase->op_targ);
+               if (!av || SvRMAGICAL(av))
+                   break;
+               svp = av_fetch(av, (I32)obase->op_private, FALSE);
+               if (!svp || *svp != uninit_sv)
+                   break;
+           }
+           return varname(Nullgv, '$', obase->op_targ,
+                   Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+       }
+       else {
+           gv = cGVOPx_gv(obase);
+           if (!gv)
+               break;
+           if (match) {
+               SV **svp;
+               av = GvAV(gv);
+               if (!av || SvRMAGICAL(av))
+                   break;
+               svp = av_fetch(av, (I32)obase->op_private, FALSE);
+               if (!svp || *svp != uninit_sv)
+                   break;
+           }
+           return varname(gv, '$', 0,
+                   Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+       }
+       break;
 
-    /* Pluggable optimizer */
-    PL_peepp           = proto_perl->Tpeepp;
+    case OP_EXISTS:
+       o = cUNOPx(obase)->op_first;
+       if (!o || o->op_type != OP_NULL ||
+               ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
+           break;
+       return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
 
-    PL_stashcache       = newHV();
+    case OP_AELEM:
+    case OP_HELEM:
+       if (PL_op == obase)
+           /* $a[uninit_expr] or $h{uninit_expr} */
+           return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
 
-    if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
-        ptr_table_free(PL_ptr_table);
-        PL_ptr_table = NULL;
-    }
+       gv = Nullgv;
+       o = cBINOPx(obase)->op_first;
+       kid = cBINOPx(obase)->op_last;
 
-    /* Call the ->CLONE method, if it exists, for each of the stashes
-       identified by sv_dup() above.
-    */
-    while(av_len(param->stashes) != -1) {
-       HV* const stash = (HV*) av_shift(param->stashes);
-       GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
-       if (cloner && GvCV(cloner)) {
-           dSP;
-           ENTER;
-           SAVETMPS;
-           PUSHMARK(SP);
-           XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
-           PUTBACK;
-           call_sv((SV*)GvCV(cloner), G_DISCARD);
-           FREETMPS;
-           LEAVE;
+       /* get the av or hv, and optionally the gv */
+       sv = Nullsv;
+       if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
+           sv = PAD_SV(o->op_targ);
+       }
+       else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
+               && cUNOPo->op_first->op_type == OP_GV)
+       {
+           gv = cGVOPx_gv(cUNOPo->op_first);
+           if (!gv)
+               break;
+           sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
+       }
+       if (!sv)
+           break;
+
+       if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
+           /* index is constant */
+           if (match) {
+               if (SvMAGICAL(sv))
+                   break;
+               if (obase->op_type == OP_HELEM) {
+                   HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
+                   if (!he || HeVAL(he) != uninit_sv)
+                       break;
+               }
+               else {
+                   SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
+                   if (!svp || *svp != uninit_sv)
+                       break;
+               }
+           }
+           if (obase->op_type == OP_HELEM)
+               return varname(gv, '%', o->op_targ,
+                           cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
+           else
+               return varname(gv, '@', o->op_targ, Nullsv,
+                           SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
+           ;
+       }
+       else  {
+           /* index is an expression;
+            * attempt to find a match within the aggregate */
+           if (obase->op_type == OP_HELEM) {
+               SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+               if (keysv)
+                   return varname(gv, '%', o->op_targ,
+                                               keysv, 0, FUV_SUBSCRIPT_HASH);
+           }
+           else {
+               const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+               if (index >= 0)
+                   return varname(gv, '@', o->op_targ,
+                                       Nullsv, index, FUV_SUBSCRIPT_ARRAY);
+           }
+           if (match)
+               break;
+           return varname(gv,
+               (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
+               ? '@' : '%',
+               o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
        }
-    }
 
-    SvREFCNT_dec(param->stashes);
+       break;
 
-    /* orphaned? eg threads->new inside BEGIN or use */
-    if (PL_compcv && ! SvREFCNT(PL_compcv)) {
-       (void)SvREFCNT_inc(PL_compcv);
-       SAVEFREESV(PL_compcv);
-    }
+    case OP_AASSIGN:
+       /* only examine RHS */
+       return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
 
-    return my_perl;
-}
+    case OP_OPEN:
+       o = cUNOPx(obase)->op_first;
+       if (o->op_type == OP_PUSHMARK)
+           o = o->op_sibling;
 
-#endif /* USE_ITHREADS */
+       if (!o->op_sibling) {
+           /* one-arg version of open is highly magical */
 
-/*
-=head1 Unicode Support
+           if (o->op_type == OP_GV) { /* open FOO; */
+               gv = cGVOPx_gv(o);
+               if (match && GvSV(gv) != uninit_sv)
+                   break;
+               return varname(gv, '$', 0,
+                           Nullsv, 0, FUV_SUBSCRIPT_NONE);
+           }
+           /* other possibilities not handled are:
+            * open $x; or open my $x;  should return '${*$x}'
+            * open expr;               should return '$'.expr ideally
+            */
+            break;
+       }
+       goto do_op;
 
-=for apidoc sv_recode_to_utf8
+    /* ops where $_ may be an implicit arg */
+    case OP_TRANS:
+    case OP_SUBST:
+    case OP_MATCH:
+       if ( !(obase->op_flags & OPf_STACKED)) {
+           if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
+                                ? PAD_SVl(obase->op_targ)
+                                : DEFSV))
+           {
+               sv = sv_newmortal();
+               sv_setpvn(sv, "$_", 2);
+               return sv;
+           }
+       }
+       goto do_op;
 
-The encoding is assumed to be an Encode object, on entry the PV
-of the sv is assumed to be octets in that encoding, and the sv
-will be converted into Unicode (and UTF-8).
+    case OP_PRTF:
+    case OP_PRINT:
+       /* skip filehandle as it can't produce 'undef' warning  */
+       o = cUNOPx(obase)->op_first;
+       if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+           o = o->op_sibling->op_sibling;
+       goto do_op2;
 
-If the sv already is UTF-8 (or if it is not POK), or if the encoding
-is not a reference, nothing is done to the sv.  If the encoding is not
-an C<Encode::XS> Encoding object, bad things will happen.
-(See F<lib/encoding.pm> and L<Encode>).
 
-The PV of the sv is returned.
+    case OP_RV2SV:
+    case OP_CUSTOM:
+    case OP_ENTERSUB:
+       match = 1; /* XS or custom code could trigger random warnings */
+       goto do_op;
 
-=cut */
+    case OP_SCHOMP:
+    case OP_CHOMP:
+       if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
+           return sv_2mortal(newSVpvn("${$/}", 5));
+       /* FALL THROUGH */
 
-char *
-Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
-{
-    dVAR;
-    if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
-       SV *uni;
-       STRLEN len;
-       const char *s;
-       dSP;
-       ENTER;
-       SAVETMPS;
-       save_re_context();
-       PUSHMARK(sp);
-       EXTEND(SP, 3);
-       XPUSHs(encoding);
-       XPUSHs(sv);
-/*
-  NI-S 2002/07/09
-  Passing sv_yes is wrong - it needs to be or'ed set of constants
-  for Encode::XS, while UTf-8 decode (currently) assumes a true value means
-  remove converted chars from source.
+    default:
+    do_op:
+       if (!(obase->op_flags & OPf_KIDS))
+           break;
+       o = cUNOPx(obase)->op_first;
+       
+    do_op2:
+       if (!o)
+           break;
 
-  Both will default the value - let them.
+       /* if all except one arg are constant, or have no side-effects,
+        * or are optimized away, then it's unambiguous */
+       o2 = Nullop;
+       for (kid=o; kid; kid = kid->op_sibling) {
+           if (kid &&
+               (    (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
+                 || (kid->op_type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
+                 || (kid->op_type == OP_PUSHMARK)
+               )
+           )
+               continue;
+           if (o2) { /* more than one found */
+               o2 = Nullop;
+               break;
+           }
+           o2 = kid;
+       }
+       if (o2)
+           return find_uninit_var(o2, uninit_sv, match);
 
-       XPUSHs(&PL_sv_yes);
-*/
-       PUTBACK;
-       call_method("decode", G_SCALAR);
-       SPAGAIN;
-       uni = POPs;
-       PUTBACK;
-       s = SvPV_const(uni, len);
-       if (s != SvPVX_const(sv)) {
-           SvGROW(sv, len + 1);
-           Move(s, SvPVX(sv), len + 1, char);
-           SvCUR_set(sv, len);
+       /* scan all args */
+       while (o) {
+           sv = find_uninit_var(o, uninit_sv, 1);
+           if (sv)
+               return sv;
+           o = o->op_sibling;
        }
-       FREETMPS;
-       LEAVE;
-       SvUTF8_on(sv);
-       return SvPVX(sv);
+       break;
     }
-    return SvPOKp(sv) ? SvPVX(sv) : NULL;
+    return Nullsv;
 }
 
-/*
-=for apidoc sv_cat_decode
 
-The encoding is assumed to be an Encode object, the PV of the ssv is
-assumed to be octets in that encoding and decoding the input starts
-from the position which (PV + *offset) pointed to.  The dsv will be
-concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
-when the string tstr appears in decoding output or the input ends on
-the PV of the ssv. The value which the offset points will be modified
-to the last input position on the ssv.
+/*
+=for apidoc report_uninit
 
-Returns TRUE if the terminator was found, else returns FALSE.
+Print appropriate "Use of uninitialized variable" warning
 
-=cut */
+=cut
+*/
 
-bool
-Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
-                  SV *ssv, int *offset, char *tstr, int tlen)
+void
+Perl_report_uninit(pTHX_ SV* uninit_sv)
 {
-    dVAR;
-    bool ret = FALSE;
-    if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
-       SV *offsv;
-       dSP;
-       ENTER;
-       SAVETMPS;
-       save_re_context();
-       PUSHMARK(sp);
-       EXTEND(SP, 6);
-       XPUSHs(encoding);
-       XPUSHs(dsv);
-       XPUSHs(ssv);
-       XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
-       XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
-       PUTBACK;
-       call_method("cat_decode", G_SCALAR);
-       SPAGAIN;
-       ret = SvTRUE(TOPs);
-       *offset = SvIV(offsv);
-       PUTBACK;
-       FREETMPS;
-       LEAVE;
+    if (PL_op) {
+       SV* varname = Nullsv;
+       if (uninit_sv) {
+           varname = find_uninit_var(PL_op, uninit_sv,0);
+           if (varname)
+               sv_insert(varname, 0, 0, " ", 1);
+       }
+       Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+               varname ? SvPV_nolen_const(varname) : "",
+               " in ", OP_DESC(PL_op));
     }
     else
-        Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
-    return ret;
+       Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+                   "", "", "");
 }
 
 /*