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