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