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