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