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