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

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#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
#include <pthread.h>
#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

typedef struct ithread_s {
    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 detached;	/* are we detached ? */
    int gimme;			/* Context of create */
    SV* init_function;          /* Code to run */
    SV* params;                 /* args to pass function */
#ifdef WIN32
	DWORD	thr;            /* OS's idea if thread id */
	HANDLE handle;          /* OS's waitable handle */
#else
  	pthread_t thr;          /* OS's handle for the thread */
#endif
} ithread;

ithread *threads;

/* Macros to supply the aTHX_ in an embed.h like manner */
#define ithread_join(thread)		Perl_ithread_join(aTHX_ thread)
#define ithread_DESTROY(thread)		Perl_ithread_DESTROY(aTHX_ thread)
#define ithread_CLONE(thread)		Perl_ithread_CLONE(aTHX_ thread)
#define ithread_detach(thread)		Perl_ithread_detach(aTHX_ thread)
#define ithread_tid(thread)		((thread)->tid)

static perl_mutex create_mutex;  /* protects the creation of threads ??? */

I32 tid_counter = 0;
I32 active_threads = 0;
perl_key self_key;

/*
 *  Clear up after thread is done with
 */
void
Perl_ithread_destruct (pTHX_ ithread* thread)
{
	MUTEX_LOCK(&thread->mutex);
	if (thread->count != 0) {
		MUTEX_UNLOCK(&thread->mutex);
		return;
	}
	MUTEX_LOCK(&create_mutex);
	/* Remove from circular list of threads */
	if (thread->next == thread) {
	    /* last one should never get here ? */
	    threads = NULL;
        }
	else {
	    thread->next->prev = thread->prev->next;
	    thread->prev->next = thread->next->prev;
	    if (threads == thread) {
		threads = thread->next;
	    }
	}
	active_threads--;
	MUTEX_UNLOCK(&create_mutex);
	/* Thread is now disowned */
#if 0
        Perl_warn(aTHX_ "destruct %d @ %p by %p",
	          thread->tid,thread->interp,aTHX);
#endif
	if (thread->interp) {
	    dTHXa(thread->interp);
	    PERL_SET_CONTEXT(thread->interp);
	    perl_destruct(thread->interp);
	    perl_free(thread->interp);
	    thread->interp = NULL;
	}
	PERL_SET_CONTEXT(aTHX);
	MUTEX_UNLOCK(&thread->mutex);
}


/* MAGIC (in mg.h sense) hooks */

int
ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
    ithread *thread = (ithread *) mg->mg_ptr;
    SvIVX(sv) = PTR2IV(thread);
    SvIOK_on(sv);
    return 0;
}

int
ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
    ithread *thread = (ithread *) mg->mg_ptr;
    MUTEX_LOCK(&thread->mutex);
    thread->count--;
    MUTEX_UNLOCK(&thread->mutex);
    /* This is safe as it re-checks count */
    Perl_ithread_destruct(aTHX_ thread);
    return 0;
}

int
ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
    ithread *thread = (ithread *) mg->mg_ptr;
    MUTEX_LOCK(&thread->mutex);
    thread->count++;
    MUTEX_UNLOCK(&thread->mutex);
    return 0;
}

MGVTBL ithread_vtbl = {
 ithread_mg_get,	/* get */
 0,			/* set */
 0,			/* len */
 0,			/* clear */
 ithread_mg_free,	/* free */
 0,			/* copy */
 ithread_mg_dup		/* dup */
};


/*
 *	Starts executing the thread. Needs to clean up memory a tad better.
 *      Passed as the C level function to run in the new thread
 */

#ifdef WIN32
THREAD_RET_TYPE
Perl_ithread_run(LPVOID arg) {
#else
void*
Perl_ithread_run(void * arg) {
#endif
	ithread* thread = (ithread*) arg;
	dTHXa(thread->interp);
	PERL_SET_CONTEXT(thread->interp);
	PERL_THREAD_SETSPECIFIC(self_key,thread);

#if 0
	/* Far from clear messing with ->thr child-side is a good idea */
	MUTEX_LOCK(&thread->mutex);
#ifdef WIN32
	thread->thr = GetCurrentThreadId();
#else
	thread->thr = pthread_self();
#endif
 	MUTEX_UNLOCK(&thread->mutex);
#endif

	PL_perl_destruct_level = 2;

	{
		AV* params = (AV*) SvRV(thread->params);
		I32 len = av_len(params)+1;
		int i;
		dSP;
		ENTER;
		SAVETMPS;
		PUSHMARK(SP);
		for(i = 0; i < len; i++) {
		    XPUSHs(av_shift(params));
		}
		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);
		}
		FREETMPS;
		LEAVE;
		SvREFCNT_dec(thread->init_function);
	}

	PerlIO_flush((PerlIO*)NULL);
	MUTEX_LOCK(&thread->mutex);
	if (thread->detached & 1) {
		MUTEX_UNLOCK(&thread->mutex);
		SvREFCNT_dec(thread->params);
		thread->params = Nullsv;
		Perl_ithread_destruct(aTHX_ thread);
	} else {
		thread->detached |= 4;
	  	MUTEX_UNLOCK(&thread->mutex);
   	}
#ifdef WIN32
	return (DWORD)0;
#else
	return 0;
#endif
}

SV *
ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
{
    SV *sv;
    MAGIC *mg;
    if (inc) {
	MUTEX_LOCK(&thread->mutex);
	thread->count++;
	MUTEX_UNLOCK(&thread->mutex);
    }
    if (!obj)
     obj = newSV(0);
    sv = newSVrv(obj,classname);
    sv_setiv(sv,PTR2IV(thread));
    mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
    mg->mg_flags |= MGf_DUP;
    SvREADONLY_on(sv);
    return obj;
}

ithread *
SV_to_ithread(pTHX_ SV *sv)
{
    ithread *thread;
    if (SvROK(sv))
     {
      thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
     }
    else
     {
      PERL_THREAD_GETSPECIFIC(self_key,thread);
     }
    return thread;
}

/*
 * iThread->create(); ( aka iThread->new() )
 * Called in context of parent thread
 */

SV *
Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
{
	ithread*	thread;
	CLONE_PARAMS	clone_param;

	MUTEX_LOCK(&create_mutex);
	thread = PerlMemShared_malloc(sizeof(ithread));
	Zero(thread,1,ithread);
	thread->next = threads;
	thread->prev = threads->prev;
	thread->prev->next = thread;
	/* Set count to 1 immediately in case thread exits before
	 * we return to caller !
	 */
	thread->count = 1;
	MUTEX_INIT(&thread->mutex);
	thread->tid = tid_counter++;
	thread->gimme = GIMME_V;
	thread->detached = (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);

#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
	   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 
            */
            SvREFCNT_dec(PL_endav);
            PL_endav = newAV();
            clone_param.flags = 0;
	    thread->init_function = sv_dup(init_function, &clone_param);
	    if (SvREFCNT(thread->init_function) == 0) {
		SvREFCNT_inc(thread->init_function);
	    }

	    thread->params = sv_dup(params, &clone_param);
	    SvREFCNT_inc(thread->params);
	    SvTEMP_off(thread->init_function);
	    ptr_table_free(PL_ptr_table);
	    PL_ptr_table = NULL;
	}

	PERL_SET_CONTEXT(aTHX);

	/* Start the thread */

#ifdef WIN32

	thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
			(LPVOID)thread, 0, &thread->thr);

#else
	{
	  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;
	    pthread_attr_init(&attr);
	  }
#  ifdef PTHREAD_ATTR_SETDETACHSTATE
            PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
#  endif
#  ifdef THREAD_CREATE_NEEDS_STACK
	    if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
	      croak("panic: pthread_attr_setstacksize failed");
#  endif

#ifdef OLD_PTHREADS_API
	  pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
#else
	  pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
#endif
	}
#endif
	active_threads++;
	MUTEX_UNLOCK(&create_mutex);
	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);
}

/*
 * Joins the thread this code needs to take the returnvalue from the
 * call_sv and send it back
 */

void
Perl_ithread_CLONE(pTHX_ SV *obj)
{
 if (SvROK(obj))
  {
   ithread *thread = SV_to_ithread(aTHX_ obj);
  }
 else
  {
   Perl_warn(aTHX_ "CLONE %_",obj);
  }
}

AV* 
Perl_ithread_join(pTHX_ SV *obj)
{
    ithread *thread = SV_to_ithread(aTHX_ obj);
    MUTEX_LOCK(&thread->mutex);
    if (thread->detached & 1) {
	MUTEX_UNLOCK(&thread->mutex);
	Perl_croak(aTHX_ "Cannot join a detached thread");
    }
    else if (thread->detached & 2) {
	MUTEX_UNLOCK(&thread->mutex);
	Perl_croak(aTHX_ "Thread already joined");
    }
    else {
        AV* retparam;
#ifdef WIN32
	DWORD waitcode;
#else
	void *retval;
#endif
	MUTEX_UNLOCK(&thread->mutex);
#ifdef WIN32
	waitcode = WaitForSingleObject(thread->handle, INFINITE);
#else
	pthread_join(thread->thr,&retval);
#endif
	MUTEX_LOCK(&thread->mutex);
	
	{
	  AV* params = (AV*) SvRV(thread->params);	  
	  CLONE_PARAMS clone_params;
	  clone_params.stashes = newAV();
	  PL_ptr_table = ptr_table_new();
	  retparam = (AV*) sv_dup((SV*)params, &clone_params);
	  SvREFCNT_dec(clone_params.stashes);
	  SvREFCNT_inc(retparam);
	  ptr_table_free(PL_ptr_table);
	  PL_ptr_table = NULL;

	}
	/* sv_dup over the args */
	/* We have finished with it */
	thread->detached |= 2;
	MUTEX_UNLOCK(&thread->mutex);
	sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
	Perl_ithread_destruct(aTHX_ thread);
	return retparam;
    }
    return (AV*)NULL;
}

void
Perl_ithread_detach(pTHX_ ithread *thread)
{
    MUTEX_LOCK(&thread->mutex);
    if (!thread->detached) {
	thread->detached = 1;
#ifdef WIN32
	CloseHandle(thread->handle);
	thread->handle = 0;
#else
	PERL_THREAD_DETACH(thread->thr);
#endif
    }
    MUTEX_UNLOCK(&thread->mutex);
}


void
Perl_ithread_DESTROY(pTHX_ SV *sv)
{
    ithread *thread = SV_to_ithread(aTHX_ sv);
    sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
}


MODULE = threads		PACKAGE = threads	PREFIX = ithread_
PROTOTYPES: DISABLE

void
ithread_new (classname, function_to_call, ...)
char *	classname
SV *	function_to_call
CODE:
{
    AV* params = newAV();
    if (items > 2) {
	int i;
	for(i = 2; i < items ; i++) {
	    av_push(params, ST(i));
	}
    }
    ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
    XSRETURN(1);
}

void
ithread_self(char *classname)
CODE:
{
	ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
	XSRETURN(1);
}

int
ithread_tid(ithread *thread)

void
ithread_join(SV *obj)
PPCODE:
{
  AV* params = Perl_ithread_join(aTHX_ obj);
  int i;
  I32 len = AvFILL(params);
  for (i = 0; i <= len; i++) {
    XPUSHs(av_shift(params));
  }
  SvREFCNT_dec(params);
}


void
ithread_detach(ithread *thread)

void
ithread_DESTROY(SV *thread)

BOOT:
{
	ithread* thread;
	PL_perl_destruct_level = 2;
	PERL_THREAD_ALLOC_SPECIFIC(self_key);
	MUTEX_INIT(&create_mutex);
	MUTEX_LOCK(&create_mutex);
	thread  = PerlMemShared_malloc(sizeof(ithread));
	Zero(thread,1,ithread);
	PL_perl_destruct_level = 2;
	MUTEX_INIT(&thread->mutex);
	threads = thread;
	thread->next = thread;
        thread->prev = thread;
	thread->interp = aTHX;
	thread->count  = 1;  /* imortal */
	thread->tid = tid_counter++;
	active_threads++;
	thread->detached = 1;
#ifdef WIN32
	thread->thr = GetCurrentThreadId();
#else
	thread->thr = pthread_self();
#endif
	PERL_THREAD_SETSPECIFIC(self_key,thread);
	MUTEX_UNLOCK(&create_mutex);
}
Commit	Line	Data
68795e93	1	#define PERL_NO_GET_CONTEXT
	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
	5
	6	#ifdef WIN32
	7	#include <windows.h>
	8	#include <win32thread.h>
	9	#define PERL_THREAD_SETSPECIFIC(k,v) TlsSetValue(k,v)
	10	#define PERL_THREAD_GETSPECIFIC(k,v) v = TlsGetValue(k)
	11	#define PERL_THREAD_ALLOC_SPECIFIC(k) \
	12	STMT_START {\
	13	if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\
	14	PerlIO_printf(PerlIO_stderr(),"panic threads.h: TlsAlloc");\
	15	exit(1);\
	16	}\
	17	} STMT_END
	18	#else
	19	#include <pthread.h>
	20	#include <thread.h>
	21
	22	#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
	23	#ifdef OLD_PTHREADS_API
	24	#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
	25	#define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v)
	26	#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
	27	if(pthread_keycreate(&(k),0)) {\
	28	PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
	29	exit(1);\
	30	}\
	31	} STMT_END
	32	#else
	33	#define PERL_THREAD_DETACH(t) pthread_detach((t))
	34	#define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k)
	35	#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
	36	if(pthread_key_create(&(k),0)) {\
	37	PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
	38	exit(1);\
	39	}\
	40	} STMT_END
	41	#endif
	42	#endif
	43
	44	typedef struct ithread_s {
	45	struct ithread_s next; / next thread in the list */
	46	struct ithread_s prev; / prev thread in the list */
	47	PerlInterpreter interp; / The threads interpreter */
	48	I32 tid; /* threads module's thread id */
	49	perl_mutex mutex; /* mutex for updating things in this struct */
	50	I32 count; /* how many SVs have a reference to us */
	51	signed char detached; /* are we detached ? */
a446a88f	52	int gimme; /* Context of create */
68795e93	53	SV* init_function; /* Code to run */
	54	SV* params; /* args to pass function */
	55	#ifdef WIN32
	56	DWORD thr; /* OS's idea if thread id */
	57	HANDLE handle; /* OS's waitable handle */
	58	#else
	59	pthread_t thr; /* OS's handle for the thread */
	60	#endif
	61	} ithread;
	62
	63	ithread *threads;
	64
	65	/* Macros to supply the aTHX_ in an embed.h like manner */
	66	#define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
	67	#define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
	68	#define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
	69	#define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
	70	#define ithread_tid(thread) ((thread)->tid)
	71
	72	static perl_mutex create_mutex; /* protects the creation of threads ??? */
	73
	74	I32 tid_counter = 0;
149bd5a9	75	I32 active_threads = 0;
68795e93	76	perl_key self_key;
	77
	78	/*
	79	* Clear up after thread is done with
	80	*/
	81	void
	82	Perl_ithread_destruct (pTHX_ ithread* thread)
	83	{
	84	MUTEX_LOCK(&thread->mutex);
68795e93	85	if (thread->count != 0) {
68795e93	86	MUTEX_UNLOCK(&thread->mutex);
d1400e48	87	return;
68795e93	88	}
68795e93	89	MUTEX_LOCK(&create_mutex);
	90	/* Remove from circular list of threads */
	91	if (thread->next == thread) {
	92	/* last one should never get here ? */
	93	threads = NULL;
	94	}
	95	else {
	96	thread->next->prev = thread->prev->next;
	97	thread->prev->next = thread->next->prev;
	98	if (threads == thread) {
	99	threads = thread->next;
	100	}
	101	}
149bd5a9	102	active_threads--;
68795e93	103	MUTEX_UNLOCK(&create_mutex);
68795e93	104	/* Thread is now disowned */
ba14dd9a	105	#if 0
	106	Perl_warn(aTHX_ "destruct %d @ %p by %p",
	107	thread->tid,thread->interp,aTHX);
	108	#endif
68795e93	109	if (thread->interp) {
	110	dTHXa(thread->interp);
	111	PERL_SET_CONTEXT(thread->interp);
	112	perl_destruct(thread->interp);
	113	perl_free(thread->interp);
	114	thread->interp = NULL;
	115	}
	116	PERL_SET_CONTEXT(aTHX);
d1400e48	117	MUTEX_UNLOCK(&thread->mutex);
68795e93	118	}
	119
	120
	121	/* MAGIC (in mg.h sense) hooks */
	122
	123	int
	124	ithread_mg_get(pTHX_ SV sv, MAGIC mg)
	125	{
	126	ithread thread = (ithread ) mg->mg_ptr;
	127	SvIVX(sv) = PTR2IV(thread);
	128	SvIOK_on(sv);
	129	return 0;
	130	}
	131
	132	int
	133	ithread_mg_free(pTHX_ SV sv, MAGIC mg)
	134	{
	135	ithread thread = (ithread ) mg->mg_ptr;
	136	MUTEX_LOCK(&thread->mutex);
68795e93	137	thread->count--;
	138	MUTEX_UNLOCK(&thread->mutex);
	139	/* This is safe as it re-checks count */
	140	Perl_ithread_destruct(aTHX_ thread);
	141	return 0;
	142	}
	143
	144	int
	145	ithread_mg_dup(pTHX_ MAGIC mg, CLONE_PARAMS param)
	146	{
	147	ithread thread = (ithread ) mg->mg_ptr;
	148	MUTEX_LOCK(&thread->mutex);
68795e93	149	thread->count++;
	150	MUTEX_UNLOCK(&thread->mutex);
	151	return 0;
	152	}
	153
	154	MGVTBL ithread_vtbl = {
	155	ithread_mg_get, /* get */
	156	0, /* set */
	157	0, /* len */
	158	0, /* clear */
	159	ithread_mg_free, /* free */
	160	0, /* copy */
	161	ithread_mg_dup /* dup */
	162	};
	163
47ba8780	164
47ba8780	165	/*
b1edfb69	166	* Starts executing the thread. Needs to clean up memory a tad better.
68795e93	167	* Passed as the C level function to run in the new thread
b1edfb69	168	*/
47ba8780	169
47ba8780	170	#ifdef WIN32
68795e93	171	THREAD_RET_TYPE
68795e93	172	Perl_ithread_run(LPVOID arg) {
47ba8780	173	#else
68795e93	174	void*
68795e93	175	Perl_ithread_run(void * arg) {
47ba8780	176	#endif
5b414d21	177	ithread* thread = (ithread*) arg;
47ba8780	178	dTHXa(thread->interp);
47ba8780	179	PERL_SET_CONTEXT(thread->interp);
68795e93	180	PERL_THREAD_SETSPECIFIC(self_key,thread);
47ba8780	181
68795e93	182	#if 0
	183	/* Far from clear messing with ->thr child-side is a good idea */
	184	MUTEX_LOCK(&thread->mutex);
47ba8780	185	#ifdef WIN32
	186	thread->thr = GetCurrentThreadId();
	187	#else
	188	thread->thr = pthread_self();
	189	#endif
68795e93	190	MUTEX_UNLOCK(&thread->mutex);
68795e93	191	#endif
47ba8780	192
47ba8780	193	PL_perl_destruct_level = 2;
4f896ddc	194
47ba8780	195	{
68795e93	196	AV* params = (AV*) SvRV(thread->params);
68795e93	197	I32 len = av_len(params)+1;
47ba8780	198	int i;
47ba8780	199	dSP;
47ba8780	200	ENTER;
	201	SAVETMPS;
	202	PUSHMARK(SP);
68795e93	203	for(i = 0; i < len; i++) {
68795e93	204	XPUSHs(av_shift(params));
47ba8780	205	}
47ba8780	206	PUTBACK;
a446a88f	207	len = call_sv(thread->init_function, thread->gimme\|G_EVAL);
68795e93	208	SPAGAIN;
a446a88f	209	for (i=len-1; i >= 0; i--) {
e1c44605	210	SV *sv = POPs;
e1c44605	211	av_store(params, i, SvREFCNT_inc(sv));
a446a88f	212	}
	213	PUTBACK;
	214	if (SvTRUE(ERRSV)) {
	215	Perl_warn(aTHX_ "Died:%_",ERRSV);
	216	}
47ba8780	217	FREETMPS;
47ba8780	218	LEAVE;
68795e93	219	SvREFCNT_dec(thread->init_function);
47ba8780	220	}
47ba8780	221
fd58862f	222	PerlIO_flush((PerlIO*)NULL);
68795e93	223	MUTEX_LOCK(&thread->mutex);
a446a88f	224	if (thread->detached & 1) {
47ba8780	225	MUTEX_UNLOCK(&thread->mutex);
a446a88f	226	SvREFCNT_dec(thread->params);
a446a88f	227	thread->params = Nullsv;
68795e93	228	Perl_ithread_destruct(aTHX_ thread);
47ba8780	229	} else {
a446a88f	230	thread->detached \|= 4;
47ba8780	231	MUTEX_UNLOCK(&thread->mutex);
	232	}
	233	#ifdef WIN32
	234	return (DWORD)0;
e8f2bb9a	235	#else
e8f2bb9a	236	return 0;
47ba8780	237	#endif
68795e93	238	}
	239
	240	SV *
	241	ithread_to_SV(pTHX_ SV obj, ithread thread, char *classname, bool inc)
	242	{
	243	SV *sv;
	244	MAGIC *mg;
	245	if (inc) {
	246	MUTEX_LOCK(&thread->mutex);
	247	thread->count++;
68795e93	248	MUTEX_UNLOCK(&thread->mutex);
	249	}
	250	if (!obj)
	251	obj = newSV(0);
	252	sv = newSVrv(obj,classname);
	253	sv_setiv(sv,PTR2IV(thread));
	254	mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
	255	mg->mg_flags \|= MGf_DUP;
	256	SvREADONLY_on(sv);
	257	return obj;
	258	}
47ba8780	259
68795e93	260	ithread *
	261	SV_to_ithread(pTHX_ SV *sv)
	262	{
	263	ithread *thread;
	264	if (SvROK(sv))
	265	{
	266	thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
	267	}
	268	else
	269	{
	270	PERL_THREAD_GETSPECIFIC(self_key,thread);
	271	}
	272	return thread;
47ba8780	273	}
47ba8780	274
47ba8780	275	/*
68795e93	276	* iThread->create(); ( aka iThread->new() )
68795e93	277	* Called in context of parent thread
b1edfb69	278	*/
47ba8780	279
68795e93	280	SV *
	281	Perl_ithread_create(pTHX_ SV obj, char classname, SV* init_function, SV* params)
	282	{
	283	ithread* thread;
	284	CLONE_PARAMS clone_param;
	285
	286	MUTEX_LOCK(&create_mutex);
	287	thread = PerlMemShared_malloc(sizeof(ithread));
	288	Zero(thread,1,ithread);
	289	thread->next = threads;
	290	thread->prev = threads->prev;
	291	thread->prev->next = thread;
	292	/* Set count to 1 immediately in case thread exits before
	293	* we return to caller !
	294	*/
	295	thread->count = 1;
	296	MUTEX_INIT(&thread->mutex);
	297	thread->tid = tid_counter++;
a446a88f	298	thread->gimme = GIMME_V;
a446a88f	299	thread->detached = (thread->gimme == G_VOID) ? 1 : 0;
4f896ddc	300
68795e93	301	/* "Clone" our interpreter into the thread's interpreter
	302	* This gives thread access to "static data" and code.
	303	*/
47ba8780	304
68795e93	305	PerlIO_flush((PerlIO*)NULL);
cd8c9bf8	306
47ba8780	307	#ifdef WIN32
68795e93	308	thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE \| CLONEf_CLONE_HOST);
47ba8780	309	#else
68795e93	310	thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
47ba8780	311	#endif
ba14dd9a	312	/* perl_clone leaves us in new interpreter's context.
ba14dd9a	313	As it is tricky to spot implcit aTHX create a new scope
a446a88f	314	with aTHX matching the context for the duration of
ba14dd9a	315	our work for new interpreter.
	316	*/
	317	{
	318	dTHXa(thread->interp);
4e00007d	319	/* Here we remove END blocks since they should only run
	320	in the thread they are created
	321	*/
	322	SvREFCNT_dec(PL_endav);
	323	PL_endav = newAV();
d1400e48	324	clone_param.flags = 0;
ba14dd9a	325	thread->init_function = sv_dup(init_function, &clone_param);
	326	if (SvREFCNT(thread->init_function) == 0) {
	327	SvREFCNT_inc(thread->init_function);
d1400e48	328	}
ba14dd9a	329
	330	thread->params = sv_dup(params, &clone_param);
	331	SvREFCNT_inc(thread->params);
	332	SvTEMP_off(thread->init_function);
	333	ptr_table_free(PL_ptr_table);
	334	PL_ptr_table = NULL;
	335	}
d1400e48	336
68795e93	337	PERL_SET_CONTEXT(aTHX);
47ba8780	338
68795e93	339	/* Start the thread */
47ba8780	340
	341	#ifdef WIN32
	342
68795e93	343	thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
47ba8780	344	(LPVOID)thread, 0, &thread->thr);
47ba8780	345
82c40bf6	346	#else
fa26028c	347	{
	348	static pthread_attr_t attr;
	349	static int attr_inited = 0;
	350	sigset_t fullmask, oldmask;
	351	static int attr_joinable = PTHREAD_CREATE_JOINABLE;
	352	if (!attr_inited) {
	353	attr_inited = 1;
	354	pthread_attr_init(&attr);
	355	}
	356	# ifdef PTHREAD_ATTR_SETDETACHSTATE
	357	PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
	358	# endif
3eb37d38	359	# ifdef THREAD_CREATE_NEEDS_STACK
	360	if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
	361	croak("panic: pthread_attr_setstacksize failed");
	362	# endif
	363
3ad0b7d6	364	#ifdef OLD_PTHREADS_API
68795e93	365	pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
47ba8780	366	#else
68795e93	367	pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
47ba8780	368	#endif
3ad0b7d6	369	}
82c40bf6	370	#endif
149bd5a9	371	active_threads++;
d1400e48	372	MUTEX_UNLOCK(&create_mutex);
68795e93	373	return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
68795e93	374	}
47ba8780	375
68795e93	376	SV*
	377	Perl_ithread_self (pTHX_ SV obj, char Class)
	378	{
	379	ithread *thread;
	380	PERL_THREAD_GETSPECIFIC(self_key,thread);
	381	return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
47ba8780	382	}
	383
	384	/*
e1c44605	385	* Joins the thread this code needs to take the returnvalue from the
68795e93	386	* call_sv and send it back
b1edfb69	387	*/
47ba8780	388
68795e93	389	void
	390	Perl_ithread_CLONE(pTHX_ SV *obj)
	391	{
	392	if (SvROK(obj))
	393	{
	394	ithread *thread = SV_to_ithread(aTHX_ obj);
	395	}
	396	else
	397	{
	398	Perl_warn(aTHX_ "CLONE %_",obj);
	399	}
47ba8780	400	}
47ba8780	401
e1c44605	402	AV*
68795e93	403	Perl_ithread_join(pTHX_ SV *obj)
	404	{
	405	ithread *thread = SV_to_ithread(aTHX_ obj);
	406	MUTEX_LOCK(&thread->mutex);
a446a88f	407	if (thread->detached & 1) {
	408	MUTEX_UNLOCK(&thread->mutex);
	409	Perl_croak(aTHX_ "Cannot join a detached thread");
	410	}
	411	else if (thread->detached & 2) {
	412	MUTEX_UNLOCK(&thread->mutex);
	413	Perl_croak(aTHX_ "Thread already joined");
	414	}
	415	else {
e1c44605	416	AV* retparam;
47ba8780	417	#ifdef WIN32
47ba8780	418	DWORD waitcode;
47ba8780	419	#else
47ba8780	420	void *retval;
47ba8780	421	#endif
47ba8780	422	MUTEX_UNLOCK(&thread->mutex);
68795e93	423	#ifdef WIN32
	424	waitcode = WaitForSingleObject(thread->handle, INFINITE);
	425	#else
	426	pthread_join(thread->thr,&retval);
	427	#endif
47ba8780	428	MUTEX_LOCK(&thread->mutex);
e1c44605	429
	430	{
	431	AV* params = (AV*) SvRV(thread->params);
	432	CLONE_PARAMS clone_params;
3275ba96	433	clone_params.stashes = newAV();
e1c44605	434	PL_ptr_table = ptr_table_new();
e1c44605	435	retparam = (AV) sv_dup((SV)params, &clone_params);
3275ba96	436	SvREFCNT_dec(clone_params.stashes);
e1c44605	437	SvREFCNT_inc(retparam);
	438	ptr_table_free(PL_ptr_table);
	439	PL_ptr_table = NULL;
	440
	441	}
a446a88f	442	/* sv_dup over the args */
	443	/* We have finished with it */
	444	thread->detached \|= 2;
47ba8780	445	MUTEX_UNLOCK(&thread->mutex);
68795e93	446	sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
e1c44605	447	Perl_ithread_destruct(aTHX_ thread);
e1c44605	448	return retparam;
68795e93	449	}
e1c44605	450	return (AV*)NULL;
47ba8780	451	}
47ba8780	452
68795e93	453	void
	454	Perl_ithread_detach(pTHX_ ithread *thread)
	455	{
	456	MUTEX_LOCK(&thread->mutex);
	457	if (!thread->detached) {
	458	thread->detached = 1;
47ba8780	459	#ifdef WIN32
68795e93	460	CloseHandle(thread->handle);
68795e93	461	thread->handle = 0;
47ba8780	462	#else
68795e93	463	PERL_THREAD_DETACH(thread->thr);
47ba8780	464	#endif
68795e93	465	}
	466	MUTEX_UNLOCK(&thread->mutex);
	467	}
47ba8780	468
47ba8780	469
68795e93	470	void
	471	Perl_ithread_DESTROY(pTHX_ SV *sv)
	472	{
	473	ithread *thread = SV_to_ithread(aTHX_ sv);
68795e93	474	sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
68795e93	475	}
8222d950	476
e1c44605	477
e1c44605	478
68795e93	479	MODULE = threads PACKAGE = threads PREFIX = ithread_
68795e93	480	PROTOTYPES: DISABLE
8222d950	481
68795e93	482	void
	483	ithread_new (classname, function_to_call, ...)
	484	char * classname
	485	SV * function_to_call
	486	CODE:
	487	{
	488	AV* params = newAV();
	489	if (items > 2) {
	490	int i;
	491	for(i = 2; i < items ; i++) {
	492	av_push(params, ST(i));
	493	}
	494	}
	495	ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
	496	XSRETURN(1);
	497	}
8222d950	498
68795e93	499	void
	500	ithread_self(char *classname)
	501	CODE:
	502	{
	503	ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
	504	XSRETURN(1);
	505	}
47ba8780	506
47ba8780	507	int
68795e93	508	ithread_tid(ithread *thread)
47ba8780	509
47ba8780	510	void
68795e93	511	ithread_join(SV *obj)
e1c44605	512	PPCODE:
	513	{
	514	AV* params = Perl_ithread_join(aTHX_ obj);
	515	int i;
	516	I32 len = AvFILL(params);
	517	for (i = 0; i <= len; i++) {
	518	XPUSHs(av_shift(params));
	519	}
	520	SvREFCNT_dec(params);
	521	}
	522
47ba8780	523
47ba8780	524	void
68795e93	525	ithread_detach(ithread *thread)
47ba8780	526
47ba8780	527	void
68795e93	528	ithread_DESTROY(SV *thread)
68795e93	529
68795e93	530	BOOT:
	531	{
	532	ithread* thread;
e1c44605	533	PL_perl_destruct_level = 2;
68795e93	534	PERL_THREAD_ALLOC_SPECIFIC(self_key);
	535	MUTEX_INIT(&create_mutex);
	536	MUTEX_LOCK(&create_mutex);
	537	thread = PerlMemShared_malloc(sizeof(ithread));
	538	Zero(thread,1,ithread);
	539	PL_perl_destruct_level = 2;
	540	MUTEX_INIT(&thread->mutex);
	541	threads = thread;
	542	thread->next = thread;
	543	thread->prev = thread;
	544	thread->interp = aTHX;
	545	thread->count = 1; /* imortal */
	546	thread->tid = tid_counter++;
149bd5a9	547	active_threads++;
68795e93	548	thread->detached = 1;
	549	#ifdef WIN32
	550	thread->thr = GetCurrentThreadId();
	551	#else
	552	thread->thr = pthread_self();
	553	#endif
	554	PERL_THREAD_SETSPECIFIC(self_key,thread);
	555	MUTEX_UNLOCK(&create_mutex);
	556	}
	557