Socket::my_inet_aton() tweak
[p5sagit/p5-mst-13.2.git] / 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