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