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