dist/threads-shared/shared.xs

   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 static 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     const char *        file;
 176     int                 line;
 177 #endif
 178 } recursive_lock_t;
 179
 180 static 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, const 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 const static 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 const static MGVTBL sharedsv_scalar_vtbl;    /* Scalars have this vtable */
 336 const static MGVTBL sharedsv_array_vtbl;     /* Hashes and arrays have this
 337                                             - like 'tie' */
 338 const static 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(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 || 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 const static 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 const static 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 const static 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     PL_sharedsv_space = perl_alloc();
1251     perl_construct(PL_sharedsv_space);
1252     /* The pair above leaves us in shared context (what dTHX would get),
1253      * but aTHX still points to caller context */
1254     aTHX = PL_sharedsv_space;
1255     LEAVE; /* This balances the ENTER at the end of perl_construct.  */
1256     PERL_SET_CONTEXT((aTHX = caller_perl));
1257     recursive_lock_init(aTHX_ &PL_sharedsv_lock);
1258     PL_lockhook = &Perl_sharedsv_locksv;
1259     PL_sharehook = &Perl_sharedsv_share;
1260 #ifdef PL_destroyhook
1261     PL_destroyhook = &Perl_shared_object_destroy;
1262 #endif
1263 #ifdef PL_signalhook
1264     if (!prev_signal_hook) {
1265         prev_signal_hook = PL_signalhook;
1266         PL_signalhook = &S_shared_signal_hook;
1267     }
1268 #endif
1269 }
1270
1271 #endif /* USE_ITHREADS */
1272
1273 MODULE = threads::shared        PACKAGE = threads::shared::tie
1274
1275 PROTOTYPES: DISABLE
1276
1277 #ifdef USE_ITHREADS
1278
1279 void
1280 PUSH(SV *obj, ...)
1281     CODE:
1282         dTHXc;
1283         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1284         int ii;
1285         for (ii = 1; ii < items; ii++) {
1286             SV* tmp = newSVsv(ST(ii));
1287             SV *stmp;
1288             U32 dualvar_flags = DUALVAR_FLAGS(tmp);
1289             ENTER_LOCK;
1290             stmp = S_sharedsv_new_shared(aTHX_ tmp);
1291             sharedsv_scalar_store(aTHX_ tmp, stmp);
1292             SvFLAGS(stmp) |= dualvar_flags;
1293             SHARED_CONTEXT;
1294             av_push((AV*) sobj, stmp);
1295             SvREFCNT_inc_void(stmp);
1296             SHARED_RELEASE;
1297             SvREFCNT_dec(tmp);
1298         }
1299
1300
1301 void
1302 UNSHIFT(SV *obj, ...)
1303     CODE:
1304         dTHXc;
1305         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1306         int ii;
1307         ENTER_LOCK;
1308         SHARED_CONTEXT;
1309         av_unshift((AV*)sobj, items - 1);
1310         CALLER_CONTEXT;
1311         for (ii = 1; ii < items; ii++) {
1312             SV *tmp = newSVsv(ST(ii));
1313             U32 dualvar_flags = DUALVAR_FLAGS(tmp);
1314             SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
1315             sharedsv_scalar_store(aTHX_ tmp, stmp);
1316             SHARED_CONTEXT;
1317             SvFLAGS(stmp) |= dualvar_flags;
1318             av_store((AV*) sobj, ii - 1, stmp);
1319             SvREFCNT_inc_void(stmp);
1320             CALLER_CONTEXT;
1321             SvREFCNT_dec(tmp);
1322         }
1323         LEAVE_LOCK;
1324
1325
1326 void
1327 POP(SV *obj)
1328     CODE:
1329         dTHXc;
1330         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1331         SV* ssv;
1332         ENTER_LOCK;
1333         SHARED_CONTEXT;
1334         ssv = av_pop((AV*)sobj);
1335         CALLER_CONTEXT;
1336         ST(0) = sv_newmortal();
1337         Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1338         SvREFCNT_dec(ssv);
1339         LEAVE_LOCK;
1340         /* XSRETURN(1); - implied */
1341
1342
1343 void
1344 SHIFT(SV *obj)
1345     CODE:
1346         dTHXc;
1347         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1348         SV* ssv;
1349         ENTER_LOCK;
1350         SHARED_CONTEXT;
1351         ssv = av_shift((AV*)sobj);
1352         CALLER_CONTEXT;
1353         ST(0) = sv_newmortal();
1354         Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1355         SvREFCNT_dec(ssv);
1356         LEAVE_LOCK;
1357         /* XSRETURN(1); - implied */
1358
1359
1360 void
1361 EXTEND(SV *obj, IV count)
1362     CODE:
1363         dTHXc;
1364         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1365         SHARED_EDIT;
1366         av_extend((AV*)sobj, count);
1367         SHARED_RELEASE;
1368
1369
1370 void
1371 STORESIZE(SV *obj,IV count)
1372     CODE:
1373         dTHXc;
1374         SV *ssv = SHAREDSV_FROM_OBJ(obj);
1375
1376         SHARED_EDIT;
1377         assert(SvTYPE(ssv) == SVt_PVAV);
1378         if (!PL_dirty) {
1379             SV **svp = AvARRAY((AV *)ssv);
1380             I32 ix = AvFILLp((AV *)ssv);
1381             for (;ix >= count; ix--) {
1382                 SV *sv = svp[ix];
1383                 if (!sv)
1384                     continue;
1385                 if (   (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
1386                     && SvREFCNT(sv) == 1 )
1387                 {
1388                     SV *tmp = Perl_sv_newmortal(caller_perl);
1389                     PERL_SET_CONTEXT((aTHX = caller_perl));
1390                     sv_upgrade(tmp, SVt_RV);
1391                     get_RV(tmp, sv);
1392                     PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
1393                 }
1394             }
1395         }
1396         av_fill((AV*) ssv, count - 1);
1397         SHARED_RELEASE;
1398
1399
1400 void
1401 EXISTS(SV *obj, SV *index)
1402     CODE:
1403         dTHXc;
1404         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1405         bool exists;
1406         if (SvTYPE(sobj) == SVt_PVAV) {
1407             SHARED_EDIT;
1408             exists = av_exists((AV*) sobj, SvIV(index));
1409         } else {
1410             I32 len;
1411             STRLEN slen;
1412             char *key = SvPVutf8(index, slen);
1413             len = slen;
1414             if (SvUTF8(index)) {
1415                 len = -len;
1416             }
1417             SHARED_EDIT;
1418             exists = hv_exists((HV*) sobj, key, len);
1419         }
1420         SHARED_RELEASE;
1421         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1422         /* XSRETURN(1); - implied */
1423
1424
1425 void
1426 FIRSTKEY(SV *obj)
1427     CODE:
1428         dTHXc;
1429         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1430         char* key = NULL;
1431         I32 len = 0;
1432         HE* entry;
1433         ENTER_LOCK;
1434         SHARED_CONTEXT;
1435         hv_iterinit((HV*) sobj);
1436         entry = hv_iternext((HV*) sobj);
1437         if (entry) {
1438             I32 utf8 = HeKUTF8(entry);
1439             key = hv_iterkey(entry,&len);
1440             CALLER_CONTEXT;
1441             ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
1442         } else {
1443             CALLER_CONTEXT;
1444             ST(0) = &PL_sv_undef;
1445         }
1446         LEAVE_LOCK;
1447         /* XSRETURN(1); - implied */
1448
1449
1450 void
1451 NEXTKEY(SV *obj, SV *oldkey)
1452     CODE:
1453         dTHXc;
1454         SV *sobj = SHAREDSV_FROM_OBJ(obj);
1455         char* key = NULL;
1456         I32 len = 0;
1457         HE* entry;
1458
1459         PERL_UNUSED_VAR(oldkey);
1460
1461         ENTER_LOCK;
1462         SHARED_CONTEXT;
1463         entry = hv_iternext((HV*) sobj);
1464         if (entry) {
1465             I32 utf8 = HeKUTF8(entry);
1466             key = hv_iterkey(entry,&len);
1467             CALLER_CONTEXT;
1468             ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
1469         } else {
1470             CALLER_CONTEXT;
1471             ST(0) = &PL_sv_undef;
1472         }
1473         LEAVE_LOCK;
1474         /* XSRETURN(1); - implied */
1475
1476
1477 MODULE = threads::shared        PACKAGE = threads::shared
1478
1479 PROTOTYPES: ENABLE
1480
1481 void
1482 _id(SV *myref)
1483     PROTOTYPE: \[$@%]
1484     PREINIT:
1485         SV *ssv;
1486     CODE:
1487         myref = SvRV(myref);
1488         if (SvMAGICAL(myref))
1489             mg_get(myref);
1490         if (SvROK(myref))
1491             myref = SvRV(myref);
1492         ssv = Perl_sharedsv_find(aTHX_ myref);
1493         if (! ssv)
1494             XSRETURN_UNDEF;
1495         ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
1496         /* XSRETURN(1); - implied */
1497
1498
1499 void
1500 _refcnt(SV *myref)
1501     PROTOTYPE: \[$@%]
1502     PREINIT:
1503         SV *ssv;
1504     CODE:
1505         myref = SvRV(myref);
1506         if (SvROK(myref))
1507             myref = SvRV(myref);
1508         ssv = Perl_sharedsv_find(aTHX_ myref);
1509         if (! ssv) {
1510             if (ckWARN(WARN_THREADS)) {
1511                 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1512                                 "%" SVf " is not shared", ST(0));
1513             }
1514             XSRETURN_UNDEF;
1515         }
1516         ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
1517         /* XSRETURN(1); - implied */
1518
1519
1520 void
1521 share(SV *myref)
1522     PROTOTYPE: \[$@%]
1523     CODE:
1524         if (! SvROK(myref))
1525             Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
1526         myref = SvRV(myref);
1527         if (SvROK(myref))
1528             myref = SvRV(myref);
1529         Perl_sharedsv_share(aTHX_ myref);
1530         ST(0) = sv_2mortal(newRV_inc(myref));
1531         /* XSRETURN(1); - implied */
1532
1533
1534 void
1535 cond_wait(SV *ref_cond, SV *ref_lock = 0)
1536     PROTOTYPE: \[$@%];\[$@%]
1537     PREINIT:
1538         SV *ssv;
1539         perl_cond* user_condition;
1540         int locks;
1541         user_lock *ul;
1542     CODE:
1543         if (!SvROK(ref_cond))
1544             Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
1545         ref_cond = SvRV(ref_cond);
1546         if (SvROK(ref_cond))
1547             ref_cond = SvRV(ref_cond);
1548         ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1549         if (! ssv)
1550             Perl_croak(aTHX_ "cond_wait can only be used on shared values");
1551         ul = S_get_userlock(aTHX_ ssv, 1);
1552
1553         user_condition = &ul->user_cond;
1554         if (ref_lock && (ref_cond != ref_lock)) {
1555             if (!SvROK(ref_lock))
1556                 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1557             ref_lock = SvRV(ref_lock);
1558             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1559             ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1560             if (! ssv)
1561                 Perl_croak(aTHX_ "cond_wait lock must be a shared value");
1562             ul = S_get_userlock(aTHX_ ssv, 1);
1563         }
1564         if (ul->lock.owner != aTHX)
1565             croak("You need a lock before you can cond_wait");
1566
1567         /* Stealing the members of the lock object worries me - NI-S */
1568         MUTEX_LOCK(&ul->lock.mutex);
1569         ul->lock.owner = NULL;
1570         locks = ul->lock.locks;
1571         ul->lock.locks = 0;
1572
1573         /* Since we are releasing the lock here, we need to tell other
1574          * people that it is ok to go ahead and use it */
1575         COND_SIGNAL(&ul->lock.cond);
1576         COND_WAIT(user_condition, &ul->lock.mutex);
1577         while (ul->lock.owner != NULL) {
1578             /* OK -- must reacquire the lock */
1579             COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1580         }
1581         ul->lock.owner = aTHX;
1582         ul->lock.locks = locks;
1583         MUTEX_UNLOCK(&ul->lock.mutex);
1584
1585
1586 int
1587 cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0)
1588     PROTOTYPE: \[$@%]$;\[$@%]
1589     PREINIT:
1590         SV *ssv;
1591         perl_cond* user_condition;
1592         int locks;
1593         user_lock *ul;
1594     CODE:
1595         if (! SvROK(ref_cond))
1596             Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1597         ref_cond = SvRV(ref_cond);
1598         if (SvROK(ref_cond))
1599             ref_cond = SvRV(ref_cond);
1600         ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1601         if (! ssv)
1602             Perl_croak(aTHX_ "cond_timedwait can only be used on shared values");
1603         ul = S_get_userlock(aTHX_ ssv, 1);
1604
1605         user_condition = &ul->user_cond;
1606         if (ref_lock && (ref_cond != ref_lock)) {
1607             if (! SvROK(ref_lock))
1608                 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1609             ref_lock = SvRV(ref_lock);
1610             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1611             ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1612             if (! ssv)
1613                 Perl_croak(aTHX_ "cond_timedwait lock must be a shared value");
1614             ul = S_get_userlock(aTHX_ ssv, 1);
1615         }
1616         if (ul->lock.owner != aTHX)
1617             Perl_croak(aTHX_ "You need a lock before you can cond_wait");
1618
1619         MUTEX_LOCK(&ul->lock.mutex);
1620         ul->lock.owner = NULL;
1621         locks = ul->lock.locks;
1622         ul->lock.locks = 0;
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         RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs);
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         if (RETVAL == 0)
1636             XSRETURN_UNDEF;
1637     OUTPUT:
1638         RETVAL
1639
1640
1641 void
1642 cond_signal(SV *myref)
1643     PROTOTYPE: \[$@%]
1644     PREINIT:
1645         SV *ssv;
1646         user_lock *ul;
1647     CODE:
1648         if (! SvROK(myref))
1649             Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
1650         myref = SvRV(myref);
1651         if (SvROK(myref))
1652             myref = SvRV(myref);
1653         ssv = Perl_sharedsv_find(aTHX_ myref);
1654         if (! ssv)
1655             Perl_croak(aTHX_ "cond_signal can only be used on shared values");
1656         ul = S_get_userlock(aTHX_ ssv, 1);
1657         if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1658             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1659                             "cond_signal() called on unlocked variable");
1660         }
1661         COND_SIGNAL(&ul->user_cond);
1662
1663
1664 void
1665 cond_broadcast(SV *myref)
1666     PROTOTYPE: \[$@%]
1667     PREINIT:
1668         SV *ssv;
1669         user_lock *ul;
1670     CODE:
1671         if (! SvROK(myref))
1672             Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
1673         myref = SvRV(myref);
1674         if (SvROK(myref))
1675             myref = SvRV(myref);
1676         ssv = Perl_sharedsv_find(aTHX_ myref);
1677         if (! ssv)
1678             Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
1679         ul = S_get_userlock(aTHX_ ssv, 1);
1680         if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1681             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1682                             "cond_broadcast() called on unlocked variable");
1683         }
1684         COND_BROADCAST(&ul->user_cond);
1685
1686
1687 void
1688 bless(SV* myref, ...)
1689     PROTOTYPE: $;$
1690     PREINIT:
1691         HV* stash;
1692         SV *ssv;
1693     CODE:
1694         if (items == 1) {
1695             stash = CopSTASH(PL_curcop);
1696         } else {
1697             SV* classname = ST(1);
1698             STRLEN len;
1699             char *ptr;
1700
1701             if (classname &&
1702                 ! SvGMAGICAL(classname) &&
1703                 ! SvAMAGIC(classname) &&
1704                 SvROK(classname))
1705             {
1706                 Perl_croak(aTHX_ "Attempt to bless into a reference");
1707             }
1708             ptr = SvPV(classname, len);
1709             if (ckWARN(WARN_MISC) && len == 0) {
1710                 Perl_warner(aTHX_ packWARN(WARN_MISC),
1711                         "Explicit blessing to '' (assuming package main)");
1712             }
1713             stash = gv_stashpvn(ptr, len, TRUE);
1714         }
1715         SvREFCNT_inc_void(myref);
1716         (void)sv_bless(myref, stash);
1717         ST(0) = sv_2mortal(myref);
1718         ssv = Perl_sharedsv_find(aTHX_ myref);
1719         if (ssv) {
1720             dTHXc;
1721             ENTER_LOCK;
1722             SHARED_CONTEXT;
1723             {
1724                 SV* fake_stash = newSVpv(HvNAME_get(stash), 0);
1725                 (void)sv_bless(ssv, (HV*)fake_stash);
1726             }
1727             CALLER_CONTEXT;
1728             LEAVE_LOCK;
1729         }
1730         /* XSRETURN(1); - implied */
1731
1732 #endif /* USE_ITHREADS */
1733
1734 BOOT:
1735 {
1736 #ifdef USE_ITHREADS
1737      Perl_sharedsv_init(aTHX);
1738 #endif /* USE_ITHREADS */
1739 }