X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2Fthreads%2Fthreads.xs;h=83f9e89dfec2bf93d7b0fa76380467e46bdfb3fd;hb=20b634c2cddd73f32cb58e435a5061f5c6e53570;hp=0e1992320cbf30d131805688e7307b3a34d2300f;hpb=953932261b0a9c87e3ae16397b725c36b4590fec;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 0e19923..83f9e89 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -18,7 +18,11 @@ STMT_START {\ }\ } STMT_END #else +#ifdef OS2 +typedef perl_os_thread pthread_t; +#else #include +#endif #include #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) @@ -122,19 +126,32 @@ Perl_ithread_destruct (pTHX_ ithread* thread, const char *why) #endif MUTEX_UNLOCK(&create_destruct_mutex); /* Thread is now disowned */ - if (thread->interp) { + + if(thread->interp) { dTHXa(thread->interp); + ithread* current_thread; PERL_SET_CONTEXT(thread->interp); + PERL_THREAD_GETSPECIFIC(self_key,current_thread); + PERL_THREAD_SETSPECIFIC(self_key,thread); + + + SvREFCNT_dec(thread->params); + + + thread->params = Nullsv; perl_destruct(thread->interp); - perl_free(thread->interp); + perl_free(thread->interp); thread->interp = NULL; + PERL_THREAD_SETSPECIFIC(self_key,current_thread); + } - PERL_SET_CONTEXT(aTHX); MUTEX_UNLOCK(&thread->mutex); MUTEX_DESTROY(&thread->mutex); PerlMemShared_free(thread); + + PERL_SET_CONTEXT(aTHX); } int @@ -143,7 +160,8 @@ 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); + Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", + (IV)active_threads); veto_cleanup = 1; } MUTEX_UNLOCK(&create_destruct_mutex); @@ -198,7 +216,9 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) MUTEX_UNLOCK(&thread->mutex); Perl_ithread_destruct(aTHX_ thread, "no reference"); } - MUTEX_UNLOCK(&thread->mutex); + else { + MUTEX_UNLOCK(&thread->mutex); + } } else { MUTEX_UNLOCK(&thread->mutex); @@ -270,14 +290,14 @@ Perl_ithread_run(void * arg) { } PUTBACK; len = call_sv(thread->init_function, thread->gimme|G_EVAL); + SPAGAIN; for (i=len-1; i >= 0; i--) { SV *sv = POPs; av_store(params, i, SvREFCNT_inc(sv)); } - PUTBACK; if (SvTRUE(ERRSV)) { - Perl_warn(aTHX_ "Died:%_",ERRSV); + Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV); } FREETMPS; LEAVE; @@ -285,10 +305,6 @@ 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); thread->state |= PERL_ITHR_FINISHED; @@ -298,6 +314,11 @@ Perl_ithread_run(void * arg) { } else { MUTEX_UNLOCK(&thread->mutex); } + MUTEX_LOCK(&create_destruct_mutex); + active_threads--; + assert( active_threads >= 0 ); + MUTEX_UNLOCK(&create_destruct_mutex); + #ifdef WIN32 return (DWORD)0; #else @@ -329,13 +350,21 @@ ithread * SV_to_ithread(pTHX_ SV *sv) { ithread *thread; +#ifdef OEMVS + void *ptr; +#endif if (SvROK(sv)) { thread = INT2PTR(ithread*, SvIV(SvRV(sv))); } else { +#ifdef OEMVS + PERL_THREAD_GETSPECIFIC(self_key,ptr); + thread = (ithread *) ptr; +#else PERL_THREAD_GETSPECIFIC(self_key,thread); +#endif } return thread; } @@ -350,7 +379,12 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param { ithread* thread; CLONE_PARAMS clone_param; + ithread* current_thread; + SV** tmps_tmp = PL_tmps_stack; + I32 tmps_ix = PL_tmps_ix; + + PERL_THREAD_GETSPECIFIC(self_key,current_thread); MUTEX_LOCK(&create_destruct_mutex); thread = PerlMemShared_malloc(sizeof(ithread)); Zero(thread,1,ithread); @@ -365,13 +399,18 @@ 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->state = (thread->gimme == G_VOID) ? 1 : 0; /* "Clone" our interpreter into the thread's interpreter * This gives thread access to "static data" and code. */ PerlIO_flush((PerlIO*)NULL); + PERL_THREAD_SETSPECIFIC(self_key,thread); + + SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct + value */ + PL_srand_called = FALSE; /* Set it to false so we can detect + if it gets set during the clone */ #ifdef WIN32 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); @@ -379,12 +418,13 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); #endif /* perl_clone leaves us in new interpreter's context. - As it is tricky to spot implcit aTHX create a new scope + As it is tricky to spot an implicit aTHX, create a new scope with aTHX matching the context for the duration of our work for new interpreter. */ { dTHXa(thread->interp); + /* Here we remove END blocks since they should only run in the thread they are created */ @@ -395,14 +435,48 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param if (SvREFCNT(thread->init_function) == 0) { SvREFCNT_inc(thread->init_function); } + + thread->params = sv_dup(params, &clone_param); SvREFCNT_inc(thread->params); + + + /* The code below checks that anything living on + the tmps stack and has been cloned (so it lives in the + ptr_table) has a refcount higher than 0 + + If the refcount is 0 it means that a something on the + stack/context was holding a reference to it and + since we init_stacks() in perl_clone that won't get + cleaned and we will get a leaked scalar. + The reason it was cloned was that it lived on the + @_ stack. + + Example of this can be found in bugreport 15837 + where calls in the parameter list end up as a temp + + One could argue that this fix should be in perl_clone + */ + + + while (tmps_ix > 0) { + SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); + tmps_ix--; + if (sv && SvREFCNT(sv) == 0) { + SvREFCNT_inc(sv); + SvREFCNT_dec(sv); + } + } + + + SvTEMP_off(thread->init_function); ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; } - + PERL_THREAD_SETSPECIFIC(self_key,current_thread); PERL_SET_CONTEXT(aTHX); /* Start the thread */ @@ -432,6 +506,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param #ifdef OLD_PTHREADS_API pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread); #else + pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM ); pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread); #endif } @@ -440,6 +515,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param active_threads++; MUTEX_UNLOCK(&create_destruct_mutex); sv_2mortal(params); + return ithread_to_SV(aTHX_ obj, thread, classname, FALSE); } @@ -447,7 +523,13 @@ SV* Perl_ithread_self (pTHX_ SV *obj, char* Class) { ithread *thread; +#ifdef OEMVS + void *ptr; + PERL_THREAD_GETSPECIFIC(self_key,ptr); + thread = (ithread *) ptr; +#else PERL_THREAD_GETSPECIFIC(self_key,thread); +#endif return ithread_to_SV(aTHX_ obj, thread, Class, TRUE); } @@ -465,7 +547,7 @@ Perl_ithread_CLONE(pTHX_ SV *obj) } else { - Perl_warn(aTHX_ "CLONE %_",obj); + Perl_warn(aTHX_ "CLONE %" SVf,obj); } } @@ -499,11 +581,35 @@ Perl_ithread_join(pTHX_ SV *obj) /* sv_dup over the args */ { + ithread* current_thread; AV* params = (AV*) SvRV(thread->params); CLONE_PARAMS clone_params; clone_params.stashes = newAV(); + clone_params.flags |= CLONEf_JOIN_IN; PL_ptr_table = ptr_table_new(); + PERL_THREAD_GETSPECIFIC(self_key,current_thread); + PERL_THREAD_SETSPECIFIC(self_key,thread); + +#if 0 + { + I32 len = av_len(params)+1; + I32 i; + for(i = 0; i < len; i++) { + sv_dump(SvRV(AvARRAY(params)[i])); + } + } +#endif retparam = (AV*) sv_dup((SV*)params, &clone_params); +#if 0 + { + I32 len = av_len(retparam)+1; + I32 i; + for(i = 0; i < len; i++) { + sv_dump(SvRV(AvARRAY(retparam)[i])); + } + } +#endif + PERL_THREAD_SETSPECIFIC(self_key,current_thread); SvREFCNT_dec(clone_params.stashes); SvREFCNT_inc(retparam); ptr_table_free(PL_ptr_table); @@ -513,6 +619,7 @@ Perl_ithread_join(pTHX_ SV *obj) /* We have finished with it */ thread->state |= PERL_ITHR_JOINED; MUTEX_UNLOCK(&thread->mutex); + return retparam; } return (AV*)NULL; @@ -550,6 +657,28 @@ CODE: } void +ithread_list(char *classname) +PPCODE: +{ + ithread *curr_thread; + MUTEX_LOCK(&create_destruct_mutex); + curr_thread = threads; + if(curr_thread->tid != 0) + PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE))); + while(curr_thread) { + curr_thread = curr_thread->next; + if(curr_thread == threads) + break; + if(curr_thread->state & PERL_ITHR_DETACHED || + curr_thread->state & PERL_ITHR_JOINED) + continue; + PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE))); + } + MUTEX_UNLOCK(&create_destruct_mutex); +} + + +void ithread_self(char *classname) CODE: { @@ -576,7 +705,12 @@ PPCODE: } void -ithread_yield(ithread *thread) +yield(...) +CODE: +{ + YIELD; +} + void ithread_detach(ithread *thread)