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