dist/threads-shared/shared.xs

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