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

diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index 3a204b2..79e926c 100644 (file)
--- 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 591ec83..f6cef35 100644 (file)
--- 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 2ee4f51..f18b38b 100644 (file)
--- 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 914ec6a..62b0f00 100644 (file)
--- 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 1bc08ff..7ed7cad 100644 (file)
--- 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 f93d5e3..dfa9a0c 100644 (file)
--- 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 697af3f..75aa25b 100644 (file)
--- 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)    \