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