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