Commit | Line | Data |
68795e93 |
1 | #define PERL_NO_GET_CONTEXT |
2 | #include "EXTERN.h" |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
4dcb9e53 |
5 | /* Workaround for XSUB.h bug under WIN32 */ |
6 | #ifdef WIN32 |
7 | # undef setjmp |
c608f8c0 |
8 | # if !defined(__BORLANDC__) |
9 | # define setjmp(x) _setjmp(x) |
10 | # endif |
4dcb9e53 |
11 | #endif |
0f1612a7 |
12 | #ifdef HAS_PPPORT_H |
404aaa48 |
13 | # define NEED_PL_signals |
0f1612a7 |
14 | # define NEED_newRV_noinc |
15 | # define NEED_sv_2pv_nolen |
16 | # include "ppport.h" |
17 | # include "threads.h" |
18 | #endif |
68795e93 |
19 | |
73e09c8f |
20 | #ifdef USE_ITHREADS |
21 | |
68795e93 |
22 | #ifdef WIN32 |
fc04eb16 |
23 | # include <windows.h> |
514612b7 |
24 | /* Supposed to be in Winbase.h */ |
25 | # ifndef STACK_SIZE_PARAM_IS_A_RESERVATION |
26 | # define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000 |
27 | # endif |
fc04eb16 |
28 | # include <win32thread.h> |
68795e93 |
29 | #else |
fc04eb16 |
30 | # ifdef OS2 |
5c728af0 |
31 | typedef perl_os_thread pthread_t; |
fc04eb16 |
32 | # else |
33 | # include <pthread.h> |
34 | # endif |
35 | # include <thread.h> |
36 | # define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) |
37 | # ifdef OLD_PTHREADS_API |
38 | # define PERL_THREAD_DETACH(t) pthread_detach(&(t)) |
39 | # else |
40 | # define PERL_THREAD_DETACH(t) pthread_detach((t)) |
41 | # endif |
467f3f08 |
42 | #endif |
d305c2c9 |
43 | #if !defined(HAS_GETPAGESIZE) && defined(I_SYS_PARAM) |
44 | # include <sys/param.h> |
45 | #endif |
68795e93 |
46 | |
62375a60 |
47 | /* Values for 'state' member */ |
69a9b4b8 |
48 | #define PERL_ITHR_JOINABLE 0 |
49 | #define PERL_ITHR_DETACHED 1 |
50 | #define PERL_ITHR_JOINED 2 |
51 | #define PERL_ITHR_FINISHED 4 |
52 | #define PERL_ITHR_THREAD_EXIT_ONLY 8 |
fc04eb16 |
53 | |
54 | typedef struct _ithread { |
55 | struct _ithread *next; /* Next thread in the list */ |
56 | struct _ithread *prev; /* Prev thread in the list */ |
57 | PerlInterpreter *interp; /* The threads interpreter */ |
58 | UV tid; /* Threads module's thread id */ |
59 | perl_mutex mutex; /* Mutex for updating things in this struct */ |
9feacc09 |
60 | int count; /* How many SVs have a reference to us */ |
fc04eb16 |
61 | int state; /* Detached, joined, finished, etc. */ |
62 | int gimme; /* Context of create */ |
63 | SV *init_function; /* Code to run */ |
64 | SV *params; /* Args to pass function */ |
68795e93 |
65 | #ifdef WIN32 |
fc04eb16 |
66 | DWORD thr; /* OS's idea if thread id */ |
67 | HANDLE handle; /* OS's waitable handle */ |
68795e93 |
68 | #else |
fc04eb16 |
69 | pthread_t thr; /* OS's handle for the thread */ |
68795e93 |
70 | #endif |
514612b7 |
71 | IV stack_size; |
68795e93 |
72 | } ithread; |
73 | |
fc04eb16 |
74 | |
75 | /* Used by Perl interpreter for thread context switching */ |
628ab322 |
76 | #define MY_CXT_KEY "threads::_guts" XS_VERSION |
77 | |
78 | typedef struct { |
79 | ithread *thread; |
80 | } my_cxt_t; |
81 | |
82 | START_MY_CXT |
83 | |
c372d929 |
84 | /* Structure for 'main' thread |
85 | * Also forms the 'base' for the doubly-linked list of threads */ |
86 | static ithread main_thread; |
68795e93 |
87 | |
fc04eb16 |
88 | /* Protects the creation and destruction of threads*/ |
89 | static perl_mutex create_destruct_mutex; |
68795e93 |
90 | |
c372d929 |
91 | static UV tid_counter = 1; |
5168baf3 |
92 | static IV joinable_threads = 0; |
4dcb9e53 |
93 | static IV running_threads = 0; |
94 | static IV detached_threads = 0; |
514612b7 |
95 | #ifdef THREAD_CREATE_NEEDS_STACK |
96 | static IV default_stack_size = THREAD_CREATE_NEEDS_STACK; |
97 | #else |
98 | static IV default_stack_size = 0; |
99 | #endif |
100 | static IV page_size = 0; |
c05ae023 |
101 | |
102 | |
fc04eb16 |
103 | /* Used by Perl interpreter for thread context switching */ |
f4cc38af |
104 | static void |
fc04eb16 |
105 | S_ithread_set(pTHX_ ithread *thread) |
c05ae023 |
106 | { |
628ab322 |
107 | dMY_CXT; |
108 | MY_CXT.thread = thread; |
c05ae023 |
109 | } |
110 | |
fc04eb16 |
111 | static ithread * |
112 | S_ithread_get(pTHX) |
113 | { |
628ab322 |
114 | dMY_CXT; |
fc04eb16 |
115 | return (MY_CXT.thread); |
c05ae023 |
116 | } |
117 | |
118 | |
fc04eb16 |
119 | /* Free any data (such as the Perl interpreter) attached to an ithread |
120 | * structure. This is a bit like undef on SVs, where the SV isn't freed, |
121 | * but the PVX is. Must be called with thread->mutex already held. |
2e676467 |
122 | */ |
2e676467 |
123 | static void |
fc04eb16 |
124 | S_ithread_clear(pTHX_ ithread *thread) |
2e676467 |
125 | { |
126 | PerlInterpreter *interp; |
fc04eb16 |
127 | |
ead32952 |
128 | assert((thread->state & PERL_ITHR_FINISHED) && |
129 | (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))); |
2e676467 |
130 | |
131 | interp = thread->interp; |
132 | if (interp) { |
fc04eb16 |
133 | dTHXa(interp); |
134 | |
135 | PERL_SET_CONTEXT(interp); |
136 | S_ithread_set(aTHX_ thread); |
f2cba68d |
137 | |
fc04eb16 |
138 | SvREFCNT_dec(thread->params); |
139 | thread->params = Nullsv; |
2e676467 |
140 | |
fc04eb16 |
141 | perl_destruct(interp); |
9ca4d7fd |
142 | perl_free(interp); |
fc04eb16 |
143 | thread->interp = NULL; |
2e676467 |
144 | } |
fc04eb16 |
145 | |
2e676467 |
146 | PERL_SET_CONTEXT(aTHX); |
147 | } |
148 | |
68795e93 |
149 | |
fc04eb16 |
150 | /* Free an ithread structure and any attached data if its count == 0 */ |
bcd9ca9b |
151 | static void |
fc04eb16 |
152 | S_ithread_destruct(pTHX_ ithread *thread) |
68795e93 |
153 | { |
385d56e4 |
154 | #ifdef WIN32 |
fc04eb16 |
155 | HANDLE handle; |
385d56e4 |
156 | #endif |
fea7688c |
157 | /* Return if thread is still being used */ |
fc04eb16 |
158 | if (thread->count != 0) { |
fc04eb16 |
159 | return; |
160 | } |
9feacc09 |
161 | |
fc04eb16 |
162 | /* Main thread (0) is immortal and should never get here */ |
163 | assert(thread->tid != 0); |
164 | |
165 | /* Remove from circular list of threads */ |
4dcb9e53 |
166 | MUTEX_LOCK(&create_destruct_mutex); |
fc04eb16 |
167 | thread->next->prev = thread->prev; |
168 | thread->prev->next = thread->next; |
169 | thread->next = NULL; |
170 | thread->prev = NULL; |
171 | MUTEX_UNLOCK(&create_destruct_mutex); |
c2f2a82b |
172 | |
fc04eb16 |
173 | /* Thread is now disowned */ |
9ca4d7fd |
174 | MUTEX_LOCK(&thread->mutex); |
fc04eb16 |
175 | S_ithread_clear(aTHX_ thread); |
385d56e4 |
176 | |
177 | #ifdef WIN32 |
fc04eb16 |
178 | handle = thread->handle; |
179 | thread->handle = NULL; |
385d56e4 |
180 | #endif |
fc04eb16 |
181 | MUTEX_UNLOCK(&thread->mutex); |
182 | MUTEX_DESTROY(&thread->mutex); |
385d56e4 |
183 | |
c7667023 |
184 | #ifdef WIN32 |
fea7688c |
185 | if (handle) { |
fc04eb16 |
186 | CloseHandle(handle); |
fea7688c |
187 | } |
c7667023 |
188 | #endif |
385d56e4 |
189 | |
fc04eb16 |
190 | /* Call PerlMemShared_free() in the context of the "first" interpreter |
191 | * per http://www.nntp.perl.org/group/perl.perl5.porters/110772 |
192 | */ |
193 | aTHX = PL_curinterp; |
194 | PerlMemShared_free(thread); |
68795e93 |
195 | } |
196 | |
fc04eb16 |
197 | |
69a9b4b8 |
198 | /* Warn if exiting with any unjoined threads */ |
60bd5ef6 |
199 | static int |
69a9b4b8 |
200 | S_exit_warning(pTHX) |
62375a60 |
201 | { |
60bd5ef6 |
202 | int veto_cleanup; |
69a9b4b8 |
203 | |
62375a60 |
204 | MUTEX_LOCK(&create_destruct_mutex); |
60bd5ef6 |
205 | veto_cleanup = (running_threads || joinable_threads); |
206 | MUTEX_UNLOCK(&create_destruct_mutex); |
207 | |
208 | if (veto_cleanup) { |
fc04eb16 |
209 | if (ckWARN_d(WARN_THREADS)) { |
4dcb9e53 |
210 | Perl_warn(aTHX_ "Perl exited with active threads:\n\t%" |
211 | IVdf " running and unjoined\n\t%" |
212 | IVdf " finished and unjoined\n\t%" |
213 | IVdf " running and detached\n", |
214 | running_threads, |
215 | joinable_threads, |
216 | detached_threads); |
fc04eb16 |
217 | } |
62375a60 |
218 | } |
69a9b4b8 |
219 | |
fc04eb16 |
220 | return (veto_cleanup); |
62375a60 |
221 | } |
222 | |
69a9b4b8 |
223 | /* Called on exit from main thread */ |
224 | int |
225 | Perl_ithread_hook(pTHX) |
226 | { |
227 | return ((aTHX == PL_curinterp) ? S_exit_warning(aTHX) : 0); |
228 | } |
229 | |
68795e93 |
230 | |
231 | /* MAGIC (in mg.h sense) hooks */ |
232 | |
233 | int |
234 | ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) |
235 | { |
fc04eb16 |
236 | ithread *thread = (ithread *)mg->mg_ptr; |
45977657 |
237 | SvIV_set(sv, PTR2IV(thread)); |
68795e93 |
238 | SvIOK_on(sv); |
fc04eb16 |
239 | return (0); |
68795e93 |
240 | } |
241 | |
242 | int |
243 | ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) |
244 | { |
f2cba68d |
245 | ithread *thread = (ithread *)mg->mg_ptr; |
246 | int cleanup; |
247 | |
68795e93 |
248 | MUTEX_LOCK(&thread->mutex); |
f2cba68d |
249 | cleanup = ((--thread->count == 0) && |
250 | (thread->state & PERL_ITHR_FINISHED) && |
251 | (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))); |
252 | MUTEX_UNLOCK(&thread->mutex); |
253 | |
fea7688c |
254 | if (cleanup) { |
f2cba68d |
255 | S_ithread_destruct(aTHX_ thread); |
fea7688c |
256 | } |
fc04eb16 |
257 | return (0); |
68795e93 |
258 | } |
259 | |
260 | int |
261 | ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
262 | { |
fc04eb16 |
263 | ithread *thread = (ithread *)mg->mg_ptr; |
68795e93 |
264 | MUTEX_LOCK(&thread->mutex); |
68795e93 |
265 | thread->count++; |
266 | MUTEX_UNLOCK(&thread->mutex); |
fc04eb16 |
267 | return (0); |
68795e93 |
268 | } |
269 | |
270 | MGVTBL ithread_vtbl = { |
fc04eb16 |
271 | ithread_mg_get, /* get */ |
272 | 0, /* set */ |
273 | 0, /* len */ |
274 | 0, /* clear */ |
275 | ithread_mg_free, /* free */ |
276 | 0, /* copy */ |
277 | ithread_mg_dup /* dup */ |
68795e93 |
278 | }; |
279 | |
47ba8780 |
280 | |
514612b7 |
281 | /* Provided default, minimum and rational stack sizes */ |
282 | static IV |
283 | good_stack_size(pTHX_ IV stack_size) |
284 | { |
285 | /* Use default stack size if no stack size specified */ |
fea7688c |
286 | if (! stack_size) { |
514612b7 |
287 | return (default_stack_size); |
fea7688c |
288 | } |
514612b7 |
289 | |
290 | #ifdef PTHREAD_STACK_MIN |
291 | /* Can't use less than minimum */ |
292 | if (stack_size < PTHREAD_STACK_MIN) { |
4dcb9e53 |
293 | if (ckWARN(WARN_THREADS)) { |
514612b7 |
294 | Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN); |
295 | } |
296 | return (PTHREAD_STACK_MIN); |
297 | } |
298 | #endif |
299 | |
300 | /* Round up to page size boundary */ |
301 | if (page_size <= 0) { |
d305c2c9 |
302 | #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) |
514612b7 |
303 | SETERRNO(0, SS_NORMAL); |
d305c2c9 |
304 | # ifdef _SC_PAGESIZE |
514612b7 |
305 | page_size = sysconf(_SC_PAGESIZE); |
d305c2c9 |
306 | # else |
514612b7 |
307 | page_size = sysconf(_SC_MMAP_PAGE_SIZE); |
d305c2c9 |
308 | # endif |
514612b7 |
309 | if ((long)page_size < 0) { |
310 | if (errno) { |
311 | SV * const error = get_sv("@", FALSE); |
312 | (void)SvUPGRADE(error, SVt_PV); |
313 | Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error)); |
314 | } else { |
315 | Perl_croak(aTHX_ "PANIC: sysconf: pagesize unknown"); |
316 | } |
317 | } |
d305c2c9 |
318 | #else |
319 | # ifdef HAS_GETPAGESIZE |
514612b7 |
320 | page_size = getpagesize(); |
514612b7 |
321 | # else |
d305c2c9 |
322 | # if defined(I_SYS_PARAM) && defined(PAGESIZE) |
323 | page_size = PAGESIZE; |
324 | # else |
514612b7 |
325 | page_size = 8192; /* A conservative default */ |
d305c2c9 |
326 | # endif |
514612b7 |
327 | # endif |
fea7688c |
328 | if (page_size <= 0) { |
d305c2c9 |
329 | Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)page_size); |
fea7688c |
330 | } |
514612b7 |
331 | #endif |
332 | } |
333 | stack_size = ((stack_size + (page_size - 1)) / page_size) * page_size; |
334 | |
335 | return (stack_size); |
336 | } |
337 | |
338 | |
fc04eb16 |
339 | /* Starts executing the thread. |
340 | * Passed as the C level function to run in the new thread. |
b1edfb69 |
341 | */ |
47ba8780 |
342 | #ifdef WIN32 |
f4cc38af |
343 | static THREAD_RET_TYPE |
fc04eb16 |
344 | S_ithread_run(LPVOID arg) |
47ba8780 |
345 | #else |
fc04eb16 |
346 | static void * |
347 | S_ithread_run(void * arg) |
47ba8780 |
348 | #endif |
fc04eb16 |
349 | { |
350 | ithread *thread = (ithread *)arg; |
69a9b4b8 |
351 | int jmp_rc = 0; |
352 | I32 oldscope; |
353 | int exit_app = 0; |
354 | int exit_code = 0; |
fc04eb16 |
355 | int cleanup; |
f2cba68d |
356 | |
69a9b4b8 |
357 | dJMPENV; |
358 | |
fc04eb16 |
359 | dTHXa(thread->interp); |
47ba8780 |
360 | |
9ca4d7fd |
361 | /* Blocked until ->create() call finishes */ |
fc04eb16 |
362 | MUTEX_LOCK(&thread->mutex); |
fc04eb16 |
363 | MUTEX_UNLOCK(&thread->mutex); |
9ca4d7fd |
364 | |
365 | PERL_SET_CONTEXT(thread->interp); |
366 | S_ithread_set(aTHX_ thread); |
47ba8780 |
367 | |
fc04eb16 |
368 | PL_perl_destruct_level = 2; |
f2cba68d |
369 | |
fc04eb16 |
370 | { |
371 | AV *params = (AV *)SvRV(thread->params); |
372 | int len = (int)av_len(params)+1; |
373 | int ii; |
374 | |
375 | dSP; |
376 | ENTER; |
377 | SAVETMPS; |
378 | |
379 | /* Put args on the stack */ |
380 | PUSHMARK(SP); |
381 | for (ii=0; ii < len; ii++) { |
382 | XPUSHs(av_shift(params)); |
383 | } |
384 | PUTBACK; |
385 | |
4dcb9e53 |
386 | oldscope = PL_scopestack_ix; |
387 | JMPENV_PUSH(jmp_rc); |
388 | if (jmp_rc == 0) { |
389 | /* Run the specified function */ |
390 | len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); |
391 | } else if (jmp_rc == 2) { |
69a9b4b8 |
392 | /* Thread exited */ |
393 | exit_app = 1; |
394 | exit_code = STATUS_CURRENT; |
4dcb9e53 |
395 | while (PL_scopestack_ix > oldscope) { |
396 | LEAVE; |
397 | } |
398 | } |
399 | JMPENV_POP; |
fc04eb16 |
400 | |
401 | /* Remove args from stack and put back in params array */ |
402 | SPAGAIN; |
403 | for (ii=len-1; ii >= 0; ii--) { |
404 | SV *sv = POPs; |
4dcb9e53 |
405 | if (jmp_rc == 0) { |
406 | av_store(params, ii, SvREFCNT_inc(sv)); |
407 | } |
fc04eb16 |
408 | } |
409 | |
4dcb9e53 |
410 | FREETMPS; |
411 | LEAVE; |
412 | |
fc04eb16 |
413 | /* Check for failure */ |
414 | if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) { |
4dcb9e53 |
415 | oldscope = PL_scopestack_ix; |
416 | JMPENV_PUSH(jmp_rc); |
417 | if (jmp_rc == 0) { |
69a9b4b8 |
418 | /* Warn that thread died */ |
4dcb9e53 |
419 | Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV); |
420 | } else if (jmp_rc == 2) { |
69a9b4b8 |
421 | /* Warn handler exited */ |
422 | exit_app = 1; |
423 | exit_code = STATUS_CURRENT; |
4dcb9e53 |
424 | while (PL_scopestack_ix > oldscope) { |
425 | LEAVE; |
426 | } |
427 | } |
428 | JMPENV_POP; |
fc04eb16 |
429 | } |
430 | |
fc04eb16 |
431 | /* Release function ref */ |
432 | SvREFCNT_dec(thread->init_function); |
433 | thread->init_function = Nullsv; |
434 | } |
62375a60 |
435 | |
fc04eb16 |
436 | PerlIO_flush((PerlIO *)NULL); |
437 | |
9ca4d7fd |
438 | MUTEX_LOCK(&create_destruct_mutex); |
fc04eb16 |
439 | MUTEX_LOCK(&thread->mutex); |
440 | /* Mark as finished */ |
441 | thread->state |= PERL_ITHR_FINISHED; |
69a9b4b8 |
442 | /* Clear exit flag if required */ |
fea7688c |
443 | if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) { |
69a9b4b8 |
444 | exit_app = 0; |
fea7688c |
445 | } |
fc04eb16 |
446 | /* Cleanup if detached */ |
447 | cleanup = (thread->state & PERL_ITHR_DETACHED); |
448 | MUTEX_UNLOCK(&thread->mutex); |
449 | |
69a9b4b8 |
450 | /* Adjust thread status counts */ |
4dcb9e53 |
451 | if (cleanup) { |
4dcb9e53 |
452 | detached_threads--; |
4dcb9e53 |
453 | } else { |
4dcb9e53 |
454 | running_threads--; |
455 | joinable_threads++; |
5168baf3 |
456 | } |
69a9b4b8 |
457 | MUTEX_UNLOCK(&create_destruct_mutex); |
458 | |
459 | /* Exit application if required */ |
460 | if (exit_app) { |
461 | oldscope = PL_scopestack_ix; |
462 | JMPENV_PUSH(jmp_rc); |
463 | if (jmp_rc == 0) { |
464 | /* Warn if there are unjoined threads */ |
465 | S_exit_warning(aTHX); |
466 | } else if (jmp_rc == 2) { |
467 | /* Warn handler exited */ |
468 | exit_code = STATUS_CURRENT; |
469 | while (PL_scopestack_ix > oldscope) { |
470 | LEAVE; |
471 | } |
472 | } |
473 | JMPENV_POP; |
474 | |
475 | my_exit(exit_code); |
476 | } |
477 | |
478 | /* Clean up detached thread */ |
fea7688c |
479 | if (cleanup) { |
69a9b4b8 |
480 | S_ithread_destruct(aTHX_ thread); |
fea7688c |
481 | } |
91604d21 |
482 | |
47ba8780 |
483 | #ifdef WIN32 |
fc04eb16 |
484 | return ((DWORD)0); |
e8f2bb9a |
485 | #else |
fc04eb16 |
486 | return (0); |
47ba8780 |
487 | #endif |
68795e93 |
488 | } |
489 | |
fc04eb16 |
490 | |
491 | /* Type conversion helper functions */ |
fea7688c |
492 | |
f4cc38af |
493 | static SV * |
68795e93 |
494 | ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) |
495 | { |
496 | SV *sv; |
497 | MAGIC *mg; |
fc04eb16 |
498 | |
9ca4d7fd |
499 | /* If incrementing thread ref count, then call within mutex lock */ |
68795e93 |
500 | if (inc) { |
fc04eb16 |
501 | MUTEX_LOCK(&thread->mutex); |
502 | thread->count++; |
503 | MUTEX_UNLOCK(&thread->mutex); |
504 | } |
505 | |
506 | if (! obj) { |
507 | obj = newSV(0); |
68795e93 |
508 | } |
fc04eb16 |
509 | |
510 | sv = newSVrv(obj, classname); |
511 | sv_setiv(sv, PTR2IV(thread)); |
512 | mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0); |
68795e93 |
513 | mg->mg_flags |= MGf_DUP; |
514 | SvREADONLY_on(sv); |
fc04eb16 |
515 | |
516 | return (obj); |
68795e93 |
517 | } |
47ba8780 |
518 | |
f4cc38af |
519 | static ithread * |
68795e93 |
520 | SV_to_ithread(pTHX_ SV *sv) |
521 | { |
fc04eb16 |
522 | /* Argument is a thread */ |
523 | if (SvROK(sv)) { |
524 | return (INT2PTR(ithread *, SvIV(SvRV(sv)))); |
525 | } |
526 | /* Argument is classname, therefore return current thread */ |
527 | return (S_ithread_get(aTHX)); |
47ba8780 |
528 | } |
529 | |
47ba8780 |
530 | |
fc04eb16 |
531 | /* threads->create() |
532 | * Called in context of parent thread. |
9ca4d7fd |
533 | * Called with create_destruct_mutex locked. (Unlocked on error.) |
fc04eb16 |
534 | */ |
9ca4d7fd |
535 | static ithread * |
fc04eb16 |
536 | S_ithread_create( |
9ca4d7fd |
537 | pTHX_ SV *init_function, |
514612b7 |
538 | IV stack_size, |
9d9ff5b1 |
539 | int gimme, |
69a9b4b8 |
540 | int exit_opt, |
fc04eb16 |
541 | SV *params) |
68795e93 |
542 | { |
fc04eb16 |
543 | ithread *thread; |
544 | CLONE_PARAMS clone_param; |
545 | ithread *current_thread = S_ithread_get(aTHX); |
3b1c3273 |
546 | |
fc04eb16 |
547 | SV **tmps_tmp = PL_tmps_stack; |
548 | IV tmps_ix = PL_tmps_ix; |
d94006e8 |
549 | #ifndef WIN32 |
fc04eb16 |
550 | int rc_stack_size = 0; |
551 | int rc_thread_create = 0; |
d94006e8 |
552 | #endif |
3b1c3273 |
553 | |
fc04eb16 |
554 | /* Allocate thread structure */ |
555 | thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); |
556 | if (!thread) { |
557 | MUTEX_UNLOCK(&create_destruct_mutex); |
558 | PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); |
559 | my_exit(1); |
560 | } |
561 | Zero(thread, 1, ithread); |
562 | |
563 | /* Add to threads list */ |
c372d929 |
564 | thread->next = &main_thread; |
565 | thread->prev = main_thread.prev; |
566 | main_thread.prev = thread; |
fc04eb16 |
567 | thread->prev->next = thread; |
c05ae023 |
568 | |
fc04eb16 |
569 | /* Set count to 1 immediately in case thread exits before |
570 | * we return to caller! |
571 | */ |
572 | thread->count = 1; |
573 | |
9ca4d7fd |
574 | /* Block new thread until ->create() call finishes */ |
fc04eb16 |
575 | MUTEX_INIT(&thread->mutex); |
9ca4d7fd |
576 | MUTEX_LOCK(&thread->mutex); |
577 | |
fc04eb16 |
578 | thread->tid = tid_counter++; |
514612b7 |
579 | thread->stack_size = good_stack_size(aTHX_ stack_size); |
9d9ff5b1 |
580 | thread->gimme = gimme; |
69a9b4b8 |
581 | thread->state = exit_opt; |
fc04eb16 |
582 | |
583 | /* "Clone" our interpreter into the thread's interpreter. |
584 | * This gives thread access to "static data" and code. |
585 | */ |
586 | PerlIO_flush((PerlIO *)NULL); |
587 | S_ithread_set(aTHX_ thread); |
588 | |
589 | SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */ |
590 | PL_srand_called = FALSE; /* Set it to false so we can detect if it gets |
591 | set during the clone */ |
3b1c3273 |
592 | |
47ba8780 |
593 | #ifdef WIN32 |
fc04eb16 |
594 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); |
47ba8780 |
595 | #else |
fc04eb16 |
596 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); |
47ba8780 |
597 | #endif |
47ba8780 |
598 | |
fc04eb16 |
599 | /* perl_clone() leaves us in new interpreter's context. As it is tricky |
600 | * to spot an implicit aTHX, create a new scope with aTHX matching the |
601 | * context for the duration of our work for new interpreter. |
602 | */ |
603 | { |
604 | dTHXa(thread->interp); |
605 | |
606 | MY_CXT_CLONE; |
607 | |
608 | /* Here we remove END blocks since they should only run in the thread |
609 | * they are created |
610 | */ |
611 | SvREFCNT_dec(PL_endav); |
612 | PL_endav = newAV(); |
404aaa48 |
613 | |
f2e0bb91 |
614 | if (SvPOK(init_function)) { |
615 | thread->init_function = newSV(0); |
616 | sv_copypv(thread->init_function, init_function); |
617 | } else { |
618 | clone_param.flags = 0; |
619 | thread->init_function = sv_dup(init_function, &clone_param); |
620 | if (SvREFCNT(thread->init_function) == 0) { |
d4315dd6 |
621 | SvREFCNT_inc_void(thread->init_function); |
f2e0bb91 |
622 | } |
fc04eb16 |
623 | } |
624 | |
625 | thread->params = sv_dup(params, &clone_param); |
d4315dd6 |
626 | SvREFCNT_inc_void(thread->params); |
fc04eb16 |
627 | |
628 | /* The code below checks that anything living on the tmps stack and |
629 | * has been cloned (so it lives in the ptr_table) has a refcount |
630 | * higher than 0. |
631 | * |
632 | * If the refcount is 0 it means that a something on the stack/context |
633 | * was holding a reference to it and since we init_stacks() in |
634 | * perl_clone that won't get cleaned and we will get a leaked scalar. |
635 | * The reason it was cloned was that it lived on the @_ stack. |
636 | * |
637 | * Example of this can be found in bugreport 15837 where calls in the |
638 | * parameter list end up as a temp. |
639 | * |
640 | * One could argue that this fix should be in perl_clone. |
641 | */ |
642 | while (tmps_ix > 0) { |
643 | SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); |
644 | tmps_ix--; |
645 | if (sv && SvREFCNT(sv) == 0) { |
d4315dd6 |
646 | SvREFCNT_inc_void(sv); |
fc04eb16 |
647 | SvREFCNT_dec(sv); |
648 | } |
649 | } |
650 | |
651 | SvTEMP_off(thread->init_function); |
652 | ptr_table_free(PL_ptr_table); |
653 | PL_ptr_table = NULL; |
654 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
655 | } |
656 | S_ithread_set(aTHX_ current_thread); |
657 | PERL_SET_CONTEXT(aTHX); |
658 | |
659 | /* Create/start the thread */ |
47ba8780 |
660 | #ifdef WIN32 |
fc04eb16 |
661 | thread->handle = CreateThread(NULL, |
514612b7 |
662 | (DWORD)thread->stack_size, |
fc04eb16 |
663 | S_ithread_run, |
664 | (LPVOID)thread, |
514612b7 |
665 | STACK_SIZE_PARAM_IS_A_RESERVATION, |
fc04eb16 |
666 | &thread->thr); |
82c40bf6 |
667 | #else |
fc04eb16 |
668 | { |
669 | static pthread_attr_t attr; |
670 | static int attr_inited = 0; |
671 | static int attr_joinable = PTHREAD_CREATE_JOINABLE; |
672 | if (! attr_inited) { |
673 | pthread_attr_init(&attr); |
674 | attr_inited = 1; |
675 | } |
676 | |
fa26028c |
677 | # ifdef PTHREAD_ATTR_SETDETACHSTATE |
fc04eb16 |
678 | /* Threads start out joinable */ |
679 | PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); |
fa26028c |
680 | # endif |
fc04eb16 |
681 | |
514612b7 |
682 | # ifdef _POSIX_THREAD_ATTR_STACKSIZE |
fc04eb16 |
683 | /* Set thread's stack size */ |
514612b7 |
684 | if (thread->stack_size > 0) { |
685 | rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size); |
686 | } |
3eb37d38 |
687 | # endif |
688 | |
fc04eb16 |
689 | /* Create the thread */ |
690 | if (! rc_stack_size) { |
691 | # ifdef OLD_PTHREADS_API |
692 | rc_thread_create = pthread_create(&thread->thr, |
693 | attr, |
694 | S_ithread_run, |
695 | (void *)thread); |
696 | # else |
697 | # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) |
698 | pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); |
699 | # endif |
700 | rc_thread_create = pthread_create(&thread->thr, |
701 | &attr, |
702 | S_ithread_run, |
703 | (void *)thread); |
19a077f6 |
704 | # endif |
fc04eb16 |
705 | } |
514612b7 |
706 | |
707 | # ifdef _POSIX_THREAD_ATTR_STACKSIZE |
708 | /* Try to get thread's actual stack size */ |
709 | { |
710 | size_t stacksize; |
58a3a76c |
711 | #ifdef HPUX1020 |
712 | stacksize = pthread_attr_getstacksize(attr); |
713 | #else |
714 | if (! pthread_attr_getstacksize(&attr, &stacksize)) |
715 | #endif |
716 | if (stacksize > 0) { |
514612b7 |
717 | thread->stack_size = (IV)stacksize; |
718 | } |
514612b7 |
719 | } |
720 | # endif |
fc04eb16 |
721 | } |
82c40bf6 |
722 | #endif |
bcd9ca9b |
723 | |
fc04eb16 |
724 | /* Check for errors */ |
d94006e8 |
725 | #ifdef WIN32 |
fc04eb16 |
726 | if (thread->handle == NULL) { |
d94006e8 |
727 | #else |
fc04eb16 |
728 | if (rc_stack_size || rc_thread_create) { |
d94006e8 |
729 | #endif |
9ca4d7fd |
730 | /* Must unlock mutex for destruct call */ |
fc04eb16 |
731 | MUTEX_UNLOCK(&create_destruct_mutex); |
732 | sv_2mortal(params); |
733 | S_ithread_destruct(aTHX_ thread); |
d94006e8 |
734 | #ifndef WIN32 |
514612b7 |
735 | if (ckWARN_d(WARN_THREADS)) { |
fea7688c |
736 | if (rc_stack_size) { |
514612b7 |
737 | Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size); |
fea7688c |
738 | } else { |
514612b7 |
739 | Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); |
fea7688c |
740 | } |
514612b7 |
741 | } |
d94006e8 |
742 | #endif |
9ca4d7fd |
743 | return (NULL); |
fc04eb16 |
744 | } |
745 | |
4dcb9e53 |
746 | running_threads++; |
fc04eb16 |
747 | sv_2mortal(params); |
9ca4d7fd |
748 | return (thread); |
68795e93 |
749 | } |
47ba8780 |
750 | |
73e09c8f |
751 | #endif /* USE_ITHREADS */ |
e1c44605 |
752 | |
fcea4b7c |
753 | |
fc04eb16 |
754 | MODULE = threads PACKAGE = threads PREFIX = ithread_ |
68795e93 |
755 | PROTOTYPES: DISABLE |
8222d950 |
756 | |
73e09c8f |
757 | #ifdef USE_ITHREADS |
758 | |
68795e93 |
759 | void |
f4cc38af |
760 | ithread_create(...) |
761 | PREINIT: |
762 | char *classname; |
514612b7 |
763 | ithread *thread; |
f4cc38af |
764 | SV *function_to_call; |
765 | AV *params; |
514612b7 |
766 | HV *specs; |
767 | IV stack_size; |
9d9ff5b1 |
768 | int context; |
69a9b4b8 |
769 | int exit_opt; |
770 | SV *thread_exit_only; |
9d9ff5b1 |
771 | char *str; |
514612b7 |
772 | int idx; |
f4cc38af |
773 | int ii; |
774 | CODE: |
514612b7 |
775 | if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) { |
fea7688c |
776 | if (--items < 2) { |
514612b7 |
777 | Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)"); |
fea7688c |
778 | } |
514612b7 |
779 | specs = (HV*)SvRV(ST(1)); |
780 | idx = 1; |
781 | } else { |
fea7688c |
782 | if (items < 2) { |
514612b7 |
783 | Perl_croak(aTHX_ "Usage: threads->create(function, ...)"); |
fea7688c |
784 | } |
514612b7 |
785 | specs = NULL; |
786 | idx = 0; |
787 | } |
f4cc38af |
788 | |
514612b7 |
789 | if (sv_isobject(ST(0))) { |
790 | /* $thr->create() */ |
791 | classname = HvNAME(SvSTASH(SvRV(ST(0)))); |
792 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
793 | stack_size = thread->stack_size; |
69a9b4b8 |
794 | exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY; |
514612b7 |
795 | } else { |
796 | /* threads->create() */ |
797 | classname = (char *)SvPV_nolen(ST(0)); |
798 | stack_size = default_stack_size; |
69a9b4b8 |
799 | thread_exit_only = get_sv("threads::thread_exit_only", TRUE); |
800 | exit_opt = (SvTRUE(thread_exit_only)) |
801 | ? PERL_ITHR_THREAD_EXIT_ONLY : 0; |
514612b7 |
802 | } |
803 | |
804 | function_to_call = ST(idx+1); |
805 | |
9d9ff5b1 |
806 | context = -1; |
514612b7 |
807 | if (specs) { |
808 | /* stack_size */ |
809 | if (hv_exists(specs, "stack", 5)) { |
810 | stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0)); |
811 | } else if (hv_exists(specs, "stacksize", 9)) { |
812 | stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0)); |
813 | } else if (hv_exists(specs, "stack_size", 10)) { |
814 | stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0)); |
815 | } |
9d9ff5b1 |
816 | |
817 | /* context */ |
818 | if (hv_exists(specs, "context", 7)) { |
819 | str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0)); |
820 | switch (*str) { |
821 | case 'a': |
822 | case 'A': |
823 | context = G_ARRAY; |
824 | break; |
825 | case 's': |
826 | case 'S': |
827 | context = G_SCALAR; |
828 | break; |
829 | case 'v': |
830 | case 'V': |
831 | context = G_VOID; |
832 | break; |
833 | default: |
834 | Perl_croak(aTHX_ "Invalid context: %s", str); |
835 | } |
836 | } else if (hv_exists(specs, "array", 5)) { |
837 | if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) { |
838 | context = G_ARRAY; |
839 | } |
840 | } else if (hv_exists(specs, "scalar", 6)) { |
841 | if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) { |
842 | context = G_SCALAR; |
843 | } |
844 | } else if (hv_exists(specs, "void", 4)) { |
845 | if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) { |
846 | context = G_VOID; |
847 | } |
848 | } |
69a9b4b8 |
849 | |
850 | /* exit => thread_only */ |
851 | if (hv_exists(specs, "exit", 4)) { |
852 | str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0)); |
853 | exit_opt = (*str == 't' || *str == 'T') |
854 | ? PERL_ITHR_THREAD_EXIT_ONLY : 0; |
855 | } |
9d9ff5b1 |
856 | } |
857 | if (context == -1) { |
858 | context = GIMME_V; /* Implicit context */ |
859 | } else { |
860 | context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID))); |
514612b7 |
861 | } |
f4cc38af |
862 | |
863 | /* Function args */ |
864 | params = newAV(); |
865 | if (items > 2) { |
514612b7 |
866 | for (ii=2; ii < items ; ii++) { |
867 | av_push(params, SvREFCNT_inc(ST(idx+ii))); |
f4cc38af |
868 | } |
869 | } |
870 | |
871 | /* Create thread */ |
9ca4d7fd |
872 | MUTEX_LOCK(&create_destruct_mutex); |
873 | thread = S_ithread_create(aTHX_ function_to_call, |
874 | stack_size, |
875 | context, |
876 | exit_opt, |
877 | newRV_noinc((SV*)params)); |
878 | if (! thread) { |
879 | XSRETURN_UNDEF; /* Mutex already unlocked */ |
880 | } |
881 | ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE)); |
882 | |
883 | /* Let thread run */ |
884 | MUTEX_UNLOCK(&thread->mutex); |
885 | MUTEX_UNLOCK(&create_destruct_mutex); |
886 | |
f4cc38af |
887 | /* XSRETURN(1); - implied */ |
888 | |
8222d950 |
889 | |
68795e93 |
890 | void |
f4cc38af |
891 | ithread_list(...) |
892 | PREINIT: |
893 | char *classname; |
fc04eb16 |
894 | ithread *thread; |
f4cc38af |
895 | int list_context; |
896 | IV count = 0; |
ead32952 |
897 | int want_running; |
f4cc38af |
898 | PPCODE: |
899 | /* Class method only */ |
fea7688c |
900 | if (SvROK(ST(0))) { |
ead32952 |
901 | Perl_croak(aTHX_ "Usage: threads->list(...)"); |
fea7688c |
902 | } |
f4cc38af |
903 | classname = (char *)SvPV_nolen(ST(0)); |
904 | |
905 | /* Calling context */ |
906 | list_context = (GIMME_V == G_ARRAY); |
907 | |
ead32952 |
908 | /* Running or joinable parameter */ |
909 | if (items > 1) { |
910 | want_running = SvTRUE(ST(1)); |
911 | } |
912 | |
f4cc38af |
913 | /* Walk through threads list */ |
914 | MUTEX_LOCK(&create_destruct_mutex); |
c372d929 |
915 | for (thread = main_thread.next; |
916 | thread != &main_thread; |
fc04eb16 |
917 | thread = thread->next) |
f4cc38af |
918 | { |
919 | /* Ignore detached or joined threads */ |
fc04eb16 |
920 | if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { |
f4cc38af |
921 | continue; |
922 | } |
ead32952 |
923 | |
924 | /* Filter per parameter */ |
925 | if (items > 1) { |
926 | if (want_running) { |
927 | if (thread->state & PERL_ITHR_FINISHED) { |
928 | continue; /* Not running */ |
929 | } |
930 | } else { |
931 | if (! (thread->state & PERL_ITHR_FINISHED)) { |
932 | continue; /* Still running - not joinable yet */ |
933 | } |
934 | } |
935 | } |
936 | |
f4cc38af |
937 | /* Push object on stack if list context */ |
938 | if (list_context) { |
fc04eb16 |
939 | XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); |
f4cc38af |
940 | } |
941 | count++; |
942 | } |
943 | MUTEX_UNLOCK(&create_destruct_mutex); |
944 | /* If scalar context, send back count */ |
945 | if (! list_context) { |
946 | XSRETURN_IV(count); |
947 | } |
678a9b6c |
948 | |
949 | |
950 | void |
f4cc38af |
951 | ithread_self(...) |
952 | PREINIT: |
953 | char *classname; |
fcea4b7c |
954 | ithread *thread; |
f4cc38af |
955 | CODE: |
956 | /* Class method only */ |
fea7688c |
957 | if (SvROK(ST(0))) { |
f4cc38af |
958 | Perl_croak(aTHX_ "Usage: threads->self()"); |
fea7688c |
959 | } |
f4cc38af |
960 | classname = (char *)SvPV_nolen(ST(0)); |
961 | |
fcea4b7c |
962 | thread = S_ithread_get(aTHX); |
963 | |
964 | ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
f4cc38af |
965 | /* XSRETURN(1); - implied */ |
47ba8780 |
966 | |
47ba8780 |
967 | |
968 | void |
f4cc38af |
969 | ithread_tid(...) |
970 | PREINIT: |
971 | ithread *thread; |
972 | CODE: |
973 | thread = SV_to_ithread(aTHX_ ST(0)); |
974 | XST_mUV(0, thread->tid); |
975 | /* XSRETURN(1); - implied */ |
976 | |
e1c44605 |
977 | |
f9dff5f5 |
978 | void |
f4cc38af |
979 | ithread_join(...) |
980 | PREINIT: |
fcea4b7c |
981 | ithread *thread; |
982 | int join_err; |
f4cc38af |
983 | AV *params; |
984 | int len; |
985 | int ii; |
fcea4b7c |
986 | #ifdef WIN32 |
987 | DWORD waitcode; |
988 | #else |
989 | void *retval; |
990 | #endif |
f4cc38af |
991 | PPCODE: |
992 | /* Object method only */ |
fea7688c |
993 | if (! sv_isobject(ST(0))) { |
f4cc38af |
994 | Perl_croak(aTHX_ "Usage: $thr->join()"); |
fea7688c |
995 | } |
f4cc38af |
996 | |
fcea4b7c |
997 | /* Check if the thread is joinable */ |
998 | thread = SV_to_ithread(aTHX_ ST(0)); |
fcea4b7c |
999 | join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)); |
fcea4b7c |
1000 | if (join_err) { |
1001 | if (join_err & PERL_ITHR_DETACHED) { |
1002 | Perl_croak(aTHX_ "Cannot join a detached thread"); |
1003 | } else { |
1004 | Perl_croak(aTHX_ "Thread already joined"); |
1005 | } |
1006 | } |
1007 | |
1008 | /* Join the thread */ |
1009 | #ifdef WIN32 |
1010 | waitcode = WaitForSingleObject(thread->handle, INFINITE); |
1011 | #else |
1012 | pthread_join(thread->thr, &retval); |
1013 | #endif |
1014 | |
1015 | MUTEX_LOCK(&thread->mutex); |
1016 | /* Mark as joined */ |
1017 | thread->state |= PERL_ITHR_JOINED; |
1018 | |
1019 | /* Get the return value from the call_sv */ |
1020 | { |
1021 | AV *params_copy; |
1022 | PerlInterpreter *other_perl; |
1023 | CLONE_PARAMS clone_params; |
1024 | ithread *current_thread; |
1025 | |
1026 | params_copy = (AV *)SvRV(thread->params); |
1027 | other_perl = thread->interp; |
1028 | clone_params.stashes = newAV(); |
1029 | clone_params.flags = CLONEf_JOIN_IN; |
1030 | PL_ptr_table = ptr_table_new(); |
1031 | current_thread = S_ithread_get(aTHX); |
1032 | S_ithread_set(aTHX_ thread); |
1033 | /* Ensure 'meaningful' addresses retain their meaning */ |
1034 | ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); |
1035 | ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); |
1036 | ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); |
1037 | params = (AV *)sv_dup((SV*)params_copy, &clone_params); |
1038 | S_ithread_set(aTHX_ current_thread); |
1039 | SvREFCNT_dec(clone_params.stashes); |
d4315dd6 |
1040 | SvREFCNT_inc_void(params); |
fcea4b7c |
1041 | ptr_table_free(PL_ptr_table); |
1042 | PL_ptr_table = NULL; |
1043 | } |
1044 | |
1045 | /* We are finished with the thread */ |
1046 | S_ithread_clear(aTHX_ thread); |
1047 | MUTEX_UNLOCK(&thread->mutex); |
1048 | |
4dcb9e53 |
1049 | MUTEX_LOCK(&create_destruct_mutex); |
9ca4d7fd |
1050 | if (! (thread->state & PERL_ITHR_DETACHED)) { |
1051 | joinable_threads--; |
1052 | } |
4dcb9e53 |
1053 | MUTEX_UNLOCK(&create_destruct_mutex); |
1054 | |
fcea4b7c |
1055 | /* If no return values, then just return */ |
f4cc38af |
1056 | if (! params) { |
1057 | XSRETURN_UNDEF; |
1058 | } |
1059 | |
1060 | /* Put return values on stack */ |
1061 | len = (int)AvFILL(params); |
1062 | for (ii=0; ii <= len; ii++) { |
1063 | SV* param = av_shift(params); |
1064 | XPUSHs(sv_2mortal(param)); |
1065 | } |
1066 | |
1067 | /* Free return value array */ |
1068 | SvREFCNT_dec(params); |
1069 | |
1070 | |
1071 | void |
1072 | ithread_yield(...) |
1073 | CODE: |
1074 | YIELD; |
1075 | |
1076 | |
1077 | void |
1078 | ithread_detach(...) |
1079 | PREINIT: |
1080 | ithread *thread; |
fcea4b7c |
1081 | int detach_err; |
1082 | int cleanup; |
f4cc38af |
1083 | CODE: |
fcea4b7c |
1084 | /* Check if the thread is detachable */ |
9ca4d7fd |
1085 | thread = SV_to_ithread(aTHX_ ST(0)); |
fcea4b7c |
1086 | if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) { |
fcea4b7c |
1087 | if (detach_err & PERL_ITHR_DETACHED) { |
1088 | Perl_croak(aTHX_ "Thread already detached"); |
1089 | } else { |
1090 | Perl_croak(aTHX_ "Cannot detach a joined thread"); |
1091 | } |
1092 | } |
1093 | |
1094 | /* Detach the thread */ |
9ca4d7fd |
1095 | MUTEX_LOCK(&create_destruct_mutex); |
1096 | MUTEX_LOCK(&thread->mutex); |
fcea4b7c |
1097 | thread->state |= PERL_ITHR_DETACHED; |
1098 | #ifdef WIN32 |
1099 | /* Windows has no 'detach thread' function */ |
1100 | #else |
1101 | PERL_THREAD_DETACH(thread->thr); |
1102 | #endif |
1103 | /* Cleanup if finished */ |
1104 | cleanup = (thread->state & PERL_ITHR_FINISHED); |
1105 | MUTEX_UNLOCK(&thread->mutex); |
1106 | |
4dcb9e53 |
1107 | if (cleanup) { |
1108 | joinable_threads--; |
1109 | } else { |
1110 | running_threads--; |
1111 | detached_threads++; |
1112 | } |
1113 | MUTEX_UNLOCK(&create_destruct_mutex); |
1114 | |
1115 | if (cleanup) { |
fcea4b7c |
1116 | S_ithread_destruct(aTHX_ thread); |
4dcb9e53 |
1117 | } |
f4cc38af |
1118 | |
47ba8780 |
1119 | |
1120 | void |
c0003851 |
1121 | ithread_kill(...) |
1122 | PREINIT: |
1123 | ithread *thread; |
1124 | char *sig_name; |
1125 | IV signal; |
1126 | CODE: |
1127 | /* Must have safe signals */ |
fea7688c |
1128 | if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { |
4dcb9e53 |
1129 | Perl_croak(aTHX_ "Cannot signal threads without safe signals"); |
fea7688c |
1130 | } |
c0003851 |
1131 | |
1132 | /* Object method only */ |
fea7688c |
1133 | if (! sv_isobject(ST(0))) { |
c0003851 |
1134 | Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')"); |
fea7688c |
1135 | } |
c0003851 |
1136 | |
c0003851 |
1137 | /* Get signal */ |
1138 | sig_name = SvPV_nolen(ST(1)); |
1139 | if (isALPHA(*sig_name)) { |
fea7688c |
1140 | if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') { |
c0003851 |
1141 | sig_name += 3; |
fea7688c |
1142 | } |
1143 | if ((signal = whichsig(sig_name)) < 0) { |
c0003851 |
1144 | Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name); |
fea7688c |
1145 | } |
1146 | } else { |
c0003851 |
1147 | signal = SvIV(ST(1)); |
fea7688c |
1148 | } |
c0003851 |
1149 | |
1150 | /* Set the signal for the thread */ |
4dcb9e53 |
1151 | thread = SV_to_ithread(aTHX_ ST(0)); |
1152 | MUTEX_LOCK(&thread->mutex); |
3ceb02cd |
1153 | if (thread->interp) { |
c0003851 |
1154 | dTHXa(thread->interp); |
1155 | PL_psig_pend[signal]++; |
1156 | PL_sig_pending = 1; |
1157 | } |
4dcb9e53 |
1158 | MUTEX_UNLOCK(&thread->mutex); |
c0003851 |
1159 | |
1160 | /* Return the thread to allow for method chaining */ |
1161 | ST(0) = ST(0); |
1162 | /* XSRETURN(1); - implied */ |
1163 | |
1164 | |
1165 | void |
f4cc38af |
1166 | ithread_DESTROY(...) |
1167 | CODE: |
fcea4b7c |
1168 | sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar); |
f4cc38af |
1169 | |
1170 | |
1171 | void |
1172 | ithread_equal(...) |
fc04eb16 |
1173 | PREINIT: |
1174 | int are_equal = 0; |
f4cc38af |
1175 | CODE: |
fc04eb16 |
1176 | /* Compares TIDs to determine thread equality */ |
f4cc38af |
1177 | if (sv_isobject(ST(0)) && sv_isobject(ST(1))) { |
1178 | ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1179 | ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1)))); |
fc04eb16 |
1180 | are_equal = (thr1->tid == thr2->tid); |
1181 | } |
1182 | if (are_equal) { |
1183 | XST_mYES(0); |
f4cc38af |
1184 | } else { |
fc04eb16 |
1185 | /* Return 0 on false for backward compatibility */ |
f4cc38af |
1186 | XST_mIV(0, 0); |
1187 | } |
1188 | /* XSRETURN(1); - implied */ |
1189 | |
47ba8780 |
1190 | |
47ba8780 |
1191 | void |
f4cc38af |
1192 | ithread_object(...) |
1193 | PREINIT: |
1194 | char *classname; |
1195 | UV tid; |
fc04eb16 |
1196 | ithread *thread; |
9ca4d7fd |
1197 | int have_obj = 0; |
f4cc38af |
1198 | CODE: |
1199 | /* Class method only */ |
fea7688c |
1200 | if (SvROK(ST(0))) { |
f4cc38af |
1201 | Perl_croak(aTHX_ "Usage: threads->object($tid)"); |
fea7688c |
1202 | } |
f4cc38af |
1203 | classname = (char *)SvPV_nolen(ST(0)); |
1204 | |
1205 | if ((items < 2) || ! SvOK(ST(1))) { |
1206 | XSRETURN_UNDEF; |
1207 | } |
1208 | |
fc04eb16 |
1209 | /* threads->object($tid) */ |
f4cc38af |
1210 | tid = SvUV(ST(1)); |
1211 | |
1212 | /* Walk through threads list */ |
1213 | MUTEX_LOCK(&create_destruct_mutex); |
c372d929 |
1214 | for (thread = main_thread.next; |
1215 | thread != &main_thread; |
fc04eb16 |
1216 | thread = thread->next) |
f4cc38af |
1217 | { |
9ca4d7fd |
1218 | /* Look for TID */ |
1219 | if (thread->tid == tid) { |
1220 | /* Ignore if detached or joined */ |
1221 | if (! (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) { |
1222 | /* Put object on stack */ |
1223 | ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
1224 | have_obj = 1; |
1225 | } |
1226 | break; |
f4cc38af |
1227 | } |
f4cc38af |
1228 | } |
1229 | MUTEX_UNLOCK(&create_destruct_mutex); |
9ca4d7fd |
1230 | |
1231 | if (! have_obj) { |
f4cc38af |
1232 | XSRETURN_UNDEF; |
1233 | } |
1234 | /* XSRETURN(1); - implied */ |
1235 | |
1236 | |
1237 | void |
1238 | ithread__handle(...); |
1239 | PREINIT: |
1240 | ithread *thread; |
1241 | CODE: |
1242 | thread = SV_to_ithread(aTHX_ ST(0)); |
1243 | #ifdef WIN32 |
fcea4b7c |
1244 | XST_mUV(0, PTR2UV(&thread->handle)); |
f4cc38af |
1245 | #else |
75ba4ae2 |
1246 | XST_mUV(0, PTR2UV(&thread->thr)); |
f4cc38af |
1247 | #endif |
1248 | /* XSRETURN(1); - implied */ |
68795e93 |
1249 | |
514612b7 |
1250 | |
1251 | void |
1252 | ithread_get_stack_size(...) |
1253 | PREINIT: |
1254 | IV stack_size; |
1255 | CODE: |
1256 | if (sv_isobject(ST(0))) { |
1257 | /* $thr->get_stack_size() */ |
1258 | ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1259 | stack_size = thread->stack_size; |
1260 | } else { |
1261 | /* threads->get_stack_size() */ |
1262 | stack_size = default_stack_size; |
1263 | } |
1264 | XST_mIV(0, stack_size); |
1265 | /* XSRETURN(1); - implied */ |
1266 | |
1267 | |
1268 | void |
1269 | ithread_set_stack_size(...) |
1270 | PREINIT: |
1271 | IV old_size; |
1272 | CODE: |
fea7688c |
1273 | if (items != 2) { |
514612b7 |
1274 | Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)"); |
fea7688c |
1275 | } |
1276 | if (sv_isobject(ST(0))) { |
514612b7 |
1277 | Perl_croak(aTHX_ "Cannot change stack size of an existing thread"); |
fea7688c |
1278 | } |
514612b7 |
1279 | |
1280 | old_size = default_stack_size; |
1281 | default_stack_size = good_stack_size(aTHX_ SvIV(ST(1))); |
1282 | XST_mIV(0, old_size); |
1283 | /* XSRETURN(1); - implied */ |
1284 | |
ead32952 |
1285 | |
1286 | void |
1287 | ithread_is_running(...) |
1288 | PREINIT: |
1289 | ithread *thread; |
1290 | CODE: |
1291 | /* Object method only */ |
fea7688c |
1292 | if (! sv_isobject(ST(0))) { |
ead32952 |
1293 | Perl_croak(aTHX_ "Usage: $thr->is_running()"); |
fea7688c |
1294 | } |
ead32952 |
1295 | |
1296 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
ead32952 |
1297 | ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes; |
ead32952 |
1298 | /* XSRETURN(1); - implied */ |
1299 | |
1300 | |
1301 | void |
1302 | ithread_is_detached(...) |
1303 | PREINIT: |
1304 | ithread *thread; |
1305 | CODE: |
1306 | thread = SV_to_ithread(aTHX_ ST(0)); |
ead32952 |
1307 | ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no; |
ead32952 |
1308 | /* XSRETURN(1); - implied */ |
1309 | |
1310 | |
1311 | void |
1312 | ithread_is_joinable(...) |
1313 | PREINIT: |
1314 | ithread *thread; |
1315 | CODE: |
1316 | /* Object method only */ |
fea7688c |
1317 | if (! sv_isobject(ST(0))) { |
ead32952 |
1318 | Perl_croak(aTHX_ "Usage: $thr->is_joinable()"); |
fea7688c |
1319 | } |
ead32952 |
1320 | |
1321 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1322 | MUTEX_LOCK(&thread->mutex); |
1323 | ST(0) = ((thread->state & PERL_ITHR_FINISHED) && |
1324 | ! (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) |
1325 | ? &PL_sv_yes : &PL_sv_no; |
1326 | MUTEX_UNLOCK(&thread->mutex); |
1327 | /* XSRETURN(1); - implied */ |
1328 | |
1329 | |
1330 | void |
1331 | ithread_wantarray(...) |
1332 | PREINIT: |
1333 | ithread *thread; |
1334 | CODE: |
1335 | thread = SV_to_ithread(aTHX_ ST(0)); |
ead32952 |
1336 | ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes : |
1337 | (thread->gimme & G_VOID) ? &PL_sv_undef |
1338 | /* G_SCALAR */ : &PL_sv_no; |
ead32952 |
1339 | /* XSRETURN(1); - implied */ |
1340 | |
69a9b4b8 |
1341 | |
1342 | void |
1343 | ithread_set_thread_exit_only(...) |
1344 | PREINIT: |
1345 | ithread *thread; |
1346 | CODE: |
fea7688c |
1347 | if (items != 2) { |
69a9b4b8 |
1348 | Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)"); |
fea7688c |
1349 | } |
69a9b4b8 |
1350 | thread = SV_to_ithread(aTHX_ ST(0)); |
1351 | MUTEX_LOCK(&thread->mutex); |
1352 | if (SvTRUE(ST(1))) { |
1353 | thread->state |= PERL_ITHR_THREAD_EXIT_ONLY; |
1354 | } else { |
1355 | thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY; |
1356 | } |
1357 | MUTEX_UNLOCK(&thread->mutex); |
1358 | |
73e09c8f |
1359 | #endif /* USE_ITHREADS */ |
1360 | |
fc04eb16 |
1361 | |
68795e93 |
1362 | BOOT: |
1363 | { |
73e09c8f |
1364 | #ifdef USE_ITHREADS |
fc04eb16 |
1365 | MY_CXT_INIT; |
1366 | |
1367 | PL_perl_destruct_level = 2; |
1368 | MUTEX_INIT(&create_destruct_mutex); |
1369 | MUTEX_LOCK(&create_destruct_mutex); |
1370 | |
1371 | PL_threadhook = &Perl_ithread_hook; |
1372 | |
c372d929 |
1373 | /* The 'main' thread is thread 0. |
1374 | * It is detached (unjoinable) and immortal. |
1375 | */ |
1376 | Zero(&main_thread, 1, ithread); /* Thread 0 */ |
fc04eb16 |
1377 | |
c372d929 |
1378 | MUTEX_INIT(&main_thread.mutex); |
fc04eb16 |
1379 | |
1380 | /* Head of the threads list */ |
c372d929 |
1381 | main_thread.next = &main_thread; |
1382 | main_thread.prev = &main_thread; |
fc04eb16 |
1383 | |
c372d929 |
1384 | main_thread.count = 1; /* Immortal */ |
fc04eb16 |
1385 | |
c372d929 |
1386 | main_thread.interp = aTHX; |
1387 | main_thread.state = PERL_ITHR_DETACHED; /* Detached */ |
1388 | main_thread.stack_size = default_stack_size; |
fc04eb16 |
1389 | # ifdef WIN32 |
c372d929 |
1390 | main_thread.thr = GetCurrentThreadId(); |
fc04eb16 |
1391 | # else |
c372d929 |
1392 | main_thread.thr = pthread_self(); |
fc04eb16 |
1393 | # endif |
1394 | |
c372d929 |
1395 | S_ithread_set(aTHX_ &main_thread); |
fc04eb16 |
1396 | MUTEX_UNLOCK(&create_destruct_mutex); |
73e09c8f |
1397 | #endif /* USE_ITHREADS */ |
68795e93 |
1398 | } |