support fetching current interpreter from TLS under useithreads
authorGurusamy Sarathy <gsar@cpan.org>
Tue, 29 Feb 2000 04:53:00 +0000 (04:53 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Tue, 29 Feb 2000 04:53:00 +0000 (04:53 +0000)
p4raw-id: //depot/perl@5342

20 files changed:
embed.h
embed.pl
embedvar.h
global.sym
intrpvar.h
makedef.pl
perl.c
perl.h
perlapi.h
perlvars.h
pod/perldelta.pod
proto.h
sv.c
thread.h
util.c
win32/perlhost.h
win32/perllib.c
win32/win32.h
win32/win32thread.c
win32/win32thread.h

index f03f499..21a812d 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -54,6 +54,8 @@
 #if defined(MYMALLOC)
 #define malloced_size          Perl_malloced_size
 #endif
+#define get_context            Perl_get_context
+#define set_context            Perl_set_context
 #if defined(PERL_OBJECT)
 #ifndef __BORLANDC__
 #endif
 #if defined(MYMALLOC)
 #define malloced_size          Perl_malloced_size
 #endif
+#define get_context            Perl_get_context
+#define set_context            Perl_set_context
 #if defined(PERL_OBJECT)
 #ifndef __BORLANDC__
 #endif
 #define mfree                  Perl_mfree
 #define malloced_size          Perl_malloced_size
 #endif
+#define get_context            Perl_get_context
+#define set_context            Perl_set_context
 #if defined(PERL_OBJECT)
 #ifndef __BORLANDC__
 #endif
index d4fe1f2..bf0b29c 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1322,6 +1322,9 @@ Ajnop     |Free_t |mfree          |Malloc_t where
 jnp    |MEM_SIZE|malloced_size |void *p
 #endif
 
+Ajnp   |void*  |get_context
+Ajnp   |void   |set_context    |void *thx
+
 END_EXTERN_C
 
 /* functions with flag 'n' should come before here */
index e44a2ce..f754940 100644 (file)
 #define PL_svref_mutex         (PERL_GET_INTERP->Isvref_mutex)
 #define PL_sys_intern          (PERL_GET_INTERP->Isys_intern)
 #define PL_tainting            (PERL_GET_INTERP->Itainting)
-#define PL_thr_key             (PERL_GET_INTERP->Ithr_key)
 #define PL_threadnum           (PERL_GET_INTERP->Ithreadnum)
 #define PL_threads_mutex       (PERL_GET_INTERP->Ithreads_mutex)
 #define PL_threadsv_names      (PERL_GET_INTERP->Ithreadsv_names)
 #define PL_svref_mutex         (vTHX->Isvref_mutex)
 #define PL_sys_intern          (vTHX->Isys_intern)
 #define PL_tainting            (vTHX->Itainting)
-#define PL_thr_key             (vTHX->Ithr_key)
 #define PL_threadnum           (vTHX->Ithreadnum)
 #define PL_threads_mutex       (vTHX->Ithreads_mutex)
 #define PL_threadsv_names      (vTHX->Ithreadsv_names)
 #define PL_svref_mutex         (aTHXo->interp.Isvref_mutex)
 #define PL_sys_intern          (aTHXo->interp.Isys_intern)
 #define PL_tainting            (aTHXo->interp.Itainting)
-#define PL_thr_key             (aTHXo->interp.Ithr_key)
 #define PL_threadnum           (aTHXo->interp.Ithreadnum)
 #define PL_threads_mutex       (aTHXo->interp.Ithreads_mutex)
 #define PL_threadsv_names      (aTHXo->interp.Ithreadsv_names)
 #define PL_Isvref_mutex                PL_svref_mutex
 #define PL_Isys_intern         PL_sys_intern
 #define PL_Itainting           PL_tainting
-#define PL_Ithr_key            PL_thr_key
 #define PL_Ithreadnum          PL_threadnum
 #define PL_Ithreads_mutex      PL_threads_mutex
 #define PL_Ithreadsv_names     PL_threadsv_names
 #define PL_hexdigit            (PL_Vars.Ghexdigit)
 #define PL_malloc_mutex                (PL_Vars.Gmalloc_mutex)
 #define PL_patleave            (PL_Vars.Gpatleave)
+#define PL_thr_key             (PL_Vars.Gthr_key)
 
 #else /* !PERL_GLOBAL_STRUCT */
 
 #define PL_Ghexdigit           PL_hexdigit
 #define PL_Gmalloc_mutex       PL_malloc_mutex
 #define PL_Gpatleave           PL_patleave
+#define PL_Gthr_key            PL_thr_key
 
 #endif /* PERL_GLOBAL_STRUCT */
 
index b38fc6f..e69747a 100644 (file)
@@ -17,6 +17,8 @@ Perl_malloc
 Perl_calloc
 Perl_realloc
 Perl_mfree
+Perl_get_context
+Perl_set_context
 Perl_amagic_call
 Perl_Gv_AMupdate
 Perl_avhv_delete_ent
index 1403787..39d14c9 100644 (file)
@@ -406,7 +406,6 @@ PERLVARA(Iuudmap,256,       char)
 PERLVAR(Ibitcount,     char *)
 
 #ifdef USE_THREADS
-PERLVAR(Ithr_key,      perl_key)       /* For per-thread struct perl_thread* */
 PERLVAR(Isv_mutex,     perl_mutex)     /* Mutex for allocating SVs in sv.c */
 PERLVAR(Ieval_mutex,   perl_mutex)     /* Mutex for doeval */
 PERLVAR(Ieval_cond,    perl_cond)      /* Condition variable for doeval */
index e3b6fd6..a54b26c 100644 (file)
@@ -394,8 +394,6 @@ unless ($define{'USE_5005THREADS'}) {
                    PL_threadsv_names
                    PL_thrsv
                    PL_vtbl_mutex
-                   Perl_getTHR
-                   Perl_setTHR
                    Perl_condpair_magic
                    Perl_new_struct_thread
                    Perl_per_thread_magicals
@@ -552,14 +550,9 @@ while (<DATA>) {
 if ($PLATFORM eq 'win32') {
     foreach my $symbol (qw(
                            boot_DynaLoader
-                           Perl_getTHR
                            Perl_init_os_extras
-                           Perl_setTHR
-                           Perl_thread_create
                            Perl_win32_init
                            RunPerl
-                           GetPerlInterpreter
-                           SetPerlInterpreter
                            win32_errno
                            win32_environ
                            win32_stdin
diff --git a/perl.c b/perl.c
index 7e9f07a..9da19e0 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -59,11 +59,25 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
 #ifdef PERL_OBJECT
     my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
                                                  ipLIO, ipD, ipS, ipP);
-    PERL_SET_INTERP(my_perl);
+    if (!PL_curinterp) {
+       PERL_SET_INTERP(my_perl);
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+       INIT_THREADS;
+        ALLOC_THREAD_KEY;
+#endif
+    }
+    PERL_SET_THX(my_perl);
 #else
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+    if (!PL_curinterp) {
+       PERL_SET_INTERP(my_perl);
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+       INIT_THREADS;
+        ALLOC_THREAD_KEY;
+#endif
+    }
+    PERL_SET_THX(my_perl);
     Zero(my_perl, 1, PerlInterpreter);
     PL_Mem = ipM;
     PL_MemShared = ipMS;
@@ -95,7 +109,15 @@ perl_alloc(void)
 
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+
+    if (!PL_curinterp) {
+       PERL_SET_INTERP(my_perl);
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+       INIT_THREADS;
+        ALLOC_THREAD_KEY;
+#endif
+    }
+    PERL_SET_THX(my_perl);
     Zero(my_perl, 1, PerlInterpreter);
     return my_perl;
 }
@@ -118,7 +140,7 @@ perl_construct(pTHXx)
     struct perl_thread *thr = NULL;
 #endif /* FAKE_THREADS */
 #endif /* USE_THREADS */
-    
+
 #ifdef MULTIPLICITY
     init_interp();
     PL_perl_destruct_level = 1; 
@@ -129,14 +151,7 @@ perl_construct(pTHXx)
 
    /* Init the real globals (and main thread)? */
     if (!PL_linestr) {
-       INIT_THREADS;
 #ifdef USE_THREADS
-#ifdef ALLOC_THREAD_KEY
-        ALLOC_THREAD_KEY;
-#else
-       if (pthread_key_create(&PL_thr_key, 0))
-           Perl_croak(aTHX_ "panic: pthread_key_create");
-#endif
        MUTEX_INIT(&PL_sv_mutex);
        /*
         * Safe to use basic SV functions from now on (though
@@ -146,9 +161,9 @@ perl_construct(pTHXx)
        COND_INIT(&PL_eval_cond);
        MUTEX_INIT(&PL_threads_mutex);
        COND_INIT(&PL_nthreads_cond);
-#ifdef EMULATE_ATOMIC_REFCOUNTS
+#  ifdef EMULATE_ATOMIC_REFCOUNTS
        MUTEX_INIT(&PL_svref_mutex);
-#endif /* EMULATE_ATOMIC_REFCOUNTS */
+#  endif /* EMULATE_ATOMIC_REFCOUNTS */
        
        MUTEX_INIT(&PL_cred_mutex);
 
diff --git a/perl.h b/perl.h
index 7d42b0f..0543a98 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1722,10 +1722,7 @@ typedef pthread_key_t    perl_key;
 #  define PERL_WAIT_FOR_CHILDREN       NOOP
 #endif
 
-/* the traditional thread-unsafe notion of "current interpreter".
- * XXX todo: a thread-safe version that fetches it from TLS (akin to THR)
- * needs to be defined elsewhere (conditional on pthread_getspecific()
- * availability). */
+/* the traditional thread-unsafe notion of "current interpreter". */
 #ifndef PERL_SET_INTERP
 #  define PERL_SET_INTERP(i)           (PL_curinterp = (PerlInterpreter*)(i))
 #endif
@@ -1734,20 +1731,35 @@ typedef pthread_key_t   perl_key;
 #  define PERL_GET_INTERP              (PL_curinterp)
 #endif
 
+#ifndef PERL_SET_CONTEXT
+#  define PERL_SET_CONTEXT(i)          PERL_SET_INTERP(i)
+#endif
+
+#ifndef PERL_GET_CONTEXT
+#  define PERL_GET_CONTEXT             PERL_GET_INTERP
+#endif
+
 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_GET_THX)
 #  ifdef USE_THREADS
-#    define PERL_GET_THX               THR
+#    define PERL_GET_THX               ((struct perl_thread *)PERL_GET_CONTEXT)
 #  else
 #  ifdef MULTIPLICITY
-#    define PERL_GET_THX               PERL_GET_INTERP
+#    define PERL_GET_THX               ((PerlInterpreter *)PERL_GET_CONTEXT)
 #  else
 #  ifdef PERL_OBJECT
-#    define PERL_GET_THX               ((CPerlObj*)PERL_GET_INTERP)
-#  else
-#    define PERL_GET_THX               ((void*)0)
+#    define PERL_GET_THX               ((CPerlObj *)PERL_GET_CONTEXT)
 #  endif
 #  endif
 #  endif
+#  define PERL_SET_THX(t)              PERL_SET_CONTEXT(t)
+#endif
+
+#ifndef PERL_GET_THX
+#  define PERL_GET_THX                 ((void*)NULL)
+#endif
+
+#ifndef PERL_SET_THX
+#  define PERL_SET_THX(t)              NOOP
 #endif
 
 #ifndef SVf
index 8ba6504..70a2187 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -508,8 +508,6 @@ START_EXTERN_C
 #define PL_sys_intern          (*Perl_Isys_intern_ptr(aTHXo))
 #undef  PL_tainting
 #define PL_tainting            (*Perl_Itainting_ptr(aTHXo))
-#undef  PL_thr_key
-#define PL_thr_key             (*Perl_Ithr_key_ptr(aTHXo))
 #undef  PL_threadnum
 #define PL_threadnum           (*Perl_Ithreadnum_ptr(aTHXo))
 #undef  PL_threads_mutex
@@ -882,6 +880,8 @@ START_EXTERN_C
 #define PL_malloc_mutex                (*Perl_Gmalloc_mutex_ptr(NULL))
 #undef  PL_patleave
 #define PL_patleave            (*Perl_Gpatleave_ptr(NULL))
+#undef  PL_thr_key
+#define PL_thr_key             (*Perl_Gthr_key_ptr(NULL))
 
 #endif /* !PERL_CORE */
 #endif /* PERL_OBJECT || MULTIPLICITY */
index 220574a..4df31bb 100644 (file)
 /* global state */
 PERLVAR(Gcurinterp,    PerlInterpreter *)
                                        /* currently running interpreter
-                                        * XXX this needs to be in TLS */
+                                        * (initial parent interpreter under
+                                        * useithreads) */
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+PERLVAR(Gthr_key,      perl_key)       /* key to retrieve per-thread struct */
+#endif
 
 /* constants (these are not literals to facilitate pointer comparisons) */
 PERLVARIC(GYes,                char *, "1")
index 3df6f55..c6361ba 100644 (file)
@@ -319,12 +319,12 @@ Interfaces and implementation are subject to sudden and drastic changes.
 
 The -Dusethreads flag now enables the experimental interpreter-based thread
 support by default.  To get the flavor of experimental threads that was in
-5.005 instead, you need to ask for -Duse5005threads.
+5.005 instead, you need to run Configure with "-Dusethreads -Duse5005threads".
 
 As of v5.5.640, interpreter-threads support is still lacking a way to
 create new threads from Perl (i.e., C<use Thread;> will not work with
 interpreter threads).  C<use Thread;> continues to be available when you
-ask for -Duse5005threads, bugs and all.
+ask for use5005threads, bugs and all.
 
 =head2 New Configure flags
 
@@ -332,15 +332,16 @@ The following new flags may be enabled on the Configure command line
 by running Configure with C<-Dflag>.
 
     usemultiplicity
-    use5005threads
+    usethreads useithreads     (new interpreter threads: no Perl API yet)
+    usethreads use5005threads  (threads as they were in 5.005)
 
-    use64bitint                (equal to now deprecated 'use64bits')
+    use64bitint                        (equal to now deprecated 'use64bits')
     use64bitall
 
     uselongdouble
     usemorebits
     uselargefiles
-    usesocks           (only SOCKS v5 supported)
+    usesocks                   (only SOCKS v5 supported)
 
 =head2 Threadedness and 64-bitness now more daring
 
diff --git a/proto.h b/proto.h
index 3013bd7..ae352c7 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -32,6 +32,9 @@ PERL_CALLCONV Free_t  Perl_mfree(Malloc_t where);
 PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p);
 #endif
 
+PERL_CALLCONV void*    Perl_get_context(void);
+PERL_CALLCONV void     Perl_set_context(void *thx);
+
 END_EXTERN_C
 
 /* functions with flag 'n' should come before here */
diff --git a/sv.c b/sv.c
index d62a145..73c15e7 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -7338,10 +7338,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #  ifdef PERL_OBJECT
     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
                                        ipD, ipS, ipP);
-    PERL_SET_INTERP(pPerl);
+    PERL_SET_THX(pPerl);
 #  else                /* !PERL_OBJECT */
     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+    PERL_SET_THX(my_perl);
 
 #    ifdef DEBUGGING
     memset(my_perl, 0xab, sizeof(PerlInterpreter));
@@ -7369,7 +7369,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     SV *sv;
     SV **svp;
     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+    PERL_SET_THX(my_perl);
 
 #    ifdef DEBUGGING
     memset(my_perl, 0xab, sizeof(PerlInterpreter));
index d03cef1..09ed596 100644 (file)
--- a/thread.h
+++ b/thread.h
@@ -4,15 +4,17 @@
 #  include <win32thread.h>
 #else
 #  ifdef OLD_PTHREADS_API /* Here be dragons. */
-#    define DETACH(t)                          \
-    STMT_START {                               \
-       if (pthread_detach(&(t)->self)) {       \
-           MUTEX_UNLOCK(&(t)->mutex);          \
-           Perl_croak(aTHX_ "panic: DETACH");          \
-       }                                       \
+#    define DETACH(t) \
+    STMT_START {                                               \
+       if (pthread_detach(&(t)->self)) {                       \
+           MUTEX_UNLOCK(&(t)->mutex);                          \
+           Perl_croak(aTHX_ "panic: DETACH");                  \
+       }                                                       \
     } STMT_END
-#    define THR getTHR()
-struct perl_thread *getTHR (void);
+
+#    define PERL_GET_CONTEXT   Perl_get_context()
+#    define PERL_SET_CONTEXT(t)        Perl_set_context((void*)t)
+
 #    define PTHREAD_GETSPECIFIC_INT
 #    ifdef DJGPP
 #      define pthread_addr_t any_t
@@ -62,44 +64,45 @@ struct perl_thread *getTHR (void);
 
 /* #include <mach/cthreads.h> is in perl.h #ifdef I_MACH_CTHREADS */
 
-#define MUTEX_INIT(m)                                  \
-       STMT_START {                                    \
-               *m = mutex_alloc();                     \
-               if (*m) {                               \
-                       mutex_init(*m);                 \
-               } else {                                \
-                       Perl_croak(aTHX_ "panic: MUTEX_INIT");  \
-               }                                       \
-       } STMT_END
-
-#define MUTEX_LOCK(m)          mutex_lock(*m)
-#define MUTEX_LOCK_NOCONTEXT(m)        mutex_lock(*m)
-#define MUTEX_UNLOCK(m)                mutex_unlock(*m)
-#define MUTEX_UNLOCK_NOCONTEXT(m) mutex_unlock(*m)
-#define MUTEX_DESTROY(m)                               \
-       STMT_START {                                    \
-               mutex_free(*m);                         \
-               *m = 0;                                 \
-       } STMT_END
-
-#define COND_INIT(c)                                   \
-       STMT_START {                                    \
-               *c = condition_alloc();                 \
-               if (*c) {                               \
-                       condition_init(*c);             \
-               } else {                                \
-                       Perl_croak(aTHX_ "panic: COND_INIT");   \
-               }                                       \
-       } STMT_END
+#define MUTEX_INIT(m) \
+    STMT_START {                                               \
+       *m = mutex_alloc();                                     \
+       if (*m) {                                               \
+           mutex_init(*m);                                     \
+       } else {                                                \
+           Perl_croak(aTHX_ "panic: MUTEX_INIT");              \
+       }                                                       \
+    } STMT_END
+
+#define MUTEX_LOCK(m)                  mutex_lock(*m)
+#define MUTEX_LOCK_NOCONTEXT(m)                mutex_lock(*m)
+#define MUTEX_UNLOCK(m)                        mutex_unlock(*m)
+#define MUTEX_UNLOCK_NOCONTEXT(m)      mutex_unlock(*m)
+#define MUTEX_DESTROY(m) \
+    STMT_START {                                               \
+       mutex_free(*m);                                         \
+       *m = 0;                                                 \
+    } STMT_END
+
+#define COND_INIT(c) \
+    STMT_START {                                               \
+       *c = condition_alloc();                                 \
+       if (*c) {                                               \
+           condition_init(*c);                                 \
+       }                                                       \
+       else {                                                  \
+           Perl_croak(aTHX_ "panic: COND_INIT");               \
+       }                                                       \
+    } STMT_END
 
 #define COND_SIGNAL(c)         condition_signal(*c)
 #define COND_BROADCAST(c)      condition_broadcast(*c)
 #define COND_WAIT(c, m)                condition_wait(*c, *m)
-#define COND_DESTROY(c)                                \
-       STMT_START {                            \
-               condition_free(*c);             \
-               *c = 0;                         \
-       } STMT_END
+#define COND_DESTROY(c) \
+    STMT_START {                                               \
+       condition_free(*c);                                     \
+       *c = 0;                                                 \
+    } STMT_END
 
 #define THREAD_CREATE(thr, f)  (thr->self = cthread_fork(f, thr), 0)
 #define THREAD_POST_CREATE(thr)
@@ -110,12 +113,12 @@ struct perl_thread *getTHR (void);
 #define DETACH(t)              cthread_detach(t->self)
 #define JOIN(t, avp)           (*(avp) = (AV *)cthread_join(t->self))
 
-#define SET_THR(thr)           cthread_set_data(cthread_self(), thr)
-#define THR                    ((struct perl_thread *)cthread_data(cthread_self()))
+#define PERL_SET_CONTEXT(t)    cthread_set_data(cthread_self(), t)
+#define PERL_GET_CONTEXT       cthread_data(cthread_self())
 
 #define INIT_THREADS           cthread_init()
 #define YIELD                  cthread_yield()
-#define ALLOC_THREAD_KEY
+#define ALLOC_THREAD_KEY       NOOP
 #define SET_THREAD_SELF(thr)   (thr->self = cthread_self())
 
 #endif /* I_MACH_CTHREADS */
@@ -141,102 +144,116 @@ struct perl_thread *getTHR (void);
 #endif
 
 #ifndef MUTEX_INIT
-#ifdef MUTEX_INIT_NEEDS_MUTEX_ZEROED
+
+#  ifdef MUTEX_INIT_NEEDS_MUTEX_ZEROED
     /* Temporary workaround, true bug is deeper. --jhi 1999-02-25 */
-#define MUTEX_INIT(m)                                          \
+#    define MUTEX_INIT(m) \
     STMT_START {                                               \
        Zero((m), 1, perl_mutex);                               \
        if (pthread_mutex_init((m), pthread_mutexattr_default)) \
-           Perl_croak(aTHX_ "panic: MUTEX_INIT");                              \
+           Perl_croak(aTHX_ "panic: MUTEX_INIT");              \
     } STMT_END
-#else
-#define MUTEX_INIT(m)                                          \
+#  else
+#    define MUTEX_INIT(m) \
     STMT_START {                                               \
        if (pthread_mutex_init((m), pthread_mutexattr_default)) \
-           Perl_croak(aTHX_ "panic: MUTEX_INIT");                              \
+           Perl_croak(aTHX_ "panic: MUTEX_INIT");              \
     } STMT_END
-#endif
-#define MUTEX_LOCK(m)                          \
-    STMT_START {                               \
-       if (pthread_mutex_lock((m)))            \
+#  endif
+
+#  define MUTEX_LOCK(m) \
+    STMT_START {                                               \
+       if (pthread_mutex_lock((m)))                            \
            Perl_croak(aTHX_ "panic: MUTEX_LOCK");              \
     } STMT_END
-#define MUTEX_UNLOCK(m)                                \
-    STMT_START {                               \
-       if (pthread_mutex_unlock((m)))          \
-           Perl_croak(aTHX_ "panic: MUTEX_UNLOCK");    \
+
+#  define MUTEX_UNLOCK(m) \
+    STMT_START {                                               \
+       if (pthread_mutex_unlock((m)))                          \
+           Perl_croak(aTHX_ "panic: MUTEX_UNLOCK");            \
     } STMT_END
-#define MUTEX_LOCK_NOCONTEXT(m)                                \
-    STMT_START {                                       \
-       if (pthread_mutex_lock((m)))                    \
-           Perl_croak_nocontext("panic: MUTEX_LOCK");  \
+
+#  define MUTEX_LOCK_NOCONTEXT(m) \
+    STMT_START {                                               \
+       if (pthread_mutex_lock((m)))                            \
+           Perl_croak_nocontext("panic: MUTEX_LOCK");          \
     } STMT_END
-#define MUTEX_UNLOCK_NOCONTEXT(m)                      \
-    STMT_START {                                       \
-       if (pthread_mutex_unlock((m)))                  \
-           Perl_croak_nocontext("panic: MUTEX_UNLOCK");\
+
+#  define MUTEX_UNLOCK_NOCONTEXT(m) \
+    STMT_START {                                               \
+       if (pthread_mutex_unlock((m)))                          \
+           Perl_croak_nocontext("panic: MUTEX_UNLOCK");        \
     } STMT_END
-#define MUTEX_DESTROY(m)                       \
-    STMT_START {                               \
-       if (pthread_mutex_destroy((m)))         \
-           Perl_croak(aTHX_ "panic: MUTEX_DESTROY");   \
+
+#  define MUTEX_DESTROY(m) \
+    STMT_START {                                               \
+       if (pthread_mutex_destroy((m)))                         \
+           Perl_croak(aTHX_ "panic: MUTEX_DESTROY");           \
     } STMT_END
 #endif /* MUTEX_INIT */
 
 #ifndef COND_INIT
-#define COND_INIT(c)                                           \
+#  define COND_INIT(c) \
     STMT_START {                                               \
        if (pthread_cond_init((c), pthread_condattr_default))   \
-           Perl_croak(aTHX_ "panic: COND_INIT");                               \
+           Perl_croak(aTHX_ "panic: COND_INIT");               \
     } STMT_END
-#define COND_SIGNAL(c)                         \
-    STMT_START {                               \
-       if (pthread_cond_signal((c)))           \
-           Perl_croak(aTHX_ "panic: COND_SIGNAL");     \
+
+#  define COND_SIGNAL(c) \
+    STMT_START {                                               \
+       if (pthread_cond_signal((c)))                           \
+           Perl_croak(aTHX_ "panic: COND_SIGNAL");             \
     } STMT_END
-#define COND_BROADCAST(c)                      \
-    STMT_START {                               \
-       if (pthread_cond_broadcast((c)))        \
-           Perl_croak(aTHX_ "panic: COND_BROADCAST");  \
+
+#  define COND_BROADCAST(c) \
+    STMT_START {                                               \
+       if (pthread_cond_broadcast((c)))                        \
+           Perl_croak(aTHX_ "panic: COND_BROADCAST");          \
     } STMT_END
-#define COND_WAIT(c, m)                                \
-    STMT_START {                               \
-       if (pthread_cond_wait((c), (m)))        \
+
+#  define COND_WAIT(c, m) \
+    STMT_START {                                               \
+       if (pthread_cond_wait((c), (m)))                        \
            Perl_croak(aTHX_ "panic: COND_WAIT");               \
     } STMT_END
-#define COND_DESTROY(c)                                \
-    STMT_START {                               \
-       if (pthread_cond_destroy((c)))          \
-           Perl_croak(aTHX_ "panic: COND_DESTROY");    \
+
+#  define COND_DESTROY(c) \
+    STMT_START {                                               \
+       if (pthread_cond_destroy((c)))                          \
+           Perl_croak(aTHX_ "panic: COND_DESTROY");            \
     } STMT_END
 #endif /* COND_INIT */
 
 /* DETACH(t) must only be called while holding t->mutex */
 #ifndef DETACH
-#define DETACH(t)                              \
-    STMT_START {                               \
-       if (pthread_detach((t)->self)) {        \
-           MUTEX_UNLOCK(&(t)->mutex);          \
-           Perl_croak(aTHX_ "panic: DETACH");          \
-       }                                       \
+#  define DETACH(t) \
+    STMT_START {                                               \
+       if (pthread_detach((t)->self)) {                        \
+           MUTEX_UNLOCK(&(t)->mutex);                          \
+           Perl_croak(aTHX_ "panic: DETACH");                  \
+       }                                                       \
     } STMT_END
 #endif /* DETACH */
 
 #ifndef JOIN
-#define JOIN(t, avp)                                   \
-    STMT_START {                                       \
-       if (pthread_join((t)->self, (void**)(avp)))     \
+#  define JOIN(t, avp) \
+    STMT_START {                                               \
+       if (pthread_join((t)->self, (void**)(avp)))             \
            Perl_croak(aTHX_ "panic: pthread_join");            \
     } STMT_END
 #endif /* JOIN */
 
-#ifndef SET_THR
-#define SET_THR(t)                                     \
-    STMT_START {                                       \
-       if (pthread_setspecific(PL_thr_key, (void *) (t)))      \
+#ifndef PERL_GET_CONTEXT
+#  define PERL_GET_CONTEXT     pthread_getspecific(PL_thr_key)
+#endif
+
+#ifndef PERL_SET_CONTEXT
+#  define PERL_SET_CONTEXT(t) \
+    STMT_START {                                               \
+       if (pthread_setspecific(PL_thr_key, (void *)(t)))       \
            Perl_croak(aTHX_ "panic: pthread_setspecific");     \
     } STMT_END
-#endif /* SET_THR */
+#endif /* PERL_SET_CONTEXT */
 
 #ifndef INIT_THREADS
 #  ifdef NEED_PTHREAD_INIT
@@ -244,6 +261,14 @@ struct perl_thread *getTHR (void);
 #  endif
 #endif
 
+#ifndef ALLOC_THREAD_KEY
+#  define ALLOC_THREAD_KEY \
+    STMT_START {                                               \
+       if (pthread_key_create(&PL_thr_key, 0))                 \
+           Perl_croak(aTHX_ "panic: pthread_key_create");      \
+    } STMT_END
+#endif
+
 #ifndef THREAD_RET_TYPE
 #  define THREAD_RET_TYPE      void *
 #  define THREAD_RET_CAST(p)   ((void *)(p))
@@ -251,25 +276,6 @@ struct perl_thread *getTHR (void);
 
 #if defined(USE_THREADS)
 
-/*
- * dTHR is performance-critical. Here, we only do the pthread_get_specific
- * if there may be more than one thread in existence, otherwise we get thr
- * from thrsv which is cached in the per-interpreter structure.
- * Systems with very fast pthread_get_specific (which should be all systems
- * but unfortunately isn't) may wish to simplify to "...*thr = THR".
- *
- * The use of PL_threadnum should be safe here.
- */
-#  if !defined(dTHR)
-#    define dTHR \
-    struct perl_thread *thr = PL_threadnum ? THR : (struct perl_thread*)SvPVX(PL_thrsv)
-#  endif /* dTHR */
-
-#  if !defined(THR)
-#    define THR ((struct perl_thread *) pthread_getspecific(PL_thr_key))
-#  endif
-
-
 /* Accessor for per-thread SVs */
 #  define THREADSV(i) (thr->threadsvp[i])
 
@@ -390,8 +396,13 @@ typedef struct condpair {
 #  define UNLOCK_CRED_MUTEX
 #endif
 
+/* THR, SET_THR, and dTHR are there for compatibility with old versions */
 #ifndef THR
-#  define THR
+#  define THR          PERL_GET_THX
+#endif
+
+#ifndef SET_THR
+#  define SET_THR(t)   PERL_SET_THX(t)
 #endif
 
 #ifndef dTHR
diff --git a/util.c b/util.c
index 1525d53..1202b33 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3291,8 +3291,38 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
     return (scriptname ? savepv(scriptname) : Nullch);
 }
 
+#ifndef PERL_GET_CONTEXT_DEFINED
+
+void *
+Perl_get_context(void)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#  ifdef OLD_PTHREADS_API
+    pthread_addr_t t;
+    if (pthread_getspecific(PL_thr_key, &t))
+       Perl_croak_nocontext("panic: pthread_getspecific");
+    return (void*)t;
+#  else
+    return (void*)pthread_getspecific(PL_thr_key);
+#  endif
+#else
+    return (void*)NULL;
+#endif
+}
+
+void
+Perl_set_context(void *t)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+    if (pthread_setspecific(PL_thr_key, t))
+       Perl_croak_nocontext("panic: pthread_setspecific");
+#endif
+}
+
+#endif /* !PERL_GET_CONTEXT_DEFINED */
 
 #ifdef USE_THREADS
+
 #ifdef FAKE_THREADS
 /* Very simplistic scheduler for now */
 void
@@ -3367,18 +3397,6 @@ Perl_cond_wait(pTHX_ perl_cond *cp)
 }
 #endif /* FAKE_THREADS */
 
-#ifdef PTHREAD_GETSPECIFIC_INT
-struct perl_thread *
-Perl_getTHR(pTHX)
-{
-    pthread_addr_t t;
-
-    if (pthread_getspecific(PL_thr_key, &t))
-       Perl_croak(aTHX_ "panic: pthread_getspecific");
-    return (struct perl_thread *) t;
-}
-#endif
-
 MAGIC *
 Perl_condpair_magic(pTHX_ SV *sv)
 {
index a748ead..a3f4c28 100644 (file)
@@ -1650,7 +1650,7 @@ win32_start_child(LPVOID arg)
 #endif
 
 
-    PERL_SET_INTERP(my_perl);
+    PERL_SET_THX(my_perl);
 
     /* set $$ to pseudo id */
 #ifdef PERL_SYNC_FORK
@@ -1745,7 +1745,7 @@ PerlProcFork(struct IPerlProc* piPerl)
     new_perl->Isys_intern.internal_host = h;
 #  ifdef PERL_SYNC_FORK
     id = win32_start_child((LPVOID)new_perl);
-    PERL_SET_INTERP(aTHXo);
+    PERL_SET_THX(aTHXo);
 #  else
 #    ifdef USE_RTL_THREAD_API
     handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
@@ -1754,7 +1754,7 @@ PerlProcFork(struct IPerlProc* piPerl)
     handle = CreateThread(NULL, 0, win32_start_child,
                          (LPVOID)new_perl, 0, &id);
 #    endif
-    PERL_SET_INTERP(aTHXo);    /* XXX perl_clone*() set TLS */
+    PERL_SET_THX(aTHXo);       /* XXX perl_clone*() set TLS */
     if (!handle)
        Perl_croak(aTHX_ "panic: pseudo fork() failed");
     w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
index 26135f8..3aed241 100644 (file)
@@ -160,7 +160,7 @@ perl_construct(PerlInterpreter* my_perl)
        CPerlHost* pHost = (CPerlHost*)w32_internal_host;
        Perl_free();
        delete pHost;
-       SetPerlInterpreter(NULL);
+       PERL_SET_THX(NULL);
     }
 }
 
@@ -200,7 +200,7 @@ perl_free(PerlInterpreter* my_perl)
     {
     }
 #endif
-    SetPerlInterpreter(NULL);
+    PERL_SET_THX(NULL);
 }
 
 EXTERN_C int
@@ -254,26 +254,6 @@ perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char**
 
 EXTERN_C HANDLE w32_perldll_handle;
 
-static DWORD g_TlsAllocIndex;
-
-EXTERN_C DllExport bool
-SetPerlInterpreter(void *interp)
-{
-    DWORD dwErr = GetLastError();
-    bool bResult = TlsSetValue(g_TlsAllocIndex, interp);
-    SetLastError(dwErr);
-    return bResult;
-}
-
-EXTERN_C DllExport void*
-GetPerlInterpreter(void)
-{
-    DWORD dwErr = GetLastError();
-    LPVOID pResult = TlsGetValue(g_TlsAllocIndex);
-    SetLastError(dwErr);
-    return pResult;
-}
-
 EXTERN_C DllExport int
 RunPerl(int argc, char **argv, char **env)
 {
@@ -333,7 +313,7 @@ RunPerl(int argc, char **argv, char **env)
        new_perl = perl_clone(my_perl, 1);
 #  endif
        exitstatus = perl_run( new_perl );
-       SetPerlInterpreter(my_perl);
+       PERL_SET_THX(my_perl);
 #else
        exitstatus = perl_run( my_perl );
 #endif
@@ -343,7 +323,7 @@ RunPerl(int argc, char **argv, char **env)
     perl_free( my_perl );
 #ifdef USE_ITHREADS
     if (new_perl) {
-       SetPerlInterpreter(new_perl);
+       PERL_SET_THX(new_perl);
        perl_destruct(new_perl);
        perl_free(new_perl);
     }
@@ -371,7 +351,6 @@ DllMain(HANDLE hModule,             /* DLL module handle */
        setmode( fileno( stderr ), O_BINARY );
        _fmode = O_BINARY;
 #endif
-       g_TlsAllocIndex = TlsAlloc();
        DisableThreadLibraryCalls((HMODULE)hModule);
        w32_perldll_handle = hModule;
        break;
@@ -380,7 +359,6 @@ DllMain(HANDLE hModule,             /* DLL module handle */
         * process termination or call to FreeLibrary.
         */
     case DLL_PROCESS_DETACH:
-       TlsFree(g_TlsAllocIndex);
        break;
 
        /* The attached process creates a new thread. */
index 4e73a23..f102234 100644 (file)
@@ -28,8 +28,9 @@
 #endif
 
 #if defined(PERL_IMPLICIT_CONTEXT)
-#  define PERL_GET_INTERP      ((PerlInterpreter*)GetPerlInterpreter())
-#  define PERL_SET_INTERP(i)   (SetPerlInterpreter(i))
+/* compat */
+#  define GetPerlInterpreter   Perl_get_context
+#  define SetPerlInterpreter   Perl_set_context
 #endif
 
 #ifdef __GNUC__
@@ -298,8 +299,6 @@ DllExport void              Perl_win32_init(int *argcp, char ***argvp);
 DllExport void         Perl_init_os_extras();
 DllExport void         win32_str_os_error(void *sv, DWORD err);
 DllExport int          RunPerl(int argc, char **argv, char **env);
-DllExport bool         SetPerlInterpreter(void* interp);
-DllExport void*                GetPerlInterpreter(void);
 
 typedef struct {
     HANDLE     childStdIn;
index 1bca3c3..900f5fe 100644 (file)
@@ -8,52 +8,44 @@ extern CPerlObj* pPerl;
 #endif
 
 #ifdef USE_DECLSPEC_THREAD
-__declspec(thread) struct perl_thread *Perl_current_thread = NULL;
+__declspec(thread) void *PL_current_context = NULL;
 #endif
 
 void
-Perl_setTHR(struct perl_thread *t)
+Perl_set_context(void *t)
 {
-#ifdef USE_THREADS
-#ifdef USE_DECLSPEC_THREAD
- Perl_current_thread = t;
-#else
- TlsSetValue(PL_thr_key,t);
-#endif
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#  ifdef USE_DECLSPEC_THREAD
+    Perl_current_context = t;
+#  else
+    DWORD err = GetLastError();
+    TlsSetValue(PL_thr_key,t);
+    SetLastError(err);
+#  endif
 #endif
 }
 
-struct perl_thread *
-Perl_getTHR(void)
+void *
+Perl_get_context(void)
 {
-#ifdef USE_THREADS
-#ifdef USE_DECLSPEC_THREAD
- return Perl_current_thread;
-#else
- return (struct perl_thread *) TlsGetValue(PL_thr_key);
-#endif
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#  ifdef USE_DECLSPEC_THREAD
+    return Perl_current_context;
+#  else
+    DWORD err = GetLastError();
+    void *result = TlsGetValue(PL_thr_key);
+    SetLastError(err);
+    return result;
+#  endif
 #else
- return NULL;
+    return NULL;
 #endif
 }
 
-void
-Perl_alloc_thread_key(void)
-{
 #ifdef USE_THREADS
-    static int key_allocated = 0;
-    if (!key_allocated) {
-       if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
-           Perl_croak_nocontext("panic: TlsAlloc");
-       key_allocated = 1;
-    }
-#endif
-}
-
 void
 Perl_init_thread_intern(struct perl_thread *athr)
 {
-#ifdef USE_THREADS
 #ifndef USE_DECLSPEC_THREAD
 
  /* 
@@ -65,13 +57,11 @@ Perl_init_thread_intern(struct perl_thread *athr)
  memset(&athr->i,0,sizeof(athr->i));
 
 #endif
-#endif
 }
 
 void
 Perl_set_thread_self(struct perl_thread *thr)
 {
-#ifdef USE_THREADS
     /* Set thr->self.  GetCurrentThread() retrurns a pseudo handle, need
        this to convert it into a handle another thread can use.
      */
@@ -82,10 +72,8 @@ Perl_set_thread_self(struct perl_thread *thr)
                    0,
                    FALSE,
                    DUPLICATE_SAME_ACCESS);
-#endif
 }
 
-#ifdef USE_THREADS
 int
 Perl_thread_create(struct perl_thread *thr, thread_func_t *fn)
 {
index d4f8ee4..cfa13cc 100644 (file)
@@ -24,32 +24,37 @@ typedef CRITICAL_SECTION perl_mutex;
 #else
 
 typedef HANDLE perl_mutex;
-#define MUTEX_INIT(m) \
+#  define MUTEX_INIT(m) \
     STMT_START {                                               \
        if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL)      \
-           Perl_croak(aTHX_ "panic: MUTEX_INIT");                              \
+           Perl_croak(aTHX_ "panic: MUTEX_INIT");              \
     } STMT_END
-#define MUTEX_LOCK(m) \
+
+#  define MUTEX_LOCK(m) \
     STMT_START {                                               \
        if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED)  \
            Perl_croak(aTHX_ "panic: MUTEX_LOCK");              \
     } STMT_END
-#define MUTEX_UNLOCK(m) \
+
+#  define MUTEX_UNLOCK(m) \
     STMT_START {                                               \
        if (ReleaseMutex(*(m)) == 0)                            \
            Perl_croak(aTHX_ "panic: MUTEX_UNLOCK");            \
     } STMT_END
-#define MUTEX_LOCK_NOCONTEXT(m) \
+
+#  define MUTEX_LOCK_NOCONTEXT(m) \
     STMT_START {                                               \
        if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED)  \
            Perl_croak_nocontext("panic: MUTEX_LOCK");          \
     } STMT_END
-#define MUTEX_UNLOCK_NOCONTEXT(m) \
+
+#  define MUTEX_UNLOCK_NOCONTEXT(m) \
     STMT_START {                                               \
        if (ReleaseMutex(*(m)) == 0)                            \
            Perl_croak_nocontext("panic: MUTEX_UNLOCK");        \
     } STMT_END
-#define MUTEX_DESTROY(m) \
+
+#  define MUTEX_DESTROY(m) \
     STMT_START {                                               \
        if (CloseHandle(*(m)) == 0)                             \
            Perl_croak(aTHX_ "panic: MUTEX_DESTROY");           \
@@ -155,27 +160,34 @@ typedef THREAD_RET_TYPE thread_func_t(void *);
 START_EXTERN_C
 
 #if defined(PERLDLL) && defined(USE_DECLSPEC_THREAD) && (!defined(__BORLANDC__) || defined(_DLL))
-extern __declspec(thread) struct perl_thread *Perl_current_thread;
-#define SET_THR(t)             (Perl_current_thread = t)
-#define THR                    Perl_current_thread
+extern __declspec(thread) void *PL_current_context;
+#define PERL_SET_CONTEXT(t)            (PL_current_context = t)
+#define PERL_GET_CONTEXT               PL_current_context
 #else
-#define THR                    Perl_getTHR()
-#define SET_THR(t)             Perl_setTHR(t)
+#define PERL_GET_CONTEXT               Perl_get_context()
+#define PERL_SET_CONTEXT(t)            Perl_set_context(t)
 #endif
-struct perl_thread;
 
-void Perl_alloc_thread_key (void);
+#define PERL_GET_CONTEXT_DEFINED
+
+#if defined(USE_THREADS)
+struct perl_thread;
 int Perl_thread_create (struct perl_thread *thr, thread_func_t *fn);
 void Perl_set_thread_self (struct perl_thread *thr);
-struct perl_thread *Perl_getTHR (void);
-void Perl_setTHR (struct perl_thread *t);
 void Perl_init_thread_intern (struct perl_thread *t);
 
+#define SET_THREAD_SELF(thr) Perl_set_thread_self(thr)
+
+#endif /* USE_THREADS */
+
 END_EXTERN_C
 
-#define INIT_THREADS NOOP
-#define ALLOC_THREAD_KEY Perl_alloc_thread_key()
-#define SET_THREAD_SELF(thr) Perl_set_thread_self(thr)
+#define INIT_THREADS           NOOP
+#define ALLOC_THREAD_KEY \
+    STMT_START {                                                       \
+       if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)            \
+           Perl_croak_nocontext("panic: TlsAlloc");                    \
+    } STMT_END
 
 #if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER)
 #define JOIN(t, avp)                                                   \