[p5sagit/p5-mst-13.2.git] / Thread.xs

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

static void *
threadstart(arg)
void *arg;
{
    Thread thr = (Thread) arg;
    LOGOP myop;
    dSP;
    I32 oldmark = TOPMARK;
    I32 oldscope = scopestack_ix;
    I32 retval;
    AV *returnav = newAV();
    int i;
    
    /*
     * Wait until our creator releases us. If we didn't do this, then
     * it would be potentially possible for out thread to carry on and
     * do stuff before our creator fills in our "self" field. For example,
     * if we went and created another thread which tried to pthread_join
     * with us, then we'd be in a mess.
     */
    MUTEX_LOCK(threadstart_mutexp);
    MUTEX_UNLOCK(threadstart_mutexp);
    MUTEX_DESTROY(threadstart_mutexp);	/* don't need it any more */
    Safefree(threadstart_mutexp);

    DEBUG_L(fprintf(stderr, "new thread 0x%lx starting at %s\n",
		    (unsigned long) thr, SvPEEK(TOPs)));
    /*
     * It's safe to wait until now to set the thread-specific pointer
     * from our pthread_t structure to our struct thread, since we're
     * the only thread who can get at it anyway.
     */
    if (pthread_setspecific(thr_key, (void *) thr))
	croak("panic: pthread_setspecific");

    switch (Sigsetjmp(top_env,1)) {
      case 3:
        fprintf(stderr, "panic: top_env\n");
	/* fall through */
      case 1:
#ifdef VMS
        statusvalue = 255;
#else
        statusvalue = 1;
#endif
	/* fall through */
      case 2:
	av_store(returnav, 0, newSViv(statusvalue));
	goto finishoff;
    }

    /* Now duplicate most of perl_call_sv but with a few twists */
    op = (OP*)&myop;
    Zero(op, 1, LOGOP);
    myop.op_flags = OPf_STACKED;
    myop.op_next = Nullop;
    myop.op_flags |= OPf_KNOW;
    myop.op_flags |= OPf_LIST;
    op = pp_entersub(ARGS);
    if (op)
	runops();
    SPAGAIN;
    retval = sp - (stack_base + oldmark);
    sp = stack_base + oldmark + 1;
    av_store(returnav, 0, newSVpv("", 0));
    for (i = 1; i <= retval; i++, sp++)
	sv_setsv(*av_fetch(returnav, i, TRUE), SvREFCNT_inc(*sp));
    
  finishoff:
    SvREFCNT_dec(stack);
    SvREFCNT_dec(cvcache);
    Safefree(markstack);
    Safefree(scopestack);
    Safefree(savestack);
    Safefree(retstack);
    Safefree(cxstack);
    Safefree(tmps_stack);

    if (ThrSTATE(thr) == THR_DETACHED) {
	SvREFCNT_dec(returnav);
	ThrSETSTATE(thr, THR_DEAD);
    }
    return (void *) returnav;	/* Available for anyone to join with us */
				/* unless we are detached in which case */
				/* noone will see the value anyway. */
}

Thread
newthread(startsv, initargs)
SV *startsv;
AV *initargs;
{
    dTHR;
    dSP;
    Thread savethread;
    int i;
    
    savethread = thr;
    New(53, thr, 1, struct thread);
    init_stacks(ARGS);
    SPAGAIN;
    defstash = savethread->Tdefstash;	/* XXX maybe these should */
    curstash = savethread->Tcurstash;	/* always be set to main? */
    mainstack = stack;
    /* top_env? */
    /* runlevel */
    cvcache = newHV();
    ThrSETSTATE(thr, THR_NORMAL);

    /* The following pushes the arg list and startsv onto the *new* stack */
    PUSHMARK(sp);
    /* Could easily speed up the following greatly */
    for (i = 0; i <= AvFILL(initargs); i++)
	XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
    XPUSHs(SvREFCNT_inc(startsv));
    PUTBACK;

    New(53, threadstart_mutexp, 1, perl_mutex);
    /* On your marks... */
    MUTEX_INIT(threadstart_mutexp);
    MUTEX_LOCK(threadstart_mutexp);
    /* Get set...
     * Increment the global thread count. It is decremented
     * by the destructor for the thread specific key thr_key.
     */
    MUTEX_LOCK(&nthreads_mutex);
    nthreads++;
    MUTEX_UNLOCK(&nthreads_mutex);
    if (pthread_create(&self, NULL, threadstart, (void*) thr))
	return NULL;	/* XXX should clean up first */
    /* Go */
    MUTEX_UNLOCK(threadstart_mutexp);
    return thr;
}

static SV *
fast(sv)
SV *sv;
{
    HV *hvp;
    GV *gvp;
    CV *cv = sv_2cv(sv, &hvp, &gvp, FALSE);

    if (!cv)
	croak("Not a CODE reference");
    if (CvCONDP(cv)) {
	COND_DESTROY(CvCONDP(cv));
	Safefree(CvCONDP(cv));
	CvCONDP(cv) = 0;
    }
    return sv;
}

MODULE = Thread		PACKAGE = Thread

Thread
new(class, startsv, ...)
	SV *		class
	SV *		startsv
	AV *		av = av_make(items - 2, &ST(2));
    CODE:
	RETVAL = newthread(startsv, av);
    OUTPUT:
	RETVAL

void
sync(sv)
	SV *	sv
	HV *	hvp = NO_INIT
	GV *	gvp = NO_INIT
    CODE:
	SvFLAGS(sv_2cv(sv, &hvp, &gvp, FALSE)) |= SVp_SYNC;
	ST(0) = sv_mortalcopy(sv);

void
fast(sv)
	SV *	sv
    CODE:
	ST(0) = sv_mortalcopy(fast(sv));

void
join(t)
	Thread	t
	AV *	av = NO_INIT
	int	i = NO_INIT
    PPCODE:
	if (ThrSTATE(t) == THR_DETACHED)
	    croak("tried to join a detached thread");
	else if (ThrSTATE(t) == THR_JOINED)
	    croak("tried to rejoin an already joined thread");
	else if (ThrSTATE(t) == THR_DEAD)
	    croak("tried to join a dead thread");

	if (pthread_join(t->Tself, (void **) &av))
	    croak("pthread_join failed");
	ThrSETSTATE(t, THR_JOINED);
	/* Could easily speed up the following if necessary */
	for (i = 0; i <= AvFILL(av); i++)
	    XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));

void
detach(t)
	Thread	t
    CODE:
	if (ThrSTATE(t) == THR_DETACHED)
	    croak("tried to detach an already detached thread");
	else if (ThrSTATE(t) == THR_JOINED)
	    croak("tried to detach an already joined thread");
	else if (ThrSTATE(t) == THR_DEAD)
	    croak("tried to detach a dead thread");
	if (pthread_detach(t->Tself))
	    croak("pthread_detach failed");
	ThrSETSTATE(t, THR_DETACHED);

void
DESTROY(t)
	Thread	t
    CODE:
	if (ThrSTATE(t) == THR_NORMAL) {
	    if (pthread_detach(t->Tself))
		croak("pthread_detach failed");
	    ThrSETSTATE(t, THR_DETACHED);
	}

void
yield()
    CODE:
#ifdef OLD_PTHREADS_API
	pthread_yield();
#else
#ifndef NO_SCHED_YIELD
	sched_yield();
#endif /* NO_SCHED_YIELD */
#endif /* OLD_PTHREADS_API */

void
cond_wait(sv)
	SV *	sv
	MAGIC *	mg = NO_INIT
CODE:
	if (SvROK(sv))
	    sv = SvRV(sv);

	mg = condpair_magic(sv);
	DEBUG_L(fprintf(stderr, "0x%lx: cond_wait 0x%lx\n",
			(unsigned long)thr, (unsigned long)sv));
	MUTEX_LOCK(MgMUTEXP(mg));
	if (MgOWNER(mg) != thr) {
	    MUTEX_UNLOCK(MgMUTEXP(mg));
	    croak("cond_wait for lock that we don't own\n");
	}
	MgOWNER(mg) = 0;
	COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
	MgOWNER(mg) = thr;
	MUTEX_UNLOCK(MgMUTEXP(mg));
	
void
cond_signal(sv)
	SV *	sv
	MAGIC *	mg = NO_INIT
CODE:
	if (SvROK(sv)) {
	    /*
	     * Kludge to allow lock of real objects without requiring
	     * to pass in every type of argument by explicit reference.
	     */
	    sv = SvRV(sv);
	}
	mg = condpair_magic(sv);
	DEBUG_L(fprintf(stderr, "0x%lx: cond_signal 0x%lx\n",
			(unsigned long)thr, (unsigned long)sv));
	MUTEX_LOCK(MgMUTEXP(mg));
	if (MgOWNER(mg) != thr) {
	    MUTEX_UNLOCK(MgMUTEXP(mg));
	    croak("cond_signal for lock that we don't own\n");
	}
	COND_SIGNAL(MgCONDP(mg));
	MUTEX_UNLOCK(MgMUTEXP(mg));

void
cond_broadcast(sv)
	SV *	sv
	MAGIC *	mg = NO_INIT
CODE:
	if (SvROK(sv)) {
	    /*
	     * Kludge to allow lock of real objects without requiring
	     * to pass in every type of argument by explicit reference.
	     */
	    sv = SvRV(sv);
	}
	mg = condpair_magic(sv);
	DEBUG_L(fprintf(stderr, "0x%lx: cond_broadcast 0x%lx\n",
			(unsigned long)thr, (unsigned long)sv));
	MUTEX_LOCK(MgMUTEXP(mg));
	if (MgOWNER(mg) != thr) {
	    MUTEX_UNLOCK(MgMUTEXP(mg));
	    croak("cond_broadcast for lock that we don't own\n");
	}
	COND_BROADCAST(MgCONDP(mg));
	MUTEX_UNLOCK(MgMUTEXP(mg));
Commit	Line	Data
d9bb3666	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
	4
d9bb3666	5	static void *
	6	threadstart(arg)
	7	void *arg;
	8	{
	9	Thread thr = (Thread) arg;
	10	LOGOP myop;
	11	dSP;
	12	I32 oldmark = TOPMARK;
	13	I32 oldscope = scopestack_ix;
	14	I32 retval;
	15	AV *returnav = newAV();
	16	int i;
	17
	18	/*
	19	* Wait until our creator releases us. If we didn't do this, then
	20	* it would be potentially possible for out thread to carry on and
	21	* do stuff before our creator fills in our "self" field. For example,
	22	* if we went and created another thread which tried to pthread_join
	23	* with us, then we'd be in a mess.
	24	*/
	25	MUTEX_LOCK(threadstart_mutexp);
	26	MUTEX_UNLOCK(threadstart_mutexp);
	27	MUTEX_DESTROY(threadstart_mutexp); /* don't need it any more */
	28	Safefree(threadstart_mutexp);
	29
	30	DEBUG_L(fprintf(stderr, "new thread 0x%lx starting at %s\n",
	31	(unsigned long) thr, SvPEEK(TOPs)));
	32	/*
	33	* It's safe to wait until now to set the thread-specific pointer
	34	* from our pthread_t structure to our struct thread, since we're
	35	* the only thread who can get at it anyway.
	36	*/
	37	if (pthread_setspecific(thr_key, (void *) thr))
	38	croak("panic: pthread_setspecific");
	39
	40	switch (Sigsetjmp(top_env,1)) {
	41	case 3:
	42	fprintf(stderr, "panic: top_env\n");
	43	/* fall through */
	44	case 1:
	45	#ifdef VMS
	46	statusvalue = 255;
	47	#else
	48	statusvalue = 1;
	49	#endif
	50	/* fall through */
	51	case 2:
	52	av_store(returnav, 0, newSViv(statusvalue));
	53	goto finishoff;
	54	}
	55
	56	/* Now duplicate most of perl_call_sv but with a few twists */
	57	op = (OP*)&myop;
	58	Zero(op, 1, LOGOP);
	59	myop.op_flags = OPf_STACKED;
	60	myop.op_next = Nullop;
	61	myop.op_flags \|= OPf_KNOW;
	62	myop.op_flags \|= OPf_LIST;
	63	op = pp_entersub(ARGS);
	64	if (op)
	65	runops();
734689b1	66	SPAGAIN;
	67	retval = sp - (stack_base + oldmark);
	68	sp = stack_base + oldmark + 1;
d9bb3666	69	av_store(returnav, 0, newSVpv("", 0));
734689b1	70	for (i = 1; i <= retval; i++, sp++)
	71	sv_setsv(av_fetch(returnav, i, TRUE), SvREFCNT_inc(sp));
	72
d9bb3666	73	finishoff:
	74	SvREFCNT_dec(stack);
	75	SvREFCNT_dec(cvcache);
	76	Safefree(markstack);
	77	Safefree(scopestack);
	78	Safefree(savestack);
	79	Safefree(retstack);
	80	Safefree(cxstack);
	81	Safefree(tmps_stack);
	82
734689b1	83	if (ThrSTATE(thr) == THR_DETACHED) {
	84	SvREFCNT_dec(returnav);
	85	ThrSETSTATE(thr, THR_DEAD);
	86	}
d9bb3666	87	return (void ) returnav; / Available for anyone to join with us */
734689b1	88	/* unless we are detached in which case */
734689b1	89	/* noone will see the value anyway. */
d9bb3666	90	}
	91
	92	Thread
	93	newthread(startsv, initargs)
	94	SV *startsv;
	95	AV *initargs;
	96	{
	97	dTHR;
	98	dSP;
	99	Thread savethread;
	100	int i;
	101
	102	savethread = thr;
	103	New(53, thr, 1, struct thread);
	104	init_stacks(ARGS);
	105	SPAGAIN;
	106	defstash = savethread->Tdefstash; /* XXX maybe these should */
	107	curstash = savethread->Tcurstash; /* always be set to main? */
	108	mainstack = stack;
	109	/* top_env? */
	110	/* runlevel */
	111	cvcache = newHV();
734689b1	112	ThrSETSTATE(thr, THR_NORMAL);
d9bb3666	113
	114	/* The following pushes the arg list and startsv onto the new stack */
	115	PUSHMARK(sp);
	116	/* Could easily speed up the following greatly */
734689b1	117	for (i = 0; i <= AvFILL(initargs); i++)
d9bb3666	118	XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
	119	XPUSHs(SvREFCNT_inc(startsv));
	120	PUTBACK;
	121
2c127b02	122	New(53, threadstart_mutexp, 1, perl_mutex);
d9bb3666	123	/* On your marks... */
	124	MUTEX_INIT(threadstart_mutexp);
	125	MUTEX_LOCK(threadstart_mutexp);
	126	/* Get set...
	127	* Increment the global thread count. It is decremented
	128	* by the destructor for the thread specific key thr_key.
	129	*/
	130	MUTEX_LOCK(&nthreads_mutex);
	131	nthreads++;
	132	MUTEX_UNLOCK(&nthreads_mutex);
	133	if (pthread_create(&self, NULL, threadstart, (void*) thr))
	134	return NULL; /* XXX should clean up first */
	135	/* Go */
	136	MUTEX_UNLOCK(threadstart_mutexp);
	137	return thr;
	138	}
	139
d9bb3666	140	static SV *
	141	fast(sv)
	142	SV *sv;
	143	{
	144	HV *hvp;
	145	GV *gvp;
	146	CV *cv = sv_2cv(sv, &hvp, &gvp, FALSE);
	147
	148	if (!cv)
	149	croak("Not a CODE reference");
	150	if (CvCONDP(cv)) {
	151	COND_DESTROY(CvCONDP(cv));
	152	Safefree(CvCONDP(cv));
	153	CvCONDP(cv) = 0;
	154	}
	155	return sv;
	156	}
	157
	158	MODULE = Thread PACKAGE = Thread
	159
	160	Thread
	161	new(class, startsv, ...)
	162	SV * class
	163	SV * startsv
734689b1	164	AV * av = av_make(items - 2, &ST(2));
d9bb3666	165	CODE:
	166	RETVAL = newthread(startsv, av);
	167	OUTPUT:
	168	RETVAL
	169
	170	void
	171	sync(sv)
	172	SV * sv
	173	HV * hvp = NO_INIT
	174	GV * gvp = NO_INIT
	175	CODE:
734689b1	176	SvFLAGS(sv_2cv(sv, &hvp, &gvp, FALSE)) \|= SVp_SYNC;
d9bb3666	177	ST(0) = sv_mortalcopy(sv);
	178
	179	void
	180	fast(sv)
	181	SV * sv
	182	CODE:
	183	ST(0) = sv_mortalcopy(fast(sv));
	184
	185	void
	186	join(t)
	187	Thread t
	188	AV * av = NO_INIT
	189	int i = NO_INIT
	190	PPCODE:
734689b1	191	if (ThrSTATE(t) == THR_DETACHED)
	192	croak("tried to join a detached thread");
	193	else if (ThrSTATE(t) == THR_JOINED)
	194	croak("tried to rejoin an already joined thread");
	195	else if (ThrSTATE(t) == THR_DEAD)
	196	croak("tried to join a dead thread");
	197
d9bb3666	198	if (pthread_join(t->Tself, (void **) &av))
d9bb3666	199	croak("pthread_join failed");
734689b1	200	ThrSETSTATE(t, THR_JOINED);
d9bb3666	201	/* Could easily speed up the following if necessary */
	202	for (i = 0; i <= AvFILL(av); i++)
	203	XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
	204
	205	void
734689b1	206	detach(t)
d9bb3666	207	Thread t
d9bb3666	208	CODE:
734689b1	209	if (ThrSTATE(t) == THR_DETACHED)
	210	croak("tried to detach an already detached thread");
	211	else if (ThrSTATE(t) == THR_JOINED)
	212	croak("tried to detach an already joined thread");
	213	else if (ThrSTATE(t) == THR_DEAD)
	214	croak("tried to detach a dead thread");
	215	if (pthread_detach(t->Tself))
	216	croak("pthread_detach failed");
	217	ThrSETSTATE(t, THR_DETACHED);
d9bb3666	218
d9bb3666	219	void
734689b1	220	DESTROY(t)
734689b1	221	Thread t
d9bb3666	222	CODE:
734689b1	223	if (ThrSTATE(t) == THR_NORMAL) {
	224	if (pthread_detach(t->Tself))
	225	croak("pthread_detach failed");
	226	ThrSETSTATE(t, THR_DETACHED);
	227	}
d9bb3666	228
d9bb3666	229	void
734689b1	230	yield()
d9bb3666	231	CODE:
734689b1	232	#ifdef OLD_PTHREADS_API
	233	pthread_yield();
	234	#else
	235	#ifndef NO_SCHED_YIELD
	236	sched_yield();
	237	#endif /* NO_SCHED_YIELD */
	238	#endif /* OLD_PTHREADS_API */
d9bb3666	239
d9bb3666	240	void
734689b1	241	cond_wait(sv)
	242	SV * sv
	243	MAGIC * mg = NO_INIT
	244	CODE:
2c127b02	245	if (SvROK(sv))
734689b1	246	sv = SvRV(sv);
2c127b02	247
734689b1	248	mg = condpair_magic(sv);
	249	DEBUG_L(fprintf(stderr, "0x%lx: cond_wait 0x%lx\n",
	250	(unsigned long)thr, (unsigned long)sv));
	251	MUTEX_LOCK(MgMUTEXP(mg));
	252	if (MgOWNER(mg) != thr) {
	253	MUTEX_UNLOCK(MgMUTEXP(mg));
	254	croak("cond_wait for lock that we don't own\n");
	255	}
	256	MgOWNER(mg) = 0;
	257	COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
	258	MgOWNER(mg) = thr;
	259	MUTEX_UNLOCK(MgMUTEXP(mg));
	260
	261	void
	262	cond_signal(sv)
	263	SV * sv
	264	MAGIC * mg = NO_INIT
	265	CODE:
	266	if (SvROK(sv)) {
	267	/*
	268	* Kludge to allow lock of real objects without requiring
	269	* to pass in every type of argument by explicit reference.
	270	*/
	271	sv = SvRV(sv);
	272	}
	273	mg = condpair_magic(sv);
	274	DEBUG_L(fprintf(stderr, "0x%lx: cond_signal 0x%lx\n",
	275	(unsigned long)thr, (unsigned long)sv));
	276	MUTEX_LOCK(MgMUTEXP(mg));
	277	if (MgOWNER(mg) != thr) {
	278	MUTEX_UNLOCK(MgMUTEXP(mg));
	279	croak("cond_signal for lock that we don't own\n");
	280	}
	281	COND_SIGNAL(MgCONDP(mg));
	282	MUTEX_UNLOCK(MgMUTEXP(mg));
d9bb3666	283
734689b1	284	void
	285	cond_broadcast(sv)
	286	SV * sv
	287	MAGIC * mg = NO_INIT
	288	CODE:
	289	if (SvROK(sv)) {
	290	/*
	291	* Kludge to allow lock of real objects without requiring
	292	* to pass in every type of argument by explicit reference.
	293	*/
	294	sv = SvRV(sv);
	295	}
	296	mg = condpair_magic(sv);
	297	DEBUG_L(fprintf(stderr, "0x%lx: cond_broadcast 0x%lx\n",
	298	(unsigned long)thr, (unsigned long)sv));
	299	MUTEX_LOCK(MgMUTEXP(mg));
	300	if (MgOWNER(mg) != thr) {
	301	MUTEX_UNLOCK(MgMUTEXP(mg));
	302	croak("cond_broadcast for lock that we don't own\n");
	303	}
	304	COND_BROADCAST(MgCONDP(mg));
	305	MUTEX_UNLOCK(MgMUTEXP(mg));