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