Use PerlMemShared for CopSTASHPV and CopFILE. MUCH harder than it sounds!

Need to use CopXXXXX macros everywhere and add CopSTASH_free
Add new scope type and add support for it to scope.c and scope stack
dup-er in sv.c. Add savesharedpv().
Also zealous version of Win32's vmem.h to catch all the abuses.
With this t/op/fork.t passes even with zealous checking and
checker is point a finger at various threads/shared issues.

PL_curcop->cop_io is still an issue.

p4raw-id: //depot/perlio@14259

diff --git a/cop.h b/cop.h
index 0040cbe..7e2b3a9 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -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))

diff --git a/embed.fnc b/embed.fnc
index f5fcac6..a9d1dcc 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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

diff --git a/embed.h b/embed.h
index cbd880e..bbae4f1 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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
@@ -2128,6 +2130,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)
@@ -2143,6 +2146,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 5f0c9de..ae33a7a 100644 (file)
--- 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/op.c b/op.c
index 2230aaf..57e7784 100644 (file)
--- a/op.c
+++ b/op.c
@@ -878,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
@@ -913,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
@@ -5171,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__);

diff --git a/op.h b/op.h
index 2bfdced..5c8e367 100644 (file)
--- a/op.h
+++ b/op.h
@@ -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 {

diff --git a/perl.c b/perl.c
index e7f7ad6..d7e3ace 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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 = "";

diff --git a/proto.h b/proto.h
index 0bdb25c..5068b43 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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);
@@ -1105,7 +1107,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\r);
 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);

diff --git a/scope.c b/scope.c
index e976f3c..59adddf 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -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;

diff --git a/scope.h b/scope.h
index f0abb72..6efeb5e 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -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 */

diff --git a/sv.c b/sv.c
index 3de686f..0cd86d6 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -9361,8 +9361,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;
 }
@@ -9415,6 +9416,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);
@@ -9784,15 +9791,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/toke.c b/toke.c
index 8382333..c0384ad 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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;

diff --git a/util.c b/util.c
index 6a0ff44..83b9026 100644 (file)
--- a/util.c
+++ b/util.c
@@ -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 = sv;
+    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 = sv;
+    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 2afea67..f85db90 100644 (file)
--- 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 7a6fc43..d828885 100644 (file)
--- 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 a60459d..712a76e 100644 (file)
--- 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 246c0c8..40b7511 100644 (file)
--- 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 c20c2f7..036db75 100644 (file)
--- 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)