5 /* Magic signature for Thread's mg_private is "Th" */
6 #define Thread_MAGIC_SIGNATURE 0x5468
8 static U32 threadnum = 0;
9 static int sig_pipe[2];
15 DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
16 "%p: remove_thread %p\n", thr, t)));
17 MUTEX_LOCK(&threads_mutex);
19 t->prev->next = t->next;
20 t->next->prev = t->prev;
21 COND_BROADCAST(&nthreads_cond);
22 MUTEX_UNLOCK(&threads_mutex);
30 Thread savethread = thr;
33 I32 oldscope = scopestack_ix;
35 AV *returnav = newAV();
38 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
42 thr->prev = thr->prev_run = savethread;
43 thr->next = savethread->next;
44 thr->next_run = savethread->next_run;
45 savethread->next = savethread->next_run = thr;
49 /* Now duplicate most of perl_call_sv but with a few twists */
52 myop.op_flags = OPf_STACKED;
53 myop.op_next = Nullop;
54 myop.op_flags |= OPf_KNOW;
55 myop.op_flags |= OPf_WANT_LIST;
56 op = pp_entersub(ARGS);
58 PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n"));
60 * When this thread is next scheduled, we start in the right
61 * place. When the thread runs off the end of the sub, perl.c
62 * handles things, using savemark to figure out how much of the
63 * stack is the return value for any join.
65 thr = savethread; /* back to the old thread */
68 Thread thr = (Thread) arg;
71 I32 oldmark = TOPMARK;
72 I32 oldscope = scopestack_ix;
74 AV *returnav = newAV();
79 /* Don't call *anything* requiring dTHR until after pthread_setspecific */
81 * Wait until our creator releases us. If we didn't do this, then
82 * it would be potentially possible for out thread to carry on and
83 * do stuff before our creator fills in our "self" field. For example,
84 * if we went and created another thread which tried to pthread_join
85 * with us, then we'd be in a mess.
87 MUTEX_LOCK(threadstart_mutexp);
88 MUTEX_UNLOCK(threadstart_mutexp);
89 MUTEX_DESTROY(threadstart_mutexp); /* don't need it any more */
90 Safefree(threadstart_mutexp);
93 * It's safe to wait until now to set the thread-specific pointer
94 * from our pthread_t structure to our struct thread, since we're
95 * the only thread who can get at it anyway.
97 if (pthread_setspecific(thr_key, (void *) thr))
98 croak("panic: pthread_setspecific");
100 /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
101 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
107 PerlIO_printf(PerlIO_stderr(), "panic: threadstart\n");
113 /* my_exit() was called */
114 while (scopestack_ix > oldscope)
117 av_store(returnav, 0, newSViv(statusvalue));
121 /* Now duplicate most of perl_call_sv but with a few twists */
124 myop.op_flags = OPf_STACKED;
125 myop.op_next = Nullop;
126 myop.op_flags |= OPf_KNOW;
127 myop.op_flags |= OPf_WANT_LIST;
128 op = pp_entersub(ARGS);
132 retval = sp - (stack_base + oldmark);
133 sp = stack_base + oldmark + 1;
134 DEBUG_L(for (i = 1; i <= retval; i++)
135 PerlIO_printf(PerlIO_stderr(),
136 "%p returnav[%d] = %s\n",
137 thr, i, SvPEEK(sp[i - 1]));)
138 av_store(returnav, 0, newSVpv("", 0));
139 for (i = 1; i <= retval; i++, sp++)
140 sv_setsv(*av_fetch(returnav, i, TRUE), SvREFCNT_inc(*sp));
144 /* removed for debug */
145 SvREFCNT_dec(curstack);
147 SvREFCNT_dec(cvcache);
149 Safefree(scopestack);
153 Safefree(tmps_stack);
155 if (ThrSTATE(thr) == THRf_DETACHED) {
156 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
157 "%p detached...zapping returnav\n", thr));
158 SvREFCNT_dec(returnav);
159 ThrSETSTATE(thr, THRf_DEAD);
162 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p returning\n", thr));
163 return (void *) returnav; /* Available for anyone to join with us */
164 /* unless we are detached in which case */
165 /* noone will see the value anyway. */
170 newthread(startsv, initargs, class)
180 sigset_t fullmask, oldmask;
184 SvGROW(sv, sizeof(struct thread) + 1);
185 SvCUR_set(sv, sizeof(struct thread));
186 thr = (Thread) SvPVX(sv);
187 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread(%s) = %p\n",
188 savethread, SvPEEK(startsv), thr));
190 /* If we don't zero these foostack pointers, init_stacks won't init them */
196 curcop = savethread->Tcurcop; /* XXX As good a guess as any? */
198 defstash = savethread->Tdefstash; /* XXX maybe these should */
199 curstash = savethread->Tcurstash; /* always be set to main? */
203 thr->flags = THRf_NORMAL;
204 thr->tid = ++threadnum;
205 /* Insert new thread into the circular linked list and bump nthreads */
206 MUTEX_LOCK(&threads_mutex);
207 thr->next = savethread->next;
208 thr->prev = savethread;
209 savethread->next = thr;
210 thr->next->prev = thr;
212 MUTEX_UNLOCK(&threads_mutex);
214 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread preparing stack\n",
216 /* The following pushes the arg list and startsv onto the *new* stack */
218 /* Could easily speed up the following greatly */
219 for (i = 0; i <= AvFILL(initargs); i++)
220 XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
221 XPUSHs(SvREFCNT_inc(startsv));
227 New(53, threadstart_mutexp, 1, perl_mutex);
228 /* On your marks... */
229 MUTEX_INIT(threadstart_mutexp);
230 MUTEX_LOCK(threadstart_mutexp);
232 * Increment the global thread count. It is decremented
233 * by the destructor for the thread specific key thr_key.
235 sigfillset(&fullmask);
236 if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
237 croak("panic: sigprocmask");
238 if (pthread_create(&self, NULL, threadstart, (void*) thr))
239 return NULL; /* XXX should clean up first */
241 MUTEX_UNLOCK(threadstart_mutexp);
242 if (sigprocmask(SIG_SETMASK, &oldmask, 0))
243 croak("panic: sigprocmask");
245 sv = newSViv(thr->tid);
246 sv_magic(sv, oursv, '~', 0, 0);
247 SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
248 return sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE));
252 handle_thread_signal(sig)
256 write(sig_pipe[0], &c, 1);
259 MODULE = Thread PACKAGE = Thread
262 new(class, startsv, ...)
265 AV * av = av_make(items - 2, &ST(2));
267 XPUSHs(sv_2mortal(newthread(startsv, av, class)));
275 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n",
276 thr, t, ThrSTATE(t)););
277 if (ThrSTATE(t) == THRf_DETACHED)
278 croak("tried to join a detached thread");
279 else if (ThrSTATE(t) == THRf_JOINED)
280 croak("tried to rejoin an already joined thread");
281 else if (ThrSTATE(t) == THRf_DEAD)
282 croak("tried to join a dead thread");
284 if (pthread_join(t->Tself, (void **) &av))
285 croak("pthread_join failed");
286 ThrSETSTATE(t, THRf_JOINED);
289 /* Could easily speed up the following if necessary */
290 for (i = 0; i <= AvFILL(av); i++)
291 XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
297 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n",
298 thr, t, ThrSTATE(t)););
299 if (ThrSTATE(t) == THRf_DETACHED)
300 croak("tried to detach an already detached thread");
301 else if (ThrSTATE(t) == THRf_JOINED)
302 croak("tried to detach an already joined thread");
303 else if (ThrSTATE(t) == THRf_DEAD)
304 croak("tried to detach a dead thread");
306 ThrSETSTATE(t, THRf_DETACHED);
312 DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
313 "%p: DESTROY(%p), state %u\n",
314 thr, t, ThrSTATE(t))));
316 if (ThrSTATE(t) == THRf_NORMAL) {
318 ThrSETSTATE(t, THRf_DETACHED);
319 t->flags |= THRf_DIE_FATAL;
327 PUSHs((t1 == t2) ? &sv_yes : &sv_no);
333 PUSHs(sv_2mortal(newSViv(t->flags)));
341 sv = newSViv(thr->tid);
342 sv_magic(sv, oursv, '~', 0, 0);
343 SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
344 PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE))));
349 #ifdef OLD_PTHREADS_API
352 #ifndef NO_SCHED_YIELD
354 #endif /* NO_SCHED_YIELD */
355 #endif /* OLD_PTHREADS_API */
365 mg = condpair_magic(sv);
366 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv));
367 MUTEX_LOCK(MgMUTEXP(mg));
368 if (MgOWNER(mg) != thr) {
369 MUTEX_UNLOCK(MgMUTEXP(mg));
370 croak("cond_wait for lock that we don't own\n");
373 COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
375 MUTEX_UNLOCK(MgMUTEXP(mg));
384 * Kludge to allow lock of real objects without requiring
385 * to pass in every type of argument by explicit reference.
389 mg = condpair_magic(sv);
390 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv));
391 MUTEX_LOCK(MgMUTEXP(mg));
392 if (MgOWNER(mg) != thr) {
393 MUTEX_UNLOCK(MgMUTEXP(mg));
394 croak("cond_signal for lock that we don't own\n");
396 COND_SIGNAL(MgCONDP(mg));
397 MUTEX_UNLOCK(MgMUTEXP(mg));
407 mg = condpair_magic(sv);
408 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n",
410 MUTEX_LOCK(MgMUTEXP(mg));
411 if (MgOWNER(mg) != thr) {
412 MUTEX_UNLOCK(MgMUTEXP(mg));
413 croak("cond_broadcast for lock that we don't own\n");
415 COND_BROADCAST(MgCONDP(mg));
416 MUTEX_UNLOCK(MgMUTEXP(mg));
429 * Iterate until we have enough dynamic storage for all threads.
430 * We mustn't do any allocation while holding threads_mutex though.
432 MUTEX_LOCK(&threads_mutex);
435 MUTEX_UNLOCK(&threads_mutex);
436 if (AvFILL(av) < n - 1) {
438 for (i = AvFILL(av); i < n - 1; i++) {
439 SV *sv = newSViv(0); /* fill in tid later */
440 sv_magic(sv, 0, '~', 0, 0); /* fill in other magic later */
441 av_push(av, sv_bless(newRV_noinc(sv),
442 gv_stashpv(class, TRUE)));
445 MUTEX_LOCK(&threads_mutex);
446 } while (n < nthreads);
449 * At this point, there's enough room to fill in av.
450 * Note that we are holding threads_mutex so the list
451 * won't change out from under us but all the remaining
452 * processing is "fast" (no blocking, malloc etc.)
457 SV *sv = SvRV(*svp++);
458 sv_setiv(sv, t->tid);
459 SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->Toursv);
460 SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
461 SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
464 /* Record the overflow */
466 MUTEX_UNLOCK(&threads_mutex);
467 /* Truncate any unneeded slots in av */
469 av_fill(av, AvFILL(av) - n);
470 /* Finally, push all the new objects onto the stack and drop av */
472 for (svp = AvARRAY(av); n > 0; n--, svp++)
474 (void)sv_2mortal((SV*)av);
477 MODULE = Thread PACKAGE = Thread::Signal
480 kill_sighandler_thread()
482 write(sig_pipe[0], "\0", 1);
486 init_thread_signals()
488 sighandlerp = handle_thread_signal;
489 if (pipe(sig_pipe) == -1)
500 ret = read(sig_pipe[1], &c, 1);
501 } while (ret == -1 && errno == EINTR);
503 croak("panic: await_signal");
506 RETVAL = c ? psig_ptr[c] : &sv_no;