X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2Fthreads%2Fthreads.xs;h=59e3597aadba329939d9a6b195d9518458b39467;hb=65575be5af9681bf691b8b72b0e5b7f432a867bf;hp=393867eefed4d277e8382aa8d42fb23ac84666d5;hpb=62375a601d6dbbc42fa6d70d83d0a60b73d1b86d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index 393867e..59e3597 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -3,6 +3,8 @@
 #include "perl.h"
 #include "XSUB.h"
 
+#ifdef USE_ITHREADS
+
 #ifdef WIN32
 #include <windows.h>
 #include <win32thread.h>
@@ -74,6 +76,7 @@ ithread *threads;
 #define ithread_CLONE(thread)		Perl_ithread_CLONE(aTHX_ thread)
 #define ithread_detach(thread)		Perl_ithread_detach(aTHX_ thread)
 #define ithread_tid(thread)		((thread)->tid)
+#define ithread_yield(thread)		(YIELD);
 
 static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
 
@@ -103,8 +106,8 @@ Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
 	    threads = NULL;
         }
 	else {
-	    thread->next->prev = thread->prev->next;
-	    thread->prev->next = thread->next->prev;
+	    thread->next->prev = thread->prev;
+	    thread->prev->next = thread->next;
 	    if (threads == thread) {
 		threads = thread->next;
 	    }
@@ -122,12 +125,16 @@ Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
 	if (thread->interp) {
 	    dTHXa(thread->interp);
 	    PERL_SET_CONTEXT(thread->interp);
+	    SvREFCNT_dec(thread->params);
+	    thread->params = Nullsv;
 	    perl_destruct(thread->interp);
 	    perl_free(thread->interp);
 	    thread->interp = NULL;
 	}
 	PERL_SET_CONTEXT(aTHX);
 	MUTEX_UNLOCK(&thread->mutex);
+	MUTEX_DESTROY(&thread->mutex);
+        PerlMemShared_free(thread);
 }
 
 int
@@ -136,7 +143,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);
@@ -184,11 +192,16 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
     MUTEX_LOCK(&thread->mutex);
     thread->count--;
     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);
+       if(thread->state & PERL_ITHR_FINISHED &&
+          (thread->state & PERL_ITHR_DETACHED ||
+           thread->state & PERL_ITHR_JOINED))
+       {
+            MUTEX_UNLOCK(&thread->mutex);
+            Perl_ithread_destruct(aTHX_ thread, "no reference");
+       }
+       else {
+	    MUTEX_UNLOCK(&thread->mutex);
+       }    
     }
     else {
 	MUTEX_UNLOCK(&thread->mutex);
@@ -267,7 +280,7 @@ Perl_ithread_run(void * arg) {
 		}
 		PUTBACK;
 		if (SvTRUE(ERRSV)) {
-		    Perl_warn(aTHX_ "Died:%_",ERRSV);
+		    Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
 		}
 		FREETMPS;
 		LEAVE;
@@ -275,21 +288,20 @@ 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;
 
 	if (thread->state & PERL_ITHR_DETACHED) {
 		MUTEX_UNLOCK(&thread->mutex);
-		SvREFCNT_dec(thread->params);
-		thread->params = Nullsv;
 		Perl_ithread_destruct(aTHX_ thread, "detached finish");
 	} 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
@@ -348,6 +360,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 	Zero(thread,1,ithread);
 	thread->next = threads;
 	thread->prev = threads->prev;
+	threads->prev = thread;
 	thread->prev->next = thread;
 	/* Set count to 1 immediately in case thread exits before
 	 * we return to caller !
@@ -356,7 +369,6 @@ 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.
@@ -392,6 +404,7 @@ 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_SET_CONTEXT(aTHX);
@@ -407,7 +420,6 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 	{
 	  static pthread_attr_t attr;
 	  static int attr_inited = 0;
-	  sigset_t fullmask, oldmask;
 	  static int attr_joinable = PTHREAD_CREATE_JOINABLE;
 	  if (!attr_inited) {
 	    attr_inited = 1;
@@ -431,6 +443,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 	known_threads++;
 	active_threads++;
 	MUTEX_UNLOCK(&create_destruct_mutex);
+	sv_2mortal(params);
 	return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
 }
 
@@ -456,7 +469,7 @@ Perl_ithread_CLONE(pTHX_ SV *obj)
   }
  else
   {
-   Perl_warn(aTHX_ "CLONE %_",obj);
+   Perl_warn(aTHX_ "CLONE %" SVf,obj);
   }
 }
 
@@ -504,8 +517,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);
-	Perl_ithread_destruct(aTHX_ thread, "joined");
+    	sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
 	return retparam;
     }
     return (AV*)NULL;
@@ -518,11 +530,13 @@ Perl_ithread_DESTROY(pTHX_ SV *sv)
     sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
 }
 
-
+#endif /* USE_ITHREADS */
 
 MODULE = threads		PACKAGE = threads	PREFIX = ithread_
 PROTOTYPES: DISABLE
 
+#ifdef USE_ITHREADS
+
 void
 ithread_new (classname, function_to_call, ...)
 char *	classname
@@ -533,7 +547,7 @@ CODE:
     if (items > 2) {
 	int i;
 	for(i = 2; i < items ; i++) {
-	    av_push(params, ST(i));
+	    av_push(params, SvREFCNT_inc(ST(i)));
 	}
     }
     ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
@@ -541,6 +555,27 @@ CODE:
 }
 
 void
+ithread_list(char *classname)
+PPCODE:
+{
+  ithread *curr_thread;
+  MUTEX_LOCK(&create_destruct_mutex);
+  curr_thread = threads;
+  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:
 {
@@ -559,11 +594,20 @@ PPCODE:
   int i;
   I32 len = AvFILL(params);
   for (i = 0; i <= len; i++) {
-    XPUSHs(av_shift(params));
+    SV* tmp = av_shift(params);
+    XPUSHs(tmp);
+    sv_2mortal(tmp);
   }
   SvREFCNT_dec(params);
 }
 
+void
+yield(...)
+CODE:
+{
+    YIELD;
+}
+	
 
 void
 ithread_detach(ithread *thread)
@@ -571,8 +615,11 @@ ithread_detach(ithread *thread)
 void
 ithread_DESTROY(SV *thread)
 
+#endif /* USE_ITHREADS */
+
 BOOT:
 {
+#ifdef USE_ITHREADS
 	ithread* thread;
 	PL_perl_destruct_level = 2;
 	PERL_THREAD_ALLOC_SPECIFIC(self_key);
@@ -600,5 +647,6 @@ BOOT:
 
 	PERL_THREAD_SETSPECIFIC(self_key,thread);
 	MUTEX_UNLOCK(&create_destruct_mutex);
+#endif /* USE_ITHREADS */
 }