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 = newRV_inc(sobj);
828 sv_setsv_nomg(ssv, tmpref);
829 SvREFCNT_dec_NN(tmpref);
830
831 if (SvOBJECT(sobj)) {
832 /* Remove any old blessing */
833 SvREFCNT_dec(SvSTASH(sobj));
834 SvOBJECT_off(sobj);
835 }
836 if (SvOBJECT(obj)) {
837 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0);
838 SvOBJECT_on(sobj);
839 SvSTASH_set(sobj, (HV*)fake_stash);
840 }
841 CALLER_CONTEXT;
842 } else {
843 allowed = FALSE;
844 }
845 } else {
846 SvTEMP_off(sv);
847 SHARED_CONTEXT;
848 sv_setsv_nomg(ssv, sv);
849 if (SvOBJECT(ssv)) {
850 /* Remove any old blessing */
851 SvREFCNT_dec(SvSTASH(ssv));
852 SvOBJECT_off(ssv);
853 }
854 if (SvOBJECT(sv)) {
855 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0);
856 SvOBJECT_on(ssv);
857 SvSTASH_set(ssv, (HV*)fake_stash);
858 }
859 CALLER_CONTEXT;
860 }
861 if (!allowed) {
862 Perl_croak(aTHX_ "Invalid value for shared scalar");
863 }
864 }
865
866 /* Set magic for PERL_MAGIC_shared_scalar(n) */
867
868 static int
sharedsv_scalar_mg_set(pTHX_ SV * sv,MAGIC * mg)869 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
870 {
871 SV *ssv = (SV*)(mg->mg_ptr);
872 assert(ssv);
873 ENTER_LOCK;
874 if (SvTYPE(ssv) < SvTYPE(sv)) {
875 dTHXc;
876 SHARED_CONTEXT;
877 sv_upgrade(ssv, SvTYPE(sv));
878 CALLER_CONTEXT;
879 }
880 sharedsv_scalar_store(aTHX_ sv, ssv);
881 LEAVE_LOCK;
882 return (0);
883 }
884
885 /* Free magic for PERL_MAGIC_shared_scalar(n) */
886
887 static int
sharedsv_scalar_mg_free(pTHX_ SV * sv,MAGIC * mg)888 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
889 {
890 PERL_UNUSED_ARG(sv);
891 ENTER_LOCK;
892 if (!PL_dirty
893 && SvROK((SV *)mg->mg_ptr) && SvREFCNT(SvRV((SV *)mg->mg_ptr)) == 1) {
894 SV *sv = sv_newmortal();
895 sv_upgrade(sv, SVt_RV);
896 get_RV(sv, SvRV((SV *)mg->mg_ptr));
897 }
898 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
899 LEAVE_LOCK;
900 return (0);
901 }
902
903 /*
904 * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread
905 */
906 static int
sharedsv_scalar_mg_dup(pTHX_ MAGIC * mg,CLONE_PARAMS * param)907 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
908 {
909 PERL_UNUSED_ARG(param);
910 SvREFCNT_inc_void(mg->mg_ptr);
911 return (0);
912 }
913
914 #ifdef MGf_LOCAL
915 /*
916 * Called during local $shared
917 */
918 static int
sharedsv_scalar_mg_local(pTHX_ SV * nsv,MAGIC * mg)919 sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg)
920 {
921 MAGIC *nmg;
922 SV *ssv = (SV *) mg->mg_ptr;
923 if (ssv) {
924 ENTER_LOCK;
925 SvREFCNT_inc_void(ssv);
926 LEAVE_LOCK;
927 }
928 nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual,
929 mg->mg_ptr, mg->mg_len);
930 nmg->mg_flags = mg->mg_flags;
931 nmg->mg_private = mg->mg_private;
932
933 return (0);
934 }
935 #endif
936
937 const MGVTBL sharedsv_scalar_vtbl = {
938 sharedsv_scalar_mg_get, /* get */
939 sharedsv_scalar_mg_set, /* set */
940 0, /* len */
941 0, /* clear */
942 sharedsv_scalar_mg_free, /* free */
943 0, /* copy */
944 sharedsv_scalar_mg_dup, /* dup */
945 #ifdef MGf_LOCAL
946 sharedsv_scalar_mg_local, /* local */
947 #endif
948 };
949
950 /* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */
951
952 /* Get magic for PERL_MAGIC_tiedelem(p) */
953
954 static int
sharedsv_elem_mg_FETCH(pTHX_ SV * sv,MAGIC * mg)955 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
956 {
957 dTHXc;
958 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
959 SV** svp = NULL;
960
961 ENTER_LOCK;
962 if (saggregate) { /* During global destruction, underlying
963 aggregate may no longer exist */
964 if (SvTYPE(saggregate) == SVt_PVAV) {
965 assert ( mg->mg_ptr == 0 );
966 SHARED_CONTEXT;
967 svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
968 } else {
969 char *key = mg->mg_ptr;
970 I32 len = mg->mg_len;
971 assert ( mg->mg_ptr != 0 );
972 if (mg->mg_len == HEf_SVKEY) {
973 STRLEN slen;
974 key = SvPV((SV *)mg->mg_ptr, slen);
975 len = slen;
976 if (SvUTF8((SV *)mg->mg_ptr)) {
977 len = -len;
978 }
979 }
980 SHARED_CONTEXT;
981 svp = hv_fetch((HV*) saggregate, key, len, 0);
982 }
983 CALLER_CONTEXT;
984 }
985 if (svp) {
986 /* Exists in the array */
987 if (SvROK(*svp)) {
988 get_RV(sv, SvRV(*svp));
989 } else {
990 /* $ary->[elem] or $ary->{elem} is a scalar */
991 Perl_sharedsv_associate(aTHX_ sv, *svp);
992 sv_setsv(sv, *svp);
993 }
994 } else {
995 /* Not in the array */
996 sv_setsv(sv, &PL_sv_undef);
997 }
998 LEAVE_LOCK;
999 return (0);
1000 }
1001
1002 /* Set magic for PERL_MAGIC_tiedelem(p) */
1003
1004 static int
sharedsv_elem_mg_STORE(pTHX_ SV * sv,MAGIC * mg)1005 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
1006 {
1007 dTHXc;
1008 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
1009 SV **svp;
1010 U32 dualvar_flags = DUALVAR_FLAGS(sv);
1011
1012 /* Theory - SV itself is magically shared - and we have ordered the
1013 magic such that by the time we get here it has been stored
1014 to its shared counterpart
1015 */
1016 ENTER_LOCK;
1017 assert(saggregate);
1018 if (SvTYPE(saggregate) == SVt_PVAV) {
1019 assert ( mg->mg_ptr == 0 );
1020 SHARED_CONTEXT;
1021 svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
1022 } else {
1023 char *key = mg->mg_ptr;
1024 I32 len = mg->mg_len;
1025 assert ( mg->mg_ptr != 0 );
1026 if (mg->mg_len == HEf_SVKEY) {
1027 STRLEN slen;
1028 key = SvPV((SV *)mg->mg_ptr, slen);
1029 len = slen;
1030 if (SvUTF8((SV *)mg->mg_ptr)) {
1031 len = -len;
1032 }
1033 }
1034 SHARED_CONTEXT;
1035 svp = hv_fetch((HV*) saggregate, key, len, 1);
1036 }
1037 CALLER_CONTEXT;
1038 Perl_sharedsv_associate(aTHX_ sv, *svp);
1039 sharedsv_scalar_store(aTHX_ sv, *svp);
1040 SvFLAGS(*svp) |= dualvar_flags;
1041 LEAVE_LOCK;
1042 return (0);
1043 }
1044
1045 /* Clear magic for PERL_MAGIC_tiedelem(p) */
1046
1047 static int
sharedsv_elem_mg_DELETE(pTHX_ SV * sv,MAGIC * mg)1048 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
1049 {
1050 dTHXc;
1051 MAGIC *shmg;
1052 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
1053
1054 /* Object may not exist during global destruction */
1055 if (! saggregate) {
1056 return (0);
1057 }
1058
1059 ENTER_LOCK;
1060 sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
1061 if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
1062 sharedsv_scalar_mg_get(aTHX_ sv, shmg);
1063 if (SvTYPE(saggregate) == SVt_PVAV) {
1064 SHARED_CONTEXT;
1065 av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
1066 } else {
1067 char *key = mg->mg_ptr;
1068 I32 len = mg->mg_len;
1069 assert ( mg->mg_ptr != 0 );
1070 if (mg->mg_len == HEf_SVKEY) {
1071 STRLEN slen;
1072 key = SvPV((SV *)mg->mg_ptr, slen);
1073 len = slen;
1074 if (SvUTF8((SV *)mg->mg_ptr)) {
1075 len = -len;
1076 }
1077 }
1078 SHARED_CONTEXT;
1079 (void) hv_delete((HV*) saggregate, key, len, G_DISCARD);
1080 }
1081 CALLER_CONTEXT;
1082 LEAVE_LOCK;
1083 return (0);
1084 }
1085
1086 /* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new
1087 * thread */
1088
1089 static int
sharedsv_elem_mg_dup(pTHX_ MAGIC * mg,CLONE_PARAMS * param)1090 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
1091 {
1092 PERL_UNUSED_ARG(param);
1093 SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj));
1094 assert(mg->mg_flags & MGf_DUP);
1095 return (0);
1096 }
1097
1098 const MGVTBL sharedsv_elem_vtbl = {
1099 sharedsv_elem_mg_FETCH, /* get */
1100 sharedsv_elem_mg_STORE, /* set */
1101 0, /* len */
1102 sharedsv_elem_mg_DELETE, /* clear */
1103 0, /* free */
1104 0, /* copy */
1105 sharedsv_elem_mg_dup, /* dup */
1106 #ifdef MGf_LOCAL
1107 0, /* local */
1108 #endif
1109 };
1110
1111 /* ------------ PERL_MAGIC_tied(P) functions -------------- */
1112
1113 /* Len magic for PERL_MAGIC_tied(P) */
1114
1115 static U32
sharedsv_array_mg_FETCHSIZE(pTHX_ SV * sv,MAGIC * mg)1116 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
1117 {
1118 dTHXc;
1119 SV *ssv = (SV *) mg->mg_ptr;
1120 U32 val;
1121 PERL_UNUSED_ARG(sv);
1122 SHARED_EDIT;
1123 if (SvTYPE(ssv) == SVt_PVAV) {
1124 val = av_len((AV*) ssv);
1125 } else {
1126 /* Not actually defined by tie API but ... */
1127 val = HvUSEDKEYS((HV*) ssv);
1128 }
1129 SHARED_RELEASE;
1130 return (val);
1131 }
1132
1133 /* Clear magic for PERL_MAGIC_tied(P) */
1134
1135 static int
sharedsv_array_mg_CLEAR(pTHX_ SV * sv,MAGIC * mg)1136 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
1137 {
1138 dTHXc;
1139 SV *ssv = (SV *) mg->mg_ptr;
1140 const bool isav = SvTYPE(ssv) == SVt_PVAV;
1141 PERL_UNUSED_ARG(sv);
1142 SHARED_EDIT;
1143 if (!PL_dirty) {
1144 SV **svp = isav ? AvARRAY((AV *)ssv) : NULL;
1145 I32 items = isav ? AvFILLp((AV *)ssv) + 1 : 0;
1146 HE *iter;
1147 if (!isav) hv_iterinit((HV *)ssv);
1148 while (isav ? items-- : !!(iter = hv_iternext((HV *)ssv))) {
1149 SV *sv = isav ? *svp++ : HeVAL(iter);
1150 if (!sv) continue;
1151 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
1152 && SvREFCNT(sv) == 1 ) {
1153 SV *tmp;
1154 PERL_SET_CONTEXT((aTHX = caller_perl));
1155 tmp = sv_newmortal();
1156 sv_upgrade(tmp, SVt_RV);
1157 get_RV(tmp, sv);
1158 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
1159 }
1160 }
1161 }
1162 if (isav) av_clear((AV*) ssv);
1163 else hv_clear((HV*) ssv);
1164 SHARED_RELEASE;
1165 return (0);
1166 }
1167
1168 /* Free magic for PERL_MAGIC_tied(P) */
1169
1170 static int
sharedsv_array_mg_free(pTHX_ SV * sv,MAGIC * mg)1171 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
1172 {
1173 PERL_UNUSED_ARG(sv);
1174 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
1175 return (0);
1176 }
1177
1178 /*
1179 * Copy magic for PERL_MAGIC_tied(P)
1180 * This is called when perl is about to access an element of
1181 * the array -
1182 */
1183 #if PERL_VERSION_GE(5,11,0)
1184 static int
sharedsv_array_mg_copy(pTHX_ SV * sv,MAGIC * mg,SV * nsv,const char * name,I32 namlen)1185 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
1186 SV *nsv, const char *name, I32 namlen)
1187 #else
1188 static int
1189 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
1190 SV *nsv, const char *name, int namlen)
1191 #endif
1192 {
1193 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
1194 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
1195 name, namlen);
1196 PERL_UNUSED_ARG(sv);
1197 nmg->mg_flags |= MGf_DUP;
1198 return (1);
1199 }
1200
1201 /* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */
1202
1203 static int
sharedsv_array_mg_dup(pTHX_ MAGIC * mg,CLONE_PARAMS * param)1204 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
1205 {
1206 PERL_UNUSED_ARG(param);
1207 SvREFCNT_inc_void((SV*)mg->mg_ptr);
1208 assert(mg->mg_flags & MGf_DUP);
1209 return (0);
1210 }
1211
1212 const MGVTBL sharedsv_array_vtbl = {
1213 0, /* get */
1214 0, /* set */
1215 sharedsv_array_mg_FETCHSIZE,/* len */
1216 sharedsv_array_mg_CLEAR, /* clear */
1217 sharedsv_array_mg_free, /* free */
1218 sharedsv_array_mg_copy, /* copy */
1219 sharedsv_array_mg_dup, /* dup */
1220 #ifdef MGf_LOCAL
1221 0, /* local */
1222 #endif
1223 };
1224
1225
1226 /* Recursive locks on a sharedsv.
1227 * Locks are dynamically scoped at the level of the first lock.
1228 */
1229 static void
Perl_sharedsv_lock(pTHX_ SV * ssv)1230 Perl_sharedsv_lock(pTHX_ SV *ssv)
1231 {
1232 user_lock *ul;
1233 if (! ssv)
1234 return;
1235 ul = S_get_userlock(aTHX_ ssv, 1);
1236 recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__);
1237 }
1238
1239 /* Handles calls from lock() builtin via PL_lockhook */
1240
1241 static void
Perl_sharedsv_locksv(pTHX_ SV * sv)1242 Perl_sharedsv_locksv(pTHX_ SV *sv)
1243 {
1244 SV *ssv;
1245
1246 if (SvROK(sv))
1247 sv = SvRV(sv);
1248 ssv = Perl_sharedsv_find(aTHX_ sv);
1249 if (!ssv)
1250 croak("lock can only be used on shared values");
1251 Perl_sharedsv_lock(aTHX_ ssv);
1252 }
1253
1254
1255 /* Can a shared object be destroyed?
1256 * True if not a shared,
1257 * or if destroying last proxy on a shared object
1258 */
1259 #ifdef PL_destroyhook
1260 static bool
Perl_shared_object_destroy(pTHX_ SV * sv)1261 Perl_shared_object_destroy(pTHX_ SV *sv)
1262 {
1263 SV *ssv;
1264
1265 if (SvROK(sv))
1266 sv = SvRV(sv);
1267 ssv = Perl_sharedsv_find(aTHX_ sv);
1268 return (!ssv || (SvREFCNT(ssv) <= 1));
1269 }
1270 #endif
1271
1272 /* veto signal dispatch if we have the lock */
1273
1274 #ifdef PL_signalhook
1275
1276 STATIC despatch_signals_proc_t prev_signal_hook = NULL;
1277
1278 STATIC void
S_shared_signal_hook(pTHX)1279 S_shared_signal_hook(pTHX) {
1280 int us;
1281 MUTEX_LOCK(&PL_sharedsv_lock.mutex);
1282 us = (PL_sharedsv_lock.owner == aTHX);
1283 MUTEX_UNLOCK(&PL_sharedsv_lock.mutex);
1284 if (us)
1285 return; /* try again later */
1286 prev_signal_hook(aTHX);
1287 }
1288 #endif
1289
1290 /* Saves a space for keeping SVs wider than an interpreter. */
1291
1292 static void
Perl_sharedsv_init(pTHX)1293 Perl_sharedsv_init(pTHX)
1294 {
1295 dTHXc;
1296 if (!PL_sharedsv_space) {
1297 PL_sharedsv_space = perl_alloc();
1298 perl_construct(PL_sharedsv_space);
1299 /* The pair above leaves us in shared context (what dTHX would get),
1300 * but aTHX still points to caller context */
1301 aTHX = PL_sharedsv_space;
1302 LEAVE; /* This balances the ENTER at the end of perl_construct. */
1303 PERL_SET_CONTEXT((aTHX = caller_perl));
1304 recursive_lock_init(aTHX_ &PL_sharedsv_lock);
1305 }
1306 PL_lockhook = &Perl_sharedsv_locksv;
1307 PL_sharehook = &Perl_sharedsv_share;
1308 #ifdef PL_destroyhook
1309 PL_destroyhook = &Perl_shared_object_destroy;
1310 #endif
1311 #ifdef PL_signalhook
1312 if (!prev_signal_hook) {
1313 prev_signal_hook = PL_signalhook;
1314 PL_signalhook = &S_shared_signal_hook;
1315 }
1316 #endif
1317 }
1318
1319 #endif /* USE_ITHREADS */
1320
1321 MODULE = threads::shared PACKAGE = threads::shared::tie
1322
1323 PROTOTYPES: DISABLE
1324
1325 #ifdef USE_ITHREADS
1326
1327 void
1328 PUSH(SV *obj, ...)
1329 CODE:
1330 dTHXc;
1331 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1332 int ii;
1333 for (ii = 1; ii < items; ii++) {
1334 SV* tmp = newSVsv(ST(ii));
1335 SV *stmp;
1336 U32 dualvar_flags = DUALVAR_FLAGS(tmp);
1337 ENTER_LOCK;
1338 stmp = S_sharedsv_new_shared(aTHX_ tmp);
1339 sharedsv_scalar_store(aTHX_ tmp, stmp);
1340 SvFLAGS(stmp) |= dualvar_flags;
1341 SHARED_CONTEXT;
1342 av_push((AV*) sobj, stmp);
1343 SvREFCNT_inc_void(stmp);
1344 SHARED_RELEASE;
1345 SvREFCNT_dec(tmp);
1346 }
1347
1348
1349 void
1350 UNSHIFT(SV *obj, ...)
1351 CODE:
1352 dTHXc;
1353 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1354 int ii;
1355 ENTER_LOCK;
1356 SHARED_CONTEXT;
1357 av_unshift((AV*)sobj, items - 1);
1358 CALLER_CONTEXT;
1359 for (ii = 1; ii < items; ii++) {
1360 SV *tmp = newSVsv(ST(ii));
1361 U32 dualvar_flags = DUALVAR_FLAGS(tmp);
1362 SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
1363 sharedsv_scalar_store(aTHX_ tmp, stmp);
1364 SHARED_CONTEXT;
1365 SvFLAGS(stmp) |= dualvar_flags;
1366 av_store((AV*) sobj, ii - 1, stmp);
1367 SvREFCNT_inc_void(stmp);
1368 CALLER_CONTEXT;
1369 SvREFCNT_dec(tmp);
1370 }
1371 LEAVE_LOCK;
1372
1373
1374 void
1375 POP(SV *obj)
1376 CODE:
1377 dTHXc;
1378 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1379 SV* ssv;
1380 ENTER_LOCK;
1381 SHARED_CONTEXT;
1382 ssv = av_pop((AV*)sobj);
1383 CALLER_CONTEXT;
1384 ST(0) = sv_newmortal();
1385 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1386 SvREFCNT_dec(ssv);
1387 LEAVE_LOCK;
1388 /* XSRETURN(1); - implied */
1389
1390
1391 void
1392 SHIFT(SV *obj)
1393 CODE:
1394 dTHXc;
1395 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1396 SV* ssv;
1397 ENTER_LOCK;
1398 SHARED_CONTEXT;
1399 ssv = av_shift((AV*)sobj);
1400 CALLER_CONTEXT;
1401 ST(0) = sv_newmortal();
1402 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1403 SvREFCNT_dec(ssv);
1404 LEAVE_LOCK;
1405 /* XSRETURN(1); - implied */
1406
1407
1408 void
1409 EXTEND(SV *obj, IV count)
1410 CODE:
1411 dTHXc;
1412 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1413 SHARED_EDIT;
1414 av_extend((AV*)sobj, count);
1415 SHARED_RELEASE;
1416
1417
1418 void
1419 STORESIZE(SV *obj,IV count)
1420 CODE:
1421 dTHXc;
1422 SV *ssv = SHAREDSV_FROM_OBJ(obj);
1423
1424 SHARED_EDIT;
1425 assert(SvTYPE(ssv) == SVt_PVAV);
1426 if (!PL_dirty) {
1427 SV **svp = AvARRAY((AV *)ssv);
1428 I32 ix = AvFILLp((AV *)ssv);
1429 for (;ix >= count; ix--) {
1430 SV *sv = svp[ix];
1431 if (!sv)
1432 continue;
1433 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
1434 && SvREFCNT(sv) == 1 )
1435 {
1436 SV *tmp;
1437 PERL_SET_CONTEXT((aTHX = caller_perl));
1438 tmp = sv_newmortal();
1439 sv_upgrade(tmp, SVt_RV);
1440 get_RV(tmp, sv);
1441 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
1442 }
1443 }
1444 }
1445 av_fill((AV*) ssv, count - 1);
1446 SHARED_RELEASE;
1447
1448
1449 void
1450 EXISTS(SV *obj, SV *index)
1451 CODE:
1452 dTHXc;
1453 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1454 bool exists;
1455 if (SvTYPE(sobj) == SVt_PVAV) {
1456 SHARED_EDIT;
1457 exists = av_exists((AV*) sobj, SvIV(index));
1458 } else {
1459 I32 len;
1460 STRLEN slen;
1461 char *key = SvPVutf8(index, slen);
1462 len = slen;
1463 if (SvUTF8(index)) {
1464 len = -len;
1465 }
1466 SHARED_EDIT;
1467 exists = hv_exists((HV*) sobj, key, len);
1468 }
1469 SHARED_RELEASE;
1470 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1471 /* XSRETURN(1); - implied */
1472
1473
1474 void
1475 FIRSTKEY(SV *obj)
1476 CODE:
1477 dTHXc;
1478 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1479 char* key = NULL;
1480 I32 len = 0;
1481 HE* entry;
1482 ENTER_LOCK;
1483 SHARED_CONTEXT;
1484 hv_iterinit((HV*) sobj);
1485 entry = hv_iternext((HV*) sobj);
1486 if (entry) {
1487 I32 utf8 = HeKUTF8(entry);
1488 key = hv_iterkey(entry,&len);
1489 CALLER_CONTEXT;
1490 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
1491 } else {
1492 CALLER_CONTEXT;
1493 ST(0) = &PL_sv_undef;
1494 }
1495 LEAVE_LOCK;
1496 /* XSRETURN(1); - implied */
1497
1498
1499 void
1500 NEXTKEY(SV *obj, SV *oldkey)
1501 CODE:
1502 dTHXc;
1503 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1504 char* key = NULL;
1505 I32 len = 0;
1506 HE* entry;
1507
1508 PERL_UNUSED_VAR(oldkey);
1509
1510 ENTER_LOCK;
1511 SHARED_CONTEXT;
1512 entry = hv_iternext((HV*) sobj);
1513 if (entry) {
1514 I32 utf8 = HeKUTF8(entry);
1515 key = hv_iterkey(entry,&len);
1516 CALLER_CONTEXT;
1517 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
1518 } else {
1519 CALLER_CONTEXT;
1520 ST(0) = &PL_sv_undef;
1521 }
1522 LEAVE_LOCK;
1523 /* XSRETURN(1); - implied */
1524
1525
1526 MODULE = threads::shared PACKAGE = threads::shared
1527
1528 PROTOTYPES: ENABLE
1529
1530 void
1531 _id(SV *myref)
1532 PROTOTYPE: \[$@%]
1533 PREINIT:
1534 SV *ssv;
1535 CODE:
1536 myref = SvRV(myref);
1537 if (SvMAGICAL(myref))
1538 mg_get(myref);
1539 if (SvROK(myref))
1540 myref = SvRV(myref);
1541 ssv = Perl_sharedsv_find(aTHX_ myref);
1542 if (! ssv)
1543 XSRETURN_UNDEF;
1544 ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
1545 /* XSRETURN(1); - implied */
1546
1547
1548 void
1549 _refcnt(SV *myref)
1550 PROTOTYPE: \[$@%]
1551 PREINIT:
1552 SV *ssv;
1553 CODE:
1554 myref = SvRV(myref);
1555 if (SvROK(myref))
1556 myref = SvRV(myref);
1557 ssv = Perl_sharedsv_find(aTHX_ myref);
1558 if (! ssv) {
1559 if (ckWARN(WARN_THREADS)) {
1560 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1561 "%" SVf " is not shared", ST(0));
1562 }
1563 XSRETURN_UNDEF;
1564 }
1565 ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
1566 /* XSRETURN(1); - implied */
1567
1568
1569 void
1570 share(SV *myref)
1571 PROTOTYPE: \[$@%]
1572 CODE:
1573 if (! SvROK(myref))
1574 Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
1575 myref = SvRV(myref);
1576 if (SvROK(myref))
1577 myref = SvRV(myref);
1578 Perl_sharedsv_share(aTHX_ myref);
1579 ST(0) = sv_2mortal(newRV_inc(myref));
1580 /* XSRETURN(1); - implied */
1581
1582
1583 void
1584 cond_wait(SV *ref_cond, SV *ref_lock = 0)
1585 PROTOTYPE: \[$@%];\[$@%]
1586 PREINIT:
1587 SV *ssv;
1588 perl_cond* user_condition;
1589 int locks;
1590 user_lock *ul;
1591 CODE:
1592 if (!SvROK(ref_cond))
1593 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
1594 ref_cond = SvRV(ref_cond);
1595 if (SvROK(ref_cond))
1596 ref_cond = SvRV(ref_cond);
1597 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1598 if (! ssv)
1599 Perl_croak(aTHX_ "cond_wait can only be used on shared values");
1600 ul = S_get_userlock(aTHX_ ssv, 1);
1601
1602 user_condition = &ul->user_cond;
1603 if (ref_lock && (ref_cond != ref_lock)) {
1604 if (!SvROK(ref_lock))
1605 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1606 ref_lock = SvRV(ref_lock);
1607 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1608 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1609 if (! ssv)
1610 Perl_croak(aTHX_ "cond_wait lock must be a shared value");
1611 ul = S_get_userlock(aTHX_ ssv, 1);
1612 }
1613 if (ul->lock.owner != aTHX)
1614 croak("You need a lock before you can cond_wait");
1615
1616 /* Stealing the members of the lock object worries me - NI-S */
1617 MUTEX_LOCK(&ul->lock.mutex);
1618 ul->lock.owner = NULL;
1619 locks = ul->lock.locks;
1620 ul->lock.locks = 0;
1621
1622 /* Since we are releasing the lock here, we need to tell other
1623 * people that it is ok to go ahead and use it */
1624 COND_SIGNAL(&ul->lock.cond);
1625 COND_WAIT(user_condition, &ul->lock.mutex);
1626 while (ul->lock.owner != NULL) {
1627 /* OK -- must reacquire the lock */
1628 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1629 }
1630 ul->lock.owner = aTHX;
1631 ul->lock.locks = locks;
1632 MUTEX_UNLOCK(&ul->lock.mutex);
1633
1634
1635 int
1636 cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0)
1637 PROTOTYPE: \[$@%]$;\[$@%]
1638 PREINIT:
1639 SV *ssv;
1640 perl_cond* user_condition;
1641 int locks;
1642 user_lock *ul;
1643 CODE:
1644 if (! SvROK(ref_cond))
1645 Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1646 ref_cond = SvRV(ref_cond);
1647 if (SvROK(ref_cond))
1648 ref_cond = SvRV(ref_cond);
1649 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1650 if (! ssv)
1651 Perl_croak(aTHX_ "cond_timedwait can only be used on shared values");
1652 ul = S_get_userlock(aTHX_ ssv, 1);
1653
1654 user_condition = &ul->user_cond;
1655 if (ref_lock && (ref_cond != ref_lock)) {
1656 if (! SvROK(ref_lock))
1657 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1658 ref_lock = SvRV(ref_lock);
1659 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1660 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1661 if (! ssv)
1662 Perl_croak(aTHX_ "cond_timedwait lock must be a shared value");
1663 ul = S_get_userlock(aTHX_ ssv, 1);
1664 }
1665 if (ul->lock.owner != aTHX)
1666 Perl_croak(aTHX_ "You need a lock before you can cond_wait");
1667
1668 MUTEX_LOCK(&ul->lock.mutex);
1669 ul->lock.owner = NULL;
1670 locks = ul->lock.locks;
1671 ul->lock.locks = 0;
1672 /* Since we are releasing the lock here, we need to tell other
1673 * people that it is ok to go ahead and use it */
1674 COND_SIGNAL(&ul->lock.cond);
1675 RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs);
1676 while (ul->lock.owner != NULL) {
1677 /* OK -- must reacquire the lock... */
1678 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1679 }
1680 ul->lock.owner = aTHX;
1681 ul->lock.locks = locks;
1682 MUTEX_UNLOCK(&ul->lock.mutex);
1683
1684 if (RETVAL == 0)
1685 XSRETURN_UNDEF;
1686 OUTPUT:
1687 RETVAL
1688
1689
1690 void
1691 cond_signal(SV *myref)
1692 PROTOTYPE: \[$@%]
1693 PREINIT:
1694 SV *ssv;
1695 user_lock *ul;
1696 CODE:
1697 if (! SvROK(myref))
1698 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
1699 myref = SvRV(myref);
1700 if (SvROK(myref))
1701 myref = SvRV(myref);
1702 ssv = Perl_sharedsv_find(aTHX_ myref);
1703 if (! ssv)
1704 Perl_croak(aTHX_ "cond_signal can only be used on shared values");
1705 ul = S_get_userlock(aTHX_ ssv, 1);
1706 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1707 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1708 "cond_signal() called on unlocked variable");
1709 }
1710 COND_SIGNAL(&ul->user_cond);
1711
1712
1713 void
1714 cond_broadcast(SV *myref)
1715 PROTOTYPE: \[$@%]
1716 PREINIT:
1717 SV *ssv;
1718 user_lock *ul;
1719 CODE:
1720 if (! SvROK(myref))
1721 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
1722 myref = SvRV(myref);
1723 if (SvROK(myref))
1724 myref = SvRV(myref);
1725 ssv = Perl_sharedsv_find(aTHX_ myref);
1726 if (! ssv)
1727 Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
1728 ul = S_get_userlock(aTHX_ ssv, 1);
1729 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1730 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1731 "cond_broadcast() called on unlocked variable");
1732 }
1733 COND_BROADCAST(&ul->user_cond);
1734
1735
1736 void
1737 bless(SV* myref, ...)
1738 PROTOTYPE: $;$
1739 PREINIT:
1740 HV* stash;
1741 SV *ssv;
1742 CODE:
1743 if (items == 1) {
1744 stash = CopSTASH(PL_curcop);
1745 } else {
1746 SV* classname = ST(1);
1747 STRLEN len;
1748 char *ptr;
1749
1750 if (classname &&
1751 ! SvGMAGICAL(classname) &&
1752 ! SvAMAGIC(classname) &&
1753 SvROK(classname))
1754 {
1755 Perl_croak(aTHX_ "Attempt to bless into a reference");
1756 }
1757 ptr = SvPV(classname, len);
1758 if (ckWARN(WARN_MISC) && len == 0) {
1759 Perl_warner(aTHX_ packWARN(WARN_MISC),
1760 "Explicit blessing to '' (assuming package main)");
1761 }
1762 stash = gv_stashpvn(ptr, len, TRUE);
1763 }
1764 SvREFCNT_inc_void(myref);
1765 (void)sv_bless(myref, stash);
1766 ST(0) = sv_2mortal(myref);
1767 ssv = Perl_sharedsv_find(aTHX_ myref);
1768 if (ssv) {
1769 dTHXc;
1770 ENTER_LOCK;
1771 SHARED_CONTEXT;
1772 {
1773 SV* fake_stash = newSVpv(HvNAME_get(stash), 0);
1774 (void)sv_bless(ssv, (HV*)fake_stash);
1775 }
1776 CALLER_CONTEXT;
1777 LEAVE_LOCK;
1778 }
1779 /* XSRETURN(1); - implied */
1780
1781 #endif /* USE_ITHREADS */
1782
1783 BOOT:
1784 {
1785 #ifdef USE_ITHREADS
1786 Perl_sharedsv_init(aTHX);
1787 #endif /* USE_ITHREADS */
1788 }
1789