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