This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add missing sig_pipe definition to Thread.xs.
[perl5.git] / Thread.xs
CommitLineData
d9bb3666
MB
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
683929b4 5static I32 threadnum = 0;
85ced67f 6static int sig_pipe[2];
683929b4 7
d9bb3666
MB
8static void *
9threadstart(arg)
10void *arg;
11{
783070da
MB
12#ifdef FAKE_THREADS
13 Thread savethread = thr;
14 LOGOP myop;
15 dSP;
16 I32 oldscope = scopestack_ix;
17 I32 retval;
18 AV *returnav = newAV();
19 int i;
20
683929b4
MB
21 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
22 thr, SvPEEK(TOPs)));
783070da
MB
23 thr = (Thread) arg;
24 savemark = TOPMARK;
25 thr->prev = thr->prev_run = savethread;
26 thr->next = savethread->next;
27 thr->next_run = savethread->next_run;
28 savethread->next = savethread->next_run = thr;
29 thr->wait_queue = 0;
30 thr->private = 0;
31
32 /* Now duplicate most of perl_call_sv but with a few twists */
33 op = (OP*)&myop;
34 Zero(op, 1, LOGOP);
35 myop.op_flags = OPf_STACKED;
36 myop.op_next = Nullop;
37 myop.op_flags |= OPf_KNOW;
38 myop.op_flags |= OPf_WANT_LIST;
39 op = pp_entersub(ARGS);
40 DEBUG_L(if (!op)
41 PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n"));
42 /*
43 * When this thread is next scheduled, we start in the right
44 * place. When the thread runs off the end of the sub, perl.c
45 * handles things, using savemark to figure out how much of the
46 * stack is the return value for any join.
47 */
48 thr = savethread; /* back to the old thread */
49 return 0;
50#else
d9bb3666
MB
51 Thread thr = (Thread) arg;
52 LOGOP myop;
53 dSP;
54 I32 oldmark = TOPMARK;
55 I32 oldscope = scopestack_ix;
56 I32 retval;
57 AV *returnav = newAV();
58 int i;
783070da
MB
59 dJMPENV;
60 int ret;
61
62 /* Don't call *anything* requiring dTHR until after pthread_setspecific */
d9bb3666
MB
63 /*
64 * Wait until our creator releases us. If we didn't do this, then
65 * it would be potentially possible for out thread to carry on and
66 * do stuff before our creator fills in our "self" field. For example,
67 * if we went and created another thread which tried to pthread_join
68 * with us, then we'd be in a mess.
69 */
70 MUTEX_LOCK(threadstart_mutexp);
71 MUTEX_UNLOCK(threadstart_mutexp);
72 MUTEX_DESTROY(threadstart_mutexp); /* don't need it any more */
73 Safefree(threadstart_mutexp);
74
d9bb3666
MB
75 /*
76 * It's safe to wait until now to set the thread-specific pointer
77 * from our pthread_t structure to our struct thread, since we're
78 * the only thread who can get at it anyway.
79 */
80 if (pthread_setspecific(thr_key, (void *) thr))
81 croak("panic: pthread_setspecific");
82
783070da 83 /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
683929b4
MB
84 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
85 thr, SvPEEK(TOPs)));
783070da
MB
86
87 JMPENV_PUSH(ret);
88 switch (ret) {
89 case 3:
90 PerlIO_printf(PerlIO_stderr(), "panic: threadstart\n");
d9bb3666 91 /* fall through */
783070da
MB
92 case 1:
93 STATUS_ALL_FAILURE;
d9bb3666 94 /* fall through */
783070da
MB
95 case 2:
96 /* my_exit() was called */
97 while (scopestack_ix > oldscope)
98 LEAVE;
99 JMPENV_POP;
d9bb3666
MB
100 av_store(returnav, 0, newSViv(statusvalue));
101 goto finishoff;
102 }
103
104 /* Now duplicate most of perl_call_sv but with a few twists */
105 op = (OP*)&myop;
106 Zero(op, 1, LOGOP);
107 myop.op_flags = OPf_STACKED;
108 myop.op_next = Nullop;
109 myop.op_flags |= OPf_KNOW;
783070da 110 myop.op_flags |= OPf_WANT_LIST;
d9bb3666
MB
111 op = pp_entersub(ARGS);
112 if (op)
113 runops();
734689b1
MB
114 SPAGAIN;
115 retval = sp - (stack_base + oldmark);
116 sp = stack_base + oldmark + 1;
783070da
MB
117 DEBUG_L(for (i = 1; i <= retval; i++)
118 PerlIO_printf(PerlIO_stderr(),
119 "%p returnav[%d] = %s\n",
120 thr, i, SvPEEK(sp[i - 1]));)
d9bb3666 121 av_store(returnav, 0, newSVpv("", 0));
734689b1
MB
122 for (i = 1; i <= retval; i++, sp++)
123 sv_setsv(*av_fetch(returnav, i, TRUE), SvREFCNT_inc(*sp));
124
d9bb3666 125 finishoff:
783070da
MB
126#if 0
127 /* removed for debug */
128 SvREFCNT_dec(curstack);
129#endif
d9bb3666
MB
130 SvREFCNT_dec(cvcache);
131 Safefree(markstack);
132 Safefree(scopestack);
133 Safefree(savestack);
134 Safefree(retstack);
135 Safefree(cxstack);
136 Safefree(tmps_stack);
137
683929b4 138 if (ThrSTATE(thr) == THRf_DETACHED) {
783070da
MB
139 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
140 "%p detached...zapping returnav\n", thr));
734689b1 141 SvREFCNT_dec(returnav);
683929b4 142 ThrSETSTATE(thr, THRf_DEAD);
734689b1 143 }
783070da 144 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p returning\n", thr));
d9bb3666 145 return (void *) returnav; /* Available for anyone to join with us */
734689b1
MB
146 /* unless we are detached in which case */
147 /* noone will see the value anyway. */
783070da 148#endif
d9bb3666
MB
149}
150
683929b4
MB
151static SV *
152newthread(startsv, initargs, class)
d9bb3666
MB
153SV *startsv;
154AV *initargs;
683929b4 155char *class;
d9bb3666
MB
156{
157 dTHR;
158 dSP;
159 Thread savethread;
160 int i;
683929b4 161 SV *sv;
f152979c 162 sigset_t fullmask, oldmask;
d9bb3666
MB
163
164 savethread = thr;
683929b4
MB
165 sv = newSVpv("", 0);
166 SvGROW(sv, sizeof(struct thread) + 1);
167 SvCUR_set(sv, sizeof(struct thread));
168 thr = (Thread) SvPVX(sv);
169 oursv = sv;
783070da
MB
170 /* If we don't zero these foostack pointers, init_stacks won't init them */
171 markstack = 0;
172 scopestack = 0;
173 savestack = 0;
174 retstack = 0;
d9bb3666 175 init_stacks(ARGS);
783070da 176 curcop = savethread->Tcurcop; /* XXX As good a guess as any? */
d9bb3666
MB
177 SPAGAIN;
178 defstash = savethread->Tdefstash; /* XXX maybe these should */
179 curstash = savethread->Tcurstash; /* always be set to main? */
d9bb3666
MB
180 /* top_env? */
181 /* runlevel */
182 cvcache = newHV();
683929b4
MB
183 thrflags = 0;
184 ThrSETSTATE(thr, THRf_NORMAL);
d9bb3666
MB
185
186 /* The following pushes the arg list and startsv onto the *new* stack */
187 PUSHMARK(sp);
188 /* Could easily speed up the following greatly */
734689b1 189 for (i = 0; i <= AvFILL(initargs); i++)
d9bb3666
MB
190 XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
191 XPUSHs(SvREFCNT_inc(startsv));
192 PUTBACK;
193
783070da
MB
194#ifdef FAKE_THREADS
195 threadstart(thr);
196#else
2c127b02 197 New(53, threadstart_mutexp, 1, perl_mutex);
d9bb3666
MB
198 /* On your marks... */
199 MUTEX_INIT(threadstart_mutexp);
200 MUTEX_LOCK(threadstart_mutexp);
201 /* Get set...
202 * Increment the global thread count. It is decremented
203 * by the destructor for the thread specific key thr_key.
204 */
205 MUTEX_LOCK(&nthreads_mutex);
206 nthreads++;
207 MUTEX_UNLOCK(&nthreads_mutex);
f152979c
MB
208 sigfillset(&fullmask);
209 if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
210 croak("panic: sigprocmask");
d9bb3666
MB
211 if (pthread_create(&self, NULL, threadstart, (void*) thr))
212 return NULL; /* XXX should clean up first */
213 /* Go */
214 MUTEX_UNLOCK(threadstart_mutexp);
f152979c
MB
215 if (sigprocmask(SIG_SETMASK, &oldmask, 0))
216 croak("panic: sigprocmask");
783070da 217#endif
683929b4
MB
218 sv = newSViv(++threadnum);
219 sv_magic(sv, oursv, '~', 0, 0);
220 return sv_bless(newRV(sv), gv_stashpv(class, TRUE));
d9bb3666
MB
221}
222
f152979c
MB
223static Signal_t
224handle_thread_signal(sig)
225int sig;
226{
227 char c = (char) sig;
228 write(sig_pipe[0], &c, 1);
229}
230
d9bb3666
MB
231MODULE = Thread PACKAGE = Thread
232
683929b4 233void
d9bb3666 234new(class, startsv, ...)
683929b4 235 char * class
d9bb3666 236 SV * startsv
734689b1 237 AV * av = av_make(items - 2, &ST(2));
683929b4
MB
238 PPCODE:
239 XPUSHs(sv_2mortal(newthread(startsv, av, class)));
d9bb3666
MB
240
241void
d9bb3666
MB
242join(t)
243 Thread t
244 AV * av = NO_INIT
245 int i = NO_INIT
246 PPCODE:
8f4f90ac 247 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
683929b4
MB
248 "%p: joining %p (state 0x%lx)\n",
249 thr, t, (unsigned long)ThrSTATE(t)););
250 if (ThrSTATE(t) == THRf_DETACHED)
734689b1 251 croak("tried to join a detached thread");
683929b4 252 else if (ThrSTATE(t) == THRf_JOINED)
734689b1 253 croak("tried to rejoin an already joined thread");
683929b4 254 else if (ThrSTATE(t) == THRf_DEAD)
734689b1
MB
255 croak("tried to join a dead thread");
256
d9bb3666
MB
257 if (pthread_join(t->Tself, (void **) &av))
258 croak("pthread_join failed");
683929b4 259 ThrSETSTATE(t, THRf_JOINED);
d9bb3666
MB
260 /* Could easily speed up the following if necessary */
261 for (i = 0; i <= AvFILL(av); i++)
262 XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
263
264void
734689b1 265detach(t)
d9bb3666
MB
266 Thread t
267 CODE:
8f4f90ac 268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
683929b4
MB
269 "%p: detaching %p (state 0x%lx)\n",
270 thr, t, (unsigned long)ThrSTATE(t)););
271 if (ThrSTATE(t) == THRf_DETACHED)
734689b1 272 croak("tried to detach an already detached thread");
683929b4 273 else if (ThrSTATE(t) == THRf_JOINED)
734689b1 274 croak("tried to detach an already joined thread");
683929b4 275 else if (ThrSTATE(t) == THRf_DEAD)
734689b1
MB
276 croak("tried to detach a dead thread");
277 if (pthread_detach(t->Tself))
683929b4
MB
278 croak("panic: pthread_detach failed");
279 ThrSETSTATE(t, THRf_DETACHED);
d9bb3666
MB
280
281void
734689b1
MB
282DESTROY(t)
283 Thread t
d9bb3666 284 CODE:
683929b4 285 if (ThrSTATE(t) == THRf_NORMAL) {
734689b1 286 if (pthread_detach(t->Tself))
683929b4
MB
287 croak("panic: pthread_detach failed");
288 ThrSETSTATE(t, THRf_DETACHED);
289 thrflags |= THRf_DIE_FATAL;
734689b1 290 }
d9bb3666
MB
291
292void
734689b1 293yield()
d9bb3666 294 CODE:
734689b1
MB
295#ifdef OLD_PTHREADS_API
296 pthread_yield();
297#else
298#ifndef NO_SCHED_YIELD
299 sched_yield();
300#endif /* NO_SCHED_YIELD */
301#endif /* OLD_PTHREADS_API */
d9bb3666
MB
302
303void
734689b1
MB
304cond_wait(sv)
305 SV * sv
306 MAGIC * mg = NO_INIT
307CODE:
2c127b02 308 if (SvROK(sv))
734689b1 309 sv = SvRV(sv);
2c127b02 310
734689b1 311 mg = condpair_magic(sv);
683929b4 312 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv));
734689b1
MB
313 MUTEX_LOCK(MgMUTEXP(mg));
314 if (MgOWNER(mg) != thr) {
315 MUTEX_UNLOCK(MgMUTEXP(mg));
316 croak("cond_wait for lock that we don't own\n");
317 }
318 MgOWNER(mg) = 0;
319 COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
320 MgOWNER(mg) = thr;
321 MUTEX_UNLOCK(MgMUTEXP(mg));
322
323void
324cond_signal(sv)
325 SV * sv
326 MAGIC * mg = NO_INIT
327CODE:
328 if (SvROK(sv)) {
329 /*
330 * Kludge to allow lock of real objects without requiring
331 * to pass in every type of argument by explicit reference.
332 */
333 sv = SvRV(sv);
334 }
335 mg = condpair_magic(sv);
683929b4 336 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv));
734689b1
MB
337 MUTEX_LOCK(MgMUTEXP(mg));
338 if (MgOWNER(mg) != thr) {
339 MUTEX_UNLOCK(MgMUTEXP(mg));
340 croak("cond_signal for lock that we don't own\n");
341 }
342 COND_SIGNAL(MgCONDP(mg));
343 MUTEX_UNLOCK(MgMUTEXP(mg));
d9bb3666 344
734689b1
MB
345void
346cond_broadcast(sv)
347 SV * sv
348 MAGIC * mg = NO_INIT
349CODE:
783070da 350 if (SvROK(sv))
734689b1 351 sv = SvRV(sv);
783070da 352
734689b1 353 mg = condpair_magic(sv);
683929b4
MB
354 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n",
355 thr, sv));
734689b1
MB
356 MUTEX_LOCK(MgMUTEXP(mg));
357 if (MgOWNER(mg) != thr) {
358 MUTEX_UNLOCK(MgMUTEXP(mg));
359 croak("cond_broadcast for lock that we don't own\n");
360 }
361 COND_BROADCAST(MgCONDP(mg));
362 MUTEX_UNLOCK(MgMUTEXP(mg));
f152979c
MB
363
364MODULE = Thread PACKAGE = Thread::Signal
365
366void
367kill_sighandler_thread()
368 PPCODE:
369 write(sig_pipe[0], "\0", 1);
370 PUSHs(&sv_yes);
371
372void
373init_thread_signals()
374 PPCODE:
375 sighandlerp = handle_thread_signal;
376 if (pipe(sig_pipe) == -1)
377 XSRETURN_UNDEF;
378 PUSHs(&sv_yes);
379
380SV *
381await_signal()
382 PREINIT:
383 char c;
384 ssize_t ret;
385 CODE:
386 do {
387 ret = read(sig_pipe[1], &c, 1);
388 } while (ret == -1 && errno == EINTR);
389 if (ret == -1)
390 croak("panic: await_signal");
391 if (ret == 0)
392 XSRETURN_UNDEF;
393 RETVAL = c ? psig_ptr[c] : &sv_no;
394 OUTPUT:
395 RETVAL