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