5 static I32 threadnum = 0;
12 Thread savethread = thr;
15 I32 oldscope = scopestack_ix;
17 AV *returnav = newAV();
20 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
24 thr->prev = thr->prev_run = savethread;
25 thr->next = savethread->next;
26 thr->next_run = savethread->next_run;
27 savethread->next = savethread->next_run = thr;
31 /* Now duplicate most of perl_call_sv but with a few twists */
34 myop.op_flags = OPf_STACKED;
35 myop.op_next = Nullop;
36 myop.op_flags |= OPf_KNOW;
37 myop.op_flags |= OPf_WANT_LIST;
38 op = pp_entersub(ARGS);
40 PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n"));
42 * When this thread is next scheduled, we start in the right
43 * place. When the thread runs off the end of the sub, perl.c
44 * handles things, using savemark to figure out how much of the
45 * stack is the return value for any join.
47 thr = savethread; /* back to the old thread */
50 Thread thr = (Thread) arg;
53 I32 oldmark = TOPMARK;
54 I32 oldscope = scopestack_ix;
56 AV *returnav = newAV();
61 /* Don't call *anything* requiring dTHR until after pthread_setspecific */
63 * Wait until our creator releases us. If we didn't do this, then
64 * it would be potentially possible for out thread to carry on and
65 * do stuff before our creator fills in our "self" field. For example,
66 * if we went and created another thread which tried to pthread_join
67 * with us, then we'd be in a mess.
69 MUTEX_LOCK(threadstart_mutexp);
70 MUTEX_UNLOCK(threadstart_mutexp);
71 MUTEX_DESTROY(threadstart_mutexp); /* don't need it any more */
72 Safefree(threadstart_mutexp);
75 * It's safe to wait until now to set the thread-specific pointer
76 * from our pthread_t structure to our struct thread, since we're
77 * the only thread who can get at it anyway.
79 if (pthread_setspecific(thr_key, (void *) thr))
80 croak("panic: pthread_setspecific");
82 /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
83 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
89 PerlIO_printf(PerlIO_stderr(), "panic: threadstart\n");
95 /* my_exit() was called */
96 while (scopestack_ix > oldscope)
99 av_store(returnav, 0, newSViv(statusvalue));
103 /* Now duplicate most of perl_call_sv but with a few twists */
106 myop.op_flags = OPf_STACKED;
107 myop.op_next = Nullop;
108 myop.op_flags |= OPf_KNOW;
109 myop.op_flags |= OPf_WANT_LIST;
110 op = pp_entersub(ARGS);
114 retval = sp - (stack_base + oldmark);
115 sp = stack_base + oldmark + 1;
116 DEBUG_L(for (i = 1; i <= retval; i++)
117 PerlIO_printf(PerlIO_stderr(),
118 "%p returnav[%d] = %s\n",
119 thr, i, SvPEEK(sp[i - 1]));)
120 av_store(returnav, 0, newSVpv("", 0));
121 for (i = 1; i <= retval; i++, sp++)
122 sv_setsv(*av_fetch(returnav, i, TRUE), SvREFCNT_inc(*sp));
126 /* removed for debug */
127 SvREFCNT_dec(curstack);
129 SvREFCNT_dec(cvcache);
131 Safefree(scopestack);
135 Safefree(tmps_stack);
137 if (ThrSTATE(thr) == THRf_DETACHED) {
138 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
139 "%p detached...zapping returnav\n", thr));
140 SvREFCNT_dec(returnav);
141 ThrSETSTATE(thr, THRf_DEAD);
143 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p returning\n", thr));
144 return (void *) returnav; /* Available for anyone to join with us */
145 /* unless we are detached in which case */
146 /* noone will see the value anyway. */
151 newthread(startsv, initargs, class)
164 SvGROW(sv, sizeof(struct thread) + 1);
165 SvCUR_set(sv, sizeof(struct thread));
166 thr = (Thread) SvPVX(sv);
168 /* If we don't zero these foostack pointers, init_stacks won't init them */
174 curcop = savethread->Tcurcop; /* XXX As good a guess as any? */
176 defstash = savethread->Tdefstash; /* XXX maybe these should */
177 curstash = savethread->Tcurstash; /* always be set to main? */
182 ThrSETSTATE(thr, THRf_NORMAL);
184 /* The following pushes the arg list and startsv onto the *new* stack */
186 /* Could easily speed up the following greatly */
187 for (i = 0; i <= AvFILL(initargs); i++)
188 XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
189 XPUSHs(SvREFCNT_inc(startsv));
195 New(53, threadstart_mutexp, 1, perl_mutex);
196 /* On your marks... */
197 MUTEX_INIT(threadstart_mutexp);
198 MUTEX_LOCK(threadstart_mutexp);
200 * Increment the global thread count. It is decremented
201 * by the destructor for the thread specific key thr_key.
203 MUTEX_LOCK(&nthreads_mutex);
205 MUTEX_UNLOCK(&nthreads_mutex);
206 if (pthread_create(&self, NULL, threadstart, (void*) thr))
207 return NULL; /* XXX should clean up first */
209 MUTEX_UNLOCK(threadstart_mutexp);
211 sv = newSViv(++threadnum);
212 sv_magic(sv, oursv, '~', 0, 0);
213 return sv_bless(newRV(sv), gv_stashpv(class, TRUE));
216 MODULE = Thread PACKAGE = Thread
219 new(class, startsv, ...)
222 AV * av = av_make(items - 2, &ST(2));
224 XPUSHs(sv_2mortal(newthread(startsv, av, class)));
232 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
233 "%p: joining %p (state 0x%lx)\n",
234 thr, t, (unsigned long)ThrSTATE(t)););
235 if (ThrSTATE(t) == THRf_DETACHED)
236 croak("tried to join a detached thread");
237 else if (ThrSTATE(t) == THRf_JOINED)
238 croak("tried to rejoin an already joined thread");
239 else if (ThrSTATE(t) == THRf_DEAD)
240 croak("tried to join a dead thread");
242 if (pthread_join(t->Tself, (void **) &av))
243 croak("pthread_join failed");
244 ThrSETSTATE(t, THRf_JOINED);
245 /* Could easily speed up the following if necessary */
246 for (i = 0; i <= AvFILL(av); i++)
247 XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
253 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
254 "%p: detaching %p (state 0x%lx)\n",
255 thr, t, (unsigned long)ThrSTATE(t)););
256 if (ThrSTATE(t) == THRf_DETACHED)
257 croak("tried to detach an already detached thread");
258 else if (ThrSTATE(t) == THRf_JOINED)
259 croak("tried to detach an already joined thread");
260 else if (ThrSTATE(t) == THRf_DEAD)
261 croak("tried to detach a dead thread");
262 if (pthread_detach(t->Tself))
263 croak("panic: pthread_detach failed");
264 ThrSETSTATE(t, THRf_DETACHED);
270 if (ThrSTATE(t) == THRf_NORMAL) {
271 if (pthread_detach(t->Tself))
272 croak("panic: pthread_detach failed");
273 ThrSETSTATE(t, THRf_DETACHED);
274 thrflags |= THRf_DIE_FATAL;
280 #ifdef OLD_PTHREADS_API
283 #ifndef NO_SCHED_YIELD
285 #endif /* NO_SCHED_YIELD */
286 #endif /* OLD_PTHREADS_API */
296 mg = condpair_magic(sv);
297 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv));
298 MUTEX_LOCK(MgMUTEXP(mg));
299 if (MgOWNER(mg) != thr) {
300 MUTEX_UNLOCK(MgMUTEXP(mg));
301 croak("cond_wait for lock that we don't own\n");
304 COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
306 MUTEX_UNLOCK(MgMUTEXP(mg));
315 * Kludge to allow lock of real objects without requiring
316 * to pass in every type of argument by explicit reference.
320 mg = condpair_magic(sv);
321 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv));
322 MUTEX_LOCK(MgMUTEXP(mg));
323 if (MgOWNER(mg) != thr) {
324 MUTEX_UNLOCK(MgMUTEXP(mg));
325 croak("cond_signal for lock that we don't own\n");
327 COND_SIGNAL(MgCONDP(mg));
328 MUTEX_UNLOCK(MgMUTEXP(mg));
338 mg = condpair_magic(sv);
339 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n",
341 MUTEX_LOCK(MgMUTEXP(mg));
342 if (MgOWNER(mg) != thr) {
343 MUTEX_UNLOCK(MgMUTEXP(mg));
344 croak("cond_broadcast for lock that we don't own\n");
346 COND_BROADCAST(MgCONDP(mg));
347 MUTEX_UNLOCK(MgMUTEXP(mg));