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 = newSV_type(SVt_RV); 828 SvRV_set(tmpref, sobj); 829 SvROK_on(tmpref); 830 SvREFCNT_inc_simple_NN(sobj); 831 sv_setsv_nomg(ssv, tmpref); 832 SvREFCNT_dec_NN(tmpref); 833 834 if (SvOBJECT(sobj)) { 835 /* Remove any old blessing */ 836 SvREFCNT_dec(SvSTASH(sobj)); 837 SvOBJECT_off(sobj); 838 } 839 if (SvOBJECT(obj)) { 840 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0); 841 SvOBJECT_on(sobj); 842 SvSTASH_set(sobj, (HV*)fake_stash); 843 } 844 CALLER_CONTEXT; 845 } else { 846 allowed = FALSE; 847 } 848 } else { 849 SvTEMP_off(sv); 850 SHARED_CONTEXT; 851 sv_setsv_nomg(ssv, sv); 852 if (SvOBJECT(ssv)) { 853 /* Remove any old blessing */ 854 SvREFCNT_dec(SvSTASH(ssv)); 855 SvOBJECT_off(ssv); 856 } 857 if (SvOBJECT(sv)) { 858 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); 859 SvOBJECT_on(ssv); 860 SvSTASH_set(ssv, (HV*)fake_stash); 861 } 862 CALLER_CONTEXT; 863 } 864 if (!allowed) { 865 Perl_croak(aTHX_ "Invalid value for shared scalar"); 866 } 867 } 868 869 /* Set magic for PERL_MAGIC_shared_scalar(n) */ 870 871 static int 872 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) 873 { 874 SV *ssv = (SV*)(mg->mg_ptr); 875 assert(ssv); 876 ENTER_LOCK; 877 if (SvTYPE(ssv) < SvTYPE(sv)) { 878 dTHXc; 879 SHARED_CONTEXT; 880 sv_upgrade(ssv, SvTYPE(sv)); 881 CALLER_CONTEXT; 882 } 883 sharedsv_scalar_store(aTHX_ sv, ssv); 884 LEAVE_LOCK; 885 return (0); 886 } 887 888 /* Free magic for PERL_MAGIC_shared_scalar(n) */ 889 890 static int 891 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) 892 { 893 PERL_UNUSED_ARG(sv); 894 ENTER_LOCK; 895 if (!PL_dirty 896 && SvROK((SV *)mg->mg_ptr) && SvREFCNT(SvRV((SV *)mg->mg_ptr)) == 1) { 897 SV *sv = sv_newmortal(); 898 sv_upgrade(sv, SVt_RV); 899 get_RV(sv, SvRV((SV *)mg->mg_ptr)); 900 } 901 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); 902 LEAVE_LOCK; 903 return (0); 904 } 905 906 /* 907 * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread 908 */ 909 static int 910 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) 911 { 912 PERL_UNUSED_ARG(param); 913 SvREFCNT_inc_void(mg->mg_ptr); 914 return (0); 915 } 916 917 #ifdef MGf_LOCAL 918 /* 919 * Called during local $shared 920 */ 921 static int 922 sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg) 923 { 924 MAGIC *nmg; 925 SV *ssv = (SV *) mg->mg_ptr; 926 if (ssv) { 927 ENTER_LOCK; 928 SvREFCNT_inc_void(ssv); 929 LEAVE_LOCK; 930 } 931 nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual, 932 mg->mg_ptr, mg->mg_len); 933 nmg->mg_flags = mg->mg_flags; 934 nmg->mg_private = mg->mg_private; 935 936 return (0); 937 } 938 #endif 939 940 const MGVTBL sharedsv_scalar_vtbl = { 941 sharedsv_scalar_mg_get, /* get */ 942 sharedsv_scalar_mg_set, /* set */ 943 0, /* len */ 944 0, /* clear */ 945 sharedsv_scalar_mg_free, /* free */ 946 0, /* copy */ 947 sharedsv_scalar_mg_dup, /* dup */ 948 #ifdef MGf_LOCAL 949 sharedsv_scalar_mg_local, /* local */ 950 #endif 951 }; 952 953 /* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */ 954 955 /* Get magic for PERL_MAGIC_tiedelem(p) */ 956 957 static int 958 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) 959 { 960 dTHXc; 961 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); 962 SV** svp = NULL; 963 964 ENTER_LOCK; 965 if (saggregate) { /* During global destruction, underlying 966 aggregate may no longer exist */ 967 if (SvTYPE(saggregate) == SVt_PVAV) { 968 assert ( mg->mg_ptr == 0 ); 969 SHARED_CONTEXT; 970 svp = av_fetch((AV*) saggregate, mg->mg_len, 0); 971 } else { 972 char *key = mg->mg_ptr; 973 I32 len = mg->mg_len; 974 assert ( mg->mg_ptr != 0 ); 975 if (mg->mg_len == HEf_SVKEY) { 976 STRLEN slen; 977 key = SvPV((SV *)mg->mg_ptr, slen); 978 len = slen; 979 if (SvUTF8((SV *)mg->mg_ptr)) { 980 len = -len; 981 } 982 } 983 SHARED_CONTEXT; 984 svp = hv_fetch((HV*) saggregate, key, len, 0); 985 } 986 CALLER_CONTEXT; 987 } 988 if (svp) { 989 /* Exists in the array */ 990 if (SvROK(*svp)) { 991 get_RV(sv, SvRV(*svp)); 992 } else { 993 /* $ary->[elem] or $ary->{elem} is a scalar */ 994 Perl_sharedsv_associate(aTHX_ sv, *svp); 995 sv_setsv(sv, *svp); 996 } 997 } else { 998 /* Not in the array */ 999 sv_setsv(sv, &PL_sv_undef); 1000 } 1001 LEAVE_LOCK; 1002 return (0); 1003 } 1004 1005 /* Set magic for PERL_MAGIC_tiedelem(p) */ 1006 1007 static int 1008 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) 1009 { 1010 dTHXc; 1011 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); 1012 SV **svp; 1013 U32 dualvar_flags = DUALVAR_FLAGS(sv); 1014 1015 /* Theory - SV itself is magically shared - and we have ordered the 1016 magic such that by the time we get here it has been stored 1017 to its shared counterpart 1018 */ 1019 ENTER_LOCK; 1020 assert(saggregate); 1021 if (SvTYPE(saggregate) == SVt_PVAV) { 1022 assert ( mg->mg_ptr == 0 ); 1023 SHARED_CONTEXT; 1024 svp = av_fetch((AV*) saggregate, mg->mg_len, 1); 1025 } else { 1026 char *key = mg->mg_ptr; 1027 I32 len = mg->mg_len; 1028 assert ( mg->mg_ptr != 0 ); 1029 if (mg->mg_len == HEf_SVKEY) { 1030 STRLEN slen; 1031 key = SvPV((SV *)mg->mg_ptr, slen); 1032 len = slen; 1033 if (SvUTF8((SV *)mg->mg_ptr)) { 1034 len = -len; 1035 } 1036 } 1037 SHARED_CONTEXT; 1038 svp = hv_fetch((HV*) saggregate, key, len, 1); 1039 } 1040 CALLER_CONTEXT; 1041 Perl_sharedsv_associate(aTHX_ sv, *svp); 1042 sharedsv_scalar_store(aTHX_ sv, *svp); 1043 SvFLAGS(*svp) |= dualvar_flags; 1044 LEAVE_LOCK; 1045 return (0); 1046 } 1047 1048 /* Clear magic for PERL_MAGIC_tiedelem(p) */ 1049 1050 static int 1051 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) 1052 { 1053 dTHXc; 1054 MAGIC *shmg; 1055 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); 1056 1057 /* Object may not exist during global destruction */ 1058 if (! saggregate) { 1059 return (0); 1060 } 1061 1062 ENTER_LOCK; 1063 sharedsv_elem_mg_FETCH(aTHX_ sv, mg); 1064 if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) 1065 sharedsv_scalar_mg_get(aTHX_ sv, shmg); 1066 if (SvTYPE(saggregate) == SVt_PVAV) { 1067 SHARED_CONTEXT; 1068 av_delete((AV*) saggregate, mg->mg_len, G_DISCARD); 1069 } else { 1070 char *key = mg->mg_ptr; 1071 I32 len = mg->mg_len; 1072 assert ( mg->mg_ptr != 0 ); 1073 if (mg->mg_len == HEf_SVKEY) { 1074 STRLEN slen; 1075 key = SvPV((SV *)mg->mg_ptr, slen); 1076 len = slen; 1077 if (SvUTF8((SV *)mg->mg_ptr)) { 1078 len = -len; 1079 } 1080 } 1081 SHARED_CONTEXT; 1082 (void) hv_delete((HV*) saggregate, key, len, G_DISCARD); 1083 } 1084 CALLER_CONTEXT; 1085 LEAVE_LOCK; 1086 return (0); 1087 } 1088 1089 /* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new 1090 * thread */ 1091 1092 static int 1093 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) 1094 { 1095 PERL_UNUSED_ARG(param); 1096 SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj)); 1097 assert(mg->mg_flags & MGf_DUP); 1098 return (0); 1099 } 1100 1101 const MGVTBL sharedsv_elem_vtbl = { 1102 sharedsv_elem_mg_FETCH, /* get */ 1103 sharedsv_elem_mg_STORE, /* set */ 1104 0, /* len */ 1105 sharedsv_elem_mg_DELETE, /* clear */ 1106 0, /* free */ 1107 0, /* copy */ 1108 sharedsv_elem_mg_dup, /* dup */ 1109 #ifdef MGf_LOCAL 1110 0, /* local */ 1111 #endif 1112 }; 1113 1114 /* ------------ PERL_MAGIC_tied(P) functions -------------- */ 1115 1116 /* Len magic for PERL_MAGIC_tied(P) */ 1117 1118 static U32 1119 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) 1120 { 1121 dTHXc; 1122 SV *ssv = (SV *) mg->mg_ptr; 1123 U32 val; 1124 PERL_UNUSED_ARG(sv); 1125 SHARED_EDIT; 1126 if (SvTYPE(ssv) == SVt_PVAV) { 1127 val = av_len((AV*) ssv); 1128 } else { 1129 /* Not actually defined by tie API but ... */ 1130 val = HvUSEDKEYS((HV*) ssv); 1131 } 1132 SHARED_RELEASE; 1133 return (val); 1134 } 1135 1136 /* Clear magic for PERL_MAGIC_tied(P) */ 1137 1138 static int 1139 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) 1140 { 1141 dTHXc; 1142 SV *ssv = (SV *) mg->mg_ptr; 1143 const bool isav = SvTYPE(ssv) == SVt_PVAV; 1144 PERL_UNUSED_ARG(sv); 1145 SHARED_EDIT; 1146 if (!PL_dirty) { 1147 SV **svp = isav ? AvARRAY((AV *)ssv) : NULL; 1148 I32 items = isav ? AvFILLp((AV *)ssv) + 1 : 0; 1149 HE *iter; 1150 if (!isav) hv_iterinit((HV *)ssv); 1151 while (isav ? items-- : !!(iter = hv_iternext((HV *)ssv))) { 1152 SV *sv = isav ? *svp++ : HeVAL(iter); 1153 if (!sv) continue; 1154 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) 1155 && SvREFCNT(sv) == 1 ) { 1156 SV *tmp; 1157 PERL_SET_CONTEXT((aTHX = caller_perl)); 1158 tmp = sv_newmortal(); 1159 sv_upgrade(tmp, SVt_RV); 1160 get_RV(tmp, sv); 1161 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); 1162 } 1163 } 1164 } 1165 if (isav) av_clear((AV*) ssv); 1166 else hv_clear((HV*) ssv); 1167 SHARED_RELEASE; 1168 return (0); 1169 } 1170 1171 /* Free magic for PERL_MAGIC_tied(P) */ 1172 1173 static int 1174 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) 1175 { 1176 PERL_UNUSED_ARG(sv); 1177 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); 1178 return (0); 1179 } 1180 1181 /* 1182 * Copy magic for PERL_MAGIC_tied(P) 1183 * This is called when perl is about to access an element of 1184 * the array - 1185 */ 1186 #if PERL_VERSION >= 11 1187 static int 1188 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, 1189 SV *nsv, const char *name, I32 namlen) 1190 #else 1191 static int 1192 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, 1193 SV *nsv, const char *name, int namlen) 1194 #endif 1195 { 1196 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, 1197 toLOWER(mg->mg_type),&sharedsv_elem_vtbl, 1198 name, namlen); 1199 PERL_UNUSED_ARG(sv); 1200 nmg->mg_flags |= MGf_DUP; 1201 return (1); 1202 } 1203 1204 /* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */ 1205 1206 static int 1207 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) 1208 { 1209 PERL_UNUSED_ARG(param); 1210 SvREFCNT_inc_void((SV*)mg->mg_ptr); 1211 assert(mg->mg_flags & MGf_DUP); 1212 return (0); 1213 } 1214 1215 const MGVTBL sharedsv_array_vtbl = { 1216 0, /* get */ 1217 0, /* set */ 1218 sharedsv_array_mg_FETCHSIZE,/* len */ 1219 sharedsv_array_mg_CLEAR, /* clear */ 1220 sharedsv_array_mg_free, /* free */ 1221 sharedsv_array_mg_copy, /* copy */ 1222 sharedsv_array_mg_dup, /* dup */ 1223 #ifdef MGf_LOCAL 1224 0, /* local */ 1225 #endif 1226 }; 1227 1228 1229 /* Recursive locks on a sharedsv. 1230 * Locks are dynamically scoped at the level of the first lock. 1231 */ 1232 static void 1233 Perl_sharedsv_lock(pTHX_ SV *ssv) 1234 { 1235 user_lock *ul; 1236 if (! ssv) 1237 return; 1238 ul = S_get_userlock(aTHX_ ssv, 1); 1239 recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__); 1240 } 1241 1242 /* Handles calls from lock() builtin via PL_lockhook */ 1243 1244 static void 1245 Perl_sharedsv_locksv(pTHX_ SV *sv) 1246 { 1247 SV *ssv; 1248 1249 if (SvROK(sv)) 1250 sv = SvRV(sv); 1251 ssv = Perl_sharedsv_find(aTHX_ sv); 1252 if (!ssv) 1253 croak("lock can only be used on shared values"); 1254 Perl_sharedsv_lock(aTHX_ ssv); 1255 } 1256 1257 1258 /* Can a shared object be destroyed? 1259 * True if not a shared, 1260 * or if destroying last proxy on a shared object 1261 */ 1262 #ifdef PL_destroyhook 1263 static bool 1264 Perl_shared_object_destroy(pTHX_ SV *sv) 1265 { 1266 SV *ssv; 1267 1268 if (SvROK(sv)) 1269 sv = SvRV(sv); 1270 ssv = Perl_sharedsv_find(aTHX_ sv); 1271 return (!ssv || (SvREFCNT(ssv) <= 1)); 1272 } 1273 #endif 1274 1275 /* veto signal dispatch if we have the lock */ 1276 1277 #ifdef PL_signalhook 1278 1279 STATIC despatch_signals_proc_t prev_signal_hook = NULL; 1280 1281 STATIC void 1282 S_shared_signal_hook(pTHX) { 1283 int us; 1284 MUTEX_LOCK(&PL_sharedsv_lock.mutex); 1285 us = (PL_sharedsv_lock.owner == aTHX); 1286 MUTEX_UNLOCK(&PL_sharedsv_lock.mutex); 1287 if (us) 1288 return; /* try again later */ 1289 prev_signal_hook(aTHX); 1290 } 1291 #endif 1292 1293 /* Saves a space for keeping SVs wider than an interpreter. */ 1294 1295 static void 1296 Perl_sharedsv_init(pTHX) 1297 { 1298 dTHXc; 1299 PL_sharedsv_space = perl_alloc(); 1300 perl_construct(PL_sharedsv_space); 1301 /* The pair above leaves us in shared context (what dTHX would get), 1302 * but aTHX still points to caller context */ 1303 aTHX = PL_sharedsv_space; 1304 LEAVE; /* This balances the ENTER at the end of perl_construct. */ 1305 PERL_SET_CONTEXT((aTHX = caller_perl)); 1306 recursive_lock_init(aTHX_ &PL_sharedsv_lock); 1307 PL_lockhook = &Perl_sharedsv_locksv; 1308 PL_sharehook = &Perl_sharedsv_share; 1309 #ifdef PL_destroyhook 1310 PL_destroyhook = &Perl_shared_object_destroy; 1311 #endif 1312 #ifdef PL_signalhook 1313 if (!prev_signal_hook) { 1314 prev_signal_hook = PL_signalhook; 1315 PL_signalhook = &S_shared_signal_hook; 1316 } 1317 #endif 1318 } 1319 1320 #endif /* USE_ITHREADS */ 1321 1322 MODULE = threads::shared PACKAGE = threads::shared::tie 1323 1324 PROTOTYPES: DISABLE 1325 1326 #ifdef USE_ITHREADS 1327 1328 void 1329 PUSH(SV *obj, ...) 1330 CODE: 1331 dTHXc; 1332 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1333 int ii; 1334 for (ii = 1; ii < items; ii++) { 1335 SV* tmp = newSVsv(ST(ii)); 1336 SV *stmp; 1337 U32 dualvar_flags = DUALVAR_FLAGS(tmp); 1338 ENTER_LOCK; 1339 stmp = S_sharedsv_new_shared(aTHX_ tmp); 1340 sharedsv_scalar_store(aTHX_ tmp, stmp); 1341 SvFLAGS(stmp) |= dualvar_flags; 1342 SHARED_CONTEXT; 1343 av_push((AV*) sobj, stmp); 1344 SvREFCNT_inc_void(stmp); 1345 SHARED_RELEASE; 1346 SvREFCNT_dec(tmp); 1347 } 1348 1349 1350 void 1351 UNSHIFT(SV *obj, ...) 1352 CODE: 1353 dTHXc; 1354 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1355 int ii; 1356 ENTER_LOCK; 1357 SHARED_CONTEXT; 1358 av_unshift((AV*)sobj, items - 1); 1359 CALLER_CONTEXT; 1360 for (ii = 1; ii < items; ii++) { 1361 SV *tmp = newSVsv(ST(ii)); 1362 U32 dualvar_flags = DUALVAR_FLAGS(tmp); 1363 SV *stmp = S_sharedsv_new_shared(aTHX_ tmp); 1364 sharedsv_scalar_store(aTHX_ tmp, stmp); 1365 SHARED_CONTEXT; 1366 SvFLAGS(stmp) |= dualvar_flags; 1367 av_store((AV*) sobj, ii - 1, stmp); 1368 SvREFCNT_inc_void(stmp); 1369 CALLER_CONTEXT; 1370 SvREFCNT_dec(tmp); 1371 } 1372 LEAVE_LOCK; 1373 1374 1375 void 1376 POP(SV *obj) 1377 CODE: 1378 dTHXc; 1379 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1380 SV* ssv; 1381 ENTER_LOCK; 1382 SHARED_CONTEXT; 1383 ssv = av_pop((AV*)sobj); 1384 CALLER_CONTEXT; 1385 ST(0) = sv_newmortal(); 1386 Perl_sharedsv_associate(aTHX_ ST(0), ssv); 1387 SvREFCNT_dec(ssv); 1388 LEAVE_LOCK; 1389 /* XSRETURN(1); - implied */ 1390 1391 1392 void 1393 SHIFT(SV *obj) 1394 CODE: 1395 dTHXc; 1396 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1397 SV* ssv; 1398 ENTER_LOCK; 1399 SHARED_CONTEXT; 1400 ssv = av_shift((AV*)sobj); 1401 CALLER_CONTEXT; 1402 ST(0) = sv_newmortal(); 1403 Perl_sharedsv_associate(aTHX_ ST(0), ssv); 1404 SvREFCNT_dec(ssv); 1405 LEAVE_LOCK; 1406 /* XSRETURN(1); - implied */ 1407 1408 1409 void 1410 EXTEND(SV *obj, IV count) 1411 CODE: 1412 dTHXc; 1413 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1414 SHARED_EDIT; 1415 av_extend((AV*)sobj, count); 1416 SHARED_RELEASE; 1417 1418 1419 void 1420 STORESIZE(SV *obj,IV count) 1421 CODE: 1422 dTHXc; 1423 SV *ssv = SHAREDSV_FROM_OBJ(obj); 1424 1425 SHARED_EDIT; 1426 assert(SvTYPE(ssv) == SVt_PVAV); 1427 if (!PL_dirty) { 1428 SV **svp = AvARRAY((AV *)ssv); 1429 I32 ix = AvFILLp((AV *)ssv); 1430 for (;ix >= count; ix--) { 1431 SV *sv = svp[ix]; 1432 if (!sv) 1433 continue; 1434 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) 1435 && SvREFCNT(sv) == 1 ) 1436 { 1437 SV *tmp; 1438 PERL_SET_CONTEXT((aTHX = caller_perl)); 1439 tmp = sv_newmortal(); 1440 sv_upgrade(tmp, SVt_RV); 1441 get_RV(tmp, sv); 1442 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); 1443 } 1444 } 1445 } 1446 av_fill((AV*) ssv, count - 1); 1447 SHARED_RELEASE; 1448 1449 1450 void 1451 EXISTS(SV *obj, SV *index) 1452 CODE: 1453 dTHXc; 1454 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1455 bool exists; 1456 if (SvTYPE(sobj) == SVt_PVAV) { 1457 SHARED_EDIT; 1458 exists = av_exists((AV*) sobj, SvIV(index)); 1459 } else { 1460 I32 len; 1461 STRLEN slen; 1462 char *key = SvPVutf8(index, slen); 1463 len = slen; 1464 if (SvUTF8(index)) { 1465 len = -len; 1466 } 1467 SHARED_EDIT; 1468 exists = hv_exists((HV*) sobj, key, len); 1469 } 1470 SHARED_RELEASE; 1471 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; 1472 /* XSRETURN(1); - implied */ 1473 1474 1475 void 1476 FIRSTKEY(SV *obj) 1477 CODE: 1478 dTHXc; 1479 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1480 char* key = NULL; 1481 I32 len = 0; 1482 HE* entry; 1483 ENTER_LOCK; 1484 SHARED_CONTEXT; 1485 hv_iterinit((HV*) sobj); 1486 entry = hv_iternext((HV*) sobj); 1487 if (entry) { 1488 I32 utf8 = HeKUTF8(entry); 1489 key = hv_iterkey(entry,&len); 1490 CALLER_CONTEXT; 1491 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0)); 1492 } else { 1493 CALLER_CONTEXT; 1494 ST(0) = &PL_sv_undef; 1495 } 1496 LEAVE_LOCK; 1497 /* XSRETURN(1); - implied */ 1498 1499 1500 void 1501 NEXTKEY(SV *obj, SV *oldkey) 1502 CODE: 1503 dTHXc; 1504 SV *sobj = SHAREDSV_FROM_OBJ(obj); 1505 char* key = NULL; 1506 I32 len = 0; 1507 HE* entry; 1508 1509 PERL_UNUSED_VAR(oldkey); 1510 1511 ENTER_LOCK; 1512 SHARED_CONTEXT; 1513 entry = hv_iternext((HV*) sobj); 1514 if (entry) { 1515 I32 utf8 = HeKUTF8(entry); 1516 key = hv_iterkey(entry,&len); 1517 CALLER_CONTEXT; 1518 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0)); 1519 } else { 1520 CALLER_CONTEXT; 1521 ST(0) = &PL_sv_undef; 1522 } 1523 LEAVE_LOCK; 1524 /* XSRETURN(1); - implied */ 1525 1526 1527 MODULE = threads::shared PACKAGE = threads::shared 1528 1529 PROTOTYPES: ENABLE 1530 1531 void 1532 _id(SV *myref) 1533 PROTOTYPE: \[$@%] 1534 PREINIT: 1535 SV *ssv; 1536 CODE: 1537 myref = SvRV(myref); 1538 if (SvMAGICAL(myref)) 1539 mg_get(myref); 1540 if (SvROK(myref)) 1541 myref = SvRV(myref); 1542 ssv = Perl_sharedsv_find(aTHX_ myref); 1543 if (! ssv) 1544 XSRETURN_UNDEF; 1545 ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv))); 1546 /* XSRETURN(1); - implied */ 1547 1548 1549 void 1550 _refcnt(SV *myref) 1551 PROTOTYPE: \[$@%] 1552 PREINIT: 1553 SV *ssv; 1554 CODE: 1555 myref = SvRV(myref); 1556 if (SvROK(myref)) 1557 myref = SvRV(myref); 1558 ssv = Perl_sharedsv_find(aTHX_ myref); 1559 if (! ssv) { 1560 if (ckWARN(WARN_THREADS)) { 1561 Perl_warner(aTHX_ packWARN(WARN_THREADS), 1562 "%" SVf " is not shared", ST(0)); 1563 } 1564 XSRETURN_UNDEF; 1565 } 1566 ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv))); 1567 /* XSRETURN(1); - implied */ 1568 1569 1570 void 1571 share(SV *myref) 1572 PROTOTYPE: \[$@%] 1573 CODE: 1574 if (! SvROK(myref)) 1575 Perl_croak(aTHX_ "Argument to share needs to be passed as ref"); 1576 myref = SvRV(myref); 1577 if (SvROK(myref)) 1578 myref = SvRV(myref); 1579 Perl_sharedsv_share(aTHX_ myref); 1580 ST(0) = sv_2mortal(newRV_inc(myref)); 1581 /* XSRETURN(1); - implied */ 1582 1583 1584 void 1585 cond_wait(SV *ref_cond, SV *ref_lock = 0) 1586 PROTOTYPE: \[$@%];\[$@%] 1587 PREINIT: 1588 SV *ssv; 1589 perl_cond* user_condition; 1590 int locks; 1591 user_lock *ul; 1592 CODE: 1593 if (!SvROK(ref_cond)) 1594 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); 1595 ref_cond = SvRV(ref_cond); 1596 if (SvROK(ref_cond)) 1597 ref_cond = SvRV(ref_cond); 1598 ssv = Perl_sharedsv_find(aTHX_ ref_cond); 1599 if (! ssv) 1600 Perl_croak(aTHX_ "cond_wait can only be used on shared values"); 1601 ul = S_get_userlock(aTHX_ ssv, 1); 1602 1603 user_condition = &ul->user_cond; 1604 if (ref_lock && (ref_cond != ref_lock)) { 1605 if (!SvROK(ref_lock)) 1606 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); 1607 ref_lock = SvRV(ref_lock); 1608 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); 1609 ssv = Perl_sharedsv_find(aTHX_ ref_lock); 1610 if (! ssv) 1611 Perl_croak(aTHX_ "cond_wait lock must be a shared value"); 1612 ul = S_get_userlock(aTHX_ ssv, 1); 1613 } 1614 if (ul->lock.owner != aTHX) 1615 croak("You need a lock before you can cond_wait"); 1616 1617 /* Stealing the members of the lock object worries me - NI-S */ 1618 MUTEX_LOCK(&ul->lock.mutex); 1619 ul->lock.owner = NULL; 1620 locks = ul->lock.locks; 1621 ul->lock.locks = 0; 1622 1623 /* Since we are releasing the lock here, we need to tell other 1624 * people that it is ok to go ahead and use it */ 1625 COND_SIGNAL(&ul->lock.cond); 1626 COND_WAIT(user_condition, &ul->lock.mutex); 1627 while (ul->lock.owner != NULL) { 1628 /* OK -- must reacquire the lock */ 1629 COND_WAIT(&ul->lock.cond, &ul->lock.mutex); 1630 } 1631 ul->lock.owner = aTHX; 1632 ul->lock.locks = locks; 1633 MUTEX_UNLOCK(&ul->lock.mutex); 1634 1635 1636 int 1637 cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0) 1638 PROTOTYPE: \[$@%]$;\[$@%] 1639 PREINIT: 1640 SV *ssv; 1641 perl_cond* user_condition; 1642 int locks; 1643 user_lock *ul; 1644 CODE: 1645 if (! SvROK(ref_cond)) 1646 Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); 1647 ref_cond = SvRV(ref_cond); 1648 if (SvROK(ref_cond)) 1649 ref_cond = SvRV(ref_cond); 1650 ssv = Perl_sharedsv_find(aTHX_ ref_cond); 1651 if (! ssv) 1652 Perl_croak(aTHX_ "cond_timedwait can only be used on shared values"); 1653 ul = S_get_userlock(aTHX_ ssv, 1); 1654 1655 user_condition = &ul->user_cond; 1656 if (ref_lock && (ref_cond != ref_lock)) { 1657 if (! SvROK(ref_lock)) 1658 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); 1659 ref_lock = SvRV(ref_lock); 1660 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); 1661 ssv = Perl_sharedsv_find(aTHX_ ref_lock); 1662 if (! ssv) 1663 Perl_croak(aTHX_ "cond_timedwait lock must be a shared value"); 1664 ul = S_get_userlock(aTHX_ ssv, 1); 1665 } 1666 if (ul->lock.owner != aTHX) 1667 Perl_croak(aTHX_ "You need a lock before you can cond_wait"); 1668 1669 MUTEX_LOCK(&ul->lock.mutex); 1670 ul->lock.owner = NULL; 1671 locks = ul->lock.locks; 1672 ul->lock.locks = 0; 1673 /* Since we are releasing the lock here, we need to tell other 1674 * people that it is ok to go ahead and use it */ 1675 COND_SIGNAL(&ul->lock.cond); 1676 RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs); 1677 while (ul->lock.owner != NULL) { 1678 /* OK -- must reacquire the lock... */ 1679 COND_WAIT(&ul->lock.cond, &ul->lock.mutex); 1680 } 1681 ul->lock.owner = aTHX; 1682 ul->lock.locks = locks; 1683 MUTEX_UNLOCK(&ul->lock.mutex); 1684 1685 if (RETVAL == 0) 1686 XSRETURN_UNDEF; 1687 OUTPUT: 1688 RETVAL 1689 1690 1691 void 1692 cond_signal(SV *myref) 1693 PROTOTYPE: \[$@%] 1694 PREINIT: 1695 SV *ssv; 1696 user_lock *ul; 1697 CODE: 1698 if (! SvROK(myref)) 1699 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); 1700 myref = SvRV(myref); 1701 if (SvROK(myref)) 1702 myref = SvRV(myref); 1703 ssv = Perl_sharedsv_find(aTHX_ myref); 1704 if (! ssv) 1705 Perl_croak(aTHX_ "cond_signal can only be used on shared values"); 1706 ul = S_get_userlock(aTHX_ ssv, 1); 1707 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { 1708 Perl_warner(aTHX_ packWARN(WARN_THREADS), 1709 "cond_signal() called on unlocked variable"); 1710 } 1711 COND_SIGNAL(&ul->user_cond); 1712 1713 1714 void 1715 cond_broadcast(SV *myref) 1716 PROTOTYPE: \[$@%] 1717 PREINIT: 1718 SV *ssv; 1719 user_lock *ul; 1720 CODE: 1721 if (! SvROK(myref)) 1722 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); 1723 myref = SvRV(myref); 1724 if (SvROK(myref)) 1725 myref = SvRV(myref); 1726 ssv = Perl_sharedsv_find(aTHX_ myref); 1727 if (! ssv) 1728 Perl_croak(aTHX_ "cond_broadcast can only be used on shared values"); 1729 ul = S_get_userlock(aTHX_ ssv, 1); 1730 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { 1731 Perl_warner(aTHX_ packWARN(WARN_THREADS), 1732 "cond_broadcast() called on unlocked variable"); 1733 } 1734 COND_BROADCAST(&ul->user_cond); 1735 1736 1737 void 1738 bless(SV* myref, ...) 1739 PROTOTYPE: $;$ 1740 PREINIT: 1741 HV* stash; 1742 SV *ssv; 1743 CODE: 1744 if (items == 1) { 1745 stash = CopSTASH(PL_curcop); 1746 } else { 1747 SV* classname = ST(1); 1748 STRLEN len; 1749 char *ptr; 1750 1751 if (classname && 1752 ! SvGMAGICAL(classname) && 1753 ! SvAMAGIC(classname) && 1754 SvROK(classname)) 1755 { 1756 Perl_croak(aTHX_ "Attempt to bless into a reference"); 1757 } 1758 ptr = SvPV(classname, len); 1759 if (ckWARN(WARN_MISC) && len == 0) { 1760 Perl_warner(aTHX_ packWARN(WARN_MISC), 1761 "Explicit blessing to '' (assuming package main)"); 1762 } 1763 stash = gv_stashpvn(ptr, len, TRUE); 1764 } 1765 SvREFCNT_inc_void(myref); 1766 (void)sv_bless(myref, stash); 1767 ST(0) = sv_2mortal(myref); 1768 ssv = Perl_sharedsv_find(aTHX_ myref); 1769 if (ssv) { 1770 dTHXc; 1771 ENTER_LOCK; 1772 SHARED_CONTEXT; 1773 { 1774 SV* fake_stash = newSVpv(HvNAME_get(stash), 0); 1775 (void)sv_bless(ssv, (HV*)fake_stash); 1776 } 1777 CALLER_CONTEXT; 1778 LEAVE_LOCK; 1779 } 1780 /* XSRETURN(1); - implied */ 1781 1782 #endif /* USE_ITHREADS */ 1783 1784 BOOT: 1785 { 1786 #ifdef USE_ITHREADS 1787 Perl_sharedsv_init(aTHX); 1788 #endif /* USE_ITHREADS */ 1789 } 1790