1 /* shared.xs 2 * 3 * Copyright (c) 2001-2002, 2006 Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 * "Hand any two wizards a piece of rope and they would instinctively pull in 9 * opposite directions." 10 * --Sourcery 11 * 12 * Contributed by Artur Bergman <sky AT crucially DOT net> 13 * Pulled in the (an)other direction by Nick Ing-Simmons 14 * <nick AT ing-simmons DOT net> 15 * CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org> 16 */ 17 18 /* 19 * Shared variables are implemented by a scheme similar to tieing. 20 * Each thread has a proxy SV with attached magic -- "private SVs" -- 21 * which all point to a single SV in a separate shared interpreter 22 * (PL_sharedsv_space) -- "shared SVs". 23 * 24 * The shared SV holds the variable's true values, and its state is 25 * copied between the shared and private SVs with the usual 26 * mg_get()/mg_set() arrangement. 27 * 28 * Aggregates (AVs and HVs) are implemented using tie magic, except that 29 * the vtable used is one defined in this file rather than the standard one. 30 * This means that where a tie function like FETCH is normally invoked by 31 * the tie magic's mg_get() function, we completely bypass the calling of a 32 * perl-level function, and directly call C-level code to handle it. On 33 * the other hand, calls to functions like PUSH are done directly by code 34 * in av.c, etc., which we can't bypass. So the best we can do is to provide 35 * XS versions of these functions. We also have to attach a tie object, 36 * blessed into the class threads::shared::tie, to keep the method-calling 37 * code happy. 38 * 39 * Access to aggregate elements is done the usual tied way by returning a 40 * proxy PVLV element with attached element magic. 41 * 42 * Pointers to the shared SV are squirrelled away in the mg->mg_ptr field 43 * of magic (with mg_len == 0), and in the IV2PTR(SvIV(sv)) field of tied 44 * object SVs. These pointers have to be hidden like this because they 45 * cross interpreter boundaries, and we don't want sv_clear() and friends 46 * following them. 47 * 48 * The three basic shared types look like the following: 49 * 50 * ----------------- 51 * 52 * Shared scalar (my $s : shared): 53 * 54 * SV = PVMG(0x7ba238) at 0x7387a8 55 * FLAGS = (PADMY,GMG,SMG) 56 * MAGIC = 0x824d88 57 * MG_TYPE = PERL_MAGIC_shared_scalar(n) 58 * MG_PTR = 0x810358 <<<< pointer to the shared SV 59 * 60 * ----------------- 61 * 62 * Shared aggregate (my @a : shared; my %h : shared): 63 * 64 * SV = PVAV(0x7175d0) at 0x738708 65 * FLAGS = (PADMY,RMG) 66 * MAGIC = 0x824e48 67 * MG_TYPE = PERL_MAGIC_tied(P) 68 * MG_OBJ = 0x7136e0 <<<< ref to the tied object 69 * SV = RV(0x7136f0) at 0x7136e0 70 * RV = 0x738640 71 * SV = PVMG(0x7ba238) at 0x738640 <<<< the tied object 72 * FLAGS = (OBJECT,IOK,pIOK) 73 * IV = 8455000 <<<< pointer to the shared AV 74 * STASH = 0x80abf0 "threads::shared::tie" 75 * MG_PTR = 0x810358 "" <<<< another pointer to the shared AV 76 * ARRAY = 0x0 77 * 78 * ----------------- 79 * 80 * Aggregate element (my @a : shared; $a[0]) 81 * 82 * SV = PVLV(0x77f628) at 0x713550 83 * FLAGS = (GMG,SMG,RMG,pIOK) 84 * MAGIC = 0x72bd58 85 * MG_TYPE = PERL_MAGIC_shared_scalar(n) 86 * MG_PTR = 0x8103c0 "" <<<< pointer to the shared element 87 * MAGIC = 0x72bd18 88 * MG_TYPE = PERL_MAGIC_tiedelem(p) 89 * MG_OBJ = 0x7136e0 <<<< ref to the tied object 90 * SV = RV(0x7136f0) at 0x7136e0 91 * RV = 0x738660 92 * SV = PVMG(0x7ba278) at 0x738660 <<<< the tied object 93 * FLAGS = (OBJECT,IOK,pIOK) 94 * IV = 8455064 <<<< pointer to the shared AV 95 * STASH = 0x80ac30 "threads::shared::tie" 96 * TYPE = t 97 * 98 * Note that PERL_MAGIC_tiedelem(p) magic doesn't have a pointer to a 99 * shared SV in mg_ptr; instead this is used to store the hash key, 100 * if any, like normal tied elements. Note also that element SVs may have 101 * pointers to both the shared aggregate and the shared element. 102 * 103 * 104 * Userland locks: 105 * 106 * If a shared variable is used as a perl-level lock or condition 107 * variable, then PERL_MAGIC_ext magic is attached to the associated 108 * *shared* SV, whose mg_ptr field points to a malloc'ed structure 109 * containing the necessary mutexes and condition variables. 110 * 111 * Nomenclature: 112 * 113 * In this file, any variable name prefixed with 's' (e.g., ssv, stmp or sobj) 114 * usually represents a shared SV which corresponds to a private SV named 115 * without the prefix (e.g., sv, tmp or obj). 116 */ 117 118 /* this is lower overhead than warn() and less likely to interfere 119 with other parts of perl (like with the debugger.) 120 */ 121 #ifdef SHARED_TRACE_LOCKS 122 # define TRACE_LOCK(x) DEBUG_U(x) 123 # define TRACE_LOCKv(x) DEBUG_Uv(x) 124 #else 125 # define TRACE_LOCK(x) 126 # define TRACE_LOCKv(x) 127 #endif 128 129 #define PERL_NO_GET_CONTEXT 130 #include "EXTERN.h" 131 #include "perl.h" 132 #include "XSUB.h" 133 #ifdef HAS_PPPORT_H 134 # define NEED_sv_2pv_flags 135 # define NEED_vnewSVpvf 136 # define NEED_warner 137 # define NEED_newSVpvn_flags 138 # include "ppport.h" 139 # include "shared.h" 140 #endif 141 142 #ifndef CLANG_DIAG_IGNORE 143 # define CLANG_DIAG_IGNORE(x) 144 # define CLANG_DIAG_RESTORE 145 #endif 146 #ifndef CLANG_DIAG_IGNORE_STMT 147 # define CLANG_DIAG_IGNORE_STMT(x) CLANG_DIAG_IGNORE(x) NOOP 148 # define CLANG_DIAG_RESTORE_STMT CLANG_DIAG_RESTORE NOOP 149 #endif 150 151 #ifdef USE_ITHREADS 152 153 /* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */ 154 #define UL_MAGIC_SIG 0x554C /* UL = user lock */ 155 156 /* 157 * The shared things need an interpreter to live in ... 158 */ 159 static PerlInterpreter *PL_sharedsv_space; /* The shared sv space */ 160 /* To access shared space we fake aTHX in this scope and thread's context */ 161 162 /* Bug #24255: We include ENTER+SAVETMPS/FREETMPS+LEAVE with 163 * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals, etc. created 164 * while in the shared interpreter context don't languish */ 165 166 #define SHARED_CONTEXT \ 167 STMT_START { \ 168 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \ 169 ENTER; \ 170 SAVETMPS; \ 171 } STMT_END 172 173 /* So we need a way to switch back to the caller's context... */ 174 /* So we declare _another_ copy of the aTHX variable ... */ 175 #define dTHXc PerlInterpreter *caller_perl = aTHX 176 177 /* ... and use it to switch back */ 178 #define CALLER_CONTEXT \ 179 STMT_START { \ 180 FREETMPS; \ 181 LEAVE; \ 182 PERL_SET_CONTEXT((aTHX = caller_perl)); \ 183 } STMT_END 184 185 /* 186 * Only one thread at a time is allowed to mess with shared space. 187 */ 188 189 typedef struct { 190 perl_mutex mutex; 191 PerlInterpreter *owner; 192 I32 locks; 193 perl_cond cond; 194 #ifdef DEBUG_LOCKS 195 const char * file; 196 int line; 197 #endif 198 } recursive_lock_t; 199 200 static recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */ 201 202 static void 203 recursive_lock_init(pTHX_ recursive_lock_t *lock) 204 { 205 Zero(lock,1,recursive_lock_t); 206 MUTEX_INIT(&lock->mutex); 207 COND_INIT(&lock->cond); 208 } 209 210 static void 211 recursive_lock_destroy(pTHX_ recursive_lock_t *lock) 212 { 213 MUTEX_DESTROY(&lock->mutex); 214 COND_DESTROY(&lock->cond); 215 } 216 217 static void 218 recursive_lock_release(pTHX_ recursive_lock_t *lock) 219 { 220 MUTEX_LOCK(&lock->mutex); 221 if (lock->owner == aTHX) { 222 if (--lock->locks == 0) { 223 lock->owner = NULL; 224 COND_SIGNAL(&lock->cond); 225 TRACE_LOCK( 226 PerlIO_printf(Perl_debug_log, "shared lock released %p for %p at %s:%d\n", 227 lock, aTHX, CopFILE(PL_curcop), CopLINE(PL_curcop)) 228 ); 229 } 230 else { 231 TRACE_LOCKv( 232 PerlIO_printf(Perl_debug_log, "shared lock unbump %p for %p at %s:%d\n", 233 lock, aTHX, CopFILE(PL_curcop), CopLINE(PL_curcop)) 234 ); 235 } 236 } 237 else { 238 TRACE_LOCK( 239 PerlIO_printf(Perl_debug_log, "bad shared lock release %p for %p (owned by %p) at %s:%d\n", 240 lock, aTHX, lock->owner, CopFILE(PL_curcop), CopLINE(PL_curcop)) 241 ); 242 } 243 MUTEX_UNLOCK(&lock->mutex); 244 } 245 246 static void 247 recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line) 248 { 249 PERL_UNUSED_ARG(file); 250 PERL_UNUSED_ARG(line); 251 assert(aTHX); 252 MUTEX_LOCK(&lock->mutex); 253 if (lock->owner == aTHX) { 254 TRACE_LOCKv( 255 PerlIO_printf(Perl_debug_log, "shared lock bump %p (%p) at %s:%d\n", 256 lock, lock->owner, CopFILE(PL_curcop), CopLINE(PL_curcop)) 257 ); 258 lock->locks++; 259 } else { 260 TRACE_LOCK( 261 PerlIO_printf(Perl_debug_log, "shared lock try %p for %p (owned by %p) at %s:%d\n", 262 lock, aTHX, lock->owner, CopFILE(PL_curcop), CopLINE(PL_curcop)) 263 ); 264 while (lock->owner) { 265 #ifdef DEBUG_LOCKS 266 Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n", 267 aTHX, lock->owner, lock->file, lock->line); 268 #endif 269 COND_WAIT(&lock->cond,&lock->mutex); 270 } 271 TRACE_LOCK( 272 PerlIO_printf(Perl_debug_log, "shared lock got %p at %s:%d\n", 273 lock, CopFILE(PL_curcop), CopLINE(PL_curcop)) 274 ); 275 lock->locks = 1; 276 lock->owner = aTHX; 277 #ifdef DEBUG_LOCKS 278 lock->file = file; 279 lock->line = line; 280 #endif 281 } 282 MUTEX_UNLOCK(&lock->mutex); 283 SAVEDESTRUCTOR_X(recursive_lock_release,lock); 284 } 285 286 #define ENTER_LOCK \ 287 STMT_START { \ 288 ENTER; \ 289 recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\ 290 } STMT_END 291 292 /* The unlocking is done automatically at scope exit */ 293 #define LEAVE_LOCK LEAVE 294 295 296 /* A common idiom is to acquire access and switch in ... */ 297 #define SHARED_EDIT \ 298 STMT_START { \ 299 ENTER_LOCK; \ 300 SHARED_CONTEXT; \ 301 } STMT_END 302 303 /* ... then switch out and release access. */ 304 #define SHARED_RELEASE \ 305 STMT_START { \ 306 CALLER_CONTEXT; \ 307 LEAVE_LOCK; \ 308 } STMT_END 309 310 311 /* User-level locks: 312 This structure is attached (using ext magic) to any shared SV that 313 is used by user-level locking or condition code 314 */ 315 316 typedef struct { 317 recursive_lock_t lock; /* For user-levl locks */ 318 perl_cond user_cond; /* For user-level conditions */ 319 } user_lock; 320 321 /* Magic used for attaching user_lock structs to shared SVs 322 323 The vtable used has just one entry - when the SV goes away 324 we free the memory for the above. 325 */ 326 327 static int 328 sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg) 329 { 330 user_lock *ul = (user_lock *) mg->mg_ptr; 331 PERL_UNUSED_ARG(sv); 332 assert(aTHX == PL_sharedsv_space); 333 if (ul) { 334 recursive_lock_destroy(aTHX_ &ul->lock); 335 COND_DESTROY(&ul->user_cond); 336 PerlMemShared_free(ul); 337 mg->mg_ptr = NULL; 338 } 339 return (0); 340 } 341 342 static const MGVTBL sharedsv_userlock_vtbl = { 343 0, /* get */ 344 0, /* set */ 345 0, /* len */ 346 0, /* clear */ 347 sharedsv_userlock_free, /* free */ 348 0, /* copy */ 349 0, /* dup */ 350 #ifdef MGf_LOCAL 351 0, /* local */ 352 #endif 353 }; 354 355 356 /* Support for dual-valued variables */ 357 #ifdef SVf_IVisUV 358 # define DUALVAR_FLAGS(sv) \ 359 ((SvPOK(sv)) \ 360 ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \ 361 : ((SvIsUV(sv)) ? (SVf_IOK | SVf_IVisUV) \ 362 : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0))) \ 363 : 0) 364 #else 365 # define DUALVAR_FLAGS(sv) \ 366 ((SvPOK(sv)) \ 367 ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \ 368 : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0)) \ 369 : 0) 370 #endif 371 372 373 /* 374 * Access to shared things is heavily based on MAGIC 375 * - in mg.h/mg.c/sv.c sense 376 */ 377 378 /* In any thread that has access to a shared thing there is a "proxy" 379 for it in its own space which has 'MAGIC' associated which accesses 380 the shared thing. 381 */ 382 383 extern const MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */ 384 extern const MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this 385 - like 'tie' */ 386 extern const MGVTBL sharedsv_elem_vtbl; /* Elements of hashes and arrays have 387 this _AS WELL AS_ the scalar magic: 388 The sharedsv_elem_vtbl associates the element with the array/hash and 389 the sharedsv_scalar_vtbl associates it with the value 390 */ 391 392 393 /* Get shared aggregate SV pointed to by threads::shared::tie magic object */ 394 395 #define SHAREDSV_FROM_OBJ(sv) ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL) 396 397 398 /* Return the user_lock structure (if any) associated with a shared SV. 399 * If create is true, create one if it doesn't exist 400 */ 401 STATIC user_lock * 402 S_get_userlock(pTHX_ SV* ssv, bool create) 403 { 404 MAGIC *mg; 405 user_lock *ul = NULL; 406 407 assert(ssv); 408 /* XXX Redesign the storage of user locks so we don't need a global 409 * lock to access them ???? DAPM */ 410 ENTER_LOCK; 411 412 /* Version of mg_find that also checks the private signature */ 413 for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) { 414 if ((mg->mg_type == PERL_MAGIC_ext) && 415 (mg->mg_private == UL_MAGIC_SIG)) 416 { 417 break; 418 } 419 } 420 421 if (mg) { 422 ul = (user_lock*)(mg->mg_ptr); 423 } else if (create) { 424 dTHXc; 425 SHARED_CONTEXT; 426 ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock)); 427 Zero(ul, 1, user_lock); 428 /* Attach to shared SV using ext magic */ 429 mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl, 430 (char *)ul, 0); 431 mg->mg_private = UL_MAGIC_SIG; /* Set private signature */ 432 recursive_lock_init(aTHX_ &ul->lock); 433 COND_INIT(&ul->user_cond); 434 CALLER_CONTEXT; 435 } 436 LEAVE_LOCK; 437 return (ul); 438 } 439 440 441 /* Given a private side SV tries to find if the SV has a shared backend, 442 * by looking for the magic. 443 */ 444 static SV * 445 Perl_sharedsv_find(pTHX_ SV *sv) 446 { 447 MAGIC *mg; 448 if (SvTYPE(sv) >= SVt_PVMG) { 449 switch(SvTYPE(sv)) { 450 case SVt_PVAV: 451 case SVt_PVHV: 452 if ((mg = mg_find(sv, PERL_MAGIC_tied)) 453 && mg->mg_virtual == &sharedsv_array_vtbl) { 454 return ((SV *)mg->mg_ptr); 455 } 456 break; 457 default: 458 /* This should work for elements as well as they 459 * have scalar magic as well as their element magic 460 */ 461 if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar)) 462 && mg->mg_virtual == &sharedsv_scalar_vtbl) { 463 return ((SV *)mg->mg_ptr); 464 } 465 break; 466 } 467 } 468 /* Just for tidyness of API also handle tie objects */ 469 if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) { 470 return (SHAREDSV_FROM_OBJ(sv)); 471 } 472 return (NULL); 473 } 474 475 476 /* Associate a private SV with a shared SV by pointing the appropriate 477 * magics at it. 478 * Assumes lock is held. 479 */ 480 static void 481 Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv) 482 { 483 MAGIC *mg = 0; 484 485 /* If we are asked for any private ops we need a thread */ 486 assert ( aTHX != PL_sharedsv_space ); 487 488 /* To avoid need for recursive locks require caller to hold lock */ 489 assert ( PL_sharedsv_lock.owner == aTHX ); 490 491 switch(SvTYPE(sv)) { 492 case SVt_PVAV: 493 case SVt_PVHV: 494 if (!(mg = mg_find(sv, PERL_MAGIC_tied)) 495 || mg->mg_virtual != &sharedsv_array_vtbl 496 || (SV*) mg->mg_ptr != ssv) 497 { 498 SV *obj = newSV(0); 499 sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv)); 500 if (mg) { 501 sv_unmagic(sv, PERL_MAGIC_tied); 502 } 503 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl, 504 (char *)ssv, 0); 505 mg->mg_flags |= (MGf_COPY|MGf_DUP); 506 SvREFCNT_inc_void(ssv); 507 SvREFCNT_dec(obj); 508 } 509 break; 510 511 default: 512 if ((SvTYPE(sv) < SVt_PVMG) 513 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) 514 || mg->mg_virtual != &sharedsv_scalar_vtbl 515 || (SV*) mg->mg_ptr != ssv) 516 { 517 if (mg) { 518 sv_unmagic(sv, PERL_MAGIC_shared_scalar); 519 } 520 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, 521 &sharedsv_scalar_vtbl, (char *)ssv, 0); 522 mg->mg_flags |= (MGf_DUP 523 #ifdef MGf_LOCAL 524 |MGf_LOCAL 525 #endif 526 ); 527 SvREFCNT_inc_void(ssv); 528 } 529 break; 530 } 531 532 assert ( Perl_sharedsv_find(aTHX_ sv) == ssv ); 533 } 534 535 536 /* Given a private SV, create and return an associated shared SV. 537 * Assumes lock is held. 538 */ 539 STATIC SV * 540 S_sharedsv_new_shared(pTHX_ SV *sv) 541 { 542 dTHXc; 543 SV *ssv; 544 545 assert(PL_sharedsv_lock.owner == aTHX); 546 assert(aTHX != PL_sharedsv_space); 547 548 SHARED_CONTEXT; 549 ssv = newSV(0); 550 SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */ 551 sv_upgrade(ssv, SvTYPE(sv)); 552 CALLER_CONTEXT; 553 Perl_sharedsv_associate(aTHX_ sv, ssv); 554 return (ssv); 555 } 556 557 558 /* Given a shared SV, create and return an associated private SV. 559 * Assumes lock is held. 560 */ 561 STATIC SV * 562 S_sharedsv_new_private(pTHX_ SV *ssv) 563 { 564 SV *sv; 565 566 assert(PL_sharedsv_lock.owner == aTHX); 567 assert(aTHX != PL_sharedsv_space); 568 569 sv = newSV(0); 570 sv_upgrade(sv, SvTYPE(ssv)); 571 Perl_sharedsv_associate(aTHX_ sv, ssv); 572 return (sv); 573 } 574 575 576 /* A threadsafe version of SvREFCNT_dec(ssv) */ 577 578 STATIC void 579 S_sharedsv_dec(pTHX_ SV* ssv) 580 { 581 if (! ssv) 582 return; 583 ENTER_LOCK; 584 if (SvREFCNT(ssv) > 1) { 585 /* No side effects, so can do it lightweight */ 586 SvREFCNT_dec(ssv); 587 } else { 588 dTHXc; 589 SHARED_CONTEXT; 590 SvREFCNT_dec(ssv); 591 CALLER_CONTEXT; 592 } 593 LEAVE_LOCK; 594 } 595 596 597 /* Implements Perl-level share() and :shared */ 598 599 static void 600 Perl_sharedsv_share(pTHX_ SV *sv) 601 { 602 switch(SvTYPE(sv)) { 603 case SVt_PVGV: 604 Perl_croak(aTHX_ "Cannot share globs yet"); 605 break; 606 607 case SVt_PVCV: 608 Perl_croak(aTHX_ "Cannot share subs yet"); 609 break; 610 611 default: 612 ENTER_LOCK; 613 (void) S_sharedsv_new_shared(aTHX_ sv); 614 LEAVE_LOCK; 615 SvSETMAGIC(sv); 616 break; 617 } 618 } 619 620 621 #ifdef WIN32 622 /* Number of milliseconds from 1/1/1601 to 1/1/1970 */ 623 #define EPOCH_BIAS 11644473600000. 624 625 /* Returns relative time in milliseconds. (Adapted from Time::HiRes.) */ 626 STATIC DWORD 627 S_abs_2_rel_milli(double abs) 628 { 629 double rel; 630 631 /* Get current time (in units of 100 nanoseconds since 1/1/1601) */ 632 union { 633 FILETIME ft; 634 __int64 i64; /* 'signed' to keep compilers happy */ 635 } now; 636 637 GetSystemTimeAsFileTime(&now.ft); 638 639 /* Relative time in milliseconds */ 640 rel = (abs * 1000.) - (((double)now.i64 / 10000.) - EPOCH_BIAS); 641 if (rel <= 0.0) { 642 return (0); 643 } 644 return (DWORD)rel; 645 } 646 647 #else 648 # if defined(OS2) 649 # define ABS2RELMILLI(abs) \ 650 do { \ 651 abs -= (double)time(NULL); \ 652 if (abs > 0) { abs *= 1000; } \ 653 else { abs = 0; } \ 654 } while (0) 655 # endif /* OS2 */ 656 #endif /* WIN32 */ 657 658 /* Do OS-specific condition timed wait */ 659 660 static bool 661 Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) 662 { 663 #if defined(NETWARE) || defined(I_MACH_CTHREADS) 664 Perl_croak_nocontext("cond_timedwait not supported on this platform"); 665 #else 666 # ifdef WIN32 667 int got_it = 0; 668 669 cond->waiters++; 670 MUTEX_UNLOCK(mut); 671 /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */ 672 switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) { 673 case WAIT_OBJECT_0: got_it = 1; break; 674 case WAIT_TIMEOUT: break; 675 default: 676 /* WAIT_FAILED? WAIT_ABANDONED? others? */ 677 Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError()); 678 break; 679 } 680 MUTEX_LOCK(mut); 681 cond->waiters--; 682 return (got_it); 683 # else 684 # ifdef OS2 685 int rc, got_it = 0; 686 STRLEN n_a; 687 688 ABS2RELMILLI(abs); 689 690 if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET)) 691 Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset"); 692 MUTEX_UNLOCK(mut); 693 if (CheckOSError(DosWaitEventSem(*cond,abs)) 694 && (rc != ERROR_INTERRUPT)) 695 croak_with_os2error("panic: cond_timedwait"); 696 if (rc == ERROR_INTERRUPT) errno = EINTR; 697 MUTEX_LOCK(mut); 698 return (got_it); 699 # else /* Hope you're I_PTHREAD! */ 700 struct timespec ts; 701 int got_it = 0; 702 703 ts.tv_sec = (long)abs; 704 abs -= (NV)ts.tv_sec; 705 ts.tv_nsec = (long)(abs * 1000000000.0); 706 707 CLANG_DIAG_IGNORE_STMT(-Wthread-safety); 708 /* warning: calling function 'pthread_cond_timedwait' requires holding mutex 'mut' exclusively [-Wthread-safety-analysis] */ 709 switch (pthread_cond_timedwait(cond, mut, &ts)) { 710 CLANG_DIAG_RESTORE_STMT; 711 712 case 0: got_it = 1; break; 713 case ETIMEDOUT: break; 714 #ifdef OEMVS 715 case -1: 716 if (errno == ETIMEDOUT || errno == EAGAIN) 717 break; 718 #endif 719 default: 720 Perl_croak_nocontext("panic: cond_timedwait"); 721 break; 722 } 723 return (got_it); 724 # endif /* OS2 */ 725 # endif /* WIN32 */ 726 #endif /* NETWARE || I_MACH_CTHREADS */ 727 } 728 729 730 /* Given a thingy referenced by a shared RV, copy it's value to a private 731 * RV, also copying the object status of the referent. 732 * If the private side is already an appropriate RV->SV combination, keep 733 * it if possible. 734 */ 735 STATIC void 736 S_get_RV(pTHX_ SV *sv, SV *sobj) { 737 SV *obj; 738 if (! (SvROK(sv) && 739 ((obj = SvRV(sv))) && 740 (Perl_sharedsv_find(aTHX_ obj) == sobj) && 741 (SvTYPE(obj) == SvTYPE(sobj)))) 742 { 743 /* Can't reuse obj */ 744 if (SvROK(sv)) { 745 SvREFCNT_dec(SvRV(sv)); 746 } else { 747 assert(SvTYPE(sv) >= SVt_RV); 748 sv_setsv_nomg(sv, &PL_sv_undef); 749 SvROK_on(sv); 750 } 751 obj = S_sharedsv_new_private(aTHX_ sobj); 752 SvRV_set(sv, obj); 753 } 754 755 if (SvOBJECT(obj)) { 756 /* Remove any old blessing */ 757 SvREFCNT_dec(SvSTASH(obj)); 758 SvOBJECT_off(obj); 759 } 760 if (SvOBJECT(sobj)) { 761 /* Add any new old blessing */ 762 STRLEN len; 763 char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len); 764 HV* stash = gv_stashpvn(stash_ptr, len, TRUE); 765 SvOBJECT_on(obj); 766 SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash)); 767 } 768 } 769 770 /* Every caller of S_get_RV needs this incantation (which cannot go inside 771 S_get_RV itself, as we do not want recursion beyond one level): */ 772 #define get_RV(sv, sobj) \ 773 S_get_RV(aTHX_ sv, sobj); \ 774 /* Look ahead for refs of refs */ \ 775 if (SvROK(sobj)) { \ 776 SvROK_on(SvRV(sv)); \ 777 S_get_RV(aTHX_ SvRV(sv), SvRV(sobj)); \ 778 } 779 780 781 /* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */ 782 783 /* Get magic for PERL_MAGIC_shared_scalar(n) */ 784 785 static int 786 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) 787 { 788 SV *ssv = (SV *) mg->mg_ptr; 789 assert(ssv); 790 791 ENTER_LOCK; 792 if (SvROK(ssv)) { 793 get_RV(sv, SvRV(ssv)); 794 } else { 795 sv_setsv_nomg(sv, ssv); 796 } 797 LEAVE_LOCK; 798 return (0); 799 } 800 801 /* Copy the contents of a private SV to a shared SV. 802 * Used by various mg_set()-type functions. 803 * Assumes lock is held. 804 */ 805 static void 806 sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) 807 { 808 dTHXc; 809 bool allowed = TRUE; 810 811 assert(PL_sharedsv_lock.owner == aTHX); 812 if (!PL_dirty && SvROK(ssv) && SvREFCNT(SvRV(ssv)) == 1) { 813 SV *sv = sv_newmortal(); 814 sv_upgrade(sv, SVt_RV); 815 get_RV(sv, SvRV(ssv)); 816 } 817 if (SvROK(sv)) { 818 SV *obj = SvRV(sv); 819 SV *sobj = Perl_sharedsv_find(aTHX_ obj); 820 if (sobj) { 821 SV* tmpref; 822 SHARED_CONTEXT; 823 /* Creating a tmp ref to sobj then assigning it to ssv ensures 824 * that any previous contents of ssv are correctly freed 825 * by sv_setsv(). Not sure if there is a better, API-legal way 826 * to achieve this */ 827 tmpref = newRV_inc(sobj); 828 sv_setsv_nomg(ssv, tmpref); 829 SvREFCNT_dec_NN(tmpref); 830 831 if (SvOBJECT(sobj)) { 832 /* Remove any old blessing */ 833 SvREFCNT_dec(SvSTASH(sobj)); 834 SvOBJECT_off(sobj); 835 } 836 if (SvOBJECT(obj)) { 837 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0); 838 SvOBJECT_on(sobj); 839 SvSTASH_set(sobj, (HV*)fake_stash); 840 } 841 CALLER_CONTEXT; 842 } else { 843 allowed = FALSE; 844 } 845 } else { 846 SvTEMP_off(sv); 847 SHARED_CONTEXT; 848 sv_setsv_nomg(ssv, sv); 849 if (SvOBJECT(ssv)) { 850 /* Remove any old blessing */ 851 SvREFCNT_dec(SvSTASH(ssv)); 852 SvOBJECT_off(ssv); 853 } 854 if (SvOBJECT(sv)) { 855 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); 856 SvOBJECT_on(ssv); 857 SvSTASH_set(ssv, (HV*)fake_stash); 858 } 859 CALLER_CONTEXT; 860 } 861 if (!allowed) { 862 Perl_croak(aTHX_ "Invalid value for shared scalar"); 863 } 864 } 865 866 /* Set magic for PERL_MAGIC_shared_scalar(n) */ 867 868 static int 869 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) 870 { 871 SV *ssv = (SV*)(mg->mg_ptr); 872 assert(ssv); 873 ENTER_LOCK; 874 if (SvTYPE(ssv) < SvTYPE(sv)) { 875 dTHXc; 876 SHARED_CONTEXT; 877 sv_upgrade(ssv, SvTYPE(sv)); 878 CALLER_CONTEXT; 879 } 880 sharedsv_scalar_store(aTHX_ sv, ssv); 881 LEAVE_LOCK; 882 return (0); 883 } 884 885 /* Free magic for PERL_MAGIC_shared_scalar(n) */ 886 887 static int 888 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) 889 { 890 PERL_UNUSED_ARG(sv); 891 ENTER_LOCK; 892 if (!PL_dirty 893 && SvROK((SV *)mg->mg_ptr) && SvREFCNT(SvRV((SV *)mg->mg_ptr)) == 1) { 894 SV *sv = sv_newmortal(); 895 sv_upgrade(sv, SVt_RV); 896 get_RV(sv, SvRV((SV *)mg->mg_ptr)); 897 } 898 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); 899 LEAVE_LOCK; 900 return (0); 901 } 902 903 /* 904 * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread 905 */ 906 static int 907 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) 908 { 909 PERL_UNUSED_ARG(param); 910 SvREFCNT_inc_void(mg->mg_ptr); 911 return (0); 912 } 913 914 #ifdef MGf_LOCAL 915 /* 916 * Called during local $shared 917 */ 918 static int 919 sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg) 920 { 921 MAGIC *nmg; 922 SV *ssv = (SV *) mg->mg_ptr; 923 if (ssv) { 924 ENTER_LOCK; 925 SvREFCNT_inc_void(ssv); 926 LEAVE_LOCK; 927 } 928 nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual, 929 mg->mg_ptr, mg->mg_len); 930 nmg->mg_flags = mg->mg_flags; 931 nmg->mg_private = mg->mg_private; 932 933 return (0); 934 } 935 #endif 936 937 const MGVTBL sharedsv_scalar_vtbl = { 938 sharedsv_scalar_mg_get, /* get */ 939 sharedsv_scalar_mg_set, /* set */ 940 0, /* len */ 941 0, /* clear */ 942 sharedsv_scalar_mg_free, /* free */ 943 0, /* copy */ 944 sharedsv_scalar_mg_dup, /* dup */ 945 #ifdef MGf_LOCAL 946 sharedsv_scalar_mg_local, /* local */ 947 #endif 948 }; 949 950 /* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */ 951 952 /* Get magic for PERL_MAGIC_tiedelem(p) */ 953 954 static int 955 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) 956 { 957 dTHXc; 958 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); 959 SV** svp = NULL; 960 961 ENTER_LOCK; 962 if (saggregate) { /* During global destruction, underlying 963 aggregate may no longer exist */ 964 if (SvTYPE(saggregate) == SVt_PVAV) { 965 assert ( mg->mg_ptr == 0 ); 966 SHARED_CONTEXT; 967 svp = av_fetch((AV*) saggregate, mg->mg_len, 0); 968 } else { 969 char *key = mg->mg_ptr; 970 I32 len = mg->mg_len; 971 assert ( mg->mg_ptr != 0 ); 972 if (mg->mg_len == HEf_SVKEY) { 973 STRLEN slen; 974 key = SvPV((SV *)mg->mg_ptr, slen); 975 len = slen; 976 if (SvUTF8((SV *)mg->mg_ptr)) { 977 len = -len; 978 } 979 } 980 SHARED_CONTEXT; 981 svp = hv_fetch((HV*) saggregate, key, len, 0); 982 } 983 CALLER_CONTEXT; 984 } 985 if (svp) { 986 /* Exists in the array */ 987 if (SvROK(*svp)) { 988 get_RV(sv, SvRV(*svp)); 989 } else { 990 /* $ary->[elem] or $ary->{elem} is a scalar */ 991 Perl_sharedsv_associate(aTHX_ sv, *svp); 992 sv_setsv(sv, *svp); 993 } 994 } else { 995 /* Not in the array */ 996 sv_setsv(sv, &PL_sv_undef); 997 } 998 LEAVE_LOCK; 999 return (0); 1000 } 1001 1002 /* Set magic for PERL_MAGIC_tiedelem(p) */ 1003 1004 static int 1005 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) 1006 { 1007 dTHXc; 1008 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); 1009 SV **svp; 1010 U32 dualvar_flags = DUALVAR_FLAGS(sv); 1011 1012 /* Theory - SV itself is magically shared - and we have ordered the 1013 magic such that by the time we get here it has been stored 1014 to its shared counterpart 1015 */ 1016 ENTER_LOCK; 1017 assert(saggregate); 1018 if (SvTYPE(saggregate) == SVt_PVAV) { 1019 assert ( mg->mg_ptr == 0 ); 1020 SHARED_CONTEXT; 1021 svp = av_fetch((AV*) saggregate, mg->mg_len, 1); 1022 } else { 1023 char *key = mg->mg_ptr; 1024 I32 len = mg->mg_len; 1025 assert ( mg->mg_ptr != 0 ); 1026 if (mg->mg_len == HEf_SVKEY) { 1027 STRLEN slen; 1028 key = SvPV((SV *)mg->mg_ptr, slen); 1029 len = slen; 1030 if (SvUTF8((SV *)mg->mg_ptr)) { 1031 len = -len; 1032 } 1033 } 1034 SHARED_CONTEXT; 1035 svp = hv_fetch((HV*) saggregate, key, len, 1); 1036 } 1037 CALLER_CONTEXT; 1038 Perl_sharedsv_associate(aTHX_ sv, *svp); 1039 sharedsv_scalar_store(aTHX_ sv, *svp); 1040 SvFLAGS(*svp) |= dualvar_flags; 1041 LEAVE_LOCK; 1042 return (0); 1043 } 1044 1045 /* Clear magic for PERL_MAGIC_tiedelem(p) */ 1046 1047 static int 1048 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) 1049 { 1050 dTHXc; 1051 MAGIC *shmg; 1052 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); 1053 1054 /* Object may not exist during global destruction */ 1055 if (! saggregate) { 1056 return (0); 1057 } 1058 1059 ENTER_LOCK; 1060 sharedsv_elem_mg_FETCH(aTHX_ sv, mg); 1061 if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) 1062 sharedsv_scalar_mg_get(aTHX_ sv, shmg); 1063 if (SvTYPE(saggregate) == SVt_PVAV) { 1064 SHARED_CONTEXT; 1065 av_delete((AV*) saggregate, mg->mg_len, G_DISCARD); 1066 } else { 1067 char *key = mg->mg_ptr; 1068 I32 len = mg->mg_len; 1069 assert ( mg->mg_ptr != 0 ); 1070 if (mg->mg_len == HEf_SVKEY) { 1071 STRLEN slen; 1072 key = SvPV((SV *)mg->mg_ptr, slen); 1073 len = slen; 1074 if (SvUTF8((SV *)mg->mg_ptr)) { 1075 len = -len; 1076 } 1077 } 1078 SHARED_CONTEXT; 1079 (void) hv_delete((HV*) saggregate, key, len, G_DISCARD); 1080 } 1081 CALLER_CONTEXT; 1082 LEAVE_LOCK; 1083 return (0); 1084 } 1085 1086 /* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new 1087 * thread */ 1088 1089 static int 1090 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) 1091 { 1092 PERL_UNUSED_ARG(param); 1093 SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj)); 1094 assert(mg->mg_flags & MGf_DUP); 1095 return (0); 1096 } 1097 1098 const MGVTBL sharedsv_elem_vtbl = { 1099 sharedsv_elem_mg_FETCH, /* get */ 1100 sharedsv_elem_mg_STORE, /* set */ 1101 0, /* len */ 1102 sharedsv_elem_mg_DELETE, /* clear */ 1103 0, /* free */ 1104 0, /* copy */ 1105 sharedsv_elem_mg_dup, /* dup */ 1106 #ifdef MGf_LOCAL 1107 0, /* local */ 1108 #endif 1109 }; 1110 1111 /* ------------ PERL_MAGIC_tied(P) functions -------------- */ 1112 1113 /* Len magic for PERL_MAGIC_tied(P) */ 1114 1115 static U32 1116 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) 1117 { 1118 dTHXc; 1119 SV *ssv = (SV *) mg->mg_ptr; 1120 U32 val; 1121 PERL_UNUSED_ARG(sv); 1122 SHARED_EDIT; 1123 if (SvTYPE(ssv) == SVt_PVAV) { 1124 val = av_len((AV*) ssv); 1125 } else { 1126 /* Not actually defined by tie API but ... */ 1127 val = HvUSEDKEYS((HV*) ssv); 1128 } 1129 SHARED_RELEASE; 1130 return (val); 1131 } 1132 1133 /* Clear magic for PERL_MAGIC_tied(P) */ 1134 1135 static int 1136 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) 1137 { 1138 dTHXc; 1139 SV *ssv = (SV *) mg->mg_ptr; 1140 const bool isav = SvTYPE(ssv) == SVt_PVAV; 1141 PERL_UNUSED_ARG(sv); 1142 SHARED_EDIT; 1143 if (!PL_dirty) { 1144 SV **svp = isav ? AvARRAY((AV *)ssv) : NULL; 1145 I32 items = isav ? AvFILLp((AV *)ssv) + 1 : 0; 1146 HE *iter; 1147 if (!isav) hv_iterinit((HV *)ssv); 1148 while (isav ? items-- : !!(iter = hv_iternext((HV *)ssv))) { 1149 SV *sv = isav ? *svp++ : HeVAL(iter); 1150 if (!sv) continue; 1151 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) 1152 && SvREFCNT(sv) == 1 ) { 1153 SV *tmp; 1154 PERL_SET_CONTEXT((aTHX = caller_perl)); 1155 tmp = sv_newmortal(); 1156 sv_upgrade(tmp, SVt_RV); 1157 get_RV(tmp, sv); 1158 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); 1159 } 1160 } 1161 } 1162 if (isav) av_clear((AV*) ssv); 1163 else hv_clear((HV*) ssv); 1164 SHARED_RELEASE; 1165 return (0); 1166 } 1167 1168 /* Free magic for PERL_MAGIC_tied(P) */ 1169 1170 static int 1171 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) 1172 { 1173 PERL_UNUSED_ARG(sv); 1174 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); 1175 return (0); 1176 } 1177 1178 /* 1179 * Copy magic for PERL_MAGIC_tied(P) 1180 * This is called when perl is about to access an element of 1181 * the array - 1182 */ 1183 #if PERL_VERSION_GE(5,11,0) 1184 static int 1185 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, 1186 SV *nsv, const char *name, I32 namlen) 1187 #else 1188 static int 1189 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, 1190 SV *nsv, const char *name, int namlen) 1191 #endif 1192 { 1193 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, 1194 toLOWER(mg->mg_type),&sharedsv_elem_vtbl, 1195 name, namlen); 1196 PERL_UNUSED_ARG(sv); 1197 nmg->mg_flags |= MGf_DUP; 1198 return (1); 1199 } 1200 1201 /* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */ 1202 1203 static int 1204 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) 1205 { 1206 PERL_UNUSED_ARG(param); 1207 SvREFCNT_inc_void((SV*)mg->mg_ptr); 1208 assert(mg->mg_flags & MGf_DUP); 1209 return (0); 1210 } 1211 1212 const MGVTBL sharedsv_array_vtbl = { 1213 0, /* get */ 1214 0, /* set */ 1215 sharedsv_array_mg_FETCHSIZE,/* len */ 1216 sharedsv_array_mg_CLEAR, /* clear */ 1217 sharedsv_array_mg_free, /* free */ 1218 sharedsv_array_mg_copy, /* copy */ 1219 sharedsv_array_mg_dup, /* dup */ 1220 #ifdef MGf_LOCAL 1221 0, /* local */ 1222 #endif 1223 }; 1224 1225 1226 /* Recursive locks on a sharedsv. 1227 * Locks are dynamically scoped at the level of the first lock. 1228 */ 1229 static void 1230 Perl_sharedsv_lock(pTHX_ SV *ssv) 1231 { 1232 user_lock *ul; 1233 if (! ssv) 1234 return; 1235 ul = S_get_userlock(aTHX_ ssv, 1); 1236 recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__); 1237 } 1238 1239 /* Handles calls from lock() builtin via PL_lockhook */ 1240 1241 static void 1242 Perl_sharedsv_locksv(pTHX_ SV *sv) 1243 { 1244 SV *ssv; 1245 1246 if (SvROK(sv)) 1247 sv = SvRV(sv); 1248 ssv = Perl_sharedsv_find(aTHX_ sv); 1249 if (!ssv) 1250 croak("lock can only be used on shared values"); 1251 Perl_sharedsv_lock(aTHX_ ssv); 1252 } 1253 1254 1255 /* Can a shared object be destroyed? 1256 * True if not a shared, 1257 * or if destroying last proxy on a shared object 1258 */ 1259 #ifdef PL_destroyhook 1260 static bool 1261 Perl_shared_object_destroy(pTHX_ SV *sv) 1262 { 1263 SV *ssv; 1264 1265 if (SvROK(sv)) 1266 sv = SvRV(sv); 1267 ssv = Perl_sharedsv_find(aTHX_ sv); 1268 return (!ssv || (SvREFCNT(ssv) <= 1)); 1269 } 1270 #endif 1271 1272 /* veto signal dispatch if we have the lock */ 1273 1274 #ifdef PL_signalhook 1275 1276 STATIC despatch_signals_proc_t prev_signal_hook = NULL; 1277 1278 STATIC void 1279 S_shared_signal_hook(pTHX) { 1280 int us; 1281 MUTEX_LOCK(&PL_sharedsv_lock.mutex); 1282 us = (PL_sharedsv_lock.owner == aTHX); 1283 MUTEX_UNLOCK(&PL_sharedsv_lock.mutex); 1284 if (us) 1285 return; /* try again later */ 1286 prev_signal_hook(aTHX); 1287 } 1288 #endif 1289 1290 /* Saves a space for keeping SVs wider than an interpreter. */ 1291 1292 static void 1293 Perl_sharedsv_init(pTHX) 1294 { 1295 dTHXc; 1296 if (!PL_sharedsv_space) { 1297 PL_sharedsv_space = perl_alloc(); 1298 perl_construct(PL_sharedsv_space); 1299 /* The pair above leaves us in shared context (what dTHX would get), 1300 * but aTHX still points to caller context */ 1301 aTHX = PL_sharedsv_space; 1302 LEAVE; /* This balances the ENTER at the end of perl_construct. */ 1303 PERL_SET_CONTEXT((aTHX = caller_perl)); 1304 recursive_lock_init(aTHX_ &PL_sharedsv_lock); 1305 } 1306 PL_lockhook = &Perl_sharedsv_locksv; 1307 PL_sharehook = &Perl_sharedsv_share; 1308 #ifdef PL_destroyhook 1309 PL_destroyhook = &Perl_shared_object_destroy; 1310 #endif 1311 #ifdef PL_signalhook 1312 if (!prev_signal_hook) { 1313 prev_signal_hook = PL_signalhook; 1314 PL_signalhook = &S_shared_signal_hook; 1315 } 1316 #endif 1317 } 1318 1319 #endif /* USE_ITHREADS */ 1320 1321 MODULE = threads::shared PACKAGE = threads::shared::tie 1322 1323 PROTOTYPES: DISABLE 1324 1325 #ifdef USE_ITHREADS 1326 1327 void 1328 PUSH(SV *obj, ...) 1329 CODE: 1330 dTHXc; 1331 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1332 int ii; 1333 for (ii = 1; ii < items; ii++) { 1334 SV* tmp = newSVsv(ST(ii)); 1335 SV *stmp; 1336 U32 dualvar_flags = DUALVAR_FLAGS(tmp); 1337 ENTER_LOCK; 1338 stmp = S_sharedsv_new_shared(aTHX_ tmp); 1339 sharedsv_scalar_store(aTHX_ tmp, stmp); 1340 SvFLAGS(stmp) |= dualvar_flags; 1341 SHARED_CONTEXT; 1342 av_push((AV*) sobj, stmp); 1343 SvREFCNT_inc_void(stmp); 1344 SHARED_RELEASE; 1345 SvREFCNT_dec(tmp); 1346 } 1347 1348 1349 void 1350 UNSHIFT(SV *obj, ...) 1351 CODE: 1352 dTHXc; 1353 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1354 int ii; 1355 ENTER_LOCK; 1356 SHARED_CONTEXT; 1357 av_unshift((AV*)sobj, items - 1); 1358 CALLER_CONTEXT; 1359 for (ii = 1; ii < items; ii++) { 1360 SV *tmp = newSVsv(ST(ii)); 1361 U32 dualvar_flags = DUALVAR_FLAGS(tmp); 1362 SV *stmp = S_sharedsv_new_shared(aTHX_ tmp); 1363 sharedsv_scalar_store(aTHX_ tmp, stmp); 1364 SHARED_CONTEXT; 1365 SvFLAGS(stmp) |= dualvar_flags; 1366 av_store((AV*) sobj, ii - 1, stmp); 1367 SvREFCNT_inc_void(stmp); 1368 CALLER_CONTEXT; 1369 SvREFCNT_dec(tmp); 1370 } 1371 LEAVE_LOCK; 1372 1373 1374 void 1375 POP(SV *obj) 1376 CODE: 1377 dTHXc; 1378 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1379 SV* ssv; 1380 ENTER_LOCK; 1381 SHARED_CONTEXT; 1382 ssv = av_pop((AV*)sobj); 1383 CALLER_CONTEXT; 1384 ST(0) = sv_newmortal(); 1385 Perl_sharedsv_associate(aTHX_ ST(0), ssv); 1386 SvREFCNT_dec(ssv); 1387 LEAVE_LOCK; 1388 /* XSRETURN(1); - implied */ 1389 1390 1391 void 1392 SHIFT(SV *obj) 1393 CODE: 1394 dTHXc; 1395 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1396 SV* ssv; 1397 ENTER_LOCK; 1398 SHARED_CONTEXT; 1399 ssv = av_shift((AV*)sobj); 1400 CALLER_CONTEXT; 1401 ST(0) = sv_newmortal(); 1402 Perl_sharedsv_associate(aTHX_ ST(0), ssv); 1403 SvREFCNT_dec(ssv); 1404 LEAVE_LOCK; 1405 /* XSRETURN(1); - implied */ 1406 1407 1408 void 1409 EXTEND(SV *obj, IV count) 1410 CODE: 1411 dTHXc; 1412 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1413 SHARED_EDIT; 1414 av_extend((AV*)sobj, count); 1415 SHARED_RELEASE; 1416 1417 1418 void 1419 STORESIZE(SV *obj,IV count) 1420 CODE: 1421 dTHXc; 1422 SV *ssv = SHAREDSV_FROM_OBJ(obj); 1423 1424 SHARED_EDIT; 1425 assert(SvTYPE(ssv) == SVt_PVAV); 1426 if (!PL_dirty) { 1427 SV **svp = AvARRAY((AV *)ssv); 1428 I32 ix = AvFILLp((AV *)ssv); 1429 for (;ix >= count; ix--) { 1430 SV *sv = svp[ix]; 1431 if (!sv) 1432 continue; 1433 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) 1434 && SvREFCNT(sv) == 1 ) 1435 { 1436 SV *tmp; 1437 PERL_SET_CONTEXT((aTHX = caller_perl)); 1438 tmp = sv_newmortal(); 1439 sv_upgrade(tmp, SVt_RV); 1440 get_RV(tmp, sv); 1441 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); 1442 } 1443 } 1444 } 1445 av_fill((AV*) ssv, count - 1); 1446 SHARED_RELEASE; 1447 1448 1449 void 1450 EXISTS(SV *obj, SV *index) 1451 CODE: 1452 dTHXc; 1453 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1454 bool exists; 1455 if (SvTYPE(sobj) == SVt_PVAV) { 1456 SHARED_EDIT; 1457 exists = av_exists((AV*) sobj, SvIV(index)); 1458 } else { 1459 I32 len; 1460 STRLEN slen; 1461 char *key = SvPVutf8(index, slen); 1462 len = slen; 1463 if (SvUTF8(index)) { 1464 len = -len; 1465 } 1466 SHARED_EDIT; 1467 exists = hv_exists((HV*) sobj, key, len); 1468 } 1469 SHARED_RELEASE; 1470 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; 1471 /* XSRETURN(1); - implied */ 1472 1473 1474 void 1475 FIRSTKEY(SV *obj) 1476 CODE: 1477 dTHXc; 1478 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1479 char* key = NULL; 1480 I32 len = 0; 1481 HE* entry; 1482 ENTER_LOCK; 1483 SHARED_CONTEXT; 1484 hv_iterinit((HV*) sobj); 1485 entry = hv_iternext((HV*) sobj); 1486 if (entry) { 1487 I32 utf8 = HeKUTF8(entry); 1488 key = hv_iterkey(entry,&len); 1489 CALLER_CONTEXT; 1490 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0)); 1491 } else { 1492 CALLER_CONTEXT; 1493 ST(0) = &PL_sv_undef; 1494 } 1495 LEAVE_LOCK; 1496 /* XSRETURN(1); - implied */ 1497 1498 1499 void 1500 NEXTKEY(SV *obj, SV *oldkey) 1501 CODE: 1502 dTHXc; 1503 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1504 char* key = NULL; 1505 I32 len = 0; 1506 HE* entry; 1507 1508 PERL_UNUSED_VAR(oldkey); 1509 1510 ENTER_LOCK; 1511 SHARED_CONTEXT; 1512 entry = hv_iternext((HV*) sobj); 1513 if (entry) { 1514 I32 utf8 = HeKUTF8(entry); 1515 key = hv_iterkey(entry,&len); 1516 CALLER_CONTEXT; 1517 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0)); 1518 } else { 1519 CALLER_CONTEXT; 1520 ST(0) = &PL_sv_undef; 1521 } 1522 LEAVE_LOCK; 1523 /* XSRETURN(1); - implied */ 1524 1525 1526 MODULE = threads::shared PACKAGE = threads::shared 1527 1528 PROTOTYPES: ENABLE 1529 1530 void 1531 _id(SV *myref) 1532 PROTOTYPE: \[$@%] 1533 PREINIT: 1534 SV *ssv; 1535 CODE: 1536 myref = SvRV(myref); 1537 if (SvMAGICAL(myref)) 1538 mg_get(myref); 1539 if (SvROK(myref)) 1540 myref = SvRV(myref); 1541 ssv = Perl_sharedsv_find(aTHX_ myref); 1542 if (! ssv) 1543 XSRETURN_UNDEF; 1544 ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv))); 1545 /* XSRETURN(1); - implied */ 1546 1547 1548 void 1549 _refcnt(SV *myref) 1550 PROTOTYPE: \[$@%] 1551 PREINIT: 1552 SV *ssv; 1553 CODE: 1554 myref = SvRV(myref); 1555 if (SvROK(myref)) 1556 myref = SvRV(myref); 1557 ssv = Perl_sharedsv_find(aTHX_ myref); 1558 if (! ssv) { 1559 if (ckWARN(WARN_THREADS)) { 1560 Perl_warner(aTHX_ packWARN(WARN_THREADS), 1561 "%" SVf " is not shared", ST(0)); 1562 } 1563 XSRETURN_UNDEF; 1564 } 1565 ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv))); 1566 /* XSRETURN(1); - implied */ 1567 1568 1569 void 1570 share(SV *myref) 1571 PROTOTYPE: \[$@%] 1572 CODE: 1573 if (! SvROK(myref)) 1574 Perl_croak(aTHX_ "Argument to share needs to be passed as ref"); 1575 myref = SvRV(myref); 1576 if (SvROK(myref)) 1577 myref = SvRV(myref); 1578 Perl_sharedsv_share(aTHX_ myref); 1579 ST(0) = sv_2mortal(newRV_inc(myref)); 1580 /* XSRETURN(1); - implied */ 1581 1582 1583 void 1584 cond_wait(SV *ref_cond, SV *ref_lock = 0) 1585 PROTOTYPE: \[$@%];\[$@%] 1586 PREINIT: 1587 SV *ssv; 1588 perl_cond* user_condition; 1589 int locks; 1590 user_lock *ul; 1591 CODE: 1592 if (!SvROK(ref_cond)) 1593 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); 1594 ref_cond = SvRV(ref_cond); 1595 if (SvROK(ref_cond)) 1596 ref_cond = SvRV(ref_cond); 1597 ssv = Perl_sharedsv_find(aTHX_ ref_cond); 1598 if (! ssv) 1599 Perl_croak(aTHX_ "cond_wait can only be used on shared values"); 1600 ul = S_get_userlock(aTHX_ ssv, 1); 1601 1602 user_condition = &ul->user_cond; 1603 if (ref_lock && (ref_cond != ref_lock)) { 1604 if (!SvROK(ref_lock)) 1605 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); 1606 ref_lock = SvRV(ref_lock); 1607 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); 1608 ssv = Perl_sharedsv_find(aTHX_ ref_lock); 1609 if (! ssv) 1610 Perl_croak(aTHX_ "cond_wait lock must be a shared value"); 1611 ul = S_get_userlock(aTHX_ ssv, 1); 1612 } 1613 if (ul->lock.owner != aTHX) 1614 croak("You need a lock before you can cond_wait"); 1615 1616 /* Stealing the members of the lock object worries me - NI-S */ 1617 MUTEX_LOCK(&ul->lock.mutex); 1618 ul->lock.owner = NULL; 1619 locks = ul->lock.locks; 1620 ul->lock.locks = 0; 1621 1622 /* Since we are releasing the lock here, we need to tell other 1623 * people that it is ok to go ahead and use it */ 1624 COND_SIGNAL(&ul->lock.cond); 1625 COND_WAIT(user_condition, &ul->lock.mutex); 1626 while (ul->lock.owner != NULL) { 1627 /* OK -- must reacquire the lock */ 1628 COND_WAIT(&ul->lock.cond, &ul->lock.mutex); 1629 } 1630 ul->lock.owner = aTHX; 1631 ul->lock.locks = locks; 1632 MUTEX_UNLOCK(&ul->lock.mutex); 1633 1634 1635 int 1636 cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0) 1637 PROTOTYPE: \[$@%]$;\[$@%] 1638 PREINIT: 1639 SV *ssv; 1640 perl_cond* user_condition; 1641 int locks; 1642 user_lock *ul; 1643 CODE: 1644 if (! SvROK(ref_cond)) 1645 Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); 1646 ref_cond = SvRV(ref_cond); 1647 if (SvROK(ref_cond)) 1648 ref_cond = SvRV(ref_cond); 1649 ssv = Perl_sharedsv_find(aTHX_ ref_cond); 1650 if (! ssv) 1651 Perl_croak(aTHX_ "cond_timedwait can only be used on shared values"); 1652 ul = S_get_userlock(aTHX_ ssv, 1); 1653 1654 user_condition = &ul->user_cond; 1655 if (ref_lock && (ref_cond != ref_lock)) { 1656 if (! SvROK(ref_lock)) 1657 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); 1658 ref_lock = SvRV(ref_lock); 1659 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); 1660 ssv = Perl_sharedsv_find(aTHX_ ref_lock); 1661 if (! ssv) 1662 Perl_croak(aTHX_ "cond_timedwait lock must be a shared value"); 1663 ul = S_get_userlock(aTHX_ ssv, 1); 1664 } 1665 if (ul->lock.owner != aTHX) 1666 Perl_croak(aTHX_ "You need a lock before you can cond_wait"); 1667 1668 MUTEX_LOCK(&ul->lock.mutex); 1669 ul->lock.owner = NULL; 1670 locks = ul->lock.locks; 1671 ul->lock.locks = 0; 1672 /* Since we are releasing the lock here, we need to tell other 1673 * people that it is ok to go ahead and use it */ 1674 COND_SIGNAL(&ul->lock.cond); 1675 RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs); 1676 while (ul->lock.owner != NULL) { 1677 /* OK -- must reacquire the lock... */ 1678 COND_WAIT(&ul->lock.cond, &ul->lock.mutex); 1679 } 1680 ul->lock.owner = aTHX; 1681 ul->lock.locks = locks; 1682 MUTEX_UNLOCK(&ul->lock.mutex); 1683 1684 if (RETVAL == 0) 1685 XSRETURN_UNDEF; 1686 OUTPUT: 1687 RETVAL 1688 1689 1690 void 1691 cond_signal(SV *myref) 1692 PROTOTYPE: \[$@%] 1693 PREINIT: 1694 SV *ssv; 1695 user_lock *ul; 1696 CODE: 1697 if (! SvROK(myref)) 1698 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); 1699 myref = SvRV(myref); 1700 if (SvROK(myref)) 1701 myref = SvRV(myref); 1702 ssv = Perl_sharedsv_find(aTHX_ myref); 1703 if (! ssv) 1704 Perl_croak(aTHX_ "cond_signal can only be used on shared values"); 1705 ul = S_get_userlock(aTHX_ ssv, 1); 1706 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { 1707 Perl_warner(aTHX_ packWARN(WARN_THREADS), 1708 "cond_signal() called on unlocked variable"); 1709 } 1710 COND_SIGNAL(&ul->user_cond); 1711 1712 1713 void 1714 cond_broadcast(SV *myref) 1715 PROTOTYPE: \[$@%] 1716 PREINIT: 1717 SV *ssv; 1718 user_lock *ul; 1719 CODE: 1720 if (! SvROK(myref)) 1721 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); 1722 myref = SvRV(myref); 1723 if (SvROK(myref)) 1724 myref = SvRV(myref); 1725 ssv = Perl_sharedsv_find(aTHX_ myref); 1726 if (! ssv) 1727 Perl_croak(aTHX_ "cond_broadcast can only be used on shared values"); 1728 ul = S_get_userlock(aTHX_ ssv, 1); 1729 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { 1730 Perl_warner(aTHX_ packWARN(WARN_THREADS), 1731 "cond_broadcast() called on unlocked variable"); 1732 } 1733 COND_BROADCAST(&ul->user_cond); 1734 1735 1736 void 1737 bless(SV* myref, ...) 1738 PROTOTYPE: $;$ 1739 PREINIT: 1740 HV* stash; 1741 SV *ssv; 1742 CODE: 1743 if (items == 1) { 1744 stash = CopSTASH(PL_curcop); 1745 } else { 1746 SV* classname = ST(1); 1747 STRLEN len; 1748 char *ptr; 1749 1750 if (classname && 1751 ! SvGMAGICAL(classname) && 1752 ! SvAMAGIC(classname) && 1753 SvROK(classname)) 1754 { 1755 Perl_croak(aTHX_ "Attempt to bless into a reference"); 1756 } 1757 ptr = SvPV(classname, len); 1758 if (ckWARN(WARN_MISC) && len == 0) { 1759 Perl_warner(aTHX_ packWARN(WARN_MISC), 1760 "Explicit blessing to '' (assuming package main)"); 1761 } 1762 stash = gv_stashpvn(ptr, len, TRUE); 1763 } 1764 SvREFCNT_inc_void(myref); 1765 (void)sv_bless(myref, stash); 1766 ST(0) = sv_2mortal(myref); 1767 ssv = Perl_sharedsv_find(aTHX_ myref); 1768 if (ssv) { 1769 dTHXc; 1770 ENTER_LOCK; 1771 SHARED_CONTEXT; 1772 { 1773 SV* fake_stash = newSVpv(HvNAME_get(stash), 0); 1774 (void)sv_bless(ssv, (HV*)fake_stash); 1775 } 1776 CALLER_CONTEXT; 1777 LEAVE_LOCK; 1778 } 1779 /* XSRETURN(1); - implied */ 1780 1781 #endif /* USE_ITHREADS */ 1782 1783 BOOT: 1784 { 1785 #ifdef USE_ITHREADS 1786 Perl_sharedsv_init(aTHX); 1787 #endif /* USE_ITHREADS */ 1788 } 1789