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 SV* Perl_shared_sv_attach_sv (pTHX_ SV* sv, shared_sv* shared) {
 284     HV* shared_hv = get_hv("threads::shared::shared", FALSE);
 285     SV* id = newSViv(PTR2IV(shared));
 286     STRLEN length = sv_len(id);
 287     SV* tiedobject;
 288     SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0);
 289     if(tiedobject_) {
 290         tiedobject = (*tiedobject_);
 291         if(sv) {
 292             SvROK_on(sv);
 293             SvRV(sv) = SvRV(tiedobject);
 294         } else {
 295             sv = newRV(SvRV(tiedobject));
 296         }
 297     } else {
 298         switch(SvTYPE(SHAREDSvGET(shared))) {
 299             case SVt_PVAV: {
 300                 SV* weakref;
 301                 SV* obj_ref = newSViv(0);
 302                 SV* obj = newSVrv(obj_ref,"threads::shared::av");
 303                 AV* hv = newAV();
 304                 sv_setiv(obj,PTR2IV(shared));
 305                 weakref = newRV((SV*)hv);
 306                 sv = newRV_noinc((SV*)hv);
 307                 sv_rvweaken(weakref);
 308                 sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0);
 309                 hv_store(shared_hv, SvPV(id,length), length, weakref, 0);
 310                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 311             }
 312             break;
 313             case SVt_PVHV: {
 314                 SV* weakref;
 315                 SV* obj_ref = newSViv(0);
 316                 SV* obj = newSVrv(obj_ref,"threads::shared::hv");
 317                 HV* hv = newHV();
 318                 sv_setiv(obj,PTR2IV(shared));
 319                 weakref = newRV((SV*)hv);
 320                 sv = newRV_noinc((SV*)hv);
 321                 sv_rvweaken(weakref);
 322                 sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0);
 323                 hv_store(shared_hv, SvPV(id,length), length, weakref, 0);
 324                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 325             }
 326             break;
 327             default: {
 328                 MAGIC* shared_magic;
 329                 SV* value = newSVsv(SHAREDSvGET(shared));
 330                 SV* obj = newSViv(PTR2IV(shared));
 331                 sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
 332                 shared_magic = mg_find(value, PERL_MAGIC_ext);
 333                 shared_magic->mg_virtual = &svtable;
 334                 shared_magic->mg_obj = newSViv(PTR2IV(shared));
 335                 shared_magic->mg_flags |= MGf_REFCOUNTED;
 336                 shared_magic->mg_private = 0;
 337                 SvMAGICAL_on(value);
 338                 sv = newRV_noinc(value);
 339                 value = newRV(value);
 340                 sv_rvweaken(value);
 341                 hv_store(shared_hv, SvPV(id,length),length, value, 0);
 342                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 343             }
 344
 345         }
 346     }
 347     return sv;
 348 }
 349
 350
 351 int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
 352     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
 353     SHAREDSvLOCK(shared);
 354     if(mg->mg_private != shared->index) {
 355         if(SvROK(SHAREDSvGET(shared))) {
 356             shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared))));
 357             shared_sv_attach_sv(sv, target);
 358         } else {
 359             sv_setsv(sv, SHAREDSvGET(shared));
 360         }
 361         mg->mg_private = shared->index;
 362     }
 363     SHAREDSvUNLOCK(shared);
 364
 365     return 0;
 366 }
 367
 368 int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
 369     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
 370     SHAREDSvLOCK(shared);
 371     if(SvROK(SHAREDSvGET(shared)))
 372         Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared)))));
 373     if(SvROK(sv)) {
 374         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
 375         if(!target) {
 376             sv_setsv(sv,SHAREDSvGET(shared));
 377             SHAREDSvUNLOCK(shared);
 378             Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
 379         }
 380         SHAREDSvEDIT(shared);
 381         Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
 382         SHAREDSvGET(shared) = newRV_noinc(newSViv(PTR2IV(target)));
 383     } else {
 384             SHAREDSvEDIT(shared);
 385         sv_setsv(SHAREDSvGET(shared), sv);
 386     }
 387     shared->index++;
 388     mg->mg_private = shared->index;
 389     SHAREDSvRELEASE(shared);
 390     if(SvROK(SHAREDSvGET(shared)))
 391        Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared)))));
 392     SHAREDSvUNLOCK(shared);
 393     return 0;
 394 }
 395
 396 int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) {
 397     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
 398     if(!shared)
 399         return 0;
 400     {
 401         HV* shared_hv = get_hv("threads::shared::shared", FALSE);
 402         SV* id = newSViv(PTR2IV(shared));
 403         STRLEN length = sv_len(id);
 404         hv_delete(shared_hv, SvPV(id,length), length,0);
 405     }
 406     Perl_sharedsv_thrcnt_dec(aTHX_ shared);
 407 }
 408
 409 MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg),
 410                   MEMBER_TO_FPTR(shared_sv_store_mg),
 411                   0,
 412                   0,
 413                   MEMBER_TO_FPTR(shared_sv_destroy_mg)
 414 };
 415
 416 MODULE = threads::shared                PACKAGE = threads::shared
 417
 418
 419 PROTOTYPES: ENABLE
 420
 421
 422 SV*
 423 ptr(ref)
 424         SV* ref
 425         CODE:
 426         RETVAL = newSViv(SvIV(SvRV(ref)));
 427         OUTPUT:
 428         RETVAL
 429
 430
 431 SV*
 432 _thrcnt(ref)
 433         SV* ref
 434         CODE:
 435         shared_sv* shared;
 436         if(SvROK(ref))
 437             ref = SvRV(ref);
 438         shared = Perl_sharedsv_find(aTHX, ref);
 439         if(!shared)
 440            croak("thrcnt can only be used on shared values");
 441         SHAREDSvLOCK(shared);
 442         RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
 443         SHAREDSvUNLOCK(shared);
 444         OUTPUT:
 445         RETVAL
 446
 447
 448 void
 449 thrcnt_inc(ref,perl)
 450         SV* ref
 451         SV* perl
 452         CODE:
 453         shared_sv* shared;
 454         PerlInterpreter* origperl = INT2PTR(PerlInterpreter*, SvIV(perl));
 455         PerlInterpreter* oldperl = PERL_GET_CONTEXT;
 456         if(SvROK(ref))
 457             ref = SvRV(ref);
 458         shared = Perl_sharedsv_find(aTHX, ref);
 459         if(!shared)
 460            croak("thrcnt can only be used on shared values");
 461         PERL_SET_CONTEXT(origperl);
 462         Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 463         PERL_SET_CONTEXT(oldperl);
 464
 465 void
 466 _thrcnt_dec(ref)
 467         SV* ref
 468         CODE:
 469         shared_sv* shared = INT2PTR(shared_sv*, SvIV(ref));
 470         if(!shared)
 471            croak("thrcnt can only be used on shared values");
 472         Perl_sharedsv_thrcnt_dec(aTHX_ shared);
 473
 474 void
 475 unlock_enabled(ref)
 476         SV* ref
 477         PROTOTYPE: \[$@%]
 478         CODE:
 479         shared_sv* shared;
 480         if(SvROK(ref))
 481             ref = SvRV(ref);
 482         shared = Perl_sharedsv_find(aTHX, ref);
 483         if(!shared)
 484            croak("unlock can only be used on shared values");
 485         SHAREDSvUNLOCK(shared);
 486
 487 void
 488 lock_enabled(ref)
 489         SV* ref
 490         CODE:
 491         shared_sv* shared;
 492         if(SvROK(ref))
 493             ref = SvRV(ref);
 494         shared = Perl_sharedsv_find(aTHX, ref);
 495         if(!shared)
 496            croak("lock can only be used on shared values");
 497         SHAREDSvLOCK(shared);
 498
 499
 500 void
 501 cond_wait_enabled(ref)
 502         SV* ref
 503         PROTOTYPE: \[$@%]
 504         CODE:
 505         shared_sv* shared;
 506         int locks;
 507         if(SvROK(ref))
 508             ref = SvRV(ref);
 509         shared = Perl_sharedsv_find(aTHX_ ref);
 510         if(!shared)
 511             croak("cond_wait can only be used on shared values");
 512         if(shared->owner != PERL_GET_CONTEXT)
 513             croak("You need a lock before you can cond_wait");
 514         MUTEX_LOCK(&shared->mutex);
 515         shared->owner = NULL;
 516         locks = shared->locks = 0;
 517         COND_WAIT(&shared->user_cond, &shared->mutex);
 518         shared->owner = PERL_GET_CONTEXT;
 519         shared->locks = locks;
 520         MUTEX_UNLOCK(&shared->mutex);
 521
 522 void cond_signal_enabled(ref)
 523         SV* ref
 524         PROTOTYPE: \[$@%]
 525         CODE:
 526         shared_sv* shared;
 527         if(SvROK(ref))
 528             ref = SvRV(ref);
 529         shared = Perl_sharedsv_find(aTHX_ ref);
 530         if(!shared)
 531             croak("cond_signal can only be used on shared values");
 532         COND_SIGNAL(&shared->user_cond);
 533
 534
 535 void cond_broadcast_enabled(ref)
 536         SV* ref
 537         PROTOTYPE: \[$@%]
 538         CODE:
 539         shared_sv* shared;
 540         if(SvROK(ref))
 541             ref = SvRV(ref);
 542         shared = Perl_sharedsv_find(aTHX_ ref);
 543         if(!shared)
 544             croak("cond_broadcast can only be used on shared values");
 545         COND_BROADCAST(&shared->user_cond);
 546
 547 MODULE = threads::shared                PACKAGE = threads::shared::sv
 548
 549 SV*
 550 new(class, value)
 551         SV* class
 552         SV* value
 553         CODE:
 554         shared_sv* shared = Perl_sharedsv_new(aTHX);
 555         MAGIC* shared_magic;
 556         SV* obj = newSViv(PTR2IV(shared));
 557         SHAREDSvEDIT(shared);
 558         SHAREDSvGET(shared) = newSVsv(value);
 559         SHAREDSvRELEASE(shared);
 560         sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
 561         shared_magic = mg_find(value, PERL_MAGIC_ext);
 562         shared_magic->mg_virtual = &svtable;
 563         shared_magic->mg_obj = newSViv(PTR2IV(shared));
 564         shared_magic->mg_flags |= MGf_REFCOUNTED;
 565         shared_magic->mg_private = 0;
 566         SvMAGICAL_on(value);
 567         RETVAL = obj;
 568         OUTPUT:
 569         RETVAL
 570
 571
 572 MODULE = threads::shared                PACKAGE = threads::shared::av
 573
 574 SV*
 575 new(class, value)
 576         SV* class
 577         SV* value
 578         CODE:
 579         shared_sv* shared = Perl_sharedsv_new(aTHX);
 580         SV* obj = newSViv(PTR2IV(shared));
 581         SHAREDSvEDIT(shared);
 582         SHAREDSvGET(shared) = (SV*) newAV();
 583         SHAREDSvRELEASE(shared);
 584         RETVAL = obj;
 585         OUTPUT:
 586         RETVAL
 587
 588 void
 589 STORE(self, index, value)
 590         SV* self
 591         SV* index
 592         SV* value
 593         CODE:
 594         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 595         shared_sv* slot;
 596         SV* aentry;
 597         SV** aentry_;
 598         if(SvROK(value)) {
 599             shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value));
 600             if(!target) {
 601                  Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
 602             }
 603             value = newRV_noinc(newSViv(PTR2IV(target)));
 604         }
 605         SHAREDSvLOCK(shared);
 606         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index), 0);
 607         if(aentry_ && SvIV((*aentry_))) {
 608             aentry = (*aentry_);
 609             slot = INT2PTR(shared_sv*, SvIV(aentry));
 610             if(SvROK(SHAREDSvGET(slot)))
 611                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 612             SHAREDSvEDIT(slot);
 613             sv_setsv(SHAREDSvGET(slot), value);
 614             SHAREDSvRELEASE(slot);
 615         } else {
 616             slot = Perl_sharedsv_new(aTHX);
 617             SHAREDSvEDIT(shared);
 618             SHAREDSvGET(slot) = newSVsv(value);
 619             aentry = newSViv(PTR2IV(slot));
 620             av_store((AV*) SHAREDSvGET(shared), SvIV(index), aentry);
 621             SHAREDSvRELEASE(shared);
 622         }
 623         if(SvROK(SHAREDSvGET(slot)))
 624             Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 625
 626         SHAREDSvUNLOCK(shared);
 627
 628 SV*
 629 FETCH(self, index)
 630         SV* self
 631         SV* index
 632         CODE:
 633         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 634         shared_sv* slot;
 635         SV* aentry;
 636         SV** aentry_;
 637         SV* retval;
 638         SHAREDSvLOCK(shared);
 639         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index),0);
 640         if(aentry_) {
 641             aentry = (*aentry_);
 642             if(SvTYPE(aentry) == SVt_NULL) {
 643                 retval = &PL_sv_undef;
 644             } else {
 645                 slot = INT2PTR(shared_sv*, SvIV(aentry));
 646                 if(SvROK(SHAREDSvGET(slot))) {
 647                      shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 648                      retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 649                 } else {
 650                      retval = newSVsv(SHAREDSvGET(slot));
 651                 }
 652             }
 653         } else {
 654             retval = &PL_sv_undef;
 655         }
 656         SHAREDSvUNLOCK(shared);
 657         RETVAL = retval;
 658         OUTPUT:
 659         RETVAL
 660
 661 void
 662 PUSH(self, ...)
 663         SV* self
 664         CODE:
 665         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 666         int i;
 667         SHAREDSvLOCK(shared);
 668         for(i = 1; i < items; i++) {
 669             shared_sv* slot = Perl_sharedsv_new(aTHX);
 670             SV* tmp = ST(i);
 671             if(SvROK(tmp)) {
 672                  shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp));
 673                  if(!target) {
 674                      Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
 675                  }
 676                  tmp = newRV_noinc(newSViv(PTR2IV(target)));
 677             }
 678             SHAREDSvEDIT(slot);
 679             SHAREDSvGET(slot) = newSVsv(tmp);
 680             av_push((AV*) SHAREDSvGET(shared), newSViv(PTR2IV(slot)));
 681             SHAREDSvRELEASE(slot);
 682             if(SvROK(SHAREDSvGET(slot)))
 683                 Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 684         }
 685         SHAREDSvUNLOCK(shared);
 686
 687 void
 688 UNSHIFT(self, ...)
 689         SV* self
 690         CODE:
 691         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 692         int i;
 693         SHAREDSvLOCK(shared);
 694         SHAREDSvEDIT(shared);
 695         av_unshift((AV*)SHAREDSvGET(shared), items - 1);
 696         SHAREDSvRELEASE(shared);
 697         for(i = 1; i < items; i++) {
 698             shared_sv* slot = Perl_sharedsv_new(aTHX);
 699             SV* tmp = ST(i);
 700             if(SvROK(tmp)) {
 701                  shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp));
 702                  if(!target) {
 703                      Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
 704                  }
 705                  tmp = newRV_noinc(newSViv(PTR2IV(target)));
 706             }
 707             SHAREDSvEDIT(slot);
 708             SHAREDSvGET(slot) = newSVsv(tmp);
 709             av_store((AV*) SHAREDSvGET(shared), i - 1, newSViv(PTR2IV(slot)));
 710             SHAREDSvRELEASE(slot);
 711             if(SvROK(SHAREDSvGET(slot)))
 712                 Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 713         }
 714         SHAREDSvUNLOCK(shared);
 715
 716 SV*
 717 POP(self)
 718         SV* self
 719         CODE:
 720         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 721         shared_sv* slot;
 722         SV* retval;
 723         SHAREDSvLOCK(shared);
 724         SHAREDSvEDIT(shared);
 725         retval = av_pop((AV*)SHAREDSvGET(shared));
 726         SHAREDSvRELEASE(shared);
 727         if(retval && SvIV(retval)) {
 728             slot = INT2PTR(shared_sv*, SvIV(retval));
 729             if(SvROK(SHAREDSvGET(slot))) {
 730                  shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 731                  retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 732             } else {
 733                  retval = newSVsv(SHAREDSvGET(slot));
 734             }
 735             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 736         } else {
 737             retval = &PL_sv_undef;
 738         }
 739         SHAREDSvUNLOCK(shared);
 740         RETVAL = retval;
 741         OUTPUT:
 742         RETVAL
 743
 744
 745 SV*
 746 SHIFT(self)
 747         SV* self
 748         CODE:
 749         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 750         shared_sv* slot;
 751         SV* retval;
 752         SHAREDSvLOCK(shared);
 753         SHAREDSvEDIT(shared);
 754         retval = av_shift((AV*)SHAREDSvGET(shared));
 755         SHAREDSvRELEASE(shared);
 756         if(retval && SvIV(retval)) {
 757             slot = INT2PTR(shared_sv*, SvIV(retval));
 758             if(SvROK(SHAREDSvGET(slot))) {
 759                  shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 760                  retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 761             } else {
 762                  retval = newSVsv(SHAREDSvGET(slot));
 763             }
 764             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 765         } else {
 766             retval = &PL_sv_undef;
 767         }
 768         SHAREDSvUNLOCK(shared);
 769         RETVAL = retval;
 770         OUTPUT:
 771         RETVAL
 772
 773 void
 774 CLEAR(self)
 775         SV* self
 776         CODE:
 777         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 778         shared_sv* slot;
 779         SV** svp;
 780         I32 i;
 781         SHAREDSvLOCK(shared);
 782         svp = AvARRAY((AV*)SHAREDSvGET(shared));
 783         i   = AvFILLp((AV*)SHAREDSvGET(shared));
 784         while ( i >= 0) {
 785             if(SvIV(svp[i])) {
 786                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(svp[i])));
 787             }
 788             i--;
 789         }
 790         SHAREDSvEDIT(shared);
 791         av_clear((AV*)SHAREDSvGET(shared));
 792         SHAREDSvRELEASE(shared);
 793         SHAREDSvUNLOCK(shared);
 794
 795 void
 796 EXTEND(self, count)
 797         SV* self
 798         SV* count
 799         CODE:
 800         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 801         SHAREDSvEDIT(shared);
 802         av_extend((AV*)SHAREDSvGET(shared), (I32) SvIV(count));
 803         SHAREDSvRELEASE(shared);
 804
 805
 806
 807
 808 SV*
 809 EXISTS(self, index)
 810         SV* self
 811         SV* index
 812         CODE:
 813         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 814         I32 exists;
 815         SHAREDSvLOCK(shared);
 816         exists = av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index));
 817         if(exists) {
 818             RETVAL = &PL_sv_yes;
 819         } else {
 820             RETVAL = &PL_sv_no;
 821         }
 822         SHAREDSvUNLOCK(shared);
 823
 824 void
 825 STORESIZE(self,count)
 826         SV* self
 827         SV* count
 828         CODE:
 829         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 830         SHAREDSvEDIT(shared);
 831         av_fill((AV*) SHAREDSvGET(shared), (I32) SvIV(count));
 832         SHAREDSvRELEASE(shared);
 833
 834 SV*
 835 FETCHSIZE(self)
 836         SV* self
 837         CODE:
 838         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 839         SHAREDSvLOCK(shared);
 840         RETVAL = newSViv(av_len((AV*) SHAREDSvGET(shared)) + 1);
 841         SHAREDSvUNLOCK(shared);
 842         OUTPUT:
 843         RETVAL
 844
 845 SV*
 846 DELETE(self,index)
 847         SV* self
 848         SV* index
 849         CODE:
 850         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 851         shared_sv* slot;
 852         SHAREDSvLOCK(shared);
 853         if(av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index))) {
 854             SV* tmp;
 855             SHAREDSvEDIT(shared);
 856             tmp = av_delete((AV*)SHAREDSvGET(shared), (I32) SvIV(index),0);
 857             SHAREDSvRELEASE(shared);
 858             if(SvIV(tmp)) {
 859                 slot = INT2PTR(shared_sv*, SvIV(tmp));
 860                 if(SvROK(SHAREDSvGET(slot))) {
 861                    shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 862                    RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
 863                 } else {
 864                    RETVAL = newSVsv(SHAREDSvGET(slot));
 865                 }
 866                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 867             } else {
 868                 RETVAL = &PL_sv_undef;
 869             }
 870         } else {
 871             RETVAL = &PL_sv_undef;
 872         }
 873         SHAREDSvUNLOCK(shared);
 874         OUTPUT:
 875         RETVAL
 876
 877 AV*
 878 SPLICE(self, offset, length, ...)
 879         SV* self
 880         SV* offset
 881         SV* length
 882         CODE:
 883         croak("Splice is not implmented for shared arrays");
 884
 885 MODULE = threads::shared                PACKAGE = threads::shared::hv
 886
 887 SV*
 888 new(class, value)
 889         SV* class
 890         SV* value
 891         CODE:
 892         shared_sv* shared = Perl_sharedsv_new(aTHX);
 893         SV* obj = newSViv(PTR2IV(shared));
 894         SHAREDSvEDIT(shared);
 895         SHAREDSvGET(shared) = (SV*) newHV();
 896         SHAREDSvRELEASE(shared);
 897         RETVAL = obj;
 898         OUTPUT:
 899         RETVAL
 900
 901 void
 902 STORE(self, key, value)
 903         SV* self
 904         SV* key
 905         SV* value
 906         CODE:
 907         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 908         shared_sv* slot;
 909         SV* hentry;
 910         SV** hentry_;
 911         STRLEN len;
 912         char* ckey = SvPV(key, len);
 913         SHAREDSvLOCK(shared);
 914         if(SvROK(value)) {
 915             shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value));
 916             if(!target) {
 917                 Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared hash");
 918             }
 919             SHAREDSvEDIT(shared);
 920             value = newRV_noinc(newSViv(PTR2IV(target)));
 921             SHAREDSvRELEASE(shared);
 922         }
 923         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len, 0);
 924         if(hentry_ && SvIV((*hentry_))) {
 925             hentry = (*hentry_);
 926             slot = INT2PTR(shared_sv*, SvIV(hentry));
 927             if(SvROK(SHAREDSvGET(slot)))
 928                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 929             SHAREDSvEDIT(slot);
 930             sv_setsv(SHAREDSvGET(slot), value);
 931             SHAREDSvRELEASE(slot);
 932         } else {
 933             slot = Perl_sharedsv_new(aTHX);
 934             SHAREDSvEDIT(shared);
 935             SHAREDSvGET(slot) = newSVsv(value);
 936             hentry = newSViv(PTR2IV(slot));
 937             hv_store((HV*) SHAREDSvGET(shared), ckey,len , hentry, 0);
 938             SHAREDSvRELEASE(shared);
 939         }
 940         if(SvROK(SHAREDSvGET(slot)))
 941             Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
 942         SHAREDSvUNLOCK(shared);
 943
 944
 945 SV*
 946 FETCH(self, key)
 947         SV* self
 948         SV* key
 949         CODE:
 950         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 951         shared_sv* slot;
 952         SV* hentry;
 953         SV** hentry_;
 954         SV* retval;
 955         STRLEN len;
 956         char* ckey = SvPV(key, len);
 957         SHAREDSvLOCK(shared);
 958         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len,0);
 959         if(hentry_) {
 960             hentry = (*hentry_);
 961             if(SvTYPE(hentry) == SVt_NULL) {
 962                 retval = &PL_sv_undef;
 963             } else {
 964                 slot = INT2PTR(shared_sv*, SvIV(hentry));
 965                 if(SvROK(SHAREDSvGET(slot))) {
 966                     shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
 967                     retval = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
 968                 } else {
 969                     retval = newSVsv(SHAREDSvGET(slot));
 970                 }
 971             }
 972         } else {
 973             retval = &PL_sv_undef;
 974         }
 975         SHAREDSvUNLOCK(shared);
 976         RETVAL = retval;
 977         OUTPUT:
 978         RETVAL
 979
 980 void
 981 CLEAR(self)
 982         SV* self
 983         CODE:
 984         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
 985         shared_sv* slot;
 986         HE* entry;
 987         SHAREDSvLOCK(shared);
 988         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
 989         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
 990         while(entry) {
 991                 slot = INT2PTR(shared_sv*, SvIV(Perl_hv_iterval(PL_sharedsv_space, (HV*) SHAREDSvGET(shared), entry)));
 992                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
 993                 entry = Perl_hv_iternext(PL_sharedsv_space,(HV*) SHAREDSvGET(shared));
 994         }
 995         SHAREDSvEDIT(shared);
 996         hv_clear((HV*) SHAREDSvGET(shared));
 997         SHAREDSvRELEASE(shared);
 998         SHAREDSvUNLOCK(shared);
 999
1000 SV*
1001 FIRSTKEY(self)
1002         SV* self
1003         CODE:
1004         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1005         char* key = NULL;
1006         I32 len;
1007         HE* entry;
1008         SHAREDSvLOCK(shared);
1009         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1010         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1011         if(entry) {
1012                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
1013                 RETVAL = newSVpv(key, len);
1014         } else {
1015              RETVAL = &PL_sv_undef;
1016         }
1017         SHAREDSvUNLOCK(shared);
1018         OUTPUT:
1019         RETVAL
1020
1021
1022 SV*
1023 NEXTKEY(self, oldkey)
1024         SV* self
1025         SV* oldkey
1026         CODE:
1027         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1028         char* key = NULL;
1029         I32 len;
1030         HE* entry;
1031         SHAREDSvLOCK(shared);
1032         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1033         if(entry) {
1034                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
1035                 RETVAL = newSVpv(key, len);
1036         } else {
1037              RETVAL = &PL_sv_undef;
1038         }
1039         SHAREDSvUNLOCK(shared);
1040         OUTPUT:
1041         RETVAL
1042
1043
1044 SV*
1045 EXISTS(self, key)
1046         SV* self
1047         SV* key
1048         CODE:
1049         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1050         STRLEN len;
1051         char* ckey = SvPV(key, len);
1052         SHAREDSvLOCK(shared);
1053         if(hv_exists((HV*)SHAREDSvGET(shared), ckey, len)) {
1054                 RETVAL = &PL_sv_yes;
1055         } else {
1056                 RETVAL = &PL_sv_no;
1057         }
1058         SHAREDSvUNLOCK(shared);
1059         OUTPUT:
1060         RETVAL
1061
1062 SV*
1063 DELETE(self, key)
1064         SV* self
1065         SV* key
1066         CODE:
1067         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1068         shared_sv* slot;
1069         STRLEN len;
1070         char* ckey = SvPV(key, len);
1071         SV* tmp;
1072         SHAREDSvLOCK(shared);
1073         SHAREDSvEDIT(shared);
1074         tmp = hv_delete((HV*) SHAREDSvGET(shared), ckey, len,0);
1075         SHAREDSvRELEASE(shared);
1076         if(tmp) {
1077                 slot = INT2PTR(shared_sv*, SvIV(tmp));
1078                 if(SvROK(SHAREDSvGET(slot))) {
1079                     shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
1080                     RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
1081                 } else {
1082                     RETVAL = newSVsv(SHAREDSvGET(slot));
1083                 }
1084                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
1085         } else {
1086                 RETVAL = &PL_sv_undef;
1087         }
1088         SHAREDSvUNLOCK(shared);
1089         OUTPUT:
1090         RETVAL
1091
1092 BOOT:
1093 {
1094      Perl_sharedsv_init(aTHX);
1095 }