This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c902683f6aa1d1c10a6ae987748e6d51df09d365
[perl5.git] / ext / threads / shared / shared.xs
1 /*    shared.xs
2  *
3  *    Copyright (c) 2001-2002, 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 Arthur Bergman arthur@contiller.se
13  * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net
14  */
15
16 #define PERL_NO_GET_CONTEXT
17 #include "EXTERN.h"
18 #include "perl.h"
19 #include "XSUB.h"
20
21 #ifdef USE_ITHREADS
22
23 #define SHAREDSvPTR(a)      ((a)->sv)
24
25 /*
26  * The shared things need an intepreter to live in ...
27  */
28 PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
29 /* To access shared space we fake aTHX in this scope and thread's context */
30
31 /* bug #24255: we include ENTER+SAVETMPS/FREETMPS+LEAVE with
32  * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals etc created
33  * while in the shared interpreter context don't languish */
34
35 #define SHARED_CONTEXT \
36     STMT_START {                                        \
37         PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));   \
38         ENTER;                                          \
39         SAVETMPS;                                       \
40     } STMT_END
41
42 /* So we need a way to switch back to the caller's context... */
43 /* So we declare _another_ copy of the aTHX variable ... */
44 #define dTHXc PerlInterpreter *caller_perl = aTHX
45
46 /* and use it to switch back */
47 #define CALLER_CONTEXT                                  \
48     STMT_START {                                        \
49         FREETMPS;                                       \
50         LEAVE;                                          \
51         PERL_SET_CONTEXT((aTHX = caller_perl));         \
52     } STMT_END
53
54 /*
55  * Only one thread at a time is allowed to mess with shared space.
56  */
57
58 typedef struct
59 {
60  perl_mutex              mutex;
61  PerlInterpreter        *owner;
62  I32                     locks;
63  perl_cond               cond;
64 #ifdef DEBUG_LOCKS
65  char *                  file;
66  int                     line;
67 #endif
68 } recursive_lock_t;
69
70 recursive_lock_t PL_sharedsv_lock;       /* Mutex protecting the shared sv space */
71
72 void
73 recursive_lock_init(pTHX_ recursive_lock_t *lock)
74 {
75     Zero(lock,1,recursive_lock_t);
76     MUTEX_INIT(&lock->mutex);
77     COND_INIT(&lock->cond);
78 }
79
80 void
81 recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
82 {
83     MUTEX_DESTROY(&lock->mutex);
84     COND_DESTROY(&lock->cond);
85 }
86
87 void
88 recursive_lock_release(pTHX_ recursive_lock_t *lock)
89 {
90     MUTEX_LOCK(&lock->mutex);
91     if (lock->owner != aTHX) {
92         MUTEX_UNLOCK(&lock->mutex);
93     }
94     else {
95         if (--lock->locks == 0) {
96             lock->owner = NULL;
97             COND_SIGNAL(&lock->cond);
98         }
99     }
100     MUTEX_UNLOCK(&lock->mutex);
101 }
102
103 void
104 recursive_lock_acquire(pTHX_ recursive_lock_t *lock,char *file,int line)
105 {
106     assert(aTHX);
107     MUTEX_LOCK(&lock->mutex);
108     if (lock->owner == aTHX) {
109         lock->locks++;
110     }
111     else {
112         while (lock->owner) {
113 #ifdef DEBUG_LOCKS
114             Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
115                       aTHX, lock->owner, lock->file, lock->line);
116 #endif
117             COND_WAIT(&lock->cond,&lock->mutex);
118         }
119         lock->locks = 1;
120         lock->owner = aTHX;
121 #ifdef DEBUG_LOCKS
122         lock->file  = file;
123         lock->line  = line;
124 #endif
125     }
126     MUTEX_UNLOCK(&lock->mutex);
127     SAVEDESTRUCTOR_X(recursive_lock_release,lock);
128 }
129
130 #define ENTER_LOCK         STMT_START { \
131                               ENTER; \
132                               recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);   \
133                             } STMT_END
134
135 #define LEAVE_LOCK       LEAVE
136
137
138 /* A common idiom is to acquire access and switch in ... */
139 #define SHARED_EDIT         STMT_START {        \
140                                 ENTER_LOCK;     \
141                                 SHARED_CONTEXT; \
142                             } STMT_END
143
144 /* then switch out and release access. */
145 #define SHARED_RELEASE     STMT_START { \
146                                 CALLER_CONTEXT; \
147                                 LEAVE_LOCK;     \
148                             } STMT_END
149
150
151 /*
152
153   Shared SV
154
155   Shared SV is a structure for keeping the backend storage
156   of shared svs.
157
158   Shared-ness really only needs the SV * - the rest is for locks.
159   (Which suggests further space optimization ... )
160
161 */
162
163 typedef struct {
164     SV                 *sv;             /* The actual SV - in shared space */
165     recursive_lock_t    lock;
166     perl_cond           user_cond;      /* For user-level conditions */
167 } shared_sv;
168
169 /* The SV in shared-space has a back-pointer to the shared_sv
170    struct associated with it PERL_MAGIC_ext.
171
172    The vtable used has just one entry - when the SV goes away
173    we free the memory for the above.
174
175  */
176
177 int
178 sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
179 {
180     shared_sv *shared = (shared_sv *) mg->mg_ptr;
181     assert( aTHX == PL_sharedsv_space );
182     if (shared) {
183         recursive_lock_destroy(aTHX_ &shared->lock);
184         COND_DESTROY(&shared->user_cond);
185         PerlMemShared_free(shared);
186         mg->mg_ptr = NULL;
187     }
188     return 0;
189 }
190
191 MGVTBL sharedsv_shared_vtbl = {
192  0,                             /* get */
193  0,                             /* set */
194  0,                             /* len */
195  0,                             /* clear */
196  sharedsv_shared_mg_free,       /* free */
197  0,                             /* copy */
198  0,                             /* dup */
199 };
200
201 /* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */
202
203 /* In any thread that has access to a shared thing there is a "proxy"
204    for it in its own space which has 'MAGIC' associated which accesses
205    the shared thing.
206  */
207
208 MGVTBL sharedsv_scalar_vtbl;    /* scalars have this vtable */
209 MGVTBL sharedsv_array_vtbl;     /* hashes and arrays have this - like 'tie' */
210 MGVTBL sharedsv_elem_vtbl;      /* elements of hashes and arrays have this
211                                    _AS WELL AS_ the scalar magic */
212
213 /* The sharedsv_elem_vtbl associates the element with the array/hash and
214    the sharedsv_scalar_vtbl associates it with the value
215  */
216
217
218 /* Accessor to convert threads::shared::tie objects back shared_sv * */
219 shared_sv *
220 SV_to_sharedsv(pTHX_ SV *sv)
221 {
222     shared_sv *shared = 0;
223     if (SvROK(sv))
224      {
225       shared = INT2PTR(shared_sv *, SvIV(SvRV(sv)));
226      }
227     return shared;
228 }
229
230 =for apidoc sharedsv_find
231
232 Given a private side SV tries to find if the SV has a shared backend,
233 by looking for the magic.
234
235 =cut
236
237 shared_sv *
238 Perl_sharedsv_find(pTHX_ SV *sv)
239 {
240     MAGIC *mg;
241     if (SvTYPE(sv) >= SVt_PVMG) {
242         switch(SvTYPE(sv)) {
243         case SVt_PVAV:
244         case SVt_PVHV:
245             if ((mg = mg_find(sv, PERL_MAGIC_tied))
246                 && mg->mg_virtual == &sharedsv_array_vtbl) {
247                 return (shared_sv *) mg->mg_ptr;
248             }
249             break;
250         default:
251             /* This should work for elements as well as they
252              * have scalar magic as well as their element magic
253              */
254             if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
255                 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
256                 return (shared_sv *) mg->mg_ptr;
257             }
258             break;
259         }
260     }
261     /* Just for tidyness of API also handle tie objects */
262     if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
263         return SV_to_sharedsv(aTHX_ sv);
264     }
265     return NULL;
266 }
267
268 /*
269  *  Almost all the pain is in this routine.
270  *
271  */
272
273 shared_sv *
274 Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
275 {
276     dTHXc;
277     MAGIC *mg = 0;
278     SV *sv    = (psv) ? *psv : Nullsv;
279
280     /* If we are asked for an private ops we need a thread */
281     assert ( aTHX !=  PL_sharedsv_space );
282
283     /* To avoid need for recursive locks require caller to hold lock */
284     assert ( PL_sharedsv_lock.owner == aTHX );
285
286     /* First try and get existing global data structure */
287
288     /* Try shared SV as 1st choice */
289     if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
290         if( (mg = mg_find(ssv, PERL_MAGIC_ext)) ){
291             data = (shared_sv *) mg->mg_ptr;
292         }
293     }
294
295     /* Next see if private SV is associated with something */
296     if (!data && sv) {
297         data = Perl_sharedsv_find(aTHX_ sv);
298     }
299
300     /* If neither of those then create a new one */
301     if (!data) {
302             SHARED_CONTEXT;
303             if (!ssv) {
304                 ssv = newSV(0);
305                 SvREFCNT(ssv) = 0;
306             }
307             data = (shared_sv *) PerlMemShared_malloc(sizeof(shared_sv));
308             Zero(data,1,shared_sv);
309             SHAREDSvPTR(data) = ssv;
310             /* Tag shared side SV with data pointer */
311             sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
312                    (char *)data, 0);
313             recursive_lock_init(aTHX_ &data->lock);
314             COND_INIT(&data->user_cond);
315             CALLER_CONTEXT;
316     }
317
318     if (!ssv)
319         ssv = SHAREDSvPTR(data);
320     if (!SHAREDSvPTR(data))
321         SHAREDSvPTR(data) = ssv;
322
323     /* If we know type upgrade shared side SV */
324     if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
325         SHARED_CONTEXT;
326         sv_upgrade(ssv, SvTYPE(*psv));
327         if (SvTYPE(ssv) == SVt_PVAV)    /* #24061 */
328             AvREAL_on(ssv);
329         CALLER_CONTEXT;
330     }
331
332     /* Now if requested allocate private SV */
333     if (psv && !sv) {
334         *psv = sv = newSV(0);
335     }
336
337     /* Finally if private SV exists check and add magic */
338     if (sv) {
339         MAGIC *mg = 0;
340         if (SvTYPE(sv) < SvTYPE(ssv)) {
341             sv_upgrade(sv, SvTYPE(ssv));
342         }
343         switch(SvTYPE(sv)) {
344         case SVt_PVAV:
345         case SVt_PVHV:
346             if (!(mg = mg_find(sv, PERL_MAGIC_tied))
347                 || mg->mg_virtual != &sharedsv_array_vtbl
348                 || (shared_sv *) mg->mg_ptr != data) {
349                 SV *obj = newSV(0);
350                 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
351                 if (mg) {
352                     sv_unmagic(sv, PERL_MAGIC_tied);
353                 }
354                 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
355                                 (char *) data, 0);
356                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
357                 SvREFCNT_inc(ssv);
358                 SvREFCNT_dec(obj);
359                 if(SvOBJECT(ssv)) {
360                   STRLEN len;
361                   char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
362                   HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
363                   SvOBJECT_on(sv);
364                   SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash));
365                 }
366             }
367             break;
368
369         default:
370             if ((SvTYPE(sv) < SVt_PVMG)
371                 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
372                 || mg->mg_virtual != &sharedsv_scalar_vtbl
373                 || (shared_sv *) mg->mg_ptr != data) {
374                 if (mg) {
375                     sv_unmagic(sv, PERL_MAGIC_shared_scalar);
376                 }
377                 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
378                                 &sharedsv_scalar_vtbl, (char *)data, 0);
379                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
380                 SvREFCNT_inc(ssv);
381                 if(SvOBJECT(ssv)) {
382                   STRLEN len;
383                   char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
384                   HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
385                   SvOBJECT_on(sv);
386                   SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash));
387                 }
388             }
389             break;
390         }
391         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
392     }
393     return data;
394 }
395
396 void
397 Perl_sharedsv_free(pTHX_ shared_sv *shared)
398 {
399     if (shared) {
400         dTHXc;
401         SHARED_EDIT;
402         SvREFCNT_dec(SHAREDSvPTR(shared));
403         SHARED_RELEASE;
404     }
405 }
406
407 void
408 Perl_sharedsv_share(pTHX_ SV *sv)
409 {
410     switch(SvTYPE(sv)) {
411     case SVt_PVGV:
412         Perl_croak(aTHX_ "Cannot share globs yet");
413         break;
414
415     case SVt_PVCV:
416         Perl_croak(aTHX_ "Cannot share subs yet");
417         break;
418
419     default:
420         ENTER_LOCK;
421         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
422         LEAVE_LOCK;
423         SvSETMAGIC(sv);
424         break;
425     }
426 }
427
428 #if defined(WIN32) || defined(OS2)
429 #  define ABS2RELMILLI(abs)        \
430     do {                                \
431         abs -= (double)time(NULL);      \
432         if (abs > 0) { abs *= 1000; }   \
433         else         { abs  = 0;    }   \
434     } while (0)
435 #endif /* WIN32 || OS2 */
436
437 bool
438 Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
439 {
440 #if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
441     Perl_croak_nocontext("cond_timedwait not supported on this platform");
442 #else
443 #  ifdef WIN32
444     int got_it = 0;
445
446     ABS2RELMILLI(abs);
447
448     cond->waiters++;
449     MUTEX_UNLOCK(mut);
450     /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
451     switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
452         case WAIT_OBJECT_0:   got_it = 1; break;
453         case WAIT_TIMEOUT:                break;
454         default:
455             /* WAIT_FAILED? WAIT_ABANDONED? others? */
456             Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
457             break;
458     }
459     MUTEX_LOCK(mut);
460     cond->waiters--;
461     return got_it;
462 #  else
463 #    ifdef OS2
464     int rc, got_it = 0;
465     STRLEN n_a;
466
467     ABS2RELMILLI(abs);
468
469     if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
470         Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
471     MUTEX_UNLOCK(mut);
472     if (CheckOSError(DosWaitEventSem(*cond,abs))
473         && (rc != ERROR_INTERRUPT))
474         croak_with_os2error("panic: cond_timedwait");
475     if (rc == ERROR_INTERRUPT) errno = EINTR;
476     MUTEX_LOCK(mut);
477     return got_it;
478 #    else         /* hope you're I_PTHREAD! */
479     struct timespec ts;
480     int got_it = 0;
481
482     ts.tv_sec = (long)abs;
483     abs -= (NV)ts.tv_sec;
484     ts.tv_nsec = (long)(abs * 1000000000.0);
485
486     switch (pthread_cond_timedwait(cond, mut, &ts)) {
487         case 0:         got_it = 1; break;
488         case ETIMEDOUT:             break;
489         default:
490             Perl_croak_nocontext("panic: cond_timedwait");
491             break;
492     }
493     return got_it;
494 #    endif /* OS2 */
495 #  endif /* WIN32 */
496 #endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
497 }
498
499 /* MAGIC (in mg.h sense) hooks */
500
501 int
502 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
503 {
504     shared_sv *shared = (shared_sv *) mg->mg_ptr;
505     assert(shared);
506
507     ENTER_LOCK;
508     if (SHAREDSvPTR(shared)) {
509         if (SvROK(SHAREDSvPTR(shared))) {
510             SV *obj = Nullsv;
511             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
512             sv_setsv_nomg(sv, &PL_sv_undef);
513             SvRV_set(sv, obj);
514             SvROK_on(sv);
515             
516         }
517         else {
518             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
519         }
520     }
521     LEAVE_LOCK;
522     return 0;
523 }
524
525 void
526 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
527 {
528     dTHXc;
529     bool allowed = TRUE;
530     if (SvROK(sv)) {
531         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
532         if (target) {
533             SV *tmp;
534             SHARED_CONTEXT;
535             tmp = newRV(SHAREDSvPTR(target));
536             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
537             SvREFCNT_dec(tmp);
538             if(SvOBJECT(SvRV(sv))) {
539               SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(SvRV(sv))),0);
540               SvOBJECT_on(SHAREDSvPTR(target));
541               SvSTASH_set(SHAREDSvPTR(target), (HV*)fake_stash);
542             }
543             CALLER_CONTEXT;
544         }
545         else {
546             allowed = FALSE;
547         }
548     }
549     else {
550         SvTEMP_off(sv);
551         SHARED_CONTEXT;
552         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
553         if(SvOBJECT(sv)) {
554           SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0);
555           SvOBJECT_on(SHAREDSvPTR(shared));
556           SvSTASH_set(SHAREDSvPTR(shared), (HV*)fake_stash);
557         }
558         CALLER_CONTEXT;
559     }
560     if (!allowed) {
561         Perl_croak(aTHX_ "Invalid value for shared scalar");
562     }
563 }
564
565 int
566 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
567 {
568     shared_sv *shared;
569     ENTER_LOCK;
570     /* We call associate to potentially upgrade shared side SV */
571     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
572     assert(shared);
573     sharedsv_scalar_store(aTHX_ sv, shared);
574     LEAVE_LOCK;
575     return 0;
576 }
577
578 int
579 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
580 {
581     shared_sv *shared = (shared_sv *) mg->mg_ptr;
582 #if 0
583     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
584 #endif
585     Perl_sharedsv_free(aTHX_ shared);
586     return 0;
587 }
588
589 int
590 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
591 {
592     return 0;
593 }
594
595 /*
596  * Called during cloning of new threads
597  */
598 int
599 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
600 {
601     shared_sv *shared = (shared_sv *) mg->mg_ptr;
602     if (shared) {
603         SvREFCNT_inc(SHAREDSvPTR(shared));
604     }
605     return 0;
606 }
607
608 MGVTBL sharedsv_scalar_vtbl = {
609  sharedsv_scalar_mg_get,        /* get */
610  sharedsv_scalar_mg_set,        /* set */
611  0,                             /* len */
612  sharedsv_scalar_mg_clear,      /* clear */
613  sharedsv_scalar_mg_free,       /* free */
614  0,                             /* copy */
615  sharedsv_scalar_mg_dup         /* dup */
616 };
617
618 /* Now the arrays/hashes stuff */
619 int
620 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
621 {
622     dTHXc;
623     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
624     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
625     SV** svp;
626
627     assert ( shared );
628     assert ( SHAREDSvPTR(shared) );
629
630     ENTER_LOCK;
631     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
632         assert ( mg->mg_ptr == 0 );
633         SHARED_CONTEXT;
634         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
635     }
636     else {
637         char *key = mg->mg_ptr;
638         STRLEN len = mg->mg_len;
639         assert ( mg->mg_ptr != 0 );
640         if (mg->mg_len == HEf_SVKEY) {
641            key = SvPV((SV *) mg->mg_ptr, len);
642         }
643         SHARED_CONTEXT;
644         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
645     }
646     CALLER_CONTEXT;
647     if (svp) {
648         /* Exists in the array */
649         if (SvROK(*svp)) {
650             SV *obj = Nullsv;
651             Perl_sharedsv_associate(aTHX_ &obj, SvRV(*svp), NULL);
652             sv_setsv_nomg(sv, &PL_sv_undef);
653             SvRV_set(sv, obj);
654             SvROK_on(sv);
655             SvSETMAGIC(sv);
656         }
657         else {
658             target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
659             sv_setsv(sv, *svp);
660         }
661     }
662     else {
663         /* Not in the array */
664         sv_setsv(sv, &PL_sv_undef);
665     }
666     LEAVE_LOCK;
667     return 0;
668 }
669
670 int
671 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
672 {
673     dTHXc;
674     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
675     shared_sv *target;
676     SV **svp;
677     /* Theory - SV itself is magically shared - and we have ordered the
678        magic such that by the time we get here it has been stored
679        to its shared counterpart
680      */
681     ENTER_LOCK;
682     assert(shared);
683     assert(SHAREDSvPTR(shared));
684     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
685         assert ( mg->mg_ptr == 0 );
686         SHARED_CONTEXT;
687         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
688     }
689     else {
690         char *key = mg->mg_ptr;
691         STRLEN len = mg->mg_len;
692         assert ( mg->mg_ptr != 0 );
693         if (mg->mg_len == HEf_SVKEY)
694            key = SvPV((SV *) mg->mg_ptr, len);
695         SHARED_CONTEXT;
696         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
697     }
698     CALLER_CONTEXT;
699     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
700     sharedsv_scalar_store(aTHX_ sv, target);
701     LEAVE_LOCK;
702     return 0;
703 }
704
705 int
706 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
707 {
708     dTHXc;
709     MAGIC *shmg;
710     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
711     ENTER_LOCK;
712     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
713     if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
714         sharedsv_scalar_mg_get(aTHX_ sv, shmg);
715     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
716         SHARED_CONTEXT;
717         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
718     }
719     else {
720         char *key = mg->mg_ptr;
721         STRLEN len = mg->mg_len;
722         assert ( mg->mg_ptr != 0 );
723         if (mg->mg_len == HEf_SVKEY)
724            key = SvPV((SV *) mg->mg_ptr, len);
725         SHARED_CONTEXT;
726         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
727     }
728     CALLER_CONTEXT;
729     LEAVE_LOCK;
730     return 0;
731 }
732
733 int
734 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
735 {
736     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
737     return 0;
738 }
739
740 int
741 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
742 {
743     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
744     SvREFCNT_inc(SHAREDSvPTR(shared));
745     mg->mg_flags |= MGf_DUP;
746     return 0;
747 }
748
749 MGVTBL sharedsv_elem_vtbl = {
750  sharedsv_elem_mg_FETCH,        /* get */
751  sharedsv_elem_mg_STORE,        /* set */
752  0,                             /* len */
753  sharedsv_elem_mg_DELETE,       /* clear */
754  sharedsv_elem_mg_free,         /* free */
755  0,                             /* copy */
756  sharedsv_elem_mg_dup           /* dup */
757 };
758
759 U32
760 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
761 {
762     dTHXc;
763     shared_sv *shared = (shared_sv *) mg->mg_ptr;
764     U32 val;
765     SHARED_EDIT;
766     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
767         val = av_len((AV*) SHAREDSvPTR(shared));
768     }
769     else {
770         /* not actually defined by tie API but ... */
771         val = HvKEYS((HV*) SHAREDSvPTR(shared));
772     }
773     SHARED_RELEASE;
774     return val;
775 }
776
777 int
778 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
779 {
780     dTHXc;
781     shared_sv *shared = (shared_sv *) mg->mg_ptr;
782     SHARED_EDIT;
783     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
784         av_clear((AV*) SHAREDSvPTR(shared));
785     }
786     else {
787         hv_clear((HV*) SHAREDSvPTR(shared));
788     }
789     SHARED_RELEASE;
790     return 0;
791 }
792
793 int
794 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
795 {
796     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
797     return 0;
798 }
799
800 /*
801  * This is called when perl is about to access an element of
802  * the array -
803  */
804 int
805 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
806                        SV *nsv, const char *name, int namlen)
807 {
808     shared_sv *shared = (shared_sv *) mg->mg_ptr;
809     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
810                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
811                             name, namlen);
812     ENTER_LOCK;
813     SvREFCNT_inc(SHAREDSvPTR(shared));
814     LEAVE_LOCK;
815     nmg->mg_flags |= MGf_DUP;
816     return 1;
817 }
818
819 int
820 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
821 {
822     shared_sv *shared = (shared_sv *) mg->mg_ptr;
823     SvREFCNT_inc(SHAREDSvPTR(shared));
824     mg->mg_flags |= MGf_DUP;
825     return 0;
826 }
827
828 MGVTBL sharedsv_array_vtbl = {
829  0,                             /* get */
830  0,                             /* set */
831  sharedsv_array_mg_FETCHSIZE,   /* len */
832  sharedsv_array_mg_CLEAR,       /* clear */
833  sharedsv_array_mg_free,        /* free */
834  sharedsv_array_mg_copy,        /* copy */
835  sharedsv_array_mg_dup          /* dup */
836 };
837
838 =for apidoc sharedsv_unlock
839
840 Recursively unlocks a shared sv.
841
842 =cut
843
844 void
845 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
846 {
847     recursive_lock_release(aTHX_ &ssv->lock);
848 }
849
850 =for apidoc sharedsv_lock
851
852 Recursive locks on a sharedsv.
853 Locks are dynamically scoped at the level of the first lock.
854
855 =cut
856
857 void
858 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
859 {
860     if (!ssv)
861         return;
862     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
863 }
864
865 /* handles calls from lock() builtin via PL_lockhook */
866
867 void
868 Perl_sharedsv_locksv(pTHX_ SV *sv)
869 {
870     shared_sv* shared;
871
872     if(SvROK(sv))
873         sv = SvRV(sv);
874     shared = Perl_sharedsv_find(aTHX_ sv);
875     if(!shared)
876        croak("lock can only be used on shared values");
877     Perl_sharedsv_lock(aTHX_ shared);
878 }
879
880 =head1 Shared SV Functions
881
882 =for apidoc sharedsv_init
883
884 Saves a space for keeping SVs wider than an interpreter,
885
886 =cut
887
888 void
889 Perl_sharedsv_init(pTHX)
890 {
891   dTHXc;
892   /* This pair leaves us in shared context ... */
893   PL_sharedsv_space = perl_alloc();
894   perl_construct(PL_sharedsv_space);
895   CALLER_CONTEXT;
896   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
897   PL_lockhook = &Perl_sharedsv_locksv;
898   PL_sharehook = &Perl_sharedsv_share;
899 }
900
901 #endif /* USE_ITHREADS */
902
903 MODULE = threads::shared        PACKAGE = threads::shared::tie
904
905 PROTOTYPES: DISABLE
906
907 #ifdef USE_ITHREADS
908
909 void
910 PUSH(shared_sv *shared, ...)
911 CODE:
912         dTHXc;
913         int i;
914         for(i = 1; i < items; i++) {
915             SV* tmp = newSVsv(ST(i));
916             shared_sv *target;
917             ENTER_LOCK;
918             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
919             sharedsv_scalar_store(aTHX_ tmp, target);
920             SHARED_CONTEXT;
921             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
922             SvREFCNT_inc(SHAREDSvPTR(target));
923             SHARED_RELEASE;
924             SvREFCNT_dec(tmp);
925         }
926
927 void
928 UNSHIFT(shared_sv *shared, ...)
929 CODE:
930         dTHXc;
931         int i;
932         ENTER_LOCK;
933         SHARED_CONTEXT;
934         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
935         CALLER_CONTEXT;
936         for(i = 1; i < items; i++) {
937             SV* tmp = newSVsv(ST(i));
938             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
939             sharedsv_scalar_store(aTHX_ tmp, target);
940             SHARED_CONTEXT;
941             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
942             SvREFCNT_inc(SHAREDSvPTR(target));
943             CALLER_CONTEXT;
944             SvREFCNT_dec(tmp);
945         }
946         LEAVE_LOCK;
947
948 void
949 POP(shared_sv *shared)
950 CODE:
951         dTHXc;
952         SV* sv;
953         ENTER_LOCK;
954         SHARED_CONTEXT;
955         sv = av_pop((AV*)SHAREDSvPTR(shared));
956         CALLER_CONTEXT;
957         ST(0) = sv_newmortal();
958         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
959         SvREFCNT_dec(sv);
960         LEAVE_LOCK;
961         XSRETURN(1);
962
963 void
964 SHIFT(shared_sv *shared)
965 CODE:
966         dTHXc;
967         SV* sv;
968         ENTER_LOCK;
969         SHARED_CONTEXT;
970         sv = av_shift((AV*)SHAREDSvPTR(shared));
971         CALLER_CONTEXT;
972         ST(0) = sv_newmortal();
973         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
974         SvREFCNT_dec(sv);
975         LEAVE_LOCK;
976         XSRETURN(1);
977
978 void
979 EXTEND(shared_sv *shared, IV count)
980 CODE:
981         dTHXc;
982         SHARED_EDIT;
983         av_extend((AV*)SHAREDSvPTR(shared), count);
984         SHARED_RELEASE;
985
986 void
987 STORESIZE(shared_sv *shared,IV count)
988 CODE:
989         dTHXc;
990         SHARED_EDIT;
991         av_fill((AV*) SHAREDSvPTR(shared), count);
992         SHARED_RELEASE;
993
994
995
996
997 void
998 EXISTS(shared_sv *shared, SV *index)
999 CODE:
1000         dTHXc;
1001         bool exists;
1002         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
1003             SHARED_EDIT;
1004             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
1005         }
1006         else {
1007             STRLEN len;
1008             char *key = SvPV(index,len);
1009             SHARED_EDIT;
1010             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
1011         }
1012         SHARED_RELEASE;
1013         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1014         XSRETURN(1);
1015
1016
1017 void
1018 FIRSTKEY(shared_sv *shared)
1019 CODE:
1020         dTHXc;
1021         char* key = NULL;
1022         I32 len = 0;
1023         HE* entry;
1024         ENTER_LOCK;
1025         SHARED_CONTEXT;
1026         hv_iterinit((HV*) SHAREDSvPTR(shared));
1027         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1028         if (entry) {
1029                 key = hv_iterkey(entry,&len);
1030                 CALLER_CONTEXT;
1031                 ST(0) = sv_2mortal(newSVpv(key, len));
1032         } else {
1033              CALLER_CONTEXT;
1034              ST(0) = &PL_sv_undef;
1035         }
1036         LEAVE_LOCK;
1037         XSRETURN(1);
1038
1039 void
1040 NEXTKEY(shared_sv *shared, SV *oldkey)
1041 CODE:
1042         dTHXc;
1043         char* key = NULL;
1044         I32 len = 0;
1045         HE* entry;
1046         ENTER_LOCK;
1047         SHARED_CONTEXT;
1048         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1049         if (entry) {
1050                 key = hv_iterkey(entry,&len);
1051                 CALLER_CONTEXT;
1052                 ST(0) = sv_2mortal(newSVpv(key, len));
1053         } else {
1054              CALLER_CONTEXT;
1055              ST(0) = &PL_sv_undef;
1056         }
1057         LEAVE_LOCK;
1058         XSRETURN(1);
1059
1060 MODULE = threads::shared                PACKAGE = threads::shared
1061
1062 PROTOTYPES: ENABLE
1063
1064 void
1065 _id(SV *ref)
1066         PROTOTYPE: \[$@%]
1067 CODE:
1068         shared_sv *shared;
1069         ref = SvRV(ref);
1070         if(SvROK(ref))
1071             ref = SvRV(ref);
1072         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1073             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
1074             XSRETURN(1);
1075         }
1076         XSRETURN_UNDEF;
1077
1078
1079 void
1080 _refcnt(SV *ref)
1081         PROTOTYPE: \[$@%]
1082 CODE:
1083         shared_sv *shared;
1084         ref = SvRV(ref);
1085         if(SvROK(ref))
1086             ref = SvRV(ref);
1087         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1088           if (SHAREDSvPTR(shared)) {
1089             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
1090             XSRETURN(1);
1091           }
1092           else {
1093              Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
1094           }
1095         }
1096         else {
1097              Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
1098         }
1099         XSRETURN_UNDEF;
1100
1101 SV*
1102 share(SV *ref)
1103         PROTOTYPE: \[$@%]
1104         CODE:
1105         if(!SvROK(ref))
1106             Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
1107         ref = SvRV(ref);
1108         if(SvROK(ref))
1109             ref = SvRV(ref);
1110         Perl_sharedsv_share(aTHX_ ref);
1111         RETVAL = newRV(ref);
1112         OUTPUT:
1113         RETVAL
1114
1115 void
1116 lock_enabled(SV *ref)
1117         PROTOTYPE: \[$@%]
1118         CODE:
1119         shared_sv* shared;
1120         if(!SvROK(ref))
1121             Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
1122         ref = SvRV(ref);
1123         if(SvROK(ref))
1124             ref = SvRV(ref);
1125         shared = Perl_sharedsv_find(aTHX_ ref);
1126         if(!shared)
1127            croak("lock can only be used on shared values");
1128         Perl_sharedsv_lock(aTHX_ shared);
1129
1130 void
1131 cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0)
1132         PROTOTYPE: \[$@%];\[$@%]
1133         PREINIT:
1134         shared_sv* shared;
1135         perl_cond* user_condition;
1136         int locks;
1137         int same = 0;
1138
1139         CODE:
1140         if (!ref_lock || ref_lock == ref_cond) same = 1;
1141
1142         if(!SvROK(ref_cond))
1143             Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
1144         ref_cond = SvRV(ref_cond);
1145         if(SvROK(ref_cond))
1146             ref_cond = SvRV(ref_cond);
1147         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1148         if(!shared)
1149             croak("cond_wait can only be used on shared values");
1150
1151         user_condition = &shared->user_cond;
1152         if (! same) {
1153             if (!SvROK(ref_lock))
1154                 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1155             ref_lock = SvRV(ref_lock);
1156             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1157             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1158             if (!shared)
1159                 croak("cond_wait lock must be a shared value");
1160         }
1161         if(shared->lock.owner != aTHX)
1162             croak("You need a lock before you can cond_wait");
1163         /* Stealing the members of the lock object worries me - NI-S */
1164         MUTEX_LOCK(&shared->lock.mutex);
1165         shared->lock.owner = NULL;
1166         locks = shared->lock.locks;
1167         shared->lock.locks = 0;
1168
1169         /* since we are releasing the lock here we need to tell other
1170         people that is ok to go ahead and use it */
1171         COND_SIGNAL(&shared->lock.cond);
1172         COND_WAIT(user_condition, &shared->lock.mutex);
1173         while(shared->lock.owner != NULL) {
1174             /* OK -- must reacquire the lock */
1175             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1176         }
1177         shared->lock.owner = aTHX;
1178         shared->lock.locks = locks;
1179         MUTEX_UNLOCK(&shared->lock.mutex);
1180
1181 int
1182 cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0)
1183         PROTOTYPE: \[$@%]$;\[$@%]
1184         PREINIT:
1185         shared_sv* shared;
1186         perl_cond* user_condition;
1187         int locks;
1188         int same = 0;
1189
1190         CODE:
1191         if (!ref_lock || ref_cond == ref_lock) same = 1;
1192
1193         if(!SvROK(ref_cond))
1194             Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1195         ref_cond = SvRV(ref_cond);
1196         if(SvROK(ref_cond))
1197             ref_cond = SvRV(ref_cond);
1198         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1199         if(!shared)
1200             croak("cond_timedwait can only be used on shared values");
1201     
1202         user_condition = &shared->user_cond;
1203         if (! same) {
1204             if (!SvROK(ref_lock))
1205                 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1206             ref_lock = SvRV(ref_lock);
1207             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1208             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1209             if (!shared)
1210                 croak("cond_timedwait lock must be a shared value");
1211         }
1212         if(shared->lock.owner != aTHX)
1213             croak("You need a lock before you can cond_wait");
1214
1215         MUTEX_LOCK(&shared->lock.mutex);
1216         shared->lock.owner = NULL;
1217         locks = shared->lock.locks;
1218         shared->lock.locks = 0;
1219         /* since we are releasing the lock here we need to tell other
1220         people that is ok to go ahead and use it */
1221         COND_SIGNAL(&shared->lock.cond);
1222         RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs);
1223         while (shared->lock.owner != NULL) {
1224             /* OK -- must reacquire the lock... */
1225             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1226         }
1227         shared->lock.owner = aTHX;
1228         shared->lock.locks = locks;
1229         MUTEX_UNLOCK(&shared->lock.mutex);
1230
1231         if (RETVAL == 0)
1232             XSRETURN_UNDEF;
1233         OUTPUT:
1234         RETVAL
1235
1236 void
1237 cond_signal_enabled(SV *ref)
1238         PROTOTYPE: \[$@%]
1239         CODE:
1240         shared_sv* shared;
1241         if(!SvROK(ref))
1242             Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
1243         ref = SvRV(ref);
1244         if(SvROK(ref))
1245             ref = SvRV(ref);
1246         shared = Perl_sharedsv_find(aTHX_ ref);
1247         if(!shared)
1248             croak("cond_signal can only be used on shared values");
1249         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1250             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1251                             "cond_signal() called on unlocked variable");
1252         COND_SIGNAL(&shared->user_cond);
1253
1254 void
1255 cond_broadcast_enabled(SV *ref)
1256         PROTOTYPE: \[$@%]
1257         CODE:
1258         shared_sv* shared;
1259         if(!SvROK(ref))
1260             Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
1261         ref = SvRV(ref);
1262         if(SvROK(ref))
1263             ref = SvRV(ref);
1264         shared = Perl_sharedsv_find(aTHX_ ref);
1265         if(!shared)
1266             croak("cond_broadcast can only be used on shared values");
1267         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1268             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1269                             "cond_broadcast() called on unlocked variable");
1270         COND_BROADCAST(&shared->user_cond);
1271
1272
1273 SV*
1274 bless(SV* ref, ...);
1275         PROTOTYPE: $;$
1276         CODE:
1277         {
1278           HV* stash;
1279           shared_sv* shared;
1280           if (items == 1)
1281             stash = CopSTASH(PL_curcop);
1282           else {
1283             SV* ssv = ST(1);
1284             STRLEN len;
1285             char *ptr;
1286             
1287             if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
1288               Perl_croak(aTHX_ "Attempt to bless into a reference");
1289             ptr = SvPV(ssv,len);
1290             if (ckWARN(WARN_MISC) && len == 0)
1291               Perl_warner(aTHX_ packWARN(WARN_MISC),
1292                           "Explicit blessing to '' (assuming package main)");
1293             stash = gv_stashpvn(ptr, len, TRUE);
1294           }
1295           SvREFCNT_inc(ref);
1296           (void)sv_bless(ref, stash);
1297           RETVAL = ref;
1298           shared = Perl_sharedsv_find(aTHX_ ref);
1299           if(shared) {
1300             dTHXc;
1301             ENTER_LOCK;
1302             SHARED_CONTEXT;
1303             {
1304               SV* fake_stash = newSVpv(HvNAME_get(stash),0);
1305               (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
1306             }
1307             CALLER_CONTEXT;
1308             LEAVE_LOCK;
1309           }
1310         }
1311         OUTPUT:
1312         RETVAL          
1313
1314 #endif /* USE_ITHREADS */
1315
1316 BOOT:
1317 {
1318 #ifdef USE_ITHREADS
1319      Perl_sharedsv_init(aTHX);
1320 #endif /* USE_ITHREADS */
1321 }
1322
1323
1324