Commit | Line | Data |
68795e93 |
1 | #define PERL_NO_GET_CONTEXT |
2 | #include "EXTERN.h" |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
5 | |
73e09c8f |
6 | #ifdef USE_ITHREADS |
7 | |
68795e93 |
8 | #ifdef WIN32 |
9 | #include <windows.h> |
10 | #include <win32thread.h> |
11 | #define PERL_THREAD_SETSPECIFIC(k,v) TlsSetValue(k,v) |
12 | #define PERL_THREAD_GETSPECIFIC(k,v) v = TlsGetValue(k) |
13 | #define PERL_THREAD_ALLOC_SPECIFIC(k) \ |
14 | STMT_START {\ |
15 | if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\ |
6dfd2d05 |
16 | PerlIO_printf(PerlIO_stderr(), "panic threads.xs: TlsAlloc");\ |
68795e93 |
17 | exit(1);\ |
18 | }\ |
19 | } STMT_END |
20 | #else |
5c728af0 |
21 | #ifdef OS2 |
22 | typedef perl_os_thread pthread_t; |
23 | #else |
68795e93 |
24 | #include <pthread.h> |
5c728af0 |
25 | #endif |
68795e93 |
26 | #include <thread.h> |
27 | |
28 | #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) |
29 | #ifdef OLD_PTHREADS_API |
30 | #define PERL_THREAD_DETACH(t) pthread_detach(&(t)) |
31 | #define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v) |
32 | #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\ |
33 | if(pthread_keycreate(&(k),0)) {\ |
ddcc6fdc |
34 | PerlIO_printf(PerlIO_stderr(), "panic threads.xs: pthread_key_create");\ |
68795e93 |
35 | exit(1);\ |
36 | }\ |
37 | } STMT_END |
38 | #else |
39 | #define PERL_THREAD_DETACH(t) pthread_detach((t)) |
40 | #define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k) |
41 | #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\ |
42 | if(pthread_key_create(&(k),0)) {\ |
ddcc6fdc |
43 | PerlIO_printf(PerlIO_stderr(), "panic threads.xs: pthread_key_create");\ |
68795e93 |
44 | exit(1);\ |
45 | }\ |
46 | } STMT_END |
47 | #endif |
48 | #endif |
467f3f08 |
49 | #ifdef OEMVS |
50 | # define PERL_THREAD_GETSPECIFIC_THREAD(k, t) STMT_START { void *gsptr; PERL_THREAD_GETSPECIFIC(k, gsptr); t = (ithread *) gsptr; } STMT_END |
51 | #else |
52 | # define PERL_THREAD_GETSPECIFIC_THREAD(k, t) PERL_THREAD_GETSPECIFIC(k, t) |
53 | #endif |
68795e93 |
54 | |
62375a60 |
55 | /* Values for 'state' member */ |
56 | #define PERL_ITHR_JOINABLE 0 |
57 | #define PERL_ITHR_DETACHED 1 |
58 | #define PERL_ITHR_FINISHED 4 |
59 | #define PERL_ITHR_JOINED 2 |
60 | |
68795e93 |
61 | typedef struct ithread_s { |
6dfd2d05 |
62 | struct ithread_s *next; /* Next thread in the list */ |
63 | struct ithread_s *prev; /* Prev thread in the list */ |
68795e93 |
64 | PerlInterpreter *interp; /* The threads interpreter */ |
6dfd2d05 |
65 | I32 tid; /* Threads module's thread id */ |
66 | perl_mutex mutex; /* Mutex for updating things in this struct */ |
67 | I32 count; /* How many SVs have a reference to us */ |
68 | signed char state; /* Are we detached ? */ |
a446a88f |
69 | int gimme; /* Context of create */ |
68795e93 |
70 | SV* init_function; /* Code to run */ |
6dfd2d05 |
71 | SV* params; /* Args to pass function */ |
68795e93 |
72 | #ifdef WIN32 |
73 | DWORD thr; /* OS's idea if thread id */ |
74 | HANDLE handle; /* OS's waitable handle */ |
75 | #else |
76 | pthread_t thr; /* OS's handle for the thread */ |
77 | #endif |
78 | } ithread; |
79 | |
80 | ithread *threads; |
81 | |
82 | /* Macros to supply the aTHX_ in an embed.h like manner */ |
83 | #define ithread_join(thread) Perl_ithread_join(aTHX_ thread) |
84 | #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread) |
85 | #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread) |
86 | #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread) |
87 | #define ithread_tid(thread) ((thread)->tid) |
f9dff5f5 |
88 | #define ithread_yield(thread) (YIELD); |
68795e93 |
89 | |
58c2ef19 |
90 | static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/ |
68795e93 |
91 | |
92 | I32 tid_counter = 0; |
62375a60 |
93 | I32 known_threads = 0; |
58c2ef19 |
94 | I32 active_threads = 0; |
68795e93 |
95 | perl_key self_key; |
96 | |
97 | /* |
98 | * Clear up after thread is done with |
99 | */ |
100 | void |
62375a60 |
101 | Perl_ithread_destruct (pTHX_ ithread* thread, const char *why) |
68795e93 |
102 | { |
103 | MUTEX_LOCK(&thread->mutex); |
62375a60 |
104 | if (!thread->next) { |
105 | Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why); |
106 | } |
68795e93 |
107 | if (thread->count != 0) { |
108 | MUTEX_UNLOCK(&thread->mutex); |
d1400e48 |
109 | return; |
68795e93 |
110 | } |
58c2ef19 |
111 | MUTEX_LOCK(&create_destruct_mutex); |
68795e93 |
112 | /* Remove from circular list of threads */ |
113 | if (thread->next == thread) { |
114 | /* last one should never get here ? */ |
115 | threads = NULL; |
116 | } |
117 | else { |
f42ad631 |
118 | thread->next->prev = thread->prev; |
119 | thread->prev->next = thread->next; |
68795e93 |
120 | if (threads == thread) { |
121 | threads = thread->next; |
122 | } |
62375a60 |
123 | thread->next = NULL; |
124 | thread->prev = NULL; |
68795e93 |
125 | } |
62375a60 |
126 | known_threads--; |
127 | assert( known_threads >= 0 ); |
ba14dd9a |
128 | #if 0 |
62375a60 |
129 | Perl_warn(aTHX_ "destruct %d @ %p by %p now %d", |
130 | thread->tid,thread->interp,aTHX, known_threads); |
ba14dd9a |
131 | #endif |
62375a60 |
132 | MUTEX_UNLOCK(&create_destruct_mutex); |
133 | /* Thread is now disowned */ |
c2f2a82b |
134 | |
135 | if(thread->interp) { |
1c3adb19 |
136 | dTHXa(thread->interp); |
c2f2a82b |
137 | ithread* current_thread; |
3e79ab2c |
138 | #ifdef OEMVS |
139 | void *ptr; |
140 | #endif |
68795e93 |
141 | PERL_SET_CONTEXT(thread->interp); |
467f3f08 |
142 | PERL_THREAD_GETSPECIFIC_THREAD(self_key, current_thread); |
c2f2a82b |
143 | PERL_THREAD_SETSPECIFIC(self_key,thread); |
3b1c3273 |
144 | |
145 | |
146 | |
1c3adb19 |
147 | SvREFCNT_dec(thread->params); |
3b1c3273 |
148 | |
149 | |
150 | |
1c3adb19 |
151 | thread->params = Nullsv; |
c2f2a82b |
152 | perl_destruct(thread->interp); |
153 | perl_free(thread->interp); |
68795e93 |
154 | thread->interp = NULL; |
c2f2a82b |
155 | PERL_THREAD_SETSPECIFIC(self_key,current_thread); |
156 | |
68795e93 |
157 | } |
d1400e48 |
158 | MUTEX_UNLOCK(&thread->mutex); |
1c3adb19 |
159 | MUTEX_DESTROY(&thread->mutex); |
160 | PerlMemShared_free(thread); |
1d784c90 |
161 | |
64821230 |
162 | PERL_SET_CONTEXT(aTHX); |
68795e93 |
163 | } |
164 | |
62375a60 |
165 | int |
166 | Perl_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 |
173 | veto_cleanup = 1; |
174 | } |
175 | MUTEX_UNLOCK(&create_destruct_mutex); |
176 | return veto_cleanup; |
177 | } |
178 | |
179 | void |
180 | Perl_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 |
201 | |
202 | /* MAGIC (in mg.h sense) hooks */ |
203 | |
204 | int |
205 | ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) |
206 | { |
207 | ithread *thread = (ithread *) mg->mg_ptr; |
208 | SvIVX(sv) = PTR2IV(thread); |
209 | SvIOK_on(sv); |
210 | return 0; |
211 | } |
212 | |
213 | int |
214 | ithread_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 |
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 |
227 | else { |
228 | MUTEX_UNLOCK(&thread->mutex); |
229 | } |
62375a60 |
230 | } |
231 | else { |
232 | MUTEX_UNLOCK(&thread->mutex); |
233 | } |
68795e93 |
234 | return 0; |
235 | } |
236 | |
237 | int |
238 | ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
239 | { |
240 | ithread *thread = (ithread *) mg->mg_ptr; |
241 | MUTEX_LOCK(&thread->mutex); |
68795e93 |
242 | thread->count++; |
243 | MUTEX_UNLOCK(&thread->mutex); |
244 | return 0; |
245 | } |
246 | |
247 | MGVTBL 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 |
262 | |
263 | #ifdef WIN32 |
68795e93 |
264 | THREAD_RET_TYPE |
265 | Perl_ithread_run(LPVOID arg) { |
47ba8780 |
266 | #else |
68795e93 |
267 | void* |
268 | Perl_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); |
68795e93 |
273 | PERL_THREAD_SETSPECIFIC(self_key,thread); |
47ba8780 |
274 | |
68795e93 |
275 | #if 0 |
276 | /* Far from clear messing with ->thr child-side is a good idea */ |
277 | MUTEX_LOCK(&thread->mutex); |
47ba8780 |
278 | #ifdef WIN32 |
279 | thread->thr = GetCurrentThreadId(); |
280 | #else |
281 | thread->thr = pthread_self(); |
282 | #endif |
68795e93 |
283 | MUTEX_UNLOCK(&thread->mutex); |
284 | #endif |
47ba8780 |
285 | |
47ba8780 |
286 | PL_perl_destruct_level = 2; |
4f896ddc |
287 | |
47ba8780 |
288 | { |
68795e93 |
289 | AV* params = (AV*) SvRV(thread->params); |
290 | I32 len = av_len(params)+1; |
47ba8780 |
291 | int i; |
292 | dSP; |
47ba8780 |
293 | ENTER; |
294 | SAVETMPS; |
295 | PUSHMARK(SP); |
68795e93 |
296 | for(i = 0; i < len; i++) { |
297 | XPUSHs(av_shift(params)); |
47ba8780 |
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 |
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 |
310 | FREETMPS; |
311 | LEAVE; |
68795e93 |
312 | SvREFCNT_dec(thread->init_function); |
47ba8780 |
313 | } |
314 | |
fd58862f |
315 | PerlIO_flush((PerlIO*)NULL); |
68795e93 |
316 | MUTEX_LOCK(&thread->mutex); |
62375a60 |
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 |
323 | MUTEX_UNLOCK(&thread->mutex); |
324 | } |
91604d21 |
325 | MUTEX_LOCK(&create_destruct_mutex); |
326 | active_threads--; |
327 | assert( active_threads >= 0 ); |
328 | MUTEX_UNLOCK(&create_destruct_mutex); |
329 | |
47ba8780 |
330 | #ifdef WIN32 |
331 | return (DWORD)0; |
e8f2bb9a |
332 | #else |
333 | return 0; |
47ba8780 |
334 | #endif |
68795e93 |
335 | } |
336 | |
337 | SV * |
338 | ithread_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 |
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 |
357 | ithread * |
358 | SV_to_ithread(pTHX_ SV *sv) |
359 | { |
360 | ithread *thread; |
361 | if (SvROK(sv)) |
362 | { |
363 | thread = INT2PTR(ithread*, SvIV(SvRV(sv))); |
364 | } |
365 | else |
366 | { |
467f3f08 |
367 | PERL_THREAD_GETSPECIFIC_THREAD(self_key, thread); |
68795e93 |
368 | } |
369 | return thread; |
47ba8780 |
370 | } |
371 | |
47ba8780 |
372 | /* |
6dfd2d05 |
373 | * ithread->create(); ( aka ithread->new() ) |
68795e93 |
374 | * Called in context of parent thread |
b1edfb69 |
375 | */ |
47ba8780 |
376 | |
68795e93 |
377 | SV * |
378 | Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params) |
379 | { |
380 | ithread* thread; |
381 | CLONE_PARAMS clone_param; |
1d784c90 |
382 | ithread* current_thread; |
3b1c3273 |
383 | |
384 | SV** tmps_tmp = PL_tmps_stack; |
385 | I32 tmps_ix = PL_tmps_ix; |
386 | |
467f3f08 |
387 | PERL_THREAD_GETSPECIFIC_THREAD(self_key, current_thread); |
58c2ef19 |
388 | MUTEX_LOCK(&create_destruct_mutex); |
68795e93 |
389 | thread = PerlMemShared_malloc(sizeof(ithread)); |
390 | Zero(thread,1,ithread); |
391 | thread->next = threads; |
392 | thread->prev = threads->prev; |
f42ad631 |
393 | threads->prev = thread; |
68795e93 |
394 | thread->prev->next = thread; |
395 | /* Set count to 1 immediately in case thread exits before |
396 | * we return to caller ! |
397 | */ |
398 | thread->count = 1; |
399 | MUTEX_INIT(&thread->mutex); |
400 | thread->tid = tid_counter++; |
a446a88f |
401 | thread->gimme = GIMME_V; |
4f896ddc |
402 | |
68795e93 |
403 | /* "Clone" our interpreter into the thread's interpreter |
404 | * This gives thread access to "static data" and code. |
405 | */ |
47ba8780 |
406 | |
68795e93 |
407 | PerlIO_flush((PerlIO*)NULL); |
1d784c90 |
408 | PERL_THREAD_SETSPECIFIC(self_key,thread); |
3b1c3273 |
409 | |
9c98058e |
410 | SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct |
411 | value */ |
412 | PL_srand_called = FALSE; /* Set it to false so we can detect |
413 | if it gets set during the clone */ |
3b1c3273 |
414 | |
47ba8780 |
415 | #ifdef WIN32 |
68795e93 |
416 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); |
47ba8780 |
417 | #else |
68795e93 |
418 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); |
47ba8780 |
419 | #endif |
ba14dd9a |
420 | /* perl_clone leaves us in new interpreter's context. |
c8dae523 |
421 | As it is tricky to spot an implicit aTHX, create a new scope |
a446a88f |
422 | with aTHX matching the context for the duration of |
ba14dd9a |
423 | our work for new interpreter. |
424 | */ |
425 | { |
426 | dTHXa(thread->interp); |
9c98058e |
427 | |
58c2ef19 |
428 | /* Here we remove END blocks since they should only run |
62375a60 |
429 | in the thread they are created |
58c2ef19 |
430 | */ |
431 | SvREFCNT_dec(PL_endav); |
432 | PL_endav = newAV(); |
d1400e48 |
433 | clone_param.flags = 0; |
ba14dd9a |
434 | thread->init_function = sv_dup(init_function, &clone_param); |
435 | if (SvREFCNT(thread->init_function) == 0) { |
436 | SvREFCNT_inc(thread->init_function); |
d1400e48 |
437 | } |
3b1c3273 |
438 | |
439 | |
ba14dd9a |
440 | |
441 | thread->params = sv_dup(params, &clone_param); |
442 | SvREFCNT_inc(thread->params); |
3b1c3273 |
443 | |
444 | |
445 | /* The code below checks that anything living on |
446 | the tmps stack and has been cloned (so it lives in the |
447 | ptr_table) has a refcount higher than 0 |
448 | |
449 | If the refcount is 0 it means that a something on the |
450 | stack/context was holding a reference to it and |
451 | since we init_stacks() in perl_clone that won't get |
452 | cleaned and we will get a leaked scalar. |
453 | The reason it was cloned was that it lived on the |
454 | @_ stack. |
455 | |
456 | Example of this can be found in bugreport 15837 |
457 | where calls in the parameter list end up as a temp |
458 | |
459 | One could argue that this fix should be in perl_clone |
460 | */ |
461 | |
462 | |
463 | while (tmps_ix > 0) { |
464 | SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); |
465 | tmps_ix--; |
466 | if (sv && SvREFCNT(sv) == 0) { |
467 | SvREFCNT_inc(sv); |
468 | SvREFCNT_dec(sv); |
469 | } |
470 | } |
471 | |
472 | |
473 | |
ba14dd9a |
474 | SvTEMP_off(thread->init_function); |
475 | ptr_table_free(PL_ptr_table); |
476 | PL_ptr_table = NULL; |
ffb29f90 |
477 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
ba14dd9a |
478 | } |
1d784c90 |
479 | PERL_THREAD_SETSPECIFIC(self_key,current_thread); |
68795e93 |
480 | PERL_SET_CONTEXT(aTHX); |
47ba8780 |
481 | |
68795e93 |
482 | /* Start the thread */ |
47ba8780 |
483 | |
484 | #ifdef WIN32 |
485 | |
68795e93 |
486 | thread->handle = CreateThread(NULL, 0, Perl_ithread_run, |
47ba8780 |
487 | (LPVOID)thread, 0, &thread->thr); |
488 | |
82c40bf6 |
489 | #else |
fa26028c |
490 | { |
491 | static pthread_attr_t attr; |
492 | static int attr_inited = 0; |
fa26028c |
493 | static int attr_joinable = PTHREAD_CREATE_JOINABLE; |
494 | if (!attr_inited) { |
495 | attr_inited = 1; |
496 | pthread_attr_init(&attr); |
497 | } |
498 | # ifdef PTHREAD_ATTR_SETDETACHSTATE |
499 | PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); |
500 | # endif |
3eb37d38 |
501 | # ifdef THREAD_CREATE_NEEDS_STACK |
502 | if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK)) |
6dfd2d05 |
503 | Perl_croak(aTHX_ "panic: pthread_attr_setstacksize failed"); |
3eb37d38 |
504 | # endif |
505 | |
3ad0b7d6 |
506 | #ifdef OLD_PTHREADS_API |
68795e93 |
507 | pthread_create( &thread->thr, attr, Perl_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 |
68795e93 |
512 | pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread); |
47ba8780 |
513 | #endif |
3ad0b7d6 |
514 | } |
82c40bf6 |
515 | #endif |
62375a60 |
516 | known_threads++; |
58c2ef19 |
517 | active_threads++; |
518 | MUTEX_UNLOCK(&create_destruct_mutex); |
95393226 |
519 | sv_2mortal(params); |
3b1c3273 |
520 | |
68795e93 |
521 | return ithread_to_SV(aTHX_ obj, thread, classname, FALSE); |
522 | } |
47ba8780 |
523 | |
68795e93 |
524 | SV* |
525 | Perl_ithread_self (pTHX_ SV *obj, char* Class) |
526 | { |
467f3f08 |
527 | ithread *thread; |
528 | PERL_THREAD_GETSPECIFIC_THREAD(self_key, thread); |
fe53aa5b |
529 | if (thread) |
530 | return ithread_to_SV(aTHX_ obj, thread, Class, TRUE); |
531 | else |
532 | Perl_croak(aTHX_ "panic: cannot find thread data"); |
47ba8780 |
533 | } |
534 | |
535 | /* |
e1c44605 |
536 | * Joins the thread this code needs to take the returnvalue from the |
68795e93 |
537 | * call_sv and send it back |
b1edfb69 |
538 | */ |
47ba8780 |
539 | |
68795e93 |
540 | void |
541 | Perl_ithread_CLONE(pTHX_ SV *obj) |
542 | { |
543 | if (SvROK(obj)) |
544 | { |
545 | ithread *thread = SV_to_ithread(aTHX_ obj); |
546 | } |
547 | else |
548 | { |
436c6dd3 |
549 | Perl_warn(aTHX_ "CLONE %" SVf,obj); |
68795e93 |
550 | } |
47ba8780 |
551 | } |
552 | |
62375a60 |
553 | AV* |
68795e93 |
554 | Perl_ithread_join(pTHX_ SV *obj) |
555 | { |
556 | ithread *thread = SV_to_ithread(aTHX_ obj); |
557 | MUTEX_LOCK(&thread->mutex); |
62375a60 |
558 | if (thread->state & PERL_ITHR_DETACHED) { |
a446a88f |
559 | MUTEX_UNLOCK(&thread->mutex); |
560 | Perl_croak(aTHX_ "Cannot join a detached thread"); |
561 | } |
62375a60 |
562 | else if (thread->state & PERL_ITHR_JOINED) { |
a446a88f |
563 | MUTEX_UNLOCK(&thread->mutex); |
564 | Perl_croak(aTHX_ "Thread already joined"); |
565 | } |
566 | else { |
e1c44605 |
567 | AV* retparam; |
47ba8780 |
568 | #ifdef WIN32 |
569 | DWORD waitcode; |
47ba8780 |
570 | #else |
571 | void *retval; |
47ba8780 |
572 | #endif |
47ba8780 |
573 | MUTEX_UNLOCK(&thread->mutex); |
68795e93 |
574 | #ifdef WIN32 |
575 | waitcode = WaitForSingleObject(thread->handle, INFINITE); |
576 | #else |
577 | pthread_join(thread->thr,&retval); |
578 | #endif |
47ba8780 |
579 | MUTEX_LOCK(&thread->mutex); |
e1c44605 |
580 | |
62375a60 |
581 | /* sv_dup over the args */ |
e1c44605 |
582 | { |
1d784c90 |
583 | ithread* current_thread; |
62375a60 |
584 | AV* params = (AV*) SvRV(thread->params); |
e1c44605 |
585 | CLONE_PARAMS clone_params; |
3275ba96 |
586 | clone_params.stashes = newAV(); |
0405e91e |
587 | clone_params.flags |= CLONEf_JOIN_IN; |
e1c44605 |
588 | PL_ptr_table = ptr_table_new(); |
467f3f08 |
589 | PERL_THREAD_GETSPECIFIC_THREAD(self_key, current_thread); |
1d784c90 |
590 | PERL_THREAD_SETSPECIFIC(self_key,thread); |
0405e91e |
591 | |
767c1403 |
592 | #if 0 |
0405e91e |
593 | { |
594 | I32 len = av_len(params)+1; |
595 | I32 i; |
596 | for(i = 0; i < len; i++) { |
767c1403 |
597 | sv_dump(SvRV(AvARRAY(params)[i])); |
0405e91e |
598 | } |
599 | } |
767c1403 |
600 | #endif |
e1c44605 |
601 | retparam = (AV*) sv_dup((SV*)params, &clone_params); |
b4cb676b |
602 | #if 0 |
0405e91e |
603 | { |
604 | I32 len = av_len(retparam)+1; |
605 | I32 i; |
606 | for(i = 0; i < len; i++) { |
b4cb676b |
607 | sv_dump(SvRV(AvARRAY(retparam)[i])); |
0405e91e |
608 | } |
609 | } |
b4cb676b |
610 | #endif |
1d784c90 |
611 | PERL_THREAD_SETSPECIFIC(self_key,current_thread); |
3275ba96 |
612 | SvREFCNT_dec(clone_params.stashes); |
e1c44605 |
613 | SvREFCNT_inc(retparam); |
614 | ptr_table_free(PL_ptr_table); |
615 | PL_ptr_table = NULL; |
616 | |
617 | } |
6dfd2d05 |
618 | /* We are finished with it */ |
62375a60 |
619 | thread->state |= PERL_ITHR_JOINED; |
47ba8780 |
620 | MUTEX_UNLOCK(&thread->mutex); |
57b48062 |
621 | |
e1c44605 |
622 | return retparam; |
68795e93 |
623 | } |
e1c44605 |
624 | return (AV*)NULL; |
47ba8780 |
625 | } |
626 | |
68795e93 |
627 | void |
68795e93 |
628 | Perl_ithread_DESTROY(pTHX_ SV *sv) |
629 | { |
630 | ithread *thread = SV_to_ithread(aTHX_ sv); |
68795e93 |
631 | sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar); |
632 | } |
8222d950 |
633 | |
73e09c8f |
634 | #endif /* USE_ITHREADS */ |
e1c44605 |
635 | |
68795e93 |
636 | MODULE = threads PACKAGE = threads PREFIX = ithread_ |
637 | PROTOTYPES: DISABLE |
8222d950 |
638 | |
73e09c8f |
639 | #ifdef USE_ITHREADS |
640 | |
68795e93 |
641 | void |
642 | ithread_new (classname, function_to_call, ...) |
643 | char * classname |
644 | SV * function_to_call |
645 | CODE: |
646 | { |
647 | AV* params = newAV(); |
648 | if (items > 2) { |
649 | int i; |
650 | for(i = 2; i < items ; i++) { |
95393226 |
651 | av_push(params, SvREFCNT_inc(ST(i))); |
68795e93 |
652 | } |
653 | } |
654 | ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params))); |
655 | XSRETURN(1); |
656 | } |
8222d950 |
657 | |
68795e93 |
658 | void |
678a9b6c |
659 | ithread_list(char *classname) |
660 | PPCODE: |
661 | { |
662 | ithread *curr_thread; |
663 | MUTEX_LOCK(&create_destruct_mutex); |
664 | curr_thread = threads; |
5eb9fe8f |
665 | if(curr_thread->tid != 0) |
2379b307 |
666 | XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE))); |
678a9b6c |
667 | while(curr_thread) { |
678a9b6c |
668 | curr_thread = curr_thread->next; |
669 | if(curr_thread == threads) |
670 | break; |
6794f985 |
671 | if(curr_thread->state & PERL_ITHR_DETACHED || |
5eb9fe8f |
672 | curr_thread->state & PERL_ITHR_JOINED) |
673 | continue; |
2379b307 |
674 | XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE))); |
678a9b6c |
675 | } |
676 | MUTEX_UNLOCK(&create_destruct_mutex); |
677 | } |
678 | |
679 | |
680 | void |
68795e93 |
681 | ithread_self(char *classname) |
682 | CODE: |
683 | { |
684 | ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname)); |
685 | XSRETURN(1); |
686 | } |
47ba8780 |
687 | |
688 | int |
68795e93 |
689 | ithread_tid(ithread *thread) |
47ba8780 |
690 | |
691 | void |
68795e93 |
692 | ithread_join(SV *obj) |
e1c44605 |
693 | PPCODE: |
694 | { |
695 | AV* params = Perl_ithread_join(aTHX_ obj); |
696 | int i; |
697 | I32 len = AvFILL(params); |
698 | for (i = 0; i <= len; i++) { |
1c3adb19 |
699 | SV* tmp = av_shift(params); |
700 | XPUSHs(tmp); |
701 | sv_2mortal(tmp); |
e1c44605 |
702 | } |
703 | SvREFCNT_dec(params); |
704 | } |
705 | |
f9dff5f5 |
706 | void |
9d7debe1 |
707 | yield(...) |
70f2e746 |
708 | CODE: |
709 | { |
710 | YIELD; |
711 | } |
712 | |
47ba8780 |
713 | |
714 | void |
68795e93 |
715 | ithread_detach(ithread *thread) |
47ba8780 |
716 | |
47ba8780 |
717 | void |
68795e93 |
718 | ithread_DESTROY(SV *thread) |
719 | |
73e09c8f |
720 | #endif /* USE_ITHREADS */ |
721 | |
68795e93 |
722 | BOOT: |
723 | { |
73e09c8f |
724 | #ifdef USE_ITHREADS |
68795e93 |
725 | ithread* thread; |
e1c44605 |
726 | PL_perl_destruct_level = 2; |
68795e93 |
727 | PERL_THREAD_ALLOC_SPECIFIC(self_key); |
58c2ef19 |
728 | MUTEX_INIT(&create_destruct_mutex); |
729 | MUTEX_LOCK(&create_destruct_mutex); |
62375a60 |
730 | PL_threadhook = &Perl_ithread_hook; |
68795e93 |
731 | thread = PerlMemShared_malloc(sizeof(ithread)); |
732 | Zero(thread,1,ithread); |
733 | PL_perl_destruct_level = 2; |
734 | MUTEX_INIT(&thread->mutex); |
735 | threads = thread; |
736 | thread->next = thread; |
737 | thread->prev = thread; |
738 | thread->interp = aTHX; |
6dfd2d05 |
739 | thread->count = 1; /* Immortal. */ |
68795e93 |
740 | thread->tid = tid_counter++; |
62375a60 |
741 | known_threads++; |
58c2ef19 |
742 | active_threads++; |
1fea7ed3 |
743 | thread->state = PERL_ITHR_DETACHED; |
68795e93 |
744 | #ifdef WIN32 |
745 | thread->thr = GetCurrentThreadId(); |
746 | #else |
747 | thread->thr = pthread_self(); |
748 | #endif |
62375a60 |
749 | |
68795e93 |
750 | PERL_THREAD_SETSPECIFIC(self_key,thread); |
58c2ef19 |
751 | MUTEX_UNLOCK(&create_destruct_mutex); |
73e09c8f |
752 | #endif /* USE_ITHREADS */ |
68795e93 |
753 | } |
754 | |