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