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; |
eb31b78e |
455 | #if 0 |
a446a88f |
456 | assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000); |
eb31b78e |
457 | #endif |
a446a88f |
458 | Perl_sharedsv_free(aTHX_ shared); |
459 | return 0; |
460 | } |
461 | |
462 | int |
463 | sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg) |
464 | { |
21312124 |
465 | return 0; |
466 | } |
68795e93 |
467 | |
468 | /* |
21312124 |
469 | * Called during cloning of new threads |
470 | */ |
471 | int |
472 | sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
473 | { |
474 | shared_sv *shared = (shared_sv *) mg->mg_ptr; |
475 | if (shared) { |
476 | SvREFCNT_inc(SHAREDSvPTR(shared)); |
477 | } |
478 | return 0; |
479 | } |
68795e93 |
480 | |
21312124 |
481 | MGVTBL sharedsv_scalar_vtbl = { |
482 | sharedsv_scalar_mg_get, /* get */ |
483 | sharedsv_scalar_mg_set, /* set */ |
484 | 0, /* len */ |
a446a88f |
485 | sharedsv_scalar_mg_clear, /* clear */ |
21312124 |
486 | sharedsv_scalar_mg_free, /* free */ |
487 | 0, /* copy */ |
488 | sharedsv_scalar_mg_dup /* dup */ |
489 | }; |
68795e93 |
490 | |
21312124 |
491 | /* Now the arrays/hashes stuff */ |
21312124 |
492 | int |
493 | sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) |
68795e93 |
494 | { |
21312124 |
495 | dTHXc; |
6b85e4fe |
496 | shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj); |
21312124 |
497 | shared_sv *target = Perl_sharedsv_find(aTHX_ sv); |
498 | SV** svp; |
499 | |
a446a88f |
500 | assert ( shared ); |
501 | assert ( SHAREDSvPTR(shared) ); |
502 | |
6b85e4fe |
503 | ENTER_LOCK; |
504 | |
21312124 |
505 | if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { |
a446a88f |
506 | assert ( mg->mg_ptr == 0 ); |
6b85e4fe |
507 | SHARED_CONTEXT; |
a446a88f |
508 | svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0); |
21312124 |
509 | } |
510 | else { |
6b85e4fe |
511 | char *key = mg->mg_ptr; |
512 | STRLEN len = mg->mg_len; |
a446a88f |
513 | assert ( mg->mg_ptr != 0 ); |
6b85e4fe |
514 | if (mg->mg_len == HEf_SVKEY) { |
515 | key = SvPV((SV *) mg->mg_ptr, len); |
516 | } |
517 | SHARED_CONTEXT; |
518 | svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0); |
21312124 |
519 | } |
6b85e4fe |
520 | CALLER_CONTEXT; |
21312124 |
521 | if (svp) { |
6b85e4fe |
522 | /* Exists in the array */ |
523 | target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target); |
524 | sv_setsv(sv, *svp); |
21312124 |
525 | } |
6b85e4fe |
526 | else { |
527 | /* Not in the array */ |
528 | sv_setsv(sv, &PL_sv_undef); |
68795e93 |
529 | } |
6b85e4fe |
530 | LEAVE_LOCK; |
21312124 |
531 | return 0; |
68795e93 |
532 | } |
533 | |
21312124 |
534 | int |
535 | sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) |
536 | { |
537 | dTHXc; |
6b85e4fe |
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); |
6b85e4fe |
574 | ENTER_LOCK; |
575 | sharedsv_elem_mg_FETCH(aTHX_ sv, mg); |
21312124 |
576 | if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { |
6b85e4fe |
577 | SHARED_CONTEXT; |
578 | av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD); |
68795e93 |
579 | } |
21312124 |
580 | else { |
6b85e4fe |
581 | char *key = mg->mg_ptr; |
582 | STRLEN len = mg->mg_len; |
583 | assert ( mg->mg_ptr != 0 ); |
584 | if (mg->mg_len == HEf_SVKEY) |
585 | key = SvPV((SV *) mg->mg_ptr, len); |
586 | SHARED_CONTEXT; |
587 | hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD); |
21312124 |
588 | } |
6b85e4fe |
589 | CALLER_CONTEXT; |
590 | LEAVE_LOCK; |
21312124 |
591 | return 0; |
592 | } |
593 | |
21312124 |
594 | int |
595 | sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg) |
596 | { |
6b85e4fe |
597 | Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj)); |
21312124 |
598 | return 0; |
599 | } |
600 | |
601 | int |
602 | sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
603 | { |
6b85e4fe |
604 | shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj); |
21312124 |
605 | SvREFCNT_inc(SHAREDSvPTR(shared)); |
606 | mg->mg_flags |= MGf_DUP; |
607 | return 0; |
608 | } |
609 | |
610 | MGVTBL sharedsv_elem_vtbl = { |
611 | sharedsv_elem_mg_FETCH, /* get */ |
612 | sharedsv_elem_mg_STORE, /* set */ |
613 | 0, /* len */ |
614 | sharedsv_elem_mg_DELETE, /* clear */ |
615 | sharedsv_elem_mg_free, /* free */ |
616 | 0, /* copy */ |
617 | sharedsv_elem_mg_dup /* dup */ |
618 | }; |
619 | |
620 | U32 |
621 | sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) |
622 | { |
623 | dTHXc; |
624 | shared_sv *shared = (shared_sv *) mg->mg_ptr; |
625 | U32 val; |
626 | SHARED_EDIT; |
627 | if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { |
628 | val = av_len((AV*) SHAREDSvPTR(shared)); |
629 | } |
630 | else { |
631 | /* not actually defined by tie API but ... */ |
632 | val = HvKEYS((HV*) SHAREDSvPTR(shared)); |
633 | } |
634 | SHARED_RELEASE; |
635 | return val; |
636 | } |
637 | |
638 | int |
639 | sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) |
640 | { |
641 | dTHXc; |
642 | shared_sv *shared = (shared_sv *) mg->mg_ptr; |
643 | SHARED_EDIT; |
644 | if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { |
645 | av_clear((AV*) SHAREDSvPTR(shared)); |
646 | } |
647 | else { |
648 | hv_clear((HV*) SHAREDSvPTR(shared)); |
649 | } |
650 | SHARED_RELEASE; |
651 | return 0; |
652 | } |
653 | |
654 | int |
655 | sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) |
656 | { |
657 | Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr); |
658 | return 0; |
68795e93 |
659 | } |
660 | |
661 | /* |
21312124 |
662 | * This is called when perl is about to access an element of |
663 | * the array - |
664 | */ |
665 | int |
666 | sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, |
667 | SV *nsv, const char *name, int namlen) |
668 | { |
669 | shared_sv *shared = (shared_sv *) mg->mg_ptr; |
670 | MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, |
671 | toLOWER(mg->mg_type),&sharedsv_elem_vtbl, |
672 | name, namlen); |
a446a88f |
673 | SvREFCNT_inc(SHAREDSvPTR(shared)); |
21312124 |
674 | nmg->mg_flags |= MGf_DUP; |
21312124 |
675 | return 1; |
676 | } |
677 | |
678 | int |
679 | sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
680 | { |
681 | shared_sv *shared = (shared_sv *) mg->mg_ptr; |
682 | SvREFCNT_inc(SHAREDSvPTR(shared)); |
683 | mg->mg_flags |= MGf_DUP; |
684 | return 0; |
685 | } |
686 | |
687 | MGVTBL sharedsv_array_vtbl = { |
688 | 0, /* get */ |
689 | 0, /* set */ |
690 | sharedsv_array_mg_FETCHSIZE, /* len */ |
691 | sharedsv_array_mg_CLEAR, /* clear */ |
692 | sharedsv_array_mg_free, /* free */ |
693 | sharedsv_array_mg_copy, /* copy */ |
694 | sharedsv_array_mg_dup /* dup */ |
695 | }; |
696 | |
697 | =for apidoc sharedsv_unlock |
68795e93 |
698 | |
699 | Recursively unlocks a shared sv. |
700 | |
21312124 |
701 | =cut |
68795e93 |
702 | |
703 | void |
704 | Perl_sharedsv_unlock(pTHX_ shared_sv* ssv) |
705 | { |
6d56dc1c |
706 | recursive_lock_release(aTHX_ &ssv->lock); |
68795e93 |
707 | } |
708 | |
21312124 |
709 | =for apidoc sharedsv_lock |
68795e93 |
710 | |
21312124 |
711 | Recursive locks on a sharedsv. |
712 | Locks are dynamically scoped at the level of the first lock. |
68795e93 |
713 | |
21312124 |
714 | =cut |
68795e93 |
715 | |
716 | void |
21312124 |
717 | Perl_sharedsv_lock(pTHX_ shared_sv* ssv) |
68795e93 |
718 | { |
21312124 |
719 | if (!ssv) |
720 | return; |
6b85e4fe |
721 | recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__); |
68795e93 |
722 | } |
723 | |
21312124 |
724 | void |
725 | Perl_sharedsv_locksv(pTHX_ SV *sv) |
726 | { |
727 | Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv)); |
b050c948 |
728 | } |
729 | |
21312124 |
730 | =head1 Shared SV Functions |
b050c948 |
731 | |
21312124 |
732 | =for apidoc sharedsv_init |
b050c948 |
733 | |
21312124 |
734 | Saves a space for keeping SVs wider than an interpreter, |
735 | currently only stores a pointer to the first interpreter. |
b050c948 |
736 | |
21312124 |
737 | =cut |
738 | |
739 | void |
740 | Perl_sharedsv_init(pTHX) |
741 | { |
742 | dTHXc; |
743 | /* This pair leaves us in shared context ... */ |
744 | PL_sharedsv_space = perl_alloc(); |
745 | perl_construct(PL_sharedsv_space); |
746 | CALLER_CONTEXT; |
6d56dc1c |
747 | recursive_lock_init(aTHX_ &PL_sharedsv_lock); |
21312124 |
748 | PL_lockhook = &Perl_sharedsv_locksv; |
749 | PL_sharehook = &Perl_sharedsv_share; |
b050c948 |
750 | } |
751 | |
21312124 |
752 | MODULE = threads::shared PACKAGE = threads::shared::tie |
b050c948 |
753 | |
21312124 |
754 | PROTOTYPES: DISABLE |
b050c948 |
755 | |
6b85e4fe |
756 | |
21312124 |
757 | void |
758 | PUSH(shared_sv *shared, ...) |
759 | CODE: |
760 | dTHXc; |
761 | int i; |
21312124 |
762 | for(i = 1; i < items; i++) { |
763 | SV* tmp = newSVsv(ST(i)); |
a446a88f |
764 | shared_sv *target; |
6d56dc1c |
765 | ENTER_LOCK; |
a446a88f |
766 | target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0); |
6b85e4fe |
767 | sharedsv_scalar_store(aTHX_ tmp, target); |
21312124 |
768 | SHARED_CONTEXT; |
769 | av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target)); |
a446a88f |
770 | SHARED_RELEASE; |
21312124 |
771 | SvREFCNT_dec(tmp); |
772 | } |
b050c948 |
773 | |
21312124 |
774 | void |
775 | UNSHIFT(shared_sv *shared, ...) |
776 | CODE: |
777 | dTHXc; |
778 | int i; |
6d56dc1c |
779 | ENTER_LOCK; |
21312124 |
780 | SHARED_CONTEXT; |
781 | av_unshift((AV*)SHAREDSvPTR(shared), items - 1); |
782 | CALLER_CONTEXT; |
783 | for(i = 1; i < items; i++) { |
784 | SV* tmp = newSVsv(ST(i)); |
785 | shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0); |
6b85e4fe |
786 | sharedsv_scalar_store(aTHX_ tmp, target); |
21312124 |
787 | SHARED_CONTEXT; |
788 | av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target)); |
789 | CALLER_CONTEXT; |
790 | SvREFCNT_dec(tmp); |
791 | } |
6d56dc1c |
792 | LEAVE_LOCK; |
b050c948 |
793 | |
21312124 |
794 | void |
795 | POP(shared_sv *shared) |
796 | CODE: |
797 | dTHXc; |
798 | SV* sv; |
6d56dc1c |
799 | ENTER_LOCK; |
21312124 |
800 | SHARED_CONTEXT; |
801 | sv = av_pop((AV*)SHAREDSvPTR(shared)); |
802 | CALLER_CONTEXT; |
803 | ST(0) = Nullsv; |
804 | Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); |
6d56dc1c |
805 | LEAVE_LOCK; |
21312124 |
806 | XSRETURN(1); |
b050c948 |
807 | |
21312124 |
808 | void |
809 | SHIFT(shared_sv *shared) |
810 | CODE: |
811 | dTHXc; |
812 | SV* sv; |
6d56dc1c |
813 | ENTER_LOCK; |
21312124 |
814 | SHARED_CONTEXT; |
815 | sv = av_shift((AV*)SHAREDSvPTR(shared)); |
816 | CALLER_CONTEXT; |
817 | ST(0) = Nullsv; |
818 | Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); |
6d56dc1c |
819 | LEAVE_LOCK; |
21312124 |
820 | XSRETURN(1); |
b050c948 |
821 | |
21312124 |
822 | void |
823 | EXTEND(shared_sv *shared, IV count) |
824 | CODE: |
825 | dTHXc; |
826 | SHARED_EDIT; |
827 | av_extend((AV*)SHAREDSvPTR(shared), count); |
828 | SHARED_RELEASE; |
b050c948 |
829 | |
21312124 |
830 | void |
6b85e4fe |
831 | STORESIZE(shared_sv *shared,IV count) |
832 | CODE: |
833 | dTHXc; |
834 | SHARED_EDIT; |
835 | av_fill((AV*) SHAREDSvPTR(shared), count); |
836 | SHARED_RELEASE; |
837 | |
838 | |
839 | |
840 | |
841 | void |
21312124 |
842 | EXISTS(shared_sv *shared, SV *index) |
843 | CODE: |
844 | dTHXc; |
845 | bool exists; |
846 | SHARED_EDIT; |
847 | if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { |
848 | exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index)); |
849 | } |
850 | else { |
6b85e4fe |
851 | STRLEN len; |
852 | char *key = SvPV(index,len); |
853 | exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len); |
21312124 |
854 | } |
855 | SHARED_RELEASE; |
856 | ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; |
857 | XSRETURN(1); |
b050c948 |
858 | |
859 | |
860 | void |
21312124 |
861 | FIRSTKEY(shared_sv *shared) |
862 | CODE: |
863 | dTHXc; |
864 | char* key = NULL; |
865 | I32 len = 0; |
866 | HE* entry; |
6d56dc1c |
867 | ENTER_LOCK; |
21312124 |
868 | SHARED_CONTEXT; |
869 | hv_iterinit((HV*) SHAREDSvPTR(shared)); |
870 | entry = hv_iternext((HV*) SHAREDSvPTR(shared)); |
871 | if (entry) { |
872 | key = hv_iterkey(entry,&len); |
873 | CALLER_CONTEXT; |
874 | ST(0) = sv_2mortal(newSVpv(key, len)); |
875 | } else { |
876 | CALLER_CONTEXT; |
877 | ST(0) = &PL_sv_undef; |
878 | } |
6d56dc1c |
879 | LEAVE_LOCK; |
21312124 |
880 | XSRETURN(1); |
b050c948 |
881 | |
866fba46 |
882 | void |
21312124 |
883 | NEXTKEY(shared_sv *shared, SV *oldkey) |
884 | CODE: |
885 | dTHXc; |
886 | char* key = NULL; |
887 | I32 len = 0; |
888 | HE* entry; |
6d56dc1c |
889 | ENTER_LOCK; |
21312124 |
890 | SHARED_CONTEXT; |
891 | entry = hv_iternext((HV*) SHAREDSvPTR(shared)); |
6b85e4fe |
892 | if (entry) { |
21312124 |
893 | key = hv_iterkey(entry,&len); |
894 | CALLER_CONTEXT; |
895 | ST(0) = sv_2mortal(newSVpv(key, len)); |
896 | } else { |
897 | CALLER_CONTEXT; |
898 | ST(0) = &PL_sv_undef; |
899 | } |
6d56dc1c |
900 | LEAVE_LOCK; |
21312124 |
901 | XSRETURN(1); |
902 | |
903 | MODULE = threads::shared PACKAGE = threads::shared |
904 | |
905 | PROTOTYPES: ENABLE |
866fba46 |
906 | |
68795e93 |
907 | void |
9c4972d9 |
908 | _id(SV *ref) |
909 | PROTOTYPE: \[$@%] |
910 | CODE: |
911 | shared_sv *shared; |
912 | if(SvROK(ref)) |
913 | ref = SvRV(ref); |
914 | if (shared = Perl_sharedsv_find(aTHX_ ref)) { |
915 | ST(0) = sv_2mortal(newSViv(PTR2IV(shared))); |
916 | XSRETURN(1); |
917 | } |
918 | XSRETURN_UNDEF; |
919 | |
920 | |
921 | void |
6b85e4fe |
922 | _refcnt(SV *ref) |
a446a88f |
923 | PROTOTYPE: \[$@%] |
924 | CODE: |
925 | shared_sv *shared; |
926 | if(SvROK(ref)) |
927 | ref = SvRV(ref); |
928 | if (shared = Perl_sharedsv_find(aTHX_ ref)) { |
929 | if (SHAREDSvPTR(shared)) { |
930 | ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared)))); |
931 | XSRETURN(1); |
932 | } |
933 | else { |
934 | Perl_warn(aTHX_ "%_ s=%p has no shared SV",ST(0),shared); |
935 | } |
936 | } |
937 | else { |
938 | Perl_warn(aTHX_ "%_ is not shared",ST(0)); |
939 | } |
940 | XSRETURN_UNDEF; |
941 | |
942 | void |
943 | share(SV *ref) |
944 | PROTOTYPE: \[$@%] |
945 | CODE: |
946 | if(SvROK(ref)) |
947 | ref = SvRV(ref); |
948 | Perl_sharedsv_share(aTHX, ref); |
949 | |
950 | void |
21312124 |
951 | lock_enabled(SV *ref) |
ce127893 |
952 | PROTOTYPE: \[$@%] |
6f942b98 |
953 | CODE: |
954 | shared_sv* shared; |
955 | if(SvROK(ref)) |
956 | ref = SvRV(ref); |
957 | shared = Perl_sharedsv_find(aTHX, ref); |
21312124 |
958 | if(!shared) |
959 | croak("lock can only be used on shared values"); |
960 | Perl_sharedsv_lock(aTHX_ shared); |
6f942b98 |
961 | |
962 | void |
21312124 |
963 | cond_wait_enabled(SV *ref) |
ce127893 |
964 | PROTOTYPE: \[$@%] |
6f942b98 |
965 | CODE: |
966 | shared_sv* shared; |
967 | int locks; |
968 | if(SvROK(ref)) |
969 | ref = SvRV(ref); |
970 | shared = Perl_sharedsv_find(aTHX_ ref); |
971 | if(!shared) |
972 | croak("cond_wait can only be used on shared values"); |
6d56dc1c |
973 | if(shared->lock.owner != aTHX) |
6f942b98 |
974 | croak("You need a lock before you can cond_wait"); |
6d56dc1c |
975 | /* Stealing the members of the lock object worries me - NI-S */ |
976 | MUTEX_LOCK(&shared->lock.mutex); |
977 | shared->lock.owner = NULL; |
978 | locks = shared->lock.locks = 0; |
979 | COND_WAIT(&shared->user_cond, &shared->lock.mutex); |
980 | shared->lock.owner = aTHX; |
981 | shared->lock.locks = locks; |
982 | MUTEX_UNLOCK(&shared->lock.mutex); |
6f942b98 |
983 | |
21312124 |
984 | void |
985 | cond_signal_enabled(SV *ref) |
ce127893 |
986 | PROTOTYPE: \[$@%] |
6f942b98 |
987 | CODE: |
988 | shared_sv* shared; |
989 | if(SvROK(ref)) |
990 | ref = SvRV(ref); |
991 | shared = Perl_sharedsv_find(aTHX_ ref); |
992 | if(!shared) |
993 | croak("cond_signal can only be used on shared values"); |
994 | COND_SIGNAL(&shared->user_cond); |
995 | |
21312124 |
996 | void |
997 | cond_broadcast_enabled(SV *ref) |
ce127893 |
998 | PROTOTYPE: \[$@%] |
6f942b98 |
999 | CODE: |
1000 | shared_sv* shared; |
1001 | if(SvROK(ref)) |
1002 | ref = SvRV(ref); |
1003 | shared = Perl_sharedsv_find(aTHX_ ref); |
1004 | if(!shared) |
1005 | croak("cond_broadcast can only be used on shared values"); |
1006 | COND_BROADCAST(&shared->user_cond); |
b050c948 |
1007 | |
68795e93 |
1008 | BOOT: |
1009 | { |
1010 | Perl_sharedsv_init(aTHX); |
1011 | } |