Commit | Line | Data |
---|---|---|
68795e93 | 1 | #define PERL_NO_GET_CONTEXT |
fa58a56f S |
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 NIS |
8 | #include "EXTERN.h" |
9 | #include "perl.h" | |
10 | #include "XSUB.h" | |
4dcb9e53 JH |
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 JH |
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 JH |
22 | # include "ppport.h" |
23 | # include "threads.h" | |
24 | #endif | |
68795e93 | 25 | |
73e09c8f JH |
26 | #ifdef USE_ITHREADS |
27 | ||
68795e93 | 28 | #ifdef WIN32 |
fc04eb16 | 29 | # include <windows.h> |
514612b7 JH |
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 JH |
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 JH |
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 RGS |
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 RGS |
58 | #define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */ |
59 | #define PERL_ITHR_DIED 32 /* Thread finished by dying */ | |
6158f8b3 DM |
60 | |
61 | #define PERL_ITHR_UNCALLABLE (PERL_ITHR_DETACHED|PERL_ITHR_JOINED) | |
62 | ||
fc04eb16 JH |
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 JH |
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 JH |
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 JH |
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 NIS |
87 | } ithread; |
88 | ||
fc04eb16 | 89 | |
5c6ff896 | 90 | #define MY_CXT_KEY "threads::_cxt" XS_VERSION |
628ab322 DM |
91 | |
92 | typedef struct { | |
861d5cbe JH |
93 | /* Used by Perl interpreter for thread context switching */ |
94 | ithread *context; | |
628ab322 DM |
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 JH |
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 JH |
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 JW |
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 CB |
147 | /* no per-thread blocking available */ |
148 | return sigprocmask(SIG_BLOCK, &newmask, oldmask); | |
b762d866 JW |
149 | #else |
150 | return pthread_sigmask(SIG_BLOCK, &newmask, oldmask); | |
bcbea5d2 | 151 | #endif /* VMS */ |
b762d866 JW |
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 JW |
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 AB |
172 | } |
173 | ||
861d5cbe | 174 | STATIC ithread * |
fc04eb16 JH |
175 | S_ithread_get(pTHX) |
176 | { | |
628ab322 | 177 | dMY_CXT; |
861d5cbe | 178 | return (MY_CXT.context); |
c05ae023 AB |
179 | } |
180 | ||
181 | ||
fc04eb16 JH |
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 RGS |
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 DM |
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 JH |
199 | || |
200 | (thread->state & PERL_ITHR_NONVIABLE)); | |
2e676467 | 201 | |
8264cf32 | 202 | #ifndef WIN32 |
b762d866 JW |
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 DM |
210 | interp = thread->interp; |
211 | if (interp) { | |
fc04eb16 JH |
212 | dTHXa(interp); |
213 | ||
214 | PERL_SET_CONTEXT(interp); | |
215 | S_ithread_set(aTHX_ thread); | |
f2cba68d | 216 | |
fc04eb16 JH |
217 | SvREFCNT_dec(thread->params); |
218 | thread->params = Nullsv; | |
2e676467 | 219 | |
955c272e JH |
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 DM |
234 | } |
235 | ||
68795e93 | 236 | |
6158f8b3 DM |
237 | /* Decrement the refcount of an ithread, and if it reaches zero, free it. |
238 | * Must be called with the mutex held. | |
6ebc233e RGS |
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 JH |
247 | dMY_POOL; |
248 | ||
6158f8b3 DM |
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 RGS |
255 | assert((thread->state & PERL_ITHR_FINISHED) && |
256 | (thread->state & PERL_ITHR_UNCALLABLE)); | |
fc04eb16 | 257 | } |
adc09a0e | 258 | MUTEX_UNLOCK(&thread->mutex); |
9feacc09 | 259 | |
fc04eb16 JH |
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 JH |
265 | assert(thread->prev && thread->next); |
266 | thread->next->prev = thread->prev; | |
267 | thread->prev->next = thread->next; | |
fc04eb16 JH |
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 JH |
275 | |
276 | #ifdef WIN32 | |
fc04eb16 JH |
277 | handle = thread->handle; |
278 | thread->handle = NULL; | |
385d56e4 | 279 | #endif |
fc04eb16 JH |
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 DM |
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 RGS |
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 DM |
296 | */ |
297 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); | |
298 | MY_POOL.total_threads--; | |
299 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); | |
68795e93 NIS |
300 | } |
301 | ||
fc04eb16 | 302 | |
6158f8b3 DM |
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 DM |
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 JH |
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 JH |
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 NIS |
337 | } |
338 | ||
ae3fba3d | 339 | |
6ebc233e RGS |
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 RGS |
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 RGS |
348 | } |
349 | ||
68795e93 NIS |
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 NIS |
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 NIS |
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 NIS |
376 | } |
377 | ||
378 | MGVTBL ithread_vtbl = { | |
fc04eb16 JH |
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 NIS |
386 | }; |
387 | ||
47ba8780 | 388 | |
514612b7 | 389 | /* Provided default, minimum and rational stack sizes */ |
861d5cbe JH |
390 | STATIC IV |
391 | S_good_stack_size(pTHX_ IV stack_size) | |
514612b7 | 392 | { |
5c6ff896 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
438 | if (MY_POOL.page_size <= 0) { |
439 | Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)MY_POOL.page_size); | |
fea7688c | 440 | } |
514612b7 JH |
441 | #endif |
442 | } | |
5c6ff896 | 443 | stack_size = ((stack_size + (MY_POOL.page_size - 1)) / MY_POOL.page_size) * MY_POOL.page_size; |
514612b7 JH |
444 | |
445 | return (stack_size); | |
446 | } | |
447 | ||
448 | ||
fc04eb16 JH |
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 JH |
459 | { |
460 | ithread *thread = (ithread *)arg; | |
69a9b4b8 RGS |
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 RGS |
467 | dJMPENV; |
468 | ||
fc04eb16 | 469 | dTHXa(thread->interp); |
47ba8780 | 470 | |
5c6ff896 JH |
471 | dMY_POOL; |
472 | ||
9ca4d7fd | 473 | /* Blocked until ->create() call finishes */ |
fc04eb16 | 474 | MUTEX_LOCK(&thread->mutex); |
fc04eb16 | 475 | MUTEX_UNLOCK(&thread->mutex); |
9ca4d7fd JH |
476 | |
477 | PERL_SET_CONTEXT(thread->interp); | |
478 | S_ithread_set(aTHX_ thread); | |
47ba8780 | 479 | |
8264cf32 | 480 | #ifndef WIN32 |
b762d866 JW |
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 JH |
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 JH |
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 RGS |
511 | /* Thread exited */ |
512 | exit_app = 1; | |
513 | exit_code = STATUS_CURRENT; | |
4dcb9e53 JH |
514 | while (PL_scopestack_ix > oldscope) { |
515 | LEAVE; | |
516 | } | |
517 | } | |
518 | JMPENV_POP; | |
fc04eb16 | 519 | |
8264cf32 | 520 | #ifndef WIN32 |
b762d866 JW |
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 JH |
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 JH |
533 | av_store(params, ii, SvREFCNT_inc(sv)); |
534 | } | |
fc04eb16 JH |
535 | } |
536 | ||
4dcb9e53 JH |
537 | FREETMPS; |
538 | LEAVE; | |
539 | ||
955c272e JH |
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 JH |
568 | } |
569 | ||
fc04eb16 JH |
570 | /* Release function ref */ |
571 | SvREFCNT_dec(thread->init_function); | |
572 | thread->init_function = Nullsv; | |
573 | } | |
62375a60 | 574 | |
fc04eb16 JH |
575 | PerlIO_flush((PerlIO *)NULL); |
576 | ||
5c6ff896 | 577 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
fc04eb16 JH |
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 JH |
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 RGS |
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 RGS |
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 DM |
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 NIS |
629 | } |
630 | ||
fc04eb16 JH |
631 | |
632 | /* Type conversion helper functions */ | |
fea7688c | 633 | |
861d5cbe JH |
634 | STATIC SV * |
635 | S_ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) | |
68795e93 NIS |
636 | { |
637 | SV *sv; | |
638 | MAGIC *mg; | |
fc04eb16 | 639 | |
6158f8b3 DM |
640 | if (inc) |
641 | S_ithread_count_inc(aTHX_ thread); | |
fc04eb16 JH |
642 | |
643 | if (! obj) { | |
644 | obj = newSV(0); | |
68795e93 | 645 | } |
fc04eb16 JH |
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 NIS |
650 | mg->mg_flags |= MGf_DUP; |
651 | SvREADONLY_on(sv); | |
fc04eb16 JH |
652 | |
653 | return (obj); | |
68795e93 | 654 | } |
47ba8780 | 655 | |
861d5cbe JH |
656 | STATIC ithread * |
657 | S_SV_to_ithread(pTHX_ SV *sv) | |
68795e93 | 658 | { |
fc04eb16 JH |
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 AB |
665 | } |
666 | ||
47ba8780 | 667 | |
fc04eb16 JH |
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 | |
24855dff | 683 | #if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 |
fc04eb16 JH |
684 | SV **tmps_tmp = PL_tmps_stack; |
685 | IV tmps_ix = PL_tmps_ix; | |
24855dff | 686 | #endif |
d94006e8 | 687 | #ifndef WIN32 |
fc04eb16 JH |
688 | int rc_stack_size = 0; |
689 | int rc_thread_create = 0; | |
d94006e8 | 690 | #endif |
adc09a0e | 691 | dMY_POOL; |
3b1c3273 | 692 | |
adc09a0e | 693 | /* Allocate thread structure in context of the main thread's interpreter */ |
5c6ff896 JH |
694 | { |
695 | PERL_SET_CONTEXT(MY_POOL.main_thread.interp); | |
696 | thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); | |
697 | } | |
698 | PERL_SET_CONTEXT(aTHX); | |
fc04eb16 | 699 | if (!thread) { |
5c6ff896 | 700 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
fc04eb16 JH |
701 | PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); |
702 | my_exit(1); | |
703 | } | |
704 | Zero(thread, 1, ithread); | |
705 | ||
706 | /* Add to threads list */ | |
5c6ff896 JH |
707 | thread->next = &MY_POOL.main_thread; |
708 | thread->prev = MY_POOL.main_thread.prev; | |
709 | MY_POOL.main_thread.prev = thread; | |
fc04eb16 | 710 | thread->prev->next = thread; |
e9a908c9 | 711 | MY_POOL.total_threads++; |
c05ae023 | 712 | |
6ebc233e | 713 | /* 1 ref to be held by the local var 'thread' in S_ithread_run(). |
6158f8b3 | 714 | * 1 ref to be held by the threads object that we assume we will |
6ebc233e RGS |
715 | * be embedded in upon our return. |
716 | * 1 ref to be the responsibility of join/detach, so we don't get | |
717 | * freed until join/detach, even if no thread objects remain. | |
718 | * This allows the following to work: | |
878090d5 | 719 | * { threads->create(sub{...}); } threads->object(1)->join; |
fc04eb16 | 720 | */ |
6158f8b3 | 721 | thread->count = 3; |
fc04eb16 | 722 | |
9ca4d7fd | 723 | /* Block new thread until ->create() call finishes */ |
fc04eb16 | 724 | MUTEX_INIT(&thread->mutex); |
9ca4d7fd JH |
725 | MUTEX_LOCK(&thread->mutex); |
726 | ||
5c6ff896 | 727 | thread->tid = MY_POOL.tid_counter++; |
861d5cbe | 728 | thread->stack_size = S_good_stack_size(aTHX_ stack_size); |
9d9ff5b1 | 729 | thread->gimme = gimme; |
69a9b4b8 | 730 | thread->state = exit_opt; |
fc04eb16 JH |
731 | |
732 | /* "Clone" our interpreter into the thread's interpreter. | |
733 | * This gives thread access to "static data" and code. | |
734 | */ | |
735 | PerlIO_flush((PerlIO *)NULL); | |
736 | S_ithread_set(aTHX_ thread); | |
737 | ||
738 | SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */ | |
739 | PL_srand_called = FALSE; /* Set it to false so we can detect if it gets | |
740 | set during the clone */ | |
3b1c3273 | 741 | |
8264cf32 | 742 | #ifndef WIN32 |
b762d866 JW |
743 | /* perl_clone() will leave us the new interpreter's context. This poses |
744 | * two problems for our signal handler. First, it sets the new context | |
745 | * before the new interpreter struct is fully initialized, so our signal | |
746 | * handler might find bogus data in the interpreter struct it gets. | |
747 | * Second, even if the interpreter is initialized before a signal comes in, | |
748 | * we would like to avoid that interpreter receiving notifications for | |
749 | * signals (especially when they ought to be for the one running in this | |
750 | * thread), until it is running in its own thread. Another problem is that | |
751 | * the new thread will not have set the context until some time after it | |
752 | * has started, so it won't be safe for our signal handler to run until | |
753 | * that time. | |
754 | * | |
755 | * So we block most signals here, so the new thread will inherit the signal | |
756 | * mask, and unblock them right after the thread creation. The original | |
757 | * mask is saved in the thread struct so that the new thread can restore | |
758 | * the original mask. | |
759 | */ | |
760 | S_block_most_signals(&thread->initial_sigmask); | |
8264cf32 | 761 | #endif |
b762d866 | 762 | |
47ba8780 | 763 | #ifdef WIN32 |
fc04eb16 | 764 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); |
47ba8780 | 765 | #else |
fc04eb16 | 766 | thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE); |
47ba8780 | 767 | #endif |
47ba8780 | 768 | |
fc04eb16 JH |
769 | /* perl_clone() leaves us in new interpreter's context. As it is tricky |
770 | * to spot an implicit aTHX, create a new scope with aTHX matching the | |
771 | * context for the duration of our work for new interpreter. | |
772 | */ | |
773 | { | |
894eec8b JH |
774 | CLONE_PARAMS clone_param; |
775 | ||
fc04eb16 JH |
776 | dTHXa(thread->interp); |
777 | ||
778 | MY_CXT_CLONE; | |
779 | ||
780 | /* Here we remove END blocks since they should only run in the thread | |
781 | * they are created | |
782 | */ | |
783 | SvREFCNT_dec(PL_endav); | |
784 | PL_endav = newAV(); | |
404aaa48 | 785 | |
894eec8b | 786 | clone_param.flags = 0; |
f2e0bb91 JH |
787 | if (SvPOK(init_function)) { |
788 | thread->init_function = newSV(0); | |
789 | sv_copypv(thread->init_function, init_function); | |
790 | } else { | |
dd5ef8e0 | 791 | thread->init_function = |
24855dff | 792 | SvREFCNT_inc(sv_dup(init_function, &clone_param)); |
fc04eb16 JH |
793 | } |
794 | ||
795 | thread->params = sv_dup(params, &clone_param); | |
d4315dd6 | 796 | SvREFCNT_inc_void(thread->params); |
fc04eb16 | 797 | |
24855dff | 798 | #if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 |
fc04eb16 JH |
799 | /* The code below checks that anything living on the tmps stack and |
800 | * has been cloned (so it lives in the ptr_table) has a refcount | |
801 | * higher than 0. | |
802 | * | |
803 | * If the refcount is 0 it means that a something on the stack/context | |
804 | * was holding a reference to it and since we init_stacks() in | |
805 | * perl_clone that won't get cleaned and we will get a leaked scalar. | |
806 | * The reason it was cloned was that it lived on the @_ stack. | |
807 | * | |
808 | * Example of this can be found in bugreport 15837 where calls in the | |
809 | * parameter list end up as a temp. | |
810 | * | |
24855dff | 811 | * As of 5.8.8 this is done in perl_clone. |
fc04eb16 JH |
812 | */ |
813 | while (tmps_ix > 0) { | |
814 | SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]); | |
815 | tmps_ix--; | |
816 | if (sv && SvREFCNT(sv) == 0) { | |
d4315dd6 | 817 | SvREFCNT_inc_void(sv); |
fc04eb16 JH |
818 | SvREFCNT_dec(sv); |
819 | } | |
820 | } | |
24855dff | 821 | #endif |
fc04eb16 JH |
822 | |
823 | SvTEMP_off(thread->init_function); | |
824 | ptr_table_free(PL_ptr_table); | |
825 | PL_ptr_table = NULL; | |
826 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; | |
827 | } | |
828 | S_ithread_set(aTHX_ current_thread); | |
829 | PERL_SET_CONTEXT(aTHX); | |
830 | ||
831 | /* Create/start the thread */ | |
47ba8780 | 832 | #ifdef WIN32 |
fc04eb16 | 833 | thread->handle = CreateThread(NULL, |
514612b7 | 834 | (DWORD)thread->stack_size, |
fc04eb16 JH |
835 | S_ithread_run, |
836 | (LPVOID)thread, | |
514612b7 | 837 | STACK_SIZE_PARAM_IS_A_RESERVATION, |
fc04eb16 | 838 | &thread->thr); |
82c40bf6 | 839 | #else |
fc04eb16 | 840 | { |
861d5cbe JH |
841 | STATIC pthread_attr_t attr; |
842 | STATIC int attr_inited = 0; | |
843 | STATIC int attr_joinable = PTHREAD_CREATE_JOINABLE; | |
fc04eb16 JH |
844 | if (! attr_inited) { |
845 | pthread_attr_init(&attr); | |
846 | attr_inited = 1; | |
847 | } | |
848 | ||
fa26028c | 849 | # ifdef PTHREAD_ATTR_SETDETACHSTATE |
fc04eb16 JH |
850 | /* Threads start out joinable */ |
851 | PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); | |
fa26028c | 852 | # endif |
fc04eb16 | 853 | |
514612b7 | 854 | # ifdef _POSIX_THREAD_ATTR_STACKSIZE |
fc04eb16 | 855 | /* Set thread's stack size */ |
514612b7 JH |
856 | if (thread->stack_size > 0) { |
857 | rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size); | |
858 | } | |
3eb37d38 AB |
859 | # endif |
860 | ||
fc04eb16 JH |
861 | /* Create the thread */ |
862 | if (! rc_stack_size) { | |
863 | # ifdef OLD_PTHREADS_API | |
864 | rc_thread_create = pthread_create(&thread->thr, | |
865 | attr, | |
866 | S_ithread_run, | |
867 | (void *)thread); | |
868 | # else | |
869 | # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) | |
870 | pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); | |
871 | # endif | |
872 | rc_thread_create = pthread_create(&thread->thr, | |
873 | &attr, | |
874 | S_ithread_run, | |
875 | (void *)thread); | |
19a077f6 | 876 | # endif |
fc04eb16 | 877 | } |
514612b7 | 878 | |
8264cf32 | 879 | #ifndef WIN32 |
b762d866 JW |
880 | /* Now it's safe to accept signals, since we're in our own interpreter's |
881 | * context and we have created the thread. | |
882 | */ | |
883 | S_set_sigmask(&thread->initial_sigmask); | |
8264cf32 | 884 | #endif |
b762d866 | 885 | |
514612b7 JH |
886 | # ifdef _POSIX_THREAD_ATTR_STACKSIZE |
887 | /* Try to get thread's actual stack size */ | |
888 | { | |
889 | size_t stacksize; | |
58a3a76c JH |
890 | #ifdef HPUX1020 |
891 | stacksize = pthread_attr_getstacksize(attr); | |
892 | #else | |
893 | if (! pthread_attr_getstacksize(&attr, &stacksize)) | |
894 | #endif | |
895 | if (stacksize > 0) { | |
514612b7 JH |
896 | thread->stack_size = (IV)stacksize; |
897 | } | |
514612b7 JH |
898 | } |
899 | # endif | |
fc04eb16 | 900 | } |
82c40bf6 | 901 | #endif |
bcd9ca9b | 902 | |
fc04eb16 | 903 | /* Check for errors */ |
d94006e8 | 904 | #ifdef WIN32 |
fc04eb16 | 905 | if (thread->handle == NULL) { |
d94006e8 | 906 | #else |
fc04eb16 | 907 | if (rc_stack_size || rc_thread_create) { |
d94006e8 | 908 | #endif |
9ca4d7fd | 909 | /* Must unlock mutex for destruct call */ |
5c6ff896 | 910 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
fc04eb16 | 911 | sv_2mortal(params); |
adc09a0e | 912 | thread->state |= PERL_ITHR_NONVIABLE; |
6ebc233e | 913 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
d94006e8 | 914 | #ifndef WIN32 |
514612b7 | 915 | if (ckWARN_d(WARN_THREADS)) { |
fea7688c | 916 | if (rc_stack_size) { |
514612b7 | 917 | Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size); |
fea7688c | 918 | } else { |
514612b7 | 919 | Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); |
fea7688c | 920 | } |
514612b7 | 921 | } |
d94006e8 | 922 | #endif |
9ca4d7fd | 923 | return (NULL); |
fc04eb16 JH |
924 | } |
925 | ||
5c6ff896 | 926 | MY_POOL.running_threads++; |
fc04eb16 | 927 | sv_2mortal(params); |
9ca4d7fd | 928 | return (thread); |
68795e93 | 929 | } |
47ba8780 | 930 | |
73e09c8f | 931 | #endif /* USE_ITHREADS */ |
e1c44605 | 932 | |
fcea4b7c | 933 | |
fc04eb16 | 934 | MODULE = threads PACKAGE = threads PREFIX = ithread_ |
68795e93 | 935 | PROTOTYPES: DISABLE |
8222d950 | 936 | |
73e09c8f JH |
937 | #ifdef USE_ITHREADS |
938 | ||
68795e93 | 939 | void |
f4cc38af JH |
940 | ithread_create(...) |
941 | PREINIT: | |
942 | char *classname; | |
514612b7 | 943 | ithread *thread; |
f4cc38af JH |
944 | SV *function_to_call; |
945 | AV *params; | |
514612b7 JH |
946 | HV *specs; |
947 | IV stack_size; | |
9d9ff5b1 | 948 | int context; |
69a9b4b8 RGS |
949 | int exit_opt; |
950 | SV *thread_exit_only; | |
9d9ff5b1 | 951 | char *str; |
514612b7 | 952 | int idx; |
f4cc38af | 953 | int ii; |
5c6ff896 | 954 | dMY_POOL; |
f4cc38af | 955 | CODE: |
514612b7 | 956 | if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) { |
fea7688c | 957 | if (--items < 2) { |
18b9e6f5 | 958 | Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)"); |
fea7688c | 959 | } |
514612b7 JH |
960 | specs = (HV*)SvRV(ST(1)); |
961 | idx = 1; | |
962 | } else { | |
fea7688c | 963 | if (items < 2) { |
514612b7 | 964 | Perl_croak(aTHX_ "Usage: threads->create(function, ...)"); |
fea7688c | 965 | } |
514612b7 JH |
966 | specs = NULL; |
967 | idx = 0; | |
968 | } | |
f4cc38af | 969 | |
514612b7 JH |
970 | if (sv_isobject(ST(0))) { |
971 | /* $thr->create() */ | |
972 | classname = HvNAME(SvSTASH(SvRV(ST(0)))); | |
973 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); | |
8718f9a1 | 974 | MUTEX_LOCK(&thread->mutex); |
514612b7 | 975 | stack_size = thread->stack_size; |
69a9b4b8 | 976 | exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY; |
8718f9a1 | 977 | MUTEX_UNLOCK(&thread->mutex); |
514612b7 JH |
978 | } else { |
979 | /* threads->create() */ | |
980 | classname = (char *)SvPV_nolen(ST(0)); | |
5c6ff896 | 981 | stack_size = MY_POOL.default_stack_size; |
8583b257 | 982 | thread_exit_only = get_sv("threads::thread_exit_only", GV_ADD); |
69a9b4b8 RGS |
983 | exit_opt = (SvTRUE(thread_exit_only)) |
984 | ? PERL_ITHR_THREAD_EXIT_ONLY : 0; | |
514612b7 JH |
985 | } |
986 | ||
987 | function_to_call = ST(idx+1); | |
988 | ||
9d9ff5b1 | 989 | context = -1; |
514612b7 JH |
990 | if (specs) { |
991 | /* stack_size */ | |
992 | if (hv_exists(specs, "stack", 5)) { | |
993 | stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0)); | |
994 | } else if (hv_exists(specs, "stacksize", 9)) { | |
995 | stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0)); | |
996 | } else if (hv_exists(specs, "stack_size", 10)) { | |
997 | stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0)); | |
998 | } | |
9d9ff5b1 JH |
999 | |
1000 | /* context */ | |
1001 | if (hv_exists(specs, "context", 7)) { | |
1002 | str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0)); | |
1003 | switch (*str) { | |
1004 | case 'a': | |
1005 | case 'A': | |
da140a40 JH |
1006 | case 'l': |
1007 | case 'L': | |
9d9ff5b1 JH |
1008 | context = G_ARRAY; |
1009 | break; | |
1010 | case 's': | |
1011 | case 'S': | |
1012 | context = G_SCALAR; | |
1013 | break; | |
1014 | case 'v': | |
1015 | case 'V': | |
1016 | context = G_VOID; | |
1017 | break; | |
1018 | default: | |
1019 | Perl_croak(aTHX_ "Invalid context: %s", str); | |
1020 | } | |
1021 | } else if (hv_exists(specs, "array", 5)) { | |
1022 | if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) { | |
1023 | context = G_ARRAY; | |
1024 | } | |
da140a40 JH |
1025 | } else if (hv_exists(specs, "list", 4)) { |
1026 | if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) { | |
1027 | context = G_ARRAY; | |
1028 | } | |
9d9ff5b1 JH |
1029 | } else if (hv_exists(specs, "scalar", 6)) { |
1030 | if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) { | |
1031 | context = G_SCALAR; | |
1032 | } | |
1033 | } else if (hv_exists(specs, "void", 4)) { | |
1034 | if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) { | |
1035 | context = G_VOID; | |
1036 | } | |
1037 | } | |
69a9b4b8 RGS |
1038 | |
1039 | /* exit => thread_only */ | |
1040 | if (hv_exists(specs, "exit", 4)) { | |
1041 | str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0)); | |
1042 | exit_opt = (*str == 't' || *str == 'T') | |
1043 | ? PERL_ITHR_THREAD_EXIT_ONLY : 0; | |
1044 | } | |
9d9ff5b1 JH |
1045 | } |
1046 | if (context == -1) { | |
1047 | context = GIMME_V; /* Implicit context */ | |
1048 | } else { | |
1049 | context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID))); | |
514612b7 | 1050 | } |
f4cc38af JH |
1051 | |
1052 | /* Function args */ | |
1053 | params = newAV(); | |
1054 | if (items > 2) { | |
514612b7 JH |
1055 | for (ii=2; ii < items ; ii++) { |
1056 | av_push(params, SvREFCNT_inc(ST(idx+ii))); | |
f4cc38af JH |
1057 | } |
1058 | } | |
1059 | ||
1060 | /* Create thread */ | |
5c6ff896 | 1061 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd JH |
1062 | thread = S_ithread_create(aTHX_ function_to_call, |
1063 | stack_size, | |
1064 | context, | |
1065 | exit_opt, | |
1066 | newRV_noinc((SV*)params)); | |
1067 | if (! thread) { | |
1068 | XSRETURN_UNDEF; /* Mutex already unlocked */ | |
1069 | } | |
861d5cbe | 1070 | ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE)); |
adc09a0e | 1071 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd JH |
1072 | |
1073 | /* Let thread run */ | |
1074 | MUTEX_UNLOCK(&thread->mutex); | |
9ca4d7fd | 1075 | |
f4cc38af JH |
1076 | /* XSRETURN(1); - implied */ |
1077 | ||
8222d950 | 1078 | |
68795e93 | 1079 | void |
f4cc38af JH |
1080 | ithread_list(...) |
1081 | PREINIT: | |
1082 | char *classname; | |
fc04eb16 | 1083 | ithread *thread; |
f4cc38af JH |
1084 | int list_context; |
1085 | IV count = 0; | |
11db694d | 1086 | int want_running = 0; |
8718f9a1 | 1087 | int state; |
5c6ff896 | 1088 | dMY_POOL; |
f4cc38af JH |
1089 | PPCODE: |
1090 | /* Class method only */ | |
fea7688c | 1091 | if (SvROK(ST(0))) { |
ead32952 | 1092 | Perl_croak(aTHX_ "Usage: threads->list(...)"); |
fea7688c | 1093 | } |
f4cc38af JH |
1094 | classname = (char *)SvPV_nolen(ST(0)); |
1095 | ||
1096 | /* Calling context */ | |
1097 | list_context = (GIMME_V == G_ARRAY); | |
1098 | ||
ead32952 JH |
1099 | /* Running or joinable parameter */ |
1100 | if (items > 1) { | |
1101 | want_running = SvTRUE(ST(1)); | |
1102 | } | |
1103 | ||
f4cc38af | 1104 | /* Walk through threads list */ |
5c6ff896 JH |
1105 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1106 | for (thread = MY_POOL.main_thread.next; | |
1107 | thread != &MY_POOL.main_thread; | |
fc04eb16 | 1108 | thread = thread->next) |
f4cc38af | 1109 | { |
8718f9a1 JH |
1110 | MUTEX_LOCK(&thread->mutex); |
1111 | state = thread->state; | |
1112 | MUTEX_UNLOCK(&thread->mutex); | |
1113 | ||
f4cc38af | 1114 | /* Ignore detached or joined threads */ |
8718f9a1 | 1115 | if (state & PERL_ITHR_UNCALLABLE) { |
f4cc38af JH |
1116 | continue; |
1117 | } | |
ead32952 JH |
1118 | |
1119 | /* Filter per parameter */ | |
1120 | if (items > 1) { | |
1121 | if (want_running) { | |
8718f9a1 | 1122 | if (state & PERL_ITHR_FINISHED) { |
ead32952 JH |
1123 | continue; /* Not running */ |
1124 | } | |
1125 | } else { | |
8718f9a1 | 1126 | if (! (state & PERL_ITHR_FINISHED)) { |
ead32952 JH |
1127 | continue; /* Still running - not joinable yet */ |
1128 | } | |
1129 | } | |
1130 | } | |
1131 | ||
f4cc38af JH |
1132 | /* Push object on stack if list context */ |
1133 | if (list_context) { | |
861d5cbe | 1134 | XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE))); |
f4cc38af JH |
1135 | } |
1136 | count++; | |
1137 | } | |
5c6ff896 | 1138 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
f4cc38af JH |
1139 | /* If scalar context, send back count */ |
1140 | if (! list_context) { | |
1141 | XSRETURN_IV(count); | |
1142 | } | |
678a9b6c AB |
1143 | |
1144 | ||
1145 | void | |
f4cc38af JH |
1146 | ithread_self(...) |
1147 | PREINIT: | |
1148 | char *classname; | |
fcea4b7c | 1149 | ithread *thread; |
f4cc38af JH |
1150 | CODE: |
1151 | /* Class method only */ | |
11db694d | 1152 | if ((items != 1) || SvROK(ST(0))) { |
f4cc38af | 1153 | Perl_croak(aTHX_ "Usage: threads->self()"); |
fea7688c | 1154 | } |
f4cc38af JH |
1155 | classname = (char *)SvPV_nolen(ST(0)); |
1156 | ||
fcea4b7c JH |
1157 | thread = S_ithread_get(aTHX); |
1158 | ||
861d5cbe | 1159 | ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
f4cc38af | 1160 | /* XSRETURN(1); - implied */ |
47ba8780 | 1161 | |
47ba8780 AB |
1162 | |
1163 | void | |
f4cc38af JH |
1164 | ithread_tid(...) |
1165 | PREINIT: | |
1166 | ithread *thread; | |
1167 | CODE: | |
11db694d | 1168 | PERL_UNUSED_VAR(items); |
861d5cbe | 1169 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
f4cc38af JH |
1170 | XST_mUV(0, thread->tid); |
1171 | /* XSRETURN(1); - implied */ | |
1172 | ||
e1c44605 | 1173 | |
f9dff5f5 | 1174 | void |
f4cc38af JH |
1175 | ithread_join(...) |
1176 | PREINIT: | |
fcea4b7c | 1177 | ithread *thread; |
8718f9a1 | 1178 | ithread *current_thread; |
fcea4b7c | 1179 | int join_err; |
6ebc233e | 1180 | AV *params = NULL; |
f4cc38af JH |
1181 | int len; |
1182 | int ii; | |
12701bb8 | 1183 | #ifndef WIN32 |
8718f9a1 | 1184 | int rc_join; |
fcea4b7c JH |
1185 | void *retval; |
1186 | #endif | |
5c6ff896 | 1187 | dMY_POOL; |
f4cc38af JH |
1188 | PPCODE: |
1189 | /* Object method only */ | |
11db694d | 1190 | if ((items != 1) || ! sv_isobject(ST(0))) { |
f4cc38af | 1191 | Perl_croak(aTHX_ "Usage: $thr->join()"); |
fea7688c | 1192 | } |
f4cc38af | 1193 | |
8718f9a1 | 1194 | /* Check if the thread is joinable and not ourselves */ |
861d5cbe | 1195 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
8718f9a1 JH |
1196 | current_thread = S_ithread_get(aTHX); |
1197 | ||
1198 | MUTEX_LOCK(&thread->mutex); | |
1199 | if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) { | |
1200 | MUTEX_UNLOCK(&thread->mutex); | |
1201 | Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED) | |
1202 | ? "Cannot join a detached thread" | |
1203 | : "Thread already joined"); | |
1204 | } else if (thread->tid == current_thread->tid) { | |
1205 | MUTEX_UNLOCK(&thread->mutex); | |
1206 | Perl_croak(aTHX_ "Cannot join self"); | |
fcea4b7c JH |
1207 | } |
1208 | ||
8718f9a1 JH |
1209 | /* Mark as joined */ |
1210 | thread->state |= PERL_ITHR_JOINED; | |
1211 | MUTEX_UNLOCK(&thread->mutex); | |
1212 | ||
1213 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); | |
1214 | MY_POOL.joinable_threads--; | |
1215 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); | |
1216 | ||
fcea4b7c JH |
1217 | /* Join the thread */ |
1218 | #ifdef WIN32 | |
8718f9a1 JH |
1219 | if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) { |
1220 | /* Timeout/abandonment unexpected here; check $^E */ | |
1221 | Perl_croak(aTHX_ "PANIC: underlying join failed"); | |
1222 | }; | |
fcea4b7c | 1223 | #else |
8718f9a1 JH |
1224 | if ((rc_join = pthread_join(thread->thr, &retval)) != 0) { |
1225 | /* In progress/deadlock/unknown unexpected here; check $! */ | |
1226 | errno = rc_join; | |
1227 | Perl_croak(aTHX_ "PANIC: underlying join failed"); | |
1228 | }; | |
fcea4b7c JH |
1229 | #endif |
1230 | ||
1231 | MUTEX_LOCK(&thread->mutex); | |
fcea4b7c | 1232 | /* Get the return value from the call_sv */ |
955c272e | 1233 | /* Objects do not survive this process - FIXME */ |
7df0357e | 1234 | if ((thread->gimme & G_WANT) != G_VOID) { |
fcea4b7c JH |
1235 | AV *params_copy; |
1236 | PerlInterpreter *other_perl; | |
1237 | CLONE_PARAMS clone_params; | |
fcea4b7c JH |
1238 | |
1239 | params_copy = (AV *)SvRV(thread->params); | |
1240 | other_perl = thread->interp; | |
1241 | clone_params.stashes = newAV(); | |
1242 | clone_params.flags = CLONEf_JOIN_IN; | |
1243 | PL_ptr_table = ptr_table_new(); | |
fcea4b7c JH |
1244 | S_ithread_set(aTHX_ thread); |
1245 | /* Ensure 'meaningful' addresses retain their meaning */ | |
1246 | ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); | |
1247 | ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); | |
1248 | ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); | |
1249 | params = (AV *)sv_dup((SV*)params_copy, &clone_params); | |
1250 | S_ithread_set(aTHX_ current_thread); | |
1251 | SvREFCNT_dec(clone_params.stashes); | |
d4315dd6 | 1252 | SvREFCNT_inc_void(params); |
fcea4b7c JH |
1253 | ptr_table_free(PL_ptr_table); |
1254 | PL_ptr_table = NULL; | |
1255 | } | |
1256 | ||
955c272e JH |
1257 | /* If thread didn't die, then we can free its interpreter */ |
1258 | if (! (thread->state & PERL_ITHR_DIED)) { | |
1259 | S_ithread_clear(aTHX_ thread); | |
1260 | } | |
6ebc233e | 1261 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
955c272e | 1262 | |
fcea4b7c | 1263 | /* If no return values, then just return */ |
f4cc38af JH |
1264 | if (! params) { |
1265 | XSRETURN_UNDEF; | |
1266 | } | |
1267 | ||
1268 | /* Put return values on stack */ | |
1269 | len = (int)AvFILL(params); | |
1270 | for (ii=0; ii <= len; ii++) { | |
1271 | SV* param = av_shift(params); | |
1272 | XPUSHs(sv_2mortal(param)); | |
1273 | } | |
1274 | ||
1275 | /* Free return value array */ | |
1276 | SvREFCNT_dec(params); | |
1277 | ||
1278 | ||
1279 | void | |
1280 | ithread_yield(...) | |
1281 | CODE: | |
11db694d | 1282 | PERL_UNUSED_VAR(items); |
f4cc38af JH |
1283 | YIELD; |
1284 | ||
1285 | ||
1286 | void | |
1287 | ithread_detach(...) | |
1288 | PREINIT: | |
1289 | ithread *thread; | |
fcea4b7c | 1290 | int detach_err; |
5c6ff896 | 1291 | dMY_POOL; |
f4cc38af | 1292 | CODE: |
11db694d JH |
1293 | PERL_UNUSED_VAR(items); |
1294 | ||
fcea4b7c | 1295 | /* Detach the thread */ |
8718f9a1 | 1296 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
5c6ff896 | 1297 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd | 1298 | MUTEX_LOCK(&thread->mutex); |
8718f9a1 JH |
1299 | if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) { |
1300 | /* Thread is detachable */ | |
1301 | thread->state |= PERL_ITHR_DETACHED; | |
fcea4b7c | 1302 | #ifdef WIN32 |
8718f9a1 | 1303 | /* Windows has no 'detach thread' function */ |
fcea4b7c | 1304 | #else |
8718f9a1 | 1305 | PERL_THREAD_DETACH(thread->thr); |
fcea4b7c | 1306 | #endif |
8718f9a1 JH |
1307 | if (thread->state & PERL_ITHR_FINISHED) { |
1308 | MY_POOL.joinable_threads--; | |
1309 | } else { | |
1310 | MY_POOL.running_threads--; | |
1311 | MY_POOL.detached_threads++; | |
1312 | } | |
4dcb9e53 | 1313 | } |
adc09a0e | 1314 | MUTEX_UNLOCK(&thread->mutex); |
5c6ff896 | 1315 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
4dcb9e53 | 1316 | |
8718f9a1 JH |
1317 | if (detach_err) { |
1318 | Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED) | |
1319 | ? "Thread already detached" | |
1320 | : "Cannot detach a joined thread"); | |
1321 | } | |
1322 | ||
955c272e JH |
1323 | /* If thread is finished and didn't die, |
1324 | * then we can free its interpreter */ | |
1325 | MUTEX_LOCK(&thread->mutex); | |
1326 | if ((thread->state & PERL_ITHR_FINISHED) && | |
1327 | ! (thread->state & PERL_ITHR_DIED)) | |
1328 | { | |
1329 | S_ithread_clear(aTHX_ thread); | |
1330 | } | |
6ebc233e | 1331 | S_ithread_free(aTHX_ thread); /* Releases MUTEX */ |
f4cc38af | 1332 | |
47ba8780 AB |
1333 | |
1334 | void | |
c0003851 JH |
1335 | ithread_kill(...) |
1336 | PREINIT: | |
1337 | ithread *thread; | |
1338 | char *sig_name; | |
1339 | IV signal; | |
1340 | CODE: | |
1341 | /* Must have safe signals */ | |
fea7688c | 1342 | if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { |
4dcb9e53 | 1343 | Perl_croak(aTHX_ "Cannot signal threads without safe signals"); |
fea7688c | 1344 | } |
c0003851 JH |
1345 | |
1346 | /* Object method only */ | |
11db694d | 1347 | if ((items != 2) || ! sv_isobject(ST(0))) { |
c0003851 | 1348 | Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')"); |
fea7688c | 1349 | } |
c0003851 | 1350 | |
c0003851 JH |
1351 | /* Get signal */ |
1352 | sig_name = SvPV_nolen(ST(1)); | |
1353 | if (isALPHA(*sig_name)) { | |
fea7688c | 1354 | if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') { |
c0003851 | 1355 | sig_name += 3; |
fea7688c JH |
1356 | } |
1357 | if ((signal = whichsig(sig_name)) < 0) { | |
c0003851 | 1358 | Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name); |
fea7688c JH |
1359 | } |
1360 | } else { | |
c0003851 | 1361 | signal = SvIV(ST(1)); |
fea7688c | 1362 | } |
c0003851 JH |
1363 | |
1364 | /* Set the signal for the thread */ | |
861d5cbe | 1365 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
4dcb9e53 | 1366 | MUTEX_LOCK(&thread->mutex); |
3ceb02cd | 1367 | if (thread->interp) { |
c0003851 JH |
1368 | dTHXa(thread->interp); |
1369 | PL_psig_pend[signal]++; | |
1370 | PL_sig_pending = 1; | |
1371 | } | |
4dcb9e53 | 1372 | MUTEX_UNLOCK(&thread->mutex); |
c0003851 JH |
1373 | |
1374 | /* Return the thread to allow for method chaining */ | |
1375 | ST(0) = ST(0); | |
1376 | /* XSRETURN(1); - implied */ | |
1377 | ||
1378 | ||
1379 | void | |
f4cc38af JH |
1380 | ithread_DESTROY(...) |
1381 | CODE: | |
11db694d | 1382 | PERL_UNUSED_VAR(items); |
fcea4b7c | 1383 | sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar); |
f4cc38af JH |
1384 | |
1385 | ||
1386 | void | |
1387 | ithread_equal(...) | |
fc04eb16 JH |
1388 | PREINIT: |
1389 | int are_equal = 0; | |
f4cc38af | 1390 | CODE: |
11db694d JH |
1391 | PERL_UNUSED_VAR(items); |
1392 | ||
fc04eb16 | 1393 | /* Compares TIDs to determine thread equality */ |
f4cc38af JH |
1394 | if (sv_isobject(ST(0)) && sv_isobject(ST(1))) { |
1395 | ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); | |
1396 | ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1)))); | |
fc04eb16 JH |
1397 | are_equal = (thr1->tid == thr2->tid); |
1398 | } | |
1399 | if (are_equal) { | |
1400 | XST_mYES(0); | |
f4cc38af | 1401 | } else { |
fc04eb16 | 1402 | /* Return 0 on false for backward compatibility */ |
f4cc38af JH |
1403 | XST_mIV(0, 0); |
1404 | } | |
1405 | /* XSRETURN(1); - implied */ | |
1406 | ||
47ba8780 | 1407 | |
47ba8780 | 1408 | void |
f4cc38af JH |
1409 | ithread_object(...) |
1410 | PREINIT: | |
1411 | char *classname; | |
1412 | UV tid; | |
fc04eb16 | 1413 | ithread *thread; |
8718f9a1 | 1414 | int state; |
9ca4d7fd | 1415 | int have_obj = 0; |
5c6ff896 | 1416 | dMY_POOL; |
f4cc38af JH |
1417 | CODE: |
1418 | /* Class method only */ | |
fea7688c | 1419 | if (SvROK(ST(0))) { |
f4cc38af | 1420 | Perl_croak(aTHX_ "Usage: threads->object($tid)"); |
fea7688c | 1421 | } |
f4cc38af JH |
1422 | classname = (char *)SvPV_nolen(ST(0)); |
1423 | ||
1424 | if ((items < 2) || ! SvOK(ST(1))) { | |
1425 | XSRETURN_UNDEF; | |
1426 | } | |
1427 | ||
fc04eb16 | 1428 | /* threads->object($tid) */ |
f4cc38af JH |
1429 | tid = SvUV(ST(1)); |
1430 | ||
1431 | /* Walk through threads list */ | |
5c6ff896 JH |
1432 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); |
1433 | for (thread = MY_POOL.main_thread.next; | |
1434 | thread != &MY_POOL.main_thread; | |
fc04eb16 | 1435 | thread = thread->next) |
f4cc38af | 1436 | { |
9ca4d7fd JH |
1437 | /* Look for TID */ |
1438 | if (thread->tid == tid) { | |
1439 | /* Ignore if detached or joined */ | |
8718f9a1 JH |
1440 | MUTEX_LOCK(&thread->mutex); |
1441 | state = thread->state; | |
1442 | MUTEX_UNLOCK(&thread->mutex); | |
1443 | if (! (state & PERL_ITHR_UNCALLABLE)) { | |
9ca4d7fd | 1444 | /* Put object on stack */ |
861d5cbe | 1445 | ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)); |
9ca4d7fd JH |
1446 | have_obj = 1; |
1447 | } | |
1448 | break; | |
f4cc38af | 1449 | } |
f4cc38af | 1450 | } |
5c6ff896 | 1451 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); |
9ca4d7fd JH |
1452 | |
1453 | if (! have_obj) { | |
f4cc38af JH |
1454 | XSRETURN_UNDEF; |
1455 | } | |
1456 | /* XSRETURN(1); - implied */ | |
1457 | ||
1458 | ||
1459 | void | |
1460 | ithread__handle(...); | |
1461 | PREINIT: | |
1462 | ithread *thread; | |
1463 | CODE: | |
11db694d | 1464 | PERL_UNUSED_VAR(items); |
861d5cbe | 1465 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
f4cc38af | 1466 | #ifdef WIN32 |
fcea4b7c | 1467 | XST_mUV(0, PTR2UV(&thread->handle)); |
f4cc38af | 1468 | #else |
75ba4ae2 | 1469 | XST_mUV(0, PTR2UV(&thread->thr)); |
f4cc38af JH |
1470 | #endif |
1471 | /* XSRETURN(1); - implied */ | |
68795e93 | 1472 | |
514612b7 JH |
1473 | |
1474 | void | |
1475 | ithread_get_stack_size(...) | |
1476 | PREINIT: | |
1477 | IV stack_size; | |
5c6ff896 | 1478 | dMY_POOL; |
514612b7 | 1479 | CODE: |
11db694d | 1480 | PERL_UNUSED_VAR(items); |
514612b7 JH |
1481 | if (sv_isobject(ST(0))) { |
1482 | /* $thr->get_stack_size() */ | |
1483 | ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); | |
1484 | stack_size = thread->stack_size; | |
1485 | } else { | |
1486 | /* threads->get_stack_size() */ | |
5c6ff896 | 1487 | stack_size = MY_POOL.default_stack_size; |
514612b7 JH |
1488 | } |
1489 | XST_mIV(0, stack_size); | |
1490 | /* XSRETURN(1); - implied */ | |
1491 | ||
1492 | ||
1493 | void | |
1494 | ithread_set_stack_size(...) | |
1495 | PREINIT: | |
1496 | IV old_size; | |
5c6ff896 | 1497 | dMY_POOL; |
514612b7 | 1498 | CODE: |
fea7688c | 1499 | if (items != 2) { |
514612b7 | 1500 | Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)"); |
fea7688c JH |
1501 | } |
1502 | if (sv_isobject(ST(0))) { | |
514612b7 | 1503 | Perl_croak(aTHX_ "Cannot change stack size of an existing thread"); |
fea7688c | 1504 | } |
6ebc233e RGS |
1505 | if (! looks_like_number(ST(1))) { |
1506 | Perl_croak(aTHX_ "Stack size must be numeric"); | |
1507 | } | |
514612b7 | 1508 | |
5c6ff896 JH |
1509 | old_size = MY_POOL.default_stack_size; |
1510 | MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1))); | |
514612b7 JH |
1511 | XST_mIV(0, old_size); |
1512 | /* XSRETURN(1); - implied */ | |
1513 | ||
ead32952 JH |
1514 | |
1515 | void | |
1516 | ithread_is_running(...) | |
1517 | PREINIT: | |
1518 | ithread *thread; | |
1519 | CODE: | |
1520 | /* Object method only */ | |
11db694d | 1521 | if ((items != 1) || ! sv_isobject(ST(0))) { |
ead32952 | 1522 | Perl_croak(aTHX_ "Usage: $thr->is_running()"); |
fea7688c | 1523 | } |
ead32952 JH |
1524 | |
1525 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); | |
8718f9a1 | 1526 | MUTEX_LOCK(&thread->mutex); |
ead32952 | 1527 | ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes; |
8718f9a1 | 1528 | MUTEX_UNLOCK(&thread->mutex); |
ead32952 JH |
1529 | /* XSRETURN(1); - implied */ |
1530 | ||
1531 | ||
1532 | void | |
1533 | ithread_is_detached(...) | |
1534 | PREINIT: | |
1535 | ithread *thread; | |
1536 | CODE: | |
11db694d | 1537 | PERL_UNUSED_VAR(items); |
861d5cbe | 1538 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
8718f9a1 | 1539 | MUTEX_LOCK(&thread->mutex); |
ead32952 | 1540 | ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no; |
8718f9a1 | 1541 | MUTEX_UNLOCK(&thread->mutex); |
ead32952 JH |
1542 | /* XSRETURN(1); - implied */ |
1543 | ||
1544 | ||
1545 | void | |
1546 | ithread_is_joinable(...) | |
1547 | PREINIT: | |
1548 | ithread *thread; | |
1549 | CODE: | |
1550 | /* Object method only */ | |
11db694d | 1551 | if ((items != 1) || ! sv_isobject(ST(0))) { |
ead32952 | 1552 | Perl_croak(aTHX_ "Usage: $thr->is_joinable()"); |
fea7688c | 1553 | } |
ead32952 JH |
1554 | |
1555 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); | |
1556 | MUTEX_LOCK(&thread->mutex); | |
1557 | ST(0) = ((thread->state & PERL_ITHR_FINISHED) && | |
8718f9a1 | 1558 | ! (thread->state & PERL_ITHR_UNCALLABLE)) |
ead32952 JH |
1559 | ? &PL_sv_yes : &PL_sv_no; |
1560 | MUTEX_UNLOCK(&thread->mutex); | |
1561 | /* XSRETURN(1); - implied */ | |
1562 | ||
1563 | ||
1564 | void | |
1565 | ithread_wantarray(...) | |
1566 | PREINIT: | |
1567 | ithread *thread; | |
1568 | CODE: | |
11db694d | 1569 | PERL_UNUSED_VAR(items); |
861d5cbe | 1570 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
7df0357e NC |
1571 | ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes : |
1572 | ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef | |
7ef93cb2 | 1573 | /* G_SCALAR */ : &PL_sv_no; |
ead32952 JH |
1574 | /* XSRETURN(1); - implied */ |
1575 | ||
69a9b4b8 RGS |
1576 | |
1577 | void | |
1578 | ithread_set_thread_exit_only(...) | |
1579 | PREINIT: | |
1580 | ithread *thread; | |
1581 | CODE: | |
fea7688c | 1582 | if (items != 2) { |
69a9b4b8 | 1583 | Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)"); |
fea7688c | 1584 | } |
861d5cbe | 1585 | thread = S_SV_to_ithread(aTHX_ ST(0)); |
69a9b4b8 RGS |
1586 | MUTEX_LOCK(&thread->mutex); |
1587 | if (SvTRUE(ST(1))) { | |
1588 | thread->state |= PERL_ITHR_THREAD_EXIT_ONLY; | |
1589 | } else { | |
1590 | thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY; | |
1591 | } | |
1592 | MUTEX_UNLOCK(&thread->mutex); | |
1593 | ||
955c272e JH |
1594 | |
1595 | void | |
1596 | ithread_error(...) | |
1597 | PREINIT: | |
1598 | ithread *thread; | |
1599 | SV *err = NULL; | |
1600 | CODE: | |
1601 | /* Object method only */ | |
1602 | if ((items != 1) || ! sv_isobject(ST(0))) { | |
1603 | Perl_croak(aTHX_ "Usage: $thr->err()"); | |
1604 | } | |
1605 | ||
1606 | thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); | |
1607 | MUTEX_LOCK(&thread->mutex); | |
1608 | ||
1609 | /* If thread died, then clone the error into the calling thread */ | |
1610 | if (thread->state & PERL_ITHR_DIED) { | |
1611 | PerlInterpreter *other_perl; | |
1612 | CLONE_PARAMS clone_params; | |
1613 | ithread *current_thread; | |
1614 | ||
1615 | other_perl = thread->interp; | |
1616 | clone_params.stashes = newAV(); | |
1617 | clone_params.flags = CLONEf_JOIN_IN; | |
1618 | PL_ptr_table = ptr_table_new(); | |
1619 | current_thread = S_ithread_get(aTHX); | |
1620 | S_ithread_set(aTHX_ thread); | |
1621 | /* Ensure 'meaningful' addresses retain their meaning */ | |
1622 | ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); | |
1623 | ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); | |
1624 | ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); | |
1625 | err = sv_dup(thread->err, &clone_params); | |
1626 | S_ithread_set(aTHX_ current_thread); | |
1627 | SvREFCNT_dec(clone_params.stashes); | |
1628 | SvREFCNT_inc_void(err); | |
1629 | /* If error was an object, bless it into the correct class */ | |
1630 | if (thread->err_class) { | |
1631 | sv_bless(err, gv_stashpv(thread->err_class, 1)); | |
1632 | } | |
1633 | ptr_table_free(PL_ptr_table); | |
1634 | PL_ptr_table = NULL; | |
1635 | } | |
1636 | ||
1637 | MUTEX_UNLOCK(&thread->mutex); | |
1638 | ||
1639 | if (! err) { | |
1640 | XSRETURN_UNDEF; | |
1641 | } | |
1642 | ||
1643 | ST(0) = sv_2mortal(err); | |
1644 | /* XSRETURN(1); - implied */ | |
1645 | ||
1646 | ||
73e09c8f JH |
1647 | #endif /* USE_ITHREADS */ |
1648 | ||
fc04eb16 | 1649 | |
68795e93 NIS |
1650 | BOOT: |
1651 | { | |
73e09c8f | 1652 | #ifdef USE_ITHREADS |
5c6ff896 JH |
1653 | SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, |
1654 | sizeof(MY_POOL_KEY)-1, TRUE); | |
1655 | my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1)); | |
1656 | ||
fc04eb16 JH |
1657 | MY_CXT_INIT; |
1658 | ||
5c6ff896 JH |
1659 | Zero(my_poolp, 1, my_pool_t); |
1660 | sv_setuv(my_pool_sv, PTR2UV(my_poolp)); | |
1661 | ||
fc04eb16 | 1662 | PL_perl_destruct_level = 2; |
5c6ff896 JH |
1663 | MUTEX_INIT(&MY_POOL.create_destruct_mutex); |
1664 | MUTEX_LOCK(&MY_POOL.create_destruct_mutex); | |
fc04eb16 JH |
1665 | |
1666 | PL_threadhook = &Perl_ithread_hook; | |
1667 | ||
5c6ff896 JH |
1668 | MY_POOL.tid_counter = 1; |
1669 | # ifdef THREAD_CREATE_NEEDS_STACK | |
1670 | MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK; | |
1671 | # endif | |
1672 | ||
c372d929 JH |
1673 | /* The 'main' thread is thread 0. |
1674 | * It is detached (unjoinable) and immortal. | |
1675 | */ | |
fc04eb16 | 1676 | |
5c6ff896 | 1677 | MUTEX_INIT(&MY_POOL.main_thread.mutex); |
fc04eb16 JH |
1678 | |
1679 | /* Head of the threads list */ | |
5c6ff896 JH |
1680 | MY_POOL.main_thread.next = &MY_POOL.main_thread; |
1681 | MY_POOL.main_thread.prev = &MY_POOL.main_thread; | |
fc04eb16 | 1682 | |
5c6ff896 | 1683 | MY_POOL.main_thread.count = 1; /* Immortal */ |
fc04eb16 | 1684 | |
5c6ff896 JH |
1685 | MY_POOL.main_thread.interp = aTHX; |
1686 | MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */ | |
1687 | MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size; | |
fc04eb16 | 1688 | # ifdef WIN32 |
5c6ff896 | 1689 | MY_POOL.main_thread.thr = GetCurrentThreadId(); |
fc04eb16 | 1690 | # else |
5c6ff896 | 1691 | MY_POOL.main_thread.thr = pthread_self(); |
fc04eb16 JH |
1692 | # endif |
1693 | ||
5c6ff896 JH |
1694 | S_ithread_set(aTHX_ &MY_POOL.main_thread); |
1695 | MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); | |
73e09c8f | 1696 | #endif /* USE_ITHREADS */ |
68795e93 | 1697 | } |