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