This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make threads use MY_CXT API rather than using PL_modglobal
[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"
5
73e09c8f
JH
6#ifdef USE_ITHREADS
7
c05ae023 8
68795e93
NIS
9#ifdef WIN32
10#include <windows.h>
11#include <win32thread.h>
68795e93 12#else
5c728af0
IZ
13#ifdef OS2
14typedef perl_os_thread pthread_t;
15#else
68795e93 16#include <pthread.h>
5c728af0 17#endif
68795e93 18#include <thread.h>
68795e93
NIS
19#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
20#ifdef OLD_PTHREADS_API
21#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
68795e93
NIS
22#else
23#define PERL_THREAD_DETACH(t) pthread_detach((t))
c05ae023 24#endif /* OLD_PTHREADS_API */
467f3f08 25#endif
68795e93 26
c05ae023
AB
27
28
29
62375a60
NIS
30/* Values for 'state' member */
31#define PERL_ITHR_JOINABLE 0
32#define PERL_ITHR_DETACHED 1
33#define PERL_ITHR_FINISHED 4
34#define PERL_ITHR_JOINED 2
35
68795e93 36typedef struct ithread_s {
6dfd2d05
JH
37 struct ithread_s *next; /* Next thread in the list */
38 struct ithread_s *prev; /* Prev thread in the list */
68795e93 39 PerlInterpreter *interp; /* The threads interpreter */
6dfd2d05
JH
40 I32 tid; /* Threads module's thread id */
41 perl_mutex mutex; /* Mutex for updating things in this struct */
42 I32 count; /* How many SVs have a reference to us */
43 signed char state; /* Are we detached ? */
a446a88f 44 int gimme; /* Context of create */
68795e93 45 SV* init_function; /* Code to run */
6dfd2d05 46 SV* params; /* Args to pass function */
68795e93
NIS
47#ifdef WIN32
48 DWORD thr; /* OS's idea if thread id */
49 HANDLE handle; /* OS's waitable handle */
50#else
51 pthread_t thr; /* OS's handle for the thread */
52#endif
53} ithread;
54
628ab322
DM
55#define MY_CXT_KEY "threads::_guts" XS_VERSION
56
57typedef struct {
58 ithread *thread;
59} my_cxt_t;
60
61START_MY_CXT
62
63
68795e93
NIS
64ithread *threads;
65
66/* Macros to supply the aTHX_ in an embed.h like manner */
67#define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
68#define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
69#define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
70#define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
71#define ithread_tid(thread) ((thread)->tid)
f9dff5f5 72#define ithread_yield(thread) (YIELD);
68795e93 73
58c2ef19 74static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
68795e93
NIS
75
76I32 tid_counter = 0;
62375a60 77I32 known_threads = 0;
58c2ef19 78I32 active_threads = 0;
c05ae023
AB
79
80
81void Perl_ithread_set (pTHX_ ithread* thread)
82{
628ab322
DM
83 dMY_CXT;
84 MY_CXT.thread = thread;
c05ae023
AB
85}
86
87ithread* Perl_ithread_get (pTHX) {
628ab322
DM
88 dMY_CXT;
89 return MY_CXT.thread;
c05ae023
AB
90}
91
92
2e676467
DM
93/* free any data (such as the perl interpreter) attached to an
94 * ithread structure. This is a bit like undef on SVs, where the SV
95 * isn't freed, but the PVX is.
96 * Must be called with thread->mutex already held
97 */
98
99static void
41fc7aad 100S_ithread_clear(pTHX_ ithread* thread)
2e676467
DM
101{
102 PerlInterpreter *interp;
103 assert(thread->state & PERL_ITHR_FINISHED &&
104 (thread->state & PERL_ITHR_DETACHED ||
105 thread->state & PERL_ITHR_JOINED));
106
107 interp = thread->interp;
108 if (interp) {
109 dTHXa(interp);
110 ithread* current_thread;
111#ifdef OEMVS
112 void *ptr;
113#endif
114 PERL_SET_CONTEXT(interp);
115 current_thread = Perl_ithread_get(aTHX);
116 Perl_ithread_set(aTHX_ thread);
117
118 SvREFCNT_dec(thread->params);
119
120 thread->params = Nullsv;
121 perl_destruct(interp);
122 thread->interp = NULL;
123 }
124 if (interp)
125 perl_free(interp);
126 PERL_SET_CONTEXT(aTHX);
127}
128
68795e93
NIS
129
130/*
2e676467 131 * free an ithread structure and any attached data if its count == 0
68795e93
NIS
132 */
133void
62375a60 134Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
68795e93
NIS
135{
136 MUTEX_LOCK(&thread->mutex);
62375a60 137 if (!thread->next) {
3307a0c5 138 MUTEX_UNLOCK(&thread->mutex);
62375a60
NIS
139 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
140 }
68795e93
NIS
141 if (thread->count != 0) {
142 MUTEX_UNLOCK(&thread->mutex);
d1400e48 143 return;
68795e93 144 }
58c2ef19 145 MUTEX_LOCK(&create_destruct_mutex);
68795e93
NIS
146 /* Remove from circular list of threads */
147 if (thread->next == thread) {
148 /* last one should never get here ? */
149 threads = NULL;
150 }
151 else {
f42ad631
AB
152 thread->next->prev = thread->prev;
153 thread->prev->next = thread->next;
68795e93
NIS
154 if (threads == thread) {
155 threads = thread->next;
156 }
62375a60
NIS
157 thread->next = NULL;
158 thread->prev = NULL;
68795e93 159 }
62375a60
NIS
160 known_threads--;
161 assert( known_threads >= 0 );
ba14dd9a 162#if 0
62375a60
NIS
163 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
164 thread->tid,thread->interp,aTHX, known_threads);
ba14dd9a 165#endif
62375a60
NIS
166 MUTEX_UNLOCK(&create_destruct_mutex);
167 /* Thread is now disowned */
c2f2a82b 168
41fc7aad 169 S_ithread_clear(aTHX_ thread);
d1400e48 170 MUTEX_UNLOCK(&thread->mutex);
1c3adb19 171 MUTEX_DESTROY(&thread->mutex);
c7667023
KC
172#ifdef WIN32
173 if (thread->handle)
174 CloseHandle(thread->handle);
175 thread->handle = 0;
176#endif
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",
188 (IV)active_threads);
62375a60
NIS
189 veto_cleanup = 1;
190 }
191 MUTEX_UNLOCK(&create_destruct_mutex);
192 return veto_cleanup;
193}
194
195void
196Perl_ithread_detach(pTHX_ ithread *thread)
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);
211 Perl_ithread_destruct(aTHX_ thread, "detach");
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);
241 Perl_ithread_destruct(aTHX_ thread, "no reference");
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
68795e93
NIS
280THREAD_RET_TYPE
281Perl_ithread_run(LPVOID arg) {
47ba8780 282#else
68795e93
NIS
283void*
284Perl_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);
c05ae023 289 Perl_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
NIS
305 AV* params = (AV*) SvRV(thread->params);
306 I32 len = av_len(params)+1;
47ba8780
AB
307 int i;
308 dSP;
47ba8780
AB
309 ENTER;
310 SAVETMPS;
311 PUSHMARK(SP);
68795e93
NIS
312 for(i = 0; i < len; i++) {
313 XPUSHs(av_shift(params));
47ba8780
AB
314 }
315 PUTBACK;
a446a88f 316 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
0405e91e 317
68795e93 318 SPAGAIN;
a446a88f 319 for (i=len-1; i >= 0; i--) {
e1c44605
AB
320 SV *sv = POPs;
321 av_store(params, i, 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);
62375a60 337 Perl_ithread_destruct(aTHX_ thread, "detached finish");
47ba8780 338 } else {
62375a60
NIS
339 MUTEX_UNLOCK(&thread->mutex);
340 }
91604d21
AB
341 MUTEX_LOCK(&create_destruct_mutex);
342 active_threads--;
343 assert( active_threads >= 0 );
344 MUTEX_UNLOCK(&create_destruct_mutex);
345
47ba8780
AB
346#ifdef WIN32
347 return (DWORD)0;
e8f2bb9a
JH
348#else
349 return 0;
47ba8780 350#endif
68795e93
NIS
351}
352
353SV *
354ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
355{
356 SV *sv;
357 MAGIC *mg;
358 if (inc) {
359 MUTEX_LOCK(&thread->mutex);
360 thread->count++;
68795e93
NIS
361 MUTEX_UNLOCK(&thread->mutex);
362 }
363 if (!obj)
364 obj = newSV(0);
365 sv = newSVrv(obj,classname);
366 sv_setiv(sv,PTR2IV(thread));
367 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
368 mg->mg_flags |= MGf_DUP;
369 SvREADONLY_on(sv);
370 return obj;
371}
47ba8780 372
68795e93
NIS
373ithread *
374SV_to_ithread(pTHX_ SV *sv)
375{
68795e93
NIS
376 if (SvROK(sv))
377 {
c05ae023 378 return INT2PTR(ithread*, SvIV(SvRV(sv)));
68795e93
NIS
379 }
380 else
381 {
c05ae023 382 return Perl_ithread_get(aTHX);
68795e93 383 }
47ba8780
AB
384}
385
47ba8780 386/*
6dfd2d05 387 * ithread->create(); ( aka ithread->new() )
68795e93 388 * Called in context of parent thread
b1edfb69 389 */
47ba8780 390
68795e93
NIS
391SV *
392Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
393{
394 ithread* thread;
395 CLONE_PARAMS clone_param;
c05ae023 396 ithread* current_thread = Perl_ithread_get(aTHX);
3b1c3273
AB
397
398 SV** tmps_tmp = PL_tmps_stack;
399 I32 tmps_ix = PL_tmps_ix;
d94006e8
NC
400#ifndef WIN32
401 int failure;
402 const char* panic = NULL;
403#endif
3b1c3273 404
c05ae023 405
58c2ef19 406 MUTEX_LOCK(&create_destruct_mutex);
8f77bfdb 407 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
8043fdaf
NC
408 if (!thread) {
409 MUTEX_UNLOCK(&create_destruct_mutex);
410 PerlLIO_write(PerlIO_fileno(Perl_error_log),
411 PL_no_mem, strlen(PL_no_mem));
412 my_exit(1);
413 }
68795e93
NIS
414 Zero(thread,1,ithread);
415 thread->next = threads;
416 thread->prev = threads->prev;
f42ad631 417 threads->prev = thread;
68795e93
NIS
418 thread->prev->next = thread;
419 /* Set count to 1 immediately in case thread exits before
420 * we return to caller !
421 */
422 thread->count = 1;
423 MUTEX_INIT(&thread->mutex);
424 thread->tid = tid_counter++;
a446a88f 425 thread->gimme = GIMME_V;
4f896ddc 426
68795e93
NIS
427 /* "Clone" our interpreter into the thread's interpreter
428 * This gives thread access to "static data" and code.
429 */
47ba8780 430
68795e93 431 PerlIO_flush((PerlIO*)NULL);
c05ae023 432 Perl_ithread_set(aTHX_ thread);
3b1c3273 433
9c98058e
AB
434 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
435 value */
436 PL_srand_called = FALSE; /* Set it to false so we can detect
437 if it gets set during the clone */
3b1c3273 438
47ba8780 439#ifdef WIN32
68795e93 440 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
47ba8780 441#else
68795e93 442 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
47ba8780 443#endif
ba14dd9a 444 /* perl_clone leaves us in new interpreter's context.
c8dae523 445 As it is tricky to spot an implicit aTHX, create a new scope
a446a88f 446 with aTHX matching the context for the duration of
ba14dd9a
NIS
447 our work for new interpreter.
448 */
449 {
450 dTHXa(thread->interp);
9c98058e 451
628ab322
DM
452 MY_CXT_CLONE;
453
58c2ef19 454 /* Here we remove END blocks since they should only run
62375a60 455 in the thread they are created
58c2ef19
NIS
456 */
457 SvREFCNT_dec(PL_endav);
458 PL_endav = newAV();
d1400e48 459 clone_param.flags = 0;
ba14dd9a
NIS
460 thread->init_function = sv_dup(init_function, &clone_param);
461 if (SvREFCNT(thread->init_function) == 0) {
462 SvREFCNT_inc(thread->init_function);
d1400e48 463 }
3b1c3273
AB
464
465
ba14dd9a
NIS
466
467 thread->params = sv_dup(params, &clone_param);
468 SvREFCNT_inc(thread->params);
3b1c3273
AB
469
470
471 /* The code below checks that anything living on
472 the tmps stack and has been cloned (so it lives in the
473 ptr_table) has a refcount higher than 0
474
475 If the refcount is 0 it means that a something on the
476 stack/context was holding a reference to it and
477 since we init_stacks() in perl_clone that won't get
478 cleaned and we will get a leaked scalar.
479 The reason it was cloned was that it lived on the
480 @_ stack.
481
482 Example of this can be found in bugreport 15837
483 where calls in the parameter list end up as a temp
484
485 One could argue that this fix should be in perl_clone
486 */
487
488
489 while (tmps_ix > 0) {
490 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
491 tmps_ix--;
492 if (sv && SvREFCNT(sv) == 0) {
493 SvREFCNT_inc(sv);
494 SvREFCNT_dec(sv);
495 }
496 }
497
498
499
ba14dd9a
NIS
500 SvTEMP_off(thread->init_function);
501 ptr_table_free(PL_ptr_table);
502 PL_ptr_table = NULL;
ffb29f90 503 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
ba14dd9a 504 }
c05ae023 505 Perl_ithread_set(aTHX_ current_thread);
68795e93 506 PERL_SET_CONTEXT(aTHX);
47ba8780 507
68795e93 508 /* Start the thread */
47ba8780
AB
509
510#ifdef WIN32
68795e93 511 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
47ba8780 512 (LPVOID)thread, 0, &thread->thr);
82c40bf6 513#else
fa26028c
AB
514 {
515 static pthread_attr_t attr;
516 static int attr_inited = 0;
fa26028c
AB
517 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
518 if (!attr_inited) {
519 attr_inited = 1;
520 pthread_attr_init(&attr);
521 }
522# ifdef PTHREAD_ATTR_SETDETACHSTATE
523 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
524# endif
3eb37d38
AB
525# ifdef THREAD_CREATE_NEEDS_STACK
526 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
d94006e8 527 panic = "panic: pthread_attr_setstacksize failed";
3eb37d38
AB
528# endif
529
3ad0b7d6 530#ifdef OLD_PTHREADS_API
d94006e8
NC
531 failure
532 = panic ? 1 : pthread_create( &thread->thr, attr,
533 Perl_ithread_run, (void *)thread);
47ba8780 534#else
58d975c3 535# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
47cb5ff9 536 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
19a077f6 537# endif
d94006e8
NC
538 failure
539 = panic ? 1 : pthread_create( &thread->thr, &attr,
540 Perl_ithread_run, (void *)thread);
47ba8780 541#endif
3ad0b7d6 542 }
82c40bf6 543#endif
62375a60 544 known_threads++;
d94006e8
NC
545 if (
546#ifdef WIN32
547 thread->handle == NULL
548#else
549 failure
550#endif
551 ) {
552 MUTEX_UNLOCK(&create_destruct_mutex);
553 sv_2mortal(params);
554 Perl_ithread_destruct(aTHX_ thread, "create failed");
555#ifndef WIN32
556 if (panic)
557 Perl_croak(aTHX_ panic);
558#endif
559 return &PL_sv_undef;
560 }
58c2ef19
NIS
561 active_threads++;
562 MUTEX_UNLOCK(&create_destruct_mutex);
95393226 563 sv_2mortal(params);
3b1c3273 564
68795e93
NIS
565 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
566}
47ba8780 567
68795e93
NIS
568SV*
569Perl_ithread_self (pTHX_ SV *obj, char* Class)
570{
c05ae023 571 ithread *thread = Perl_ithread_get(aTHX);
fe53aa5b
JH
572 if (thread)
573 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
574 else
575 Perl_croak(aTHX_ "panic: cannot find thread data");
c5661c80 576 return NULL; /* silence compiler warning */
47ba8780
AB
577}
578
579/*
e1c44605 580 * Joins the thread this code needs to take the returnvalue from the
68795e93 581 * call_sv and send it back
b1edfb69 582 */
47ba8780 583
68795e93
NIS
584void
585Perl_ithread_CLONE(pTHX_ SV *obj)
586{
4447dfc1
TP
587 if (SvROK(obj)) {
588 ithread *thread = SV_to_ithread(aTHX_ obj);
589 }
590 else if (ckWARN_d(WARN_THREADS)) {
591 Perl_warn(aTHX_ "CLONE %" SVf,obj);
592 }
47ba8780
AB
593}
594
62375a60 595AV*
68795e93
NIS
596Perl_ithread_join(pTHX_ SV *obj)
597{
598 ithread *thread = SV_to_ithread(aTHX_ obj);
599 MUTEX_LOCK(&thread->mutex);
62375a60 600 if (thread->state & PERL_ITHR_DETACHED) {
a446a88f
NIS
601 MUTEX_UNLOCK(&thread->mutex);
602 Perl_croak(aTHX_ "Cannot join a detached thread");
603 }
62375a60 604 else if (thread->state & PERL_ITHR_JOINED) {
a446a88f
NIS
605 MUTEX_UNLOCK(&thread->mutex);
606 Perl_croak(aTHX_ "Thread already joined");
607 }
608 else {
e1c44605 609 AV* retparam;
47ba8780
AB
610#ifdef WIN32
611 DWORD waitcode;
47ba8780
AB
612#else
613 void *retval;
47ba8780 614#endif
47ba8780 615 MUTEX_UNLOCK(&thread->mutex);
68795e93
NIS
616#ifdef WIN32
617 waitcode = WaitForSingleObject(thread->handle, INFINITE);
c7667023
KC
618 CloseHandle(thread->handle);
619 thread->handle = 0;
68795e93
NIS
620#else
621 pthread_join(thread->thr,&retval);
622#endif
47ba8780 623 MUTEX_LOCK(&thread->mutex);
e1c44605 624
62375a60 625 /* sv_dup over the args */
e1c44605 626 {
1d784c90 627 ithread* current_thread;
62375a60 628 AV* params = (AV*) SvRV(thread->params);
b23f1a86 629 PerlInterpreter *other_perl = thread->interp;
e1c44605 630 CLONE_PARAMS clone_params;
3275ba96 631 clone_params.stashes = newAV();
0405e91e 632 clone_params.flags |= CLONEf_JOIN_IN;
e1c44605 633 PL_ptr_table = ptr_table_new();
c05ae023
AB
634 current_thread = Perl_ithread_get(aTHX);
635 Perl_ithread_set(aTHX_ thread);
b23f1a86
DM
636 /* ensure 'meaningful' addresses retain their meaning */
637 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
638 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
639 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
0405e91e 640
767c1403 641#if 0
0405e91e
AB
642 {
643 I32 len = av_len(params)+1;
644 I32 i;
645 for(i = 0; i < len; i++) {
767c1403 646 sv_dump(SvRV(AvARRAY(params)[i]));
0405e91e
AB
647 }
648 }
767c1403 649#endif
e1c44605 650 retparam = (AV*) sv_dup((SV*)params, &clone_params);
b4cb676b 651#if 0
0405e91e
AB
652 {
653 I32 len = av_len(retparam)+1;
654 I32 i;
655 for(i = 0; i < len; i++) {
b4cb676b 656 sv_dump(SvRV(AvARRAY(retparam)[i]));
0405e91e
AB
657 }
658 }
b4cb676b 659#endif
c05ae023 660 Perl_ithread_set(aTHX_ current_thread);
3275ba96 661 SvREFCNT_dec(clone_params.stashes);
e1c44605
AB
662 SvREFCNT_inc(retparam);
663 ptr_table_free(PL_ptr_table);
664 PL_ptr_table = NULL;
665
666 }
6dfd2d05 667 /* We are finished with it */
62375a60 668 thread->state |= PERL_ITHR_JOINED;
41fc7aad 669 S_ithread_clear(aTHX_ thread);
47ba8780 670 MUTEX_UNLOCK(&thread->mutex);
57b48062 671
e1c44605 672 return retparam;
68795e93 673 }
e1c44605 674 return (AV*)NULL;
47ba8780
AB
675}
676
68795e93 677void
68795e93
NIS
678Perl_ithread_DESTROY(pTHX_ SV *sv)
679{
680 ithread *thread = SV_to_ithread(aTHX_ sv);
68795e93
NIS
681 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
682}
8222d950 683
73e09c8f 684#endif /* USE_ITHREADS */
e1c44605 685
68795e93
NIS
686MODULE = threads PACKAGE = threads PREFIX = ithread_
687PROTOTYPES: DISABLE
8222d950 688
73e09c8f
JH
689#ifdef USE_ITHREADS
690
68795e93
NIS
691void
692ithread_new (classname, function_to_call, ...)
693char * classname
694SV * function_to_call
695CODE:
696{
697 AV* params = newAV();
698 if (items > 2) {
699 int i;
700 for(i = 2; i < items ; i++) {
95393226 701 av_push(params, SvREFCNT_inc(ST(i)));
68795e93
NIS
702 }
703 }
704 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
705 XSRETURN(1);
706}
8222d950 707
68795e93 708void
678a9b6c
AB
709ithread_list(char *classname)
710PPCODE:
711{
712 ithread *curr_thread;
713 MUTEX_LOCK(&create_destruct_mutex);
714 curr_thread = threads;
5eb9fe8f 715 if(curr_thread->tid != 0)
2379b307 716 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
678a9b6c 717 while(curr_thread) {
678a9b6c
AB
718 curr_thread = curr_thread->next;
719 if(curr_thread == threads)
720 break;
6794f985 721 if(curr_thread->state & PERL_ITHR_DETACHED ||
5eb9fe8f
AB
722 curr_thread->state & PERL_ITHR_JOINED)
723 continue;
2379b307 724 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
678a9b6c
AB
725 }
726 MUTEX_UNLOCK(&create_destruct_mutex);
727}
728
729
730void
68795e93
NIS
731ithread_self(char *classname)
732CODE:
733{
734 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
735 XSRETURN(1);
736}
47ba8780
AB
737
738int
68795e93 739ithread_tid(ithread *thread)
47ba8780
AB
740
741void
68795e93 742ithread_join(SV *obj)
e1c44605
AB
743PPCODE:
744{
745 AV* params = Perl_ithread_join(aTHX_ obj);
746 int i;
747 I32 len = AvFILL(params);
748 for (i = 0; i <= len; i++) {
1c3adb19
AB
749 SV* tmp = av_shift(params);
750 XPUSHs(tmp);
751 sv_2mortal(tmp);
e1c44605
AB
752 }
753 SvREFCNT_dec(params);
754}
755
f9dff5f5 756void
9d7debe1 757yield(...)
70f2e746
DM
758CODE:
759{
760 YIELD;
761}
762
47ba8780
AB
763
764void
68795e93 765ithread_detach(ithread *thread)
47ba8780 766
47ba8780 767void
68795e93
NIS
768ithread_DESTROY(SV *thread)
769
73e09c8f
JH
770#endif /* USE_ITHREADS */
771
68795e93
NIS
772BOOT:
773{
628ab322 774 MY_CXT_INIT;
73e09c8f 775#ifdef USE_ITHREADS
68795e93 776 ithread* thread;
e1c44605 777 PL_perl_destruct_level = 2;
58c2ef19
NIS
778 MUTEX_INIT(&create_destruct_mutex);
779 MUTEX_LOCK(&create_destruct_mutex);
62375a60 780 PL_threadhook = &Perl_ithread_hook;
8f77bfdb 781 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
8043fdaf
NC
782 if (!thread) {
783 PerlLIO_write(PerlIO_fileno(Perl_error_log),
784 PL_no_mem, strlen(PL_no_mem));
785 my_exit(1);
786 }
68795e93
NIS
787 Zero(thread,1,ithread);
788 PL_perl_destruct_level = 2;
789 MUTEX_INIT(&thread->mutex);
790 threads = thread;
791 thread->next = thread;
792 thread->prev = thread;
793 thread->interp = aTHX;
6dfd2d05 794 thread->count = 1; /* Immortal. */
68795e93 795 thread->tid = tid_counter++;
62375a60 796 known_threads++;
58c2ef19 797 active_threads++;
1fea7ed3 798 thread->state = PERL_ITHR_DETACHED;
68795e93
NIS
799#ifdef WIN32
800 thread->thr = GetCurrentThreadId();
801#else
802 thread->thr = pthread_self();
803#endif
62375a60 804
c05ae023 805 Perl_ithread_set(aTHX_ thread);
58c2ef19 806 MUTEX_UNLOCK(&create_destruct_mutex);
73e09c8f 807#endif /* USE_ITHREADS */
68795e93
NIS
808}
809