diff options
| -rw-r--r-- | cop.h | 9 | ||||
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | intrpvar.h | 6 | ||||
| -rw-r--r-- | op.c | 116 | ||||
| -rw-r--r-- | op.h | 8 | ||||
| -rw-r--r-- | perl.c | 17 | ||||
| -rw-r--r-- | perl.h | 2 | ||||
| -rw-r--r-- | perlio.h | 2 | ||||
| -rw-r--r-- | proto.h | 4 | ||||
| -rw-r--r-- | scope.c | 20 | ||||
| -rw-r--r-- | scope.h | 6 | ||||
| -rw-r--r-- | sv.c | 23 | ||||
| -rwxr-xr-x[-rw-r--r--] | t/op/utf8decode.t | 0 | ||||
| -rw-r--r-- | toke.c | 6 | ||||
| -rw-r--r-- | util.c | 30 | ||||
| -rw-r--r-- | win32/config_H.vc | 14 | ||||
| -rw-r--r-- | win32/perlhost.h | 6 | ||||
| -rw-r--r-- | win32/vmem.h | 14 | ||||
| -rw-r--r-- | win32/win32.c | 3 | ||||
| -rw-r--r-- | win32/win32.h | 6 |
22 files changed, 198 insertions, 103 deletions
@@ -30,13 +30,13 @@ struct cop { # 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 @@ struct cop { && (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 @@ struct cop { /* 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)) @@ -613,6 +613,7 @@ p |void |rxres_save |void** rsp|REGEXP* prx 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 @@ p |void |save_freeop |OP* o 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 @@ -1007,6 +1009,7 @@ s |void |apply_attrs |HV *stash|SV *target|OP *attrs|bool for_my s |void |apply_attrs_my |HV *stash|OP *target|OP *attrs|OP **imopsp # if defined(PL_OP_SLAB_ALLOC) s |void* |Slab_Alloc |int m|size_t sz +s |void |Slab_Free |void * # endif #endif @@ -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) diff --git a/global.sym b/global.sym index 5f0c9dec83..ae33a7aee8 100644 --- a/global.sym +++ b/global.sym @@ -351,6 +351,7 @@ Perl_rninstr Perl_rsignal Perl_rsignal_state Perl_savepv +Perl_savesharedpv Perl_savepvn Perl_savestack_grow Perl_save_aelem @@ -365,6 +366,7 @@ Perl_save_freesv Perl_save_freepv Perl_save_generic_svref Perl_save_generic_pvref +Perl_save_shared_pvref Perl_save_gp Perl_save_hash Perl_save_helem diff --git a/intrpvar.h b/intrpvar.h index 3d08143fb6..4486d2f636 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -512,6 +512,12 @@ PERLVAR(Idebug_pad, struct perl_debug_pad) /* always needed because of the re ex PERLVAR(Itaint_warn, bool) /* taint warns instead of dying */ +#ifdef PL_OP_SLAB_ALLOC +PERLVAR(IOpPtr,IV **) +PERLVARI(IOpSpace,int,0) +PERLVAR(IOpSlab,IV *) +#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. */ @@ -23,28 +23,66 @@ #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) -/* #define PL_OP_SLAB_ALLOC */ - -#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) +#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 + +#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; + /* Add an overhead for pointer to slab and round up as a number of IVs */ + sz = (sz + 2*sizeof(IV) -1)/sizeof(IV); + if ((PL_OpSpace -= sz) < 0) { + PL_OpSlab = (IV *) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(IV)); + if (!PL_OpSlab) { + return NULL; + } + Zero(PL_OpSlab,PERL_SLAB_SIZE,IV); + /* We reserve the 0'th word as a use count */ + PL_OpSpace = PERL_SLAB_SIZE - 1 - 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 = (IV **) &PL_OpSlab[PERL_SLAB_SIZE]; + } + assert( PL_OpSpace >= 0 ); + /* Move the allocation pointer down */ + PL_OpPtr -= sz; + assert( PL_OpPtr > (IV **) PL_OpSlab ); + *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ + (*PL_OpSlab)++; /* Increment use count of slab */ + assert( (IV *) (PL_OpPtr+sz) <= (PL_OpSlab + PERL_SLAB_SIZE) ); + assert( *PL_OpSlab > 0 ); + return (void *)(PL_OpPtr + 1); +} + +STATIC void +S_Slab_Free(pTHX_ void *op) +{ + IV **ptr = (IV **) op; + IV *slab = ptr[-1]; + assert( ptr-1 > (IV **) slab ); + assert( (IV *) ptr < (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 +773,7 @@ Perl_op_free(pTHX_ OP *o) 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 +878,7 @@ clear_pmop: 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 +909,20 @@ clear_pmop: STATIC void S_cop_free(pTHX_ COP* cop) { - Safefree(cop->cop_label); -#ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ -#else - /* NOTE: COP.cop_stash is not refcounted */ - SvREFCNT_dec(CopFILEGV(cop)); -#endif + 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)) + if (! specialCopIO(cop->cop_io)) { +#ifdef USE_ITHREADS + STRLEN len; + char *s = SvPV(cop->cop_io,len); + Perl_warn(aTHX_ "io='%.*s'",(int) len,s); +#else SvREFCNT_dec(cop->cop_io); +#endif + } } void @@ -2583,10 +2612,8 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 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 +4315,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LOOP); + FreeOp(loop); loop = tmp; } #else @@ -5141,11 +5169,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) 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 +6080,6 @@ Perl_ck_glob(pTHX_ OP *o) 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); @@ -299,17 +299,21 @@ struct pmop { #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 { @@ -696,15 +696,8 @@ perl_destruct(pTHXx) 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 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } -# 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 = ""; @@ -425,7 +425,7 @@ int usleep(unsigned int); # define MYSWAP #endif -/* Cannot include embed.h here on Win32 as win32.h has not +/* Cannot include embed.h here on Win32 as win32.h has not yet been included and defines some config variables e.g. HAVE_INTERP_INTERN */ #if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS)) @@ -149,7 +149,7 @@ extern void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param); #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 ---------- */ @@ -641,6 +641,7 @@ PERL_CALLCONV void Perl_rxres_save(pTHX_ void** rsp, REGEXP* prx); 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_freeop(pTHX_ OP* o); 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); @@ -1104,7 +1106,7 @@ STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock); STATIC I32 S_dopoptolabel(pTHX_ char *label); STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock); STATIC I32 S_dopoptosub(pTHX_ I32 startingblock); -STATIC I32 S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock); +STATIC I32 S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock
); STATIC void S_save_lines(pTHX_ AV *array, SV *sv); STATIC OP* S_doeval(pTHX_ int gimme, OP** startop); STATIC PerlIO * S_doopen_pmc(pTHX_ const char *name, const char *mode); @@ -254,6 +254,18 @@ Perl_save_generic_pvref(pTHX_ char **str) 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 @@ Perl_leave_scope(pTHX_ I32 base) *(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; @@ -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 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. #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 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. #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 */ @@ -9363,8 +9363,9 @@ Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) /* 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 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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); diff --git a/t/op/utf8decode.t b/t/op/utf8decode.t index 499049aab9..499049aab9 100644..100755 --- a/t/op/utf8decode.t +++ b/t/op/utf8decode.t @@ -514,11 +514,7 @@ S_incline(pTHX_ char *s) 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; @@ -891,10 +891,11 @@ Copy a string to a safe spot. This does not use an SV. 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 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len) 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 * diff --git a/win32/config_H.vc b/win32/config_H.vc index 2afea67030..f85db9018c 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -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. diff --git a/win32/perlhost.h b/win32/perlhost.h index 7a6fc437fc..d8288852b3 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -216,9 +216,7 @@ protected: 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* IPerlMem2Host(struct IPerlMem* piPerl) 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) diff --git a/win32/vmem.h b/win32/vmem.h index a60459dfe1..712a76edad 100644 --- a/win32/vmem.h +++ b/win32/vmem.h @@ -200,15 +200,17 @@ void VMem::Free(void* pMem) 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; -#else if (ptr->owner) { - ptr->owner->Free(pMem); +#if 1 + dTHX; + int *nowhere = NULL; + Perl_warn(aTHX_ "Free to wrong pool %p not %p",this,ptr->owner); + *nowhere = 0; +#else + ptr->owner->Free(pMem); +#endif } return; -#endif } GetLock(); UnlinkBlock(ptr); diff --git a/win32/win32.c b/win32/win32.c index 246c0c8a47..40b7511296 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1759,6 +1759,7 @@ win32_async_check(pTHX) break; } } + w32_poll_count = 0; /* Above or other stuff may have set a signal flag */ if (PL_sig_pending) { @@ -4561,6 +4562,7 @@ Perl_sys_intern_init(pTHX) # 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 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) 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 */ diff --git a/win32/win32.h b/win32/win32.h index c20c2f7250..036db755ec 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -383,11 +383,12 @@ struct interp_intern { 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 @@ DllExport int win32_async_check(pTHX); #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) |