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 * Contributed by Arthur Bergman arthur@contiller.se
  12 *
  13 * "Hand any two wizards a piece of rope and they would instinctively pull in
  14 * opposite directions."
  15 *                         --Sourcery
  16 *
  17 */
  18
  19 #define PERL_NO_GET_CONTEXT
  20 #include "EXTERN.h"
  21 #include "perl.h"
  22 #include "XSUB.h"
  23
  24 PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
  25 perl_mutex       PL_sharedsv_space_mutex;       /* Mutex protecting the shared sv space */
  26
  27 typedef struct {
  28     SV                 *sv;             /* The actual SV */
  29     perl_mutex          mutex;          /* Our mutex */
  30     perl_cond           cond;           /* Our condition variable */
  31     perl_cond           user_cond;      /* For user-level conditions */
  32     IV                  locks;          /* Number of locks held */
  33     PerlInterpreter    *owner;          /* Who owns the lock? */
  34     U16                 index;          /* Update index */
  35 } shared_sv;
  36
  37 #define SHAREDSvGET(a)      (a->sv)
  38 #define SHAREDSvLOCK(a)     Perl_sharedsv_lock(aTHX_ a)
  39 #define SHAREDSvUNLOCK(a)   Perl_sharedsv_unlock(aTHX_ a)
  40
  41 #define SHAREDSvEDIT(a)     STMT_START {                                \
  42                                 MUTEX_LOCK(&PL_sharedsv_space_mutex);   \
  43                                 SHAREDSvLOCK((a));                      \
  44                                 PERL_SET_CONTEXT(PL_sharedsv_space);    \
  45                             } STMT_END
  46
  47 #define SHAREDSvRELEASE(a)  STMT_START {                                \
  48                                 PERL_SET_CONTEXT((a)->owner);           \
  49                                 SHAREDSvUNLOCK((a));                    \
  50                                 MUTEX_UNLOCK(&PL_sharedsv_space_mutex); \
  51                             } STMT_END
  52
  53 extern void     Perl_sharedsv_init(pTHX);
  54 extern shared_sv*       Perl_sharedsv_new(pTHX);
  55 extern shared_sv*       Perl_sharedsv_find(pTHX_ SV* sv);
  56 extern void     Perl_sharedsv_lock(pTHX_ shared_sv* ssv);
  57 extern void     Perl_sharedsv_unlock(pTHX_ shared_sv* ssv);
  58 extern void     Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv);
  59 extern void     Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv);
  60 extern void     Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv);
  61
  62 /*
  63   Shared SV
  64
  65   Shared SV is a structure for keeping the backend storage
  66   of shared svs.
  67
  68 */
  69
  70 /*
  71
  72  =head1 Shared SV Functions
  73
  74  =for apidoc sharedsv_init
  75
  76 Saves a space for keeping SVs wider than an interpreter,
  77 currently only stores a pointer to the first interpreter.
  78
  79  =cut
  80
  81 */
  82
  83 void
  84 Perl_sharedsv_init(pTHX)
  85 {
  86   PerlInterpreter* old_context = PERL_GET_CONTEXT;
  87   PL_sharedsv_space = perl_alloc();
  88   perl_construct(PL_sharedsv_space);
  89   PERL_SET_CONTEXT(old_context);
  90   MUTEX_INIT(&PL_sharedsv_space_mutex);
  91 }
  92
  93 /*
  94  =for apidoc sharedsv_new
  95
  96 Allocates a new shared sv struct, you must yourself create the SV/AV/HV.
  97  =cut
  98 */
  99
 100 shared_sv *
 101 Perl_sharedsv_new(pTHX)
 102 {
 103     shared_sv* ssv;
 104     New(2555,ssv,1,shared_sv);
 105     MUTEX_INIT(&ssv->mutex);
 106     COND_INIT(&ssv->cond);
 107     COND_INIT(&ssv->user_cond);
 108     ssv->owner = 0;
 109     ssv->locks = 0;
 110     ssv->index = 0;
 111     return ssv;
 112 }
 113
 114
 115 /*
 116  =for apidoc sharedsv_find
 117
 118 Tries to find if a given SV has a shared backend, either by
 119 looking at magic, or by checking if it is tied again threads::shared.
 120
 121  =cut
 122 */
 123
 124 shared_sv *
 125 Perl_sharedsv_find(pTHX_ SV* sv)
 126 {
 127   /* does all it can to find a shared_sv struct, returns NULL otherwise */
 128     shared_sv* ssv = NULL;
 129     switch (SvTYPE(sv)) {
 130         case SVt_PVMG:
 131         case SVt_PVAV:
 132         case SVt_PVHV: {
 133             MAGIC* mg = mg_find(sv, PERL_MAGIC_ext);
 134             if(mg) {
 135                 if(strcmp(mg->mg_ptr,"threads::shared"))
 136                     break;
 137                 ssv = INT2PTR(shared_sv *, SvIV(mg->mg_obj));
 138                 break;
 139              }
 140
 141              mg = mg_find(sv,PERL_MAGIC_tied);
 142              if(mg) {
 143                  SV* obj = SvTIED_obj(sv,mg);
 144                  if(sv_derived_from(obj, "threads::shared"))
 145                      ssv = INT2PTR(shared_sv *, SvIV(SvRV(obj)));
 146                  break;
 147              }
 148         }
 149     }
 150     return ssv;
 151 }
 152
 153 /*
 154  =for apidoc sharedsv_lock
 155
 156 Recursive locks on a sharedsv.
 157 Locks are dynamically scoped at the level of the first lock.
 158  =cut
 159 */
 160 void
 161 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
 162 {
 163     if(!ssv)
 164         return;
 165     MUTEX_LOCK(&ssv->mutex);
 166     if(ssv->owner && ssv->owner == my_perl) {
 167         ssv->locks++;
 168         MUTEX_UNLOCK(&ssv->mutex);
 169         return;
 170     }
 171     while(ssv->owner)
 172       COND_WAIT(&ssv->cond,&ssv->mutex);
 173     ssv->locks++;
 174     ssv->owner = my_perl;
 175     if(ssv->locks == 1)
 176         SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv);
 177     MUTEX_UNLOCK(&ssv->mutex);
 178 }
 179
 180 /*
 181  =for apidoc sharedsv_unlock
 182
 183 Recursively unlocks a shared sv.
 184
 185  =cut
 186 */
 187
 188 void
 189 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
 190 {
 191     MUTEX_LOCK(&ssv->mutex);
 192     if(ssv->owner != my_perl) {
 193         Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own");
 194         MUTEX_UNLOCK(&ssv->mutex);
 195         return;
 196     }
 197
 198     if(--ssv->locks == 0) {
 199         ssv->owner = NULL;
 200         COND_SIGNAL(&ssv->cond);
 201     }
 202     MUTEX_UNLOCK(&ssv->mutex);
 203  }
 204
 205 void
 206 Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv)
 207 {
 208     MUTEX_LOCK(&ssv->mutex);
 209     if(ssv->owner != my_perl) {
 210         MUTEX_UNLOCK(&ssv->mutex);
 211         return;
 212     }
 213     ssv->locks = 0;
 214     ssv->owner = NULL;
 215     COND_SIGNAL(&ssv->cond);
 216     MUTEX_UNLOCK(&ssv->mutex);
 217 }
 218
 219 /*
 220  =for apidoc sharedsv_thrcnt_inc
 221
 222 Increments the threadcount of a sharedsv.
 223  =cut
 224 */
 225 void
 226 Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv)
 227 {
 228   SHAREDSvLOCK(ssv);
 229   SvREFCNT_inc(ssv->sv);
 230   SHAREDSvUNLOCK(ssv);
 231 }
 232
 233 /*
 234  =for apidoc sharedsv_thrcnt_dec
 235
 236 Decrements the threadcount of a shared sv. When a threads frontend is freed
 237 this function should be called.
 238
 239  =cut
 240 */
 241
 242 void
 243 Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv)
 244 {
 245     SV* sv;
 246     SHAREDSvLOCK(ssv);
 247     sv = SHAREDSvGET(ssv);
 248     if (SvREFCNT(sv) == 1) {
 249         switch (SvTYPE(sv)) {
 250         case SVt_RV:
 251             if (SvROK(sv))
 252             Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(SvRV(sv))));
 253             break;
 254         case SVt_PVAV: {
 255             SV **src_ary  = AvARRAY((AV *)sv);
 256             SSize_t items = AvFILLp((AV *)sv) + 1;
 257
 258             while (items-- > 0) {
 259             if(SvTYPE(*src_ary))
 260                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(*src_ary)));
 261                 src_ary++;
 262             }
 263             break;
 264         }
 265         case SVt_PVHV: {
 266             HE *entry;
 267             (void)hv_iterinit((HV *)sv);
 268             while ((entry = hv_iternext((HV *)sv)))
 269                 Perl_sharedsv_thrcnt_dec(
 270                     aTHX_ INT2PTR(shared_sv *, SvIV(hv_iterval((HV *)sv, entry)))
 271                 );
 272             break;
 273         }
 274         }
 275     }
 276     Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv));
 277     SHAREDSvUNLOCK(ssv);
 278 }
 279
 280
 281 MGVTBL svtable;
 282
 283 #define shared_sv_attach_sv(sv,shared) Perl_shared_sv_attach_sv(aTHX_ sv,shared)
 284
 285 SV* Perl_shared_sv_attach_sv (pTHX_ SV* sv, shared_sv* shared) {
 286     HV* shared_hv = get_hv("threads::shared::shared", FALSE);
 287     SV* id = newSViv(PTR2IV(shared));
 288     STRLEN length = sv_len(id);
 289     SV* tiedobject;
 290     SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0);
 291     if(tiedobject_) {
 292         tiedobject = (*tiedobject_);
 293         if(sv) {
 294             SvROK_on(sv);
 295             SvRV(sv) = SvRV(tiedobject);
 296         } else {
 297             sv = newRV(SvRV(tiedobject));
 298         }
 299     } else {
 300         switch(SvTYPE(SHAREDSvGET(shared))) {
 301             case SVt_PVAV: {
 302                 SV* weakref;
 303                 SV* obj_ref = newSViv(0);
 304                 SV* obj = newSVrv(obj_ref,"threads::shared::av");
 305                 AV* hv = newAV();
 306                 sv_setiv(obj,PTR2IV(shared));
 307                 weakref = newRV((SV*)hv);
 308                 sv = newRV_noinc((SV*)hv);
 309                 sv_rvweaken(weakref);
 310                 sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0);
 311                 hv_store(shared_hv, SvPV(id,length), length, weakref, 0);
 312                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 313             }
 314             break;
 315             case SVt_PVHV: {
 316                 SV* weakref;
 317                 SV* obj_ref = newSViv(0);
 318                 SV* obj = newSVrv(obj_ref,"threads::shared::hv");
 319                 HV* hv = newHV();
 320                 sv_setiv(obj,PTR2IV(shared));
 321                 weakref = newRV((SV*)hv);
 322                 sv = newRV_noinc((SV*)hv);
 323                 sv_rvweaken(weakref);
 324                 sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0);
 325                 hv_store(shared_hv, SvPV(id,length), length, weakref, 0);
 326                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 327             }
 328             break;
 329             default: {
 330                 MAGIC* shared_magic;
 331                 SV* value = newSVsv(SHAREDSvGET(shared));
 332                 SV* obj = newSViv(PTR2IV(shared));
 333                 sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
 334                 shared_magic = mg_find(value, PERL_MAGIC_ext);
 335                 shared_magic->mg_virtual = &svtable;
 336                 shared_magic->mg_obj = newSViv(PTR2IV(shared));
 337                 shared_magic->mg_flags |= MGf_REFCOUNTED;
 338                 shared_magic->mg_private = 0;
 339                 SvMAGICAL_on(value);
 340                 sv = newRV_noinc(value);
 341                 value = newRV(value);
 342                 sv_rvweaken(value);
 343                 hv_store(shared_hv, SvPV(id,length),length, value, 0);
 344                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 345             }
 346
 347         }
 348     }
 349     return sv;
 350 }
 351
 352
 353 int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
 354     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
 355     SHAREDSvLOCK(shared);
 356     if(mg->mg_private != shared->index) {
 357         if(SvROK(SHAREDSvGET(shared))) {
 358             shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared))));
 359             shared_sv_attach_sv(sv, target);
 360         } else {
 361             sv_setsv(sv, SHAREDSvGET(shared));
 362         }
 363         mg->mg_private = shared->index;
 364     }
 365     SHAREDSvUNLOCK(shared);
 366
 367     return 0;
 368 }
 369
 370 int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
 371     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
 372     SHAREDSvLOCK(shared);
 373     if(SvROK(SHAREDSvGET(shared)))
 374         Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared)))));
 375     if(SvROK(sv)) {
 376         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
 377         if(!target) {
 378             sv_setsv(sv,SHAREDSvGET(shared));
 379             SHAREDSvUNLOCK(shared);
 380             Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
 381         }
 382         SHAREDSvEDIT(shared);
 383         Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
 384         SHAREDSvGET(shared) = newRV_noinc(newSViv(PTR2IV(target)));
 385     } else {
 386             SHAREDSvEDIT(shared);
 387         sv_setsv(SHAREDSvGET(shared), sv);
 388     }
 389     shared->index++;
 390     mg->mg_private = shared->index;
 391     SHAREDSvRELEASE(shared);
 392     if(SvROK(SHAREDSvGET(shared)))
 393        Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared)))));
 394     SHAREDSvUNLOCK(shared);
 395     return 0;
 396 }
 397
 398 int
 399 shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg)
 400 {
 401     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
 402     if (shared) {
 403         HV* shared_hv = get_hv("threads::shared::shared", FALSE);
 404         SV* id = newSViv(PTR2IV(shared));
 405         STRLEN length = sv_len(id);
 406         hv_delete(shared_hv, SvPV(id,length), length,0);
 407         Perl_sharedsv_thrcnt_dec(aTHX_ shared);
 408     }
 409     return 0;
 410 }
 411
 412 MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg),
 413                   MEMBER_TO_FPTR(shared_sv_store_mg),
 414                   0,
 415                   0,
 416                   MEMBER_TO_FPTR(shared_sv_destroy_mg)
 417 };
 418
 419 MODULE = threads::shared                PACKAGE = threads::shared
 420
 421
 422 PROTOTYPES: ENABLE
 423
 424
 425 SV*
 426 ptr(ref)
 427         SV* ref
 428         CODE:
 429         RETVAL = newSViv(SvIV(SvRV(ref)));
 430         OUTPUT:
 431         RETVAL
 432
 433
 434 SV*
 435 _thrcnt(ref)
 436         SV* ref
 437         CODE:
 438         shared_sv* shared;
 439         if(SvROK(ref))
 440             ref = SvRV(ref);
 441         shared = Perl_sharedsv_find(aTHX, ref);
 442         if(!shared)
 443            croak("thrcnt can only be used on shared values");
 444         SHAREDSvLOCK(shared);
 445         RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
 446         SHAREDSvUNLOCK(shared);
 447         OUTPUT:
 448         RETVAL
 449
 450
 451 void
 452 thrcnt_inc(ref,perl)
 453         SV* ref
 454         SV* perl
 455         CODE:
 456         shared_sv* shared;
 457         PerlInterpreter* origperl = INT2PTR(PerlInterpreter*, SvIV(perl));
 458         PerlInterpreter* oldperl = PERL_GET_CONTEXT;
 459         if(SvROK(ref))
 460             ref = SvRV(ref);
 461         shared = Perl_sharedsv_find(aTHX, ref);
 462         if(!shared)
 463            croak("thrcnt can only be used on shared values");
 464         PERL_SET_CONTEXT(origperl);
 465         Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 466         PERL_SET_CONTEXT(oldperl);
 467
 468 void
 469 _thrcnt_dec(ref)
 470         SV* ref
 471         CODE:
 472         shared_sv* shared = INT2PTR(shared_sv*, SvIV(ref));
 473         if(!shared)
 474            croak("thrcnt can only be used on shared values");
 475         Perl_sharedsv_thrcnt_dec(aTHX_ shared);
 476
 477 void
 478 unlock_enabled(ref)
 479         SV* ref
 480         PROTOTYPE: \[$@%]
 481         CODE:
 482         shared_sv* shared;
 483         if(SvROK(ref))
 484             ref = SvRV(ref);
 485         shared = Perl_sharedsv_find(aTHX, ref);
 486         if(!shared)
 487            croak("unlock can only be used on shared values");
 488         SHAREDSvUNLOCK(shared);
 489
 490 void
 491 lock_enabled(ref)
 492         SV* ref
 493         CODE:
 494         shared_sv* shared;
 495         if(SvROK(ref))
 496             ref = SvRV(ref);
 497         shared = Perl_sharedsv_find(aTHX, ref);
 498         if(!shared)
 499            croak("lock can only be used on shared values");
 500         SHAREDSvLOCK(shared);
 501
 502
 503 void
 504 cond_wait_enabled(ref)
 505         SV* ref
 506         PROTOTYPE: \[$@%]
 507         CODE:
 508         shared_sv* shared;
 509         int locks;
 510         if(SvROK(ref))
 511             ref = SvRV(ref);
 512         shared = Perl_sharedsv_find(aTHX_ ref);
 513         if(!shared)
 514             croak("cond_wait can only be used on shared values");
 515         if(shared->owner != PERL_GET_CONTEXT)
 516             croak("You need a lock before you can cond_wait");
 517         MUTEX_LOCK(&shared->mutex);
 518         shared->owner = NULL;
 519         locks = shared->locks = 0;
 520         COND_WAIT(&shared->user_cond, &shared->mutex);
 521         shared->owner = PERL_GET_CONTEXT;
 522         shared->locks = locks;
 523         MUTEX_UNLOCK(&shared->mutex);
 524
 525 void cond_signal_enabled(ref)
 526         SV* ref
 527         PROTOTYPE: \[$@%]
 528         CODE:
 529         shared_sv* shared;
 530         if(SvROK(ref))
 531             ref = SvRV(ref);
 532         shared = Perl_sharedsv_find(aTHX_ ref);
 533         if(!shared)
 534             croak("cond_signal can only be used on shared values");
 535         COND_SIGNAL(&shared->user_cond);
 536
 537
 538 void cond_broadcast_enabled(ref)
 539         SV* ref
 540         PROTOTYPE: \[$@%]
 541         CODE:
 542         shared_sv* shared;
 543         if(SvROK(ref))
 544             ref = SvRV(ref);
 545         shared = Perl_sharedsv_find(aTHX_ ref);
 546         if(!shared)
 547             croak("cond_broadcast can only be used on shared values");
 548         COND_BROADCAST(&shared->user_cond);
 549
 550 MODULE = threads::shared                PACKAGE = threads::shared::sv
 551
 552 SV*
 553 new(class, value)
 554         SV* class
 555         SV* value
 556         CODE:
 557         shared_sv* shared = Perl_sharedsv_new(aTHX);
 558         MAGIC* shared_magic;
 559         SV* obj = newSViv(PTR2IV(shared));
 560         SHAREDSvEDIT(shared);
 561         SHAREDSvGET(shared) = newSVsv(value);
 562         SHAREDSvRELEASE(shared);
 563         sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
 564         shared_magic = mg_find(value, PERL_MAGIC_ext);
 565         shared_magic->mg_virtual = &svtable;
 566         shared_magic->mg_obj = newSViv(PTR2IV(shared));
 567         shared_magic->mg_flags |= MGf_REFCOUNTED;
 568         shared_magic->mg_private = 0;
 569         SvMAGICAL_on(value);
 570         RETVAL = obj;
 571         OUTPUT:
 572         RETVAL
 573
 574
 575 MODULE = threads::shared                PACKAGE = threads::shared::av
 576
 577 SV*
 578 new(class, value)
 579         SV* class
 580         SV* value
 581         CODE:
 582         shared_sv* shared = Perl_sharedsv_new(aTHX);
 583         SV* obj = newSViv(PTR2IV(shared));
 584         SHAREDSvEDIT(shared);
 585         SHAREDSvGET(shared) = (SV*) newAV();
 586         SHAREDSvRELEASE(shared);
 587         RETVAL = obj;
 588         OUTPUT:
 589         RETVAL
 590
 591 void
 592 STORE(self, index, value)
 593         SV* self
 594         SV* index
 595         SV* value
 596         CODE:
 597         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 598         shared_sv* slot;
 599         SV* aentry;
 600         SV** aentry_;
 601         if(SvROK(value)) {
 602             shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value));
 603             if(!target) {
 604                  Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
 605             }
 606             value = newRV_noinc(newSViv(PTR2IV(target)));
 607         }
 608         SHAREDSvLOCK(shared);
 609         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index), 0);
 610         if(aentry_ && SvIV((*aentry_))) {
 611             aentry = (*aentry_);
 612             slot = INT2PTR(shared_sv*, SvIV(aentry));
 613             if(SvROK(SHAREDSvGET(slot)))
 614                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 615             SHAREDSvEDIT(slot);
 616             sv_setsv(SHAREDSvGET(slot), value);
 617             SHAREDSvRELEASE(slot);
 618         } else {
 619             slot = Perl_sharedsv_new(aTHX);
 620             SHAREDSvEDIT(shared);
 621             SHAREDSvGET(slot) = newSVsv(value);
 622             aentry = newSViv(PTR2IV(slot));
 623             av_store((AV*) SHAREDSvGET(shared), SvIV(index), aentry);
 624             SHAREDSvRELEASE(shared);
 625         }
 626         if(SvROK(SHAREDSvGET(slot)))
 627             Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 628
 629         SHAREDSvUNLOCK(shared);
 630
 631 SV*
 632 FETCH(self, index)
 633         SV* self
 634         SV* index
 635         CODE:
 636         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 637         shared_sv* slot;
 638         SV* aentry;
 639         SV** aentry_;
 640         SV* retval;
 641         SHAREDSvLOCK(shared);
 642         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index),0);
 643         if(aentry_) {
 644             aentry = (*aentry_);
 645             if(SvTYPE(aentry) == SVt_NULL) {
 646                 retval = &PL_sv_undef;
 647             } else {
 648                 slot = INT2PTR(shared_sv*, SvIV(aentry));
 649                 if(SvROK(SHAREDSvGET(slot))) {
 650                      shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 651                      retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 652                 } else {
 653                      retval = newSVsv(SHAREDSvGET(slot));
 654                 }
 655             }
 656         } else {
 657             retval = &PL_sv_undef;
 658         }
 659         SHAREDSvUNLOCK(shared);
 660         RETVAL = retval;
 661         OUTPUT:
 662         RETVAL
 663
 664 void
 665 PUSH(self, ...)
 666         SV* self
 667         CODE:
 668         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 669         int i;
 670         SHAREDSvLOCK(shared);
 671         for(i = 1; i < items; i++) {
 672             shared_sv* slot = Perl_sharedsv_new(aTHX);
 673             SV* tmp = ST(i);
 674             if(SvROK(tmp)) {
 675                  shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp));
 676                  if(!target) {
 677                      Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
 678                  }
 679                  tmp = newRV_noinc(newSViv(PTR2IV(target)));
 680             }
 681             SHAREDSvEDIT(slot);
 682             SHAREDSvGET(slot) = newSVsv(tmp);
 683             av_push((AV*) SHAREDSvGET(shared), newSViv(PTR2IV(slot)));
 684             SHAREDSvRELEASE(slot);
 685             if(SvROK(SHAREDSvGET(slot)))
 686                 Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 687         }
 688         SHAREDSvUNLOCK(shared);
 689
 690 void
 691 UNSHIFT(self, ...)
 692         SV* self
 693         CODE:
 694         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 695         int i;
 696         SHAREDSvLOCK(shared);
 697         SHAREDSvEDIT(shared);
 698         av_unshift((AV*)SHAREDSvGET(shared), items - 1);
 699         SHAREDSvRELEASE(shared);
 700         for(i = 1; i < items; i++) {
 701             shared_sv* slot = Perl_sharedsv_new(aTHX);
 702             SV* tmp = ST(i);
 703             if(SvROK(tmp)) {
 704                  shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp));
 705                  if(!target) {
 706                      Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
 707                  }
 708                  tmp = newRV_noinc(newSViv(PTR2IV(target)));
 709             }
 710             SHAREDSvEDIT(slot);
 711             SHAREDSvGET(slot) = newSVsv(tmp);
 712             av_store((AV*) SHAREDSvGET(shared), i - 1, newSViv(PTR2IV(slot)));
 713             SHAREDSvRELEASE(slot);
 714             if(SvROK(SHAREDSvGET(slot)))
 715                 Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 716         }
 717         SHAREDSvUNLOCK(shared);
 718
 719 SV*
 720 POP(self)
 721         SV* self
 722         CODE:
 723         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 724         shared_sv* slot;
 725         SV* retval;
 726         SHAREDSvLOCK(shared);
 727         SHAREDSvEDIT(shared);
 728         retval = av_pop((AV*)SHAREDSvGET(shared));
 729         SHAREDSvRELEASE(shared);
 730         if(retval && SvIV(retval)) {
 731             slot = INT2PTR(shared_sv*, SvIV(retval));
 732             if(SvROK(SHAREDSvGET(slot))) {
 733                  shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 734                  retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 735             } else {
 736                  retval = newSVsv(SHAREDSvGET(slot));
 737             }
 738             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 739         } else {
 740             retval = &PL_sv_undef;
 741         }
 742         SHAREDSvUNLOCK(shared);
 743         RETVAL = retval;
 744         OUTPUT:
 745         RETVAL
 746
 747
 748 SV*
 749 SHIFT(self)
 750         SV* self
 751         CODE:
 752         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 753         shared_sv* slot;
 754         SV* retval;
 755         SHAREDSvLOCK(shared);
 756         SHAREDSvEDIT(shared);
 757         retval = av_shift((AV*)SHAREDSvGET(shared));
 758         SHAREDSvRELEASE(shared);
 759         if(retval && SvIV(retval)) {
 760             slot = INT2PTR(shared_sv*, SvIV(retval));
 761             if(SvROK(SHAREDSvGET(slot))) {
 762                  shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 763                  retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 764             } else {
 765                  retval = newSVsv(SHAREDSvGET(slot));
 766             }
 767             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 768         } else {
 769             retval = &PL_sv_undef;
 770         }
 771         SHAREDSvUNLOCK(shared);
 772         RETVAL = retval;
 773         OUTPUT:
 774         RETVAL
 775
 776 void
 777 CLEAR(self)
 778         SV* self
 779         CODE:
 780         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 781         shared_sv* slot;
 782         SV** svp;
 783         I32 i;
 784         SHAREDSvLOCK(shared);
 785         svp = AvARRAY((AV*)SHAREDSvGET(shared));
 786         i   = AvFILLp((AV*)SHAREDSvGET(shared));
 787         while ( i >= 0) {
 788             if(SvIV(svp[i])) {
 789                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(svp[i])));
 790             }
 791             i--;
 792         }
 793         SHAREDSvEDIT(shared);
 794         av_clear((AV*)SHAREDSvGET(shared));
 795         SHAREDSvRELEASE(shared);
 796         SHAREDSvUNLOCK(shared);
 797
 798 void
 799 EXTEND(self, count)
 800         SV* self
 801         SV* count
 802         CODE:
 803         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 804         SHAREDSvEDIT(shared);
 805         av_extend((AV*)SHAREDSvGET(shared), (I32) SvIV(count));
 806         SHAREDSvRELEASE(shared);
 807
 808
 809
 810
 811 SV*
 812 EXISTS(self, index)
 813         SV* self
 814         SV* index
 815         CODE:
 816         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 817         I32 exists;
 818         SHAREDSvLOCK(shared);
 819         exists = av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index));
 820         if(exists) {
 821             RETVAL = &PL_sv_yes;
 822         } else {
 823             RETVAL = &PL_sv_no;
 824         }
 825         SHAREDSvUNLOCK(shared);
 826
 827 void
 828 STORESIZE(self,count)
 829         SV* self
 830         SV* count
 831         CODE:
 832         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 833         SHAREDSvEDIT(shared);
 834         av_fill((AV*) SHAREDSvGET(shared), (I32) SvIV(count));
 835         SHAREDSvRELEASE(shared);
 836
 837 SV*
 838 FETCHSIZE(self)
 839         SV* self
 840         CODE:
 841         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 842         SHAREDSvLOCK(shared);
 843         RETVAL = newSViv(av_len((AV*) SHAREDSvGET(shared)) + 1);
 844         SHAREDSvUNLOCK(shared);
 845         OUTPUT:
 846         RETVAL
 847
 848 SV*
 849 DELETE(self,index)
 850         SV* self
 851         SV* index
 852         CODE:
 853         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 854         shared_sv* slot;
 855         SHAREDSvLOCK(shared);
 856         if(av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index))) {
 857             SV* tmp;
 858             SHAREDSvEDIT(shared);
 859             tmp = av_delete((AV*)SHAREDSvGET(shared), (I32) SvIV(index),0);
 860             SHAREDSvRELEASE(shared);
 861             if(SvIV(tmp)) {
 862                 slot = INT2PTR(shared_sv*, SvIV(tmp));
 863                 if(SvROK(SHAREDSvGET(slot))) {
 864                    shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 865                    RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 866                 } else {
 867                    RETVAL = newSVsv(SHAREDSvGET(slot));
 868                 }
 869                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 870             } else {
 871                 RETVAL = &PL_sv_undef;
 872             }
 873         } else {
 874             RETVAL = &PL_sv_undef;
 875         }
 876         SHAREDSvUNLOCK(shared);
 877         OUTPUT:
 878         RETVAL
 879
 880 AV*
 881 SPLICE(self, offset, length, ...)
 882         SV* self
 883         SV* offset
 884         SV* length
 885         CODE:
 886         croak("Splice is not implmented for shared arrays");
 887
 888 MODULE = threads::shared                PACKAGE = threads::shared::hv
 889
 890 SV*
 891 new(class, value)
 892         SV* class
 893         SV* value
 894         CODE:
 895         shared_sv* shared = Perl_sharedsv_new(aTHX);
 896         SV* obj = newSViv(PTR2IV(shared));
 897         SHAREDSvEDIT(shared);
 898         SHAREDSvGET(shared) = (SV*) newHV();
 899         SHAREDSvRELEASE(shared);
 900         RETVAL = obj;
 901         OUTPUT:
 902         RETVAL
 903
 904 void
 905 STORE(self, key, value)
 906         SV* self
 907         SV* key
 908         SV* value
 909         CODE:
 910         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 911         shared_sv* slot;
 912         SV* hentry;
 913         SV** hentry_;
 914         STRLEN len;
 915         char* ckey = SvPV(key, len);
 916         SHAREDSvLOCK(shared);
 917         if(SvROK(value)) {
 918             shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value));
 919             if(!target) {
 920                 Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared hash");
 921             }
 922             SHAREDSvEDIT(shared);
 923             value = newRV_noinc(newSViv(PTR2IV(target)));
 924             SHAREDSvRELEASE(shared);
 925         }
 926         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len, 0);
 927         if(hentry_ && SvIV((*hentry_))) {
 928             hentry = (*hentry_);
 929             slot = INT2PTR(shared_sv*, SvIV(hentry));
 930             if(SvROK(SHAREDSvGET(slot)))
 931                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 932             SHAREDSvEDIT(slot);
 933             sv_setsv(SHAREDSvGET(slot), value);
 934             SHAREDSvRELEASE(slot);
 935         } else {
 936             slot = Perl_sharedsv_new(aTHX);
 937             SHAREDSvEDIT(shared);
 938             SHAREDSvGET(slot) = newSVsv(value);
 939             hentry = newSViv(PTR2IV(slot));
 940             hv_store((HV*) SHAREDSvGET(shared), ckey,len , hentry, 0);
 941             SHAREDSvRELEASE(shared);
 942         }
 943         if(SvROK(SHAREDSvGET(slot)))
 944             Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 945         SHAREDSvUNLOCK(shared);
 946
 947
 948 SV*
 949 FETCH(self, key)
 950         SV* self
 951         SV* key
 952         CODE:
 953         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 954         shared_sv* slot;
 955         SV* hentry;
 956         SV** hentry_;
 957         SV* retval;
 958         STRLEN len;
 959         char* ckey = SvPV(key, len);
 960         SHAREDSvLOCK(shared);
 961         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len,0);
 962         if(hentry_) {
 963             hentry = (*hentry_);
 964             if(SvTYPE(hentry) == SVt_NULL) {
 965                 retval = &PL_sv_undef;
 966             } else {
 967                 slot = INT2PTR(shared_sv*, SvIV(hentry));
 968                 if(SvROK(SHAREDSvGET(slot))) {
 969                     shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 970                     retval = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
 971                 } else {
 972                     retval = newSVsv(SHAREDSvGET(slot));
 973                 }
 974             }
 975         } else {
 976             retval = &PL_sv_undef;
 977         }
 978         SHAREDSvUNLOCK(shared);
 979         RETVAL = retval;
 980         OUTPUT:
 981         RETVAL
 982
 983 void
 984 CLEAR(self)
 985         SV* self
 986         CODE:
 987         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 988         shared_sv* slot;
 989         HE* entry;
 990         SHAREDSvLOCK(shared);
 991         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
 992         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
 993         while(entry) {
 994                 slot = INT2PTR(shared_sv*, SvIV(Perl_hv_iterval(PL_sharedsv_space, (HV*) SHAREDSvGET(shared), entry)));
 995                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 996                 entry = Perl_hv_iternext(PL_sharedsv_space,(HV*) SHAREDSvGET(shared));
 997         }
 998         SHAREDSvEDIT(shared);
 999         hv_clear((HV*) SHAREDSvGET(shared));
1000         SHAREDSvRELEASE(shared);
1001         SHAREDSvUNLOCK(shared);
1002
1003 SV*
1004 FIRSTKEY(self)
1005         SV* self
1006         CODE:
1007         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1008         char* key = NULL;
1009         I32 len;
1010         HE* entry;
1011         SHAREDSvLOCK(shared);
1012         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1013         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1014         if(entry) {
1015                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
1016                 RETVAL = newSVpv(key, len);
1017         } else {
1018              RETVAL = &PL_sv_undef;
1019         }
1020         SHAREDSvUNLOCK(shared);
1021         OUTPUT:
1022         RETVAL
1023
1024
1025 SV*
1026 NEXTKEY(self, oldkey)
1027         SV* self
1028         SV* oldkey
1029         CODE:
1030         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1031         char* key = NULL;
1032         I32 len;
1033         HE* entry;
1034         SHAREDSvLOCK(shared);
1035         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1036         if(entry) {
1037                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
1038                 RETVAL = newSVpv(key, len);
1039         } else {
1040              RETVAL = &PL_sv_undef;
1041         }
1042         SHAREDSvUNLOCK(shared);
1043         OUTPUT:
1044         RETVAL
1045
1046
1047 SV*
1048 EXISTS(self, key)
1049         SV* self
1050         SV* key
1051         CODE:
1052         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1053         STRLEN len;
1054         char* ckey = SvPV(key, len);
1055         SHAREDSvLOCK(shared);
1056         if(hv_exists((HV*)SHAREDSvGET(shared), ckey, len)) {
1057                 RETVAL = &PL_sv_yes;
1058         } else {
1059                 RETVAL = &PL_sv_no;
1060         }
1061         SHAREDSvUNLOCK(shared);
1062         OUTPUT:
1063         RETVAL
1064
1065 SV*
1066 DELETE(self, key)
1067         SV* self
1068         SV* key
1069         CODE:
1070         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1071         shared_sv* slot;
1072         STRLEN len;
1073         char* ckey = SvPV(key, len);
1074         SV* tmp;
1075         SHAREDSvLOCK(shared);
1076         SHAREDSvEDIT(shared);
1077         tmp = hv_delete((HV*) SHAREDSvGET(shared), ckey, len,0);
1078         SHAREDSvRELEASE(shared);
1079         if(tmp) {
1080                 slot = INT2PTR(shared_sv*, SvIV(tmp));
1081                 if(SvROK(SHAREDSvGET(slot))) {
1082                     shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
1083                     RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
1084                 } else {
1085                     RETVAL = newSVsv(SHAREDSvGET(slot));
1086                 }
1087                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
1088         } else {
1089                 RETVAL = &PL_sv_undef;
1090         }
1091         SHAREDSvUNLOCK(shared);
1092         OUTPUT:
1093         RETVAL
1094
1095 BOOT:
1096 {
1097      Perl_sharedsv_init(aTHX);
1098 }