ext/threads/shared/shared.xs

   1 /*    sharedsv.c
   2  *
   3  *    Copyright (c) 2001, 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  */
   9
  10 /*
  11  *
  12  * "Hand any two wizards a piece of rope and they would instinctively pull in
  13  * opposite directions."
  14  *                         --Sourcery
  15  *
  16  * Contributed by Arthur Bergman arthur@contiller.se
  17  * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net
  18  */
  19
  20 #define PERL_NO_GET_CONTEXT
  21 #include "EXTERN.h"
  22 #include "perl.h"
  23 #include "XSUB.h"
  24
  25 #define SHAREDSvPTR(a)      ((a)->sv)
  26
  27 /*
  28  * The shared things need an intepreter to live in ...
  29  */
  30 PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
  31 /* To access shared space we fake aTHX in this scope and thread's context */
  32 #define SHARED_CONTEXT      PERL_SET_CONTEXT((aTHX = PL_sharedsv_space))
  33
  34 /* So we need a way to switch back to the caller's context... */
  35 /* So we declare _another_ copy of the aTHX variable ... */
  36 #define dTHXc PerlInterpreter *caller_perl = aTHX
  37 /* and use it to switch back */
  38 #define CALLER_CONTEXT      PERL_SET_CONTEXT((aTHX = caller_perl))
  39
  40 /*
  41  * Only one thread at a time is allowed to mess with shared space.
  42  */
  43
  44 typedef struct
  45 {
  46  perl_mutex              mutex;
  47  perl_cond               cond;
  48  PerlInterpreter        *owner;
  49  I32                     locks;
  50 } recursive_lock_t;
  51
  52 recursive_lock_t PL_sharedsv_lock;       /* Mutex protecting the shared sv space */
  53
  54 void
  55 recursive_lock_init(pTHX_ recursive_lock_t *lock)
  56 {
  57     Zero(lock,1,recursive_lock_t);
  58     MUTEX_INIT(&lock->mutex);
  59     COND_INIT(&lock->cond);
  60 }
  61
  62 void
  63 recursive_lock_release(pTHX_ recursive_lock_t *lock)
  64 {
  65     MUTEX_LOCK(&lock->mutex);
  66     if (lock->owner != aTHX) {
  67         MUTEX_UNLOCK(&lock->mutex);
  68     }
  69     else {
  70         if (--lock->locks == 0) {
  71             lock->owner = NULL;
  72             COND_SIGNAL(&lock->cond);
  73         }
  74     }
  75     MUTEX_UNLOCK(&lock->mutex);
  76 }
  77
  78 void
  79 recursive_lock_acquire(pTHX_ recursive_lock_t *lock)
  80 {
  81     assert(aTHX);
  82     MUTEX_LOCK(&lock->mutex);
  83     if (lock->owner == aTHX) {
  84         lock->locks++;
  85     }
  86     else {
  87         while (lock->owner)
  88             COND_WAIT(&lock->cond,&lock->mutex);
  89         lock->locks = 1;
  90         lock->owner = aTHX;
  91         SAVEDESTRUCTOR_X(recursive_lock_release,lock);
  92     }
  93     MUTEX_UNLOCK(&lock->mutex);
  94 }
  95
  96 #define ENTER_LOCK         STMT_START { \
  97                               ENTER; \
  98                               recursive_lock_acquire(aTHX_ &PL_sharedsv_lock);   \
  99                             } STMT_END
 100
 101 #define LEAVE_LOCK       LEAVE
 102
 103
 104 /* A common idiom is to acquire access and switch in ... */
 105 #define SHARED_EDIT         STMT_START {        \
 106                                 ENTER_LOCK;     \
 107                                 SHARED_CONTEXT; \
 108                             } STMT_END
 109
 110 /* then switch out and release access. */
 111 #define SHARED_RELEASE     STMT_START { \
 112                                 CALLER_CONTEXT; \
 113                                 LEAVE_LOCK;     \
 114                             } STMT_END
 115
 116
 117 /*
 118
 119   Shared SV
 120
 121   Shared SV is a structure for keeping the backend storage
 122   of shared svs.
 123
 124   Shared-ness really only needs the SV * - the rest is for locks.
 125   (Which suggests further space optimization ... )
 126
 127 */
 128
 129 typedef struct {
 130     SV                 *sv;             /* The actual SV - in shared space */
 131     recursive_lock_t    lock;
 132     perl_cond           user_cond;      /* For user-level conditions */
 133 } shared_sv;
 134
 135 /* The SV in shared-space has a back-pointer to the shared_sv
 136    struct associated with it PERL_MAGIC_ext.
 137
 138    The vtable used has just one entry - when the SV goes away
 139    we free the memory for the above.
 140
 141  */
 142
 143 int
 144 sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
 145 {
 146     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 147     if (shared) {
 148         PerlIO_debug(__FUNCTION__ "Free %p\n",shared);
 149         PerlMemShared_free(shared);
 150         mg->mg_ptr = NULL;
 151     }
 152     return 0;
 153 }
 154
 155
 156 MGVTBL sharedsv_shared_vtbl = {
 157  0,                             /* get */
 158  0,                             /* set */
 159  0,                             /* len */
 160  0,                             /* clear */
 161  sharedsv_shared_mg_free,       /* free */
 162  0,                             /* copy */
 163  0,                             /* dup */
 164 };
 165
 166 /* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */
 167
 168 /* In any thread that has access to a shared thing there is a "proxy"
 169    for it in its own space which has 'MAGIC' associated which accesses
 170    the shared thing.
 171  */
 172
 173 MGVTBL sharedsv_scalar_vtbl;    /* scalars have this vtable */
 174 MGVTBL sharedsv_array_vtbl;     /* hashes and arrays have this - like 'tie' */
 175 MGVTBL sharedsv_elem_vtbl;      /* elements of hashes and arrays have this
 176                                    _AS WELL AS_ the scalar magic */
 177
 178 /* The sharedsv_elem_vtbl associates the element with the array/hash and
 179    the sharedsv_scalar_vtbl associates it with the value
 180  */
 181
 182 =for apidoc sharedsv_find
 183
 184 Given a private side SV tries to find if a given SV has a shared backend,
 185 by looking for the magic.
 186
 187 =cut
 188
 189 shared_sv *
 190 Perl_sharedsv_find(pTHX_ SV *sv)
 191 {
 192     MAGIC *mg;
 193     if (SvTYPE(sv) >= SVt_PVMG) {
 194         switch(SvTYPE(sv)) {
 195         case SVt_PVAV:
 196         case SVt_PVHV:
 197             if ((mg = mg_find(sv, PERL_MAGIC_tied))
 198                 && mg->mg_virtual == &sharedsv_array_vtbl) {
 199                 return (shared_sv *) mg->mg_ptr;
 200             }
 201             break;
 202         default:
 203             if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
 204                 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
 205                 return (shared_sv *) mg->mg_ptr;
 206                 }
 207             break;
 208         }
 209     }
 210     return NULL;
 211 }
 212
 213 /*
 214  *  Almost all the pain is in this routine.
 215  *
 216  */
 217
 218 shared_sv *
 219 Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
 220 {
 221     /* First try and get global data structure */
 222     dTHXc;
 223     MAGIC *mg = 0;
 224     SV *sv;
 225
 226     /* If we are asked for an private ops we need a thread */
 227     assert ( aTHX !=  PL_sharedsv_space );
 228
 229     /* To avoid need for recursive locks require caller to hold lock */
 230     assert ( PL_sharedsv_lock.owner == aTHX );
 231     if ( PL_sharedsv_lock.owner != aTHX )
 232      abort();
 233
 234     /* Try shared SV as 1st choice */
 235     if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
 236         if (mg = mg_find(ssv, PERL_MAGIC_ext)) {
 237             data = (shared_sv *) mg->mg_ptr;
 238         }
 239     }
 240     /* Next try private SV */
 241     if (!data && psv && *psv) {
 242         data = Perl_sharedsv_find(aTHX,*psv);
 243     }
 244     /* If neither of those then create a new one */
 245     if (!data) {
 246             data = PerlMemShared_malloc(sizeof(shared_sv));
 247             Zero(data,1,shared_sv);
 248             recursive_lock_init(aTHX_ &data->lock);
 249             COND_INIT(&data->user_cond);
 250     }
 251
 252     if (!ssv)
 253         ssv = SHAREDSvPTR(data);
 254
 255     /* If we know type allocate shared side SV */
 256     if (psv && *psv && !ssv) {
 257         SHARED_CONTEXT;
 258         ssv = newSV(0);
 259         sv_upgrade(ssv, SvTYPE(*psv));
 260         /* Tag shared side SV with data pointer */
 261         sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
 262                    (char *)data, 0);
 263         CALLER_CONTEXT;
 264     }
 265
 266     if (!SHAREDSvPTR(data))
 267         SHAREDSvPTR(data) = ssv;
 268
 269     /* Now if requested allocate private SV */
 270     if (psv && !*psv && ssv) {
 271         sv = newSV(0);
 272         sv_upgrade(sv, SvTYPE(SHAREDSvPTR(data)));
 273         *psv = sv;
 274     }
 275
 276     /* Finally if private SV exists check and add magic */
 277     if (psv && (sv = *psv)) {
 278         MAGIC *mg = 0;
 279         switch(SvTYPE(sv)) {
 280         case SVt_PVAV:
 281         case SVt_PVHV:
 282             if (!(mg = mg_find(sv, PERL_MAGIC_tied))
 283                 || mg->mg_virtual != &sharedsv_array_vtbl) {
 284                 SV *obj = newSV(0);
 285                 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
 286                 if (mg)
 287                     sv_unmagic(sv, PERL_MAGIC_tied);
 288                 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
 289                                 (char *) data, 0);
 290                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
 291                 SvREFCNT_inc(SHAREDSvPTR(data));
 292                 PerlIO_debug(__FUNCTION__ " %p %d\n",data,SvREFCNT(SHAREDSvPTR(data)));
 293                 SvREFCNT_dec(obj);
 294             }
 295             break;
 296
 297         default:
 298             if (SvTYPE(sv) < SVt_PVMG || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) ||
 299                 mg->mg_virtual != &sharedsv_scalar_vtbl) {
 300                 if (mg)
 301                     sv_unmagic(sv, PERL_MAGIC_shared_scalar);
 302                 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
 303                                 &sharedsv_scalar_vtbl, (char *)data, 0);
 304                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
 305                 SvREFCNT_inc(SHAREDSvPTR(data));
 306                 PerlIO_debug(__FUNCTION__ " %p %d\n",data,SvREFCNT(SHAREDSvPTR(data)));
 307             }
 308             break;
 309         }
 310         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
 311     }
 312     return data;
 313 }
 314
 315 void
 316 Perl_sharedsv_free(pTHX_ shared_sv *shared)
 317 {
 318     if (shared) {
 319         dTHXc;
 320         SHARED_EDIT;
 321         SvREFCNT_dec(SHAREDSvPTR(shared));
 322         SHARED_RELEASE;
 323     }
 324 }
 325
 326 void
 327 Perl_sharedsv_share(pTHX_ SV *sv)
 328 {
 329     switch(SvTYPE(sv)) {
 330     case SVt_PVGV:
 331         Perl_croak(aTHX_ "Cannot share globs yet");
 332         break;
 333
 334     case SVt_PVCV:
 335         Perl_croak(aTHX_ "Cannot share subs yet");
 336         break;
 337
 338     default:
 339         ENTER_LOCK;
 340         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
 341         LEAVE_LOCK;
 342         SvSETMAGIC(sv);
 343         break;
 344     }
 345 }
 346
 347 /* MAGIC (in mg.h sense) hooks */
 348
 349 int
 350 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
 351 {
 352     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 353
 354     ENTER_LOCK;
 355     if (SHAREDSvPTR(shared)) {
 356         if (SvROK(SHAREDSvPTR(shared))) {
 357             SV *obj = Nullsv;
 358             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
 359             sv_setsv_nomg(sv, &PL_sv_undef);
 360             SvRV(sv) = obj;
 361             SvROK_on(sv);
 362         }
 363         else {
 364             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
 365         }
 366     }
 367     LEAVE_LOCK;
 368     return 0;
 369 }
 370
 371 int
 372 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
 373 {
 374     dTHXc;
 375     shared_sv *shared;
 376     bool allowed = TRUE;
 377     ENTER_LOCK;
 378     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
 379
 380     if (SvROK(sv)) {
 381         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
 382         if (target) {
 383             SV *tmp;
 384             SHARED_CONTEXT;
 385             tmp = newRV(SHAREDSvPTR(target));
 386             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
 387             SvREFCNT_dec(tmp);
 388             CALLER_CONTEXT;
 389         }
 390         else {
 391             allowed = FALSE;
 392         }
 393     }
 394     else {
 395         SHARED_CONTEXT;
 396         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
 397         CALLER_CONTEXT;
 398     }
 399     SHARED_RELEASE;
 400
 401     if (!allowed) {
 402         Perl_croak(aTHX_ "Invalid value for shared scalar");
 403     }
 404     return 0;
 405 }
 406
 407 int
 408 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
 409 {
 410     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 411     PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared))-1);
 412     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
 413     Perl_sharedsv_free(aTHX_ shared);
 414     return 0;
 415 }
 416
 417 int
 418 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 419 {
 420     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 421     PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
 422     return 0;
 423 }
 424
 425 /*
 426  * Called during cloning of new threads
 427  */
 428 int
 429 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 430 {
 431     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 432     if (shared) {
 433         SvREFCNT_inc(SHAREDSvPTR(shared));
 434     }
 435     PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
 436     return 0;
 437 }
 438
 439 MGVTBL sharedsv_scalar_vtbl = {
 440  sharedsv_scalar_mg_get,        /* get */
 441  sharedsv_scalar_mg_set,        /* set */
 442  0,                             /* len */
 443  sharedsv_scalar_mg_clear,      /* clear */
 444  sharedsv_scalar_mg_free,       /* free */
 445  0,                             /* copy */
 446  sharedsv_scalar_mg_dup         /* dup */
 447 };
 448
 449 /* Now the arrays/hashes stuff */
 450
 451 int
 452 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
 453 {
 454     dTHXc;
 455     shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
 456     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
 457     SV** svp;
 458
 459     assert ( shared );
 460     assert ( SHAREDSvPTR(shared) );
 461
 462     SHARED_EDIT;
 463     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 464         assert ( mg->mg_ptr == 0 );
 465         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
 466     }
 467     else {
 468         assert ( mg->mg_ptr != 0 );
 469         svp = hv_fetch((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len, 0);
 470     }
 471
 472     if (svp) {
 473         if (target) {
 474             if (SHAREDSvPTR(target) != *svp) {
 475                 if (SHAREDSvPTR(target)) {
 476                     PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
 477                     SvREFCNT_dec(SHAREDSvPTR(target));
 478                 }
 479                 SHAREDSvPTR(target) = SvREFCNT_inc(*svp);
 480             }
 481         }
 482         else {
 483             CALLER_CONTEXT;
 484             Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
 485             SHARED_CONTEXT;
 486         }
 487     }
 488     else if (target) {
 489         if (SHAREDSvPTR(target)) {
 490             SvREFCNT_dec(SHAREDSvPTR(target));
 491         }
 492         SHAREDSvPTR(target) = Nullsv;
 493     }
 494     SHARED_RELEASE;
 495     return 0;
 496 }
 497
 498 int
 499 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
 500 {
 501     dTHXc;
 502     shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
 503     shared_sv *target;
 504     SV *val;
 505     /* Theory - SV itself is magically shared - and we have ordered the
 506        magic such that by the time we get here it has been stored
 507        to its shared counterpart
 508      */
 509     ENTER_LOCK;
 510     assert(shared);
 511     assert(SHAREDSvPTR(shared));
 512     target = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, 0);
 513     SHARED_CONTEXT;
 514     val = SHAREDSvPTR(target);
 515     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 516         av_store((AV*) SHAREDSvPTR(shared), mg->mg_len, SvREFCNT_inc(val));
 517     }
 518     else {
 519         hv_store((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len,
 520                        SvREFCNT_inc(val), 0);
 521     }
 522     SHARED_RELEASE;
 523     return 0;
 524 }
 525
 526 int
 527 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
 528 {
 529     dTHXc;
 530     shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
 531     SV* ssv;
 532     SHARED_EDIT;
 533     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 534         ssv = av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
 535     }
 536     else {
 537         ssv = hv_delete((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len, 0);
 538     }
 539     SHARED_RELEASE;
 540     /* It is no longer in the array - so remove that magic */
 541     sv_unmagic(sv, PERL_MAGIC_tiedelem);
 542     Perl_sharedsv_associate(aTHX_ &sv, ssv, 0);
 543     return 0;
 544 }
 545
 546 int
 547 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
 548 {
 549     Perl_sharedsv_free(aTHX_ Perl_sharedsv_find(aTHX_ mg->mg_obj));
 550     return 0;
 551 }
 552
 553 int
 554 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 555 {
 556     shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
 557     SvREFCNT_inc(SHAREDSvPTR(shared));
 558     PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
 559     mg->mg_flags |= MGf_DUP;
 560     return 0;
 561 }
 562
 563 MGVTBL sharedsv_elem_vtbl = {
 564  sharedsv_elem_mg_FETCH,        /* get */
 565  sharedsv_elem_mg_STORE,        /* set */
 566  0,                             /* len */
 567  sharedsv_elem_mg_DELETE,       /* clear */
 568  sharedsv_elem_mg_free,         /* free */
 569  0,                             /* copy */
 570  sharedsv_elem_mg_dup           /* dup */
 571 };
 572
 573 U32
 574 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
 575 {
 576     dTHXc;
 577     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 578     U32 val;
 579     SHARED_EDIT;
 580     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 581         val = av_len((AV*) SHAREDSvPTR(shared));
 582     }
 583     else {
 584         /* not actually defined by tie API but ... */
 585         val = HvKEYS((HV*) SHAREDSvPTR(shared));
 586     }
 587     SHARED_RELEASE;
 588     return val;
 589 }
 590
 591 int
 592 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
 593 {
 594     dTHXc;
 595     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 596     SHARED_EDIT;
 597     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 598         av_clear((AV*) SHAREDSvPTR(shared));
 599     }
 600     else {
 601         hv_clear((HV*) SHAREDSvPTR(shared));
 602     }
 603     SHARED_RELEASE;
 604     return 0;
 605 }
 606
 607 int
 608 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
 609 {
 610     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
 611     return 0;
 612 }
 613
 614 /*
 615  * This is called when perl is about to access an element of
 616  * the array -
 617  */
 618 int
 619 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
 620                        SV *nsv, const char *name, int namlen)
 621 {
 622     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 623     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
 624                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
 625                             name, namlen);
 626     SvREFCNT_inc(SHAREDSvPTR(shared));
 627     nmg->mg_flags |= MGf_DUP;
 628 #if 0
 629     /* Maybe do this to associate shared value immediately ? */
 630     sharedsv_elem_FIND(aTHX_ nsv, nmg);
 631 #endif
 632     return 1;
 633 }
 634
 635 int
 636 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 637 {
 638     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 639     SvREFCNT_inc(SHAREDSvPTR(shared));
 640     PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
 641     mg->mg_flags |= MGf_DUP;
 642     return 0;
 643 }
 644
 645 MGVTBL sharedsv_array_vtbl = {
 646  0,                             /* get */
 647  0,                             /* set */
 648  sharedsv_array_mg_FETCHSIZE,   /* len */
 649  sharedsv_array_mg_CLEAR,       /* clear */
 650  sharedsv_array_mg_free,        /* free */
 651  sharedsv_array_mg_copy,        /* copy */
 652  sharedsv_array_mg_dup          /* dup */
 653 };
 654
 655 =for apidoc sharedsv_unlock
 656
 657 Recursively unlocks a shared sv.
 658
 659 =cut
 660
 661 void
 662 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
 663 {
 664     recursive_lock_release(aTHX_ &ssv->lock);
 665 }
 666
 667 =for apidoc sharedsv_lock
 668
 669 Recursive locks on a sharedsv.
 670 Locks are dynamically scoped at the level of the first lock.
 671
 672 =cut
 673
 674 void
 675 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
 676 {
 677     if (!ssv)
 678         return;
 679     recursive_lock_acquire(aTHX_ &ssv->lock);
 680 }
 681
 682 void
 683 Perl_sharedsv_locksv(pTHX_ SV *sv)
 684 {
 685     Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv));
 686 }
 687
 688 =head1 Shared SV Functions
 689
 690 =for apidoc sharedsv_init
 691
 692 Saves a space for keeping SVs wider than an interpreter,
 693 currently only stores a pointer to the first interpreter.
 694
 695 =cut
 696
 697 void
 698 Perl_sharedsv_init(pTHX)
 699 {
 700   dTHXc;
 701   /* This pair leaves us in shared context ... */
 702   PL_sharedsv_space = perl_alloc();
 703   perl_construct(PL_sharedsv_space);
 704   CALLER_CONTEXT;
 705   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
 706   PL_lockhook = &Perl_sharedsv_locksv;
 707   PL_sharehook = &Perl_sharedsv_share;
 708 }
 709
 710 /* Accessor to convert threads::shared::tie objects back shared_sv * */
 711 shared_sv *
 712 SV_to_sharedsv(pTHX_ SV *sv)
 713 {
 714     shared_sv *shared = 0;
 715     if (SvROK(sv))
 716      {
 717       shared = INT2PTR(shared_sv *, SvIV(SvRV(sv)));
 718      }
 719     return shared;
 720 }
 721
 722 MODULE = threads::shared        PACKAGE = threads::shared::tie
 723
 724 PROTOTYPES: DISABLE
 725
 726 void
 727 PUSH(shared_sv *shared, ...)
 728 CODE:
 729         dTHXc;
 730         int i;
 731         for(i = 1; i < items; i++) {
 732             SV* tmp = newSVsv(ST(i));
 733             shared_sv *target;
 734             ENTER_LOCK;
 735             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 736             SHARED_CONTEXT;
 737             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
 738             SHARED_RELEASE;
 739             SvREFCNT_dec(tmp);
 740         }
 741
 742 void
 743 UNSHIFT(shared_sv *shared, ...)
 744 CODE:
 745         dTHXc;
 746         int i;
 747         ENTER_LOCK;
 748         SHARED_CONTEXT;
 749         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
 750         CALLER_CONTEXT;
 751         for(i = 1; i < items; i++) {
 752             SV* tmp = newSVsv(ST(i));
 753             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 754             SHARED_CONTEXT;
 755             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
 756             CALLER_CONTEXT;
 757             SvREFCNT_dec(tmp);
 758         }
 759         LEAVE_LOCK;
 760
 761 void
 762 POP(shared_sv *shared)
 763 CODE:
 764         dTHXc;
 765         SV* sv;
 766         ENTER_LOCK;
 767         SHARED_CONTEXT;
 768         sv = av_pop((AV*)SHAREDSvPTR(shared));
 769         CALLER_CONTEXT;
 770         ST(0) = Nullsv;
 771         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 772         LEAVE_LOCK;
 773         XSRETURN(1);
 774
 775 void
 776 SHIFT(shared_sv *shared)
 777 CODE:
 778         dTHXc;
 779         SV* sv;
 780         ENTER_LOCK;
 781         SHARED_CONTEXT;
 782         sv = av_shift((AV*)SHAREDSvPTR(shared));
 783         CALLER_CONTEXT;
 784         ST(0) = Nullsv;
 785         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 786         LEAVE_LOCK;
 787         XSRETURN(1);
 788
 789 void
 790 EXTEND(shared_sv *shared, IV count)
 791 CODE:
 792         dTHXc;
 793         SHARED_EDIT;
 794         av_extend((AV*)SHAREDSvPTR(shared), count);
 795         SHARED_RELEASE;
 796
 797 void
 798 EXISTS(shared_sv *shared, SV *index)
 799 CODE:
 800         dTHXc;
 801         bool exists;
 802         SHARED_EDIT;
 803         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 804             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
 805         }
 806         else {
 807             exists = hv_exists_ent((HV*) SHAREDSvPTR(shared), index, 0);
 808         }
 809         SHARED_RELEASE;
 810         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
 811         XSRETURN(1);
 812
 813 void
 814 STORESIZE(shared_sv *shared,IV count)
 815 CODE:
 816         dTHXc;
 817         SHARED_EDIT;
 818         av_fill((AV*) SHAREDSvPTR(shared), count);
 819         SHARED_RELEASE;
 820
 821 void
 822 FIRSTKEY(shared_sv *shared)
 823 CODE:
 824         dTHXc;
 825         char* key = NULL;
 826         I32 len = 0;
 827         HE* entry;
 828         ENTER_LOCK;
 829         SHARED_CONTEXT;
 830         hv_iterinit((HV*) SHAREDSvPTR(shared));
 831         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
 832         if (entry) {
 833                 key = hv_iterkey(entry,&len);
 834                 CALLER_CONTEXT;
 835                 ST(0) = sv_2mortal(newSVpv(key, len));
 836         } else {
 837              CALLER_CONTEXT;
 838              ST(0) = &PL_sv_undef;
 839         }
 840         LEAVE_LOCK;
 841         XSRETURN(1);
 842
 843 void
 844 NEXTKEY(shared_sv *shared, SV *oldkey)
 845 CODE:
 846         dTHXc;
 847         char* key = NULL;
 848         I32 len = 0;
 849         HE* entry;
 850         ENTER_LOCK;
 851         SHARED_CONTEXT;
 852         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
 853         if(entry) {
 854                 key = hv_iterkey(entry,&len);
 855                 CALLER_CONTEXT;
 856                 ST(0) = sv_2mortal(newSVpv(key, len));
 857         } else {
 858              CALLER_CONTEXT;
 859              ST(0) = &PL_sv_undef;
 860         }
 861         LEAVE_LOCK;
 862         XSRETURN(1);
 863
 864 MODULE = threads::shared                PACKAGE = threads::shared
 865
 866 PROTOTYPES: ENABLE
 867
 868 void
 869 _thrcnt(SV *ref)
 870         PROTOTYPE: \[$@%]
 871 CODE:
 872         shared_sv *shared;
 873         if(SvROK(ref))
 874             ref = SvRV(ref);
 875         if (shared = Perl_sharedsv_find(aTHX_ ref)) {
 876           if (SHAREDSvPTR(shared)) {
 877             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
 878             XSRETURN(1);
 879           }
 880           else {
 881              Perl_warn(aTHX_ "%_ s=%p has no shared SV",ST(0),shared);
 882           }
 883         }
 884         else {
 885              Perl_warn(aTHX_ "%_ is not shared",ST(0));
 886         }
 887         XSRETURN_UNDEF;
 888
 889 void
 890 share(SV *ref)
 891         PROTOTYPE: \[$@%]
 892         CODE:
 893         if(SvROK(ref))
 894             ref = SvRV(ref);
 895         Perl_sharedsv_share(aTHX, ref);
 896
 897 void
 898 lock_enabled(SV *ref)
 899         PROTOTYPE: \[$@%]
 900         CODE:
 901         shared_sv* shared;
 902         if(SvROK(ref))
 903             ref = SvRV(ref);
 904         shared = Perl_sharedsv_find(aTHX, ref);
 905         if(!shared)
 906            croak("lock can only be used on shared values");
 907         Perl_sharedsv_lock(aTHX_ shared);
 908
 909 void
 910 cond_wait_enabled(SV *ref)
 911         PROTOTYPE: \[$@%]
 912         CODE:
 913         shared_sv* shared;
 914         int locks;
 915         if(SvROK(ref))
 916             ref = SvRV(ref);
 917         shared = Perl_sharedsv_find(aTHX_ ref);
 918         if(!shared)
 919             croak("cond_wait can only be used on shared values");
 920         if(shared->lock.owner != aTHX)
 921             croak("You need a lock before you can cond_wait");
 922         /* Stealing the members of the lock object worries me - NI-S */
 923         MUTEX_LOCK(&shared->lock.mutex);
 924         shared->lock.owner = NULL;
 925         locks = shared->lock.locks = 0;
 926         COND_WAIT(&shared->user_cond, &shared->lock.mutex);
 927         shared->lock.owner = aTHX;
 928         shared->lock.locks = locks;
 929         MUTEX_UNLOCK(&shared->lock.mutex);
 930
 931 void
 932 cond_signal_enabled(SV *ref)
 933         PROTOTYPE: \[$@%]
 934         CODE:
 935         shared_sv* shared;
 936         if(SvROK(ref))
 937             ref = SvRV(ref);
 938         shared = Perl_sharedsv_find(aTHX_ ref);
 939         if(!shared)
 940             croak("cond_signal can only be used on shared values");
 941         COND_SIGNAL(&shared->user_cond);
 942
 943 void
 944 cond_broadcast_enabled(SV *ref)
 945         PROTOTYPE: \[$@%]
 946         CODE:
 947         shared_sv* shared;
 948         if(SvROK(ref))
 949             ref = SvRV(ref);
 950         shared = Perl_sharedsv_find(aTHX_ ref);
 951         if(!shared)
 952             croak("cond_broadcast can only be used on shared values");
 953         COND_BROADCAST(&shared->user_cond);
 954
 955 BOOT:
 956 {
 957      Perl_sharedsv_init(aTHX);
 958 }