This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make Module-Build aware of new Test-Harness output
[perl5.git] / ext / threads / threads.xs
CommitLineData
68795e93
NIS
1#define PERL_NO_GET_CONTEXT
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
0f1612a7
JH
5#ifdef HAS_PPPORT_H
6# define NEED_newRV_noinc
7# define NEED_sv_2pv_nolen
8# include "ppport.h"
9# include "threads.h"
10#endif
68795e93 11
73e09c8f
JH
12#ifdef USE_ITHREADS
13
c05ae023 14
68795e93
NIS
15#ifdef WIN32
16#include <windows.h>
17#include <win32thread.h>
68795e93 18#else
5c728af0
IZ
19#ifdef OS2
20typedef perl_os_thread pthread_t;
21#else
68795e93 22#include <pthread.h>
5c728af0 23#endif
68795e93 24#include <thread.h>
68795e93
NIS
25#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
26#ifdef OLD_PTHREADS_API
27#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
68795e93
NIS
28#else
29#define PERL_THREAD_DETACH(t) pthread_detach((t))
c05ae023 30#endif /* OLD_PTHREADS_API */
467f3f08 31#endif
68795e93 32
c05ae023
AB
33
34
35
62375a60
NIS
36/* Values for 'state' member */
37#define PERL_ITHR_JOINABLE 0
38#define PERL_ITHR_DETACHED 1
62375a60 39#define PERL_ITHR_JOINED 2
9feacc09 40#define PERL_ITHR_FINISHED 4
62375a60 41
68795e93 42typedef struct ithread_s {
6dfd2d05
JH
43 struct ithread_s *next; /* Next thread in the list */
44 struct ithread_s *prev; /* Prev thread in the list */
68795e93 45 PerlInterpreter *interp; /* The threads interpreter */
f4cc38af 46 UV tid; /* Threads module's thread id */
6dfd2d05 47 perl_mutex mutex; /* Mutex for updating things in this struct */
9feacc09
JH
48 int count; /* How many SVs have a reference to us */
49 int state; /* Are we detached ? */
a446a88f 50 int gimme; /* Context of create */
68795e93 51 SV* init_function; /* Code to run */
6dfd2d05 52 SV* params; /* Args to pass function */
68795e93
NIS
53#ifdef WIN32
54 DWORD thr; /* OS's idea if thread id */
55 HANDLE handle; /* OS's waitable handle */
56#else
57 pthread_t thr; /* OS's handle for the thread */
58#endif
59} ithread;
60
628ab322
DM
61#define MY_CXT_KEY "threads::_guts" XS_VERSION
62
63typedef struct {
64 ithread *thread;
65} my_cxt_t;
66
67START_MY_CXT
68
69
f4cc38af 70static ithread *threads;
68795e93 71
58c2ef19 72static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
68795e93 73
f4cc38af 74static UV tid_counter = 0;
f4cc38af 75static IV active_threads = 0;
c05ae023
AB
76
77
f4cc38af 78static void
bcd9ca9b 79S_ithread_set (pTHX_ ithread* thread)
c05ae023 80{
628ab322
DM
81 dMY_CXT;
82 MY_CXT.thread = thread;
c05ae023
AB
83}
84
f4cc38af 85static ithread*
bcd9ca9b 86S_ithread_get (pTHX) {
628ab322
DM
87 dMY_CXT;
88 return MY_CXT.thread;
c05ae023
AB
89}
90
91
2e676467
DM
92/* free any data (such as the perl interpreter) attached to an
93 * ithread structure. This is a bit like undef on SVs, where the SV
94 * isn't freed, but the PVX is.
95 * Must be called with thread->mutex already held
96 */
97
98static void
41fc7aad 99S_ithread_clear(pTHX_ ithread* thread)
2e676467
DM
100{
101 PerlInterpreter *interp;
102 assert(thread->state & PERL_ITHR_FINISHED &&
103 (thread->state & PERL_ITHR_DETACHED ||
104 thread->state & PERL_ITHR_JOINED));
105
106 interp = thread->interp;
107 if (interp) {
108 dTHXa(interp);
109 ithread* current_thread;
110#ifdef OEMVS
111 void *ptr;
112#endif
113 PERL_SET_CONTEXT(interp);
bcd9ca9b
JH
114 current_thread = S_ithread_get(aTHX);
115 S_ithread_set(aTHX_ thread);
2e676467
DM
116
117 SvREFCNT_dec(thread->params);
118
119 thread->params = Nullsv;
120 perl_destruct(interp);
121 thread->interp = NULL;
122 }
123 if (interp)
124 perl_free(interp);
125 PERL_SET_CONTEXT(aTHX);
126}
127
68795e93
NIS
128
129/*
2e676467 130 * free an ithread structure and any attached data if its count == 0
68795e93 131 */
bcd9ca9b 132static void
385d56e4 133S_ithread_destruct (pTHX_ ithread* thread)
68795e93 134{
385d56e4
JH
135#ifdef WIN32
136 HANDLE handle;
137#endif
138
68795e93 139 MUTEX_LOCK(&thread->mutex);
385d56e4
JH
140
141 /* Thread is still in use */
68795e93
NIS
142 if (thread->count != 0) {
143 MUTEX_UNLOCK(&thread->mutex);
d1400e48 144 return;
68795e93 145 }
bcd9ca9b 146
385d56e4 147 MUTEX_LOCK(&create_destruct_mutex);
9feacc09
JH
148 /* Main thread (0) is immortal and should never get here */
149 assert(thread->tid != 0);
150
151 /* Remove from circular list of threads */
385d56e4
JH
152 thread->next->prev = thread->prev;
153 thread->prev->next = thread->next;
154 thread->next = NULL;
155 thread->prev = NULL;
62375a60 156 MUTEX_UNLOCK(&create_destruct_mutex);
c2f2a82b 157
385d56e4 158 /* Thread is now disowned */
41fc7aad 159 S_ithread_clear(aTHX_ thread);
385d56e4
JH
160
161#ifdef WIN32
162 handle = thread->handle;
163 thread->handle = NULL;
164#endif
d1400e48 165 MUTEX_UNLOCK(&thread->mutex);
1c3adb19 166 MUTEX_DESTROY(&thread->mutex);
385d56e4 167
c7667023 168#ifdef WIN32
385d56e4
JH
169 if (handle)
170 CloseHandle(handle);
c7667023 171#endif
385d56e4
JH
172
173 /* Call PerlMemShared_free() in the context of the "first" interpreter
174 * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
175 */
176 aTHX = PL_curinterp;
1c3adb19 177 PerlMemShared_free(thread);
68795e93
NIS
178}
179
62375a60
NIS
180int
181Perl_ithread_hook(pTHX)
182{
183 int veto_cleanup = 0;
184 MUTEX_LOCK(&create_destruct_mutex);
185 if (aTHX == PL_curinterp && active_threads != 1) {
4447dfc1
TP
186 if (ckWARN_d(WARN_THREADS))
187 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
f4cc38af 188 active_threads);
62375a60
NIS
189 veto_cleanup = 1;
190 }
191 MUTEX_UNLOCK(&create_destruct_mutex);
192 return veto_cleanup;
193}
194
bcd9ca9b
JH
195static void
196S_ithread_detach(pTHX_ ithread *thread)
62375a60
NIS
197{
198 MUTEX_LOCK(&thread->mutex);
199 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
200 thread->state |= PERL_ITHR_DETACHED;
201#ifdef WIN32
202 CloseHandle(thread->handle);
203 thread->handle = 0;
204#else
205 PERL_THREAD_DETACH(thread->thr);
206#endif
207 }
208 if ((thread->state & PERL_ITHR_FINISHED) &&
209 (thread->state & PERL_ITHR_DETACHED)) {
210 MUTEX_UNLOCK(&thread->mutex);
385d56e4 211 S_ithread_destruct(aTHX_ thread);
62375a60
NIS
212 }
213 else {
214 MUTEX_UNLOCK(&thread->mutex);
215 }
216}
68795e93
NIS
217
218/* MAGIC (in mg.h sense) hooks */
219
220int
221ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
222{
223 ithread *thread = (ithread *) mg->mg_ptr;
45977657 224 SvIV_set(sv, PTR2IV(thread));
68795e93
NIS
225 SvIOK_on(sv);
226 return 0;
227}
228
229int
230ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
231{
232 ithread *thread = (ithread *) mg->mg_ptr;
233 MUTEX_LOCK(&thread->mutex);
68795e93 234 thread->count--;
62375a60 235 if (thread->count == 0) {
1c3adb19
AB
236 if(thread->state & PERL_ITHR_FINISHED &&
237 (thread->state & PERL_ITHR_DETACHED ||
238 thread->state & PERL_ITHR_JOINED))
239 {
240 MUTEX_UNLOCK(&thread->mutex);
385d56e4 241 S_ithread_destruct(aTHX_ thread);
1c3adb19 242 }
1ea20f42
AB
243 else {
244 MUTEX_UNLOCK(&thread->mutex);
245 }
62375a60
NIS
246 }
247 else {
248 MUTEX_UNLOCK(&thread->mutex);
249 }
68795e93
NIS
250 return 0;
251}
252
253int
254ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
255{
256 ithread *thread = (ithread *) mg->mg_ptr;
257 MUTEX_LOCK(&thread->mutex);
68795e93
NIS
258 thread->count++;
259 MUTEX_UNLOCK(&thread->mutex);
260 return 0;
261}
262
263MGVTBL ithread_vtbl = {
264 ithread_mg_get, /* get */
265 0, /* set */
266 0, /* len */
267 0, /* clear */
268 ithread_mg_free, /* free */
269 0, /* copy */
270 ithread_mg_dup /* dup */
271};
272
47ba8780 273
47ba8780 274/*
b1edfb69 275 * Starts executing the thread. Needs to clean up memory a tad better.
68795e93 276 * Passed as the C level function to run in the new thread
b1edfb69 277 */
47ba8780
AB
278
279#ifdef WIN32
f4cc38af 280static THREAD_RET_TYPE
bcd9ca9b 281S_ithread_run(LPVOID arg) {
47ba8780 282#else
f4cc38af 283static void*
bcd9ca9b 284S_ithread_run(void * arg) {
47ba8780 285#endif
5b414d21 286 ithread* thread = (ithread*) arg;
47ba8780 287 dTHXa(thread->interp);
47ba8780 288 PERL_SET_CONTEXT(thread->interp);
bcd9ca9b 289 S_ithread_set(aTHX_ thread);
47ba8780 290
68795e93
NIS
291#if 0
292 /* Far from clear messing with ->thr child-side is a good idea */
293 MUTEX_LOCK(&thread->mutex);
47ba8780
AB
294#ifdef WIN32
295 thread->thr = GetCurrentThreadId();
296#else
297 thread->thr = pthread_self();
298#endif
68795e93
NIS
299 MUTEX_UNLOCK(&thread->mutex);
300#endif
47ba8780 301
47ba8780 302 PL_perl_destruct_level = 2;
4f896ddc 303
47ba8780 304 {
68795e93 305 AV* params = (AV*) SvRV(thread->params);
f4cc38af
JH
306 int len = (int)av_len(params)+1;
307 int ii;
47ba8780 308 dSP;
47ba8780
AB
309 ENTER;
310 SAVETMPS;
311 PUSHMARK(SP);
f4cc38af 312 for(ii = 0; ii < len; ii++) {
68795e93 313 XPUSHs(av_shift(params));
47ba8780
AB
314 }
315 PUTBACK;
f4cc38af 316 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
0405e91e 317
68795e93 318 SPAGAIN;
f4cc38af 319 for (ii=len-1; ii >= 0; ii--) {
e1c44605 320 SV *sv = POPs;
f4cc38af 321 av_store(params, ii, SvREFCNT_inc(sv));
a446a88f 322 }
4447dfc1 323 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
6b3c7930 324 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
a446a88f 325 }
47ba8780
AB
326 FREETMPS;
327 LEAVE;
68795e93 328 SvREFCNT_dec(thread->init_function);
47ba8780
AB
329 }
330
fd58862f 331 PerlIO_flush((PerlIO*)NULL);
68795e93 332 MUTEX_LOCK(&thread->mutex);
62375a60
NIS
333 thread->state |= PERL_ITHR_FINISHED;
334
335 if (thread->state & PERL_ITHR_DETACHED) {
47ba8780 336 MUTEX_UNLOCK(&thread->mutex);
385d56e4 337 S_ithread_destruct(aTHX_ thread);
47ba8780 338 } else {
62375a60
NIS
339 MUTEX_UNLOCK(&thread->mutex);
340 }
91604d21
AB
341 MUTEX_LOCK(&create_destruct_mutex);
342 active_threads--;
91604d21
AB
343 MUTEX_UNLOCK(&create_destruct_mutex);
344
47ba8780
AB
345#ifdef WIN32
346 return (DWORD)0;
e8f2bb9a
JH
347#else
348 return 0;
47ba8780 349#endif
68795e93
NIS
350}
351
f4cc38af 352static SV *
68795e93
NIS
353ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
354{
355 SV *sv;
356 MAGIC *mg;
357 if (inc) {
358 MUTEX_LOCK(&thread->mutex);
359 thread->count++;
68795e93
NIS
360 MUTEX_UNLOCK(&thread->mutex);
361 }
362 if (!obj)
363 obj = newSV(0);
364 sv = newSVrv(obj,classname);
365 sv_setiv(sv,PTR2IV(thread));
366 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
367 mg->mg_flags |= MGf_DUP;
368 SvREADONLY_on(sv);
369 return obj;
370}
47ba8780 371
f4cc38af 372static ithread *
68795e93
NIS
373SV_to_ithread(pTHX_ SV *sv)
374{
68795e93
NIS
375 if (SvROK(sv))
376 {
c05ae023 377 return INT2PTR(ithread*, SvIV(SvRV(sv)));
68795e93
NIS
378 }
379 else
380 {
bcd9ca9b 381 return S_ithread_get(aTHX);
68795e93 382 }
47ba8780
AB
383}
384
47ba8780 385/*
6dfd2d05 386 * ithread->create(); ( aka ithread->new() )
68795e93 387 * Called in context of parent thread
b1edfb69 388 */
47ba8780 389
f4cc38af 390static SV *
bcd9ca9b 391S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
68795e93
NIS
392{
393 ithread* thread;
394 CLONE_PARAMS clone_param;
bcd9ca9b 395 ithread* current_thread = S_ithread_get(aTHX);
3b1c3273
AB
396
397 SV** tmps_tmp = PL_tmps_stack;
f4cc38af 398 IV tmps_ix = PL_tmps_ix;
d94006e8 399#ifndef WIN32
9feacc09
JH
400 int rc_stack_size = 0;
401 int rc_thread_create = 0;
d94006e8 402#endif
3b1c3273 403
c05ae023 404
58c2ef19 405 MUTEX_LOCK(&create_destruct_mutex);
8f77bfdb 406 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
8043fdaf
NC
407 if (!thread) {
408 MUTEX_UNLOCK(&create_destruct_mutex);
409 PerlLIO_write(PerlIO_fileno(Perl_error_log),
410 PL_no_mem, strlen(PL_no_mem));
411 my_exit(1);
412 }
68795e93 413 Zero(thread,1,ithread);
385d56e4
JH
414
415 /* Add to threads list */
68795e93
NIS
416 thread->next = threads;
417 thread->prev = threads->prev;
f42ad631 418 threads->prev = thread;
68795e93 419 thread->prev->next = thread;
385d56e4 420
68795e93
NIS
421 /* Set count to 1 immediately in case thread exits before
422 * we return to caller !
423 */
424 thread->count = 1;
425 MUTEX_INIT(&thread->mutex);
426 thread->tid = tid_counter++;
a446a88f 427 thread->gimme = GIMME_V;
4f896ddc 428
68795e93
NIS
429 /* "Clone" our interpreter into the thread's interpreter
430 * This gives thread access to "static data" and code.
431 */
47ba8780 432
68795e93 433 PerlIO_flush((PerlIO*)NULL);
bcd9ca9b 434 S_ithread_set(aTHX_ thread);
3b1c3273 435
9c98058e
AB
436 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
437 value */
438 PL_srand_called = FALSE; /* Set it to false so we can detect
439 if it gets set during the clone */
3b1c3273 440
47ba8780 441#ifdef WIN32
68795e93 442 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
47ba8780 443#else
68795e93 444 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
47ba8780 445#endif
ba14dd9a 446 /* perl_clone leaves us in new interpreter's context.
c8dae523 447 As it is tricky to spot an implicit aTHX, create a new scope
a446a88f 448 with aTHX matching the context for the duration of
ba14dd9a
NIS
449 our work for new interpreter.
450 */
451 {
452 dTHXa(thread->interp);
9c98058e 453
628ab322
DM
454 MY_CXT_CLONE;
455
58c2ef19 456 /* Here we remove END blocks since they should only run
62375a60 457 in the thread they are created
58c2ef19
NIS
458 */
459 SvREFCNT_dec(PL_endav);
460 PL_endav = newAV();
d1400e48 461 clone_param.flags = 0;
ba14dd9a
NIS
462 thread->init_function = sv_dup(init_function, &clone_param);
463 if (SvREFCNT(thread->init_function) == 0) {
464 SvREFCNT_inc(thread->init_function);
d1400e48 465 }
3b1c3273
AB
466
467
ba14dd9a
NIS
468
469 thread->params = sv_dup(params, &clone_param);
470 SvREFCNT_inc(thread->params);
3b1c3273
AB
471
472
473 /* The code below checks that anything living on
474 the tmps stack and has been cloned (so it lives in the
475 ptr_table) has a refcount higher than 0
476
477 If the refcount is 0 it means that a something on the
478 stack/context was holding a reference to it and
479 since we init_stacks() in perl_clone that won't get
480 cleaned and we will get a leaked scalar.
481 The reason it was cloned was that it lived on the
482 @_ stack.
483
484 Example of this can be found in bugreport 15837
485 where calls in the parameter list end up as a temp
486
487 One could argue that this fix should be in perl_clone
488 */
489
490
491 while (tmps_ix > 0) {
492 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
493 tmps_ix--;
494 if (sv && SvREFCNT(sv) == 0) {
495 SvREFCNT_inc(sv);
496 SvREFCNT_dec(sv);
497 }
498 }
499
500
501
ba14dd9a
NIS
502 SvTEMP_off(thread->init_function);
503 ptr_table_free(PL_ptr_table);
504 PL_ptr_table = NULL;
ffb29f90 505 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
ba14dd9a 506 }
bcd9ca9b 507 S_ithread_set(aTHX_ current_thread);
68795e93 508 PERL_SET_CONTEXT(aTHX);
47ba8780 509
68795e93 510 /* Start the thread */
47ba8780
AB
511
512#ifdef WIN32
bcd9ca9b 513 thread->handle = CreateThread(NULL, 0, S_ithread_run,
47ba8780 514 (LPVOID)thread, 0, &thread->thr);
82c40bf6 515#else
fa26028c
AB
516 {
517 static pthread_attr_t attr;
518 static int attr_inited = 0;
fa26028c
AB
519 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
520 if (!attr_inited) {
521 attr_inited = 1;
522 pthread_attr_init(&attr);
523 }
524# ifdef PTHREAD_ATTR_SETDETACHSTATE
525 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
526# endif
3eb37d38 527# ifdef THREAD_CREATE_NEEDS_STACK
9feacc09 528 rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
3eb37d38
AB
529# endif
530
9feacc09 531 if (! rc_stack_size) {
3ad0b7d6 532#ifdef OLD_PTHREADS_API
9feacc09 533 rc_thread_create = pthread_create( &thread->thr, attr,
bcd9ca9b 534 S_ithread_run, (void *)thread);
47ba8780 535#else
58d975c3 536# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
47cb5ff9 537 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
19a077f6 538# endif
9feacc09 539 rc_thread_create = pthread_create( &thread->thr, &attr,
bcd9ca9b 540 S_ithread_run, (void *)thread);
47ba8780 541#endif
9feacc09 542 }
3ad0b7d6 543 }
82c40bf6 544#endif
bcd9ca9b 545
9feacc09 546 /* Check for errors */
d94006e8 547#ifdef WIN32
9feacc09 548 if (thread->handle == NULL) {
d94006e8 549#else
9feacc09 550 if (rc_stack_size || rc_thread_create) {
d94006e8 551#endif
d94006e8
NC
552 MUTEX_UNLOCK(&create_destruct_mutex);
553 sv_2mortal(params);
385d56e4 554 S_ithread_destruct(aTHX_ thread);
d94006e8 555#ifndef WIN32
9feacc09
JH
556 if (ckWARN_d(WARN_THREADS)) {
557# ifdef THREAD_CREATE_NEEDS_STACK
558 if (rc_stack_size)
559 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", (IV)THREAD_CREATE_NEEDS_STACK, rc_stack_size);
560 else
561# endif
562 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
563 }
d94006e8
NC
564#endif
565 return &PL_sv_undef;
566 }
58c2ef19
NIS
567 active_threads++;
568 MUTEX_UNLOCK(&create_destruct_mutex);
95393226 569 sv_2mortal(params);
3b1c3273 570
68795e93
NIS
571 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
572}
47ba8780 573
f4cc38af 574static SV*
bcd9ca9b 575S_ithread_self (pTHX_ SV *obj, char* Class)
68795e93 576{
bcd9ca9b 577 ithread *thread = S_ithread_get(aTHX);
fe53aa5b
JH
578 if (thread)
579 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
580 else
581 Perl_croak(aTHX_ "panic: cannot find thread data");
c5661c80 582 return NULL; /* silence compiler warning */
47ba8780
AB
583}
584
47ba8780 585
f4cc38af
JH
586/* Joins the thread.
587 * This code takes the return value from the call_sv and sends it back.
588 */
589static AV*
bcd9ca9b 590S_ithread_join(pTHX_ SV *obj)
68795e93
NIS
591{
592 ithread *thread = SV_to_ithread(aTHX_ obj);
593 MUTEX_LOCK(&thread->mutex);
62375a60 594 if (thread->state & PERL_ITHR_DETACHED) {
a446a88f
NIS
595 MUTEX_UNLOCK(&thread->mutex);
596 Perl_croak(aTHX_ "Cannot join a detached thread");
597 }
62375a60 598 else if (thread->state & PERL_ITHR_JOINED) {
a446a88f
NIS
599 MUTEX_UNLOCK(&thread->mutex);
600 Perl_croak(aTHX_ "Thread already joined");
601 }
602 else {
e1c44605 603 AV* retparam;
47ba8780
AB
604#ifdef WIN32
605 DWORD waitcode;
47ba8780
AB
606#else
607 void *retval;
47ba8780 608#endif
47ba8780 609 MUTEX_UNLOCK(&thread->mutex);
68795e93
NIS
610#ifdef WIN32
611 waitcode = WaitForSingleObject(thread->handle, INFINITE);
c7667023
KC
612 CloseHandle(thread->handle);
613 thread->handle = 0;
68795e93
NIS
614#else
615 pthread_join(thread->thr,&retval);
616#endif
47ba8780 617 MUTEX_LOCK(&thread->mutex);
e1c44605 618
62375a60 619 /* sv_dup over the args */
e1c44605 620 {
1d784c90 621 ithread* current_thread;
62375a60 622 AV* params = (AV*) SvRV(thread->params);
b23f1a86 623 PerlInterpreter *other_perl = thread->interp;
e1c44605 624 CLONE_PARAMS clone_params;
3275ba96 625 clone_params.stashes = newAV();
3ae345e3 626 clone_params.flags = CLONEf_JOIN_IN;
e1c44605 627 PL_ptr_table = ptr_table_new();
bcd9ca9b
JH
628 current_thread = S_ithread_get(aTHX);
629 S_ithread_set(aTHX_ thread);
b23f1a86
DM
630 /* ensure 'meaningful' addresses retain their meaning */
631 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
632 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
633 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
0405e91e 634
767c1403 635#if 0
0405e91e
AB
636 {
637 I32 len = av_len(params)+1;
638 I32 i;
639 for(i = 0; i < len; i++) {
767c1403 640 sv_dump(SvRV(AvARRAY(params)[i]));
0405e91e
AB
641 }
642 }
767c1403 643#endif
e1c44605 644 retparam = (AV*) sv_dup((SV*)params, &clone_params);
b4cb676b 645#if 0
0405e91e
AB
646 {
647 I32 len = av_len(retparam)+1;
648 I32 i;
649 for(i = 0; i < len; i++) {
b4cb676b 650 sv_dump(SvRV(AvARRAY(retparam)[i]));
0405e91e
AB
651 }
652 }
b4cb676b 653#endif
bcd9ca9b 654 S_ithread_set(aTHX_ current_thread);
3275ba96 655 SvREFCNT_dec(clone_params.stashes);
e1c44605
AB
656 SvREFCNT_inc(retparam);
657 ptr_table_free(PL_ptr_table);
658 PL_ptr_table = NULL;
659
660 }
6dfd2d05 661 /* We are finished with it */
62375a60 662 thread->state |= PERL_ITHR_JOINED;
41fc7aad 663 S_ithread_clear(aTHX_ thread);
47ba8780 664 MUTEX_UNLOCK(&thread->mutex);
57b48062 665
e1c44605 666 return retparam;
68795e93 667 }
e1c44605 668 return (AV*)NULL;
47ba8780
AB
669}
670
f4cc38af 671static void
bcd9ca9b 672S_ithread_DESTROY(pTHX_ SV *sv)
68795e93
NIS
673{
674 ithread *thread = SV_to_ithread(aTHX_ sv);
68795e93
NIS
675 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
676}
8222d950 677
73e09c8f 678#endif /* USE_ITHREADS */
e1c44605 679
68795e93
NIS
680MODULE = threads PACKAGE = threads PREFIX = ithread_
681PROTOTYPES: DISABLE
8222d950 682
73e09c8f
JH
683#ifdef USE_ITHREADS
684
68795e93 685void
f4cc38af
JH
686ithread_create(...)
687 PREINIT:
688 char *classname;
689 SV *function_to_call;
690 AV *params;
691 int ii;
692 CODE:
693 if (items < 2)
694 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
695
696 classname = (char *)SvPV_nolen(ST(0));
697 function_to_call = ST(1);
698
699 /* Function args */
700 params = newAV();
701 if (items > 2) {
702 for (ii=2; ii < items; ii++) {
703 av_push(params, SvREFCNT_inc(ST(ii)));
704 }
705 }
706
707 /* Create thread */
bcd9ca9b 708 ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
f4cc38af
JH
709 classname,
710 function_to_call,
711 newRV_noinc((SV*)params)));
712 /* XSRETURN(1); - implied */
713
8222d950 714
68795e93 715void
f4cc38af
JH
716ithread_list(...)
717 PREINIT:
718 char *classname;
719 ithread *thr;
720 int list_context;
721 IV count = 0;
722 PPCODE:
723 /* Class method only */
724 if (SvROK(ST(0)))
725 Perl_croak(aTHX_ "Usage: threads->list()");
726 classname = (char *)SvPV_nolen(ST(0));
727
728 /* Calling context */
729 list_context = (GIMME_V == G_ARRAY);
730
731 /* Walk through threads list */
732 MUTEX_LOCK(&create_destruct_mutex);
733 for (thr = threads->next;
734 thr != threads;
735 thr = thr->next)
736 {
737 /* Ignore detached or joined threads */
738 if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
739 continue;
740 }
741 /* Push object on stack if list context */
742 if (list_context) {
743 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
744 }
745 count++;
746 }
747 MUTEX_UNLOCK(&create_destruct_mutex);
748 /* If scalar context, send back count */
749 if (! list_context) {
750 XSRETURN_IV(count);
751 }
678a9b6c
AB
752
753
754void
f4cc38af
JH
755ithread_self(...)
756 PREINIT:
757 char *classname;
758 CODE:
759 /* Class method only */
760 if (SvROK(ST(0)))
761 Perl_croak(aTHX_ "Usage: threads->self()");
762 classname = (char *)SvPV_nolen(ST(0));
763
bcd9ca9b 764 ST(0) = sv_2mortal(S_ithread_self(aTHX_ Nullsv, classname));
f4cc38af 765 /* XSRETURN(1); - implied */
47ba8780 766
47ba8780
AB
767
768void
f4cc38af
JH
769ithread_tid(...)
770 PREINIT:
771 ithread *thread;
772 CODE:
773 thread = SV_to_ithread(aTHX_ ST(0));
774 XST_mUV(0, thread->tid);
775 /* XSRETURN(1); - implied */
776
e1c44605 777
f9dff5f5 778void
f4cc38af
JH
779ithread_join(...)
780 PREINIT:
781 AV *params;
782 int len;
783 int ii;
784 PPCODE:
785 /* Object method only */
786 if (! sv_isobject(ST(0)))
787 Perl_croak(aTHX_ "Usage: $thr->join()");
788
789 /* Join thread and get return values */
bcd9ca9b 790 params = S_ithread_join(aTHX_ ST(0));
f4cc38af
JH
791 if (! params) {
792 XSRETURN_UNDEF;
793 }
794
795 /* Put return values on stack */
796 len = (int)AvFILL(params);
797 for (ii=0; ii <= len; ii++) {
798 SV* param = av_shift(params);
799 XPUSHs(sv_2mortal(param));
800 }
801
802 /* Free return value array */
803 SvREFCNT_dec(params);
804
805
806void
807ithread_yield(...)
808 CODE:
809 YIELD;
810
811
812void
813ithread_detach(...)
814 PREINIT:
815 ithread *thread;
816 CODE:
817 thread = SV_to_ithread(aTHX_ ST(0));
bcd9ca9b 818 S_ithread_detach(aTHX_ thread);
f4cc38af 819
47ba8780
AB
820
821void
f4cc38af
JH
822ithread_DESTROY(...)
823 CODE:
bcd9ca9b 824 S_ithread_DESTROY(aTHX_ ST(0));
f4cc38af
JH
825
826
827void
828ithread_equal(...)
829 CODE:
830 /* Compares TIDs to determine thread equality.
831 * Return 0 on false for backward compatibility.
832 */
833 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
834 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
835 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
836 if (thr1->tid == thr2->tid) {
837 XST_mYES(0);
838 } else {
839 XST_mIV(0, 0);
840 }
841 } else {
842 XST_mIV(0, 0);
843 }
844 /* XSRETURN(1); - implied */
845
47ba8780 846
47ba8780 847void
f4cc38af
JH
848ithread_object(...)
849 PREINIT:
850 char *classname;
851 UV tid;
852 ithread *thr;
853 int found = 0;
854 CODE:
855 /* Class method only */
856 if (SvROK(ST(0)))
857 Perl_croak(aTHX_ "Usage: threads->object($tid)");
858 classname = (char *)SvPV_nolen(ST(0));
859
860 if ((items < 2) || ! SvOK(ST(1))) {
861 XSRETURN_UNDEF;
862 }
863
864 tid = SvUV(ST(1));
865
866 /* Walk through threads list */
867 MUTEX_LOCK(&create_destruct_mutex);
868 for (thr = threads->next;
869 thr != threads;
870 thr = thr->next)
871 {
872 /* Look for TID, but ignore detached or joined threads */
873 if ((thr->tid != tid) ||
874 (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
875 {
876 continue;
877 }
878 /* Put object on stack */
879 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
880 found = 1;
881 break;
882 }
883 MUTEX_UNLOCK(&create_destruct_mutex);
884 if (! found) {
885 XSRETURN_UNDEF;
886 }
887 /* XSRETURN(1); - implied */
888
889
890void
891ithread__handle(...);
892 PREINIT:
893 ithread *thread;
894 CODE:
895 thread = SV_to_ithread(aTHX_ ST(0));
896#ifdef WIN32
897 XST_mUV(0, PTR2UV(thread->handle));
898#else
75ba4ae2 899 XST_mUV(0, PTR2UV(&thread->thr));
f4cc38af
JH
900#endif
901 /* XSRETURN(1); - implied */
68795e93 902
73e09c8f
JH
903#endif /* USE_ITHREADS */
904
68795e93
NIS
905BOOT:
906{
73e09c8f 907#ifdef USE_ITHREADS
9feacc09
JH
908 /* The 'main' thread is thread 0.
909 * It is detached (unjoinable) and immortal.
910 */
68795e93 911 ithread* thread;
9feacc09
JH
912 MY_CXT_INIT;
913
e1c44605 914 PL_perl_destruct_level = 2;
58c2ef19
NIS
915 MUTEX_INIT(&create_destruct_mutex);
916 MUTEX_LOCK(&create_destruct_mutex);
62375a60 917 PL_threadhook = &Perl_ithread_hook;
8f77bfdb 918 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
8043fdaf
NC
919 if (!thread) {
920 PerlLIO_write(PerlIO_fileno(Perl_error_log),
921 PL_no_mem, strlen(PL_no_mem));
922 my_exit(1);
923 }
68795e93
NIS
924 Zero(thread,1,ithread);
925 PL_perl_destruct_level = 2;
926 MUTEX_INIT(&thread->mutex);
385d56e4
JH
927
928 /* Head of the threads list */
68795e93
NIS
929 threads = thread;
930 thread->next = thread;
931 thread->prev = thread;
385d56e4 932
68795e93 933 thread->interp = aTHX;
6dfd2d05 934 thread->count = 1; /* Immortal. */
68795e93 935 thread->tid = tid_counter++;
58c2ef19 936 active_threads++;
1fea7ed3 937 thread->state = PERL_ITHR_DETACHED;
68795e93
NIS
938#ifdef WIN32
939 thread->thr = GetCurrentThreadId();
940#else
941 thread->thr = pthread_self();
942#endif
62375a60 943
bcd9ca9b 944 S_ithread_set(aTHX_ thread);
58c2ef19 945 MUTEX_UNLOCK(&create_destruct_mutex);
73e09c8f 946#endif /* USE_ITHREADS */
68795e93
NIS
947}
948