source: trunk/essentials/dev-lang/perl/ext/threads/threads.xs

Last change on this file was 3181, checked in by bird, 18 years ago

perl 5.8.8
File size: 18.8 KB
Line 
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
14typedef 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
36typedef 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
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)
63#define ithread_yield(thread) (YIELD);
64
65static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
66
67I32 tid_counter = 0;
68I32 known_threads = 0;
69I32 active_threads = 0;
70
71
72void 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
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 }
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
95static void
96S_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 */
129void
130Perl_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
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) {
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
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}
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;
220 SvIV_set(sv, PTR2IV(thread));
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);
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
249int
250ithread_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
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
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
276THREAD_RET_TYPE
277Perl_ithread_run(LPVOID arg) {
278#else
279void*
280Perl_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
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++;
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
369ithread *
370SV_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
387SV *
388Perl_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
562SV*
563Perl_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
578void
579Perl_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
589AV*
590Perl_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
671void
672Perl_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
680MODULE = threads PACKAGE = threads PREFIX = ithread_
681PROTOTYPES: DISABLE
682
683#ifdef USE_ITHREADS
684
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++) {
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
702void
703ithread_list(char *classname)
704PPCODE:
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
724void
725ithread_self(char *classname)
726CODE:
727{
728 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
729 XSRETURN(1);
730}
731
732int
733ithread_tid(ithread *thread)
734
735void
736ithread_join(SV *obj)
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++) {
743 SV* tmp = av_shift(params);
744 XPUSHs(tmp);
745 sv_2mortal(tmp);
746 }
747 SvREFCNT_dec(params);
748}
749
750void
751yield(...)
752CODE:
753{
754 YIELD;
755}
756
757
758void
759ithread_detach(ithread *thread)
760
761void
762ithread_DESTROY(SV *thread)
763
764#endif /* USE_ITHREADS */
765
766BOOT:
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
Note: See TracBrowser for help on using the repository browser.