Commit | Line | Data |
afe38520 |
1 | /* shared.xs |
68795e93 |
2 | * |
60c5c75c |
3 | * Copyright (c) 2001-2002, 2006 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 | * |
7473853a |
12 | * Contributed by Artur Bergman <sky AT crucially DOT net> |
13 | * Pulled in the (an)other direction by Nick Ing-Simmons |
14 | * <nick AT ing-simmons DOT net> |
15 | * CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org> |
21312124 |
16 | */ |
68795e93 |
17 | |
29ecdb6f |
18 | /* |
19 | * Shared variables are implemented by a scheme similar to tieing. |
20 | * Each thread has a proxy SV with attached magic -- "private SVs" -- |
21 | * which all point to a single SV in a separate shared interpreter |
22 | * (PL_sharedsv_space) -- "shared SVs". |
23 | * |
24 | * The shared SV holds the variable's true values, and its state is |
25 | * copied between the shared and private SVs with the usual |
26 | * mg_get()/mg_set() arrangement. |
27 | * |
28 | * Aggregates (AVs and HVs) are implemented using tie magic, except that |
29 | * the vtable used is one defined in this file rather than the standard one. |
7473853a |
30 | * This means that where a tie function like FETCH is normally invoked by |
29ecdb6f |
31 | * the tie magic's mg_get() function, we completely bypass the calling of a |
32 | * perl-level function, and directly call C-level code to handle it. On |
7473853a |
33 | * the other hand, calls to functions like PUSH are done directly by code |
34 | * in av.c, etc., which we can't bypass. So the best we can do is to provide |
29ecdb6f |
35 | * XS versions of these functions. We also have to attach a tie object, |
36 | * blessed into the class threads::shared::tie, to keep the method-calling |
37 | * code happy. |
38 | * |
39 | * Access to aggregate elements is done the usual tied way by returning a |
40 | * proxy PVLV element with attached element magic. |
41 | * |
42 | * Pointers to the shared SV are squirrelled away in the mg->mg_ptr field |
43 | * of magic (with mg_len == 0), and in the IV2PTR(SvIV(sv)) field of tied |
44 | * object SVs. These pointers have to be hidden like this because they |
45 | * cross interpreter boundaries, and we don't want sv_clear() and friends |
46 | * following them. |
47 | * |
48 | * The three basic shared types look like the following: |
49 | * |
50 | * ----------------- |
51 | * |
52 | * Shared scalar (my $s : shared): |
53 | * |
54 | * SV = PVMG(0x7ba238) at 0x7387a8 |
55 | * FLAGS = (PADMY,GMG,SMG) |
56 | * MAGIC = 0x824d88 |
57 | * MG_TYPE = PERL_MAGIC_shared_scalar(n) |
7473853a |
58 | * MG_PTR = 0x810358 <<<< pointer to the shared SV |
29ecdb6f |
59 | * |
60 | * ----------------- |
61 | * |
62 | * Shared aggregate (my @a : shared; my %h : shared): |
63 | * |
64 | * SV = PVAV(0x7175d0) at 0x738708 |
65 | * FLAGS = (PADMY,RMG) |
66 | * MAGIC = 0x824e48 |
67 | * MG_TYPE = PERL_MAGIC_tied(P) |
7473853a |
68 | * MG_OBJ = 0x7136e0 <<<< ref to the tied object |
29ecdb6f |
69 | * SV = RV(0x7136f0) at 0x7136e0 |
70 | * RV = 0x738640 |
71 | * SV = PVMG(0x7ba238) at 0x738640 <<<< the tied object |
72 | * FLAGS = (OBJECT,IOK,pIOK) |
7473853a |
73 | * IV = 8455000 <<<< pointer to the shared AV |
29ecdb6f |
74 | * STASH = 0x80abf0 "threads::shared::tie" |
7473853a |
75 | * MG_PTR = 0x810358 "" <<<< another pointer to the shared AV |
29ecdb6f |
76 | * ARRAY = 0x0 |
77 | * |
78 | * ----------------- |
79 | * |
80 | * Aggregate element (my @a : shared; $a[0]) |
81 | * |
82 | * SV = PVLV(0x77f628) at 0x713550 |
83 | * FLAGS = (GMG,SMG,RMG,pIOK) |
84 | * MAGIC = 0x72bd58 |
85 | * MG_TYPE = PERL_MAGIC_shared_scalar(n) |
7473853a |
86 | * MG_PTR = 0x8103c0 "" <<<< pointer to the shared element |
29ecdb6f |
87 | * MAGIC = 0x72bd18 |
88 | * MG_TYPE = PERL_MAGIC_tiedelem(p) |
7473853a |
89 | * MG_OBJ = 0x7136e0 <<<< ref to the tied object |
29ecdb6f |
90 | * SV = RV(0x7136f0) at 0x7136e0 |
91 | * RV = 0x738660 |
92 | * SV = PVMG(0x7ba278) at 0x738660 <<<< the tied object |
93 | * FLAGS = (OBJECT,IOK,pIOK) |
7473853a |
94 | * IV = 8455064 <<<< pointer to the shared AV |
29ecdb6f |
95 | * STASH = 0x80ac30 "threads::shared::tie" |
96 | * TYPE = t |
97 | * |
98 | * Note that PERL_MAGIC_tiedelem(p) magic doesn't have a pointer to a |
99 | * shared SV in mg_ptr; instead this is used to store the hash key, |
100 | * if any, like normal tied elements. Note also that element SVs may have |
7473853a |
101 | * pointers to both the shared aggregate and the shared element. |
29ecdb6f |
102 | * |
103 | * |
104 | * Userland locks: |
105 | * |
7473853a |
106 | * If a shared variable is used as a perl-level lock or condition |
29ecdb6f |
107 | * variable, then PERL_MAGIC_ext magic is attached to the associated |
7473853a |
108 | * *shared* SV, whose mg_ptr field points to a malloc'ed structure |
29ecdb6f |
109 | * containing the necessary mutexes and condition variables. |
110 | * |
111 | * Nomenclature: |
112 | * |
7473853a |
113 | * In this file, any variable name prefixed with 's' (e.g., ssv, stmp or sobj) |
114 | * usually represents a shared SV which corresponds to a private SV named |
115 | * without the prefix (e.g., sv, tmp or obj). |
116 | */ |
117 | |
68795e93 |
118 | #define PERL_NO_GET_CONTEXT |
b050c948 |
119 | #include "EXTERN.h" |
120 | #include "perl.h" |
121 | #include "XSUB.h" |
7473853a |
122 | #ifdef HAS_PPPORT_H |
39ec4146 |
123 | # define NEED_sv_2pv_flags |
05b59262 |
124 | # define NEED_vnewSVpvf |
125 | # define NEED_warner |
c4393b60 |
126 | # define NEED_newSVpvn_flags |
7473853a |
127 | # include "ppport.h" |
128 | # include "shared.h" |
129 | #endif |
b050c948 |
130 | |
73e09c8f |
131 | #ifdef USE_ITHREADS |
132 | |
e21694ed |
133 | /* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */ |
134 | #define UL_MAGIC_SIG 0x554C /* UL = user lock */ |
135 | |
21312124 |
136 | /* |
137 | * The shared things need an intepreter to live in ... |
138 | */ |
139 | PerlInterpreter *PL_sharedsv_space; /* The shared sv space */ |
140 | /* To access shared space we fake aTHX in this scope and thread's context */ |
057e91b3 |
141 | |
7473853a |
142 | /* Bug #24255: We include ENTER+SAVETMPS/FREETMPS+LEAVE with |
143 | * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals, etc. created |
1011f542 |
144 | * while in the shared interpreter context don't languish */ |
057e91b3 |
145 | |
7473853a |
146 | #define SHARED_CONTEXT \ |
147 | STMT_START { \ |
148 | PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \ |
149 | ENTER; \ |
150 | SAVETMPS; \ |
057e91b3 |
151 | } STMT_END |
21312124 |
152 | |
153 | /* So we need a way to switch back to the caller's context... */ |
154 | /* So we declare _another_ copy of the aTHX variable ... */ |
155 | #define dTHXc PerlInterpreter *caller_perl = aTHX |
057e91b3 |
156 | |
7473853a |
157 | /* ... and use it to switch back */ |
158 | #define CALLER_CONTEXT \ |
159 | STMT_START { \ |
160 | FREETMPS; \ |
161 | LEAVE; \ |
162 | PERL_SET_CONTEXT((aTHX = caller_perl)); \ |
057e91b3 |
163 | } STMT_END |
21312124 |
164 | |
165 | /* |
166 | * Only one thread at a time is allowed to mess with shared space. |
167 | */ |
a446a88f |
168 | |
7473853a |
169 | typedef struct { |
170 | perl_mutex mutex; |
171 | PerlInterpreter *owner; |
172 | I32 locks; |
173 | perl_cond cond; |
6b85e4fe |
174 | #ifdef DEBUG_LOCKS |
7473853a |
175 | char * file; |
176 | int line; |
6b85e4fe |
177 | #endif |
6d56dc1c |
178 | } recursive_lock_t; |
179 | |
7473853a |
180 | recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */ |
6d56dc1c |
181 | |
182 | void |
183 | recursive_lock_init(pTHX_ recursive_lock_t *lock) |
184 | { |
185 | Zero(lock,1,recursive_lock_t); |
186 | MUTEX_INIT(&lock->mutex); |
187 | COND_INIT(&lock->cond); |
188 | } |
189 | |
a39edb3a |
190 | void |
579f9913 |
191 | recursive_lock_destroy(pTHX_ recursive_lock_t *lock) |
192 | { |
193 | MUTEX_DESTROY(&lock->mutex); |
194 | COND_DESTROY(&lock->cond); |
195 | } |
196 | |
6d56dc1c |
197 | void |
198 | recursive_lock_release(pTHX_ recursive_lock_t *lock) |
199 | { |
200 | MUTEX_LOCK(&lock->mutex); |
ba2940ce |
201 | if (lock->owner == aTHX) { |
202 | if (--lock->locks == 0) { |
203 | lock->owner = NULL; |
204 | COND_SIGNAL(&lock->cond); |
205 | } |
6d56dc1c |
206 | } |
207 | MUTEX_UNLOCK(&lock->mutex); |
208 | } |
a446a88f |
209 | |
6d56dc1c |
210 | void |
7473853a |
211 | recursive_lock_acquire(pTHX_ recursive_lock_t *lock, char *file, int line) |
6d56dc1c |
212 | { |
213 | assert(aTHX); |
214 | MUTEX_LOCK(&lock->mutex); |
215 | if (lock->owner == aTHX) { |
7473853a |
216 | lock->locks++; |
217 | } else { |
218 | while (lock->owner) { |
6b85e4fe |
219 | #ifdef DEBUG_LOCKS |
7473853a |
220 | Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n", |
221 | aTHX, lock->owner, lock->file, lock->line); |
6b85e4fe |
222 | #endif |
7473853a |
223 | COND_WAIT(&lock->cond,&lock->mutex); |
6b85e4fe |
224 | } |
7473853a |
225 | lock->locks = 1; |
226 | lock->owner = aTHX; |
6b85e4fe |
227 | #ifdef DEBUG_LOCKS |
7473853a |
228 | lock->file = file; |
229 | lock->line = line; |
6b85e4fe |
230 | #endif |
6d56dc1c |
231 | } |
232 | MUTEX_UNLOCK(&lock->mutex); |
6b85e4fe |
233 | SAVEDESTRUCTOR_X(recursive_lock_release,lock); |
6d56dc1c |
234 | } |
235 | |
7473853a |
236 | #define ENTER_LOCK \ |
237 | STMT_START { \ |
238 | ENTER; \ |
239 | recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\ |
240 | } STMT_END |
21312124 |
241 | |
7473853a |
242 | /* The unlocking is done automatically at scope exit */ |
243 | #define LEAVE_LOCK LEAVE |
6d56dc1c |
244 | |
21312124 |
245 | |
246 | /* A common idiom is to acquire access and switch in ... */ |
7473853a |
247 | #define SHARED_EDIT \ |
248 | STMT_START { \ |
249 | ENTER_LOCK; \ |
250 | SHARED_CONTEXT; \ |
251 | } STMT_END |
21312124 |
252 | |
7473853a |
253 | /* ... then switch out and release access. */ |
254 | #define SHARED_RELEASE \ |
255 | STMT_START { \ |
256 | CALLER_CONTEXT; \ |
257 | LEAVE_LOCK; \ |
258 | } STMT_END |
85e0a142 |
259 | |
21312124 |
260 | |
7473853a |
261 | /* User-level locks: |
29ecdb6f |
262 | This structure is attached (using ext magic) to any shared SV that |
263 | is used by user-level locking or condition code |
21312124 |
264 | */ |
68795e93 |
265 | |
266 | typedef struct { |
7473853a |
267 | recursive_lock_t lock; /* For user-levl locks */ |
68795e93 |
268 | perl_cond user_cond; /* For user-level conditions */ |
29ecdb6f |
269 | } user_lock; |
68795e93 |
270 | |
7473853a |
271 | /* Magic used for attaching user_lock structs to shared SVs |
68795e93 |
272 | |
21312124 |
273 | The vtable used has just one entry - when the SV goes away |
274 | we free the memory for the above. |
21312124 |
275 | */ |
68795e93 |
276 | |
21312124 |
277 | int |
29ecdb6f |
278 | sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg) |
21312124 |
279 | { |
29ecdb6f |
280 | user_lock *ul = (user_lock *) mg->mg_ptr; |
281 | assert(aTHX == PL_sharedsv_space); |
282 | if (ul) { |
7473853a |
283 | recursive_lock_destroy(aTHX_ &ul->lock); |
284 | COND_DESTROY(&ul->user_cond); |
285 | PerlMemShared_free(ul); |
286 | mg->mg_ptr = NULL; |
21312124 |
287 | } |
7473853a |
288 | return (0); |
21312124 |
289 | } |
290 | |
7473853a |
291 | MGVTBL sharedsv_userlock_vtbl = { |
292 | 0, /* get */ |
293 | 0, /* set */ |
294 | 0, /* len */ |
295 | 0, /* clear */ |
296 | sharedsv_userlock_free, /* free */ |
297 | 0, /* copy */ |
298 | 0, /* dup */ |
299 | #ifdef MGf_LOCAL |
300 | 0, /* local */ |
301 | #endif |
21312124 |
302 | }; |
303 | |
7473853a |
304 | /* |
305 | * Access to shared things is heavily based on MAGIC |
306 | * - in mg.h/mg.c/sv.c sense |
307 | */ |
21312124 |
308 | |
309 | /* In any thread that has access to a shared thing there is a "proxy" |
310 | for it in its own space which has 'MAGIC' associated which accesses |
311 | the shared thing. |
312 | */ |
313 | |
3bc7ad01 |
314 | extern MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */ |
315 | extern MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this |
316 | - like 'tie' */ |
317 | extern MGVTBL sharedsv_elem_vtbl; /* Elements of hashes and arrays have |
318 | this _AS WELL AS_ the scalar magic: |
29ecdb6f |
319 | The sharedsv_elem_vtbl associates the element with the array/hash and |
21312124 |
320 | the sharedsv_scalar_vtbl associates it with the value |
321 | */ |
322 | |
6b85e4fe |
323 | |
7473853a |
324 | /* Get shared aggregate SV pointed to by threads::shared::tie magic object */ |
29ecdb6f |
325 | |
326 | STATIC SV * |
327 | S_sharedsv_from_obj(pTHX_ SV *sv) |
6b85e4fe |
328 | { |
7473853a |
329 | return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL); |
29ecdb6f |
330 | } |
331 | |
332 | |
333 | /* Return the user_lock structure (if any) associated with a shared SV. |
7473853a |
334 | * If create is true, create one if it doesn't exist |
335 | */ |
29ecdb6f |
336 | STATIC user_lock * |
337 | S_get_userlock(pTHX_ SV* ssv, bool create) |
338 | { |
339 | MAGIC *mg; |
340 | user_lock *ul = NULL; |
341 | |
342 | assert(ssv); |
7473853a |
343 | /* XXX Redesign the storage of user locks so we don't need a global |
29ecdb6f |
344 | * lock to access them ???? DAPM */ |
345 | ENTER_LOCK; |
e21694ed |
346 | |
347 | /* Version of mg_find that also checks the private signature */ |
348 | for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) { |
349 | if ((mg->mg_type == PERL_MAGIC_ext) && |
350 | (mg->mg_private == UL_MAGIC_SIG)) |
351 | { |
352 | break; |
353 | } |
354 | } |
355 | |
7473853a |
356 | if (mg) { |
357 | ul = (user_lock*)(mg->mg_ptr); |
358 | } else if (create) { |
359 | dTHXc; |
360 | SHARED_CONTEXT; |
361 | ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock)); |
362 | Zero(ul, 1, user_lock); |
363 | /* Attach to shared SV using ext magic */ |
e21694ed |
364 | mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl, |
365 | (char *)ul, 0); |
366 | mg->mg_private = UL_MAGIC_SIG; /* Set private signature */ |
7473853a |
367 | recursive_lock_init(aTHX_ &ul->lock); |
368 | COND_INIT(&ul->user_cond); |
369 | CALLER_CONTEXT; |
29ecdb6f |
370 | } |
371 | LEAVE_LOCK; |
7473853a |
372 | return (ul); |
6b85e4fe |
373 | } |
374 | |
29ecdb6f |
375 | |
ba2940ce |
376 | /* Given a private side SV tries to find if the SV has a shared backend, |
377 | * by looking for the magic. |
378 | */ |
29ecdb6f |
379 | SV * |
21312124 |
380 | Perl_sharedsv_find(pTHX_ SV *sv) |
381 | { |
382 | MAGIC *mg; |
a446a88f |
383 | if (SvTYPE(sv) >= SVt_PVMG) { |
7473853a |
384 | switch(SvTYPE(sv)) { |
385 | case SVt_PVAV: |
386 | case SVt_PVHV: |
387 | if ((mg = mg_find(sv, PERL_MAGIC_tied)) |
388 | && mg->mg_virtual == &sharedsv_array_vtbl) { |
389 | return ((SV *)mg->mg_ptr); |
390 | } |
391 | break; |
392 | default: |
393 | /* This should work for elements as well as they |
394 | * have scalar magic as well as their element magic |
395 | */ |
396 | if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar)) |
397 | && mg->mg_virtual == &sharedsv_scalar_vtbl) { |
398 | return ((SV *)mg->mg_ptr); |
399 | } |
400 | break; |
401 | } |
21312124 |
402 | } |
6b85e4fe |
403 | /* Just for tidyness of API also handle tie objects */ |
404 | if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) { |
7473853a |
405 | return (S_sharedsv_from_obj(aTHX_ sv)); |
6b85e4fe |
406 | } |
7473853a |
407 | return (NULL); |
21312124 |
408 | } |
68795e93 |
409 | |
68795e93 |
410 | |
7473853a |
411 | /* Associate a private SV with a shared SV by pointing the appropriate |
412 | * magics at it. |
413 | * Assumes lock is held. |
414 | */ |
29ecdb6f |
415 | void |
416 | Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv) |
21312124 |
417 | { |
a446a88f |
418 | MAGIC *mg = 0; |
a446a88f |
419 | |
29ecdb6f |
420 | /* If we are asked for any private ops we need a thread */ |
a446a88f |
421 | assert ( aTHX != PL_sharedsv_space ); |
422 | |
423 | /* To avoid need for recursive locks require caller to hold lock */ |
6d56dc1c |
424 | assert ( PL_sharedsv_lock.owner == aTHX ); |
6b85e4fe |
425 | |
29ecdb6f |
426 | switch(SvTYPE(sv)) { |
427 | case SVt_PVAV: |
428 | case SVt_PVHV: |
7473853a |
429 | if (!(mg = mg_find(sv, PERL_MAGIC_tied)) |
430 | || mg->mg_virtual != &sharedsv_array_vtbl |
431 | || (SV*) mg->mg_ptr != ssv) |
432 | { |
433 | SV *obj = newSV(0); |
434 | sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv)); |
435 | if (mg) { |
436 | sv_unmagic(sv, PERL_MAGIC_tied); |
437 | } |
438 | mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl, |
439 | (char *)ssv, 0); |
440 | mg->mg_flags |= (MGf_COPY|MGf_DUP); |
441 | SvREFCNT_inc_void(ssv); |
442 | SvREFCNT_dec(obj); |
443 | } |
444 | break; |
68795e93 |
445 | |
29ecdb6f |
446 | default: |
7473853a |
447 | if ((SvTYPE(sv) < SVt_PVMG) |
448 | || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) |
449 | || mg->mg_virtual != &sharedsv_scalar_vtbl |
450 | || (SV*) mg->mg_ptr != ssv) |
451 | { |
452 | if (mg) { |
453 | sv_unmagic(sv, PERL_MAGIC_shared_scalar); |
454 | } |
455 | mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, |
456 | &sharedsv_scalar_vtbl, (char *)ssv, 0); |
457 | mg->mg_flags |= (MGf_DUP |
458 | #ifdef MGf_LOCAL |
459 | |MGf_LOCAL |
460 | #endif |
461 | ); |
462 | SvREFCNT_inc_void(ssv); |
463 | } |
464 | break; |
21312124 |
465 | } |
7473853a |
466 | |
29ecdb6f |
467 | assert ( Perl_sharedsv_find(aTHX_ sv) == ssv ); |
468 | } |
6b85e4fe |
469 | |
6b85e4fe |
470 | |
29ecdb6f |
471 | /* Given a private SV, create and return an associated shared SV. |
7473853a |
472 | * Assumes lock is held. |
473 | */ |
29ecdb6f |
474 | STATIC SV * |
475 | S_sharedsv_new_shared(pTHX_ SV *sv) |
476 | { |
477 | dTHXc; |
478 | SV *ssv; |
6b85e4fe |
479 | |
29ecdb6f |
480 | assert(PL_sharedsv_lock.owner == aTHX); |
481 | assert(aTHX != PL_sharedsv_space); |
68795e93 |
482 | |
29ecdb6f |
483 | SHARED_CONTEXT; |
484 | ssv = newSV(0); |
7473853a |
485 | SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */ |
29ecdb6f |
486 | sv_upgrade(ssv, SvTYPE(sv)); |
487 | CALLER_CONTEXT; |
488 | Perl_sharedsv_associate(aTHX_ sv, ssv); |
7473853a |
489 | return (ssv); |
29ecdb6f |
490 | } |
21312124 |
491 | |
21312124 |
492 | |
29ecdb6f |
493 | /* Given a shared SV, create and return an associated private SV. |
7473853a |
494 | * Assumes lock is held. |
495 | */ |
29ecdb6f |
496 | STATIC SV * |
497 | S_sharedsv_new_private(pTHX_ SV *ssv) |
498 | { |
499 | SV *sv; |
500 | |
501 | assert(PL_sharedsv_lock.owner == aTHX); |
502 | assert(aTHX != PL_sharedsv_space); |
503 | |
504 | sv = newSV(0); |
505 | sv_upgrade(sv, SvTYPE(ssv)); |
506 | Perl_sharedsv_associate(aTHX_ sv, ssv); |
7473853a |
507 | return (sv); |
21312124 |
508 | } |
68795e93 |
509 | |
29ecdb6f |
510 | |
7473853a |
511 | /* A threadsafe version of SvREFCNT_dec(ssv) */ |
29ecdb6f |
512 | |
513 | STATIC void |
514 | S_sharedsv_dec(pTHX_ SV* ssv) |
68795e93 |
515 | { |
7473853a |
516 | if (! ssv) |
517 | return; |
29ecdb6f |
518 | ENTER_LOCK; |
519 | if (SvREFCNT(ssv) > 1) { |
7473853a |
520 | /* No side effects, so can do it lightweight */ |
521 | SvREFCNT_dec(ssv); |
522 | } else { |
523 | dTHXc; |
524 | SHARED_CONTEXT; |
525 | SvREFCNT_dec(ssv); |
526 | CALLER_CONTEXT; |
21312124 |
527 | } |
29ecdb6f |
528 | LEAVE_LOCK; |
68795e93 |
529 | } |
530 | |
7473853a |
531 | |
532 | /* Implements Perl-level share() and :shared */ |
29ecdb6f |
533 | |
21312124 |
534 | void |
535 | Perl_sharedsv_share(pTHX_ SV *sv) |
536 | { |
537 | switch(SvTYPE(sv)) { |
538 | case SVt_PVGV: |
7473853a |
539 | Perl_croak(aTHX_ "Cannot share globs yet"); |
540 | break; |
21312124 |
541 | |
542 | case SVt_PVCV: |
7473853a |
543 | Perl_croak(aTHX_ "Cannot share subs yet"); |
544 | break; |
85e0a142 |
545 | |
21312124 |
546 | default: |
7473853a |
547 | ENTER_LOCK; |
548 | (void) S_sharedsv_new_shared(aTHX_ sv); |
549 | LEAVE_LOCK; |
550 | SvSETMAGIC(sv); |
551 | break; |
21312124 |
552 | } |
553 | } |
68795e93 |
554 | |
7473853a |
555 | |
2a6601ce |
556 | #ifdef WIN32 |
557 | /* Number of milliseconds from 1/1/1601 to 1/1/1970 */ |
558 | #define EPOCH_BIAS 11644473600000. |
559 | |
560 | /* Returns relative time in milliseconds. (Adapted from Time::HiRes.) */ |
561 | STATIC DWORD |
562 | S_abs_2_rel_milli(double abs) |
563 | { |
564 | double rel; |
565 | |
566 | /* Get current time (in units of 100 nanoseconds since 1/1/1601) */ |
567 | union { |
05b59262 |
568 | FILETIME ft; |
569 | __int64 i64; /* 'signed' to keep compilers happy */ |
2a6601ce |
570 | } now; |
571 | |
572 | GetSystemTimeAsFileTime(&now.ft); |
573 | |
574 | /* Relative time in milliseconds */ |
575 | rel = (abs * 1000.) - (((double)now.i64 / 10000.) - EPOCH_BIAS); |
2a6601ce |
576 | if (rel <= 0.0) { |
577 | return (0); |
578 | } |
579 | return (DWORD)rel; |
580 | } |
581 | |
582 | #else |
583 | # if defined(OS2) |
7473853a |
584 | # define ABS2RELMILLI(abs) \ |
a0e036c1 |
585 | do { \ |
2666606c |
586 | abs -= (double)time(NULL); \ |
a0e036c1 |
587 | if (abs > 0) { abs *= 1000; } \ |
588 | else { abs = 0; } \ |
589 | } while (0) |
2a6601ce |
590 | # endif /* OS2 */ |
591 | #endif /* WIN32 */ |
a0e036c1 |
592 | |
7473853a |
593 | /* Do OS-specific condition timed wait */ |
29ecdb6f |
594 | |
a0e036c1 |
595 | bool |
596 | Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) |
597 | { |
598 | #if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS) |
599 | Perl_croak_nocontext("cond_timedwait not supported on this platform"); |
600 | #else |
601 | # ifdef WIN32 |
602 | int got_it = 0; |
603 | |
a0e036c1 |
604 | cond->waiters++; |
605 | MUTEX_UNLOCK(mut); |
606 | /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */ |
2a6601ce |
607 | switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) { |
a0e036c1 |
608 | case WAIT_OBJECT_0: got_it = 1; break; |
609 | case WAIT_TIMEOUT: break; |
610 | default: |
611 | /* WAIT_FAILED? WAIT_ABANDONED? others? */ |
612 | Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError()); |
613 | break; |
614 | } |
615 | MUTEX_LOCK(mut); |
2666606c |
616 | cond->waiters--; |
7473853a |
617 | return (got_it); |
a0e036c1 |
618 | # else |
619 | # ifdef OS2 |
620 | int rc, got_it = 0; |
621 | STRLEN n_a; |
622 | |
623 | ABS2RELMILLI(abs); |
624 | |
625 | if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET)) |
626 | Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset"); |
627 | MUTEX_UNLOCK(mut); |
628 | if (CheckOSError(DosWaitEventSem(*cond,abs)) |
629 | && (rc != ERROR_INTERRUPT)) |
630 | croak_with_os2error("panic: cond_timedwait"); |
631 | if (rc == ERROR_INTERRUPT) errno = EINTR; |
632 | MUTEX_LOCK(mut); |
7473853a |
633 | return (got_it); |
634 | # else /* Hope you're I_PTHREAD! */ |
a0e036c1 |
635 | struct timespec ts; |
636 | int got_it = 0; |
637 | |
638 | ts.tv_sec = (long)abs; |
639 | abs -= (NV)ts.tv_sec; |
640 | ts.tv_nsec = (long)(abs * 1000000000.0); |
641 | |
642 | switch (pthread_cond_timedwait(cond, mut, &ts)) { |
643 | case 0: got_it = 1; break; |
644 | case ETIMEDOUT: break; |
cf0d1c66 |
645 | #ifdef OEMVS |
646 | case -1: |
7473853a |
647 | if (errno == ETIMEDOUT || errno == EAGAIN) |
648 | break; |
cf0d1c66 |
649 | #endif |
a0e036c1 |
650 | default: |
651 | Perl_croak_nocontext("panic: cond_timedwait"); |
652 | break; |
653 | } |
7473853a |
654 | return (got_it); |
a0e036c1 |
655 | # endif /* OS2 */ |
656 | # endif /* WIN32 */ |
657 | #endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */ |
658 | } |
659 | |
dad67c22 |
660 | |
7473853a |
661 | /* Given a shared RV, copy it's value to a private RV, also copying the |
dad67c22 |
662 | * object status of the referent. |
663 | * If the private side is already an appropriate RV->SV combination, keep |
664 | * it if possible. |
665 | */ |
dad67c22 |
666 | STATIC void |
667 | S_get_RV(pTHX_ SV *sv, SV *ssv) { |
668 | SV *sobj = SvRV(ssv); |
669 | SV *obj; |
7473853a |
670 | if (! (SvROK(sv) && |
671 | ((obj = SvRV(sv))) && |
672 | (Perl_sharedsv_find(aTHX_ obj) == sobj) && |
673 | (SvTYPE(obj) == SvTYPE(sobj)))) |
dad67c22 |
674 | { |
7473853a |
675 | /* Can't reuse obj */ |
676 | if (SvROK(sv)) { |
677 | SvREFCNT_dec(SvRV(sv)); |
678 | } else { |
679 | assert(SvTYPE(sv) >= SVt_RV); |
680 | sv_setsv_nomg(sv, &PL_sv_undef); |
681 | SvROK_on(sv); |
682 | } |
683 | obj = S_sharedsv_new_private(aTHX_ SvRV(ssv)); |
684 | SvRV_set(sv, obj); |
dad67c22 |
685 | } |
686 | |
687 | if (SvOBJECT(obj)) { |
7473853a |
688 | /* Remove any old blessing */ |
689 | SvREFCNT_dec(SvSTASH(obj)); |
690 | SvOBJECT_off(obj); |
dad67c22 |
691 | } |
692 | if (SvOBJECT(sobj)) { |
7473853a |
693 | /* Add any new old blessing */ |
694 | STRLEN len; |
695 | char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len); |
696 | HV* stash = gv_stashpvn(stash_ptr, len, TRUE); |
697 | SvOBJECT_on(obj); |
698 | SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash)); |
dad67c22 |
699 | } |
700 | } |
701 | |
702 | |
29ecdb6f |
703 | /* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */ |
704 | |
7473853a |
705 | /* Get magic for PERL_MAGIC_shared_scalar(n) */ |
68795e93 |
706 | |
21312124 |
707 | int |
708 | sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) |
68795e93 |
709 | { |
29ecdb6f |
710 | SV *ssv = (SV *) mg->mg_ptr; |
711 | assert(ssv); |
21312124 |
712 | |
6d56dc1c |
713 | ENTER_LOCK; |
29ecdb6f |
714 | if (SvROK(ssv)) { |
7473853a |
715 | S_get_RV(aTHX_ sv, ssv); |
500a8019 |
716 | /* Look ahead for refs of refs */ |
f6d55995 |
717 | if (SvROK(SvRV(ssv))) { |
718 | SvROK_on(SvRV(sv)); |
719 | S_get_RV(aTHX_ SvRV(sv), SvRV(ssv)); |
720 | } |
7473853a |
721 | } else { |
722 | sv_setsv_nomg(sv, ssv); |
21312124 |
723 | } |
6d56dc1c |
724 | LEAVE_LOCK; |
7473853a |
725 | return (0); |
21312124 |
726 | } |
727 | |
7473853a |
728 | /* Copy the contents of a private SV to a shared SV. |
729 | * Used by various mg_set()-type functions. |
730 | * Assumes lock is held. |
731 | */ |
6b85e4fe |
732 | void |
29ecdb6f |
733 | sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) |
21312124 |
734 | { |
735 | dTHXc; |
21312124 |
736 | bool allowed = TRUE; |
29ecdb6f |
737 | |
738 | assert(PL_sharedsv_lock.owner == aTHX); |
21312124 |
739 | if (SvROK(sv)) { |
7473853a |
740 | SV *obj = SvRV(sv); |
741 | SV *sobj = Perl_sharedsv_find(aTHX_ obj); |
742 | if (sobj) { |
743 | SHARED_CONTEXT; |
2a6601ce |
744 | (void)SvUPGRADE(ssv, SVt_RV); |
7473853a |
745 | sv_setsv_nomg(ssv, &PL_sv_undef); |
746 | |
747 | SvRV_set(ssv, SvREFCNT_inc(sobj)); |
748 | SvROK_on(ssv); |
749 | if (SvOBJECT(sobj)) { |
750 | /* Remove any old blessing */ |
751 | SvREFCNT_dec(SvSTASH(sobj)); |
752 | SvOBJECT_off(sobj); |
753 | } |
754 | if (SvOBJECT(obj)) { |
755 | SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0); |
756 | SvOBJECT_on(sobj); |
757 | SvSTASH_set(sobj, (HV*)fake_stash); |
758 | } |
759 | CALLER_CONTEXT; |
760 | } else { |
761 | allowed = FALSE; |
762 | } |
763 | } else { |
5c360ac5 |
764 | SvTEMP_off(sv); |
7473853a |
765 | SHARED_CONTEXT; |
766 | sv_setsv_nomg(ssv, sv); |
767 | if (SvOBJECT(ssv)) { |
768 | /* Remove any old blessing */ |
769 | SvREFCNT_dec(SvSTASH(ssv)); |
770 | SvOBJECT_off(ssv); |
771 | } |
772 | if (SvOBJECT(sv)) { |
773 | SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); |
774 | SvOBJECT_on(ssv); |
775 | SvSTASH_set(ssv, (HV*)fake_stash); |
776 | } |
777 | CALLER_CONTEXT; |
21312124 |
778 | } |
21312124 |
779 | if (!allowed) { |
7473853a |
780 | Perl_croak(aTHX_ "Invalid value for shared scalar"); |
21312124 |
781 | } |
6b85e4fe |
782 | } |
783 | |
7473853a |
784 | /* Set magic for PERL_MAGIC_shared_scalar(n) */ |
29ecdb6f |
785 | |
6b85e4fe |
786 | int |
787 | sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) |
788 | { |
29ecdb6f |
789 | SV *ssv = (SV*)(mg->mg_ptr); |
790 | assert(ssv); |
6b85e4fe |
791 | ENTER_LOCK; |
29ecdb6f |
792 | if (SvTYPE(ssv) < SvTYPE(sv)) { |
7473853a |
793 | dTHXc; |
794 | SHARED_CONTEXT; |
795 | sv_upgrade(ssv, SvTYPE(sv)); |
796 | CALLER_CONTEXT; |
29ecdb6f |
797 | } |
798 | sharedsv_scalar_store(aTHX_ sv, ssv); |
6b85e4fe |
799 | LEAVE_LOCK; |
7473853a |
800 | return (0); |
68795e93 |
801 | } |
802 | |
7473853a |
803 | /* Free magic for PERL_MAGIC_shared_scalar(n) */ |
a446a88f |
804 | |
805 | int |
29ecdb6f |
806 | sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) |
a446a88f |
807 | { |
29ecdb6f |
808 | S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); |
7473853a |
809 | return (0); |
21312124 |
810 | } |
68795e93 |
811 | |
812 | /* |
29ecdb6f |
813 | * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread |
21312124 |
814 | */ |
815 | int |
816 | sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
817 | { |
7473853a |
818 | SvREFCNT_inc_void(mg->mg_ptr); |
819 | return (0); |
21312124 |
820 | } |
68795e93 |
821 | |
7473853a |
822 | #ifdef MGf_LOCAL |
a5063e7c |
823 | /* |
824 | * Called during local $shared |
825 | */ |
826 | int |
827 | sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg) |
828 | { |
829 | MAGIC *nmg; |
29ecdb6f |
830 | SV *ssv = (SV *) mg->mg_ptr; |
831 | if (ssv) { |
7473853a |
832 | ENTER_LOCK; |
833 | SvREFCNT_inc_void(ssv); |
834 | LEAVE_LOCK; |
a5063e7c |
835 | } |
836 | nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual, |
7473853a |
837 | mg->mg_ptr, mg->mg_len); |
a5063e7c |
838 | nmg->mg_flags = mg->mg_flags; |
839 | nmg->mg_private = mg->mg_private; |
840 | |
7473853a |
841 | return (0); |
a5063e7c |
842 | } |
7473853a |
843 | #endif |
a5063e7c |
844 | |
21312124 |
845 | MGVTBL sharedsv_scalar_vtbl = { |
7473853a |
846 | sharedsv_scalar_mg_get, /* get */ |
847 | sharedsv_scalar_mg_set, /* set */ |
848 | 0, /* len */ |
849 | 0, /* clear */ |
850 | sharedsv_scalar_mg_free, /* free */ |
851 | 0, /* copy */ |
852 | sharedsv_scalar_mg_dup, /* dup */ |
853 | #ifdef MGf_LOCAL |
854 | sharedsv_scalar_mg_local, /* local */ |
855 | #endif |
21312124 |
856 | }; |
68795e93 |
857 | |
29ecdb6f |
858 | /* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */ |
859 | |
7473853a |
860 | /* Get magic for PERL_MAGIC_tiedelem(p) */ |
29ecdb6f |
861 | |
21312124 |
862 | int |
863 | sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) |
68795e93 |
864 | { |
21312124 |
865 | dTHXc; |
29ecdb6f |
866 | SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); |
21312124 |
867 | SV** svp; |
868 | |
6b85e4fe |
869 | ENTER_LOCK; |
29ecdb6f |
870 | if (SvTYPE(saggregate) == SVt_PVAV) { |
7473853a |
871 | assert ( mg->mg_ptr == 0 ); |
872 | SHARED_CONTEXT; |
873 | svp = av_fetch((AV*) saggregate, mg->mg_len, 0); |
874 | } else { |
875 | char *key = mg->mg_ptr; |
876 | STRLEN len = mg->mg_len; |
877 | assert ( mg->mg_ptr != 0 ); |
878 | if (mg->mg_len == HEf_SVKEY) { |
c4393b60 |
879 | key = SvPVutf8((SV *)mg->mg_ptr, len); |
7473853a |
880 | } |
881 | SHARED_CONTEXT; |
882 | svp = hv_fetch((HV*) saggregate, key, len, 0); |
21312124 |
883 | } |
6b85e4fe |
884 | CALLER_CONTEXT; |
21312124 |
885 | if (svp) { |
7473853a |
886 | /* Exists in the array */ |
887 | if (SvROK(*svp)) { |
888 | S_get_RV(aTHX_ sv, *svp); |
500a8019 |
889 | /* Look ahead for refs of refs */ |
f6d55995 |
890 | if (SvROK(SvRV(*svp))) { |
891 | SvROK_on(SvRV(sv)); |
892 | S_get_RV(aTHX_ SvRV(sv), SvRV(*svp)); |
893 | } |
7473853a |
894 | } else { |
373098c0 |
895 | /* $ary->[elem] or $ary->{elem} is a scalar */ |
7473853a |
896 | Perl_sharedsv_associate(aTHX_ sv, *svp); |
897 | sv_setsv(sv, *svp); |
898 | } |
899 | } else { |
900 | /* Not in the array */ |
901 | sv_setsv(sv, &PL_sv_undef); |
68795e93 |
902 | } |
6b85e4fe |
903 | LEAVE_LOCK; |
7473853a |
904 | return (0); |
68795e93 |
905 | } |
906 | |
7473853a |
907 | /* Set magic for PERL_MAGIC_tiedelem(p) */ |
29ecdb6f |
908 | |
21312124 |
909 | int |
910 | sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) |
911 | { |
912 | dTHXc; |
29ecdb6f |
913 | SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); |
6b85e4fe |
914 | SV **svp; |
21312124 |
915 | /* Theory - SV itself is magically shared - and we have ordered the |
916 | magic such that by the time we get here it has been stored |
917 | to its shared counterpart |
918 | */ |
6d56dc1c |
919 | ENTER_LOCK; |
29ecdb6f |
920 | assert(saggregate); |
921 | if (SvTYPE(saggregate) == SVt_PVAV) { |
7473853a |
922 | assert ( mg->mg_ptr == 0 ); |
923 | SHARED_CONTEXT; |
924 | svp = av_fetch((AV*) saggregate, mg->mg_len, 1); |
925 | } else { |
926 | char *key = mg->mg_ptr; |
927 | STRLEN len = mg->mg_len; |
928 | assert ( mg->mg_ptr != 0 ); |
929 | if (mg->mg_len == HEf_SVKEY) |
c4393b60 |
930 | key = SvPVutf8((SV *)mg->mg_ptr, len); |
7473853a |
931 | SHARED_CONTEXT; |
932 | svp = hv_fetch((HV*) saggregate, key, len, 1); |
21312124 |
933 | } |
6b85e4fe |
934 | CALLER_CONTEXT; |
29ecdb6f |
935 | Perl_sharedsv_associate(aTHX_ sv, *svp); |
936 | sharedsv_scalar_store(aTHX_ sv, *svp); |
6b85e4fe |
937 | LEAVE_LOCK; |
7473853a |
938 | return (0); |
21312124 |
939 | } |
68795e93 |
940 | |
7473853a |
941 | /* Clear magic for PERL_MAGIC_tiedelem(p) */ |
29ecdb6f |
942 | |
21312124 |
943 | int |
944 | sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) |
68795e93 |
945 | { |
21312124 |
946 | dTHXc; |
057e91b3 |
947 | MAGIC *shmg; |
29ecdb6f |
948 | SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); |
6b85e4fe |
949 | ENTER_LOCK; |
950 | sharedsv_elem_mg_FETCH(aTHX_ sv, mg); |
057e91b3 |
951 | if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) |
7473853a |
952 | sharedsv_scalar_mg_get(aTHX_ sv, shmg); |
29ecdb6f |
953 | if (SvTYPE(saggregate) == SVt_PVAV) { |
7473853a |
954 | SHARED_CONTEXT; |
955 | av_delete((AV*) saggregate, mg->mg_len, G_DISCARD); |
956 | } else { |
957 | char *key = mg->mg_ptr; |
958 | STRLEN len = mg->mg_len; |
959 | assert ( mg->mg_ptr != 0 ); |
960 | if (mg->mg_len == HEf_SVKEY) |
c4393b60 |
961 | key = SvPVutf8((SV *)mg->mg_ptr, len); |
7473853a |
962 | SHARED_CONTEXT; |
963 | hv_delete((HV*) saggregate, key, len, G_DISCARD); |
21312124 |
964 | } |
6b85e4fe |
965 | CALLER_CONTEXT; |
966 | LEAVE_LOCK; |
7473853a |
967 | return (0); |
21312124 |
968 | } |
969 | |
29ecdb6f |
970 | /* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new |
971 | * thread */ |
972 | |
21312124 |
973 | int |
974 | sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
975 | { |
7473853a |
976 | SvREFCNT_inc_void(S_sharedsv_from_obj(aTHX_ mg->mg_obj)); |
29ecdb6f |
977 | assert(mg->mg_flags & MGf_DUP); |
7473853a |
978 | return (0); |
21312124 |
979 | } |
980 | |
981 | MGVTBL sharedsv_elem_vtbl = { |
7473853a |
982 | sharedsv_elem_mg_FETCH, /* get */ |
983 | sharedsv_elem_mg_STORE, /* set */ |
984 | 0, /* len */ |
985 | sharedsv_elem_mg_DELETE, /* clear */ |
986 | 0, /* free */ |
987 | 0, /* copy */ |
988 | sharedsv_elem_mg_dup, /* dup */ |
989 | #ifdef MGf_LOCAL |
990 | 0, /* local */ |
991 | #endif |
21312124 |
992 | }; |
993 | |
29ecdb6f |
994 | /* ------------ PERL_MAGIC_tied(P) functions -------------- */ |
995 | |
7473853a |
996 | /* Len magic for PERL_MAGIC_tied(P) */ |
29ecdb6f |
997 | |
21312124 |
998 | U32 |
999 | sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) |
1000 | { |
1001 | dTHXc; |
29ecdb6f |
1002 | SV *ssv = (SV *) mg->mg_ptr; |
21312124 |
1003 | U32 val; |
1004 | SHARED_EDIT; |
29ecdb6f |
1005 | if (SvTYPE(ssv) == SVt_PVAV) { |
7473853a |
1006 | val = av_len((AV*) ssv); |
1007 | } else { |
1008 | /* Not actually defined by tie API but ... */ |
1009 | val = HvKEYS((HV*) ssv); |
21312124 |
1010 | } |
1011 | SHARED_RELEASE; |
7473853a |
1012 | return (val); |
21312124 |
1013 | } |
1014 | |
7473853a |
1015 | /* Clear magic for PERL_MAGIC_tied(P) */ |
29ecdb6f |
1016 | |
21312124 |
1017 | int |
1018 | sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) |
1019 | { |
1020 | dTHXc; |
29ecdb6f |
1021 | SV *ssv = (SV *) mg->mg_ptr; |
21312124 |
1022 | SHARED_EDIT; |
29ecdb6f |
1023 | if (SvTYPE(ssv) == SVt_PVAV) { |
7473853a |
1024 | av_clear((AV*) ssv); |
1025 | } else { |
1026 | hv_clear((HV*) ssv); |
21312124 |
1027 | } |
1028 | SHARED_RELEASE; |
7473853a |
1029 | return (0); |
21312124 |
1030 | } |
1031 | |
7473853a |
1032 | /* Free magic for PERL_MAGIC_tied(P) */ |
29ecdb6f |
1033 | |
21312124 |
1034 | int |
1035 | sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) |
1036 | { |
29ecdb6f |
1037 | S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); |
7473853a |
1038 | return (0); |
68795e93 |
1039 | } |
1040 | |
1041 | /* |
7473853a |
1042 | * Copy magic for PERL_MAGIC_tied(P) |
21312124 |
1043 | * This is called when perl is about to access an element of |
1044 | * the array - |
1045 | */ |
33d16ee7 |
1046 | #if PERL_VERSION >= 11 |
21312124 |
1047 | int |
1048 | sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, |
3468c7ea |
1049 | SV *nsv, const char *name, I32 namlen) |
33d16ee7 |
1050 | #else |
1051 | int |
1052 | sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, |
1053 | SV *nsv, const char *name, int namlen) |
1054 | #endif |
21312124 |
1055 | { |
21312124 |
1056 | MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, |
7473853a |
1057 | toLOWER(mg->mg_type),&sharedsv_elem_vtbl, |
1058 | name, namlen); |
21312124 |
1059 | nmg->mg_flags |= MGf_DUP; |
7473853a |
1060 | return (1); |
21312124 |
1061 | } |
1062 | |
29ecdb6f |
1063 | /* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */ |
1064 | |
21312124 |
1065 | int |
1066 | sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
1067 | { |
7473853a |
1068 | SvREFCNT_inc_void((SV*)mg->mg_ptr); |
29ecdb6f |
1069 | assert(mg->mg_flags & MGf_DUP); |
7473853a |
1070 | return (0); |
21312124 |
1071 | } |
1072 | |
1073 | MGVTBL sharedsv_array_vtbl = { |
7473853a |
1074 | 0, /* get */ |
1075 | 0, /* set */ |
1076 | sharedsv_array_mg_FETCHSIZE,/* len */ |
1077 | sharedsv_array_mg_CLEAR, /* clear */ |
1078 | sharedsv_array_mg_free, /* free */ |
1079 | sharedsv_array_mg_copy, /* copy */ |
1080 | sharedsv_array_mg_dup, /* dup */ |
1081 | #ifdef MGf_LOCAL |
1082 | 0, /* local */ |
1083 | #endif |
21312124 |
1084 | }; |
1085 | |
68795e93 |
1086 | |
ba2940ce |
1087 | /* Recursively unlocks a shared sv. */ |
68795e93 |
1088 | |
1089 | void |
29ecdb6f |
1090 | Perl_sharedsv_unlock(pTHX_ SV *ssv) |
68795e93 |
1091 | { |
29ecdb6f |
1092 | user_lock *ul = S_get_userlock(aTHX_ ssv, 0); |
1093 | assert(ul); |
1094 | recursive_lock_release(aTHX_ &ul->lock); |
68795e93 |
1095 | } |
1096 | |
68795e93 |
1097 | |
ba2940ce |
1098 | /* Recursive locks on a sharedsv. |
1099 | * Locks are dynamically scoped at the level of the first lock. |
1100 | */ |
68795e93 |
1101 | void |
29ecdb6f |
1102 | Perl_sharedsv_lock(pTHX_ SV *ssv) |
68795e93 |
1103 | { |
29ecdb6f |
1104 | user_lock *ul; |
7473853a |
1105 | if (! ssv) |
1106 | return; |
29ecdb6f |
1107 | ul = S_get_userlock(aTHX_ ssv, 1); |
1108 | recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__); |
68795e93 |
1109 | } |
1110 | |
7473853a |
1111 | /* Handles calls from lock() builtin via PL_lockhook */ |
afe38520 |
1112 | |
21312124 |
1113 | void |
1114 | Perl_sharedsv_locksv(pTHX_ SV *sv) |
1115 | { |
29ecdb6f |
1116 | SV *ssv; |
afe38520 |
1117 | |
7473853a |
1118 | if (SvROK(sv)) |
1119 | sv = SvRV(sv); |
29ecdb6f |
1120 | ssv = Perl_sharedsv_find(aTHX_ sv); |
7473853a |
1121 | if (!ssv) |
afe38520 |
1122 | croak("lock can only be used on shared values"); |
29ecdb6f |
1123 | Perl_sharedsv_lock(aTHX_ ssv); |
b050c948 |
1124 | } |
1125 | |
b050c948 |
1126 | |
794f4697 |
1127 | /* Can a shared object be destroyed? |
1128 | * True if not a shared, |
1129 | * or if detroying last proxy on a shared object |
1130 | */ |
1131 | #ifdef PL_destroyhook |
1132 | bool |
1133 | Perl_shared_object_destroy(pTHX_ SV *sv) |
1134 | { |
1135 | SV *ssv; |
1136 | |
1137 | if (SvROK(sv)) |
1138 | sv = SvRV(sv); |
1139 | ssv = Perl_sharedsv_find(aTHX_ sv); |
1140 | return (!ssv || (SvREFCNT(ssv) <= 1)); |
1141 | } |
1142 | #endif |
1143 | |
1144 | |
ba2940ce |
1145 | /* Saves a space for keeping SVs wider than an interpreter. */ |
21312124 |
1146 | |
1147 | void |
1148 | Perl_sharedsv_init(pTHX) |
1149 | { |
7473853a |
1150 | dTHXc; |
1151 | /* This pair leaves us in shared context ... */ |
1152 | PL_sharedsv_space = perl_alloc(); |
1153 | perl_construct(PL_sharedsv_space); |
1154 | CALLER_CONTEXT; |
1155 | recursive_lock_init(aTHX_ &PL_sharedsv_lock); |
1156 | PL_lockhook = &Perl_sharedsv_locksv; |
1157 | PL_sharehook = &Perl_sharedsv_share; |
794f4697 |
1158 | #ifdef PL_destroyhook |
1159 | PL_destroyhook = &Perl_shared_object_destroy; |
1160 | #endif |
b050c948 |
1161 | } |
1162 | |
73e09c8f |
1163 | #endif /* USE_ITHREADS */ |
1164 | |
7473853a |
1165 | MODULE = threads::shared PACKAGE = threads::shared::tie |
b050c948 |
1166 | |
21312124 |
1167 | PROTOTYPES: DISABLE |
b050c948 |
1168 | |
73e09c8f |
1169 | #ifdef USE_ITHREADS |
6b85e4fe |
1170 | |
21312124 |
1171 | void |
29ecdb6f |
1172 | PUSH(SV *obj, ...) |
7473853a |
1173 | CODE: |
1174 | dTHXc; |
1175 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1176 | int i; |
1177 | for (i = 1; i < items; i++) { |
1178 | SV* tmp = newSVsv(ST(i)); |
1179 | SV *stmp; |
1180 | ENTER_LOCK; |
1181 | stmp = S_sharedsv_new_shared(aTHX_ tmp); |
1182 | sharedsv_scalar_store(aTHX_ tmp, stmp); |
1183 | SHARED_CONTEXT; |
1184 | av_push((AV*) sobj, stmp); |
1185 | SvREFCNT_inc_void(stmp); |
1186 | SHARED_RELEASE; |
1187 | SvREFCNT_dec(tmp); |
1188 | } |
1189 | |
b050c948 |
1190 | |
21312124 |
1191 | void |
29ecdb6f |
1192 | UNSHIFT(SV *obj, ...) |
7473853a |
1193 | CODE: |
1194 | dTHXc; |
1195 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1196 | int i; |
1197 | ENTER_LOCK; |
1198 | SHARED_CONTEXT; |
1199 | av_unshift((AV*)sobj, items - 1); |
1200 | CALLER_CONTEXT; |
1201 | for (i = 1; i < items; i++) { |
1202 | SV *tmp = newSVsv(ST(i)); |
1203 | SV *stmp = S_sharedsv_new_shared(aTHX_ tmp); |
1204 | sharedsv_scalar_store(aTHX_ tmp, stmp); |
1205 | SHARED_CONTEXT; |
1206 | av_store((AV*) sobj, i - 1, stmp); |
1207 | SvREFCNT_inc_void(stmp); |
1208 | CALLER_CONTEXT; |
1209 | SvREFCNT_dec(tmp); |
1210 | } |
1211 | LEAVE_LOCK; |
1212 | |
b050c948 |
1213 | |
21312124 |
1214 | void |
29ecdb6f |
1215 | POP(SV *obj) |
7473853a |
1216 | CODE: |
1217 | dTHXc; |
1218 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1219 | SV* ssv; |
1220 | ENTER_LOCK; |
1221 | SHARED_CONTEXT; |
1222 | ssv = av_pop((AV*)sobj); |
1223 | CALLER_CONTEXT; |
1224 | ST(0) = sv_newmortal(); |
1225 | Perl_sharedsv_associate(aTHX_ ST(0), ssv); |
1226 | SvREFCNT_dec(ssv); |
1227 | LEAVE_LOCK; |
1228 | /* XSRETURN(1); - implied */ |
1229 | |
b050c948 |
1230 | |
21312124 |
1231 | void |
29ecdb6f |
1232 | SHIFT(SV *obj) |
7473853a |
1233 | CODE: |
1234 | dTHXc; |
1235 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1236 | SV* ssv; |
1237 | ENTER_LOCK; |
1238 | SHARED_CONTEXT; |
1239 | ssv = av_shift((AV*)sobj); |
1240 | CALLER_CONTEXT; |
1241 | ST(0) = sv_newmortal(); |
1242 | Perl_sharedsv_associate(aTHX_ ST(0), ssv); |
1243 | SvREFCNT_dec(ssv); |
1244 | LEAVE_LOCK; |
1245 | /* XSRETURN(1); - implied */ |
1246 | |
b050c948 |
1247 | |
21312124 |
1248 | void |
29ecdb6f |
1249 | EXTEND(SV *obj, IV count) |
7473853a |
1250 | CODE: |
1251 | dTHXc; |
1252 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1253 | SHARED_EDIT; |
1254 | av_extend((AV*)sobj, count); |
1255 | SHARED_RELEASE; |
1256 | |
b050c948 |
1257 | |
21312124 |
1258 | void |
29ecdb6f |
1259 | STORESIZE(SV *obj,IV count) |
7473853a |
1260 | CODE: |
1261 | dTHXc; |
1262 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1263 | SHARED_EDIT; |
1264 | av_fill((AV*) sobj, count); |
1265 | SHARED_RELEASE; |
6b85e4fe |
1266 | |
1267 | |
1268 | void |
29ecdb6f |
1269 | EXISTS(SV *obj, SV *index) |
7473853a |
1270 | CODE: |
1271 | dTHXc; |
1272 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1273 | bool exists; |
1274 | if (SvTYPE(sobj) == SVt_PVAV) { |
1275 | SHARED_EDIT; |
1276 | exists = av_exists((AV*) sobj, SvIV(index)); |
1277 | } else { |
1278 | STRLEN len; |
c4393b60 |
1279 | char *key = SvPVutf8(index, len); |
7473853a |
1280 | SHARED_EDIT; |
1281 | exists = hv_exists((HV*) sobj, key, len); |
1282 | } |
1283 | SHARED_RELEASE; |
1284 | ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; |
1285 | /* XSRETURN(1); - implied */ |
b050c948 |
1286 | |
1287 | |
1288 | void |
29ecdb6f |
1289 | FIRSTKEY(SV *obj) |
7473853a |
1290 | CODE: |
1291 | dTHXc; |
1292 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1293 | char* key = NULL; |
1294 | I32 len = 0; |
1295 | HE* entry; |
1296 | ENTER_LOCK; |
1297 | SHARED_CONTEXT; |
1298 | hv_iterinit((HV*) sobj); |
1299 | entry = hv_iternext((HV*) sobj); |
1300 | if (entry) { |
1301 | key = hv_iterkey(entry,&len); |
1302 | CALLER_CONTEXT; |
c4393b60 |
1303 | ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1)); |
7473853a |
1304 | } else { |
1305 | CALLER_CONTEXT; |
1306 | ST(0) = &PL_sv_undef; |
1307 | } |
1308 | LEAVE_LOCK; |
1309 | /* XSRETURN(1); - implied */ |
1310 | |
b050c948 |
1311 | |
866fba46 |
1312 | void |
29ecdb6f |
1313 | NEXTKEY(SV *obj, SV *oldkey) |
7473853a |
1314 | CODE: |
1315 | dTHXc; |
1316 | SV *sobj = S_sharedsv_from_obj(aTHX_ obj); |
1317 | char* key = NULL; |
1318 | I32 len = 0; |
1319 | HE* entry; |
2a6601ce |
1320 | |
1321 | PERL_UNUSED_VAR(oldkey); |
1322 | |
7473853a |
1323 | ENTER_LOCK; |
1324 | SHARED_CONTEXT; |
1325 | entry = hv_iternext((HV*) sobj); |
1326 | if (entry) { |
1327 | key = hv_iterkey(entry,&len); |
1328 | CALLER_CONTEXT; |
c4393b60 |
1329 | ST(0) = sv_2mortal(newSVpvn_utf8(key, len, 1)); |
7473853a |
1330 | } else { |
1331 | CALLER_CONTEXT; |
1332 | ST(0) = &PL_sv_undef; |
1333 | } |
1334 | LEAVE_LOCK; |
1335 | /* XSRETURN(1); - implied */ |
1336 | |
1337 | |
1338 | MODULE = threads::shared PACKAGE = threads::shared |
21312124 |
1339 | |
1340 | PROTOTYPES: ENABLE |
866fba46 |
1341 | |
68795e93 |
1342 | void |
39ec4146 |
1343 | _id(SV *myref) |
7473853a |
1344 | PROTOTYPE: \[$@%] |
1345 | PREINIT: |
1346 | SV *ssv; |
1347 | CODE: |
39ec4146 |
1348 | myref = SvRV(myref); |
373098c0 |
1349 | if (SvMAGICAL(myref)) |
1350 | mg_get(myref); |
39ec4146 |
1351 | if (SvROK(myref)) |
1352 | myref = SvRV(myref); |
1353 | ssv = Perl_sharedsv_find(aTHX_ myref); |
7473853a |
1354 | if (! ssv) |
1355 | XSRETURN_UNDEF; |
1356 | ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv))); |
1357 | /* XSRETURN(1); - implied */ |
9c4972d9 |
1358 | |
1359 | |
1360 | void |
39ec4146 |
1361 | _refcnt(SV *myref) |
7473853a |
1362 | PROTOTYPE: \[$@%] |
1363 | PREINIT: |
1364 | SV *ssv; |
1365 | CODE: |
39ec4146 |
1366 | myref = SvRV(myref); |
1367 | if (SvROK(myref)) |
1368 | myref = SvRV(myref); |
1369 | ssv = Perl_sharedsv_find(aTHX_ myref); |
7473853a |
1370 | if (! ssv) { |
7c8caac0 |
1371 | if (ckWARN(WARN_THREADS)) { |
1372 | Perl_warner(aTHX_ packWARN(WARN_THREADS), |
1373 | "%" SVf " is not shared", ST(0)); |
1374 | } |
7473853a |
1375 | XSRETURN_UNDEF; |
1376 | } |
1377 | ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv))); |
1378 | /* XSRETURN(1); - implied */ |
1379 | |
1380 | |
1381 | void |
39ec4146 |
1382 | share(SV *myref) |
7473853a |
1383 | PROTOTYPE: \[$@%] |
1384 | CODE: |
39ec4146 |
1385 | if (! SvROK(myref)) |
56fcff86 |
1386 | Perl_croak(aTHX_ "Argument to share needs to be passed as ref"); |
39ec4146 |
1387 | myref = SvRV(myref); |
1388 | if (SvROK(myref)) |
1389 | myref = SvRV(myref); |
1390 | Perl_sharedsv_share(aTHX_ myref); |
1391 | ST(0) = sv_2mortal(newRV_inc(myref)); |
7473853a |
1392 | /* XSRETURN(1); - implied */ |
a446a88f |
1393 | |
6f942b98 |
1394 | |
1395 | void |
7473853a |
1396 | cond_wait(SV *ref_cond, SV *ref_lock = 0) |
1397 | PROTOTYPE: \[$@%];\[$@%] |
1398 | PREINIT: |
1399 | SV *ssv; |
1400 | perl_cond* user_condition; |
1401 | int locks; |
1402 | user_lock *ul; |
1403 | CODE: |
1404 | if (!SvROK(ref_cond)) |
56fcff86 |
1405 | Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); |
7473853a |
1406 | ref_cond = SvRV(ref_cond); |
1407 | if (SvROK(ref_cond)) |
1408 | ref_cond = SvRV(ref_cond); |
1409 | ssv = Perl_sharedsv_find(aTHX_ ref_cond); |
1410 | if (! ssv) |
1411 | Perl_croak(aTHX_ "cond_wait can only be used on shared values"); |
1412 | ul = S_get_userlock(aTHX_ ssv, 1); |
1413 | |
1414 | user_condition = &ul->user_cond; |
1415 | if (ref_lock && (ref_cond != ref_lock)) { |
1416 | if (!SvROK(ref_lock)) |
1417 | Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); |
1418 | ref_lock = SvRV(ref_lock); |
1419 | if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); |
1420 | ssv = Perl_sharedsv_find(aTHX_ ref_lock); |
1421 | if (! ssv) |
1422 | Perl_croak(aTHX_ "cond_wait lock must be a shared value"); |
1423 | ul = S_get_userlock(aTHX_ ssv, 1); |
1424 | } |
1425 | if (ul->lock.owner != aTHX) |
1426 | croak("You need a lock before you can cond_wait"); |
ba2940ce |
1427 | |
7473853a |
1428 | /* Stealing the members of the lock object worries me - NI-S */ |
1429 | MUTEX_LOCK(&ul->lock.mutex); |
1430 | ul->lock.owner = NULL; |
1431 | locks = ul->lock.locks; |
1432 | ul->lock.locks = 0; |
1433 | |
ba2940ce |
1434 | /* Since we are releasing the lock here, we need to tell other |
1435 | * people that it is ok to go ahead and use it */ |
7473853a |
1436 | COND_SIGNAL(&ul->lock.cond); |
1437 | COND_WAIT(user_condition, &ul->lock.mutex); |
ba2940ce |
1438 | while (ul->lock.owner != NULL) { |
7473853a |
1439 | /* OK -- must reacquire the lock */ |
1440 | COND_WAIT(&ul->lock.cond, &ul->lock.mutex); |
1441 | } |
1442 | ul->lock.owner = aTHX; |
1443 | ul->lock.locks = locks; |
1444 | MUTEX_UNLOCK(&ul->lock.mutex); |
1445 | |
a0e036c1 |
1446 | |
1447 | int |
7473853a |
1448 | cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0) |
1449 | PROTOTYPE: \[$@%]$;\[$@%] |
1450 | PREINIT: |
1451 | SV *ssv; |
1452 | perl_cond* user_condition; |
1453 | int locks; |
1454 | user_lock *ul; |
1455 | CODE: |
1456 | if (! SvROK(ref_cond)) |
1457 | Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); |
1458 | ref_cond = SvRV(ref_cond); |
1459 | if (SvROK(ref_cond)) |
1460 | ref_cond = SvRV(ref_cond); |
1461 | ssv = Perl_sharedsv_find(aTHX_ ref_cond); |
1462 | if (! ssv) |
1463 | Perl_croak(aTHX_ "cond_timedwait can only be used on shared values"); |
1464 | ul = S_get_userlock(aTHX_ ssv, 1); |
1465 | |
1466 | user_condition = &ul->user_cond; |
1467 | if (ref_lock && (ref_cond != ref_lock)) { |
1468 | if (! SvROK(ref_lock)) |
1469 | Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); |
1470 | ref_lock = SvRV(ref_lock); |
1471 | if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); |
1472 | ssv = Perl_sharedsv_find(aTHX_ ref_lock); |
1473 | if (! ssv) |
1474 | Perl_croak(aTHX_ "cond_timedwait lock must be a shared value"); |
1475 | ul = S_get_userlock(aTHX_ ssv, 1); |
1476 | } |
1477 | if (ul->lock.owner != aTHX) |
1478 | Perl_croak(aTHX_ "You need a lock before you can cond_wait"); |
1479 | |
1480 | MUTEX_LOCK(&ul->lock.mutex); |
1481 | ul->lock.owner = NULL; |
1482 | locks = ul->lock.locks; |
1483 | ul->lock.locks = 0; |
ba2940ce |
1484 | /* Since we are releasing the lock here, we need to tell other |
1485 | * people that it is ok to go ahead and use it */ |
7473853a |
1486 | COND_SIGNAL(&ul->lock.cond); |
1487 | RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs); |
1488 | while (ul->lock.owner != NULL) { |
1489 | /* OK -- must reacquire the lock... */ |
1490 | COND_WAIT(&ul->lock.cond, &ul->lock.mutex); |
1491 | } |
1492 | ul->lock.owner = aTHX; |
1493 | ul->lock.locks = locks; |
1494 | MUTEX_UNLOCK(&ul->lock.mutex); |
1495 | |
1496 | if (RETVAL == 0) |
a0e036c1 |
1497 | XSRETURN_UNDEF; |
7473853a |
1498 | OUTPUT: |
1499 | RETVAL |
a0e036c1 |
1500 | |
29ecdb6f |
1501 | |
7473853a |
1502 | void |
39ec4146 |
1503 | cond_signal(SV *myref) |
7473853a |
1504 | PROTOTYPE: \[$@%] |
1505 | PREINIT: |
1506 | SV *ssv; |
1507 | user_lock *ul; |
1508 | CODE: |
39ec4146 |
1509 | if (! SvROK(myref)) |
56fcff86 |
1510 | Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); |
39ec4146 |
1511 | myref = SvRV(myref); |
1512 | if (SvROK(myref)) |
1513 | myref = SvRV(myref); |
1514 | ssv = Perl_sharedsv_find(aTHX_ myref); |
7473853a |
1515 | if (! ssv) |
1516 | Perl_croak(aTHX_ "cond_signal can only be used on shared values"); |
1517 | ul = S_get_userlock(aTHX_ ssv, 1); |
1518 | if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { |
1519 | Perl_warner(aTHX_ packWARN(WARN_THREADS), |
1520 | "cond_signal() called on unlocked variable"); |
1521 | } |
1522 | COND_SIGNAL(&ul->user_cond); |
6f942b98 |
1523 | |
29ecdb6f |
1524 | |
7473853a |
1525 | void |
39ec4146 |
1526 | cond_broadcast(SV *myref) |
7473853a |
1527 | PROTOTYPE: \[$@%] |
1528 | PREINIT: |
1529 | SV *ssv; |
1530 | user_lock *ul; |
1531 | CODE: |
39ec4146 |
1532 | if (! SvROK(myref)) |
56fcff86 |
1533 | Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); |
39ec4146 |
1534 | myref = SvRV(myref); |
1535 | if (SvROK(myref)) |
1536 | myref = SvRV(myref); |
1537 | ssv = Perl_sharedsv_find(aTHX_ myref); |
7473853a |
1538 | if (! ssv) |
1539 | Perl_croak(aTHX_ "cond_broadcast can only be used on shared values"); |
1540 | ul = S_get_userlock(aTHX_ ssv, 1); |
1541 | if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { |
1542 | Perl_warner(aTHX_ packWARN(WARN_THREADS), |
1543 | "cond_broadcast() called on unlocked variable"); |
1544 | } |
1545 | COND_BROADCAST(&ul->user_cond); |
1546 | |
1547 | |
1548 | void |
39ec4146 |
1549 | bless(SV* myref, ...); |
7473853a |
1550 | PROTOTYPE: $;$ |
1551 | PREINIT: |
1552 | HV* stash; |
1553 | SV *ssv; |
1554 | CODE: |
1555 | if (items == 1) { |
1556 | stash = CopSTASH(PL_curcop); |
1557 | } else { |
1558 | SV* classname = ST(1); |
1559 | STRLEN len; |
1560 | char *ptr; |
1561 | |
1562 | if (classname && |
1563 | ! SvGMAGICAL(classname) && |
1564 | ! SvAMAGIC(classname) && |
1565 | SvROK(classname)) |
1566 | { |
1567 | Perl_croak(aTHX_ "Attempt to bless into a reference"); |
1568 | } |
1569 | ptr = SvPV(classname, len); |
1570 | if (ckWARN(WARN_MISC) && len == 0) { |
1571 | Perl_warner(aTHX_ packWARN(WARN_MISC), |
1572 | "Explicit blessing to '' (assuming package main)"); |
1573 | } |
1574 | stash = gv_stashpvn(ptr, len, TRUE); |
1575 | } |
39ec4146 |
1576 | SvREFCNT_inc_void(myref); |
1577 | (void)sv_bless(myref, stash); |
1578 | ST(0) = sv_2mortal(myref); |
1579 | ssv = Perl_sharedsv_find(aTHX_ myref); |
7473853a |
1580 | if (ssv) { |
1581 | dTHXc; |
1582 | ENTER_LOCK; |
1583 | SHARED_CONTEXT; |
1584 | { |
1585 | SV* fake_stash = newSVpv(HvNAME_get(stash), 0); |
1586 | (void)sv_bless(ssv, (HV*)fake_stash); |
1587 | } |
1588 | CALLER_CONTEXT; |
1589 | LEAVE_LOCK; |
1590 | } |
1591 | /* XSRETURN(1); - implied */ |
5c360ac5 |
1592 | |
73e09c8f |
1593 | #endif /* USE_ITHREADS */ |
1594 | |
68795e93 |
1595 | BOOT: |
1596 | { |
73e09c8f |
1597 | #ifdef USE_ITHREADS |
68795e93 |
1598 | Perl_sharedsv_init(aTHX); |
73e09c8f |
1599 | #endif /* USE_ITHREADS */ |
68795e93 |
1600 | } |