Get threads working again on Win32

Root cause of fail was init_thread_intern() in
new_struct_thread() (which is called in parent thread)
clobbering dTHR of parent thread. 
It is doubtfull if setting 'self' in new_struct_thread()
is 'right' but left in for now.

p4raw-id: //depot/ansiperl@213

7 files changed, 76 insertions, 29 deletions

diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index 3a204b25b3..79e926cb31 100644
--- a/ext/Thread/Thread.xs
+++ b/ext/Thread/Thread.xs
@@ -89,8 +89,10 @@ threadstart(void *arg)
     AV *returnav;
     int i, ret;
     dJMPENV;
+    DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n",
+			  thr));
 
-    /* Don't call *anything* requiring dTHR until after pthread_setspecific */
+    /* Don't call *anything* requiring dTHR until after SET_THR() */
     /*
      * Wait until our creator releases us. If we didn't do this, then
      * it would be potentially possible for out thread to carry on and
@@ -226,8 +228,8 @@ newthread (SV *startsv, AV *initargs, char *Class)
     thr = new_struct_thread(thr);
     SPAGAIN;
     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
-			  "%p: newthread, tid is %u, preparing stack\n",
-			  savethread, thr->tid));
+			  "%p: newthread (%p), tid is %u, preparing stack\n",
+			  savethread, thr, thr->tid));
     /* The following pushes the arg list and startsv onto the *new* stack */
     PUSHMARK(sp);
     /* Could easily speed up the following greatly */
@@ -235,7 +237,6 @@ newthread (SV *startsv, AV *initargs, char *Class)
 	XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
     XPUSHs(SvREFCNT_inc(startsv));
     PUTBACK;
-
 #ifdef THREAD_CREATE
     err = THREAD_CREATE(thr, threadstart);
 #else    
@@ -251,6 +252,8 @@ newthread (SV *startsv, AV *initargs, char *Class)
     MUTEX_UNLOCK(&thr->mutex);
 #endif
     if (err) {
+        DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+			  "%p: create of %p failed %d\n", savethread, thr, err));
 	/* Thread creation failed--clean up */
 	SvREFCNT_dec(thr->cvcache);
 	remove_thread(thr);
@@ -286,6 +289,7 @@ handle_thread_signal(int sig)
 }
 
 MODULE = Thread		PACKAGE = Thread
+PROTOTYPES: DISABLE
 
 void
 new(Class, startsv, ...)
diff --git a/perl.c b/perl.c
index 591ec832b1..f6cef3536b 100644
--- a/perl.c
+++ b/perl.c
@@ -128,7 +128,9 @@ perl_construct(register PerlInterpreter *sv_interp)
 #ifdef USE_THREADS
 
     	INIT_THREADS;
-#ifndef WIN32
+#ifdef ALLOC_THREAD_KEY
+        ALLOC_THREAD_KEY;
+#else
 	if (pthread_key_create(&thr_key, 0))
 	    croak("panic: pthread_key_create");
 #endif
@@ -2829,8 +2831,8 @@ init_main_thread()
     thr->prev = thr;
     MUTEX_UNLOCK(&threads_mutex);
 
-#ifdef HAVE_THREAD_INTERN
-    init_thread_intern(thr);
+#ifdef INIT_THREAD_INTERN
+    INIT_THREAD_INTERN(thr);
 #else
     thr->self = pthread_self();
 #endif /* HAVE_THREAD_INTERN */
diff --git a/thread.h b/thread.h
index 2ee4f518f6..f18b38b797 100644
--- a/thread.h
+++ b/thread.h
@@ -128,6 +128,7 @@ struct thread *getTHR _((void));
 #  endif
 #endif
 
+
 #ifndef THREAD_RET_TYPE
 #  define THREAD_RET_TYPE	void *
 #  define THREAD_RET_CAST(p)	((void *)(p))
@@ -223,7 +224,7 @@ struct thread {
     perl_mutex	mutex;			/* For the fields others can change */
     U32		tid;
     struct thread *next, *prev;		/* Circular linked list of threads */
-
+    JMPENV	Tstart_env;	        /* Top of top_env longjmp() chain */ 
 #ifdef ADD_THREAD_INTERN
     struct thread_intern i;		/* Platform-dependent internals */
 #endif
@@ -306,6 +307,7 @@ typedef struct condpair {
 #undef	chopset
 #undef	formtarget
 #undef	bodytarget
+#undef  start_env
 #undef	toptarget
 #undef	top_env
 #undef	runlevel
@@ -381,6 +383,7 @@ typedef struct condpair {
 
 #define	top_env		(thr->Ttop_env)
 #define	runlevel	(thr->Trunlevel)
+#define start_env       (thr->Tstart_env)
 
 #else
 /* USE_THREADS is not defined */
diff --git a/util.c b/util.c
index 914ec6ace5..62b0f00c01 100644
--- a/util.c
+++ b/util.c
@@ -2418,8 +2418,6 @@ new_struct_thread(struct thread *t)
     SvGROW(sv, sizeof(struct thread) + 1);
     SvCUR_set(sv, sizeof(struct thread));
     thr = (Thread) SvPVX(sv);
-    /* Zero(thr, 1, struct thread); */
-
     /* debug */
     memset(thr, 0xab, sizeof(struct thread));
     markstack = 0;
@@ -2431,7 +2429,7 @@ new_struct_thread(struct thread *t)
     /* end debug */
 
     thr->oursv = sv;
-    init_stacks(thr);
+    init_stacks(ARGS);
 
     curcop = &compiling;
     thr->cvcache = newHV();
@@ -2443,9 +2441,23 @@ new_struct_thread(struct thread *t)
     curcop = t->Tcurcop;       /* XXX As good a guess as any? */
     defstash = t->Tdefstash;   /* XXX maybe these should */
     curstash = t->Tcurstash;   /* always be set to main? */
-    /* top_env needs to be non-zero. The particular value doesn't matter */
-    top_env = t->Ttop_env;
-    runlevel = 1;		/* XXX should be safe ? */
+
+
+    /* top_env needs to be non-zero. It points to an area
+       in which longjmp() stuff is stored, as C callstack
+       info there at least is thread specific this has to
+       be per-thread. Otherwise a 'die' in a thread gives
+       that thread the C stack of last thread to do an eval {}!
+       See comments in scope.h    
+       Initialize top entry (as in perl.c for main thread)
+     */
+    start_env.je_prev = NULL;
+    start_env.je_ret = -1;
+    start_env.je_mustcatch = TRUE;
+    top_env  = &start_env;
+
+    runlevel = 0;		/* Let entering sub do increment */
+
     in_eval = FALSE;
     restartop = 0;
 
@@ -2470,7 +2482,8 @@ new_struct_thread(struct thread *t)
 	    av_store(thr->magicals, i, sv);
 	    sv_magic(sv, 0, 0, &per_thread_magicals[i], 1);
 	    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
-				  "new_struct_thread: copied magical %d\n",i));
+				  "new_struct_thread: copied magical %d %p->%p\n",i,
+                                  t, thr));
 	}
     } 
 
@@ -2483,8 +2496,17 @@ new_struct_thread(struct thread *t)
     thr->next->prev = thr;
     MUTEX_UNLOCK(&threads_mutex);
 
-#ifdef HAVE_THREAD_INTERN
-    init_thread_intern(thr);
+/*
+ * This is highly suspect - new_struct_thread is executed
+ * by creating thread so pthread_self() or equivalent
+ * is parent thread not the child.
+ * In particular this should _NOT_ change dTHR value of calling thread.
+ * 
+ * But a good place to have a 'hook' for filling in port-private
+ * fields of thr. 
+ */
+#ifdef INIT_THREAD_INTERN
+    INIT_THREAD_INTERN(thr);
 #else
     thr->self = pthread_self();
 #endif /* HAVE_THREAD_INTERN */
diff --git a/win32/Makefile b/win32/Makefile
index 1bc08ffc9e..7ed7cadb39 100644
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -360,8 +360,8 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) perlmain.obj
 	del perl.exe
 	copy splittree.pl .. 
 	$(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto"
-	attrib -r ..\t\*.*
-	copy test ..\t
+#	attrib -r ..\t\*.*
+#	copy test ..\t
 
 perl95.c : runperl.c 
 	copy runperl.c perl95.c
diff --git a/win32/win32thread.c b/win32/win32thread.c
index f93d5e3585..dfa9a0c733 100644
--- a/win32/win32thread.c
+++ b/win32/win32thread.c
@@ -2,10 +2,25 @@
 #include "perl.h"
 
 void
-init_thread_intern(struct thread *thr)
+Perl_alloc_thread_key(void)
 {
 #ifdef USE_THREADS
     static int key_allocated = 0;
+    if (!key_allocated) {
+	if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
+	    croak("panic: TlsAlloc");
+	key_allocated = 1;
+    }
+#endif
+}
+
+void
+init_thread_intern(struct thread *thr)
+{
+#ifdef USE_THREADS
+    /* GetCurrentThread() retrurns a pseudo handle, need
+       this to convert it into a handle another thread can use
+     */
     DuplicateHandle(GetCurrentProcess(),
 		    GetCurrentThread(),
 		    GetCurrentProcess(),
@@ -13,13 +28,6 @@ init_thread_intern(struct thread *thr)
 		    0,
 		    FALSE,
 		    DUPLICATE_SAME_ACCESS);
-    if (!key_allocated) {
-	if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
-	    croak("panic: TlsAlloc");
-	key_allocated = 1;
-    }
-    if (TlsSetValue(thr_key, (LPVOID) thr) != TRUE)
-	croak("panic: TlsSetValue");
 #endif
 }
 
@@ -30,7 +38,11 @@ Perl_thread_create(struct thread *thr, thread_func_t *fn)
     DWORD junk;
 
     MUTEX_LOCK(&thr->mutex);
+    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+			  "%p: create OS thread\n", thr));
     thr->self = CreateThread(NULL, 0, fn, (void*)thr, 0, &junk);
+    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+			  "%p: OS thread = %p, id=%ld\n", thr, thr->self, junk));
     MUTEX_UNLOCK(&thr->mutex);
     return thr->self ? 0 : -1;
 }
diff --git a/win32/win32thread.h b/win32/win32thread.h
index 697af3fe80..75aa25b632 100644
--- a/win32/win32thread.h
+++ b/win32/win32thread.h
@@ -102,12 +102,16 @@ typedef HANDLE perl_mutex;
 
 typedef THREAD_RET_TYPE thread_func_t(void *);
 
-#define HAVE_THREAD_INTERN
 START_EXTERN_C
-void Perl_init_thread_intern _((struct thread *thr));
+void Perl_alloc_thread_key _((void));
 int Perl_thread_create _((struct thread *thr, thread_func_t *fn));
+void Perl_init_thread_intern _((struct thread *thr));
 END_EXTERN_C
 
+#define INIT_THREADS NOOP
+#define ALLOC_THREAD_KEY Perl_alloc_thread_key()
+#define INIT_THREAD_INTERN(thr) Perl_init_thread_intern(thr)
+
 #define JOIN(t, avp)							\
     STMT_START {							\
 	if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED)	\