This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix major bug in GIMME (introduced in 5.003_96); void contexts were
[perl5.git] / ext / Thread / Thread.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 /* Magic signature for Thread's mg_private is "Th" */ 
6 #define Thread_MAGIC_SIGNATURE 0x5468
7
8 #ifdef __cplusplus
9 #ifdef I_UNISTD
10 #include <unistd.h>
11 #endif
12 #endif
13 #include <fcntl.h>
14                         
15 static int sig_pipe[2];
16             
17 #ifndef THREAD_RET_TYPE
18 #define THREAD_RET_TYPE void *
19 #define THREAD_RET_CAST(x) ((THREAD_RET_TYPE) x)
20 #endif
21
22 static void
23 remove_thread(struct perl_thread *t)
24 {
25 #ifdef USE_THREADS
26     DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
27                                    "%p: remove_thread %p\n", thr, t)));
28     MUTEX_LOCK(&threads_mutex);
29     MUTEX_DESTROY(&t->mutex);
30     nthreads--;
31     t->prev->next = t->next;
32     t->next->prev = t->prev;
33     COND_BROADCAST(&nthreads_cond);
34     MUTEX_UNLOCK(&threads_mutex);
35 #endif
36 }
37
38 static THREAD_RET_TYPE
39 threadstart(void *arg)
40 {
41 #ifdef USE_THREADS
42 #ifdef FAKE_THREADS
43     Thread savethread = thr;
44     LOGOP myop;
45     dSP;
46     I32 oldscope = scopestack_ix;
47     I32 retval;
48     AV *av;
49     int i;
50
51     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
52                           thr, SvPEEK(TOPs)));
53     thr = (Thread) arg;
54     savemark = TOPMARK;
55     thr->prev = thr->prev_run = savethread;
56     thr->next = savethread->next;
57     thr->next_run = savethread->next_run;
58     savethread->next = savethread->next_run = thr;
59     thr->wait_queue = 0;
60     thr->private = 0;
61
62     /* Now duplicate most of perl_call_sv but with a few twists */
63     op = (OP*)&myop;
64     Zero(op, 1, LOGOP);
65     myop.op_flags = OPf_STACKED;
66     myop.op_next = Nullop;
67     myop.op_flags |= OPf_KNOW;
68     myop.op_flags |= OPf_WANT_LIST;
69     op = pp_entersub(ARGS);
70     DEBUG_L(if (!op)
71             PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n"));
72     /*
73      * When this thread is next scheduled, we start in the right
74      * place. When the thread runs off the end of the sub, perl.c
75      * handles things, using savemark to figure out how much of the
76      * stack is the return value for any join.
77      */
78     thr = savethread;           /* back to the old thread */
79     return 0;
80 #else
81     Thread thr = (Thread) arg;
82     LOGOP myop;
83     djSP;
84     I32 oldmark = TOPMARK;
85     I32 oldscope = scopestack_ix;
86     I32 retval;
87     SV *sv;
88     AV *av = newAV();
89     int i, ret;
90     dJMPENV;
91     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n",
92                           thr));
93
94     /* Don't call *anything* requiring dTHR until after SET_THR() */
95     /*
96      * Wait until our creator releases us. If we didn't do this, then
97      * it would be potentially possible for out thread to carry on and
98      * do stuff before our creator fills in our "self" field. For example,
99      * if we went and created another thread which tried to JOIN with us,
100      * then we'd be in a mess.
101      */
102     MUTEX_LOCK(&thr->mutex);
103     MUTEX_UNLOCK(&thr->mutex);
104
105     /*
106      * It's safe to wait until now to set the thread-specific pointer
107      * from our pthread_t structure to our struct perl_thread, since
108      * we're the only thread who can get at it anyway.
109      */
110     SET_THR(thr);
111
112     /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
113     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
114                           thr, SvPEEK(TOPs)));
115
116     sv = POPs;
117     PUTBACK;
118     perl_call_sv(sv, G_ARRAY|G_EVAL);
119     SPAGAIN;
120     retval = SP - (stack_base + oldmark);
121     SP = stack_base + oldmark + 1;
122     if (SvCUR(thr->errsv)) {
123         MUTEX_LOCK(&thr->mutex);
124         thr->flags |= THRf_DID_DIE;
125         MUTEX_UNLOCK(&thr->mutex);
126         av_store(av, 0, &sv_no);
127         av_store(av, 1, newSVsv(thr->errsv));
128         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n",
129                               thr, SvPV(thr->errsv, na)));
130     } else {
131         DEBUG_L(STMT_START {
132             for (i = 1; i <= retval; i++) {
133                 PerlIO_printf(PerlIO_stderr(), "%p return[%d] = %s\n",
134                                 thr, i, SvPEEK(SP[i - 1]));
135             }
136         } STMT_END);
137         av_store(av, 0, &sv_yes);
138         for (i = 1; i <= retval; i++, SP++)
139             sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP));
140     }
141
142   finishoff:
143 #if 0    
144     /* removed for debug */
145     SvREFCNT_dec(curstack);
146 #endif
147     SvREFCNT_dec(thr->cvcache);
148     SvREFCNT_dec(thr->threadsv);
149     SvREFCNT_dec(thr->specific);
150     SvREFCNT_dec(thr->errsv);
151     SvREFCNT_dec(thr->errhv);
152
153     Safefree(markstack);
154     Safefree(scopestack);
155     Safefree(savestack);
156     Safefree(retstack);
157     Safefree(cxstack);
158     Safefree(tmps_stack);
159     Safefree(ofs);
160
161     SvREFCNT_dec(rs);
162     SvREFCNT_dec(nrs);
163     SvREFCNT_dec(statname);
164     Safefree(screamfirst);
165     Safefree(screamnext);
166     Safefree(reg_start_tmp);
167     SvREFCNT_dec(lastscream);
168
169     MUTEX_LOCK(&thr->mutex);
170     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
171                           "%p: threadstart finishing: state is %u\n",
172                           thr, ThrSTATE(thr)));
173     switch (ThrSTATE(thr)) {
174     case THRf_R_JOINABLE:
175         ThrSETSTATE(thr, THRf_ZOMBIE);
176         MUTEX_UNLOCK(&thr->mutex);
177         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
178                               "%p: R_JOINABLE thread finished\n", thr));
179         break;
180     case THRf_R_JOINED:
181         ThrSETSTATE(thr, THRf_DEAD);
182         MUTEX_UNLOCK(&thr->mutex);
183         remove_thread(thr);
184         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
185                               "%p: R_JOINED thread finished\n", thr));
186         break;
187     case THRf_R_DETACHED:
188         ThrSETSTATE(thr, THRf_DEAD);
189         MUTEX_UNLOCK(&thr->mutex);
190         SvREFCNT_dec(av);
191         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
192                               "%p: DETACHED thread finished\n", thr));
193         remove_thread(thr);     /* This might trigger main thread to finish */
194         break;
195     default:
196         MUTEX_UNLOCK(&thr->mutex);
197         croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr));
198         /* NOTREACHED */
199     }
200     return THREAD_RET_CAST(av); /* Available for anyone to join with */
201                                         /* us unless we're detached, in which */
202                                         /* case noone sees the value anyway. */
203 #endif    
204 #else
205     return THREAD_RET_CAST(NULL);
206 #endif
207 }
208
209 static SV *
210 newthread (SV *startsv, AV *initargs, char *classname)
211 {
212 #ifdef USE_THREADS
213     dSP;
214     Thread savethread;
215     int i;
216     SV *sv;
217     int err;
218 #ifndef THREAD_CREATE
219     static pthread_attr_t attr;
220     static int attr_inited = 0;
221     sigset_t fullmask, oldmask;
222 #endif
223     
224     savethread = thr;
225     thr = new_struct_thread(thr);
226     SPAGAIN;
227     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
228                           "%p: newthread (%p), tid is %u, preparing stack\n",
229                           savethread, thr, thr->tid));
230     /* The following pushes the arg list and startsv onto the *new* stack */
231     PUSHMARK(SP);
232     /* Could easily speed up the following greatly */
233     for (i = 0; i <= AvFILL(initargs); i++)
234         XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
235     XPUSHs(SvREFCNT_inc(startsv));
236     PUTBACK;
237 #ifdef THREAD_CREATE
238     err = THREAD_CREATE(thr, threadstart);
239 #else    
240     /* On your marks... */
241     MUTEX_LOCK(&thr->mutex);
242     /* Get set...  */
243     sigfillset(&fullmask);
244     if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
245         croak("panic: sigprocmask");
246     err = 0;
247     if (!attr_inited) {
248         attr_inited = 1;
249         err = pthread_attr_init(&attr);
250         if (err == 0)
251             err = pthread_attr_setdetachstate(&attr, ATTR_JOINABLE);
252     }
253     if (err == 0)
254         err = pthread_create(&thr->self, &attr, threadstart, (void*) thr);
255     /* Go */
256     MUTEX_UNLOCK(&thr->mutex);
257 #endif
258     if (err) {
259         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
260                               "%p: create of %p failed %d\n",
261                               savethread, thr, err));
262         /* Thread creation failed--clean up */
263         SvREFCNT_dec(thr->cvcache);
264         remove_thread(thr);
265         MUTEX_DESTROY(&thr->mutex);
266         for (i = 0; i <= AvFILL(initargs); i++)
267             SvREFCNT_dec(*av_fetch(initargs, i, FALSE));
268         SvREFCNT_dec(startsv);
269         return NULL;
270     }
271 #ifdef THREAD_POST_CREATE
272     THREAD_POST_CREATE(thr);
273 #else
274     if (sigprocmask(SIG_SETMASK, &oldmask, 0))
275         croak("panic: sigprocmask");
276 #endif
277     sv = newSViv(thr->tid);
278     sv_magic(sv, thr->oursv, '~', 0, 0);
279     SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
280     return sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));
281 #else
282     croak("No threads in this perl");
283     return &sv_undef;
284 #endif
285 }
286
287 static Signal_t handle_thread_signal _((int sig));
288
289 static Signal_t
290 handle_thread_signal(int sig)
291 {
292     unsigned char c = (unsigned char) sig;
293     /*
294      * We're not really allowed to call fprintf in a signal handler
295      * so don't be surprised if this isn't robust while debugging
296      * with -DL.
297      */
298     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
299             "handle_thread_signal: got signal %d\n", sig););
300     write(sig_pipe[1], &c, 1);
301 }
302
303 MODULE = Thread         PACKAGE = Thread
304 PROTOTYPES: DISABLE
305
306 void
307 new(classname, startsv, ...)
308         char *          classname
309         SV *            startsv
310         AV *            av = av_make(items - 2, &ST(2));
311     PPCODE:
312         XPUSHs(sv_2mortal(newthread(startsv, av, classname)));
313
314 void
315 join(t)
316         Thread  t
317         AV *    av = NO_INIT
318         int     i = NO_INIT
319     PPCODE:
320 #ifdef USE_THREADS
321         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n",
322                               thr, t, ThrSTATE(t)););
323         MUTEX_LOCK(&t->mutex);
324         switch (ThrSTATE(t)) {
325         case THRf_R_JOINABLE:
326         case THRf_R_JOINED:
327             ThrSETSTATE(t, THRf_R_JOINED);
328             MUTEX_UNLOCK(&t->mutex);
329             break;
330         case THRf_ZOMBIE:
331             ThrSETSTATE(t, THRf_DEAD);
332             MUTEX_UNLOCK(&t->mutex);
333             remove_thread(t);
334             break;
335         default:
336             MUTEX_UNLOCK(&t->mutex);
337             croak("can't join with thread");
338             /* NOTREACHED */
339         }
340         JOIN(t, &av);
341
342         if (SvTRUE(*av_fetch(av, 0, FALSE))) {
343             /* Could easily speed up the following if necessary */
344             for (i = 1; i <= AvFILL(av); i++)
345                 XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
346         } else {
347             char *mess = SvPV(*av_fetch(av, 1, FALSE), na);
348             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
349                                   "%p: join propagating die message: %s\n",
350                                   thr, mess));
351             croak(mess);
352         }
353 #endif
354
355 void
356 detach(t)
357         Thread  t
358     CODE:
359 #ifdef USE_THREADS
360         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n",
361                               thr, t, ThrSTATE(t)););
362         MUTEX_LOCK(&t->mutex);
363         switch (ThrSTATE(t)) {
364         case THRf_R_JOINABLE:
365             ThrSETSTATE(t, THRf_R_DETACHED);
366             /* fall through */
367         case THRf_R_DETACHED:
368             DETACH(t);
369             MUTEX_UNLOCK(&t->mutex);
370             break;
371         case THRf_ZOMBIE:
372             ThrSETSTATE(t, THRf_DEAD);
373             DETACH(t);
374             MUTEX_UNLOCK(&t->mutex);
375             remove_thread(t);
376             break;
377         default:
378             MUTEX_UNLOCK(&t->mutex);
379             croak("can't detach thread");
380             /* NOTREACHED */
381         }
382 #endif
383
384 void
385 equal(t1, t2)
386         Thread  t1
387         Thread  t2
388     PPCODE:
389         PUSHs((t1 == t2) ? &sv_yes : &sv_no);
390
391 void
392 flags(t)
393         Thread  t
394     PPCODE:
395 #ifdef USE_THREADS
396         PUSHs(sv_2mortal(newSViv(t->flags)));
397 #endif
398
399 void
400 self(classname)
401         char *  classname
402     PREINIT:
403         SV *sv;
404     PPCODE:        
405 #ifdef USE_THREADS
406         sv = newSViv(thr->tid);
407         sv_magic(sv, thr->oursv, '~', 0, 0);
408         SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
409         PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv),
410                                   gv_stashpv(classname, TRUE))));
411 #endif
412
413 U32
414 tid(t)
415         Thread  t
416     CODE:
417 #ifdef USE_THREADS
418         MUTEX_LOCK(&t->mutex);
419         RETVAL = t->tid;
420         MUTEX_UNLOCK(&t->mutex);
421 #else 
422         RETVAL = 0;
423 #endif
424     OUTPUT:
425         RETVAL
426
427 void
428 DESTROY(t)
429         SV *    t
430     PPCODE:
431         PUSHs(&sv_yes);
432
433 void
434 yield()
435     CODE:
436 {
437 #ifdef USE_THREADS
438         YIELD;
439 #endif
440 }
441
442 void
443 cond_wait(sv)
444         SV *    sv
445         MAGIC * mg = NO_INIT
446 CODE:                       
447 #ifdef USE_THREADS
448         if (SvROK(sv))
449             sv = SvRV(sv);
450
451         mg = condpair_magic(sv);
452         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv));
453         MUTEX_LOCK(MgMUTEXP(mg));
454         if (MgOWNER(mg) != thr) {
455             MUTEX_UNLOCK(MgMUTEXP(mg));
456             croak("cond_wait for lock that we don't own\n");
457         }
458         MgOWNER(mg) = 0;
459         COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
460         while (MgOWNER(mg))
461             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
462         MgOWNER(mg) = thr;
463         MUTEX_UNLOCK(MgMUTEXP(mg));
464 #endif
465
466 void
467 cond_signal(sv)
468         SV *    sv
469         MAGIC * mg = NO_INIT
470 CODE:
471 #ifdef USE_THREADS
472         if (SvROK(sv))
473             sv = SvRV(sv);
474
475         mg = condpair_magic(sv);
476         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv));
477         MUTEX_LOCK(MgMUTEXP(mg));
478         if (MgOWNER(mg) != thr) {
479             MUTEX_UNLOCK(MgMUTEXP(mg));
480             croak("cond_signal for lock that we don't own\n");
481         }
482         COND_SIGNAL(MgCONDP(mg));
483         MUTEX_UNLOCK(MgMUTEXP(mg));
484 #endif
485
486 void
487 cond_broadcast(sv)
488         SV *    sv
489         MAGIC * mg = NO_INIT
490 CODE: 
491 #ifdef USE_THREADS
492         if (SvROK(sv))
493             sv = SvRV(sv);
494
495         mg = condpair_magic(sv);
496         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n",
497                               thr, sv));
498         MUTEX_LOCK(MgMUTEXP(mg));
499         if (MgOWNER(mg) != thr) {
500             MUTEX_UNLOCK(MgMUTEXP(mg));
501             croak("cond_broadcast for lock that we don't own\n");
502         }
503         COND_BROADCAST(MgCONDP(mg));
504         MUTEX_UNLOCK(MgMUTEXP(mg));
505 #endif
506
507 void
508 list(classname)
509         char *  classname
510     PREINIT:
511         Thread  t;
512         AV *    av;
513         SV **   svp;
514         int     n = 0;
515     PPCODE:
516 #ifdef USE_THREADS
517         av = newAV();
518         /*
519          * Iterate until we have enough dynamic storage for all threads.
520          * We mustn't do any allocation while holding threads_mutex though.
521          */
522         MUTEX_LOCK(&threads_mutex);
523         do {
524             n = nthreads;
525             MUTEX_UNLOCK(&threads_mutex);
526             if (AvFILL(av) < n - 1) {
527                 int i = AvFILL(av);
528                 for (i = AvFILL(av); i < n - 1; i++) {
529                     SV *sv = newSViv(0);        /* fill in tid later */
530                     sv_magic(sv, 0, '~', 0, 0); /* fill in other magic later */
531                     av_push(av, sv_bless(newRV_noinc(sv),
532                                          gv_stashpv(classname, TRUE)));
533         
534                 }
535             }
536             MUTEX_LOCK(&threads_mutex);
537         } while (n < nthreads);
538         n = nthreads;   /* Get the final correct value */
539
540         /*
541          * At this point, there's enough room to fill in av.
542          * Note that we are holding threads_mutex so the list
543          * won't change out from under us but all the remaining
544          * processing is "fast" (no blocking, malloc etc.)
545          */
546         t = thr;
547         svp = AvARRAY(av);
548         do {
549             SV *sv = (SV*)SvRV(*svp);
550             sv_setiv(sv, t->tid);
551             SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv);
552             SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
553             SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
554             t = t->next;
555             svp++;
556         } while (t != thr);
557         /*  */
558         MUTEX_UNLOCK(&threads_mutex);
559         /* Truncate any unneeded slots in av */
560         av_fill(av, n - 1);
561         /* Finally, push all the new objects onto the stack and drop av */
562         EXTEND(SP, n);
563         for (svp = AvARRAY(av); n > 0; n--, svp++)
564             PUSHs(*svp);
565         (void)sv_2mortal((SV*)av);
566 #endif
567
568
569 MODULE = Thread         PACKAGE = Thread::Signal
570
571 void
572 kill_sighandler_thread()
573     PPCODE:
574         write(sig_pipe[1], "\0", 1);
575         PUSHs(&sv_yes);
576
577 void
578 init_thread_signals()
579     PPCODE:
580         sighandlerp = handle_thread_signal;
581         if (pipe(sig_pipe) == -1)
582             XSRETURN_UNDEF;
583         PUSHs(&sv_yes);
584
585 void
586 await_signal()
587     PREINIT:
588         unsigned char c;
589         SSize_t ret;
590     CODE:
591         do {
592             ret = read(sig_pipe[0], &c, 1);
593         } while (ret == -1 && errno == EINTR);
594         if (ret == -1)
595             croak("panic: await_signal");
596         ST(0) = sv_newmortal();
597         if (ret)
598             sv_setsv(ST(0), c ? psig_ptr[c] : &sv_no);
599         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
600                               "await_signal returning %s\n", SvPEEK(ST(0))););
601
602 MODULE = Thread         PACKAGE = Thread::Specific
603
604 void
605 data(classname = "Thread::Specific")
606         char *  classname
607     PPCODE:
608 #ifdef USE_THREADS
609         if (AvFILL(thr->specific) == -1) {
610             GV *gv = gv_fetchpv("Thread::Specific::FIELDS", TRUE, SVt_PVHV);
611             av_store(thr->specific, 0, newRV((SV*)GvHV(gv)));
612         }
613         XPUSHs(sv_bless(newRV((SV*)thr->specific),gv_stashpv(classname,TRUE)));
614 #endif