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