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