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