sharedsv.c

   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 #include "EXTERN.h"
  20 #define PERL_IN_SHAREDSV_C
  21 #include "perl.h"
  22
  23 #ifdef USE_ITHREADS
  24
  25
  26
  27 /*
  28   Shared SV
  29
  30   Shared SV is a structure for keeping the backend storage
  31   of shared svs.
  32
  33  */
  34
  35 /*
  36 =for apidoc sharedsv_init
  37
  38 Saves a space for keeping SVs wider than an interpreter,
  39 currently only stores a pointer to the first interpreter.
  40
  41 =cut
  42 */
  43
  44 void
  45 Perl_sharedsv_init(pTHX)
  46 {
  47   PerlInterpreter* old_context = PERL_GET_CONTEXT;
  48   PL_sharedsv_space = perl_alloc();
  49   perl_construct(PL_sharedsv_space);
  50   PERL_SET_CONTEXT(old_context);
  51   MUTEX_INIT(&PL_sharedsv_space_mutex);
  52 }
  53
  54 /*
  55 =for apidoc sharedsv_new
  56
  57 Allocates a new shared sv struct, you must yourself create the SV/AV/HV.
  58 =cut
  59 */
  60
  61 shared_sv *
  62 Perl_sharedsv_new(pTHX)
  63 {
  64     shared_sv* ssv;
  65     New(2555,ssv,1,shared_sv);
  66     MUTEX_INIT(&ssv->mutex);
  67     COND_INIT(&ssv->cond);
  68     COND_INIT(&ssv->user_cond);
  69     ssv->owner = 0;
  70     ssv->locks = 0;
  71     ssv->index = 0;
  72     return ssv;
  73 }
  74
  75
  76 /*
  77 =for apidoc sharedsv_find
  78
  79 Tries to find if a given SV has a shared backend, either by
  80 looking at magic, or by checking if it is tied again threads::shared.
  81
  82 =cut
  83 */
  84
  85 shared_sv *
  86 Perl_sharedsv_find(pTHX_ SV* sv)
  87 {
  88   /* does all it can to find a shared_sv struct, returns NULL otherwise */
  89     shared_sv* ssv = NULL;
  90     switch (SvTYPE(sv)) {
  91         case SVt_PVMG:
  92         case SVt_PVAV:
  93         case SVt_PVHV: {
  94             MAGIC* mg = mg_find(sv, PERL_MAGIC_ext);
  95             if(mg) {
  96                 if(strcmp(mg->mg_ptr,"threads::shared"))
  97                     break;
  98                 ssv = INT2PTR(shared_sv *, SvIV(mg->mg_obj));
  99                 break;
 100              }
 101
 102              mg = mg_find(sv,PERL_MAGIC_tied);
 103              if(mg) {
 104                  SV* obj = SvTIED_obj(sv,mg);
 105                  if(sv_derived_from(obj, "threads::shared"))
 106                      ssv = INT2PTR(shared_sv *, SvIV(SvRV(obj)));
 107                  break;
 108              }
 109         }
 110     }
 111     return ssv;
 112 }
 113
 114 /*
 115 =for apidoc sharedsv_lock
 116
 117 Recursive locks on a sharedsv.
 118 Locks are dynamically scoped at the level of the first lock.
 119 =cut
 120 */
 121 void
 122 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
 123 {
 124     if(!ssv)
 125         return;
 126     MUTEX_LOCK(&ssv->mutex);
 127     if(ssv->owner && ssv->owner == my_perl) {
 128         ssv->locks++;
 129         MUTEX_UNLOCK(&ssv->mutex);
 130         return;
 131     }
 132     while(ssv->owner)
 133       COND_WAIT(&ssv->cond,&ssv->mutex);
 134     ssv->locks++;
 135     ssv->owner = my_perl;
 136     if(ssv->locks == 1)
 137         SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv);
 138     MUTEX_UNLOCK(&ssv->mutex);
 139 }
 140
 141 /*
 142 =for apidoc sharedsv_unlock
 143
 144 Recursively unlocks a shared sv.
 145
 146 =cut
 147 */
 148
 149 void
 150 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
 151 {
 152     MUTEX_LOCK(&ssv->mutex);
 153     if(ssv->owner != my_perl) {
 154         Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own");
 155         MUTEX_UNLOCK(&ssv->mutex);
 156         return;
 157     }
 158
 159     if(--ssv->locks == 0) {
 160         ssv->owner = NULL;
 161         COND_SIGNAL(&ssv->cond);
 162     }
 163     MUTEX_UNLOCK(&ssv->mutex);
 164  }
 165
 166 void
 167 Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv)
 168 {
 169     MUTEX_LOCK(&ssv->mutex);
 170     if(ssv->owner != my_perl) {
 171         MUTEX_UNLOCK(&ssv->mutex);
 172         return;
 173     }
 174     ssv->locks = 0;
 175     ssv->owner = NULL;
 176     COND_SIGNAL(&ssv->cond);
 177     MUTEX_UNLOCK(&ssv->mutex);
 178 }
 179
 180 /*
 181 =for apidoc sharedsv_thrcnt_inc
 182
 183 Increments the threadcount of a sharedsv.
 184 =cut
 185 */
 186 void
 187 Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv)
 188 {
 189   SHAREDSvLOCK(ssv);
 190   SvREFCNT_inc(ssv->sv);
 191   SHAREDSvUNLOCK(ssv);
 192 }
 193
 194 /*
 195 =for apidoc sharedsv_thrcnt_dec
 196
 197 Decrements the threadcount of a shared sv. When a threads frontend is freed
 198 this function should be called.
 199
 200 =cut
 201 */
 202
 203 void
 204 Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv)
 205 {
 206     SV* sv;
 207     SHAREDSvLOCK(ssv);
 208     sv = SHAREDSvGET(ssv);
 209     if (SvREFCNT(sv) == 1) {
 210         switch (SvTYPE(sv)) {
 211         case SVt_RV:
 212             if (SvROK(sv))
 213             Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(SvRV(sv))));
 214             break;
 215         case SVt_PVAV: {
 216             SV **src_ary  = AvARRAY((AV *)sv);
 217             SSize_t items = AvFILLp((AV *)sv) + 1;
 218
 219             while (items-- > 0) {
 220             if(SvTYPE(*src_ary))
 221                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(*src_ary)));
 222                 src_ary++;
 223             }
 224             break;
 225         }
 226         case SVt_PVHV: {
 227             HE *entry;
 228             (void)hv_iterinit((HV *)sv);
 229             while ((entry = hv_iternext((HV *)sv)))
 230                 Perl_sharedsv_thrcnt_dec(
 231                     aTHX_ INT2PTR(shared_sv *, SvIV(hv_iterval((HV *)sv, entry)))
 232                 );
 233             break;
 234         }
 235         }
 236     }
 237     Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv));
 238     SHAREDSvUNLOCK(ssv);
 239 }
 240
 241 #endif /* USE_ITHREADS */
 242