Win32 fixes:

 - vmem.h hack to handle free-by-wrong-thread after eval "".
 - Initialize timerid

p4raw-id: //depot/perlio@14232

4 files changed, 74 insertions, 6 deletions

diff --git a/win32/perlhost.h b/win32/perlhost.h
index 3be76ed817..7a6fc437fc 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -7,6 +7,8 @@
  *    License or the Artistic License, as specified in the README file.
  */
 
+#define CHECK_HOST_INTERP
+
 #ifndef ___PerlHost_H___
 #define ___PerlHost_H___
 
@@ -214,16 +216,30 @@ 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;
 
+extern "C" void win32_checkTLS(struct interpreter *host_perl);
 
-#define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
+#define STRUCT2RAWPTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
+#ifdef CHECK_HOST_INTERP
+inline CPerlHost* CheckInterp(CPerlHost *host) 
+{
+ win32_checkTLS(host->host_perl);
+ return host;
+}
+#define STRUCT2PTR(x, y) CheckInterp(STRUCT2RAWPTR(x, y))
+#else
+#define STRUCT2PTR(x, y) STRUCT2RAWPTR(x, y)
+#endif
 
 inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl)
 {
-    return STRUCT2PTR(piPerl, m_hostperlMem);
+    return STRUCT2RAWPTR(piPerl, m_hostperlMem);
 }
 
 inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
@@ -1681,6 +1697,7 @@ win32_start_child(LPVOID arg)
 
 
     PERL_SET_THX(my_perl);
+    win32_checkTLS(my_perl);
 
     /* set $$ to pseudo id */
 #ifdef PERL_SYNC_FORK
@@ -1747,9 +1764,11 @@ restart:
 	JMPENV_POP;
 
 	/* XXX hack to avoid perl_destruct() freeing optree */
+        win32_checkTLS(my_perl);
 	PL_main_root = Nullop;
     }
 
+    win32_checkTLS(my_perl);
     /* close the std handles to avoid fd leaks */
     {
 	do_close(gv_fetchpv("STDIN", TRUE, SVt_PVIO), FALSE);
@@ -1758,7 +1777,9 @@ restart:
     }
 
     /* destroy everything (waits for any pseudo-forked children) */
+    win32_checkTLS(my_perl);
     perl_destruct(my_perl);
+    win32_checkTLS(my_perl);
     perl_free(my_perl);
 
 #ifdef PERL_SYNC_FORK
@@ -1795,6 +1816,7 @@ PerlProcFork(struct IPerlProc* piPerl)
 						 h->m_pHostperlProc
 						 );
     new_perl->Isys_intern.internal_host = h;
+    h->host_perl = new_perl;
 #  ifdef PERL_SYNC_FORK
     id = win32_start_child((LPVOID)new_perl);
     PERL_SET_THX(aTHX);
@@ -2414,3 +2436,4 @@ CPerlHost::Chdir(const char *dirname)
 }
 
 #endif /* ___PerlHost_H___ */
+
diff --git a/win32/perllib.c b/win32/perllib.c
index 6243a79fd3..4e4c113964 100644
--- a/win32/perllib.c
+++ b/win32/perllib.c
@@ -33,6 +33,17 @@ xs_init(pTHX)
 
 #include "perlhost.h"
 
+void
+win32_checkTLS(PerlInterpreter *host_perl)
+{
+    dTHX;
+    if (host_perl != my_perl) {
+	int *nowhere = NULL;
+        *nowhere = 0; 
+	abort();
+    }
+}
+
 EXTERN_C void
 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
 		   struct IPerlMemInfo* perlMemSharedInfo,
@@ -105,6 +116,7 @@ perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 				   pHost->m_pHostperlProc);
 	if (my_perl) {
 	    w32_internal_host = pHost;
+	    pHost->host_perl  = my_perl;
 	}
     }
     return my_perl;
@@ -127,6 +139,7 @@ perl_alloc(void)
 				   pHost->m_pHostperlProc);
 	if (my_perl) {
 	    w32_internal_host = pHost;
+            pHost->host_perl  = my_perl;
 	}
     }
     return my_perl;
@@ -287,6 +300,7 @@ perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
                         h->m_pHostperlProc
     );
     proto_perl->Isys_intern.internal_host = h;
+    h->host_perl  = proto_perl;
     return proto_perl;
 	
 }
diff --git a/win32/vmem.h b/win32/vmem.h
index cda6f819bc..a60459dfe1 100644
--- a/win32/vmem.h
+++ b/win32/vmem.h
@@ -21,7 +21,8 @@
 #ifndef ___VMEM_H_INC___
 #define ___VMEM_H_INC___
 
-// #define _USE_MSVCRT_MEM_ALLOC
+#define _USE_MSVCRT_MEM_ALLOC
+#define _USE_LINKED_LIST
 
 // #define _USE_BUDDY_BLOCKS
 
@@ -70,10 +71,12 @@ typedef void (*LPFREE)(void *block);
 typedef void* (*LPMALLOC)(size_t size);
 typedef void* (*LPREALLOC)(void *block, size_t size);
 #ifdef _USE_LINKED_LIST
+class VMem;
 typedef struct _MemoryBlockHeader* PMEMORY_BLOCK_HEADER;
 typedef struct _MemoryBlockHeader {
     PMEMORY_BLOCK_HEADER    pNext;
     PMEMORY_BLOCK_HEADER    pPrev;
+    VMem *owner;
 } MEMORY_BLOCK_HEADER, *PMEMORY_BLOCK_HEADER;
 #endif
 
@@ -104,6 +107,7 @@ protected:
 	m_Dummy.pNext = ptr;
 	ptr->pPrev = &m_Dummy;
 	ptr->pNext = next;
+        ptr->owner = this;
 	next->pPrev = ptr;
     }
     void UnlinkBlock(PMEMORY_BLOCK_HEADER ptr)
@@ -131,6 +135,7 @@ VMem::VMem()
     InitializeCriticalSection(&m_cs);
 #ifdef _USE_LINKED_LIST
     m_Dummy.pNext = m_Dummy.pPrev =  &m_Dummy;
+    m_Dummy.owner = this;
 #endif
     m_hLib = LoadLibrary("msvcrt.dll");
     if (m_hLib) {
@@ -155,8 +160,10 @@ VMem::~VMem(void)
 void* VMem::Malloc(size_t size)
 {
 #ifdef _USE_LINKED_LIST
+    GetLock();
     PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)m_pmalloc(size+sizeof(MEMORY_BLOCK_HEADER));
     LinkBlock(ptr);
+    FreeLock();
     return (ptr+1);
 #else
     return m_pmalloc(size);
@@ -174,10 +181,12 @@ void* VMem::Realloc(void* pMem, size_t size)
 	return NULL;
     }
 
+    GetLock();
     PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER));
     UnlinkBlock(ptr);
     ptr = (PMEMORY_BLOCK_HEADER)m_prealloc(ptr, size+sizeof(MEMORY_BLOCK_HEADER));
     LinkBlock(ptr);
+    FreeLock();
 
     return (ptr+1);
 #else
@@ -190,8 +199,22 @@ void VMem::Free(void* pMem)
 #ifdef _USE_LINKED_LIST
     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);	
+	    }
+	    return;
+#endif
+        }
+	GetLock();
 	UnlinkBlock(ptr);
+	ptr->owner = NULL;
 	m_pfree(ptr);
+	FreeLock();
     }
 #else
     m_pfree(pMem);
diff --git a/win32/win32.c b/win32/win32.c
index 7df339d9cf..246c0c8a47 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -1722,7 +1722,7 @@ win32_async_check(pTHX)
     /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
      * and ignores window messages - should co-exist better with windows apps e.g. Tk
      */ 
-    while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE)) {
+    while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
 	switch(msg.message) {
 
 #if 0
@@ -1742,8 +1742,10 @@ win32_async_check(pTHX)
 	
 	case WM_TIMER: {
 	    /* alarm() is a one-shot but SetTimer() repeats so kill it */
-	    KillTimer(NULL,w32_timerid);
-	    w32_timerid=0;  
+	    if (w32_timerid) {
+	    	KillTimer(NULL,w32_timerid);
+	    	w32_timerid=0;  
+            }
 	    /* Now fake a call to signal handler */
 	    CALL_FPTR(PL_sighandlerp)(14);
 	    break;
@@ -4558,6 +4560,7 @@ Perl_sys_intern_init(pTHX)
     w32_num_pseudo_children	= 0;
 #  endif
     w32_init_socktype		= 0;
+    w32_timerid                 = 0;
     if (my_perl == PL_curinterp) {
         /* Force C runtime signal stuff to set its console handler */
 	signal(SIGINT,&win32_csighandler);
@@ -4574,6 +4577,10 @@ Perl_sys_intern_clear(pTHX)
     Safefree(w32_perlshell_vec);
     /* NOTE: w32_fdpid is freed by sv_clean_all() */
     Safefree(w32_children);
+    if (w32_timerid) {
+    	KillTimer(NULL,w32_timerid);
+    	w32_timerid=0;  
+    }
     if (my_perl == PL_curinterp) {
 	SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
     }
@@ -4595,6 +4602,7 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
     dst->pseudo_id		= 0;
     Newz(1313, dst->pseudo_children, 1, child_tab);
     dst->thr_intern.Winit_socktype = 0;
+    dst->timerid                 = 0;
 }
 #  endif /* USE_ITHREADS */
 #endif /* HAVE_INTERP_INTERN */