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