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