Change 14284 by jhi@alpha on 2002/01/15 15:55:53
Integrate perlio;
(reintroduce #14251) Slab allocator for ops
- moved the statics to intrpvar.h
- implemented Slab_Free()
- uses PerlMemShared (for now) if distinction exists.
Slab allocator submit after resolve -ay to keep it!
Hand merge of non slab allocator stuff
const-ness fix in savepv's passing of NULL
Typo in #else branch of PL_SLAB_ALLOC
Integrate rest of mainline
Regen embed enable slab for PERL_IMPLICIT_SYS
Correct name of PL_OP_SLAB_ALLOC
Correct slab allocator for case where sizeof(IV) > sizeof(IV *)
e.g. -Duse64bitint on a 32-bit platform.
Now uses I32 for use-count and is more careful with its casts.
Affected files ...
.... //depot/perl/cop.h#62 integrate
.... //depot/perl/embed.fnc#9 integrate
.... //depot/perl/embed.h#330 integrate
.... //depot/perl/embedvar.h#138 integrate
.... //depot/perl/global.sym#202 integrate
.... //depot/perl/intrpvar.h#100 integrate
.... //depot/perl/op.c#478 integrate
.... //depot/perl/op.h#104 integrate
.... //depot/perl/perl.c#405 integrate
.... //depot/perl/perl.h#436 integrate
.... //depot/perl/perlapi.c#128 integrate
.... //depot/perl/perlapi.h#60 integrate
.... //depot/perl/perlio.h#38 integrate
.... //depot/perl/pod/perlapi.pod#127 integrate
.... //depot/perl/pod/perlintern.pod#16 integrate
.... //depot/perl/proto.h#372 integrate
.... //depot/perl/scope.c#89 integrate
.... //depot/perl/scope.h#51 integrate
.... //depot/perl/sv.c#510 integrate
.... //depot/perl/toke.c#411 integrate
.... //depot/perl/util.c#316 integrate
.... //depot/perl/win32/config_H.vc#114 integrate
.... //depot/perl/win32/config_h.PL#26 integrate
.... //depot/perl/win32/perlhost.h#49 integrate
.... //depot/perl/win32/perllib.c#51 integrate
.... //depot/perl/win32/vmem.h#8 integrate
.... //depot/perl/win32/win32.c#187 integrate
.... //depot/perl/win32/win32.h#98 integrate
Differences ...
==== //depot/perl/cop.h#62 (text) ====
Index: perl/cop.h
--- perl/cop.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/cop.h Tue Jan 15 09:00:05 2002
@@ -30,13 +30,13 @@
# define CopFILE(c) ((c)->cop_file)
# define CopFILEGV(c) (CopFILE(c) \
? gv_fetchfile(CopFILE(c)) : Nullgv)
-# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
+# define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv))
# define CopFILESV(c) (CopFILE(c) \
? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
# define CopFILEAV(c) (CopFILE(c) \
? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
# define CopSTASHPV(c) ((c)->cop_stashpv)
-# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
+# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv))
# define CopSTASH(c) (CopSTASHPV(c) \
? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
@@ -44,6 +44,8 @@
&& (CopSTASHPV(c) == HvNAME(hv) \
|| (CopSTASHPV(c) && HvNAME(hv) \
&& strEQ(CopSTASHPV(c), HvNAME(hv)))))
+# define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c))
+# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = Nullch))
+
#else
# define CopFILEGV(c) ((c)->cop_filegv)
# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
@@ -57,6 +59,9 @@
/* cop_stash is not refcounted */
# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
+# define CopSTASH_free(c)
+# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = Nullgv))
+
#endif /* USE_ITHREADS */
#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
==== //depot/perl/embed.fnc#9 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc.~1~ Tue Jan 15 09:00:05 2002
+++ perl/embed.fnc Tue Jan 15 09:00:05 2002
@@ -613,6 +613,7 @@
p |I32 |same_dirent |char* a|char* b
#endif
Apd |char* |savepv |const char* sv
+Apd |char* |savesharedpv |const char* sv
Apd |char* |savepvn |const char* sv|I32 len
Ap |void |savestack_grow
Ap |void |save_aelem |AV* av|I32 idx|SV **sptr
@@ -628,6 +629,7 @@
Ap |void |save_freepv |char* pv
Ap |void |save_generic_svref|SV** sptr
Ap |void |save_generic_pvref|char** str
+Ap |void |save_shared_pvref|char** str
Ap |void |save_gp |GV* gv|I32 empty
Ap |HV* |save_hash |GV* gv
Ap |void |save_helem |HV* hv|SV *key|SV **sptr
==== //depot/perl/embed.h#330 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/embed.h Tue Jan 15 09:00:05 2002
@@ -578,6 +578,7 @@
#define same_dirent Perl_same_dirent
#endif
#define savepv Perl_savepv
+#define savesharedpv Perl_savesharedpv
#define savepvn Perl_savepvn
#define savestack_grow Perl_savestack_grow
#define save_aelem Perl_save_aelem
@@ -593,6 +594,7 @@
#define save_freepv Perl_save_freepv
#define save_generic_svref Perl_save_generic_svref
#define save_generic_pvref Perl_save_generic_pvref
+#define save_shared_pvref Perl_save_shared_pvref
#define save_gp Perl_save_gp
#define save_hash Perl_save_hash
#define save_helem Perl_save_helem
@@ -2127,6 +2129,7 @@
#define same_dirent(a,b) Perl_same_dirent(aTHX_ a,b)
#endif
#define savepv(a) Perl_savepv(aTHX_ a)
+#define savesharedpv(a) Perl_savesharedpv(aTHX_ a)
#define savepvn(a,b) Perl_savepvn(aTHX_ a,b)
#define savestack_grow() Perl_savestack_grow(aTHX)
#define save_aelem(a,b,c) Perl_save_aelem(aTHX_ a,b,c)
@@ -2142,6 +2145,7 @@
#define save_freepv(a) Perl_save_freepv(aTHX_ a)
#define save_generic_svref(a) Perl_save_generic_svref(aTHX_ a)
#define save_generic_pvref(a) Perl_save_generic_pvref(aTHX_ a)
+#define save_shared_pvref(a) Perl_save_shared_pvref(aTHX_ a)
#define save_gp(a,b) Perl_save_gp(aTHX_ a,b)
#define save_hash(a) Perl_save_hash(aTHX_ a)
#define save_helem(a,b,c) Perl_save_helem(aTHX_ a,b,c)
==== //depot/perl/embedvar.h#138 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/embedvar.h Tue Jan 15 09:00:05 2002
@@ -183,6 +183,9 @@
#define PL_Mem (PERL_GET_INTERP->IMem)
#define PL_MemParse (PERL_GET_INTERP->IMemParse)
#define PL_MemShared (PERL_GET_INTERP->IMemShared)
+#define PL_OpPtr (PERL_GET_INTERP->IOpPtr)
+#define PL_OpSlab (PERL_GET_INTERP->IOpSlab)
+#define PL_OpSpace (PERL_GET_INTERP->IOpSpace)
#define PL_Proc (PERL_GET_INTERP->IProc)
#define PL_Sock (PERL_GET_INTERP->ISock)
#define PL_StdIO (PERL_GET_INTERP->IStdIO)
@@ -478,6 +481,9 @@
#define PL_Mem (vTHX->IMem)
#define PL_MemParse (vTHX->IMemParse)
#define PL_MemShared (vTHX->IMemShared)
+#define PL_OpPtr (vTHX->IOpPtr)
+#define PL_OpSlab (vTHX->IOpSlab)
+#define PL_OpSpace (vTHX->IOpSpace)
#define PL_Proc (vTHX->IProc)
#define PL_Sock (vTHX->ISock)
#define PL_StdIO (vTHX->IStdIO)
@@ -776,6 +782,9 @@
#define PL_IMem PL_Mem
#define PL_IMemParse PL_MemParse
#define PL_IMemShared PL_MemShared
+#define PL_IOpPtr PL_OpPtr
+#define PL_IOpSlab PL_OpSlab
+#define PL_IOpSpace PL_OpSpace
#define PL_IProc PL_Proc
#define PL_ISock PL_Sock
#define PL_IStdIO PL_StdIO
==== //depot/perl/global.sym#202 (text+w) ====
Index: perl/global.sym
--- perl/global.sym.~1~ Tue Jan 15 09:00:05 2002
+++ perl/global.sym Tue Jan 15 09:00:05 2002
@@ -351,6 +351,7 @@
Perl_rsignal
Perl_rsignal_state
Perl_savepv
+Perl_savesharedpv
Perl_savepvn
Perl_savestack_grow
Perl_save_aelem
@@ -365,6 +366,7 @@
Perl_save_freepv
Perl_save_generic_svref
Perl_save_generic_pvref
+Perl_save_shared_pvref
Perl_save_gp
Perl_save_hash
Perl_save_helem
==== //depot/perl/intrpvar.h#100 (text) ====
Index: perl/intrpvar.h
--- perl/intrpvar.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/intrpvar.h Tue Jan 15 09:00:05 2002
@@ -512,6 +512,12 @@
PERLVAR(Itaint_warn, bool) /* taint warns instead of dying */
+#ifdef PL_OP_SLAB_ALLOC
+PERLVAR(IOpPtr,I32 **)
+PERLVARI(IOpSpace,I32,0)
+PERLVAR(IOpSlab,I32 *)
+#endif
+
/* New variables must be added to the very end for binary compatibility.
* XSUB.h provides wrapper functions via perlapi.h that make this
* irrelevant, but not all code may be expected to #include XSUB.h. */
==== //depot/perl/op.c#478 (text) ====
Index: perl/op.c
--- perl/op.c.~1~ Tue Jan 15 09:00:05 2002
+++ perl/op.c Tue Jan 15 09:00:05 2002
@@ -23,28 +23,75 @@
#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
-/* #define PL_OP_SLAB_ALLOC */
+#if defined(PL_OP_SLAB_ALLOC)
+
+#ifndef PERL_SLAB_SIZE
+#define PERL_SLAB_SIZE 2048
+#endif
+
+#define NewOp(m,var,c,type) \
+ STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
-#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
-#define SLAB_SIZE 8192
-static char *PL_OpPtr = NULL; /* XXX threadead */
-static int PL_OpSpace = 0; /* XXX threadead */
-#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
- var = (type *)(PL_OpPtr -= c*sizeof(type)); \
- else \
- var = (type *) Slab_Alloc(m,c*sizeof(type)); \
- } while (0)
+#define FreeOp(p) Slab_Free(p)
STATIC void *
S_Slab_Alloc(pTHX_ int m, size_t sz)
{
- Newz(m,PL_OpPtr,SLAB_SIZE,char);
- PL_OpSpace = SLAB_SIZE - sz;
- return PL_OpPtr += PL_OpSpace;
+ /*
+ * To make incrementing use count easy PL_OpSlab is an I32 *
+ * To make inserting the link to slab PL_OpPtr is I32 **
+ * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
+ * Add an overhead for pointer to slab and round up as a number of pointers
+ */
+ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
+ if ((PL_OpSpace -= sz) < 0) {
+ PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
+ if (!PL_OpPtr) {
+ return NULL;
+ }
+ Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
+ /* We reserve the 0'th I32 sized chunk as a use count */
+ PL_OpSlab = (I32 *) PL_OpPtr;
+ /* Reduce size by the use count word, and by the size we need.
+ * Latter is to mimic the '-=' in the if() above
+ */
+ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) -
+sz;
+ /* Allocation pointer starts at the top.
+ Theory: because we build leaves before trunk allocating at end
+ means that at run time access is cache friendly upward
+ */
+ PL_OpPtr += PERL_SLAB_SIZE;
+ }
+ assert( PL_OpSpace >= 0 );
+ /* Move the allocation pointer down */
+ PL_OpPtr -= sz;
+ assert( PL_OpPtr > (I32 **) PL_OpSlab );
+ *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
+ (*PL_OpSlab)++; /* Increment use count of slab */
+ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
+ assert( *PL_OpSlab > 0 );
+ return (void *)(PL_OpPtr + 1);
+}
+
+STATIC void
+S_Slab_Free(pTHX_ void *op)
+{
+ I32 **ptr = (I32 **) op;
+ I32 *slab = ptr[-1];
+ assert( ptr-1 > (I32 **) slab );
+ assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
+ assert( *slab > 0 );
+ if (--(*slab) == 0) {
+ PerlMemShared_free(slab);
+ if (slab == PL_OpSlab) {
+ PL_OpSpace = 0;
+ }
+ }
}
#else
#define NewOp(m, var, c, type) Newz(m, var, c, type)
+#define FreeOp(p) Safefree(p)
#endif
/*
* In the following definition, the ", Nullop" is just to make the compiler
@@ -735,14 +782,7 @@
cop_free((COP*)o);
op_clear(o);
-
-#ifdef PL_OP_SLAB_ALLOC
- if ((char *) o == PL_OpPtr)
- {
- }
-#else
- Safefree(o);
-#endif
+ FreeOp(o);
}
void
@@ -847,11 +887,7 @@
pmop = pmop->op_pmnext;
}
}
-#ifdef USE_ITHREADS
- Safefree(PmopSTASHPV(cPMOPo));
-#else
- /* NOTE: PMOP.op_pmstash is not refcounted */
-#endif
+ PmopSTASH_free(cPMOPo);
}
cPMOPo->op_pmreplroot = Nullop;
/* we use the "SAFE" version of the PM_ macros here
@@ -882,18 +918,20 @@
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label);
+ Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ CopFILE_free(cop);
+ CopSTASH_free(cop);
+ if (! specialWARN(cop->cop_warnings))
+ SvREFCNT_dec(cop->cop_warnings);
+ if (! specialCopIO(cop->cop_io)) {
#ifdef USE_ITHREADS
- Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
- Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
+ STRLEN len;
+ char *s = SvPV(cop->cop_io,len);
+ Perl_warn(aTHX_ "io='%.*s'",(int) len,s);
#else
- /* NOTE: COP.cop_stash is not refcounted */
- SvREFCNT_dec(CopFILEGV(cop));
+ SvREFCNT_dec(cop->cop_io);
#endif
- if (! specialWARN(cop->cop_warnings))
- SvREFCNT_dec(cop->cop_warnings);
- if (! specialCopIO(cop->cop_io))
- SvREFCNT_dec(cop->cop_io);
+ }
}
void
@@ -2583,10 +2621,8 @@
first->op_last = last->op_last;
first->op_flags |= (last->op_flags & OPf_KIDS);
-#ifdef PL_OP_SLAB_ALLOC
-#else
- Safefree(last);
-#endif
+ FreeOp(last);
+
return (OP*)first;
}
@@ -4288,6 +4324,7 @@
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LOOP);
+ FreeOp(loop);
loop = tmp;
}
#else
@@ -5141,11 +5178,7 @@
SAVESPTR(PL_curstash);
SAVECOPSTASH(PL_curcop);
PL_curstash = stash;
-#ifdef USE_ITHREADS
- CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
-#else
- CopSTASH(PL_curcop) = stash;
-#endif
+ CopSTASH_set(PL_curcop,stash);
}
cv = newXS(name, const_sv_xsub, __FILE__);
@@ -6056,8 +6089,6 @@
newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
- if (!glob_gv)
- Perl_croak(aTHX_ "Can't locate File::Glob");
GvCV(gv) = GvCV(glob_gv);
SvREFCNT_inc((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
==== //depot/perl/op.h#104 (text) ====
Index: perl/op.h
--- perl/op.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/op.h Tue Jan 15 09:00:05 2002
@@ -299,17 +299,21 @@
#define PMf_COMPILETIME
(PMf_MULTILINE|PMf_SINGLELINE|PMf_LOCALE|PMf_FOLD|PMf_EXTENDED)
#ifdef USE_ITHREADS
+
# define PmopSTASHPV(o) ((o)->op_pmstashpv)
-# define PmopSTASHPV_set(o,pv) ((o)->op_pmstashpv = ((pv) ? savepv(pv) :
Nullch))
+# define PmopSTASHPV_set(o,pv) (PmopSTASHPV(o) = savesharedpv(pv))
# define PmopSTASH(o) (PmopSTASHPV(o) \
? gv_stashpv(PmopSTASHPV(o),GV_ADD) : Nullhv)
-# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, (hv) ? HvNAME(hv) : Nullch)
+# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, ((hv) ? HvNAME(hv) : Nullch))
+# define PmopSTASH_free(o) PerlMemShared_free(PmopSTASHPV(o))
+
#else
# define PmopSTASH(o) ((o)->op_pmstash)
# define PmopSTASH_set(o,hv) ((o)->op_pmstash = (hv))
# define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME(PmopSTASH(o)) : Nullch)
/* op_pmstash is not refcounted */
# define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
+# define PmopSTASH_free(o)
#endif
struct svop {
==== //depot/perl/perl.c#405 (text) ====
Index: perl/perl.c
--- perl/perl.c.~1~ Tue Jan 15 09:00:05 2002
+++ perl/perl.c Tue Jan 15 09:00:05 2002
@@ -696,15 +696,8 @@
if (!specialCopIO(PL_compiling.cop_io))
SvREFCNT_dec(PL_compiling.cop_io);
PL_compiling.cop_io = Nullsv;
-#ifdef USE_ITHREADS
- Safefree(CopFILE(&PL_compiling));
- CopFILE(&PL_compiling) = Nullch;
- Safefree(CopSTASHPV(&PL_compiling));
-#else
- SvREFCNT_dec(CopFILEGV(&PL_compiling));
- CopFILEGV(&PL_compiling) = Nullgv;
- /* cop_stash is not refcounted */
-#endif
+ CopFILE_free(&PL_compiling);
+ CopSTASH_free(&PL_compiling);
/* Prepare to destruct main symbol table. */
@@ -2717,11 +2710,7 @@
}
}
-# ifdef USE_ITHREADS
- Safefree(CopFILE(PL_curcop));
-# else
- SvREFCNT_dec(CopFILEGV(PL_curcop));
-# endif
+ CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
if (strEQ(PL_origfilename,"-"))
scriptname = "";
==== //depot/perl/perl.h#436 (text) ====
Index: perl/perl.h
--- perl/perl.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/perl.h Tue Jan 15 09:00:05 2002
@@ -41,6 +41,15 @@
/* See L<perlguts/"The Perl API"> for detailed notes on
* PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */
+#ifdef PERL_IMPLICIT_SYS
+/* PERL_IMPLICIT_SYS implies PerlMemShared != PerlMem
+ so use slab allocator to avoid lots of MUTEX overhead
+ */
+# ifndef PL_OP_SLAB_ALLOC
+# define PL_OP_SLAB_ALLOC
+# endif
+#endif
+
#ifdef USE_ITHREADS
# if !defined(MULTIPLICITY)
# define MULTIPLICITY
==== //depot/perl/perlapi.c#128 (text+w) ====
==== //depot/perl/perlapi.h#60 (text+w) ====
Index: perl/perlapi.h
--- perl/perlapi.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/perlapi.h Tue Jan 15 09:00:05 2002
@@ -103,6 +103,12 @@
#define PL_MemParse (*Perl_IMemParse_ptr(aTHX))
#undef PL_MemShared
#define PL_MemShared (*Perl_IMemShared_ptr(aTHX))
+#undef PL_OpPtr
+#define PL_OpPtr (*Perl_IOpPtr_ptr(aTHX))
+#undef PL_OpSlab
+#define PL_OpSlab (*Perl_IOpSlab_ptr(aTHX))
+#undef PL_OpSpace
+#define PL_OpSpace (*Perl_IOpSpace_ptr(aTHX))
#undef PL_Proc
#define PL_Proc (*Perl_IProc_ptr(aTHX))
#undef PL_Sock
==== //depot/perl/perlio.h#38 (text) ====
Index: perl/perlio.h
--- perl/perlio.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/perlio.h Tue Jan 15 09:00:05 2002
@@ -149,7 +149,7 @@
#endif /* ifndef PERLIO_NOT_STDIO */
#endif /* PERLIO_IS_STDIO */
-#define specialCopIO(sv) ((sv) != Nullsv)
+#define specialCopIO(sv) ((sv) == Nullsv)
/* ----------- fill in things that have not got #define'd ---------- */
==== //depot/perl/pod/perlapi.pod#127 (text+w) ====
==== //depot/perl/pod/perlintern.pod#16 (text+w) ====
==== //depot/perl/proto.h#372 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/proto.h Tue Jan 15 09:00:05 2002
@@ -641,6 +641,7 @@
PERL_CALLCONV I32 Perl_same_dirent(pTHX_ char* a, char* b);
#endif
PERL_CALLCONV char* Perl_savepv(pTHX_ const char* sv);
+PERL_CALLCONV char* Perl_savesharedpv(pTHX_ const char* sv);
PERL_CALLCONV char* Perl_savepvn(pTHX_ const char* sv, I32 len);
PERL_CALLCONV void Perl_savestack_grow(pTHX);
PERL_CALLCONV void Perl_save_aelem(pTHX_ AV* av, I32 idx, SV **sptr);
@@ -656,6 +657,7 @@
PERL_CALLCONV void Perl_save_freepv(pTHX_ char* pv);
PERL_CALLCONV void Perl_save_generic_svref(pTHX_ SV** sptr);
PERL_CALLCONV void Perl_save_generic_pvref(pTHX_ char** str);
+PERL_CALLCONV void Perl_save_shared_pvref(pTHX_ char** str);
PERL_CALLCONV void Perl_save_gp(pTHX_ GV* gv, I32 empty);
PERL_CALLCONV HV* Perl_save_hash(pTHX_ GV* gv);
PERL_CALLCONV void Perl_save_helem(pTHX_ HV* hv, SV *key, SV **sptr);
==== //depot/perl/scope.c#89 (text) ====
Index: perl/scope.c
--- perl/scope.c.~1~ Tue Jan 15 09:00:05 2002
+++ perl/scope.c Tue Jan 15 09:00:05 2002
@@ -254,6 +254,18 @@
SSPUSHINT(SAVEt_GENERIC_PVREF);
}
+/* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
+ * Can be used to restore a shared global char* to its prior
+ * contents, freeing new value. */
+void
+Perl_save_shared_pvref(pTHX_ char **str)
+{
+ SSCHECK(3);
+ SSPUSHPTR(str);
+ SSPUSHPTR(*str);
+ SSPUSHINT(SAVEt_SHARED_PVREF);
+}
+
void
Perl_save_gp(pTHX_ GV *gv, I32 empty)
{
@@ -657,6 +669,14 @@
*(char**)ptr = str;
}
break;
+ case SAVEt_SHARED_PVREF: /* shared pv */
+ str = (char*)SSPOPPTR;
+ ptr = SSPOPPTR;
+ if (*(char**)ptr != str) {
+ PerlMemShared_free(*(char**)ptr);
+ *(char**)ptr = str;
+ }
+ break;
case SAVEt_GENERIC_SVREF: /* generic sv */
value = (SV*)SSPOPPTR;
ptr = SSPOPPTR;
==== //depot/perl/scope.h#51 (text) ====
Index: perl/scope.h
--- perl/scope.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/scope.h Tue Jan 15 09:00:05 2002
@@ -35,6 +35,7 @@
#define SAVEt_GENERIC_PVREF 34
#define SAVEt_PADSV 35
#define SAVEt_MORTALIZESV 36
+#define SAVEt_SHARED_PVREF 37
#ifndef SCOPE_SAVES_SIGNAL_MASK
#define SCOPE_SAVES_SIGNAL_MASK 0
@@ -117,6 +118,7 @@
#define SAVECLEARSV(sv) save_clearsv(SOFT_CAST(SV**)&(sv))
#define SAVEGENERICSV(s) save_generic_svref((SV**)&(s))
#define SAVEGENERICPV(s) save_generic_pvref((char**)&(s))
+#define SAVESHAREDPV(s) save_shared_pvref((char**)&(s))
#define SAVEDELETE(h,k,l) \
save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l))
#define SAVEDESTRUCTOR(f,p) \
@@ -160,9 +162,9 @@
#ifdef USE_ITHREADS
# define SAVECOPSTASH(c) SAVEPPTR(CopSTASHPV(c))
-# define SAVECOPSTASH_FREE(c) SAVEGENERICPV(CopSTASHPV(c))
+# define SAVECOPSTASH_FREE(c) SAVESHAREDPV(CopSTASHPV(c))
# define SAVECOPFILE(c) SAVEPPTR(CopFILE(c))
-# define SAVECOPFILE_FREE(c) SAVEGENERICPV(CopFILE(c))
+# define SAVECOPFILE_FREE(c) SAVESHAREDPV(CopFILE(c))
#else
# define SAVECOPSTASH(c) SAVESPTR(CopSTASH(c))
# define SAVECOPSTASH_FREE(c) SAVECOPSTASH(c) /* XXX not refcounted */
==== //depot/perl/sv.c#510 (text) ====
Index: perl/sv.c
--- perl/sv.c.~1~ Tue Jan 15 09:00:05 2002
+++ perl/sv.c Tue Jan 15 09:00:05 2002
@@ -9363,8 +9363,9 @@
/* see if it is part of the interpreter structure */
if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
- else
+ else {
ret = v;
+ }
return ret;
}
@@ -9417,6 +9418,12 @@
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
break;
+ case SAVEt_SHARED_PVREF: /* char* in shared space */
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = savesharedpv(c);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ break;
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
@@ -9786,15 +9793,21 @@
SvNVX(&PL_sv_yes) = 1;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
- /* create shared string table */
+ /* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
hv_ksplit(PL_strtab, 512);
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
- PL_compiling = proto_perl->Icompiling;
- PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
- PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
+ 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);
==== //depot/perl/toke.c#411 (text) ====
Index: perl/toke.c
--- perl/toke.c.~1~ Tue Jan 15 09:00:05 2002
+++ perl/toke.c Tue Jan 15 09:00:05 2002
@@ -514,11 +514,7 @@
ch = *t;
*t = '\0';
if (t - s > 0) {
-#ifdef USE_ITHREADS
- Safefree(CopFILE(PL_curcop));
-#else
- SvREFCNT_dec(CopFILEGV(PL_curcop));
-#endif
+ CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, s);
}
*t = ch;
@@ -2184,7 +2180,7 @@
bool bof = FALSE;
/* check if there's an identifier for us to look at */
- if (PL_pending_ident)
+ if (PL_pending_ident)
return S_pending_ident(aTHX);
/* no identifier pending identification */
@@ -6672,12 +6668,12 @@
(void)strcpy(d,"ARGV");
/* Check whether readline() is overriden */
- if ((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
- && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)
+ if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
+ && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
||
- (gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
+ ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
&& (gv_readline = *gvp) != (GV*)&PL_sv_undef
- && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
+ && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
readline_overriden = TRUE;
/* if <$fh>, create the ops to turn the variable into a
==== //depot/perl/util.c#316 (text) ====
Index: perl/util.c
--- perl/util.c.~1~ Tue Jan 15 09:00:05 2002
+++ perl/util.c Tue Jan 15 09:00:05 2002
@@ -891,10 +891,11 @@
char *
Perl_savepv(pTHX_ const char *sv)
{
- register char *newaddr;
-
- New(902,newaddr,strlen(sv)+1,char);
- (void)strcpy(newaddr,sv);
+ register char *newaddr = Nullch;
+ if (sv) {
+ New(902,newaddr,strlen(sv)+1,char);
+ (void)strcpy(newaddr,sv);
+ }
return newaddr;
}
@@ -920,6 +921,27 @@
return newaddr;
}
+/*
+=for apidoc savesharedpv
+
+Copy a string to a safe spot in memory shared between threads.
+This does not use an SV.
+
+=cut
+*/
+char *
+Perl_savesharedpv(pTHX_ const char *sv)
+{
+ register char *newaddr = Nullch;
+ if (sv) {
+ newaddr = PerlMemShared_malloc(strlen(sv)+1);
+ (void)strcpy(newaddr,sv);
+ }
+ return newaddr;
+}
+
+
+
/* the SV for Perl_form() and mess() is not kept in an arena */
STATIC SV *
==== //depot/perl/win32/config_H.vc#114 (text+w) ====
Index: perl/win32/config_H.vc
--- perl/win32/config_H.vc.~1~ Tue Jan 15 09:00:05 2002
+++ perl/win32/config_H.vc Tue Jan 15 09:00:05 2002
@@ -13,7 +13,7 @@
/*
* Package name : perl5
* Source directory :
- * Configuration time: Fri Jan 11 12:16:33 2002
+ * Configuration time: Mon Jan 14 15:39:13 2002
* Configured by : nick
* Target system :
*/
@@ -733,12 +733,6 @@
*/
/*#define I_MEMORY /**/
-/* I_NDBM:
- * This symbol, if defined, indicates that <ndbm.h> exists and should
- * be included.
- */
-/*#define I_NDBM /**/
-
/* I_NET_ERRNO:
* This symbol, if defined, indicates that <net/errno.h> exists and
* should be included.
@@ -3420,6 +3414,12 @@
/*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
/*#define DOSUID /**/
+/* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+/*#define I_NDBM /**/
+
/* I_STDARG:
* This symbol, if defined, indicates that <stdarg.h> exists and should
* be included.
==== //depot/perl/win32/config_h.PL#26 (text) ====
==== //depot/perl/win32/perlhost.h#49 (text) ====
Index: perl/win32/perlhost.h
--- perl/win32/perlhost.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/win32/perlhost.h Tue Jan 15 09:00:05 2002
@@ -216,9 +216,7 @@
static long num_hosts;
public:
inline int LastHost(void) { return num_hosts == 1L; };
-#ifdef CHECK_HOST_INTERP
struct interpreter *host_perl;
-#endif
};
long CPerlHost::num_hosts = 0L;
@@ -244,12 +242,12 @@
inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
{
- return STRUCT2PTR(piPerl, m_hostperlMemShared);
+ return STRUCT2RAWPTR(piPerl, m_hostperlMemShared);
}
inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl)
{
- return STRUCT2PTR(piPerl, m_hostperlMemParse);
+ return STRUCT2RAWPTR(piPerl, m_hostperlMemParse);
}
inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl)
==== //depot/perl/win32/perllib.c#51 (text) ====
==== //depot/perl/win32/vmem.h#8 (text) ====
Index: perl/win32/vmem.h
--- perl/win32/vmem.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/win32/vmem.h Tue Jan 15 09:00:05 2002
@@ -200,15 +200,17 @@
if (pMem) {
PMEMORY_BLOCK_HEADER ptr =
(PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER));
if (ptr->owner != this) {
-#if 0
- int *nowhere = NULL;
- *nowhere = 0;
+ if (ptr->owner) {
+#if 1
+ dTHX;
+ int *nowhere = NULL;
+ Perl_warn(aTHX_ "Free to wrong pool %p not %p",this,ptr->owner);
+ *nowhere = 0;
#else
- if (ptr->owner) {
- ptr->owner->Free(pMem);
+ ptr->owner->Free(pMem);
+#endif
}
return;
-#endif
}
GetLock();
UnlinkBlock(ptr);
==== //depot/perl/win32/win32.c#187 (text) ====
Index: perl/win32/win32.c
--- perl/win32/win32.c.~1~ Tue Jan 15 09:00:05 2002
+++ perl/win32/win32.c Tue Jan 15 09:00:05 2002
@@ -1759,6 +1759,7 @@
break;
}
}
+ w32_poll_count = 0;
/* Above or other stuff may have set a signal flag */
if (PL_sig_pending) {
@@ -4561,6 +4562,7 @@
# endif
w32_init_socktype = 0;
w32_timerid = 0;
+ w32_poll_count = 0;
if (my_perl == PL_curinterp) {
/* Force C runtime signal stuff to set its console handler */
signal(SIGINT,&win32_csighandler);
@@ -4603,6 +4605,7 @@
Newz(1313, dst->pseudo_children, 1, child_tab);
dst->thr_intern.Winit_socktype = 0;
dst->timerid = 0;
+ dst->poll_count = 0;
}
# endif /* USE_ITHREADS */
#endif /* HAVE_INTERP_INTERN */
==== //depot/perl/win32/win32.h#98 (text) ====
Index: perl/win32/win32.h
--- perl/win32/win32.h.~1~ Tue Jan 15 09:00:05 2002
+++ perl/win32/win32.h Tue Jan 15 09:00:05 2002
@@ -383,11 +383,12 @@
struct thread_intern thr_intern;
#endif
UINT timerid;
- HANDLE msg_event;
+ unsigned poll_count;
};
DllExport int win32_async_check(pTHX);
+#define WIN32_POLL_INTERVAL 32768
#define PERL_ASYNC_CHECK() if (w32_do_async || PL_sig_pending) win32_async_check(aTHX)
#define w32_perlshell_tokens (PL_sys_intern.perlshell_tokens)
@@ -405,7 +406,8 @@
#define w32_pseudo_child_handles (w32_pseudo_children->handles)
#define w32_internal_host (PL_sys_intern.internal_host)
#define w32_timerid (PL_sys_intern.timerid)
-#define w32_do_async (w32_timerid != 0)
+#define w32_poll_count (PL_sys_intern.poll_count)
+#define w32_do_async (w32_poll_count++ > WIN32_POLL_INTERVAL)
#ifdef USE_5005THREADS
# define w32_strerror_buffer (thr->i.Wstrerror_buffer)
# define w32_getlogin_buffer (thr->i.Wgetlogin_buffer)
End of Patch.
