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