POC C static shared string HEKPOOL API

Cross/Makefile-cross-SH

@@ -333,7 +333,7 @@ unidatafiles = lib/unicore/Decomposition.pl lib/unicore/TestProp.pl \
 unidatadirs = lib/unicore/To lib/unicore/lib
 
 h1 = EXTERN.h INTERN.h XSUB.h av.h xconfig.h cop.h cv.h dosish.h
-h2 = embed.h form.h gv.h handy.h hv.h hv_func.h keywords.h mg.h op.h opcode.h
+h2 = embed.h form.h gv.h handy.h hekpool.h hv.h hv_func.h keywords.h mg.h op.h opcode.h
 h3 = pad.h patchlevel.h perl.h perlapi.h perly.h pp.h proto.h regcomp.h
 h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
 h5 = utf8.h warnings.h

MANIFEST

@@ -42,6 +42,7 @@ globvar.sym				Global variables that need hiding when embedded
 gv.c					Glob value code
 gv.h					Glob value header
 handy.h					Handy definitions
+hekpool.h
 hv.c					Hash value code
 hv.h					Hash value header
 hv_func.h				Hash value static inline function header
@@ -5950,6 +5951,7 @@ regen/embed_lib.pl			Reads embed.fnc and regen/opcodes
 regen/feature.pl			Generates feature.pm
 regen/genpacksizetables.pl		Generate the size tables for pack/unpack
 regen/HeaderParser.pm			Module used to parse header files
+regen/hekpool.pl			Updates/creates hekpool.h
 regen/keywords.pl			Program to write keywords.h
 regen/lib_cleanup.pl			Generate lib/.gitignore from MANIFEST
 regen/locale.pl				Program to write locale_table.h

Makefile.SH

@@ -531,7 +531,7 @@ unidatadirs = lib/unicore/To lib/unicore/lib
 h = \
     EXTERN.h INTERN.h XSUB.h \
     av.h charclass_invlists.h cop.h cv.h dosish.h embed.h form.h gv.h \
-    handy.h hv.h hv_func.h iperlsys.h keywords.h l1_char_class_tab.h \
+    handy.h hekpool.h hv.h hv_func.h iperlsys.h keywords.h l1_char_class_tab.h \
     mg.h mydtrace.h op.h op_reg_common.h opcode.h pad.h patchlevel.h \
     perl.h perlapi.h perly.h pp.h proto.h regcomp.h regcomp_internal.h \
     regexp.h scope.h sv.h thread.h unixish.h utf8.h util.h warnings.h \

av.c

@@ -83,7 +83,7 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key)
          * we call the tied method.
          */
         sv_setiv(arg1, (IV)(key + 1));
-        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
+        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST2(EXTEND), G_DISCARD, 1,
                             arg1);
         return;
     }
@@ -799,7 +799,7 @@ Perl_av_push(pTHX_ AV *av, SV *val)
         Perl_croak_no_modify();
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
+        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST2(PUSH), G_DISCARD, 1,
                             val);
         return;
     }
@@ -830,7 +830,7 @@ Perl_av_pop(pTHX_ AV *av)
     if (SvREADONLY(av))
         Perl_croak_no_modify();
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-        retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
+        retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST2(POP), 0, 0);
         if (retval)
             retval = newSVsv(retval);
         return retval;
@@ -890,7 +890,7 @@ Perl_av_unshift(pTHX_ AV *av, SSize_t num)
         Perl_croak_no_modify();
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
+        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST2(UNSHIFT),
                             G_DISCARD | G_UNDEF_FILL, num);
         return;
     }
@@ -956,7 +956,7 @@ Perl_av_shift(pTHX_ AV *av)
     if (SvREADONLY(av))
         Perl_croak_no_modify();
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-        retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
+        retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST2(SHIFT), 0, 0);
         if (retval)
             retval = newSVsv(retval);
         return retval;
@@ -1034,7 +1034,7 @@ Perl_av_fill(pTHX_ AV *av, SSize_t fill)
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
         SV *arg1 = sv_newmortal();
         sv_setiv(arg1, (IV)(fill + 1));
-        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
+        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST2(STORESIZE), G_DISCARD,
                             1, arg1);
         return;
     }

class.c

@@ -463,7 +463,8 @@ static void S_ensure_module_version(pTHX_ SV *module, SV *version)
 
     PUSHMARK(PL_stack_sp);
     rpp_xpush_2(module, version);
-    call_method("VERSION", G_VOID);
+    /* call_method("VERSION", G_VOID); */
+    call_sv(SV_CONST2(VERSION), G_VOID | G_METHOD);
 
     LEAVE;
 }

configpm

@@ -77,7 +77,7 @@ my %Extensions = map {($_,$_)}
 # This is the list from MM_VMS, plus pad.h, parser.h, utf8.h
 # which it installs. It *doesn't* install perliol.h - FIXME.
 my @header_files = qw(EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h
-		      embed.h embedvar.h form.h gv.h handy.h hv.h hv_func.h intrpvar.h
+		      embed.h embedvar.h form.h gv.h handy.h hekpool.h hv.h hv_func.h intrpvar.h
 		      iperlsys.h keywords.h mg.h nostdio.h op.h opcode.h
 		      pad.h parser.h patchlevel.h perl.h perlio.h perlsdio.h
 		      perlvars.h perly.h pp.h pp_proto.h proto.h

cop.h

@@ -683,6 +683,22 @@ typedef struct rcpv RCPV;
 
 #endif /* USE_ITHREADS */
 
+/* A cache of the last CopFILE char *, that was turned into a HEK*, probably
+   to be stored in a GP*.  This is a cache. HEK* might be stale, always compare
+   it to the current CopFILE.  This cache prevents alot of repetitive work
+   in Perl_newGP(), PERL_HASH(), share_hek_flags(), and HvARRAY(PL_strtab). */
+struct cop_lastfile {
+    char * copfile_unsafe; /* unsafe to deref, ptr that was used to create
+    this HEK*, the ptr was originally from CopFILE(PL_curcop).
+    The copfile_unsafe does not have any ownership or any RC on the ptr in it.
+    It could be freed by now. char * copfile_unsafe is only used as a ==
+    against the current char * (which has an undefined allocator), to skip
+    the memcmp(). The == will likely pass b/c of the RCPV API. RCPV is an
+    internals detail we don't know about. */
+    HEK * cached_file; /* This field owns a RC +1 HEK*.  If old HEK*
+    is not NULL, it must be --ed. New HEK* must be ++ed.  */
+};
+
 #define CopSTASHPV(c)		(CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
    /* cop_stash is not refcounted */
 #define CopSTASHPV_set(c,pv)	CopSTASH_set((c), gv_stashpv(pv,GV_ADD))

doio.c

@@ -1403,7 +1403,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
         SAVEFREESV(old_out_name);
 
     if (!PL_argvoutgv)
-        PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
+        PL_argvoutgv = gv_fetchsv_nomg(SV_CONST2(ARGVOUT), GV_ADD|GV_NOTQUAL, SVt_PVIO);
     if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
         IoFLAGS(io) &= ~IOf_START;
         if (PL_inplace) {
@@ -1473,7 +1473,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 
                 TAINT_PROPER("inplace open");
                 if (oldlen == 1 && *PL_oldname == '-') {
-                    setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
+                    setdefout(gv_fetchsv_nomg(SV_CONST2(STDOUT), GV_ADD|GV_NOTQUAL,
                                           SVt_PVIO));
                     return IoIFP(GvIOp(gv));
                 }
@@ -1604,7 +1604,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
             SvREFCNT_dec_NN(oldout);
             return NULL;
         }
-        setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
+        setdefout(gv_fetchsv_nomg(SV_CONST2(STDOUT), GV_ADD|GV_NOTQUAL, SVt_PVIO));
     }
     return NULL;
 }

embed.fnc

@@ -3591,6 +3591,9 @@ Adp	|void	|sv_vcatpvfn_flags					\
 				|const Size_t sv_count			\
 				|NULLOK bool * const maybe_tainted	\
 				|const U32 flags
+Cp	|void	|sv_viviall_hekpool
+CRTXp	|SV *	|sv_vivihek	|NN SV * const sv
+Cp	|void	|sv_vivisome_hekpool
 Adp	|void	|sv_vsetpvf	|NN SV * const sv			\
 				|NN const char * const pat		\
 				|NULLOK va_list * const args
@@ -4460,13 +4463,6 @@ S	|bool	|find_default_stash					\
 				|const U32 is_utf8			\
 				|const I32 add				\
 				|const svtype sv_type
-i	|GV *	|gv_fetchmeth_internal					\
-				|NULLOK HV *stash			\
-				|NULLOK SV *meth			\
-				|NULLOK const char *name		\
-				|STRLEN len				\
-				|I32 level				\
-				|U32 flags
 S	|void	|gv_init_svtype |NN GV *gv				\
 				|const svtype sv_type
 S	|bool	|gv_is_in_main	|NN const char *name			\
@@ -4508,6 +4504,15 @@ S	|void	|require_tie_mod|NN GV *gv				\
 op	|void	|sv_add_backref |NN SV * const tsv			\
 				|NN SV * const sv
 #endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C)
+ep	|GV *	|gv_fetchmeth_internal					\
+				|NULLOK HV *stash			\
+				|NULLOK SV *meth			\
+				|NULLOK const char *name		\
+				|STRLEN len				\
+				|I32 level				\
+				|U32 flags
+#endif
 #if defined(PERL_IN_GV_C) || defined(PERL_IN_UNIVERSAL_C)
 EGdp	|HV *	|gv_stashsvpvn_cached					\
 				|SV *namesv				\

embed.h

@@ -846,6 +846,9 @@
 # define sv_vcatpvf_mg(a,b,c)                   Perl_sv_vcatpvf_mg(aTHX_ a,b,c)
 # define sv_vcatpvfn(a,b,c,d,e,f,g)             Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g)
 # define sv_vcatpvfn_flags(a,b,c,d,e,f,g,h)     Perl_sv_vcatpvfn_flags(aTHX_ a,b,c,d,e,f,g,h)
+# define sv_viviall_hekpool()                   Perl_sv_viviall_hekpool(aTHX)
+# define sv_vivihek                             Perl_sv_vivihek
+# define sv_vivisome_hekpool()                  Perl_sv_vivisome_hekpool(aTHX)
 # define sv_vsetpvf(a,b,c)                      Perl_sv_vsetpvf(aTHX_ a,b,c)
 # define sv_vsetpvf_mg(a,b,c)                   Perl_sv_vsetpvf_mg(aTHX_ a,b,c)
 # define sv_vsetpvfn(a,b,c,d,e,f,g)             Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
@@ -1399,7 +1402,6 @@
 #   endif
 #   if defined(PERL_IN_GV_C)
 #     define find_default_stash(a,b,c,d,e,f)    S_find_default_stash(aTHX_ a,b,c,d,e,f)
-#     define gv_fetchmeth_internal(a,b,c,d,e,f) S_gv_fetchmeth_internal(aTHX_ a,b,c,d,e,f)
 #     define gv_init_svtype(a,b)                S_gv_init_svtype(aTHX_ a,b)
 #     define gv_is_in_main(a,b,c)               S_gv_is_in_main(aTHX_ a,b,c)
 #     define gv_magicalize(a,b,c,d,e)           S_gv_magicalize(aTHX_ a,b,c,d,e)
@@ -1409,6 +1411,9 @@
 #     define parse_gv_stash_name(a,b,c,d,e,f,g,h) S_parse_gv_stash_name(aTHX_ a,b,c,d,e,f,g,h)
 #     define require_tie_mod(a,b,c,d,e)         S_require_tie_mod(aTHX_ a,b,c,d,e)
 #   endif /* defined(PERL_IN_GV_C) */
+#   if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C)
+#     define gv_fetchmeth_internal(a,b,c,d,e,f) Perl_gv_fetchmeth_internal(aTHX_ a,b,c,d,e,f)
+#   endif
 #   if defined(PERL_IN_HV_C)
 #     define clear_placeholders(a,b)            S_clear_placeholders(aTHX_ a,b)
 #     define hsplit(a,b,c)                      S_hsplit(aTHX_ a,b,c)

globvar.sym

@@ -19,6 +19,8 @@ PL_EXACT_REQ8_bitmask
 PL_extended_utf8_dfa_tab
 PL_fold
 PL_fold_latin1
+PL_hekpool
+PL_hekpoolsv
 PL_hexdigit
 PL_inf
 PL_interp_size

gv.c

@@ -43,8 +43,9 @@ within a package.  See L<perlguts/Stashes and Globs>
 #include "keywords.h"
 #include "feature.h"
 
-static const char S_autoload[] = "AUTOLOAD";
-#define S_autolen (sizeof("AUTOLOAD")-1)
+/* static const char * S_autoload = NULL;
+   #define S_autolen (sizeof("AUTOLOAD")-1) */
+
 
 /*
 =for apidoc gv_add_by_type
@@ -206,6 +207,8 @@ Perl_newGP(pTHX_ GV *const gv)
     U32 hash;
     const char *file;
     STRLEN len;
+    HEK* hek_cached;
+    HEK* hek;
 
     PERL_ARGS_ASSERT_NEWGP;
     Newxz(gp, 1, GP);
@@ -234,8 +237,27 @@ Perl_newGP(pTHX_ GV *const gv)
         len = 0;
     }
 
-    PERL_HASH(hash, file, len);
-    gp->gp_file_hek = share_hek(file, len, hash);
+    hek_cached = PL_lastcopfile.cached_file;
+    if( hek_cached
+        && (file == PL_lastcopfile.copfile_unsafe
+        /* TODO research chances of free(); malloc(); same addr,
+        len I32 not STRLEN  cache it also? #line and #file in PP can they
+        make a 4.5 GB filepath? */
+            || (len == HEK_LEN(hek_cached)
+                && memEQ(file, HEK_KEY(hek_cached), len)))) {
+        hek = share_hek_hek(hek_cached);
+    }
+    else {
+        PERL_HASH(hash, file, len);
+        hek = share_hek(file, len, hash);
+        hek_cached = PL_lastcopfile.cached_file;
+        PL_lastcopfile.cached_file = share_hek_hek(hek); /* no fn calls here */
+        PL_lastcopfile.copfile_unsafe = file;
+        if(hek_cached) {
+            unshare_hek(hek_cached);
+        }
+    }
+    gp->gp_file_hek = hek;
     gp->gp_refcnt = 1;
 
     return gp;
@@ -846,8 +868,8 @@ Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 
 /* NOTE: No support for tied ISA */
 
-PERL_STATIC_INLINE GV*
-S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
+GV*
+Perl_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
 {
     GV** gvp;
     HE* he;
@@ -865,10 +887,11 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len,
     U32 topgen_cmp;
     U32 is_utf8 = flags & SVf_UTF8;
 
+    PERL_ARGS_ASSERT_GV_FETCHMETH_INTERNAL;
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
         create = 0;  /* probably appropriate */
-        if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
+        if(!(stash = gv_stashsv(SV_CONST2(UNIVERSAL), 0)))
             return 0;
     }
 
@@ -948,14 +971,14 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len,
             if ( ckWARN(WARN_SYNTAX)) {
                 if(     /* these are loaded from Perl_Gv_AMupdate() one way or another */
                            ( len    && name[0] == '(' )  /* overload.pm related, in particular "()" */
-                        || ( memEQs( name, len, "DESTROY") )
+                        || (  memEQhp(name, len, DESTROY, "DESTROY"))
                 ) {
                      Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
                             "Can't locate package %" SVf " for @%" HEKf "::ISA",
                             SVfARG(linear_sv),
                             HEKfARG(HvNAME_HEK(stash)));
 
-                } else if( memEQs( name, len, "AUTOLOAD") ) {
+                } else if( memEQhp(name, len, AUTOLOAD, "AUTOLOAD") ) {
                     /* gobble this warning */
                 } else {
                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
@@ -1074,9 +1097,9 @@ Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I3
 
         if (!stash)
             return NULL;	/* UNIVERSAL::AUTOLOAD could cause trouble */
-        if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
+        if (memEQhp(name, len, AUTOLOAD, "AUTOLOAD"))
             return NULL;
-        if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
+        if (!(gv = gv_fetchmeth_sv_nomg_x(stash, SV_CONST2(AUTOLOAD), FALSE, flags)))
             return NULL;
         cv = GvCV(gv);
         if (!(CvROOT(cv) || CvXSUB(cv)))
@@ -1367,6 +1390,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
 {
     GV* gv;
     CV* cv;
+    HE* varhe;
     HV* varstash;
     GV* vargv;
     SV* varsv;
@@ -1375,7 +1399,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
 
     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
 
-    if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
+    if (memEQhp(name, len, AUTOLOAD, "AUTOLOAD"))
         return NULL;
     if (stash) {
         if (SvTYPE(stash) < SVt_PVHV) {
@@ -1389,7 +1413,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
             packname = newSVhek_mortal(HvNAME_HEK(stash));
         if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
     }
-    if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
+    if (!(gv = gv_fetchmeth_sv_nomg_x(stash, SV_CONST2(AUTOLOAD), FALSE,
                                 is_utf8 | (flags & GV_SUPER))))
         return NULL;
     cv = GvCV(gv);
@@ -1469,11 +1493,13 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
      * original package to look up $AUTOLOAD.
      */
     varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
-    vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
+    varhe = hv_fetch_ent(varstash, SV_CONST2(AUTOLOAD), TRUE, 0);
+    vargv = (GV*)HeVAL(varhe);
     ENTER;
 
     if (!isGV(vargv)) {
-        gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
+        /* gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); */
+        gv_init_sv(vargv, varstash, SV_CONST2(AUTOLOAD), 0); /* TODO add NOVI */
 #ifdef PERL_DONT_CREATE_GVSV
         GvSV(vargv) = newSV_type(SVt_NULL);
 #endif