ext/threads/shared/shared.xs

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