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