Integrate from maintperl:

[p5sagit/p5-mst-13.2.git] / ext / threads / threads.xs

diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index eea6d65..205c889 100755 (executable)
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -91,6 +91,7 @@ perl_key self_key;
 void
 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
 {
+        PerlInterpreter* destroyperl = NULL;        
        MUTEX_LOCK(&thread->mutex);
        if (!thread->next) {
            Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
@@ -127,14 +128,22 @@ Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
            PERL_SET_CONTEXT(thread->interp);
            SvREFCNT_dec(thread->params);
            thread->params = Nullsv;
-           perl_destruct(thread->interp);
-           perl_free(thread->interp);
+           destroyperl = thread->interp;
            thread->interp = NULL;
        }
-       PERL_SET_CONTEXT(aTHX);
        MUTEX_UNLOCK(&thread->mutex);
        MUTEX_DESTROY(&thread->mutex);
         PerlMemShared_free(thread);
+       if(destroyperl) {
+           ithread*        current_thread;
+           PERL_THREAD_GETSPECIFIC(self_key,current_thread);
+           PERL_THREAD_SETSPECIFIC(self_key,thread);
+           perl_destruct(destroyperl);
+            perl_free(destroyperl);
+           PERL_THREAD_SETSPECIFIC(self_key,current_thread);
+
+       }
+       PERL_SET_CONTEXT(aTHX);
 }
 
 int
@@ -143,7 +152,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 " other threads were still running",
+                                               (IV)active_threads);
        veto_cleanup = 1;
     }
     MUTEX_UNLOCK(&create_destruct_mutex);
@@ -272,14 +282,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;
@@ -287,10 +297,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;
 
@@ -300,6 +306,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
@@ -352,7 +363,8 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 {
        ithread*        thread;
        CLONE_PARAMS    clone_param;
-
+       ithread*        current_thread;
+       PERL_THREAD_GETSPECIFIC(self_key,current_thread);
        MUTEX_LOCK(&create_destruct_mutex);
        thread = PerlMemShared_malloc(sizeof(ithread));
        Zero(thread,1,ithread);
@@ -367,21 +379,20 @@ 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);
 #ifdef WIN32
        thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
 #else
        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.
         */
@@ -403,8 +414,9 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
            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 */
@@ -467,7 +479,7 @@ Perl_ithread_CLONE(pTHX_ SV *obj)
   }
  else
   {
-   Perl_warn(aTHX_ "CLONE %_",obj);
+   Perl_warn(aTHX_ "CLONE %" SVf,obj);
   }
 }
 
@@ -501,11 +513,34 @@ 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);
+
+         {
+           I32 len = av_len(params)+1;
+           I32 i;
+           for(i = 0; i < len; i++) {
+             //              sv_dump(SvRV(AvARRAY(params)[i]));
+           }
+         }
+
          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);
@@ -515,6 +550,7 @@ Perl_ithread_join(pTHX_ SV *obj)
        /* We have finished with it */
        thread->state |= PERL_ITHR_JOINED;
        MUTEX_UNLOCK(&thread->mutex);
+       sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
        return retparam;
     }
     return (AV*)NULL;
@@ -552,6 +588,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:
 {
@@ -578,7 +636,12 @@ PPCODE:
 }
 
 void
-ithread_yield(ithread *thread)
+yield(...)
+CODE:
+{
+    YIELD;
+}
+       
 
 void
 ithread_detach(ithread *thread)