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