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