diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rwxr-xr-x | ext/threads/threads.xs | 131 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | perl.c | 34 | ||||
| -rw-r--r-- | perl.h | 1 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | perlvars.h | 1 | ||||
| -rw-r--r-- | pod/perlapi.pod | 10 | ||||
| -rw-r--r-- | proto.h | 1 |
11 files changed, 137 insertions, 49 deletions
@@ -957,6 +957,7 @@ Ap |char * |custom_op_desc|OP* op Adp |void |sv_nosharing |SV * Adp |void |sv_nolocking |SV * Adp |void |sv_nounlocking |SV * +Adp |int |nothreadhook END_EXTERN_C @@ -899,6 +899,7 @@ #define sv_nosharing Perl_sv_nosharing #define sv_nolocking Perl_sv_nolocking #define sv_nounlocking Perl_sv_nounlocking +#define nothreadhook Perl_nothreadhook #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define avhv_index_sv S_avhv_index_sv #define avhv_index S_avhv_index @@ -2447,6 +2448,7 @@ #define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a) #define sv_nolocking(a) Perl_sv_nolocking(aTHX_ a) #define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a) +#define nothreadhook() Perl_nothreadhook(aTHX) #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define avhv_index_sv(a) S_avhv_index_sv(aTHX_ a) #define avhv_index(a,b,c) S_avhv_index(aTHX_ a,b,c) diff --git a/embedvar.h b/embedvar.h index 8eccfa2e72..379917832a 100644 --- a/embedvar.h +++ b/embedvar.h @@ -1370,6 +1370,7 @@ #define PL_runops_std (PL_Vars.Grunops_std) #define PL_sharehook (PL_Vars.Gsharehook) #define PL_thr_key (PL_Vars.Gthr_key) +#define PL_threadhook (PL_Vars.Gthreadhook) #define PL_unlockhook (PL_Vars.Gunlockhook) #else /* !PERL_GLOBAL_STRUCT */ @@ -1387,6 +1388,7 @@ #define PL_Grunops_std PL_runops_std #define PL_Gsharehook PL_sharehook #define PL_Gthr_key PL_thr_key +#define PL_Gthreadhook PL_threadhook #define PL_Gunlockhook PL_unlockhook #endif /* PERL_GLOBAL_STRUCT */ diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 006e55252c..393867eefe 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -41,6 +41,12 @@ STMT_START {\ #endif #endif +/* Values for 'state' member */ +#define PERL_ITHR_JOINABLE 0 +#define PERL_ITHR_DETACHED 1 +#define PERL_ITHR_FINISHED 4 +#define PERL_ITHR_JOINED 2 + typedef struct ithread_s { struct ithread_s *next; /* next thread in the list */ struct ithread_s *prev; /* prev thread in the list */ @@ -48,7 +54,7 @@ typedef struct ithread_s { I32 tid; /* threads module's thread id */ perl_mutex mutex; /* mutex for updating things in this struct */ I32 count; /* how many SVs have a reference to us */ - signed char detached; /* are we detached ? */ + signed char state; /* are we detached ? */ int gimme; /* Context of create */ SV* init_function; /* Code to run */ SV* params; /* args to pass function */ @@ -72,6 +78,7 @@ ithread *threads; static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/ I32 tid_counter = 0; +I32 known_threads = 0; I32 active_threads = 0; perl_key self_key; @@ -79,9 +86,12 @@ perl_key self_key; * Clear up after thread is done with */ void -Perl_ithread_destruct (pTHX_ ithread* thread) +Perl_ithread_destruct (pTHX_ ithread* thread, const char *why) { MUTEX_LOCK(&thread->mutex); + if (!thread->next) { + Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why); + } if (thread->count != 0) { MUTEX_UNLOCK(&thread->mutex); return; @@ -98,14 +108,17 @@ Perl_ithread_destruct (pTHX_ ithread* thread) if (threads == thread) { threads = thread->next; } + thread->next = NULL; + thread->prev = NULL; } - active_threads--; - MUTEX_UNLOCK(&create_destruct_mutex); - /* Thread is now disowned */ + known_threads--; + assert( known_threads >= 0 ); #if 0 - Perl_warn(aTHX_ "destruct %d @ %p by %p", - thread->tid,thread->interp,aTHX); + Perl_warn(aTHX_ "destruct %d @ %p by %p now %d", + thread->tid,thread->interp,aTHX, known_threads); #endif + MUTEX_UNLOCK(&create_destruct_mutex); + /* Thread is now disowned */ if (thread->interp) { dTHXa(thread->interp); PERL_SET_CONTEXT(thread->interp); @@ -117,6 +130,41 @@ Perl_ithread_destruct (pTHX_ ithread* thread) MUTEX_UNLOCK(&thread->mutex); } +int +Perl_ithread_hook(pTHX) +{ + int veto_cleanup = 0; + MUTEX_LOCK(&create_destruct_mutex); + if (aTHX == PL_curinterp && active_threads != 1) { + Perl_warn(aTHX_ "Cleanup skipped %d active threads", active_threads); + veto_cleanup = 1; + } + MUTEX_UNLOCK(&create_destruct_mutex); + return veto_cleanup; +} + +void +Perl_ithread_detach(pTHX_ ithread *thread) +{ + MUTEX_LOCK(&thread->mutex); + if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) { + thread->state |= PERL_ITHR_DETACHED; +#ifdef WIN32 + CloseHandle(thread->handle); + thread->handle = 0; +#else + PERL_THREAD_DETACH(thread->thr); +#endif + } + if ((thread->state & PERL_ITHR_FINISHED) && + (thread->state & PERL_ITHR_DETACHED)) { + MUTEX_UNLOCK(&thread->mutex); + Perl_ithread_destruct(aTHX_ thread, "detach"); + } + else { + MUTEX_UNLOCK(&thread->mutex); + } +} /* MAGIC (in mg.h sense) hooks */ @@ -135,9 +183,16 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) ithread *thread = (ithread *) mg->mg_ptr; MUTEX_LOCK(&thread->mutex); thread->count--; - MUTEX_UNLOCK(&thread->mutex); - /* This is safe as it re-checks count */ - Perl_ithread_destruct(aTHX_ thread); + if (thread->count == 0) { + if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) { + Perl_warn(aTHX_ "Implicit detach"); + } + MUTEX_UNLOCK(&thread->mutex); + Perl_ithread_detach(aTHX_ thread); + } + else { + MUTEX_UNLOCK(&thread->mutex); + } return 0; } @@ -220,16 +275,21 @@ Perl_ithread_run(void * arg) { } PerlIO_flush((PerlIO*)NULL); + MUTEX_LOCK(&create_destruct_mutex); + active_threads--; + assert( active_threads >= 0 ); + MUTEX_UNLOCK(&create_destruct_mutex); MUTEX_LOCK(&thread->mutex); - if (thread->detached & 1) { + thread->state |= PERL_ITHR_FINISHED; + + if (thread->state & PERL_ITHR_DETACHED) { MUTEX_UNLOCK(&thread->mutex); SvREFCNT_dec(thread->params); thread->params = Nullsv; - Perl_ithread_destruct(aTHX_ thread); + Perl_ithread_destruct(aTHX_ thread, "detached finish"); } else { - thread->detached |= 4; - MUTEX_UNLOCK(&thread->mutex); - } + MUTEX_UNLOCK(&thread->mutex); + } #ifdef WIN32 return (DWORD)0; #else @@ -296,7 +356,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param MUTEX_INIT(&thread->mutex); thread->tid = tid_counter++; thread->gimme = GIMME_V; - thread->detached = (thread->gimme == G_VOID) ? 1 : 0; + thread->state = (thread->gimme == G_VOID) ? 1 : 0; /* "Clone" our interpreter into the thread's interpreter * This gives thread access to "static data" and code. @@ -317,7 +377,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param { dTHXa(thread->interp); /* Here we remove END blocks since they should only run - in the thread they are created + in the thread they are created */ SvREFCNT_dec(PL_endav); PL_endav = newAV(); @@ -368,6 +428,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param #endif } #endif + known_threads++; active_threads++; MUTEX_UNLOCK(&create_destruct_mutex); return ithread_to_SV(aTHX_ obj, thread, classname, FALSE); @@ -399,16 +460,16 @@ Perl_ithread_CLONE(pTHX_ SV *obj) } } -AV* +AV* Perl_ithread_join(pTHX_ SV *obj) { ithread *thread = SV_to_ithread(aTHX_ obj); MUTEX_LOCK(&thread->mutex); - if (thread->detached & 1) { + if (thread->state & PERL_ITHR_DETACHED) { MUTEX_UNLOCK(&thread->mutex); Perl_croak(aTHX_ "Cannot join a detached thread"); } - else if (thread->detached & 2) { + else if (thread->state & PERL_ITHR_JOINED) { MUTEX_UNLOCK(&thread->mutex); Perl_croak(aTHX_ "Thread already joined"); } @@ -427,8 +488,9 @@ Perl_ithread_join(pTHX_ SV *obj) #endif MUTEX_LOCK(&thread->mutex); + /* sv_dup over the args */ { - AV* params = (AV*) SvRV(thread->params); + AV* params = (AV*) SvRV(thread->params); CLONE_PARAMS clone_params; clone_params.stashes = newAV(); PL_ptr_table = ptr_table_new(); @@ -439,35 +501,17 @@ Perl_ithread_join(pTHX_ SV *obj) PL_ptr_table = NULL; } - /* sv_dup over the args */ /* We have finished with it */ - thread->detached |= 2; + thread->state |= PERL_ITHR_JOINED; MUTEX_UNLOCK(&thread->mutex); sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar); - Perl_ithread_destruct(aTHX_ thread); + Perl_ithread_destruct(aTHX_ thread, "joined"); return retparam; } return (AV*)NULL; } void -Perl_ithread_detach(pTHX_ ithread *thread) -{ - MUTEX_LOCK(&thread->mutex); - if (!thread->detached) { - thread->detached = 1; -#ifdef WIN32 - CloseHandle(thread->handle); - thread->handle = 0; -#else - PERL_THREAD_DETACH(thread->thr); -#endif - } - MUTEX_UNLOCK(&thread->mutex); -} - - -void Perl_ithread_DESTROY(pTHX_ SV *sv) { ithread *thread = SV_to_ithread(aTHX_ sv); @@ -534,6 +578,7 @@ BOOT: PERL_THREAD_ALLOC_SPECIFIC(self_key); MUTEX_INIT(&create_destruct_mutex); MUTEX_LOCK(&create_destruct_mutex); + PL_threadhook = &Perl_ithread_hook; thread = PerlMemShared_malloc(sizeof(ithread)); Zero(thread,1,ithread); PL_perl_destruct_level = 2; @@ -544,13 +589,15 @@ BOOT: thread->interp = aTHX; thread->count = 1; /* imortal */ thread->tid = tid_counter++; + known_threads++; active_threads++; - thread->detached = 1; + thread->state = 1; #ifdef WIN32 thread->thr = GetCurrentThreadId(); #else thread->thr = pthread_self(); #endif + PERL_THREAD_SETSPECIFIC(self_key,thread); MUTEX_UNLOCK(&create_destruct_mutex); } diff --git a/global.sym b/global.sym index f86942ef7b..3eb8d34dba 100644 --- a/global.sym +++ b/global.sym @@ -608,6 +608,7 @@ Perl_custom_op_desc Perl_sv_nosharing Perl_sv_nolocking Perl_sv_nounlocking +Perl_nothreadhook Perl_sv_setsv_flags Perl_sv_catpvn_flags Perl_sv_catsv_flags @@ -294,6 +294,21 @@ perl_construct(pTHXx) } /* +=for apidoc nothreadhook + +Stub that provides thread hook for perl_destruct when there are +no threads. + +=cut +*/ + +int +Perl_nothreadhook(pTHXx) +{ + return 0; +} + +/* =for apidoc perl_destruct Shuts down a Perl interpreter. See L<perlembed>. @@ -410,6 +425,11 @@ perl_destruct(pTHXx) LEAVE; FREETMPS; + if (CALL_FPTR(PL_threadhook)(aTHX)) { + /* Threads hook has vetoed further cleanup */ + return STATUS_NATIVE_EXPORT;; + } + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -2776,8 +2796,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) /* This strips off Perl comments which might interfere with - the C pre-processor, including #!. #line directives are - deliberately stripped to avoid confusion with Perl's version + the C pre-processor, including #!. #line directives are + deliberately stripped to avoid confusion with Perl's version of #line. FWP played some golf with it so it will fit into VMS's 255 character buffer. */ @@ -2788,7 +2808,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) Perl_sv_setpvf(aTHX_ cmd, "\ %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", - perl, quote, code, quote, scriptname, cpp, + perl, quote, code, quote, scriptname, cpp, cpp_discard_flag, sv, CPPMINUS); PL_doextract = FALSE; @@ -2812,8 +2832,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } # endif /* IAMSUID */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "PL_preprocess: cmd=\"%s\"\n", + DEBUG_P(PerlIO_printf(Perl_debug_log, + "PL_preprocess: cmd=\"%s\"\n", SvPVX(cmd))); PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); @@ -2840,8 +2860,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, - BIN_EXP, (int)PERL_REVISION, + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, + BIN_EXP, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION), PL_origargv); Perl_croak(aTHX_ "Can't do setuid\n"); @@ -2797,6 +2797,7 @@ typedef Sighandler_t Sigsave_t; typedef int (CPERLscope(*runops_proc_t)) (pTHX); typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv); +typedef int (CPERLscope(*thrhook_proc_t)) (pTHX); typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX); /* _ (for $_) must be first in the following list (DEFSV requires it) */ @@ -968,6 +968,8 @@ END_EXTERN_C #define PL_sharehook (*Perl_Gsharehook_ptr(NULL)) #undef PL_thr_key #define PL_thr_key (*Perl_Gthr_key_ptr(NULL)) +#undef PL_threadhook +#define PL_threadhook (*Perl_Gthreadhook_ptr(NULL)) #undef PL_unlockhook #define PL_unlockhook (*Perl_Gunlockhook_ptr(NULL)) diff --git a/perlvars.h b/perlvars.h index 51956795d8..b841719dc2 100644 --- a/perlvars.h +++ b/perlvars.h @@ -56,4 +56,5 @@ PERLVARI(Grunops_dbg, runops_proc_t, MEMBER_TO_FPTR(Perl_runops_debug)) PERLVARI(Gsharehook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nosharing)) PERLVARI(Glockhook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nolocking)) PERLVARI(Gunlockhook, share_proc_t, MEMBER_TO_FPTR(Perl_sv_nounlocking)) +PERLVARI(Gthreadhook, thrhook_proc_t, MEMBER_TO_FPTR(Perl_nothreadhook)) diff --git a/pod/perlapi.pod b/pod/perlapi.pod index ad0d6d850c..94f26eb63a 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -576,6 +576,16 @@ method, similar to C<use Foo::Bar VERSION LIST>. =for hackers Found in file op.c +=item nothreadhook + +Stub that provides thread hook for perl_destruct when there are +no threads. + + int nothreadhook() + +=for hackers +Found in file perl.c + =item perl_alloc Allocates a new Perl interpreter. See L<perlembed>. @@ -1004,6 +1004,7 @@ PERL_CALLCONV char * Perl_custom_op_desc(pTHX_ OP* op); PERL_CALLCONV void Perl_sv_nosharing(pTHX_ SV *); PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *); PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *); +PERL_CALLCONV int Perl_nothreadhook(pTHX); END_EXTERN_C |