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