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