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