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