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