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