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