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