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 #if 0
 456     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
 457 #endif
 458     Perl_sharedsv_free(aTHX_ shared);
 459     return 0;
 460 }
 461
 462 int
 463 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 464 {
 465     return 0;
 466 }
 467
 468 /*
 469  * Called during cloning of new threads
 470  */
 471 int
 472 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 473 {
 474     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 475     if (shared) {
 476         SvREFCNT_inc(SHAREDSvPTR(shared));
 477     }
 478     return 0;
 479 }
 480
 481 MGVTBL sharedsv_scalar_vtbl = {
 482  sharedsv_scalar_mg_get,        /* get */
 483  sharedsv_scalar_mg_set,        /* set */
 484  0,                             /* len */
 485  sharedsv_scalar_mg_clear,      /* clear */
 486  sharedsv_scalar_mg_free,       /* free */
 487  0,                             /* copy */
 488  sharedsv_scalar_mg_dup         /* dup */
 489 };
 490
 491 /* Now the arrays/hashes stuff */
 492 int
 493 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
 494 {
 495     dTHXc;
 496     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 497     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
 498     SV** svp;
 499
 500     assert ( shared );
 501     assert ( SHAREDSvPTR(shared) );
 502
 503     ENTER_LOCK;
 504
 505     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 506         assert ( mg->mg_ptr == 0 );
 507         SHARED_CONTEXT;
 508         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
 509     }
 510     else {
 511         char *key = mg->mg_ptr;
 512         STRLEN len = mg->mg_len;
 513         assert ( mg->mg_ptr != 0 );
 514         if (mg->mg_len == HEf_SVKEY) {
 515            key = SvPV((SV *) mg->mg_ptr, len);
 516         }
 517         SHARED_CONTEXT;
 518         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
 519     }
 520     CALLER_CONTEXT;
 521     if (svp) {
 522         /* Exists in the array */
 523         target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
 524         sv_setsv(sv, *svp);
 525     }
 526     else {
 527         /* Not in the array */
 528         sv_setsv(sv, &PL_sv_undef);
 529     }
 530     LEAVE_LOCK;
 531     return 0;
 532 }
 533
 534 int
 535 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
 536 {
 537     dTHXc;
 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     ENTER_LOCK;
 575     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
 576     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 577         SHARED_CONTEXT;
 578         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
 579     }
 580     else {
 581         char *key = mg->mg_ptr;
 582         STRLEN len = mg->mg_len;
 583         assert ( mg->mg_ptr != 0 );
 584         if (mg->mg_len == HEf_SVKEY)
 585            key = SvPV((SV *) mg->mg_ptr, len);
 586         SHARED_CONTEXT;
 587         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
 588     }
 589     CALLER_CONTEXT;
 590     LEAVE_LOCK;
 591     return 0;
 592 }
 593
 594 int
 595 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
 596 {
 597     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
 598     return 0;
 599 }
 600
 601 int
 602 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 603 {
 604     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 605     SvREFCNT_inc(SHAREDSvPTR(shared));
 606     mg->mg_flags |= MGf_DUP;
 607     return 0;
 608 }
 609
 610 MGVTBL sharedsv_elem_vtbl = {
 611  sharedsv_elem_mg_FETCH,        /* get */
 612  sharedsv_elem_mg_STORE,        /* set */
 613  0,                             /* len */
 614  sharedsv_elem_mg_DELETE,       /* clear */
 615  sharedsv_elem_mg_free,         /* free */
 616  0,                             /* copy */
 617  sharedsv_elem_mg_dup           /* dup */
 618 };
 619
 620 U32
 621 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
 622 {
 623     dTHXc;
 624     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 625     U32 val;
 626     SHARED_EDIT;
 627     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 628         val = av_len((AV*) SHAREDSvPTR(shared));
 629     }
 630     else {
 631         /* not actually defined by tie API but ... */
 632         val = HvKEYS((HV*) SHAREDSvPTR(shared));
 633     }
 634     SHARED_RELEASE;
 635     return val;
 636 }
 637
 638 int
 639 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
 640 {
 641     dTHXc;
 642     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 643     SHARED_EDIT;
 644     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 645         av_clear((AV*) SHAREDSvPTR(shared));
 646     }
 647     else {
 648         hv_clear((HV*) SHAREDSvPTR(shared));
 649     }
 650     SHARED_RELEASE;
 651     return 0;
 652 }
 653
 654 int
 655 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
 656 {
 657     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
 658     return 0;
 659 }
 660
 661 /*
 662  * This is called when perl is about to access an element of
 663  * the array -
 664  */
 665 int
 666 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
 667                        SV *nsv, const char *name, int namlen)
 668 {
 669     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 670     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
 671                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
 672                             name, namlen);
 673     SvREFCNT_inc(SHAREDSvPTR(shared));
 674     nmg->mg_flags |= MGf_DUP;
 675     return 1;
 676 }
 677
 678 int
 679 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 680 {
 681     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 682     SvREFCNT_inc(SHAREDSvPTR(shared));
 683     mg->mg_flags |= MGf_DUP;
 684     return 0;
 685 }
 686
 687 MGVTBL sharedsv_array_vtbl = {
 688  0,                             /* get */
 689  0,                             /* set */
 690  sharedsv_array_mg_FETCHSIZE,   /* len */
 691  sharedsv_array_mg_CLEAR,       /* clear */
 692  sharedsv_array_mg_free,        /* free */
 693  sharedsv_array_mg_copy,        /* copy */
 694  sharedsv_array_mg_dup          /* dup */
 695 };
 696
 697 =for apidoc sharedsv_unlock
 698
 699 Recursively unlocks a shared sv.
 700
 701 =cut
 702
 703 void
 704 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
 705 {
 706     recursive_lock_release(aTHX_ &ssv->lock);
 707 }
 708
 709 =for apidoc sharedsv_lock
 710
 711 Recursive locks on a sharedsv.
 712 Locks are dynamically scoped at the level of the first lock.
 713
 714 =cut
 715
 716 void
 717 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
 718 {
 719     if (!ssv)
 720         return;
 721     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
 722 }
 723
 724 void
 725 Perl_sharedsv_locksv(pTHX_ SV *sv)
 726 {
 727     Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv));
 728 }
 729
 730 =head1 Shared SV Functions
 731
 732 =for apidoc sharedsv_init
 733
 734 Saves a space for keeping SVs wider than an interpreter,
 735 currently only stores a pointer to the first interpreter.
 736
 737 =cut
 738
 739 void
 740 Perl_sharedsv_init(pTHX)
 741 {
 742   dTHXc;
 743   /* This pair leaves us in shared context ... */
 744   PL_sharedsv_space = perl_alloc();
 745   perl_construct(PL_sharedsv_space);
 746   CALLER_CONTEXT;
 747   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
 748   PL_lockhook = &Perl_sharedsv_locksv;
 749   PL_sharehook = &Perl_sharedsv_share;
 750 }
 751
 752 MODULE = threads::shared        PACKAGE = threads::shared::tie
 753
 754 PROTOTYPES: DISABLE
 755
 756
 757 void
 758 PUSH(shared_sv *shared, ...)
 759 CODE:
 760         dTHXc;
 761         int i;
 762         for(i = 1; i < items; i++) {
 763             SV* tmp = newSVsv(ST(i));
 764             shared_sv *target;
 765             ENTER_LOCK;
 766             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 767             sharedsv_scalar_store(aTHX_ tmp, target);
 768             SHARED_CONTEXT;
 769             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
 770             SHARED_RELEASE;
 771             SvREFCNT_dec(tmp);
 772         }
 773
 774 void
 775 UNSHIFT(shared_sv *shared, ...)
 776 CODE:
 777         dTHXc;
 778         int i;
 779         ENTER_LOCK;
 780         SHARED_CONTEXT;
 781         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
 782         CALLER_CONTEXT;
 783         for(i = 1; i < items; i++) {
 784             SV* tmp = newSVsv(ST(i));
 785             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 786             sharedsv_scalar_store(aTHX_ tmp, target);
 787             SHARED_CONTEXT;
 788             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
 789             CALLER_CONTEXT;
 790             SvREFCNT_dec(tmp);
 791         }
 792         LEAVE_LOCK;
 793
 794 void
 795 POP(shared_sv *shared)
 796 CODE:
 797         dTHXc;
 798         SV* sv;
 799         ENTER_LOCK;
 800         SHARED_CONTEXT;
 801         sv = av_pop((AV*)SHAREDSvPTR(shared));
 802         CALLER_CONTEXT;
 803         ST(0) = Nullsv;
 804         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 805         LEAVE_LOCK;
 806         XSRETURN(1);
 807
 808 void
 809 SHIFT(shared_sv *shared)
 810 CODE:
 811         dTHXc;
 812         SV* sv;
 813         ENTER_LOCK;
 814         SHARED_CONTEXT;
 815         sv = av_shift((AV*)SHAREDSvPTR(shared));
 816         CALLER_CONTEXT;
 817         ST(0) = Nullsv;
 818         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 819         LEAVE_LOCK;
 820         XSRETURN(1);
 821
 822 void
 823 EXTEND(shared_sv *shared, IV count)
 824 CODE:
 825         dTHXc;
 826         SHARED_EDIT;
 827         av_extend((AV*)SHAREDSvPTR(shared), count);
 828         SHARED_RELEASE;
 829
 830 void
 831 STORESIZE(shared_sv *shared,IV count)
 832 CODE:
 833         dTHXc;
 834         SHARED_EDIT;
 835         av_fill((AV*) SHAREDSvPTR(shared), count);
 836         SHARED_RELEASE;
 837
 838
 839
 840
 841 void
 842 EXISTS(shared_sv *shared, SV *index)
 843 CODE:
 844         dTHXc;
 845         bool exists;
 846         SHARED_EDIT;
 847         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 848             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
 849         }
 850         else {
 851             STRLEN len;
 852             char *key = SvPV(index,len);
 853             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
 854         }
 855         SHARED_RELEASE;
 856         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
 857         XSRETURN(1);
 858
 859
 860 void
 861 FIRSTKEY(shared_sv *shared)
 862 CODE:
 863         dTHXc;
 864         char* key = NULL;
 865         I32 len = 0;
 866         HE* entry;
 867         ENTER_LOCK;
 868         SHARED_CONTEXT;
 869         hv_iterinit((HV*) SHAREDSvPTR(shared));
 870         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
 871         if (entry) {
 872                 key = hv_iterkey(entry,&len);
 873                 CALLER_CONTEXT;
 874                 ST(0) = sv_2mortal(newSVpv(key, len));
 875         } else {
 876              CALLER_CONTEXT;
 877              ST(0) = &PL_sv_undef;
 878         }
 879         LEAVE_LOCK;
 880         XSRETURN(1);
 881
 882 void
 883 NEXTKEY(shared_sv *shared, SV *oldkey)
 884 CODE:
 885         dTHXc;
 886         char* key = NULL;
 887         I32 len = 0;
 888         HE* entry;
 889         ENTER_LOCK;
 890         SHARED_CONTEXT;
 891         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
 892         if (entry) {
 893                 key = hv_iterkey(entry,&len);
 894                 CALLER_CONTEXT;
 895                 ST(0) = sv_2mortal(newSVpv(key, len));
 896         } else {
 897              CALLER_CONTEXT;
 898              ST(0) = &PL_sv_undef;
 899         }
 900         LEAVE_LOCK;
 901         XSRETURN(1);
 902
 903 MODULE = threads::shared                PACKAGE = threads::shared
 904
 905 PROTOTYPES: ENABLE
 906
 907 void
 908 _id(SV *ref)
 909         PROTOTYPE: \[$@%]
 910 CODE:
 911         shared_sv *shared;
 912         if(SvROK(ref))
 913             ref = SvRV(ref);
 914         if (shared = Perl_sharedsv_find(aTHX_ ref)) {
 915             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
 916             XSRETURN(1);
 917         }
 918         XSRETURN_UNDEF;
 919
 920
 921 void
 922 _refcnt(SV *ref)
 923         PROTOTYPE: \[$@%]
 924 CODE:
 925         shared_sv *shared;
 926         if(SvROK(ref))
 927             ref = SvRV(ref);
 928         if (shared = Perl_sharedsv_find(aTHX_ ref)) {
 929           if (SHAREDSvPTR(shared)) {
 930             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
 931             XSRETURN(1);
 932           }
 933           else {
 934              Perl_warn(aTHX_ "%_ s=%p has no shared SV",ST(0),shared);
 935           }
 936         }
 937         else {
 938              Perl_warn(aTHX_ "%_ is not shared",ST(0));
 939         }
 940         XSRETURN_UNDEF;
 941
 942 void
 943 share(SV *ref)
 944         PROTOTYPE: \[$@%]
 945         CODE:
 946         if(SvROK(ref))
 947             ref = SvRV(ref);
 948         Perl_sharedsv_share(aTHX, ref);
 949
 950 void
 951 lock_enabled(SV *ref)
 952         PROTOTYPE: \[$@%]
 953         CODE:
 954         shared_sv* shared;
 955         if(SvROK(ref))
 956             ref = SvRV(ref);
 957         shared = Perl_sharedsv_find(aTHX, ref);
 958         if(!shared)
 959            croak("lock can only be used on shared values");
 960         Perl_sharedsv_lock(aTHX_ shared);
 961
 962 void
 963 cond_wait_enabled(SV *ref)
 964         PROTOTYPE: \[$@%]
 965         CODE:
 966         shared_sv* shared;
 967         int locks;
 968         if(SvROK(ref))
 969             ref = SvRV(ref);
 970         shared = Perl_sharedsv_find(aTHX_ ref);
 971         if(!shared)
 972             croak("cond_wait can only be used on shared values");
 973         if(shared->lock.owner != aTHX)
 974             croak("You need a lock before you can cond_wait");
 975         /* Stealing the members of the lock object worries me - NI-S */
 976         MUTEX_LOCK(&shared->lock.mutex);
 977         shared->lock.owner = NULL;
 978         locks = shared->lock.locks = 0;
 979         COND_WAIT(&shared->user_cond, &shared->lock.mutex);
 980         shared->lock.owner = aTHX;
 981         shared->lock.locks = locks;
 982         MUTEX_UNLOCK(&shared->lock.mutex);
 983
 984 void
 985 cond_signal_enabled(SV *ref)
 986         PROTOTYPE: \[$@%]
 987         CODE:
 988         shared_sv* shared;
 989         if(SvROK(ref))
 990             ref = SvRV(ref);
 991         shared = Perl_sharedsv_find(aTHX_ ref);
 992         if(!shared)
 993             croak("cond_signal can only be used on shared values");
 994         COND_SIGNAL(&shared->user_cond);
 995
 996 void
 997 cond_broadcast_enabled(SV *ref)
 998         PROTOTYPE: \[$@%]
 999         CODE:
1000         shared_sv* shared;
1001         if(SvROK(ref))
1002             ref = SvRV(ref);
1003         shared = Perl_sharedsv_find(aTHX_ ref);
1004         if(!shared)
1005             croak("cond_broadcast can only be used on shared values");
1006         COND_BROADCAST(&shared->user_cond);
1007
1008 BOOT:
1009 {
1010      Perl_sharedsv_init(aTHX);
1011 }