dist/threads-shared/shared.xs

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