experiment failed 48 copies of struct bodies_by_type_STAT

Author: bulk88

gv.c

@@ -58,6 +58,7 @@ GV *
 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
 {
     SV **where;
+    static char saw [20] = {0};
 
     if (
         !gv
@@ -94,8 +95,39 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
 
     if (!*where)
     {
-        __debugbreak();
-        *where = Perl_newSV_typeX(pTHX_ type);
+        if(type == SVt_PVHV) {
+            *where = newSV_type(SVt_PVHV);
+        }
+        else if(type == SVt_PVAV) {
+            *where = newSV_type(SVt_PVAV);
+        }
+        else if(type == SVt_PVMG) {
+            *where = newSV_type(SVt_PVMG);
+        }
+        else if(type == SVt_PVIO) {
+            *where = newSV_type(SVt_PVIO);
+        }
+        else if(type == SVt_PV) {
+            *where = newSV_type(SVt_PV);
+        }
+        else if (type == SVt_PVGV) {
+            *where = newSV_type(SVt_PVGV);
+        }
+        else if(type == SVt_NULL) {
+            *where = newSV_type(SVt_NULL);
+        }
+        // else if(type == ) {
+            // *where = newSV_type();
+        // }
+        else {
+          if(!saw[type]) {
+            __debugbreak();
+            saw[type] = 1;
+          }
+          *where = Perl_newSV_typeX(aTHX_ type);
+        }
+        
+
         if (   type == SVt_PVAV
             && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
         {
@@ -578,7 +610,7 @@ S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
     case SVt_PVGV:
         break;
     default:
-        if(GvSVn(gv)) {
+        if(GvSVnt(gv,sv_type)) {
             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
                If we just cast GvSVn(gv) to void, it ignores evaluating it for
                its side effect */
@@ -2331,24 +2363,24 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
         storeparen:
             /* Flag the capture variables with a NULL mg_ptr
                Use mg_len for the array index to lookup.  */
-            sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
+            sv_magic(GvSVnt(gv, SVt_PVMG), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
             break;
 
         case ':':		/* $: */
-            sv_setpv(GvSVn(gv),PL_chopset);
+            sv_setpv(GvSVnt(gv, SVt_PVMG),PL_chopset);
             goto magicalize;
 
         case '?':		/* $? */
 #ifdef COMPLEX_STATUS
-            SvUPGRADE(GvSVn(gv), SVt_PVLV);
+            SvUPGRADE(GvSVnt(gv, SVt_PVLV), SVt_PVLV);
 #endif
             goto magicalize;
 
         case '!':		/* $! */
             GvMULTI_on(gv);
             /* If %! has been used, automatically load Errno.pm. */
 
-            sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
+            sv_magic(GvSVnt(gv,SVt_PVMG), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
 
             /* magicalization must be done before require_tie_mod_s is called */
             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
@@ -2359,8 +2391,9 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
         case '+':		/* $+, %+, @+ */
             GvMULTI_on(gv); /* no used once warnings here */
             {   /* $- $+ */
-                sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
-                if (*name == '+')
+                SV* svplusminus = GvSVnt(gv, SVt_PVMG);
+                sv_magic(svplusminus, MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
+                    if (*name == '+')
                     SvREADONLY_on(GvSVn(gv));
             }
             {   /* %- %+ */
@@ -2389,7 +2422,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
             goto magicalize;
         case '\023':	/* $^S */
         ro_magicalize:
-            SvREADONLY_on(GvSVn(gv));
+            SvREADONLY_on(GvSVnt(gv,SVt_PVMG));
             /* FALLTHROUGH */
         case '0':		/* $0 */
         case '^':		/* $^ */
@@ -2418,14 +2451,14 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
         case '\024':	/* $^T */
         case '\027':	/* $^W */
         magicalize:
-            sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
+            sv_magic(GvSVnt(gv,SVt_PVMG), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
             break;
 
         case '\014':	/* $^L */
-            sv_setpvs(GvSVn(gv),"\f");
+            sv_setpvs(GvSVnt(gv, SVt_PV),"\f");
             break;
         case ';':		/* $; */
-            sv_setpvs(GvSVn(gv),"\034");
+            sv_setpvs(GvSVnt(gv, SVt_PV),"\034");
             break;
         case ']':		/* $] */
         {

gv.h

@@ -101,6 +101,17 @@ L<perl5100delta>.
 =for apidoc Am|SV*|GvSVn|GV* gv
 Like C<L</GvSV>>, but creates an empty scalar if none already exists.
 
+=for apidoc Am|SV*|GvSVnt|GV* gv|svtype sv_type
+Like C<L</GvSVn>>, but creates an empty scalar whose type is already upgraded
+to the requested type if none already exists. Note, if there is an existing
+scalar already stored in the GV, its type is NOT upgraded, so you still must
+do an C<SvUPGRADE> unless you are absolutly the scalar slot in the GV was
+empty before, or if you allocated or created the GV immediatly before.
+Note, all the I<sv_set**v()> functions do all necessary C<SvUPGRADE> type
+logic checks for you. This macro exists to skip a 2nd pass through the
+I<SV *> allocator subsystem. That 2nd pass skipped is the slow path of
+C<SvUPGRADE> and swapping SV body types in the type upgrade.
+
 =for apidoc Am|AV*|GvAV|GV* gv
 
 Return the AV from the GV.
@@ -121,8 +132,12 @@ Return the CV from the GV.
 #define GvSVn(gv)	(*(GvGP(gv)->gp_sv ? \
                          &(GvGP(gv)->gp_sv) : \
                          &(GvGP(gv_SVadd(gv))->gp_sv)))
+#define GvSVnt(_gv,_sv_type)	(*(GvGP(_gv)->gp_sv ? \
+                         &(GvGP(_gv)->gp_sv) : \
+                         &(GvGP(gv_SVadd_type(_gv,_sv_type))->gp_sv)))
 #else
 #define GvSVn(gv)	GvSV(gv)
+#define GvSVnt(_gv,_sv_type) (((void)SvUPGRADE(GvSV(_gv),_sv_type)),GvSV(_gv))
 #endif
 
 #define GvREFCNT(gv)	(GvGP(gv)->gp_refcnt)
@@ -347,6 +362,7 @@ Make sure there is a slot of the given type (AV, HV, IO, SV) in the GV C<gv>.
 #define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV)
 #define gv_IOadd(gv) gv_add_by_type((gv), SVt_PVIO)
 #define gv_SVadd(gv) gv_add_by_type((gv), SVt_NULL)
+#define gv_SVadd_type(_gv,_sv_type) gv_add_by_type((_gv), (_sv_type))
 
 /*
  * ex: set ts=8 sts=4 sw=4 et:

pad.c

@@ -2220,8 +2220,17 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
     assert(!CvUNIQUE(proto));
 
     if (!cv) {
-      __debugbreak();
-      cv = MUTABLE_CV(Perl_newSV_typeX(pTHX_ SvTYPE(proto)));
+      if(SvTYPE(proto) != SVt_PVCV && SvTYPE(proto)  != SVt_PVFM )
+          __debugbreak();
+      if (SvTYPE(proto) == SVt_PVCV) {
+          cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+      }
+      else if(SvTYPE(proto) == SVt_PVFM) {
+          cv = MUTABLE_CV(newSV_type(SVt_PVFM));
+      }
+      else {
+          __debugbreak();
+      }
     }
     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
                                     |CVf_SLABBED);

pp.c

@@ -5983,8 +5983,8 @@ PP(pp_emptyavhv)
     OP * const op = PL_op;
     SV * rv;
     SV * const sv = MUTABLE_SV( (op->op_private & OPpEMPTYAVHV_IS_HV)
-                                ? Perl_newSV_type(SVt_PVHV)
-                                : Perl_newSV_type(SVt_PVAV) );
+                                ? newSV_type(SVt_PVHV)
+                                : newSV_type(SVt_PVAV) );
 
     /* Is it an assignment, just a stack push, or both?*/
     if (op->op_private & OPpTARGET_MY) {

sv.c

@@ -29,6 +29,9 @@
 
 #include "EXTERN.h"
 #define PERL_IN_SV_C
+//#if defined(DEBUGGING)
+#  define WANT_SV_BODY_DETAILS
+//#endif
 #include "perl.h"
 #include "regcomp.h"
 #ifdef __VMS
@@ -5441,14 +5444,14 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
         svtype new_type;
         SV * temp;
         if(islv) {
-          temp = Perl_newSV_type(SVt_NULL);
+          temp = newSV_type(SVt_NULL);
           new_type = SVt_NULL;
         } else if (SvMAGIC(sv) || SvSTASH(sv)) {
-          temp = Perl_newSV_type(SVt_PVMG);
+          temp = newSV_type(SVt_PVMG);
           new_type = SVt_PVMG;
         }
         else  {
-          temp = Perl_newSV_type(SVt_PV);
+          temp = newSV_type(SVt_PV);
           new_type = SVt_PV;
         }
         regexp *old_rx_body;