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