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