Commit | Line | Data |
68795e93 |
1 | #define PERL_NO_GET_CONTEXT |
fa58a56f |
2 | /* Workaround for mingw 32-bit compiler by mingw-w64.sf.net - has to come before any #include. |
3 | * It also defines USE_NO_MINGW_SETJMP_TWO_ARGS for the mingw.org 32-bit compilers ... but |
4 | * that's ok as that compiler makes no use of that symbol anyway */ |
5 | #if defined(WIN32) && defined(__MINGW32__) && !defined(__MINGW64__) |
6 | # define USE_NO_MINGW_SETJMP_TWO_ARGS 1 |
7 | #endif |
68795e93 |
8 | #include "EXTERN.h" |
9 | #include "perl.h" |
10 | #include "XSUB.h" |
4dcb9e53 |
11 | /* Workaround for XSUB.h bug under WIN32 */ |
12 | #ifdef WIN32 |
13 | # undef setjmp |
fa58a56f |
14 | # if defined(USE_NO_MINGW_SETJMP_TWO_ARGS) || (!defined(__BORLANDC__) && !defined(__MINGW64__)) |
c608f8c0 |
15 | # define setjmp(x) _setjmp(x) |
16 | # endif |
4dcb9e53 |
17 | #endif |
0f1612a7 |
18 | #ifdef HAS_PPPORT_H |
404aaa48 |
19 | # define NEED_PL_signals |
0f1612a7 |
20 | # define NEED_newRV_noinc |
dcefd27c |
21 | # define NEED_sv_2pv_flags |
0f1612a7 |
22 | # include "ppport.h" |
23 | # include "threads.h" |
24 | #endif |
68795e93 |
25 | |
73e09c8f |
26 | #ifdef USE_ITHREADS |
27 | |
68795e93 |
28 | #ifdef WIN32 |
fc04eb16 |
29 | # include <windows.h> |
514612b7 |
30 | /* Supposed to be in Winbase.h */ |
31 | # ifndef STACK_SIZE_PARAM_IS_A_RESERVATION |
32 | # define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000 |
33 | # endif |
fc04eb16 |
34 | # include <win32thread.h> |
68795e93 |
35 | #else |
fc04eb16 |
36 | # ifdef OS2 |
5c728af0 |
37 | typedef perl_os_thread pthread_t; |
fc04eb16 |
38 | # else |
39 | # include <pthread.h> |
40 | # endif |
41 | # include <thread.h> |
42 | # define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v) |
43 | # ifdef OLD_PTHREADS_API |
44 | # define PERL_THREAD_DETACH(t) pthread_detach(&(t)) |
45 | # else |
46 | # define PERL_THREAD_DETACH(t) pthread_detach((t)) |
47 | # endif |
467f3f08 |
48 | #endif |
d305c2c9 |
49 | #if !defined(HAS_GETPAGESIZE) && defined(I_SYS_PARAM) |
50 | # include <sys/param.h> |
51 | #endif |
68795e93 |
52 | |
62375a60 |
53 | /* Values for 'state' member */ |
6ebc233e |
54 | #define PERL_ITHR_DETACHED 1 /* Thread has been detached */ |
55 | #define PERL_ITHR_JOINED 2 /* Thread has been joined */ |
56 | #define PERL_ITHR_FINISHED 4 /* Thread has finished execution */ |
6158f8b3 |
57 | #define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */ |
6ebc233e |
58 | #define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */ |
59 | #define PERL_ITHR_DIED 32 /* Thread finished by dying */ |
6158f8b3 |
60 | |
61 | #define PERL_ITHR_UNCALLABLE (PERL_ITHR_DETACHED|PERL_ITHR_JOINED) |
62 | |
fc04eb16 |
63 | |
64 | typedef struct _ithread { |
65 | struct _ithread *next; /* Next thread in the list */ |
66 | struct _ithread *prev; /* Prev thread in the list */ |
67 | PerlInterpreter *interp; /* The threads interpreter */ |
68 | UV tid; /* Threads module's thread id */ |
69 | perl_mutex mutex; /* Mutex for updating things in this struct */ |
6ebc233e |
70 | int count; /* Reference count. See S_ithread_create. */ |
fc04eb16 |
71 | int state; /* Detached, joined, finished, etc. */ |
72 | int gimme; /* Context of create */ |
73 | SV *init_function; /* Code to run */ |
74 | SV *params; /* Args to pass function */ |
68795e93 |
75 | #ifdef WIN32 |
fc04eb16 |
76 | DWORD thr; /* OS's idea if thread id */ |
77 | HANDLE handle; /* OS's waitable handle */ |
68795e93 |
78 | #else |
fc04eb16 |
79 | pthread_t thr; /* OS's handle for the thread */ |
68795e93 |
80 | #endif |
514612b7 |
81 | IV stack_size; |
955c272e |
82 | SV *err; /* Error from abnormally terminated thread */ |
83 | char *err_class; /* Error object's classname if applicable */ |
8264cf32 |
84 | #ifndef WIN32 |
b762d866 |
85 | sigset_t initial_sigmask; /* Thread wakes up with signals blocked */ |
8264cf32 |
86 | #endif |
68795e93 |
87 | } ithread; |
88 | |
fc04eb16 |
89 | |
5c6ff896 |
90 | #define MY_CXT_KEY "threads::_cxt" XS_VERSION |
628ab322 |
91 | |
92 | typedef struct { |
861d5cbe |
93 | /* Used by Perl interpreter for thread context switching */ |
94 | ithread *context; |
628ab322 |
95 | } my_cxt_t; |
96 | |
97 | START_MY_CXT |
98 | |
68795e93 |
99 | |
5c6ff896 |
100 | #define MY_POOL_KEY "threads::_pool" XS_VERSION |
68795e93 |
101 | |
5c6ff896 |
102 | typedef struct { |
103 | /* Structure for 'main' thread |
104 | * Also forms the 'base' for the doubly-linked list of threads */ |
105 | ithread main_thread; |
106 | |
107 | /* Protects the creation and destruction of threads*/ |
108 | perl_mutex create_destruct_mutex; |
109 | |
110 | UV tid_counter; |
111 | IV joinable_threads; |
112 | IV running_threads; |
113 | IV detached_threads; |
e9a908c9 |
114 | IV total_threads; |
5c6ff896 |
115 | IV default_stack_size; |
116 | IV page_size; |
117 | } my_pool_t; |
118 | |
119 | #define dMY_POOL \ |
120 | SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, \ |
121 | sizeof(MY_POOL_KEY)-1, TRUE); \ |
122 | my_pool_t *my_poolp = INT2PTR(my_pool_t*, SvUV(my_pool_sv)) |
123 | |
124 | #define MY_POOL (*my_poolp) |
c05ae023 |
125 | |
8264cf32 |
126 | #ifndef WIN32 |
b762d866 |
127 | /* Block most signals for calling thread, setting the old signal mask to |
128 | * oldmask, if it is not NULL */ |
129 | STATIC int |
130 | S_block_most_signals(sigset_t *oldmask) |
131 | { |
132 | sigset_t newmask; |
133 | |
134 | sigfillset(&newmask); |
135 | /* Don't block certain "important" signals (stolen from mg.c) */ |
136 | #ifdef SIGILL |
137 | sigdelset(&newmask, SIGILL); |
138 | #endif |
139 | #ifdef SIGBUS |
140 | sigdelset(&newmask, SIGBUS); |
141 | #endif |
142 | #ifdef SIGSEGV |
143 | sigdelset(&newmask, SIGSEGV); |
144 | #endif |
145 | |
8264cf32 |
146 | #if defined(VMS) |
d2aa556d |
147 | /* no per-thread blocking available */ |
148 | return sigprocmask(SIG_BLOCK, &newmask, oldmask); |
b762d866 |
149 | #else |
150 | return pthread_sigmask(SIG_BLOCK, &newmask, oldmask); |
bcbea5d2 |
151 | #endif /* VMS */ |
b762d866 |
152 | } |
153 | |
154 | /* Set the signal mask for this thread to newmask */ |
155 | STATIC int |
156 | S_set_sigmask(sigset_t *newmask) |
157 | { |
8264cf32 |
158 | #if defined(VMS) |
d2aa556d |
159 | return sigprocmask(SIG_SETMASK, newmask, NULL); |
b762d866 |
160 | #else |
161 | return pthread_sigmask(SIG_SETMASK, newmask, NULL); |
bcbea5d2 |
162 | #endif /* VMS */ |
b762d866 |
163 | } |
bcbea5d2 |
164 | #endif /* WIN32 */ |
c05ae023 |
165 | |
fc04eb16 |
166 | /* Used by Perl interpreter for thread context switching */ |
861d5cbe |
167 | STATIC void |
fc04eb16 |
168 | S_ithread_set(pTHX_ ithread *thread) |
c05ae023 |
169 | { |
628ab322 |
170 | dMY_CXT; |
861d5cbe |
171 | MY_CXT.context = thread; |
c05ae023 |
172 | } |
173 | |
861d5cbe |
174 | STATIC ithread * |
fc04eb16 |
175 | S_ithread_get(pTHX) |
176 | { |
628ab322 |
177 | dMY_CXT; |
861d5cbe |
178 | return (MY_CXT.context); |
c05ae023 |
179 | } |
180 | |
181 | |
fc04eb16 |
182 | /* Free any data (such as the Perl interpreter) attached to an ithread |
183 | * structure. This is a bit like undef on SVs, where the SV isn't freed, |
6ebc233e |
184 | * but the PVX is. Must be called with thread->mutex already locked. Also, |
185 | * must be called with MY_POOL.create_destruct_mutex unlocked as destruction |
186 | * of the interpreter can lead to recursive destruction calls that could |
187 | * lead to a deadlock on that mutex. |
2e676467 |
188 | */ |
861d5cbe |
189 | STATIC void |
fc04eb16 |
190 | S_ithread_clear(pTHX_ ithread *thread) |
2e676467 |
191 | { |
192 | PerlInterpreter *interp; |
bcbea5d2 |
193 | #ifndef WIN32 |
b762d866 |
194 | sigset_t origmask; |
bcbea5d2 |
195 | #endif |
fc04eb16 |
196 | |
adc09a0e |
197 | assert(((thread->state & PERL_ITHR_FINISHED) && |
8718f9a1 |
198 | (thread->state & PERL_ITHR_UNCALLABLE)) |
adc09a0e |
199 | || |
200 | (thread->state & PERL_ITHR_NONVIABLE)); |
2e676467 |
201 | |
8264cf32 |
202 | #ifndef WIN32 |
b762d866 |
203 | /* We temporarily set the interpreter context to the interpreter being |
204 | * destroyed. It's in no condition to handle signals while it's being |
205 | * taken apart. |
206 | */ |
207 | S_block_most_signals(&origmask); |
8264cf32 |
208 | #endif |
b762d866 |
209 | |
2e676467 |
210 | interp = thread->interp; |
211 | if (interp) { |
fc04eb16 |
212 | dTHXa(interp); |
213 | |
214 | PERL_SET_CONTEXT(interp); |
215 | S_ithread_set(aTHX_ thread); |
f2cba68d |
216 | |
fc04eb16 |
217 | SvREFCNT_dec(thread->params); |
218 | thread->params = Nullsv; |
2e676467 |
219 | |
955c272e |
220 | if (thread->err) { |
221 | SvREFCNT_dec(thread->err); |
222 | thread->err = Nullsv; |
223 | } |
224 | |
fc04eb16 |
225 | perl_destruct(interp); |
9ca4d7fd |
226 | perl_free(interp); |
fc04eb16 |
227 | thread->interp = NULL; |
2e676467 |
228 | } |
fc04eb16 |
229 | |
2e676467 |
230 | PERL_SET_CONTEXT(aTHX); |
8264cf32 |
231 | #ifndef WIN32 |
b762d866 |
232 | S_set_sigmask(&origmask); |
8264cf32 |
233 | #endif |
2e676467 |
234 | } |
235 | |
68795e93 |
236 | |
6158f8b3 |
237 | /* Decrement the refcount of an ithread, and if it reaches zero, free it. |
238 | * Must be called with the mutex held. |
6ebc233e |
239 | * On return, mutex is released (or destroyed). |
240 | */ |
861d5cbe |
241 | STATIC void |
6158f8b3 |
242 | S_ithread_free(pTHX_ ithread *thread) |
68795e93 |
243 | { |
385d56e4 |
244 | #ifdef WIN32 |
fc04eb16 |
245 | HANDLE handle; |
385d56e4 |
246 | #endif |
adc09a0e |
247 | dMY_POOL; |
248 | |
6158f8b3 |
249 | if (! (thread->state & PERL_ITHR_NONVIABLE)) { |
250 | assert(thread->count > 0); |
251 | if (--thread->count > 0) { |
252 | MUTEX_UNLOCK(&thread->mutex); |
253 | return; |
254 | } |
6ebc233e |
255 | assert((thread->state & PERL_ITHR_FINISHED) && |
256 | (thread->state & PERL_ITHR_UNCALLABLE)); |
fc04eb16 |
257 | } |
adc09a0e |
258 | MUTEX_UNLOCK(&thread->mutex); |
9feacc09 |
259 | |
fc04eb16 |
260 | /* Main thread (0) is immortal and should never get here */ |
261 | assert(thread->tid != 0); |
262 | |
263 | /* Remove from circular list of threads */ |
5c6ff896 |
264 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
adc09a0e |
265 | assert(thread->prev && thread->next); |
266 | thread->next->prev = thread->prev; |
267 | thread->prev->next = thread->next; |
fc04eb16 |
268 | thread->next = NULL; |
269 | thread->prev = NULL; |
5c6ff896 |
270 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
c2f2a82b |
271 | |
fc04eb16 |
272 | /* Thread is now disowned */ |
9ca4d7fd |
273 | MUTEX_LOCK(&thread->mutex); |
fc04eb16 |
274 | S_ithread_clear(aTHX_ thread); |
385d56e4 |
275 | |
276 | #ifdef WIN32 |
fc04eb16 |
277 | handle = thread->handle; |
278 | thread->handle = NULL; |
385d56e4 |
279 | #endif |
fc04eb16 |
280 | MUTEX_UNLOCK(&thread->mutex); |
281 | MUTEX_DESTROY(&thread->mutex); |
385d56e4 |
282 | |
c7667023 |
283 | #ifdef WIN32 |
fea7688c |
284 | if (handle) { |
fc04eb16 |
285 | CloseHandle(handle); |
fea7688c |
286 | } |
c7667023 |
287 | #endif |
385d56e4 |
288 | |
fc04eb16 |
289 | PerlMemShared_free(thread); |
ae3fba3d |
290 | |
291 | /* total_threads >= 1 is used to veto cleanup by the main thread, |
292 | * should it happen to exit while other threads still exist. |
6ebc233e |
293 | * Decrement this as the very last thing in the thread's existence. |
294 | * Otherwise, MY_POOL and global state such as PL_op_mutex may get |
295 | * freed while we're still using it. |
ae3fba3d |
296 | */ |
297 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
298 | MY_POOL.total_threads--; |
299 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
68795e93 |
300 | } |
301 | |
fc04eb16 |
302 | |
6158f8b3 |
303 | static void |
304 | S_ithread_count_inc(pTHX_ ithread *thread) |
305 | { |
306 | MUTEX_LOCK(&thread->mutex); |
307 | thread->count++; |
308 | MUTEX_UNLOCK(&thread->mutex); |
309 | } |
310 | |
311 | |
69a9b4b8 |
312 | /* Warn if exiting with any unjoined threads */ |
861d5cbe |
313 | STATIC int |
69a9b4b8 |
314 | S_exit_warning(pTHX) |
62375a60 |
315 | { |
e9a908c9 |
316 | int veto_cleanup, warn; |
adc09a0e |
317 | dMY_POOL; |
69a9b4b8 |
318 | |
5c6ff896 |
319 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
e9a908c9 |
320 | veto_cleanup = (MY_POOL.total_threads > 0); |
321 | warn = (MY_POOL.running_threads || MY_POOL.joinable_threads); |
5c6ff896 |
322 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
60bd5ef6 |
323 | |
e9a908c9 |
324 | if (warn) { |
fc04eb16 |
325 | if (ckWARN_d(WARN_THREADS)) { |
4dcb9e53 |
326 | Perl_warn(aTHX_ "Perl exited with active threads:\n\t%" |
327 | IVdf " running and unjoined\n\t%" |
328 | IVdf " finished and unjoined\n\t%" |
329 | IVdf " running and detached\n", |
5c6ff896 |
330 | MY_POOL.running_threads, |
331 | MY_POOL.joinable_threads, |
332 | MY_POOL.detached_threads); |
fc04eb16 |
333 | } |
62375a60 |
334 | } |
69a9b4b8 |
335 | |
fc04eb16 |
336 | return (veto_cleanup); |
62375a60 |
337 | } |
338 | |
ae3fba3d |
339 | |
6ebc233e |
340 | /* Called from perl_destruct() in each thread. If it's the main thread, |
341 | * stop it from freeing everything if there are other threads still running. |
342 | */ |
69a9b4b8 |
343 | int |
344 | Perl_ithread_hook(pTHX) |
345 | { |
5c6ff896 |
346 | dMY_POOL; |
b5c80a23 |
347 | return ((aTHX == MY_POOL.main_thread.interp) ? S_exit_warning(aTHX) : 0); |
69a9b4b8 |
348 | } |
349 | |
68795e93 |
350 | |
351 | /* MAGIC (in mg.h sense) hooks */ |
352 | |
353 | int |
354 | ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) |
355 | { |
fc04eb16 |
356 | ithread *thread = (ithread *)mg->mg_ptr; |
45977657 |
357 | SvIV_set(sv, PTR2IV(thread)); |
68795e93 |
358 | SvIOK_on(sv); |
fc04eb16 |
359 | return (0); |
68795e93 |
360 | } |
361 | |
362 | int |
363 | ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) |
364 | { |
f2cba68d |
365 | ithread *thread = (ithread *)mg->mg_ptr; |
68795e93 |
366 | MUTEX_LOCK(&thread->mutex); |
6ebc233e |
367 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
fc04eb16 |
368 | return (0); |
68795e93 |
369 | } |
370 | |
371 | int |
372 | ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
373 | { |
6158f8b3 |
374 | S_ithread_count_inc(aTHX_ (ithread *)mg->mg_ptr); |
fc04eb16 |
375 | return (0); |
68795e93 |
376 | } |
377 | |
378 | MGVTBL ithread_vtbl = { |
fc04eb16 |
379 | ithread_mg_get, /* get */ |
380 | 0, /* set */ |
381 | 0, /* len */ |
382 | 0, /* clear */ |
383 | ithread_mg_free, /* free */ |
384 | 0, /* copy */ |
385 | ithread_mg_dup /* dup */ |
68795e93 |
386 | }; |
387 | |
47ba8780 |
388 | |
514612b7 |
389 | /* Provided default, minimum and rational stack sizes */ |
861d5cbe |
390 | STATIC IV |
391 | S_good_stack_size(pTHX_ IV stack_size) |
514612b7 |
392 | { |
5c6ff896 |
393 | dMY_POOL; |
394 | |
514612b7 |
395 | /* Use default stack size if no stack size specified */ |
fea7688c |
396 | if (! stack_size) { |
5c6ff896 |
397 | return (MY_POOL.default_stack_size); |
fea7688c |
398 | } |
514612b7 |
399 | |
400 | #ifdef PTHREAD_STACK_MIN |
401 | /* Can't use less than minimum */ |
402 | if (stack_size < PTHREAD_STACK_MIN) { |
4dcb9e53 |
403 | if (ckWARN(WARN_THREADS)) { |
514612b7 |
404 | Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN); |
405 | } |
406 | return (PTHREAD_STACK_MIN); |
407 | } |
408 | #endif |
409 | |
410 | /* Round up to page size boundary */ |
5c6ff896 |
411 | if (MY_POOL.page_size <= 0) { |
d305c2c9 |
412 | #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) |
514612b7 |
413 | SETERRNO(0, SS_NORMAL); |
d305c2c9 |
414 | # ifdef _SC_PAGESIZE |
5c6ff896 |
415 | MY_POOL.page_size = sysconf(_SC_PAGESIZE); |
d305c2c9 |
416 | # else |
5c6ff896 |
417 | MY_POOL.page_size = sysconf(_SC_MMAP_PAGE_SIZE); |
d305c2c9 |
418 | # endif |
5c6ff896 |
419 | if ((long)MY_POOL.page_size < 0) { |
514612b7 |
420 | if (errno) { |
8583b257 |
421 | SV * const error = get_sv("@", 0); |
514612b7 |
422 | (void)SvUPGRADE(error, SVt_PV); |
423 | Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error)); |
424 | } else { |
425 | Perl_croak(aTHX_ "PANIC: sysconf: pagesize unknown"); |
426 | } |
427 | } |
d305c2c9 |
428 | #else |
429 | # ifdef HAS_GETPAGESIZE |
5c6ff896 |
430 | MY_POOL.page_size = getpagesize(); |
514612b7 |
431 | # else |
d305c2c9 |
432 | # if defined(I_SYS_PARAM) && defined(PAGESIZE) |
5c6ff896 |
433 | MY_POOL.page_size = PAGESIZE; |
d305c2c9 |
434 | # else |
5c6ff896 |
435 | MY_POOL.page_size = 8192; /* A conservative default */ |
d305c2c9 |
436 | # endif |
514612b7 |
437 | # endif |
5c6ff896 |
438 | if (MY_POOL.page_size <= 0) { |
439 | Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)MY_POOL.page_size); |
fea7688c |
440 | } |
514612b7 |
441 | #endif |
442 | } |
5c6ff896 |
443 | stack_size = ((stack_size + (MY_POOL.page_size - 1)) / MY_POOL.page_size) * MY_POOL.page_size; |
514612b7 |
444 | |
445 | return (stack_size); |
446 | } |
447 | |
448 | |
fc04eb16 |
449 | /* Starts executing the thread. |
450 | * Passed as the C level function to run in the new thread. |
b1edfb69 |
451 | */ |
47ba8780 |
452 | #ifdef WIN32 |
861d5cbe |
453 | STATIC THREAD_RET_TYPE |
fc04eb16 |
454 | S_ithread_run(LPVOID arg) |
47ba8780 |
455 | #else |
861d5cbe |
456 | STATIC void * |
fc04eb16 |
457 | S_ithread_run(void * arg) |
47ba8780 |
458 | #endif |
fc04eb16 |
459 | { |
460 | ithread *thread = (ithread *)arg; |
69a9b4b8 |
461 | int jmp_rc = 0; |
462 | I32 oldscope; |
955c272e |
463 | int exit_app = 0; /* Thread terminated using 'exit' */ |
69a9b4b8 |
464 | int exit_code = 0; |
955c272e |
465 | int died = 0; /* Thread terminated abnormally */ |
f2cba68d |
466 | |
69a9b4b8 |
467 | dJMPENV; |
468 | |
fc04eb16 |
469 | dTHXa(thread->interp); |
47ba8780 |
470 | |
5c6ff896 |
471 | dMY_POOL; |
472 | |
9ca4d7fd |
473 | /* Blocked until ->create() call finishes */ |
fc04eb16 |
474 | MUTEX_LOCK(&thread->mutex); |
fc04eb16 |
475 | MUTEX_UNLOCK(&thread->mutex); |
9ca4d7fd |
476 | |
477 | PERL_SET_CONTEXT(thread->interp); |
478 | S_ithread_set(aTHX_ thread); |
47ba8780 |
479 | |
8264cf32 |
480 | #ifndef WIN32 |
b762d866 |
481 | /* Thread starts with most signals blocked - restore the signal mask from |
482 | * the ithread struct. |
483 | */ |
484 | S_set_sigmask(&thread->initial_sigmask); |
8264cf32 |
485 | #endif |
b762d866 |
486 | |
fc04eb16 |
487 | PL_perl_destruct_level = 2; |
f2cba68d |
488 | |
fc04eb16 |
489 | { |
490 | AV *params = (AV *)SvRV(thread->params); |
491 | int len = (int)av_len(params)+1; |
492 | int ii; |
493 | |
494 | dSP; |
495 | ENTER; |
496 | SAVETMPS; |
497 | |
498 | /* Put args on the stack */ |
499 | PUSHMARK(SP); |
500 | for (ii=0; ii < len; ii++) { |
501 | XPUSHs(av_shift(params)); |
502 | } |
503 | PUTBACK; |
504 | |
4dcb9e53 |
505 | oldscope = PL_scopestack_ix; |
506 | JMPENV_PUSH(jmp_rc); |
507 | if (jmp_rc == 0) { |
508 | /* Run the specified function */ |
509 | len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL); |
510 | } else if (jmp_rc == 2) { |
69a9b4b8 |
511 | /* Thread exited */ |
512 | exit_app = 1; |
513 | exit_code = STATUS_CURRENT; |
4dcb9e53 |
514 | while (PL_scopestack_ix > oldscope) { |
515 | LEAVE; |
516 | } |
517 | } |
518 | JMPENV_POP; |
fc04eb16 |
519 | |
8264cf32 |
520 | #ifndef WIN32 |
b762d866 |
521 | /* The interpreter is finished, so this thread can stop receiving |
522 | * signals. This way, our signal handler doesn't get called in the |
523 | * middle of our parent thread calling perl_destruct()... |
524 | */ |
525 | S_block_most_signals(NULL); |
8264cf32 |
526 | #endif |
b762d866 |
527 | |
fc04eb16 |
528 | /* Remove args from stack and put back in params array */ |
529 | SPAGAIN; |
530 | for (ii=len-1; ii >= 0; ii--) { |
531 | SV *sv = POPs; |
7df0357e |
532 | if (jmp_rc == 0 && (thread->gimme & G_WANT) != G_VOID) { |
4dcb9e53 |
533 | av_store(params, ii, SvREFCNT_inc(sv)); |
534 | } |
fc04eb16 |
535 | } |
536 | |
4dcb9e53 |
537 | FREETMPS; |
538 | LEAVE; |
539 | |
955c272e |
540 | /* Check for abnormal termination */ |
541 | if (SvTRUE(ERRSV)) { |
542 | died = PERL_ITHR_DIED; |
543 | thread->err = newSVsv(ERRSV); |
544 | /* If ERRSV is an object, remember the classname and then |
545 | * rebless into 'main' so it will survive 'cloning' |
546 | */ |
547 | if (sv_isobject(thread->err)) { |
548 | thread->err_class = HvNAME(SvSTASH(SvRV(thread->err))); |
549 | sv_bless(thread->err, gv_stashpv("main", 0)); |
550 | } |
551 | |
552 | if (ckWARN_d(WARN_THREADS)) { |
553 | oldscope = PL_scopestack_ix; |
554 | JMPENV_PUSH(jmp_rc); |
555 | if (jmp_rc == 0) { |
556 | /* Warn that thread died */ |
557 | Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV); |
558 | } else if (jmp_rc == 2) { |
559 | /* Warn handler exited */ |
560 | exit_app = 1; |
561 | exit_code = STATUS_CURRENT; |
562 | while (PL_scopestack_ix > oldscope) { |
563 | LEAVE; |
564 | } |
4dcb9e53 |
565 | } |
955c272e |
566 | JMPENV_POP; |
4dcb9e53 |
567 | } |
fc04eb16 |
568 | } |
569 | |
fc04eb16 |
570 | /* Release function ref */ |
571 | SvREFCNT_dec(thread->init_function); |
572 | thread->init_function = Nullsv; |
573 | } |
62375a60 |
574 | |
fc04eb16 |
575 | PerlIO_flush((PerlIO *)NULL); |
576 | |
5c6ff896 |
577 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
fc04eb16 |
578 | MUTEX_LOCK(&thread->mutex); |
579 | /* Mark as finished */ |
955c272e |
580 | thread->state |= (PERL_ITHR_FINISHED | died); |
69a9b4b8 |
581 | /* Clear exit flag if required */ |
fea7688c |
582 | if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) { |
69a9b4b8 |
583 | exit_app = 0; |
fea7688c |
584 | } |
fc04eb16 |
585 | |
69a9b4b8 |
586 | /* Adjust thread status counts */ |
adc09a0e |
587 | if (thread->state & PERL_ITHR_DETACHED) { |
5c6ff896 |
588 | MY_POOL.detached_threads--; |
4dcb9e53 |
589 | } else { |
5c6ff896 |
590 | MY_POOL.running_threads--; |
591 | MY_POOL.joinable_threads++; |
5168baf3 |
592 | } |
adc09a0e |
593 | MUTEX_UNLOCK(&thread->mutex); |
5c6ff896 |
594 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
69a9b4b8 |
595 | |
596 | /* Exit application if required */ |
597 | if (exit_app) { |
598 | oldscope = PL_scopestack_ix; |
599 | JMPENV_PUSH(jmp_rc); |
600 | if (jmp_rc == 0) { |
601 | /* Warn if there are unjoined threads */ |
602 | S_exit_warning(aTHX); |
603 | } else if (jmp_rc == 2) { |
604 | /* Warn handler exited */ |
605 | exit_code = STATUS_CURRENT; |
606 | while (PL_scopestack_ix > oldscope) { |
607 | LEAVE; |
608 | } |
609 | } |
610 | JMPENV_POP; |
611 | |
612 | my_exit(exit_code); |
613 | } |
614 | |
6ebc233e |
615 | /* At this point, the interpreter may have been freed, so call |
616 | * free in the the context of of the 'main' interpreter which |
617 | * can't have been freed due to the veto_cleanup mechanism. |
618 | */ |
46c5d8f1 |
619 | aTHX = MY_POOL.main_thread.interp; |
620 | |
6158f8b3 |
621 | MUTEX_LOCK(&thread->mutex); |
6ebc233e |
622 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
91604d21 |
623 | |
47ba8780 |
624 | #ifdef WIN32 |
fc04eb16 |
625 | return ((DWORD)0); |
e8f2bb9a |
626 | #else |
fc04eb16 |
627 | return (0); |
47ba8780 |
628 | #endif |
68795e93 |
629 | } |
630 | |
fc04eb16 |
631 | |
632 | /* Type conversion helper functions */ |
fea7688c |
633 | |
861d5cbe |
634 | STATIC SV * |
635 | S_ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) |
68795e93 |
636 | { |
637 | SV *sv; |
638 | MAGIC *mg; |
fc04eb16 |
639 | |
6158f8b3 |
640 | if (inc) |
641 | S_ithread_count_inc(aTHX_ thread); |
fc04eb16 |
642 | |
643 | if (! obj) { |
644 | obj = newSV(0); |
68795e93 |
645 | } |
fc04eb16 |
646 | |
647 | sv = newSVrv(obj, classname); |
648 | sv_setiv(sv, PTR2IV(thread)); |
649 | mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0); |
68795e93 |
650 | mg->mg_flags |= MGf_DUP; |
651 | SvREADONLY_on(sv); |
fc04eb16 |
652 | |
653 | return (obj); |
68795e93 |
654 | } |
47ba8780 |
655 | |
861d5cbe |
656 | STATIC ithread * |
657 | S_SV_to_ithread(pTHX_ SV *sv) |
68795e93 |
658 | { |
fc04eb16 |
659 | /* Argument is a thread */ |
660 | if (SvROK(sv)) { |
661 | return (INT2PTR(ithread *, SvIV(SvRV(sv)))); |
662 | } |
663 | /* Argument is classname, therefore return current thread */ |
664 | return (S_ithread_get(aTHX)); |
47ba8780 |
665 | } |
666 | |
47ba8780 |
667 | |
fc04eb16 |
668 | /* threads->create() |
669 | * Called in context of parent thread. |
5c6ff896 |
670 | * Called with MY_POOL.create_destruct_mutex locked. (Unlocked on error.) |
fc04eb16 |
671 | */ |
861d5cbe |
672 | STATIC ithread * |
fc04eb16 |
673 | S_ithread_create( |
9ca4d7fd |
674 | pTHX_ SV *init_function, |
514612b7 |
675 | IV stack_size, |
9d9ff5b1 |
676 | int gimme, |
69a9b4b8 |
677 | int exit_opt, |
fc04eb16 |
678 | SV *params) |
68795e93 |
679 | { |
fc04eb16 |
680 | ithread *thread; |
fc04eb16 |
681 | ithread *current_thread = S_ithread_get(aTHX); |
3b1c3273 |
682 | |
fc04eb16 |
683 | SV **tmps_tmp = PL_tmps_stack; |
684 | IV tmps_ix = PL_tmps_ix; |
d94006e8 |
685 | #ifndef WIN32 |
fc04eb16 |
686 | int rc_stack_size = 0; |
687 | int rc_thread_create = 0; |
d94006e8 |
688 | #endif |
adc09a0e |
689 | dMY_POOL; |
3b1c3273 |
690 | |
adc09a0e |
691 | /* Allocate thread structure in context of the main thread's interpreter */ |
5c6ff896 |
692 | { |
693 | PERL_SET_CONTEXT(MY_POOL.main_thread.interp); |
694 | thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); |
695 | } |
696 | PERL_SET_CONTEXT(aTHX); |
fc04eb16 |
697 | if (!thread) { |
5c6ff896 |
698 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
fc04eb16 |
699 | PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); |
700 | my_exit(1); |
701 | } |
702 | Zero(thread, 1, ithread); |
703 | |
704 | /* Add to threads list */ |
5c6ff896 |
705 | thread->next = &MY_POOL.main_thread; |
706 | thread->prev = MY_POOL.main_thread.prev; |
707 | MY_POOL.main_thread.prev = thread; |
fc04eb16 |
708 | thread->prev->next = thread; |
e9a908c9 |
709 | MY_POOL.total_threads++; |
c05ae023 |
710 | |
6ebc233e |
711 | /* 1 ref to be held by the local var 'thread' in S_ithread_run(). |
6158f8b3 |
712 | * 1 ref to be held by the threads object that we assume we will |
6ebc233e |
713 | * be embedded in upon our return. |
714 | * 1 ref to be the responsibility of join/detach, so we don't get |
715 | * freed until join/detach, even if no thread objects remain. |
716 | * This allows the following to work: |
878090d5 |
717 | * { threads->create(sub{...}); } threads->object(1)->join; |
fc04eb16 |
718 | */ |
6158f8b3 |
719 | thread->count = 3; |
fc04eb16 |
720 | |
9ca4d7fd |
721 | /* Block new thread until ->create() call finishes */ |
fc04eb16 |
722 | MUTEX_INIT(&thread->mutex); |
9ca4d7fd |
723 | MUTEX_LOCK(&thread->mutex); |
724 | |
5c6ff896 |
725 | thread->tid = MY_POOL.tid_counter++; |
861d5cbe |
726 | thread->stack_size = S_good_stack_size(aTHX_ stack_size); |
9d9ff5b1 |
727 | thread->gimme = gimme; |
69a9b4b8 |
728 | thread->state = exit_opt; |
fc04eb16 |
729 | |
730 | /* "Clone" our interpreter into the thread's interpreter. |
731 | * This gives thread access to "static data" and code. |
732 | */ |
733 | PerlIO_flush((PerlIO *)NULL); |
734 | S_ithread_set(aTHX_ thread); |
735 | |
736 | SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */ |
737 | PL_srand_called = FALSE; /* Set it to false so we can detect if it gets |
738 | set during the clone */ |
3b1c3273 |
739 | |
8264cf32 |
740 | #ifndef WIN32 |
b762d866 |
741 | /* perl_clone() will leave us the new interpreter's context. This poses |
742 | * two problems for our signal handler. First, it sets the new context |
743 | * before the new interpreter struct is fully initialized, so our signal |
744 | * handler might find bogus data in the interpreter struct it gets. |
745 | * Second, even if the interpreter is initialized before a signal comes in, |
746 | * we would like to avoid that interpreter receiving notifications for |
747 | * signals (especially when they ought to be for the one running in this |
748 | * thread), until it is running in its own thread. Another problem is that |
749 | * the new thread will not have set the context until some time after it |
750 | * has started, so it won't be safe for our signal handler to run until |
751 | * that time. |
752 | * |
753 | * So we block most signals here, so the new thread will inherit the signal |
754 | * mask, and unblock them right after the thread creation. The original |
755 | * mask is saved in the thread struct so that the new thread can restore |
756 | * the original mask. |
757 | */ |
758 | S_block_most_signals(&thread->initial_sigmask); |
8264cf32 |
759 | #endif |
b762d866 |
760 | |
47ba8780 |
761 | #ifdef WIN32 |
fc04eb16 |
762 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); |
47ba8780 |
763 | #else |
fc04eb16 |
764 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); |
47ba8780 |
765 | #endif |
47ba8780 |
766 | |
fc04eb16 |
767 | /* perl_clone() leaves us in new interpreter's context. As it is tricky |
768 | * to spot an implicit aTHX, create a new scope with aTHX matching the |
769 | * context for the duration of our work for new interpreter. |
770 | */ |
771 | { |
894eec8b |
772 | CLONE_PARAMS clone_param; |
773 | |
fc04eb16 |
774 | dTHXa(thread->interp); |
775 | |
776 | MY_CXT_CLONE; |
777 | |
778 | /* Here we remove END blocks since they should only run in the thread |
779 | * they are created |
780 | */ |
781 | SvREFCNT_dec(PL_endav); |
782 | PL_endav = newAV(); |
404aaa48 |
783 | |
894eec8b |
784 | clone_param.flags = 0; |
f2e0bb91 |
785 | if (SvPOK(init_function)) { |
786 | thread->init_function = newSV(0); |
787 | sv_copypv(thread->init_function, init_function); |
788 | } else { |
dd5ef8e0 |
789 | thread->init_function = |
790 | SvREFCNT_inc(sv_dup(init_function, &clone_param)); |
fc04eb16 |
791 | } |
792 | |
793 | thread->params = sv_dup(params, &clone_param); |
d4315dd6 |
794 | SvREFCNT_inc_void(thread->params); |
fc04eb16 |
795 | |
796 | /* The code below checks that anything living on the tmps stack and |
797 | * has been cloned (so it lives in the ptr_table) has a refcount |
798 | * higher than 0. |
799 | * |
800 | * If the refcount is 0 it means that a something on the stack/context |
801 | * was holding a reference to it and since we init_stacks() in |
802 | * perl_clone that won't get cleaned and we will get a leaked scalar. |
803 | * The reason it was cloned was that it lived on the @_ stack. |
804 | * |
805 | * Example of this can be found in bugreport 15837 where calls in the |
806 | * parameter list end up as a temp. |
807 | * |
808 | * One could argue that this fix should be in perl_clone. |
809 | */ |
810 | while (tmps_ix > 0) { |
811 | SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); |
812 | tmps_ix--; |
813 | if (sv && SvREFCNT(sv) == 0) { |
d4315dd6 |
814 | SvREFCNT_inc_void(sv); |
fc04eb16 |
815 | SvREFCNT_dec(sv); |
816 | } |
817 | } |
818 | |
819 | SvTEMP_off(thread->init_function); |
820 | ptr_table_free(PL_ptr_table); |
821 | PL_ptr_table = NULL; |
822 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
823 | } |
824 | S_ithread_set(aTHX_ current_thread); |
825 | PERL_SET_CONTEXT(aTHX); |
826 | |
827 | /* Create/start the thread */ |
47ba8780 |
828 | #ifdef WIN32 |
fc04eb16 |
829 | thread->handle = CreateThread(NULL, |
514612b7 |
830 | (DWORD)thread->stack_size, |
fc04eb16 |
831 | S_ithread_run, |
832 | (LPVOID)thread, |
514612b7 |
833 | STACK_SIZE_PARAM_IS_A_RESERVATION, |
fc04eb16 |
834 | &thread->thr); |
82c40bf6 |
835 | #else |
fc04eb16 |
836 | { |
861d5cbe |
837 | STATIC pthread_attr_t attr; |
838 | STATIC int attr_inited = 0; |
839 | STATIC int attr_joinable = PTHREAD_CREATE_JOINABLE; |
fc04eb16 |
840 | if (! attr_inited) { |
841 | pthread_attr_init(&attr); |
842 | attr_inited = 1; |
843 | } |
844 | |
fa26028c |
845 | # ifdef PTHREAD_ATTR_SETDETACHSTATE |
fc04eb16 |
846 | /* Threads start out joinable */ |
847 | PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); |
fa26028c |
848 | # endif |
fc04eb16 |
849 | |
514612b7 |
850 | # ifdef _POSIX_THREAD_ATTR_STACKSIZE |
fc04eb16 |
851 | /* Set thread's stack size */ |
514612b7 |
852 | if (thread->stack_size > 0) { |
853 | rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size); |
854 | } |
3eb37d38 |
855 | # endif |
856 | |
fc04eb16 |
857 | /* Create the thread */ |
858 | if (! rc_stack_size) { |
859 | # ifdef OLD_PTHREADS_API |
860 | rc_thread_create = pthread_create(&thread->thr, |
861 | attr, |
862 | S_ithread_run, |
863 | (void *)thread); |
864 | # else |
865 | # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) |
866 | pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); |
867 | # endif |
868 | rc_thread_create = pthread_create(&thread->thr, |
869 | &attr, |
870 | S_ithread_run, |
871 | (void *)thread); |
19a077f6 |
872 | # endif |
fc04eb16 |
873 | } |
514612b7 |
874 | |
8264cf32 |
875 | #ifndef WIN32 |
b762d866 |
876 | /* Now it's safe to accept signals, since we're in our own interpreter's |
877 | * context and we have created the thread. |
878 | */ |
879 | S_set_sigmask(&thread->initial_sigmask); |
8264cf32 |
880 | #endif |
b762d866 |
881 | |
514612b7 |
882 | # ifdef _POSIX_THREAD_ATTR_STACKSIZE |
883 | /* Try to get thread's actual stack size */ |
884 | { |
885 | size_t stacksize; |
58a3a76c |
886 | #ifdef HPUX1020 |
887 | stacksize = pthread_attr_getstacksize(attr); |
888 | #else |
889 | if (! pthread_attr_getstacksize(&attr, &stacksize)) |
890 | #endif |
891 | if (stacksize > 0) { |
514612b7 |
892 | thread->stack_size = (IV)stacksize; |
893 | } |
514612b7 |
894 | } |
895 | # endif |
fc04eb16 |
896 | } |
82c40bf6 |
897 | #endif |
bcd9ca9b |
898 | |
fc04eb16 |
899 | /* Check for errors */ |
d94006e8 |
900 | #ifdef WIN32 |
fc04eb16 |
901 | if (thread->handle == NULL) { |
d94006e8 |
902 | #else |
fc04eb16 |
903 | if (rc_stack_size || rc_thread_create) { |
d94006e8 |
904 | #endif |
9ca4d7fd |
905 | /* Must unlock mutex for destruct call */ |
5c6ff896 |
906 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
fc04eb16 |
907 | sv_2mortal(params); |
adc09a0e |
908 | thread->state |= PERL_ITHR_NONVIABLE; |
6ebc233e |
909 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
d94006e8 |
910 | #ifndef WIN32 |
514612b7 |
911 | if (ckWARN_d(WARN_THREADS)) { |
fea7688c |
912 | if (rc_stack_size) { |
514612b7 |
913 | Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size); |
fea7688c |
914 | } else { |
514612b7 |
915 | Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); |
fea7688c |
916 | } |
514612b7 |
917 | } |
d94006e8 |
918 | #endif |
9ca4d7fd |
919 | return (NULL); |
fc04eb16 |
920 | } |
921 | |
5c6ff896 |
922 | MY_POOL.running_threads++; |
fc04eb16 |
923 | sv_2mortal(params); |
9ca4d7fd |
924 | return (thread); |
68795e93 |
925 | } |
47ba8780 |
926 | |
73e09c8f |
927 | #endif /* USE_ITHREADS */ |
e1c44605 |
928 | |
fcea4b7c |
929 | |
fc04eb16 |
930 | MODULE = threads PACKAGE = threads PREFIX = ithread_ |
68795e93 |
931 | PROTOTYPES: DISABLE |
8222d950 |
932 | |
73e09c8f |
933 | #ifdef USE_ITHREADS |
934 | |
68795e93 |
935 | void |
f4cc38af |
936 | ithread_create(...) |
937 | PREINIT: |
938 | char *classname; |
514612b7 |
939 | ithread *thread; |
f4cc38af |
940 | SV *function_to_call; |
941 | AV *params; |
514612b7 |
942 | HV *specs; |
943 | IV stack_size; |
9d9ff5b1 |
944 | int context; |
69a9b4b8 |
945 | int exit_opt; |
946 | SV *thread_exit_only; |
9d9ff5b1 |
947 | char *str; |
514612b7 |
948 | int idx; |
f4cc38af |
949 | int ii; |
5c6ff896 |
950 | dMY_POOL; |
f4cc38af |
951 | CODE: |
514612b7 |
952 | if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) { |
fea7688c |
953 | if (--items < 2) { |
18b9e6f5 |
954 | Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)"); |
fea7688c |
955 | } |
514612b7 |
956 | specs = (HV*)SvRV(ST(1)); |
957 | idx = 1; |
958 | } else { |
fea7688c |
959 | if (items < 2) { |
514612b7 |
960 | Perl_croak(aTHX_ "Usage: threads->create(function, ...)"); |
fea7688c |
961 | } |
514612b7 |
962 | specs = NULL; |
963 | idx = 0; |
964 | } |
f4cc38af |
965 | |
514612b7 |
966 | if (sv_isobject(ST(0))) { |
967 | /* $thr->create() */ |
968 | classname = HvNAME(SvSTASH(SvRV(ST(0)))); |
969 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
8718f9a1 |
970 | MUTEX_LOCK(&thread->mutex); |
514612b7 |
971 | stack_size = thread->stack_size; |
69a9b4b8 |
972 | exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY; |
8718f9a1 |
973 | MUTEX_UNLOCK(&thread->mutex); |
514612b7 |
974 | } else { |
975 | /* threads->create() */ |
976 | classname = (char *)SvPV_nolen(ST(0)); |
5c6ff896 |
977 | stack_size = MY_POOL.default_stack_size; |
8583b257 |
978 | thread_exit_only = get_sv("threads::thread_exit_only", GV_ADD); |
69a9b4b8 |
979 | exit_opt = (SvTRUE(thread_exit_only)) |
980 | ? PERL_ITHR_THREAD_EXIT_ONLY : 0; |
514612b7 |
981 | } |
982 | |
983 | function_to_call = ST(idx+1); |
984 | |
9d9ff5b1 |
985 | context = -1; |
514612b7 |
986 | if (specs) { |
987 | /* stack_size */ |
988 | if (hv_exists(specs, "stack", 5)) { |
989 | stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0)); |
990 | } else if (hv_exists(specs, "stacksize", 9)) { |
991 | stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0)); |
992 | } else if (hv_exists(specs, "stack_size", 10)) { |
993 | stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0)); |
994 | } |
9d9ff5b1 |
995 | |
996 | /* context */ |
997 | if (hv_exists(specs, "context", 7)) { |
998 | str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0)); |
999 | switch (*str) { |
1000 | case 'a': |
1001 | case 'A': |
da140a40 |
1002 | case 'l': |
1003 | case 'L': |
9d9ff5b1 |
1004 | context = G_ARRAY; |
1005 | break; |
1006 | case 's': |
1007 | case 'S': |
1008 | context = G_SCALAR; |
1009 | break; |
1010 | case 'v': |
1011 | case 'V': |
1012 | context = G_VOID; |
1013 | break; |
1014 | default: |
1015 | Perl_croak(aTHX_ "Invalid context: %s", str); |
1016 | } |
1017 | } else if (hv_exists(specs, "array", 5)) { |
1018 | if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) { |
1019 | context = G_ARRAY; |
1020 | } |
da140a40 |
1021 | } else if (hv_exists(specs, "list", 4)) { |
1022 | if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) { |
1023 | context = G_ARRAY; |
1024 | } |
9d9ff5b1 |
1025 | } else if (hv_exists(specs, "scalar", 6)) { |
1026 | if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) { |
1027 | context = G_SCALAR; |
1028 | } |
1029 | } else if (hv_exists(specs, "void", 4)) { |
1030 | if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) { |
1031 | context = G_VOID; |
1032 | } |
1033 | } |
69a9b4b8 |
1034 | |
1035 | /* exit => thread_only */ |
1036 | if (hv_exists(specs, "exit", 4)) { |
1037 | str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0)); |
1038 | exit_opt = (*str == 't' || *str == 'T') |
1039 | ? PERL_ITHR_THREAD_EXIT_ONLY : 0; |
1040 | } |
9d9ff5b1 |
1041 | } |
1042 | if (context == -1) { |
1043 | context = GIMME_V; /* Implicit context */ |
1044 | } else { |
1045 | context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID))); |
514612b7 |
1046 | } |
f4cc38af |
1047 | |
1048 | /* Function args */ |
1049 | params = newAV(); |
1050 | if (items > 2) { |
514612b7 |
1051 | for (ii=2; ii < items ; ii++) { |
1052 | av_push(params, SvREFCNT_inc(ST(idx+ii))); |
f4cc38af |
1053 | } |
1054 | } |
1055 | |
1056 | /* Create thread */ |
5c6ff896 |
1057 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd |
1058 | thread = S_ithread_create(aTHX_ function_to_call, |
1059 | stack_size, |
1060 | context, |
1061 | exit_opt, |
1062 | newRV_noinc((SV*)params)); |
1063 | if (! thread) { |
1064 | XSRETURN_UNDEF; /* Mutex already unlocked */ |
1065 | } |
861d5cbe |
1066 | ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE)); |
adc09a0e |
1067 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd |
1068 | |
1069 | /* Let thread run */ |
1070 | MUTEX_UNLOCK(&thread->mutex); |
9ca4d7fd |
1071 | |
f4cc38af |
1072 | /* XSRETURN(1); - implied */ |
1073 | |
8222d950 |
1074 | |
68795e93 |
1075 | void |
f4cc38af |
1076 | ithread_list(...) |
1077 | PREINIT: |
1078 | char *classname; |
fc04eb16 |
1079 | ithread *thread; |
f4cc38af |
1080 | int list_context; |
1081 | IV count = 0; |
11db694d |
1082 | int want_running = 0; |
8718f9a1 |
1083 | int state; |
5c6ff896 |
1084 | dMY_POOL; |
f4cc38af |
1085 | PPCODE: |
1086 | /* Class method only */ |
fea7688c |
1087 | if (SvROK(ST(0))) { |
ead32952 |
1088 | Perl_croak(aTHX_ "Usage: threads->list(...)"); |
fea7688c |
1089 | } |
f4cc38af |
1090 | classname = (char *)SvPV_nolen(ST(0)); |
1091 | |
1092 | /* Calling context */ |
1093 | list_context = (GIMME_V == G_ARRAY); |
1094 | |
ead32952 |
1095 | /* Running or joinable parameter */ |
1096 | if (items > 1) { |
1097 | want_running = SvTRUE(ST(1)); |
1098 | } |
1099 | |
f4cc38af |
1100 | /* Walk through threads list */ |
5c6ff896 |
1101 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1102 | for (thread = MY_POOL.main_thread.next; |
1103 | thread != &MY_POOL.main_thread; |
fc04eb16 |
1104 | thread = thread->next) |
f4cc38af |
1105 | { |
8718f9a1 |
1106 | MUTEX_LOCK(&thread->mutex); |
1107 | state = thread->state; |
1108 | MUTEX_UNLOCK(&thread->mutex); |
1109 | |
f4cc38af |
1110 | /* Ignore detached or joined threads */ |
8718f9a1 |
1111 | if (state & PERL_ITHR_UNCALLABLE) { |
f4cc38af |
1112 | continue; |
1113 | } |
ead32952 |
1114 | |
1115 | /* Filter per parameter */ |
1116 | if (items > 1) { |
1117 | if (want_running) { |
8718f9a1 |
1118 | if (state & PERL_ITHR_FINISHED) { |
ead32952 |
1119 | continue; /* Not running */ |
1120 | } |
1121 | } else { |
8718f9a1 |
1122 | if (! (state & PERL_ITHR_FINISHED)) { |
ead32952 |
1123 | continue; /* Still running - not joinable yet */ |
1124 | } |
1125 | } |
1126 | } |
1127 | |
f4cc38af |
1128 | /* Push object on stack if list context */ |
1129 | if (list_context) { |
861d5cbe |
1130 | XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); |
f4cc38af |
1131 | } |
1132 | count++; |
1133 | } |
5c6ff896 |
1134 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
f4cc38af |
1135 | /* If scalar context, send back count */ |
1136 | if (! list_context) { |
1137 | XSRETURN_IV(count); |
1138 | } |
678a9b6c |
1139 | |
1140 | |
1141 | void |
f4cc38af |
1142 | ithread_self(...) |
1143 | PREINIT: |
1144 | char *classname; |
fcea4b7c |
1145 | ithread *thread; |
f4cc38af |
1146 | CODE: |
1147 | /* Class method only */ |
11db694d |
1148 | if ((items != 1) || SvROK(ST(0))) { |
f4cc38af |
1149 | Perl_croak(aTHX_ "Usage: threads->self()"); |
fea7688c |
1150 | } |
f4cc38af |
1151 | classname = (char *)SvPV_nolen(ST(0)); |
1152 | |
fcea4b7c |
1153 | thread = S_ithread_get(aTHX); |
1154 | |
861d5cbe |
1155 | ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
f4cc38af |
1156 | /* XSRETURN(1); - implied */ |
47ba8780 |
1157 | |
47ba8780 |
1158 | |
1159 | void |
f4cc38af |
1160 | ithread_tid(...) |
1161 | PREINIT: |
1162 | ithread *thread; |
1163 | CODE: |
11db694d |
1164 | PERL_UNUSED_VAR(items); |
861d5cbe |
1165 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
f4cc38af |
1166 | XST_mUV(0, thread->tid); |
1167 | /* XSRETURN(1); - implied */ |
1168 | |
e1c44605 |
1169 | |
f9dff5f5 |
1170 | void |
f4cc38af |
1171 | ithread_join(...) |
1172 | PREINIT: |
fcea4b7c |
1173 | ithread *thread; |
8718f9a1 |
1174 | ithread *current_thread; |
fcea4b7c |
1175 | int join_err; |
6ebc233e |
1176 | AV *params = NULL; |
f4cc38af |
1177 | int len; |
1178 | int ii; |
12701bb8 |
1179 | #ifndef WIN32 |
8718f9a1 |
1180 | int rc_join; |
fcea4b7c |
1181 | void *retval; |
1182 | #endif |
5c6ff896 |
1183 | dMY_POOL; |
f4cc38af |
1184 | PPCODE: |
1185 | /* Object method only */ |
11db694d |
1186 | if ((items != 1) || ! sv_isobject(ST(0))) { |
f4cc38af |
1187 | Perl_croak(aTHX_ "Usage: $thr->join()"); |
fea7688c |
1188 | } |
f4cc38af |
1189 | |
8718f9a1 |
1190 | /* Check if the thread is joinable and not ourselves */ |
861d5cbe |
1191 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
8718f9a1 |
1192 | current_thread = S_ithread_get(aTHX); |
1193 | |
1194 | MUTEX_LOCK(&thread->mutex); |
1195 | if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) { |
1196 | MUTEX_UNLOCK(&thread->mutex); |
1197 | Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED) |
1198 | ? "Cannot join a detached thread" |
1199 | : "Thread already joined"); |
1200 | } else if (thread->tid == current_thread->tid) { |
1201 | MUTEX_UNLOCK(&thread->mutex); |
1202 | Perl_croak(aTHX_ "Cannot join self"); |
fcea4b7c |
1203 | } |
1204 | |
8718f9a1 |
1205 | /* Mark as joined */ |
1206 | thread->state |= PERL_ITHR_JOINED; |
1207 | MUTEX_UNLOCK(&thread->mutex); |
1208 | |
1209 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1210 | MY_POOL.joinable_threads--; |
1211 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
1212 | |
fcea4b7c |
1213 | /* Join the thread */ |
1214 | #ifdef WIN32 |
8718f9a1 |
1215 | if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) { |
1216 | /* Timeout/abandonment unexpected here; check $^E */ |
1217 | Perl_croak(aTHX_ "PANIC: underlying join failed"); |
1218 | }; |
fcea4b7c |
1219 | #else |
8718f9a1 |
1220 | if ((rc_join = pthread_join(thread->thr, &retval)) != 0) { |
1221 | /* In progress/deadlock/unknown unexpected here; check $! */ |
1222 | errno = rc_join; |
1223 | Perl_croak(aTHX_ "PANIC: underlying join failed"); |
1224 | }; |
fcea4b7c |
1225 | #endif |
1226 | |
1227 | MUTEX_LOCK(&thread->mutex); |
fcea4b7c |
1228 | /* Get the return value from the call_sv */ |
955c272e |
1229 | /* Objects do not survive this process - FIXME */ |
7df0357e |
1230 | if ((thread->gimme & G_WANT) != G_VOID) { |
fcea4b7c |
1231 | AV *params_copy; |
1232 | PerlInterpreter *other_perl; |
1233 | CLONE_PARAMS clone_params; |
fcea4b7c |
1234 | |
1235 | params_copy = (AV *)SvRV(thread->params); |
1236 | other_perl = thread->interp; |
1237 | clone_params.stashes = newAV(); |
1238 | clone_params.flags = CLONEf_JOIN_IN; |
1239 | PL_ptr_table = ptr_table_new(); |
fcea4b7c |
1240 | S_ithread_set(aTHX_ thread); |
1241 | /* Ensure 'meaningful' addresses retain their meaning */ |
1242 | ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); |
1243 | ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); |
1244 | ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); |
1245 | params = (AV *)sv_dup((SV*)params_copy, &clone_params); |
1246 | S_ithread_set(aTHX_ current_thread); |
1247 | SvREFCNT_dec(clone_params.stashes); |
d4315dd6 |
1248 | SvREFCNT_inc_void(params); |
fcea4b7c |
1249 | ptr_table_free(PL_ptr_table); |
1250 | PL_ptr_table = NULL; |
1251 | } |
1252 | |
955c272e |
1253 | /* If thread didn't die, then we can free its interpreter */ |
1254 | if (! (thread->state & PERL_ITHR_DIED)) { |
1255 | S_ithread_clear(aTHX_ thread); |
1256 | } |
6ebc233e |
1257 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
955c272e |
1258 | |
fcea4b7c |
1259 | /* If no return values, then just return */ |
f4cc38af |
1260 | if (! params) { |
1261 | XSRETURN_UNDEF; |
1262 | } |
1263 | |
1264 | /* Put return values on stack */ |
1265 | len = (int)AvFILL(params); |
1266 | for (ii=0; ii <= len; ii++) { |
1267 | SV* param = av_shift(params); |
1268 | XPUSHs(sv_2mortal(param)); |
1269 | } |
1270 | |
1271 | /* Free return value array */ |
1272 | SvREFCNT_dec(params); |
1273 | |
1274 | |
1275 | void |
1276 | ithread_yield(...) |
1277 | CODE: |
11db694d |
1278 | PERL_UNUSED_VAR(items); |
f4cc38af |
1279 | YIELD; |
1280 | |
1281 | |
1282 | void |
1283 | ithread_detach(...) |
1284 | PREINIT: |
1285 | ithread *thread; |
fcea4b7c |
1286 | int detach_err; |
5c6ff896 |
1287 | dMY_POOL; |
f4cc38af |
1288 | CODE: |
11db694d |
1289 | PERL_UNUSED_VAR(items); |
1290 | |
fcea4b7c |
1291 | /* Detach the thread */ |
8718f9a1 |
1292 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
5c6ff896 |
1293 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd |
1294 | MUTEX_LOCK(&thread->mutex); |
8718f9a1 |
1295 | if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) { |
1296 | /* Thread is detachable */ |
1297 | thread->state |= PERL_ITHR_DETACHED; |
fcea4b7c |
1298 | #ifdef WIN32 |
8718f9a1 |
1299 | /* Windows has no 'detach thread' function */ |
fcea4b7c |
1300 | #else |
8718f9a1 |
1301 | PERL_THREAD_DETACH(thread->thr); |
fcea4b7c |
1302 | #endif |
8718f9a1 |
1303 | if (thread->state & PERL_ITHR_FINISHED) { |
1304 | MY_POOL.joinable_threads--; |
1305 | } else { |
1306 | MY_POOL.running_threads--; |
1307 | MY_POOL.detached_threads++; |
1308 | } |
4dcb9e53 |
1309 | } |
adc09a0e |
1310 | MUTEX_UNLOCK(&thread->mutex); |
5c6ff896 |
1311 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
4dcb9e53 |
1312 | |
8718f9a1 |
1313 | if (detach_err) { |
1314 | Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED) |
1315 | ? "Thread already detached" |
1316 | : "Cannot detach a joined thread"); |
1317 | } |
1318 | |
955c272e |
1319 | /* If thread is finished and didn't die, |
1320 | * then we can free its interpreter */ |
1321 | MUTEX_LOCK(&thread->mutex); |
1322 | if ((thread->state & PERL_ITHR_FINISHED) && |
1323 | ! (thread->state & PERL_ITHR_DIED)) |
1324 | { |
1325 | S_ithread_clear(aTHX_ thread); |
1326 | } |
6ebc233e |
1327 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
f4cc38af |
1328 | |
47ba8780 |
1329 | |
1330 | void |
c0003851 |
1331 | ithread_kill(...) |
1332 | PREINIT: |
1333 | ithread *thread; |
1334 | char *sig_name; |
1335 | IV signal; |
1336 | CODE: |
1337 | /* Must have safe signals */ |
fea7688c |
1338 | if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { |
4dcb9e53 |
1339 | Perl_croak(aTHX_ "Cannot signal threads without safe signals"); |
fea7688c |
1340 | } |
c0003851 |
1341 | |
1342 | /* Object method only */ |
11db694d |
1343 | if ((items != 2) || ! sv_isobject(ST(0))) { |
c0003851 |
1344 | Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')"); |
fea7688c |
1345 | } |
c0003851 |
1346 | |
c0003851 |
1347 | /* Get signal */ |
1348 | sig_name = SvPV_nolen(ST(1)); |
1349 | if (isALPHA(*sig_name)) { |
fea7688c |
1350 | if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') { |
c0003851 |
1351 | sig_name += 3; |
fea7688c |
1352 | } |
1353 | if ((signal = whichsig(sig_name)) < 0) { |
c0003851 |
1354 | Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name); |
fea7688c |
1355 | } |
1356 | } else { |
c0003851 |
1357 | signal = SvIV(ST(1)); |
fea7688c |
1358 | } |
c0003851 |
1359 | |
1360 | /* Set the signal for the thread */ |
861d5cbe |
1361 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
4dcb9e53 |
1362 | MUTEX_LOCK(&thread->mutex); |
3ceb02cd |
1363 | if (thread->interp) { |
c0003851 |
1364 | dTHXa(thread->interp); |
1365 | PL_psig_pend[signal]++; |
1366 | PL_sig_pending = 1; |
1367 | } |
4dcb9e53 |
1368 | MUTEX_UNLOCK(&thread->mutex); |
c0003851 |
1369 | |
1370 | /* Return the thread to allow for method chaining */ |
1371 | ST(0) = ST(0); |
1372 | /* XSRETURN(1); - implied */ |
1373 | |
1374 | |
1375 | void |
f4cc38af |
1376 | ithread_DESTROY(...) |
1377 | CODE: |
11db694d |
1378 | PERL_UNUSED_VAR(items); |
fcea4b7c |
1379 | sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar); |
f4cc38af |
1380 | |
1381 | |
1382 | void |
1383 | ithread_equal(...) |
fc04eb16 |
1384 | PREINIT: |
1385 | int are_equal = 0; |
f4cc38af |
1386 | CODE: |
11db694d |
1387 | PERL_UNUSED_VAR(items); |
1388 | |
fc04eb16 |
1389 | /* Compares TIDs to determine thread equality */ |
f4cc38af |
1390 | if (sv_isobject(ST(0)) && sv_isobject(ST(1))) { |
1391 | ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1392 | ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1)))); |
fc04eb16 |
1393 | are_equal = (thr1->tid == thr2->tid); |
1394 | } |
1395 | if (are_equal) { |
1396 | XST_mYES(0); |
f4cc38af |
1397 | } else { |
fc04eb16 |
1398 | /* Return 0 on false for backward compatibility */ |
f4cc38af |
1399 | XST_mIV(0, 0); |
1400 | } |
1401 | /* XSRETURN(1); - implied */ |
1402 | |
47ba8780 |
1403 | |
47ba8780 |
1404 | void |
f4cc38af |
1405 | ithread_object(...) |
1406 | PREINIT: |
1407 | char *classname; |
1408 | UV tid; |
fc04eb16 |
1409 | ithread *thread; |
8718f9a1 |
1410 | int state; |
9ca4d7fd |
1411 | int have_obj = 0; |
5c6ff896 |
1412 | dMY_POOL; |
f4cc38af |
1413 | CODE: |
1414 | /* Class method only */ |
fea7688c |
1415 | if (SvROK(ST(0))) { |
f4cc38af |
1416 | Perl_croak(aTHX_ "Usage: threads->object($tid)"); |
fea7688c |
1417 | } |
f4cc38af |
1418 | classname = (char *)SvPV_nolen(ST(0)); |
1419 | |
1420 | if ((items < 2) || ! SvOK(ST(1))) { |
1421 | XSRETURN_UNDEF; |
1422 | } |
1423 | |
fc04eb16 |
1424 | /* threads->object($tid) */ |
f4cc38af |
1425 | tid = SvUV(ST(1)); |
1426 | |
1427 | /* Walk through threads list */ |
5c6ff896 |
1428 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1429 | for (thread = MY_POOL.main_thread.next; |
1430 | thread != &MY_POOL.main_thread; |
fc04eb16 |
1431 | thread = thread->next) |
f4cc38af |
1432 | { |
9ca4d7fd |
1433 | /* Look for TID */ |
1434 | if (thread->tid == tid) { |
1435 | /* Ignore if detached or joined */ |
8718f9a1 |
1436 | MUTEX_LOCK(&thread->mutex); |
1437 | state = thread->state; |
1438 | MUTEX_UNLOCK(&thread->mutex); |
1439 | if (! (state & PERL_ITHR_UNCALLABLE)) { |
9ca4d7fd |
1440 | /* Put object on stack */ |
861d5cbe |
1441 | ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
9ca4d7fd |
1442 | have_obj = 1; |
1443 | } |
1444 | break; |
f4cc38af |
1445 | } |
f4cc38af |
1446 | } |
5c6ff896 |
1447 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd |
1448 | |
1449 | if (! have_obj) { |
f4cc38af |
1450 | XSRETURN_UNDEF; |
1451 | } |
1452 | /* XSRETURN(1); - implied */ |
1453 | |
1454 | |
1455 | void |
1456 | ithread__handle(...); |
1457 | PREINIT: |
1458 | ithread *thread; |
1459 | CODE: |
11db694d |
1460 | PERL_UNUSED_VAR(items); |
861d5cbe |
1461 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
f4cc38af |
1462 | #ifdef WIN32 |
fcea4b7c |
1463 | XST_mUV(0, PTR2UV(&thread->handle)); |
f4cc38af |
1464 | #else |
75ba4ae2 |
1465 | XST_mUV(0, PTR2UV(&thread->thr)); |
f4cc38af |
1466 | #endif |
1467 | /* XSRETURN(1); - implied */ |
68795e93 |
1468 | |
514612b7 |
1469 | |
1470 | void |
1471 | ithread_get_stack_size(...) |
1472 | PREINIT: |
1473 | IV stack_size; |
5c6ff896 |
1474 | dMY_POOL; |
514612b7 |
1475 | CODE: |
11db694d |
1476 | PERL_UNUSED_VAR(items); |
514612b7 |
1477 | if (sv_isobject(ST(0))) { |
1478 | /* $thr->get_stack_size() */ |
1479 | ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1480 | stack_size = thread->stack_size; |
1481 | } else { |
1482 | /* threads->get_stack_size() */ |
5c6ff896 |
1483 | stack_size = MY_POOL.default_stack_size; |
514612b7 |
1484 | } |
1485 | XST_mIV(0, stack_size); |
1486 | /* XSRETURN(1); - implied */ |
1487 | |
1488 | |
1489 | void |
1490 | ithread_set_stack_size(...) |
1491 | PREINIT: |
1492 | IV old_size; |
5c6ff896 |
1493 | dMY_POOL; |
514612b7 |
1494 | CODE: |
fea7688c |
1495 | if (items != 2) { |
514612b7 |
1496 | Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)"); |
fea7688c |
1497 | } |
1498 | if (sv_isobject(ST(0))) { |
514612b7 |
1499 | Perl_croak(aTHX_ "Cannot change stack size of an existing thread"); |
fea7688c |
1500 | } |
6ebc233e |
1501 | if (! looks_like_number(ST(1))) { |
1502 | Perl_croak(aTHX_ "Stack size must be numeric"); |
1503 | } |
514612b7 |
1504 | |
5c6ff896 |
1505 | old_size = MY_POOL.default_stack_size; |
1506 | MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1))); |
514612b7 |
1507 | XST_mIV(0, old_size); |
1508 | /* XSRETURN(1); - implied */ |
1509 | |
ead32952 |
1510 | |
1511 | void |
1512 | ithread_is_running(...) |
1513 | PREINIT: |
1514 | ithread *thread; |
1515 | CODE: |
1516 | /* Object method only */ |
11db694d |
1517 | if ((items != 1) || ! sv_isobject(ST(0))) { |
ead32952 |
1518 | Perl_croak(aTHX_ "Usage: $thr->is_running()"); |
fea7688c |
1519 | } |
ead32952 |
1520 | |
1521 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
8718f9a1 |
1522 | MUTEX_LOCK(&thread->mutex); |
ead32952 |
1523 | ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes; |
8718f9a1 |
1524 | MUTEX_UNLOCK(&thread->mutex); |
ead32952 |
1525 | /* XSRETURN(1); - implied */ |
1526 | |
1527 | |
1528 | void |
1529 | ithread_is_detached(...) |
1530 | PREINIT: |
1531 | ithread *thread; |
1532 | CODE: |
11db694d |
1533 | PERL_UNUSED_VAR(items); |
861d5cbe |
1534 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
8718f9a1 |
1535 | MUTEX_LOCK(&thread->mutex); |
ead32952 |
1536 | ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no; |
8718f9a1 |
1537 | MUTEX_UNLOCK(&thread->mutex); |
ead32952 |
1538 | /* XSRETURN(1); - implied */ |
1539 | |
1540 | |
1541 | void |
1542 | ithread_is_joinable(...) |
1543 | PREINIT: |
1544 | ithread *thread; |
1545 | CODE: |
1546 | /* Object method only */ |
11db694d |
1547 | if ((items != 1) || ! sv_isobject(ST(0))) { |
ead32952 |
1548 | Perl_croak(aTHX_ "Usage: $thr->is_joinable()"); |
fea7688c |
1549 | } |
ead32952 |
1550 | |
1551 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1552 | MUTEX_LOCK(&thread->mutex); |
1553 | ST(0) = ((thread->state & PERL_ITHR_FINISHED) && |
8718f9a1 |
1554 | ! (thread->state & PERL_ITHR_UNCALLABLE)) |
ead32952 |
1555 | ? &PL_sv_yes : &PL_sv_no; |
1556 | MUTEX_UNLOCK(&thread->mutex); |
1557 | /* XSRETURN(1); - implied */ |
1558 | |
1559 | |
1560 | void |
1561 | ithread_wantarray(...) |
1562 | PREINIT: |
1563 | ithread *thread; |
1564 | CODE: |
11db694d |
1565 | PERL_UNUSED_VAR(items); |
861d5cbe |
1566 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
7df0357e |
1567 | ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes : |
1568 | ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef |
7ef93cb2 |
1569 | /* G_SCALAR */ : &PL_sv_no; |
ead32952 |
1570 | /* XSRETURN(1); - implied */ |
1571 | |
69a9b4b8 |
1572 | |
1573 | void |
1574 | ithread_set_thread_exit_only(...) |
1575 | PREINIT: |
1576 | ithread *thread; |
1577 | CODE: |
fea7688c |
1578 | if (items != 2) { |
69a9b4b8 |
1579 | Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)"); |
fea7688c |
1580 | } |
861d5cbe |
1581 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
69a9b4b8 |
1582 | MUTEX_LOCK(&thread->mutex); |
1583 | if (SvTRUE(ST(1))) { |
1584 | thread->state |= PERL_ITHR_THREAD_EXIT_ONLY; |
1585 | } else { |
1586 | thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY; |
1587 | } |
1588 | MUTEX_UNLOCK(&thread->mutex); |
1589 | |
955c272e |
1590 | |
1591 | void |
1592 | ithread_error(...) |
1593 | PREINIT: |
1594 | ithread *thread; |
1595 | SV *err = NULL; |
1596 | CODE: |
1597 | /* Object method only */ |
1598 | if ((items != 1) || ! sv_isobject(ST(0))) { |
1599 | Perl_croak(aTHX_ "Usage: $thr->err()"); |
1600 | } |
1601 | |
1602 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); |
1603 | MUTEX_LOCK(&thread->mutex); |
1604 | |
1605 | /* If thread died, then clone the error into the calling thread */ |
1606 | if (thread->state & PERL_ITHR_DIED) { |
1607 | PerlInterpreter *other_perl; |
1608 | CLONE_PARAMS clone_params; |
1609 | ithread *current_thread; |
1610 | |
1611 | other_perl = thread->interp; |
1612 | clone_params.stashes = newAV(); |
1613 | clone_params.flags = CLONEf_JOIN_IN; |
1614 | PL_ptr_table = ptr_table_new(); |
1615 | current_thread = S_ithread_get(aTHX); |
1616 | S_ithread_set(aTHX_ thread); |
1617 | /* Ensure 'meaningful' addresses retain their meaning */ |
1618 | ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); |
1619 | ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); |
1620 | ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); |
1621 | err = sv_dup(thread->err, &clone_params); |
1622 | S_ithread_set(aTHX_ current_thread); |
1623 | SvREFCNT_dec(clone_params.stashes); |
1624 | SvREFCNT_inc_void(err); |
1625 | /* If error was an object, bless it into the correct class */ |
1626 | if (thread->err_class) { |
1627 | sv_bless(err, gv_stashpv(thread->err_class, 1)); |
1628 | } |
1629 | ptr_table_free(PL_ptr_table); |
1630 | PL_ptr_table = NULL; |
1631 | } |
1632 | |
1633 | MUTEX_UNLOCK(&thread->mutex); |
1634 | |
1635 | if (! err) { |
1636 | XSRETURN_UNDEF; |
1637 | } |
1638 | |
1639 | ST(0) = sv_2mortal(err); |
1640 | /* XSRETURN(1); - implied */ |
1641 | |
1642 | |
73e09c8f |
1643 | #endif /* USE_ITHREADS */ |
1644 | |
fc04eb16 |
1645 | |
68795e93 |
1646 | BOOT: |
1647 | { |
73e09c8f |
1648 | #ifdef USE_ITHREADS |
5c6ff896 |
1649 | SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, |
1650 | sizeof(MY_POOL_KEY)-1, TRUE); |
1651 | my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1)); |
1652 | |
fc04eb16 |
1653 | MY_CXT_INIT; |
1654 | |
5c6ff896 |
1655 | Zero(my_poolp, 1, my_pool_t); |
1656 | sv_setuv(my_pool_sv, PTR2UV(my_poolp)); |
1657 | |
fc04eb16 |
1658 | PL_perl_destruct_level = 2; |
5c6ff896 |
1659 | MUTEX_INIT(&MY_POOL.create_destruct_mutex); |
1660 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
fc04eb16 |
1661 | |
1662 | PL_threadhook = &Perl_ithread_hook; |
1663 | |
5c6ff896 |
1664 | MY_POOL.tid_counter = 1; |
1665 | # ifdef THREAD_CREATE_NEEDS_STACK |
1666 | MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK; |
1667 | # endif |
1668 | |
c372d929 |
1669 | /* The 'main' thread is thread 0. |
1670 | * It is detached (unjoinable) and immortal. |
1671 | */ |
fc04eb16 |
1672 | |
5c6ff896 |
1673 | MUTEX_INIT(&MY_POOL.main_thread.mutex); |
fc04eb16 |
1674 | |
1675 | /* Head of the threads list */ |
5c6ff896 |
1676 | MY_POOL.main_thread.next = &MY_POOL.main_thread; |
1677 | MY_POOL.main_thread.prev = &MY_POOL.main_thread; |
fc04eb16 |
1678 | |
5c6ff896 |
1679 | MY_POOL.main_thread.count = 1; /* Immortal */ |
fc04eb16 |
1680 | |
5c6ff896 |
1681 | MY_POOL.main_thread.interp = aTHX; |
1682 | MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */ |
1683 | MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size; |
fc04eb16 |
1684 | # ifdef WIN32 |
5c6ff896 |
1685 | MY_POOL.main_thread.thr = GetCurrentThreadId(); |
fc04eb16 |
1686 | # else |
5c6ff896 |
1687 | MY_POOL.main_thread.thr = pthread_self(); |
fc04eb16 |
1688 | # endif |
1689 | |
5c6ff896 |
1690 | S_ithread_set(aTHX_ &MY_POOL.main_thread); |
1691 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
73e09c8f |
1692 | #endif /* USE_ITHREADS */ |
68795e93 |
1693 | } |