WIP add API for refcounting CopFILE names with threads #8

This has large memory savings, test prog,
perl -MTest::More -e"system 'pause'"
before 2196KB Private Bytes Win 7 32 bit to after 2092KB.

-On a CHEK the refcount is a U32 for memory savings on 64 bit CPUs while
 SHEKs are Size_t for refcount because of HE struct, on 32 bit Size_t and
 U32 happen to be the same thing, if there is future integration the
 refcount members will have to be the same type, then duping a SHEK or
 a CHEK is the same code, except that HVhek_COMPILING controls whether to
 aquire OP_REFCNT_LOCK before touching the ref count, in the future with
 atomic operations, the refcount can be manipulated with atomic operations
 regardless if it is a SHEK or CHEK since OP_REFCNT_LOCK lines were removed
-TODO figure out how to do static const CHEKs, hash member must be 0
 since its process specific randomized (rurban's B stores HEKs in RW static
 memory and fixes up the hash #s at runtime), add test and branch
 so that refcount isn't read and written or passed to PerlMemShared_free
 if static flag is on inidicating static const CHEK
-TODO Perl_newGP uses CHEKs not CopFILE, no memcpy and add _< that way
-TODO optimize the former alloca to smallbuf or Safefree or savestack
 newx free

cop.h

@@ -383,7 +383,7 @@ struct cop {
 #ifdef USE_ITHREADS
     PADOFFSET	cop_stashoff;	/* offset into PL_stashpad, for the
 				   package the line was compiled in */
-    char *	cop_file;	/* file name the following line # is from */
+    char *	cop_file;	/* a CHEK allocated file name, part of line # */
 #else
     HV *	cop_stash;	/* package line was compiled in */
     GV *	cop_filegv;	/* file the following line # is from */
@@ -398,34 +398,32 @@ struct cop {
 };
 
 #ifdef USE_ITHREADS
+/* make this unassignable with a "+0" force ppl to use _set(), but what about setting
+   the ptr directly in the CHEK code? what suffix to use on the _setptr() variant
+   "setptr" isn't perl XS API nomenclature
+   the fact you can assign a Newx ptr to CopFILE is very dangerous and will
+   cause mem corruption, and it did in Perl_gv_check */
 #  define CopFILE(c)		((c)->cop_file)
+#  define CopFILE_len(c)	(HEK_LEN(FNPV2HEK(CopFILE(c)))-2)
 #  define CopFILEGV(c)		(CopFILE(c) \
-				 ? gv_fetchfile(CopFILE(c)) : NULL)
+				 ? Perl_gv_fetchfile_hek(aTHX_ FNPV2HEK(CopFILE(c))) : NULL)
 
-#  ifdef NETWARE
-#    define CopFILE_set(c,pv)	((c)->cop_file = savepv(pv))
-#    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savepvn((pv),(l)))
-#  else
-#    define CopFILE_set(c,pv)	((c)->cop_file = savesharedpv(pv))
-#    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savesharedpvn((pv),(l)))
-#  endif
+#define CopFILE_set(c,pv)	((c)->cop_file = newchek((pv),0))
+#define CopFILE_setn(c,pv,l)	((c)->cop_file = newchek((pv),(l)))
 
 #  define CopFILESV(c)		(CopFILE(c) \
-				 ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
+				 ? GvSV(Perl_gv_fetchfile_hek(aTHX_ FNPV2HEK(CopFILE(c)))) : NULL)
 #  define CopFILEAV(c)		(CopFILE(c) \
-				 ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
+				 ? GvAV(Perl_gv_fetchfile_hek(aTHX_ FNPV2HEK(CopFILE(c)))) : NULL)
 #  define CopFILEAVx(c)		(assert_(CopFILE(c)) \
-				   GvAV(gv_fetchfile(CopFILE(c))))
+				   GvAV(Perl_gv_fetchfile_hek(aTHX_ FNPV2HEK(CopFILE(c)))))
 
 #  define CopSTASH(c)           PL_stashpad[(c)->cop_stashoff]
 #  define CopSTASH_set(c,hv)	((c)->cop_stashoff = (hv)		\
 				    ? alloccopstash(hv)			\
 				    : 0)
-#  ifdef NETWARE
-#    define CopFILE_free(c) SAVECOPFILE_FREE(c)
-#  else
-#    define CopFILE_free(c)	(PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
-#  endif
+#  define CopFILE_free(c)	free_copfile(c)
+
 #else
 #  define CopFILEGV(c)		((c)->cop_filegv)
 #  define CopFILEGV_set(c,gv)	((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
@@ -440,6 +438,8 @@ struct cop {
 # endif
 #  define CopFILE(c)		(CopFILEGV(c) \
 				    ? GvNAME(CopFILEGV(c))+2 : NULL)
+#  define CopFILE_len(c)	(CopFILEGV(c) \
+				    ? GvNAMELEN(CopFILEGV(c))-2 : 0)
 #  define CopSTASH(c)		((c)->cop_stash)
 #  define CopSTASH_set(c,hv)	((c)->cop_stash = (hv))
 #  define CopFILE_free(c)	(SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))

cv.h

@@ -53,13 +53,9 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CvGV_set(cv,gv)	Perl_cvgv_set(aTHX_ cv, gv)
 #define CvHASGV(cv)	cBOOL(SvANY(cv)->xcv_gv_u.xcv_gv)
 #define CvFILE(sv)	((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file
-#ifdef USE_ITHREADS
-#  define CvFILE_set_from_cop(sv, cop)	\
-    (CvFILE(sv) = savepv(CopFILE(cop)), CvDYNFILE_on(sv))
-#else
-#  define CvFILE_set_from_cop(sv, cop)	\
-    (CvFILE(sv) = CopFILE(cop), CvDYNFILE_off(sv))
-#endif
+/* remove assert once stable */
+#define CvFILE_set_from_cop(sv, cop)	\
+    (assert_(!CvDYNFILE(cv)) CvFILE(sv) = CopFILE(cop), CvDYNFILE_off(sv))
 #define CvFILEGV(sv)	(gv_fetchfile(CvFILE(sv)))
 #define CvDEPTH(sv)	(*S_CvDEPTHp((const CV *)sv))
 /* For use when you only have a XPVCV*, not a real CV*.

embed.fnc

@@ -508,6 +508,9 @@ Ap	|GV*	|gv_fetchfile	|NN const char* name
 Am	|GV*	|gv_fetchfile_flags|NN const char *const name|const STRLEN len\
 				|const U32 flags
 pX	|GV*	|gv_fetchfile_x|NN const char *const name|const STRLEN len
+#ifdef USE_ITHREADS
+pX	|GV*	|gv_fetchfile_hek|NN const HEK * const hek
+#endif
 Amd	|GV*	|gv_fetchmeth	|NULLOK HV* stash|NN const char* name \
 				|STRLEN len|I32 level
 Apd	|GV*	|gv_fetchmeth_sv	|NULLOK HV* stash|NN SV* namesv|I32 level|U32 flags
@@ -2870,6 +2873,13 @@ Apon	|void	|sys_init3	|NN int* argc|NN char*** argv|NN char*** env
 Apon	|void	|sys_term
 ApoM	|const char *|cop_fetch_label|NN COP *const cop \
 		|NULLOK STRLEN *len|NULLOK U32 *flags
+#ifdef USE_ITHREADS
+p	|char *	|newchek	|NN const char *str	|I32 len
+p	|void	|free_copfile	|NN COP * cop
+p	|void	|chek_inc	|NN CHEK * chek
+p	|void	|chek_dec	|NN CHEK * chek
+p	|void	|save_copfile	|NN COP * cop
+#endif
 : Only used  in op.c and the perl compiler
 ApoM	|void|cop_store_label \
 		|NN COP *const cop|NN const char *label|STRLEN len|U32 flags

embed.h

@@ -1810,10 +1810,16 @@
 #define get_c_backtrace(a,b)	Perl_get_c_backtrace(aTHX_ a,b)
 #  endif
 #  if defined(USE_ITHREADS)
+#define chek_dec(a)		Perl_chek_dec(aTHX_ a)
+#define chek_inc(a)		Perl_chek_inc(aTHX_ a)
+#define free_copfile(a)		Perl_free_copfile(aTHX_ a)
+#define gv_fetchfile_hek(a)	Perl_gv_fetchfile_hek(aTHX_ a)
 #define mro_meta_dup(a,b)	Perl_mro_meta_dup(aTHX_ a,b)
+#define newchek(a,b)		Perl_newchek(aTHX_ a,b)
 #define padlist_dup(a,b)	Perl_padlist_dup(aTHX_ a,b)
 #define padname_dup(a,b)	Perl_padname_dup(aTHX_ a,b)
 #define padnamelist_dup(a,b)	Perl_padnamelist_dup(aTHX_ a,b)
+#define save_copfile(a)		Perl_save_copfile(aTHX_ a)
 #  endif
 #  if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
 #define stdize_locale(a)	S_stdize_locale(aTHX_ a)

ext/Devel-Peek/t/Peek.t

@@ -298,8 +298,8 @@ do_test('reference to anon sub with empty prototype',
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = 2
-    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
-    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
+    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr || $] >= 5.023008
+    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && $] < 5.023008 && thr
     PROTOTYPE = ""
     COMP_STASH = $ADDR\\t"main"
     START = $ADDR ===> \\d+
@@ -309,8 +309,8 @@ do_test('reference to anon sub with empty prototype',
     DEPTH = 0(?:
     MUTEXP = $ADDR
     OWNER = $ADDR)?
-    FLAGS = 0x490				# $] < 5.015 || !thr
-    FLAGS = 0x1490				# $] >= 5.015 && thr
+    FLAGS = 0x490				# $] < 5.015 || !thr || $] >= 5.023008
+    FLAGS = 0x1490				# $] >= 5.015 && $] < 5.023008 && thr
     OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
@@ -324,8 +324,8 @@ do_test('reference to named subroutine without prototype',
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = (3|4)
-    FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\)	# $] < 5.015 || !thr
-    FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
+    FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\)	# $] < 5.015 || !thr || $] >= 5.023008
+    FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && $] < 5.023008 && thr
     COMP_STASH = $ADDR\\t"main"
     START = $ADDR ===> \\d+
     ROOT = $ADDR
@@ -734,8 +734,8 @@ do_test('FORMAT',
   RV = $ADDR
   SV = PVFM\\($ADDR\\) at $ADDR
     REFCNT = 2
-    FLAGS = \\(\\)				# $] < 5.015 || !thr
-    FLAGS = \\(DYNFILE\\)			# $] >= 5.015 && thr
+    FLAGS = \\(\\)				# $] < 5.015 || !thr || $] >= 5.023008
+    FLAGS = \\(DYNFILE\\)			# $] >= 5.015 && $] < 5.023008 && thr
 (?:    PV = 0
 )?    COMP_STASH = 0x0
     START = $ADDR ===> \\d+
@@ -745,8 +745,8 @@ do_test('FORMAT',
     DEPTH = 0)?(?:
     MUTEXP = $ADDR
     OWNER = $ADDR)?
-    FLAGS = 0x0					# $] < 5.015 || !thr
-    FLAGS = 0x1000				# $] >= 5.015 && thr
+    FLAGS = 0x0					# $] < 5.015 || !thr || $] >= 5.023008
+    FLAGS = 0x1000				# $] >= 5.015 && $] < 5.023008 && thr
     OUTSIDE_SEQ = \\d+
     LINES = 0					# $] < 5.017_003
     PADLIST = $ADDR

gv.c

@@ -134,6 +134,34 @@ Perl_gv_fetchfile_x(pTHX_ const char *const name, const STRLEN namelen)
     return gv;
 }
 
+#ifdef USE_ITHREADS
+/* HEK must start with "_<" */
+GV *
+Perl_gv_fetchfile_hek(pTHX_ const HEK * const hek)
+{
+    GV *gv;
+
+    PERL_ARGS_ASSERT_GV_FETCHFILE_HEK;
+
+    if (!PL_defstash)
+	return NULL;
+    assert(HEK_LEN(hek) >= 2
+	&& HEK_KEY(hek)[0] == '_' && HEK_KEY(hek)[1] == '<');
+    gv = *(GV**)hv_fetchhek(PL_defstash, hek, TRUE);
+    if (!isGV(gv)) {
+	gv_init(gv, PL_defstash, HEK_KEY(hek), HEK_LEN(hek), FALSE);
+#ifdef PERL_DONT_CREATE_GVSV
+	GvSV(gv) = newSVpvn(HEK_KEY(hek)+2, HEK_LEN(hek)-2);
+#else
+	sv_setpvn(GvSV(gv), HEK_KEY(hek)+2, HEK_LEN(hek)-2);
+#endif
+    }
+    if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
+	    hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
+    return gv;
+}
+#endif
+
 /*
 =for apidoc gv_const_sv
 
@@ -2443,9 +2471,12 @@ Perl_gv_check(pTHX_ HV *stash)
 		if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
 		    continue;
 		file = GvFILE(gv);
+                /* how is this thread safe ???????? aren't ops immutable after creation??*/
 		CopLINE_set(PL_curcop, GvLINE(gv));
 #ifdef USE_ITHREADS
-		CopFILE(PL_curcop) = (char *)file;	/* set for warning */
+		CopFILE_free(PL_curcop);
+		assert(CopFILE(PL_curcop) == NULL);
+		CopFILE_set(PL_curcop, file);	/* set for warning */
 #else
 		CopFILEGV(PL_curcop)
 		    = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);

gv.h

@@ -138,6 +138,13 @@ Return the CV from the GV.
 #define GvGPFLAGS(gv)	(GvGP(gv)->gp_flags)
 
 #define GvLINE(gv)	(GvGP(gv)->gp_line)
+/*XXXX gp_file_hek seems to always come from curcop in gv_init(), so shouldn't
+ *this be a CHEK instead of a SHEK ????
+ *GvFILE and GvFILEx will be the +2 versions that DONT include _< for back compat
+ *that way gv_fetchfile(GvFILEx(gv)) will be gv_fetchfile_hek(chek_ptr) and not
+ *turn the no _< string into a temporary _< prefixed string to do the hash lookup
+
+ *XXXX*/
 #define GvFILE_HEK(gv)	(GvGP(gv)->gp_file_hek)
 #define GvFILEx(gv)	HEK_KEY(GvFILE_HEK(gv))
 #define GvFILE(gv)	(GvFILE_HEK(gv) ? GvFILEx(gv) : NULL)

hv.c

@@ -72,6 +72,30 @@ S_new_he(pTHX)
 
 #endif
 
+#ifdef USE_ITHREADS
+char *
+Perl_newchek(pTHX_ const char *str, I32 len)
+{
+    HEK * hek;
+    U32 hash;
+    char * buf;
+    PERL_ARGS_ASSERT_NEWCHEK;
+    if(!len)
+	len = strlen(str);
+    len +=2;
+    /* was alloca */
+    buf = sv_grow(sv_newmortal(),len);
+    buf[0] = '_';
+    buf[1] = '<';
+    memcpy(&buf[2], str, len-2);
+    PERL_HASH(hash, buf, len);
+    hek = save_hek_flags(buf, len, hash, HVhek_COMPILING);
+    return (char*)&HEK_KEY(hek)+2;
+}
+#endif
+
+/* When this creates CHEKs, it returns a HEK * from inside a CHEK.
+ * The HEK * can be converted to a CHEK * if needed by the caller */
 STATIC HEK *
 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
 {
@@ -81,8 +105,20 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
 
     PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
 
-    Newx(k, HEK_BASESIZE + len + 2, char);
-    hek = (HEK*)k;
+#ifdef USE_ITHREADS
+    if(flags & HVhek_COMPILING) {
+	dTHX;
+	CHEK * chek = (CHEK*)PerlMemShared_malloc(STRUCT_OFFSET(CHEK, chek_hek.hek_key[0]) + len + 2);
+	chek->chek_refcount = 1;
+	hek = &chek->chek_hek;
+    }
+    else {
+#endif
+	Newx(k, HEK_BASESIZE + len + 2, char);
+	hek = (HEK*)k;
+#ifdef USE_ITHREADS
+    }
+#endif
     Copy(str, HEK_KEY(hek), len, char);
     HEK_KEY(hek)[len] = 0;
     HEK_LEN(hek) = len;
@@ -94,6 +130,73 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
     return hek;
 }
 
+#ifdef USE_ITHREADS
+
+void
+Perl_free_copfile(pTHX_ COP * cop)
+{
+    PERL_ARGS_ASSERT_FREE_COPFILE;
+    if(CopFILE(cop)) {
+	CHEK * chek = FNPV2CHEK(CopFILE(cop));
+	CopFILE(cop) = NULL;
+	chek_dec(chek);
+    }
+}
+
+void
+Perl_restore_copfile(pTHX_ void * idx)
+{
+    SSCHEK* ssent = SSPTRt(INT2PTR(I32,idx), SSCHEK);
+    if(*ssent->where != CHEK2FNPV(ssent->what)) {
+	CHEK * existing = FNPV2CHEK(*ssent->where);
+	*ssent->where = CHEK2FNPV(ssent->what);
+	chek_dec(existing);
+    }
+    else
+	chek_dec(ssent->what);
+}
+
+/* instead of SSNEW and SAVEDESTRUCTOR_X this probably needs its own save type
+ * and croak if its save type is ever tried to be dup-ed. I need to research
+ * what happens if 2 different threads restore at 2 random points the CopFILE */
+void
+Perl_save_copfile(pTHX_ COP * cop)
+{
+    I32 idx = SSNEW(sizeof(void *)*2);
+    SSCHEK* ssent = SSPTR(idx, SSCHEK*);
+    CHEK * old = FNPV2CHEK(CopFILE(cop));
+    PERL_ARGS_ASSERT_SAVE_COPFILE;
+    ssent->what = old;
+    ssent->where = &CopFILE(cop);
+    SAVEDESTRUCTOR_X(Perl_restore_copfile,(void*)idx);
+    chek_inc(old);
+}
+
+void
+Perl_chek_inc(pTHX_ CHEK * chek)
+{
+    dVAR;
+    PERL_ARGS_ASSERT_CHEK_INC;
+    OP_REFCNT_LOCK; /* atomic in future ? */
+    chek->chek_refcount++;
+    OP_REFCNT_UNLOCK;
+}
+
+void
+Perl_chek_dec(pTHX_ CHEK * chek)
+{
+    dVAR;
+    U32 refcnt;
+    PERL_ARGS_ASSERT_CHEK_DEC;
+    OP_REFCNT_LOCK; /* atomic in future ? */
+    refcnt = --chek->chek_refcount;
+    OP_REFCNT_UNLOCK;
+    if(!refcnt)
+        PerlMemShared_free(chek);
+}
+
+#endif
+
 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
  * for tied hashes */
 
@@ -1622,7 +1725,7 @@ S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
     }
     else if (HvSHAREKEYS(hv))
 	unshare_hek(HeKEY_hek(entry));
-    else
+    else /* ??? research if a CHEK can wind up in a HE */
 	Safefree(HeKEY_hek(entry));
     del_HE(entry);
     return val;
@@ -2843,6 +2946,11 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
     struct shared_he *he = NULL;
 
     if (hek) {
+	/* if CHEKs are stored in SVPVs like HEKs, for example caller
+	 change here possibly */
+#ifdef USE_ITHREADS
+	assert((HEK_FLAGS(hek) & HVhek_COMPILING) == 0);
+#endif
 	/* Find the shared he which is just before us in memory.  */
 	he = (struct shared_he *)(((char *)hek)
 				  - STRUCT_OFFSET(struct shared_he,