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