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