X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2Fthreads%2Fthreads.xs;h=48530fea617e346fda46a87b9e539e019c9870fa;hb=87c9b3a674e8d668946befbd197e1e7dcbafd7e6;hp=eea6d652ad20300d4077839fadf1996714c29a52;hpb=1ea20f421a49b3c1ecb2a2fcef2f8a40d21ccdfc;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index eea6d65..48530fe 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -5,44 +5,28 @@
 
 #ifdef USE_ITHREADS
 
+
 #ifdef WIN32
 #include <windows.h>
 #include <win32thread.h>
-#define PERL_THREAD_SETSPECIFIC(k,v) TlsSetValue(k,v)
-#define PERL_THREAD_GETSPECIFIC(k,v) v = TlsGetValue(k)
-#define PERL_THREAD_ALLOC_SPECIFIC(k) \
-STMT_START {\
-  if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\
-    PerlIO_printf(PerlIO_stderr(),"panic threads.h: TlsAlloc");\
-    exit(1);\
-  }\
-} STMT_END
+#else
+#ifdef OS2
+typedef perl_os_thread pthread_t;
 #else
 #include <pthread.h>
+#endif
 #include <thread.h>
-
 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
 #ifdef OLD_PTHREADS_API
 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
-#define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v)
-#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
-  if(pthread_keycreate(&(k),0)) {\
-    PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
-    exit(1);\
-  }\
-} STMT_END
 #else
 #define PERL_THREAD_DETACH(t) pthread_detach((t))
-#define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k)
-#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
-  if(pthread_key_create(&(k),0)) {\
-    PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
-    exit(1);\
-  }\
-} STMT_END
-#endif
+#endif  /* OLD_PTHREADS_API */
 #endif
 
+
+
+
 /* Values for 'state' member */
 #define PERL_ITHR_JOINABLE		0
 #define PERL_ITHR_DETACHED		1
@@ -50,16 +34,16 @@ STMT_START {\
 #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 */
+    struct ithread_s *next;	/* Next thread in the list */
+    struct ithread_s *prev;	/* Prev thread in the list */
     PerlInterpreter *interp;	/* The threads interpreter */
-    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 state;		/* are we detached ? */
+    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 state;		/* Are we detached ? */
     int gimme;			/* Context of create */
     SV* init_function;          /* Code to run */
-    SV* params;                 /* args to pass function */
+    SV* params;                 /* Args to pass function */
 #ifdef WIN32
 	DWORD	thr;            /* OS's idea if thread id */
 	HANDLE handle;          /* OS's waitable handle */
@@ -83,7 +67,25 @@ static perl_mutex create_destruct_mutex;  /* protects the creation and destructi
 I32 tid_counter = 0;
 I32 known_threads = 0;
 I32 active_threads = 0;
-perl_key self_key;
+
+
+void Perl_ithread_set (pTHX_ ithread* thread)
+{
+  SV* thread_sv = newSViv(PTR2IV(thread));
+  if(!hv_store(PL_modglobal, "threads::self", 12, thread_sv,0)) {
+    croak("%s\n","Internal error, couldn't set TLS");
+  }
+}
+
+ithread* Perl_ithread_get (pTHX) {
+  SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
+  if(!thread_sv) {
+    croak("%s\n","Internal error, couldn't get TLS");
+  }
+  return INT2PTR(ithread*,SvIV(*thread_sv));
+}
+
+
 
 /*
  *  Clear up after thread is done with
@@ -122,19 +124,34 @@ 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;
+#ifdef OEMVS
+	    void *ptr;
+#endif
 	    PERL_SET_CONTEXT(thread->interp);
+	    current_thread = Perl_ithread_get(aTHX);
+	    Perl_ithread_set(aTHX_ thread);
+
+
+
+	    
 	    SvREFCNT_dec(thread->params);
+
+
+
 	    thread->params = Nullsv;
 	    perl_destruct(thread->interp);
-	    perl_free(thread->interp);
+            perl_free(thread->interp);
 	    thread->interp = NULL;
 	}
-	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);
@@ -244,7 +262,7 @@ Perl_ithread_run(void * arg) {
 	ithread* thread = (ithread*) arg;
 	dTHXa(thread->interp);
 	PERL_SET_CONTEXT(thread->interp);
-	PERL_THREAD_SETSPECIFIC(self_key,thread);
+	Perl_ithread_set(aTHX_ thread);
 
 #if 0
 	/* Far from clear messing with ->thr child-side is a good idea */
@@ -272,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;
@@ -287,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;
 
@@ -300,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
@@ -330,20 +349,18 @@ ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
 ithread *
 SV_to_ithread(pTHX_ SV *sv)
 {
-    ithread *thread;
     if (SvROK(sv))
      {
-      thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
+      return INT2PTR(ithread*, SvIV(SvRV(sv)));
      }
     else
      {
-      PERL_THREAD_GETSPECIFIC(self_key,thread);
+      return Perl_ithread_get(aTHX);
      }
-    return thread;
 }
 
 /*
- * iThread->create(); ( aka iThread->new() )
+ * ithread->create(); ( aka ithread->new() )
  * Called in context of parent thread
  */
 
@@ -352,6 +369,11 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 {
 	ithread*	thread;
 	CLONE_PARAMS	clone_param;
+	ithread*        current_thread = Perl_ithread_get(aTHX);
+
+	SV**            tmps_tmp = PL_tmps_stack;
+	I32             tmps_ix  = PL_tmps_ix;
+
 
 	MUTEX_LOCK(&create_destruct_mutex);
 	thread = PerlMemShared_malloc(sizeof(ithread));
@@ -367,13 +389,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_ithread_set(aTHX_ 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);
@@ -381,12 +408,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
             */
@@ -397,14 +425,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_ithread_set(aTHX_ current_thread);
 	PERL_SET_CONTEXT(aTHX);
 
 	/* Start the thread */
@@ -428,12 +490,15 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 #  endif
 #  ifdef THREAD_CREATE_NEEDS_STACK
 	    if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
-	      croak("panic: pthread_attr_setstacksize failed");
+	      Perl_croak(aTHX_ "panic: pthread_attr_setstacksize failed");
 #  endif
 
 #ifdef OLD_PTHREADS_API
 	  pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
 #else
+#  if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
+	  pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
+#  endif
 	  pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
 #endif
 	}
@@ -442,15 +507,19 @@ 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);
 }
 
 SV*
 Perl_ithread_self (pTHX_ SV *obj, char* Class)
 {
-    ithread *thread;
-    PERL_THREAD_GETSPECIFIC(self_key,thread);
-    return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
+   ithread *thread = Perl_ithread_get(aTHX);
+   if (thread)
+	return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
+   else
+	Perl_croak(aTHX_ "panic: cannot find thread data");
+   return NULL; /* silence compiler warning */
 }
 
 /*
@@ -467,7 +536,7 @@ Perl_ithread_CLONE(pTHX_ SV *obj)
   }
  else
   {
-   Perl_warn(aTHX_ "CLONE %_",obj);
+   Perl_warn(aTHX_ "CLONE %" SVf,obj);
   }
 }
 
@@ -501,20 +570,50 @@ Perl_ithread_join(pTHX_ SV *obj)
 	
 	/* sv_dup over the args */
 	{
+	  ithread*        current_thread;
 	  AV* params = (AV*) SvRV(thread->params);	
+	  PerlInterpreter *other_perl = thread->interp;
 	  CLONE_PARAMS clone_params;
 	  clone_params.stashes = newAV();
+	  clone_params.flags |= CLONEf_JOIN_IN;
 	  PL_ptr_table = ptr_table_new();
+	  current_thread = Perl_ithread_get(aTHX);
+	  Perl_ithread_set(aTHX_ thread);
+	  /* ensure 'meaningful' addresses retain their meaning */
+	  ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
+	  ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
+	  ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
+
+#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_ithread_set(aTHX_ current_thread);
 	  SvREFCNT_dec(clone_params.stashes);
 	  SvREFCNT_inc(retparam);
 	  ptr_table_free(PL_ptr_table);
 	  PL_ptr_table = NULL;
 
 	}
-	/* We have finished with it */
+	/* We are finished with it */
 	thread->state |= PERL_ITHR_JOINED;
 	MUTEX_UNLOCK(&thread->mutex);
+    	
 	return retparam;
     }
     return (AV*)NULL;
@@ -552,6 +651,28 @@ CODE:
 }
 
 void
+ithread_list(char *classname)
+PPCODE:
+{
+  ithread *curr_thread;
+  MUTEX_LOCK(&create_destruct_mutex);
+  curr_thread = threads;
+  if(curr_thread->tid != 0)	
+    XPUSHs( 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;
+     XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
+  }	
+  MUTEX_UNLOCK(&create_destruct_mutex);
+}
+
+
+void
 ithread_self(char *classname)
 CODE:
 {
@@ -578,7 +699,12 @@ PPCODE:
 }
 
 void
-ithread_yield(ithread *thread)
+yield(...)
+CODE:
+{
+    YIELD;
+}
+	
 
 void
 ithread_detach(ithread *thread)
@@ -593,7 +719,6 @@ BOOT:
 #ifdef USE_ITHREADS
 	ithread* thread;
 	PL_perl_destruct_level = 2;
-	PERL_THREAD_ALLOC_SPECIFIC(self_key);
 	MUTEX_INIT(&create_destruct_mutex);
 	MUTEX_LOCK(&create_destruct_mutex);
 	PL_threadhook = &Perl_ithread_hook;
@@ -605,18 +730,18 @@ BOOT:
 	thread->next = thread;
         thread->prev = thread;
 	thread->interp = aTHX;
-	thread->count  = 1;  /* imortal */
+	thread->count  = 1;  /* Immortal. */
 	thread->tid = tid_counter++;
 	known_threads++;
 	active_threads++;
-	thread->state = 1;
+	thread->state = PERL_ITHR_DETACHED;
 #ifdef WIN32
 	thread->thr = GetCurrentThreadId();
 #else
 	thread->thr = pthread_self();
 #endif
 
-	PERL_THREAD_SETSPECIFIC(self_key,thread);
+	Perl_ithread_set(aTHX_ thread);
 	MUTEX_UNLOCK(&create_destruct_mutex);
 #endif /* USE_ITHREADS */
 }