X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2Fthreads%2Fthreads.xs;h=40bd2d1436fb85d64634f256c95d54b043ac9976;hb=28f0d0ec424c9050a6c7d38541d2e6b5e66fb97c;hp=4d9ef4cf003f24db31b26b31db2910a188c08653;hpb=f2e0bb91ca7c0e6f975c2a54cb50ff00d953561c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 4d9ef4c..40bd2d1 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -2,6 +2,11 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +/* Workaround for XSUB.h bug under WIN32 */ +#ifdef WIN32 +# undef setjmp +# define setjmp(x) _setjmp(x) +#endif #ifdef HAS_PPPORT_H # define NEED_PL_signals # define NEED_newRV_noinc @@ -81,7 +86,9 @@ static ithread *threads; static perl_mutex create_destruct_mutex; static UV tid_counter = 0; -static IV active_threads = 0; +static IV joinable_threads = 0; +static IV running_threads = 0; +static IV detached_threads = 0; #ifdef THREAD_CREATE_NEEDS_STACK static IV default_stack_size = THREAD_CREATE_NEEDS_STACK; #else @@ -115,8 +122,8 @@ S_ithread_clear(pTHX_ ithread *thread) { PerlInterpreter *interp; - assert(thread->state & PERL_ITHR_FINISHED && - thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)); + assert((thread->state & PERL_ITHR_FINISHED) && + (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))); interp = thread->interp; if (interp) { @@ -154,11 +161,11 @@ S_ithread_destruct(pTHX_ ithread *thread) return; } - MUTEX_LOCK(&create_destruct_mutex); /* Main thread (0) is immortal and should never get here */ assert(thread->tid != 0); /* Remove from circular list of threads */ + MUTEX_LOCK(&create_destruct_mutex); thread->next->prev = thread->prev; thread->prev->next = thread->next; thread->next = NULL; @@ -194,9 +201,17 @@ Perl_ithread_hook(pTHX) { int veto_cleanup = 0; MUTEX_LOCK(&create_destruct_mutex); - if ((aTHX == PL_curinterp) && (active_threads != 1)) { + if ((aTHX == PL_curinterp) && + (running_threads || joinable_threads)) + { if (ckWARN_d(WARN_THREADS)) { - Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", active_threads); + Perl_warn(aTHX_ "Perl exited with active threads:\n\t%" + IVdf " running and unjoined\n\t%" + IVdf " finished and unjoined\n\t%" + IVdf " running and detached\n", + running_threads, + joinable_threads, + detached_threads); } veto_cleanup = 1; } @@ -265,7 +280,7 @@ good_stack_size(pTHX_ IV stack_size) #ifdef PTHREAD_STACK_MIN /* Can't use less than minimum */ if (stack_size < PTHREAD_STACK_MIN) { - if (ckWARN_d(WARN_THREADS)) { + if (ckWARN(WARN_THREADS)) { Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN); } return (PTHREAD_STACK_MIN); @@ -345,6 +360,10 @@ S_ithread_run(void * arg) AV *params = (AV *)SvRV(thread->params); int len = (int)av_len(params)+1; int ii; + int jmp_rc = 0; + I32 oldscope; + + dJMPENV; dSP; ENTER; @@ -357,24 +376,44 @@ S_ithread_run(void * arg) } PUTBACK; - /* Run the specified function */ - len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); + oldscope = PL_scopestack_ix; + JMPENV_PUSH(jmp_rc); + if (jmp_rc == 0) { + /* Run the specified function */ + len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); + } else if (jmp_rc == 2) { + while (PL_scopestack_ix > oldscope) { + LEAVE; + } + } + JMPENV_POP; /* Remove args from stack and put back in params array */ SPAGAIN; for (ii=len-1; ii >= 0; ii--) { SV *sv = POPs; - av_store(params, ii, SvREFCNT_inc(sv)); + if (jmp_rc == 0) { + av_store(params, ii, SvREFCNT_inc(sv)); + } } + FREETMPS; + LEAVE; + /* Check for failure */ if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) { - Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV); + oldscope = PL_scopestack_ix; + JMPENV_PUSH(jmp_rc); + if (jmp_rc == 0) { + Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV); + } else if (jmp_rc == 2) { + while (PL_scopestack_ix > oldscope) { + LEAVE; + } + } + JMPENV_POP; } - FREETMPS; - LEAVE; - /* Release function ref */ SvREFCNT_dec(thread->init_function); thread->init_function = Nullsv; @@ -389,12 +428,17 @@ S_ithread_run(void * arg) cleanup = (thread->state & PERL_ITHR_DETACHED); MUTEX_UNLOCK(&thread->mutex); - if (cleanup) + if (cleanup) { + MUTEX_LOCK(&create_destruct_mutex); + detached_threads--; + MUTEX_UNLOCK(&create_destruct_mutex); S_ithread_destruct(aTHX_ thread); - - MUTEX_LOCK(&create_destruct_mutex); - active_threads--; - MUTEX_UNLOCK(&create_destruct_mutex); + } else { + MUTEX_LOCK(&create_destruct_mutex); + running_threads--; + joinable_threads++; + MUTEX_UNLOCK(&create_destruct_mutex); + } #ifdef WIN32 return ((DWORD)0); @@ -451,6 +495,7 @@ S_ithread_create( char *classname, SV *init_function, IV stack_size, + int gimme, SV *params) { ithread *thread; @@ -489,7 +534,7 @@ S_ithread_create( MUTEX_INIT(&thread->mutex); thread->tid = tid_counter++; thread->stack_size = good_stack_size(aTHX_ stack_size); - thread->gimme = GIMME_V; + thread->gimme = gimme; /* "Clone" our interpreter into the thread's interpreter. * This gives thread access to "static data" and code. @@ -619,11 +664,14 @@ S_ithread_create( /* Try to get thread's actual stack size */ { size_t stacksize; - if (! pthread_attr_getstacksize(&attr, &stacksize)) { - if (stacksize) { +#ifdef HPUX1020 + stacksize = pthread_attr_getstacksize(attr); +#else + if (! pthread_attr_getstacksize(&attr, &stacksize)) +#endif + if (stacksize > 0) { thread->stack_size = (IV)stacksize; } - } } # endif } @@ -649,7 +697,7 @@ S_ithread_create( return (&PL_sv_undef); } - active_threads++; + running_threads++; MUTEX_UNLOCK(&create_destruct_mutex); sv_2mortal(params); @@ -674,6 +722,8 @@ ithread_create(...) AV *params; HV *specs; IV stack_size; + int context; + char *str; int idx; int ii; CODE: @@ -702,6 +752,7 @@ ithread_create(...) function_to_call = ST(idx+1); + context = -1; if (specs) { /* stack_size */ if (hv_exists(specs, "stack", 5)) { @@ -711,6 +762,44 @@ ithread_create(...) } else if (hv_exists(specs, "stack_size", 10)) { stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0)); } + + /* context */ + if (hv_exists(specs, "context", 7)) { + str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0)); + switch (*str) { + case 'a': + case 'A': + context = G_ARRAY; + break; + case 's': + case 'S': + context = G_SCALAR; + break; + case 'v': + case 'V': + context = G_VOID; + break; + default: + Perl_croak(aTHX_ "Invalid context: %s", str); + } + } else if (hv_exists(specs, "array", 5)) { + if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) { + context = G_ARRAY; + } + } else if (hv_exists(specs, "scalar", 6)) { + if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) { + context = G_SCALAR; + } + } else if (hv_exists(specs, "void", 4)) { + if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) { + context = G_VOID; + } + } + } + if (context == -1) { + context = GIMME_V; /* Implicit context */ + } else { + context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID))); } /* Function args */ @@ -726,6 +815,7 @@ ithread_create(...) classname, function_to_call, stack_size, + context, newRV_noinc((SV*)params))); /* XSRETURN(1); - implied */ @@ -737,15 +827,21 @@ ithread_list(...) ithread *thread; int list_context; IV count = 0; + int want_running; PPCODE: /* Class method only */ if (SvROK(ST(0))) - Perl_croak(aTHX_ "Usage: threads->list()"); + Perl_croak(aTHX_ "Usage: threads->list(...)"); classname = (char *)SvPV_nolen(ST(0)); /* Calling context */ list_context = (GIMME_V == G_ARRAY); + /* Running or joinable parameter */ + if (items > 1) { + want_running = SvTRUE(ST(1)); + } + /* Walk through threads list */ MUTEX_LOCK(&create_destruct_mutex); for (thread = threads->next; @@ -756,6 +852,20 @@ ithread_list(...) if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { continue; } + + /* Filter per parameter */ + if (items > 1) { + if (want_running) { + if (thread->state & PERL_ITHR_FINISHED) { + continue; /* Not running */ + } + } else { + if (! (thread->state & PERL_ITHR_FINISHED)) { + continue; /* Still running - not joinable yet */ + } + } + } + /* Push object on stack if list context */ if (list_context) { XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); @@ -868,6 +978,10 @@ ithread_join(...) S_ithread_clear(aTHX_ thread); MUTEX_UNLOCK(&thread->mutex); + MUTEX_LOCK(&create_destruct_mutex); + joinable_threads--; + MUTEX_UNLOCK(&create_destruct_mutex); + /* If no return values, then just return */ if (! params) { XSRETURN_UNDEF; @@ -921,8 +1035,18 @@ ithread_detach(...) cleanup = (thread->state & PERL_ITHR_FINISHED); MUTEX_UNLOCK(&thread->mutex); - if (cleanup) + MUTEX_LOCK(&create_destruct_mutex); + if (cleanup) { + joinable_threads--; + } else { + running_threads--; + detached_threads++; + } + MUTEX_UNLOCK(&create_destruct_mutex); + + if (cleanup) { S_ithread_destruct(aTHX_ thread); + } void @@ -934,15 +1058,12 @@ ithread_kill(...) CODE: /* Must have safe signals */ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) - Perl_croak(aTHX_ "Cannot signal other threads without safe signals"); + Perl_croak(aTHX_ "Cannot signal threads without safe signals"); /* Object method only */ if (! sv_isobject(ST(0))) Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')"); - /* Get thread */ - thread = SV_to_ithread(aTHX_ ST(0)); - /* Get signal */ sig_name = SvPV_nolen(ST(1)); if (isALPHA(*sig_name)) { @@ -954,11 +1075,14 @@ ithread_kill(...) signal = SvIV(ST(1)); /* Set the signal for the thread */ + thread = SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); { dTHXa(thread->interp); PL_psig_pend[signal]++; PL_sig_pending = 1; } + MUTEX_UNLOCK(&thread->mutex); /* Return the thread to allow for method chaining */ ST(0) = ST(0); @@ -1081,6 +1205,66 @@ ithread_set_stack_size(...) XST_mIV(0, old_size); /* XSRETURN(1); - implied */ + +void +ithread_is_running(...) + PREINIT: + ithread *thread; + CODE: + /* Object method only */ + if (! sv_isobject(ST(0))) + Perl_croak(aTHX_ "Usage: $thr->is_running()"); + + thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&thread->mutex); + ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + + +void +ithread_is_detached(...) + PREINIT: + ithread *thread; + CODE: + thread = SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + + +void +ithread_is_joinable(...) + PREINIT: + ithread *thread; + CODE: + /* Object method only */ + if (! sv_isobject(ST(0))) + Perl_croak(aTHX_ "Usage: $thr->is_joinable()"); + + thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&thread->mutex); + ST(0) = ((thread->state & PERL_ITHR_FINISHED) && + ! (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) + ? &PL_sv_yes : &PL_sv_no; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + + +void +ithread_wantarray(...) + PREINIT: + ithread *thread; + CODE: + thread = SV_to_ithread(aTHX_ ST(0)); + MUTEX_LOCK(&thread->mutex); + ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes : + (thread->gimme & G_VOID) ? &PL_sv_undef + /* G_SCALAR */ : &PL_sv_no; + MUTEX_UNLOCK(&thread->mutex); + /* XSRETURN(1); - implied */ + #endif /* USE_ITHREADS */ @@ -1107,7 +1291,6 @@ BOOT: } Zero(thread, 1, ithread); - PL_perl_destruct_level = 2; MUTEX_INIT(&thread->mutex); thread->tid = tid_counter++; /* Thread 0 */ @@ -1128,8 +1311,6 @@ BOOT: thread->thr = pthread_self(); # endif - active_threads++; - S_ithread_set(aTHX_ thread); MUTEX_UNLOCK(&create_destruct_mutex); #endif /* USE_ITHREADS */