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