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