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  * "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             data = PerlMemShared_malloc(sizeof(shared_sv));
 281             Zero(data,1,shared_sv);
 282             SHAREDSvPTR(data) = ssv;
 283             /* Tag shared side SV with data pointer */
 284             sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
 285                    (char *)data, 0);
 286             recursive_lock_init(aTHX_ &data->lock);
 287             COND_INIT(&data->user_cond);
 288             CALLER_CONTEXT;
 289     }
 290
 291     if (!ssv)
 292         ssv = SHAREDSvPTR(data);
 293     if (!SHAREDSvPTR(data))
 294         SHAREDSvPTR(data) = ssv;
 295
 296     /* If we know type upgrade shared side SV */
 297     if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
 298         SHARED_CONTEXT;
 299         sv_upgrade(ssv, SvTYPE(*psv));
 300         CALLER_CONTEXT;
 301     }
 302
 303     /* Now if requested allocate private SV */
 304     if (psv && !sv) {
 305         *psv = sv = newSV(0);
 306     }
 307
 308     /* Finally if private SV exists check and add magic */
 309     if (sv) {
 310         MAGIC *mg = 0;
 311         if (SvTYPE(sv) < SvTYPE(ssv)) {
 312             sv_upgrade(sv, SvTYPE(ssv));
 313         }
 314         switch(SvTYPE(sv)) {
 315         case SVt_PVAV:
 316         case SVt_PVHV:
 317             if (!(mg = mg_find(sv, PERL_MAGIC_tied))
 318                 || mg->mg_virtual != &sharedsv_array_vtbl
 319                 || (shared_sv *) mg->mg_ptr != data) {
 320                 SV *obj = newSV(0);
 321                 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
 322                 if (mg) {
 323                     sv_unmagic(sv, PERL_MAGIC_tied);
 324                 }
 325                 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
 326                                 (char *) data, 0);
 327                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
 328                 SvREFCNT_inc(ssv);
 329                 SvREFCNT_dec(obj);
 330             }
 331             break;
 332
 333         default:
 334             if ((SvTYPE(sv) < SVt_PVMG)
 335                 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
 336                 || mg->mg_virtual != &sharedsv_scalar_vtbl
 337                 || (shared_sv *) mg->mg_ptr != data) {
 338                 if (mg) {
 339                     sv_unmagic(sv, PERL_MAGIC_shared_scalar);
 340                 }
 341                 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
 342                                 &sharedsv_scalar_vtbl, (char *)data, 0);
 343                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
 344                 SvREFCNT_inc(ssv);
 345             }
 346             break;
 347         }
 348         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
 349     }
 350     return data;
 351 }
 352
 353 void
 354 Perl_sharedsv_free(pTHX_ shared_sv *shared)
 355 {
 356     if (shared) {
 357         dTHXc;
 358         SHARED_EDIT;
 359         SvREFCNT_dec(SHAREDSvPTR(shared));
 360         SHARED_RELEASE;
 361     }
 362 }
 363
 364 void
 365 Perl_sharedsv_share(pTHX_ SV *sv)
 366 {
 367     switch(SvTYPE(sv)) {
 368     case SVt_PVGV:
 369         Perl_croak(aTHX_ "Cannot share globs yet");
 370         break;
 371
 372     case SVt_PVCV:
 373         Perl_croak(aTHX_ "Cannot share subs yet");
 374         break;
 375
 376     default:
 377         ENTER_LOCK;
 378         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
 379         LEAVE_LOCK;
 380         SvSETMAGIC(sv);
 381         break;
 382     }
 383 }
 384
 385 /* MAGIC (in mg.h sense) hooks */
 386
 387 int
 388 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
 389 {
 390     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 391     assert(shared);
 392
 393     ENTER_LOCK;
 394     if (SHAREDSvPTR(shared)) {
 395         if (SvROK(SHAREDSvPTR(shared))) {
 396             SV *obj = Nullsv;
 397             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
 398             sv_setsv_nomg(sv, &PL_sv_undef);
 399             SvRV(sv) = obj;
 400             SvROK_on(sv);
 401         }
 402         else {
 403             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
 404         }
 405     }
 406     LEAVE_LOCK;
 407     return 0;
 408 }
 409
 410 void
 411 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
 412 {
 413     dTHXc;
 414     bool allowed = TRUE;
 415     if (SvROK(sv)) {
 416         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
 417         if (target) {
 418             SV *tmp;
 419             SHARED_CONTEXT;
 420             tmp = newRV(SHAREDSvPTR(target));
 421             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
 422             SvREFCNT_dec(tmp);
 423             CALLER_CONTEXT;
 424         }
 425         else {
 426             allowed = FALSE;
 427         }
 428     }
 429     else {
 430                 SvTEMP_off(sv);
 431         SHARED_CONTEXT;
 432         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
 433         CALLER_CONTEXT;
 434     }
 435     if (!allowed) {
 436         Perl_croak(aTHX_ "Invalid value for shared scalar");
 437     }
 438 }
 439
 440 int
 441 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
 442 {
 443     shared_sv *shared;
 444     ENTER_LOCK;
 445     /* We call associate to potentially upgrade shared side SV */
 446     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
 447     assert(shared);
 448     sharedsv_scalar_store(aTHX_ sv, shared);
 449     LEAVE_LOCK;
 450     return 0;
 451 }
 452
 453 int
 454 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
 455 {
 456     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 457 #if 0
 458     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
 459 #endif
 460     Perl_sharedsv_free(aTHX_ shared);
 461     return 0;
 462 }
 463
 464 int
 465 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 466 {
 467     return 0;
 468 }
 469
 470 /*
 471  * Called during cloning of new threads
 472  */
 473 int
 474 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 475 {
 476     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 477     if (shared) {
 478         SvREFCNT_inc(SHAREDSvPTR(shared));
 479     }
 480     return 0;
 481 }
 482
 483 MGVTBL sharedsv_scalar_vtbl = {
 484  sharedsv_scalar_mg_get,        /* get */
 485  sharedsv_scalar_mg_set,        /* set */
 486  0,                             /* len */
 487  sharedsv_scalar_mg_clear,      /* clear */
 488  sharedsv_scalar_mg_free,       /* free */
 489  0,                             /* copy */
 490  sharedsv_scalar_mg_dup         /* dup */
 491 };
 492
 493 /* Now the arrays/hashes stuff */
 494 int
 495 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
 496 {
 497     dTHXc;
 498     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 499     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
 500     SV** svp;
 501
 502     assert ( shared );
 503     assert ( SHAREDSvPTR(shared) );
 504
 505     ENTER_LOCK;
 506
 507     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 508         assert ( mg->mg_ptr == 0 );
 509         SHARED_CONTEXT;
 510         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
 511     }
 512     else {
 513         char *key = mg->mg_ptr;
 514         STRLEN len = mg->mg_len;
 515         assert ( mg->mg_ptr != 0 );
 516         if (mg->mg_len == HEf_SVKEY) {
 517            key = SvPV((SV *) mg->mg_ptr, len);
 518         }
 519         SHARED_CONTEXT;
 520         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
 521     }
 522     CALLER_CONTEXT;
 523     if (svp) {
 524         /* Exists in the array */
 525         target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
 526         sv_setsv(sv, *svp);
 527     }
 528     else {
 529         /* Not in the array */
 530         sv_setsv(sv, &PL_sv_undef);
 531     }
 532     LEAVE_LOCK;
 533     return 0;
 534 }
 535
 536 int
 537 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
 538 {
 539     dTHXc;
 540     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 541     shared_sv *target;
 542     SV **svp;
 543     /* Theory - SV itself is magically shared - and we have ordered the
 544        magic such that by the time we get here it has been stored
 545        to its shared counterpart
 546      */
 547     ENTER_LOCK;
 548     assert(shared);
 549     assert(SHAREDSvPTR(shared));
 550     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 551         assert ( mg->mg_ptr == 0 );
 552         SHARED_CONTEXT;
 553         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
 554     }
 555     else {
 556         char *key = mg->mg_ptr;
 557         STRLEN len = mg->mg_len;
 558         assert ( mg->mg_ptr != 0 );
 559         if (mg->mg_len == HEf_SVKEY)
 560            key = SvPV((SV *) mg->mg_ptr, len);
 561         SHARED_CONTEXT;
 562         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
 563     }
 564     CALLER_CONTEXT;
 565     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
 566     sharedsv_scalar_store(aTHX_ sv, target);
 567     LEAVE_LOCK;
 568     return 0;
 569 }
 570
 571 int
 572 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
 573 {
 574     dTHXc;
 575     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 576     ENTER_LOCK;
 577     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
 578     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 579         SHARED_CONTEXT;
 580         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
 581     }
 582     else {
 583         char *key = mg->mg_ptr;
 584         STRLEN len = mg->mg_len;
 585         assert ( mg->mg_ptr != 0 );
 586         if (mg->mg_len == HEf_SVKEY)
 587            key = SvPV((SV *) mg->mg_ptr, len);
 588         SHARED_CONTEXT;
 589         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
 590     }
 591     CALLER_CONTEXT;
 592     LEAVE_LOCK;
 593     return 0;
 594 }
 595
 596 int
 597 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
 598 {
 599     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
 600     return 0;
 601 }
 602
 603 int
 604 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 605 {
 606     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 607     SvREFCNT_inc(SHAREDSvPTR(shared));
 608     mg->mg_flags |= MGf_DUP;
 609     return 0;
 610 }
 611
 612 MGVTBL sharedsv_elem_vtbl = {
 613  sharedsv_elem_mg_FETCH,        /* get */
 614  sharedsv_elem_mg_STORE,        /* set */
 615  0,                             /* len */
 616  sharedsv_elem_mg_DELETE,       /* clear */
 617  sharedsv_elem_mg_free,         /* free */
 618  0,                             /* copy */
 619  sharedsv_elem_mg_dup           /* dup */
 620 };
 621
 622 U32
 623 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
 624 {
 625     dTHXc;
 626     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 627     U32 val;
 628     SHARED_EDIT;
 629     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 630         val = av_len((AV*) SHAREDSvPTR(shared));
 631     }
 632     else {
 633         /* not actually defined by tie API but ... */
 634         val = HvKEYS((HV*) SHAREDSvPTR(shared));
 635     }
 636     SHARED_RELEASE;
 637     return val;
 638 }
 639
 640 int
 641 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
 642 {
 643     dTHXc;
 644     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 645     SHARED_EDIT;
 646     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 647         av_clear((AV*) SHAREDSvPTR(shared));
 648     }
 649     else {
 650         hv_clear((HV*) SHAREDSvPTR(shared));
 651     }
 652     SHARED_RELEASE;
 653     return 0;
 654 }
 655
 656 int
 657 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
 658 {
 659     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
 660     return 0;
 661 }
 662
 663 /*
 664  * This is called when perl is about to access an element of
 665  * the array -
 666  */
 667 int
 668 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
 669                        SV *nsv, const char *name, int namlen)
 670 {
 671     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 672     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
 673                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
 674                             name, namlen);
 675     SvREFCNT_inc(SHAREDSvPTR(shared));
 676     nmg->mg_flags |= MGf_DUP;
 677     return 1;
 678 }
 679
 680 int
 681 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 682 {
 683     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 684     SvREFCNT_inc(SHAREDSvPTR(shared));
 685     mg->mg_flags |= MGf_DUP;
 686     return 0;
 687 }
 688
 689 MGVTBL sharedsv_array_vtbl = {
 690  0,                             /* get */
 691  0,                             /* set */
 692  sharedsv_array_mg_FETCHSIZE,   /* len */
 693  sharedsv_array_mg_CLEAR,       /* clear */
 694  sharedsv_array_mg_free,        /* free */
 695  sharedsv_array_mg_copy,        /* copy */
 696  sharedsv_array_mg_dup          /* dup */
 697 };
 698
 699 =for apidoc sharedsv_unlock
 700
 701 Recursively unlocks a shared sv.
 702
 703 =cut
 704
 705 void
 706 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
 707 {
 708     recursive_lock_release(aTHX_ &ssv->lock);
 709 }
 710
 711 =for apidoc sharedsv_lock
 712
 713 Recursive locks on a sharedsv.
 714 Locks are dynamically scoped at the level of the first lock.
 715
 716 =cut
 717
 718 void
 719 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
 720 {
 721     if (!ssv)
 722         return;
 723     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
 724 }
 725
 726 void
 727 Perl_sharedsv_locksv(pTHX_ SV *sv)
 728 {
 729     Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv));
 730 }
 731
 732 =head1 Shared SV Functions
 733
 734 =for apidoc sharedsv_init
 735
 736 Saves a space for keeping SVs wider than an interpreter,
 737 currently only stores a pointer to the first interpreter.
 738
 739 =cut
 740
 741 void
 742 Perl_sharedsv_init(pTHX)
 743 {
 744   dTHXc;
 745   /* This pair leaves us in shared context ... */
 746   PL_sharedsv_space = perl_alloc();
 747   perl_construct(PL_sharedsv_space);
 748   CALLER_CONTEXT;
 749   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
 750   PL_lockhook = &Perl_sharedsv_locksv;
 751   PL_sharehook = &Perl_sharedsv_share;
 752 }
 753
 754 #endif /* USE_ITHREADS */
 755
 756 MODULE = threads::shared        PACKAGE = threads::shared::tie
 757
 758 PROTOTYPES: DISABLE
 759
 760 #ifdef USE_ITHREADS
 761
 762 void
 763 PUSH(shared_sv *shared, ...)
 764 CODE:
 765         dTHXc;
 766         int i;
 767         for(i = 1; i < items; i++) {
 768             SV* tmp = newSVsv(ST(i));
 769             shared_sv *target;
 770             ENTER_LOCK;
 771             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 772             sharedsv_scalar_store(aTHX_ tmp, target);
 773             SHARED_CONTEXT;
 774             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
 775             SHARED_RELEASE;
 776             SvREFCNT_dec(tmp);
 777         }
 778
 779 void
 780 UNSHIFT(shared_sv *shared, ...)
 781 CODE:
 782         dTHXc;
 783         int i;
 784         ENTER_LOCK;
 785         SHARED_CONTEXT;
 786         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
 787         CALLER_CONTEXT;
 788         for(i = 1; i < items; i++) {
 789             SV* tmp = newSVsv(ST(i));
 790             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 791             sharedsv_scalar_store(aTHX_ tmp, target);
 792             SHARED_CONTEXT;
 793             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
 794             CALLER_CONTEXT;
 795             SvREFCNT_dec(tmp);
 796         }
 797         LEAVE_LOCK;
 798
 799 void
 800 POP(shared_sv *shared)
 801 CODE:
 802         dTHXc;
 803         SV* sv;
 804         ENTER_LOCK;
 805         SHARED_CONTEXT;
 806         sv = av_pop((AV*)SHAREDSvPTR(shared));
 807         CALLER_CONTEXT;
 808         ST(0) = Nullsv;
 809         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 810         LEAVE_LOCK;
 811         XSRETURN(1);
 812
 813 void
 814 SHIFT(shared_sv *shared)
 815 CODE:
 816         dTHXc;
 817         SV* sv;
 818         ENTER_LOCK;
 819         SHARED_CONTEXT;
 820         sv = av_shift((AV*)SHAREDSvPTR(shared));
 821         CALLER_CONTEXT;
 822         ST(0) = Nullsv;
 823         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 824         LEAVE_LOCK;
 825         XSRETURN(1);
 826
 827 void
 828 EXTEND(shared_sv *shared, IV count)
 829 CODE:
 830         dTHXc;
 831         SHARED_EDIT;
 832         av_extend((AV*)SHAREDSvPTR(shared), count);
 833         SHARED_RELEASE;
 834
 835 void
 836 STORESIZE(shared_sv *shared,IV count)
 837 CODE:
 838         dTHXc;
 839         SHARED_EDIT;
 840         av_fill((AV*) SHAREDSvPTR(shared), count);
 841         SHARED_RELEASE;
 842
 843
 844
 845
 846 void
 847 EXISTS(shared_sv *shared, SV *index)
 848 CODE:
 849         dTHXc;
 850         bool exists;
 851         SHARED_EDIT;
 852         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 853             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
 854         }
 855         else {
 856             STRLEN len;
 857             char *key = SvPV(index,len);
 858             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
 859         }
 860         SHARED_RELEASE;
 861         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
 862         XSRETURN(1);
 863
 864
 865 void
 866 FIRSTKEY(shared_sv *shared)
 867 CODE:
 868         dTHXc;
 869         char* key = NULL;
 870         I32 len = 0;
 871         HE* entry;
 872         ENTER_LOCK;
 873         SHARED_CONTEXT;
 874         hv_iterinit((HV*) SHAREDSvPTR(shared));
 875         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
 876         if (entry) {
 877                 key = hv_iterkey(entry,&len);
 878                 CALLER_CONTEXT;
 879                 ST(0) = sv_2mortal(newSVpv(key, len));
 880         } else {
 881              CALLER_CONTEXT;
 882              ST(0) = &PL_sv_undef;
 883         }
 884         LEAVE_LOCK;
 885         XSRETURN(1);
 886
 887 void
 888 NEXTKEY(shared_sv *shared, SV *oldkey)
 889 CODE:
 890         dTHXc;
 891         char* key = NULL;
 892         I32 len = 0;
 893         HE* entry;
 894         ENTER_LOCK;
 895         SHARED_CONTEXT;
 896         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
 897         if (entry) {
 898                 key = hv_iterkey(entry,&len);
 899                 CALLER_CONTEXT;
 900                 ST(0) = sv_2mortal(newSVpv(key, len));
 901         } else {
 902              CALLER_CONTEXT;
 903              ST(0) = &PL_sv_undef;
 904         }
 905         LEAVE_LOCK;
 906         XSRETURN(1);
 907
 908 MODULE = threads::shared                PACKAGE = threads::shared
 909
 910 PROTOTYPES: ENABLE
 911
 912 void
 913 _id(SV *ref)
 914         PROTOTYPE: \[$@%]
 915 CODE:
 916         shared_sv *shared;
 917         if(SvROK(ref))
 918             ref = SvRV(ref);
 919         if (shared = Perl_sharedsv_find(aTHX_ ref)) {
 920             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
 921             XSRETURN(1);
 922         }
 923         XSRETURN_UNDEF;
 924
 925
 926 void
 927 _refcnt(SV *ref)
 928         PROTOTYPE: \[$@%]
 929 CODE:
 930         shared_sv *shared;
 931         if(SvROK(ref))
 932             ref = SvRV(ref);
 933         if (shared = Perl_sharedsv_find(aTHX_ ref)) {
 934           if (SHAREDSvPTR(shared)) {
 935             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
 936             XSRETURN(1);
 937           }
 938           else {
 939              Perl_warn(aTHX_ "%_ s=%p has no shared SV",ST(0),shared);
 940           }
 941         }
 942         else {
 943              Perl_warn(aTHX_ "%_ is not shared",ST(0));
 944         }
 945         XSRETURN_UNDEF;
 946
 947 void
 948 share(SV *ref)
 949         PROTOTYPE: \[$@%]
 950         CODE:
 951         if(SvROK(ref))
 952             ref = SvRV(ref);
 953         Perl_sharedsv_share(aTHX, ref);
 954
 955 void
 956 lock_enabled(SV *ref)
 957         PROTOTYPE: \[$@%]
 958         CODE:
 959         shared_sv* shared;
 960         if(SvROK(ref))
 961             ref = SvRV(ref);
 962         shared = Perl_sharedsv_find(aTHX, ref);
 963         if(!shared)
 964            croak("lock can only be used on shared values");
 965         Perl_sharedsv_lock(aTHX_ shared);
 966
 967 void
 968 cond_wait_enabled(SV *ref)
 969         PROTOTYPE: \[$@%]
 970         CODE:
 971         shared_sv* shared;
 972         int locks;
 973         if(SvROK(ref))
 974             ref = SvRV(ref);
 975         shared = Perl_sharedsv_find(aTHX_ ref);
 976         if(!shared)
 977             croak("cond_wait can only be used on shared values");
 978         if(shared->lock.owner != aTHX)
 979             croak("You need a lock before you can cond_wait");
 980         /* Stealing the members of the lock object worries me - NI-S */
 981         MUTEX_LOCK(&shared->lock.mutex);
 982         shared->lock.owner = NULL;
 983         locks = shared->lock.locks;
 984         shared->lock.locks = 0;
 985
 986         /* since we are releasing the lock here we need to tell other
 987         people that is ok to go ahead and use it */
 988         COND_SIGNAL(&shared->lock.cond);
 989         COND_WAIT(&shared->user_cond, &shared->lock.mutex);
 990         while(shared->lock.owner != NULL) {
 991                 COND_WAIT(&shared->lock.cond,&shared->lock.mutex);
 992         }
 993         shared->lock.owner = aTHX;
 994         shared->lock.locks = locks;
 995         MUTEX_UNLOCK(&shared->lock.mutex);
 996
 997 void
 998 cond_signal_enabled(SV *ref)
 999         PROTOTYPE: \[$@%]
1000         CODE:
1001         shared_sv* shared;
1002         if(SvROK(ref))
1003             ref = SvRV(ref);
1004         shared = Perl_sharedsv_find(aTHX_ ref);
1005         if(!shared)
1006             croak("cond_signal can only be used on shared values");
1007         COND_SIGNAL(&shared->user_cond);
1008
1009 void
1010 cond_broadcast_enabled(SV *ref)
1011         PROTOTYPE: \[$@%]
1012         CODE:
1013         shared_sv* shared;
1014         if(SvROK(ref))
1015             ref = SvRV(ref);
1016         shared = Perl_sharedsv_find(aTHX_ ref);
1017         if(!shared)
1018             croak("cond_broadcast can only be used on shared values");
1019         COND_BROADCAST(&shared->user_cond);
1020
1021 #endif /* USE_ITHREADS */
1022
1023 BOOT:
1024 {
1025 #ifdef USE_ITHREADS
1026      Perl_sharedsv_init(aTHX);
1027 #endif /* USE_ITHREADS */
1028 }
1029
1030
1031