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