ext/threads/shared/shared.xs

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