1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 #ifdef USE_ITHREADS
7
8
9 #ifdef WIN32
10 #include <windows.h>
11 #include <win32thread.h>
12 #else
13 #ifdef OS2
14 typedef perl_os_thread pthread_t;
15 #else
16 #include <pthread.h>
17 #endif
18 #include <thread.h>
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))
22 #else
23 #define PERL_THREAD_DETACH(t) pthread_detach((t))
24 #endif /* OLD_PTHREADS_API */
25 #endif
26
27
28
29
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
36 typedef struct ithread_s {
37 struct ithread_s *next; /* Next thread in the list */
38 struct ithread_s *prev; /* Prev thread in the list */
39 PerlInterpreter *interp; /* The threads interpreter */
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 ? */
44 int gimme; /* Context of create */
45 SV* init_function; /* Code to run */
46 SV* params; /* Args to pass function */
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
55 ithread *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)
63 #define ithread_yield(thread) (YIELD);
64
65 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
66
67 I32 tid_counter = 0;
68 I32 known_threads = 0;
69 I32 active_threads = 0;
70
71
Perl_ithread_set(pTHX_ ithread * thread)72 void Perl_ithread_set (pTHX_ ithread* thread)
73 {
74 SV* thread_sv = newSViv(PTR2IV(thread));
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
Perl_ithread_get(pTHX)80 ithread* 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 }
85 return INT2PTR(ithread*,SvIV(*thread_sv));
86 }
87
88
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
95 static void
S_ithread_clear(pTHX_ ithread * thread)96 S_ithread_clear(pTHX_ ithread* thread)
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
125
126 /*
127 * free an ithread structure and any attached data if its count == 0
128 */
129 void
Perl_ithread_destruct(pTHX_ ithread * thread,const char * why)130 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
131 {
132 MUTEX_LOCK(&thread->mutex);
133 if (!thread->next) {
134 MUTEX_UNLOCK(&thread->mutex);
135 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
136 }
137 if (thread->count != 0) {
138 MUTEX_UNLOCK(&thread->mutex);
139 return;
140 }
141 MUTEX_LOCK(&create_destruct_mutex);
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 {
148 thread->next->prev = thread->prev;
149 thread->prev->next = thread->next;
150 if (threads == thread) {
151 threads = thread->next;
152 }
153 thread->next = NULL;
154 thread->prev = NULL;
155 }
156 known_threads--;
157 assert( known_threads >= 0 );
158 #if 0
159 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
160 thread->tid,thread->interp,aTHX, known_threads);
161 #endif
162 MUTEX_UNLOCK(&create_destruct_mutex);
163 /* Thread is now disowned */
164
165 S_ithread_clear(aTHX_ thread);
166 MUTEX_UNLOCK(&thread->mutex);
167 MUTEX_DESTROY(&thread->mutex);
168 #ifdef WIN32
169 if (thread->handle)
170 CloseHandle(thread->handle);
171 thread->handle = 0;
172 #endif
173 PerlMemShared_free(thread);
174 }
175
176 int
Perl_ithread_hook(pTHX)177 Perl_ithread_hook(pTHX)
178 {
179 int veto_cleanup = 0;
180 MUTEX_LOCK(&create_destruct_mutex);
181 if (aTHX == PL_curinterp && active_threads != 1) {
182 if (ckWARN_d(WARN_THREADS))
183 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
184 (IV)active_threads);
185 veto_cleanup = 1;
186 }
187 MUTEX_UNLOCK(&create_destruct_mutex);
188 return veto_cleanup;
189 }
190
191 void
Perl_ithread_detach(pTHX_ ithread * thread)192 Perl_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 }
213
214 /* MAGIC (in mg.h sense) hooks */
215
216 int
ithread_mg_get(pTHX_ SV * sv,MAGIC * mg)217 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
218 {
219 ithread *thread = (ithread *) mg->mg_ptr;
220 SvIV_set(sv, PTR2IV(thread));
221 SvIOK_on(sv);
222 return 0;
223 }
224
225 int
ithread_mg_free(pTHX_ SV * sv,MAGIC * mg)226 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
227 {
228 ithread *thread = (ithread *) mg->mg_ptr;
229 MUTEX_LOCK(&thread->mutex);
230 thread->count--;
231 if (thread->count == 0) {
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 }
239 else {
240 MUTEX_UNLOCK(&thread->mutex);
241 }
242 }
243 else {
244 MUTEX_UNLOCK(&thread->mutex);
245 }
246 return 0;
247 }
248
249 int
ithread_mg_dup(pTHX_ MAGIC * mg,CLONE_PARAMS * param)250 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
251 {
252 ithread *thread = (ithread *) mg->mg_ptr;
253 MUTEX_LOCK(&thread->mutex);
254 thread->count++;
255 MUTEX_UNLOCK(&thread->mutex);
256 return 0;
257 }
258
259 MGVTBL 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
269
270 /*
271 * Starts executing the thread. Needs to clean up memory a tad better.
272 * Passed as the C level function to run in the new thread
273 */
274
275 #ifdef WIN32
276 THREAD_RET_TYPE
Perl_ithread_run(LPVOID arg)277 Perl_ithread_run(LPVOID arg) {
278 #else
279 void*
280 Perl_ithread_run(void * arg) {
281 #endif
282 ithread* thread = (ithread*) arg;
283 dTHXa(thread->interp);
284 PERL_SET_CONTEXT(thread->interp);
285 Perl_ithread_set(aTHX_ thread);
286
287 #if 0
288 /* Far from clear messing with ->thr child-side is a good idea */
289 MUTEX_LOCK(&thread->mutex);
290 #ifdef WIN32
291 thread->thr = GetCurrentThreadId();
292 #else
293 thread->thr = pthread_self();
294 #endif
295 MUTEX_UNLOCK(&thread->mutex);
296 #endif
297
298 PL_perl_destruct_level = 2;
299
300 {
301 AV* params = (AV*) SvRV(thread->params);
302 I32 len = av_len(params)+1;
303 int i;
304 dSP;
305 ENTER;
306 SAVETMPS;
307 PUSHMARK(SP);
308 for(i = 0; i < len; i++) {
309 XPUSHs(av_shift(params));
310 }
311 PUTBACK;
312 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
313
314 SPAGAIN;
315 for (i=len-1; i >= 0; i--) {
316 SV *sv = POPs;
317 av_store(params, i, SvREFCNT_inc(sv));
318 }
319 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
320 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
321 }
322 FREETMPS;
323 LEAVE;
324 SvREFCNT_dec(thread->init_function);
325 }
326
327 PerlIO_flush((PerlIO*)NULL);
328 MUTEX_LOCK(&thread->mutex);
329 thread->state |= PERL_ITHR_FINISHED;
330
331 if (thread->state & PERL_ITHR_DETACHED) {
332 MUTEX_UNLOCK(&thread->mutex);
333 Perl_ithread_destruct(aTHX_ thread, "detached finish");
334 } else {
335 MUTEX_UNLOCK(&thread->mutex);
336 }
337 MUTEX_LOCK(&create_destruct_mutex);
338 active_threads--;
339 assert( active_threads >= 0 );
340 MUTEX_UNLOCK(&create_destruct_mutex);
341
342 #ifdef WIN32
343 return (DWORD)0;
344 #else
345 return 0;
346 #endif
347 }
348
349 SV *
350 ithread_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++;
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 }
368
369 ithread *
370 SV_to_ithread(pTHX_ SV *sv)
371 {
372 if (SvROK(sv))
373 {
374 return INT2PTR(ithread*, SvIV(SvRV(sv)));
375 }
376 else
377 {
378 return Perl_ithread_get(aTHX);
379 }
380 }
381
382 /*
383 * ithread->create(); ( aka ithread->new() )
384 * Called in context of parent thread
385 */
386
387 SV *
388 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
389 {
390 ithread* thread;
391 CLONE_PARAMS clone_param;
392 ithread* current_thread = Perl_ithread_get(aTHX);
393
394 SV** tmps_tmp = PL_tmps_stack;
395 I32 tmps_ix = PL_tmps_ix;
396 #ifndef WIN32
397 int failure;
398 const char* panic = NULL;
399 #endif
400
401
402 MUTEX_LOCK(&create_destruct_mutex);
403 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
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 }
410 Zero(thread,1,ithread);
411 thread->next = threads;
412 thread->prev = threads->prev;
413 threads->prev = thread;
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++;
421 thread->gimme = GIMME_V;
422
423 /* "Clone" our interpreter into the thread's interpreter
424 * This gives thread access to "static data" and code.
425 */
426
427 PerlIO_flush((PerlIO*)NULL);
428 Perl_ithread_set(aTHX_ thread);
429
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 */
434
435 #ifdef WIN32
436 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
437 #else
438 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
439 #endif
440 /* perl_clone leaves us in new interpreter's context.
441 As it is tricky to spot an implicit aTHX, create a new scope
442 with aTHX matching the context for the duration of
443 our work for new interpreter.
444 */
445 {
446 dTHXa(thread->interp);
447
448 /* Here we remove END blocks since they should only run
449 in the thread they are created
450 */
451 SvREFCNT_dec(PL_endav);
452 PL_endav = newAV();
453 clone_param.flags = 0;
454 thread->init_function = sv_dup(init_function, &clone_param);
455 if (SvREFCNT(thread->init_function) == 0) {
456 SvREFCNT_inc(thread->init_function);
457 }
458
459
460
461 thread->params = sv_dup(params, &clone_param);
462 SvREFCNT_inc(thread->params);
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
494 SvTEMP_off(thread->init_function);
495 ptr_table_free(PL_ptr_table);
496 PL_ptr_table = NULL;
497 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
498 }
499 Perl_ithread_set(aTHX_ current_thread);
500 PERL_SET_CONTEXT(aTHX);
501
502 /* Start the thread */
503
504 #ifdef WIN32
505 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
506 (LPVOID)thread, 0, &thread->thr);
507 #else
508 {
509 static pthread_attr_t attr;
510 static int attr_inited = 0;
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
519 # ifdef THREAD_CREATE_NEEDS_STACK
520 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
521 panic = "panic: pthread_attr_setstacksize failed";
522 # endif
523
524 #ifdef OLD_PTHREADS_API
525 failure
526 = panic ? 1 : pthread_create( &thread->thr, attr,
527 Perl_ithread_run, (void *)thread);
528 #else
529 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
530 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
531 # endif
532 failure
533 = panic ? 1 : pthread_create( &thread->thr, &attr,
534 Perl_ithread_run, (void *)thread);
535 #endif
536 }
537 #endif
538 known_threads++;
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 }
555 active_threads++;
556 MUTEX_UNLOCK(&create_destruct_mutex);
557 sv_2mortal(params);
558
559 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
560 }
561
562 SV*
563 Perl_ithread_self (pTHX_ SV *obj, char* Class)
564 {
565 ithread *thread = Perl_ithread_get(aTHX);
566 if (thread)
567 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
568 else
569 Perl_croak(aTHX_ "panic: cannot find thread data");
570 return NULL; /* silence compiler warning */
571 }
572
573 /*
574 * Joins the thread this code needs to take the returnvalue from the
575 * call_sv and send it back
576 */
577
578 void
579 Perl_ithread_CLONE(pTHX_ SV *obj)
580 {
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 }
587 }
588
589 AV*
590 Perl_ithread_join(pTHX_ SV *obj)
591 {
592 ithread *thread = SV_to_ithread(aTHX_ obj);
593 MUTEX_LOCK(&thread->mutex);
594 if (thread->state & PERL_ITHR_DETACHED) {
595 MUTEX_UNLOCK(&thread->mutex);
596 Perl_croak(aTHX_ "Cannot join a detached thread");
597 }
598 else if (thread->state & PERL_ITHR_JOINED) {
599 MUTEX_UNLOCK(&thread->mutex);
600 Perl_croak(aTHX_ "Thread already joined");
601 }
602 else {
603 AV* retparam;
604 #ifdef WIN32
605 DWORD waitcode;
606 #else
607 void *retval;
608 #endif
609 MUTEX_UNLOCK(&thread->mutex);
610 #ifdef WIN32
611 waitcode = WaitForSingleObject(thread->handle, INFINITE);
612 CloseHandle(thread->handle);
613 thread->handle = 0;
614 #else
615 pthread_join(thread->thr,&retval);
616 #endif
617 MUTEX_LOCK(&thread->mutex);
618
619 /* sv_dup over the args */
620 {
621 ithread* current_thread;
622 AV* params = (AV*) SvRV(thread->params);
623 PerlInterpreter *other_perl = thread->interp;
624 CLONE_PARAMS clone_params;
625 clone_params.stashes = newAV();
626 clone_params.flags |= CLONEf_JOIN_IN;
627 PL_ptr_table = ptr_table_new();
628 current_thread = Perl_ithread_get(aTHX);
629 Perl_ithread_set(aTHX_ thread);
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);
634
635 #if 0
636 {
637 I32 len = av_len(params)+1;
638 I32 i;
639 for(i = 0; i < len; i++) {
640 sv_dump(SvRV(AvARRAY(params)[i]));
641 }
642 }
643 #endif
644 retparam = (AV*) sv_dup((SV*)params, &clone_params);
645 #if 0
646 {
647 I32 len = av_len(retparam)+1;
648 I32 i;
649 for(i = 0; i < len; i++) {
650 sv_dump(SvRV(AvARRAY(retparam)[i]));
651 }
652 }
653 #endif
654 Perl_ithread_set(aTHX_ current_thread);
655 SvREFCNT_dec(clone_params.stashes);
656 SvREFCNT_inc(retparam);
657 ptr_table_free(PL_ptr_table);
658 PL_ptr_table = NULL;
659
660 }
661 /* We are finished with it */
662 thread->state |= PERL_ITHR_JOINED;
663 S_ithread_clear(aTHX_ thread);
664 MUTEX_UNLOCK(&thread->mutex);
665
666 return retparam;
667 }
668 return (AV*)NULL;
669 }
670
671 void
672 Perl_ithread_DESTROY(pTHX_ SV *sv)
673 {
674 ithread *thread = SV_to_ithread(aTHX_ sv);
675 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
676 }
677
678 #endif /* USE_ITHREADS */
679
680 MODULE = threads PACKAGE = threads PREFIX = ithread_
681 PROTOTYPES: DISABLE
682
683 #ifdef USE_ITHREADS
684
685 void
686 ithread_new (classname, function_to_call, ...)
687 char * classname
688 SV * function_to_call
689 CODE:
690 {
691 AV* params = newAV();
692 if (items > 2) {
693 int i;
694 for(i = 2; i < items ; i++) {
695 av_push(params, SvREFCNT_inc(ST(i)));
696 }
697 }
698 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
699 XSRETURN(1);
700 }
701
702 void
703 ithread_list(char *classname)
704 PPCODE:
705 {
706 ithread *curr_thread;
707 MUTEX_LOCK(&create_destruct_mutex);
708 curr_thread = threads;
709 if(curr_thread->tid != 0)
710 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
711 while(curr_thread) {
712 curr_thread = curr_thread->next;
713 if(curr_thread == threads)
714 break;
715 if(curr_thread->state & PERL_ITHR_DETACHED ||
716 curr_thread->state & PERL_ITHR_JOINED)
717 continue;
718 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
719 }
720 MUTEX_UNLOCK(&create_destruct_mutex);
721 }
722
723
724 void
725 ithread_self(char *classname)
726 CODE:
727 {
728 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
729 XSRETURN(1);
730 }
731
732 int
733 ithread_tid(ithread *thread)
734
735 void
736 ithread_join(SV *obj)
737 PPCODE:
738 {
739 AV* params = Perl_ithread_join(aTHX_ obj);
740 int i;
741 I32 len = AvFILL(params);
742 for (i = 0; i <= len; i++) {
743 SV* tmp = av_shift(params);
744 XPUSHs(tmp);
745 sv_2mortal(tmp);
746 }
747 SvREFCNT_dec(params);
748 }
749
750 void
751 yield(...)
752 CODE:
753 {
754 YIELD;
755 }
756
757
758 void
759 ithread_detach(ithread *thread)
760
761 void
762 ithread_DESTROY(SV *thread)
763
764 #endif /* USE_ITHREADS */
765
766 BOOT:
767 {
768 #ifdef USE_ITHREADS
769 ithread* thread;
770 PL_perl_destruct_level = 2;
771 MUTEX_INIT(&create_destruct_mutex);
772 MUTEX_LOCK(&create_destruct_mutex);
773 PL_threadhook = &Perl_ithread_hook;
774 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
775 if (!thread) {
776 PerlLIO_write(PerlIO_fileno(Perl_error_log),
777 PL_no_mem, strlen(PL_no_mem));
778 my_exit(1);
779 }
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;
787 thread->count = 1; /* Immortal. */
788 thread->tid = tid_counter++;
789 known_threads++;
790 active_threads++;
791 thread->state = PERL_ITHR_DETACHED;
792 #ifdef WIN32
793 thread->thr = GetCurrentThreadId();
794 #else
795 thread->thr = pthread_self();
796 #endif
797
798 Perl_ithread_set(aTHX_ thread);
799 MUTEX_UNLOCK(&create_destruct_mutex);
800 #endif /* USE_ITHREADS */
801 }
802
803