diff options
| -rw-r--r-- | embed.h | 6 | ||||
| -rwxr-xr-x | embed.pl | 3 | ||||
| -rw-r--r-- | embedvar.h | 6 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | makedef.pl | 7 | ||||
| -rw-r--r-- | perl.c | 41 | ||||
| -rw-r--r-- | perl.h | 30 | ||||
| -rw-r--r-- | perlapi.h | 4 | ||||
| -rw-r--r-- | perlvars.h | 6 | ||||
| -rw-r--r-- | pod/perldelta.pod | 11 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | sv.c | 6 | ||||
| -rw-r--r-- | thread.h | 255 | ||||
| -rw-r--r-- | util.c | 42 | ||||
| -rw-r--r-- | win32/perlhost.h | 6 | ||||
| -rw-r--r-- | win32/perllib.c | 30 | ||||
| -rw-r--r-- | win32/win32.h | 7 | ||||
| -rw-r--r-- | win32/win32thread.c | 56 | ||||
| -rw-r--r-- | win32/win32thread.h | 50 |
20 files changed, 307 insertions, 265 deletions
@@ -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 @@ -1503,6 +1505,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 @@ -2929,6 +2933,8 @@ #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 @@ -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 */ diff --git a/embedvar.h b/embedvar.h index e44a2cee2c..f7549406ea 100644 --- a/embedvar.h +++ b/embedvar.h @@ -385,7 +385,6 @@ #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) @@ -650,7 +649,6 @@ #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) @@ -1052,7 +1050,6 @@ #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) @@ -1318,7 +1315,6 @@ #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 @@ -1653,6 +1649,7 @@ #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 */ @@ -1663,6 +1660,7 @@ #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 */ diff --git a/global.sym b/global.sym index b38fc6f519..e69747a626 100644 --- a/global.sym +++ b/global.sym @@ -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 diff --git a/intrpvar.h b/intrpvar.h index 14037873b9..39d14c985e 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -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 */ diff --git a/makedef.pl b/makedef.pl index e3b6fd638f..a54b26c227 100644 --- a/makedef.pl +++ b/makedef.pl @@ -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 @@ -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); @@ -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 @@ -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 */ diff --git a/perlvars.h b/perlvars.h index 220574a2be..4df31bb4a0 100644 --- a/perlvars.h +++ b/perlvars.h @@ -16,7 +16,11 @@ /* 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") diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 3df6f558e9..c6361ba707 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -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 @@ -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 */ @@ -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)); @@ -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 @@ -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) { diff --git a/win32/perlhost.h b/win32/perlhost.h index a748ead0b2..a3f4c28350 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -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; diff --git a/win32/perllib.c b/win32/perllib.c index 26135f864e..3aed2415fd 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -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. */ diff --git a/win32/win32.h b/win32/win32.h index 4e73a23fe6..f102234b78 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -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; diff --git a/win32/win32thread.c b/win32/win32thread.c index 1bca3c3ca5..900f5fedff 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -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) { diff --git a/win32/win32thread.h b/win32/win32thread.h index d4f8ee409e..cfa13cc9f5 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -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) \ |