This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Saving locks after we set it to 0 was kind of pointless.
[perl5.git] / ext / threads / shared / shared.xs
1 /*    sharedsv.c
2  *
3  *    Copyright (c) 2001, 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 #define SHARED_CONTEXT      PERL_SET_CONTEXT((aTHX = PL_sharedsv_space))
31
32 /* So we need a way to switch back to the caller's context... */
33 /* So we declare _another_ copy of the aTHX variable ... */
34 #define dTHXc PerlInterpreter *caller_perl = aTHX
35 /* and use it to switch back */
36 #define CALLER_CONTEXT      PERL_SET_CONTEXT((aTHX = caller_perl))
37
38 /*
39  * Only one thread at a time is allowed to mess with shared space.
40  */
41
42 typedef struct
43 {
44  perl_mutex              mutex;
45  PerlInterpreter        *owner;
46  I32                     locks;
47  perl_cond               cond;
48 #ifdef DEBUG_LOCKS
49  char *                  file;
50  int                     line;
51 #endif
52 } recursive_lock_t;
53
54 recursive_lock_t PL_sharedsv_lock;       /* Mutex protecting the shared sv space */
55
56 void
57 recursive_lock_init(pTHX_ recursive_lock_t *lock)
58 {
59     Zero(lock,1,recursive_lock_t);
60     MUTEX_INIT(&lock->mutex);
61     COND_INIT(&lock->cond);
62 }
63
64 void
65 recursive_lock_release(pTHX_ recursive_lock_t *lock)
66 {
67     MUTEX_LOCK(&lock->mutex);
68     if (lock->owner != aTHX) {
69         MUTEX_UNLOCK(&lock->mutex);
70     }
71     else {
72         if (--lock->locks == 0) {
73             lock->owner = NULL;
74             COND_SIGNAL(&lock->cond);
75         }
76     }
77     MUTEX_UNLOCK(&lock->mutex);
78 }
79
80 void
81 recursive_lock_acquire(pTHX_ recursive_lock_t *lock,char *file,int line)
82 {
83     assert(aTHX);
84     MUTEX_LOCK(&lock->mutex);
85     if (lock->owner == aTHX) {
86         lock->locks++;
87     }
88     else {
89         while (lock->owner) {
90 #ifdef DEBUG_LOCKS
91             Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
92                       aTHX, lock->owner, lock->file, lock->line);
93 #endif
94             COND_WAIT(&lock->cond,&lock->mutex);
95         }
96         lock->locks = 1;
97         lock->owner = aTHX;
98 #ifdef DEBUG_LOCKS
99         lock->file  = file;
100         lock->line  = line;
101 #endif
102     }
103     MUTEX_UNLOCK(&lock->mutex);
104     SAVEDESTRUCTOR_X(recursive_lock_release,lock);
105 }
106
107 #define ENTER_LOCK         STMT_START { \
108                               ENTER; \
109                               recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);   \
110                             } STMT_END
111
112 #define LEAVE_LOCK       LEAVE
113
114
115 /* A common idiom is to acquire access and switch in ... */
116 #define SHARED_EDIT         STMT_START {        \
117                                 ENTER_LOCK;     \
118                                 SHARED_CONTEXT; \
119                             } STMT_END
120
121 /* then switch out and release access. */
122 #define SHARED_RELEASE     STMT_START { \
123                                 CALLER_CONTEXT; \
124                                 LEAVE_LOCK;     \
125                             } STMT_END
126
127
128 /*
129
130   Shared SV
131
132   Shared SV is a structure for keeping the backend storage
133   of shared svs.
134
135   Shared-ness really only needs the SV * - the rest is for locks.
136   (Which suggests further space optimization ... )
137
138 */
139
140 typedef struct {
141     SV                 *sv;             /* The actual SV - in shared space */
142     recursive_lock_t    lock;
143     perl_cond           user_cond;      /* For user-level conditions */
144 } shared_sv;
145
146 /* The SV in shared-space has a back-pointer to the shared_sv
147    struct associated with it PERL_MAGIC_ext.
148
149    The vtable used has just one entry - when the SV goes away
150    we free the memory for the above.
151
152  */
153
154 int
155 sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
156 {
157     shared_sv *shared = (shared_sv *) mg->mg_ptr;
158     assert( aTHX == PL_sharedsv_space );
159     if (shared) {
160         PerlMemShared_free(shared);
161         mg->mg_ptr = NULL;
162     }
163     return 0;
164 }
165
166 MGVTBL sharedsv_shared_vtbl = {
167  0,                             /* get */
168  0,                             /* set */
169  0,                             /* len */
170  0,                             /* clear */
171  sharedsv_shared_mg_free,       /* free */
172  0,                             /* copy */
173  0,                             /* dup */
174 };
175
176 /* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */
177
178 /* In any thread that has access to a shared thing there is a "proxy"
179    for it in its own space which has 'MAGIC' associated which accesses
180    the shared thing.
181  */
182
183 MGVTBL sharedsv_scalar_vtbl;    /* scalars have this vtable */
184 MGVTBL sharedsv_array_vtbl;     /* hashes and arrays have this - like 'tie' */
185 MGVTBL sharedsv_elem_vtbl;      /* elements of hashes and arrays have this
186                                    _AS WELL AS_ the scalar magic */
187
188 /* The sharedsv_elem_vtbl associates the element with the array/hash and
189    the sharedsv_scalar_vtbl associates it with the value
190  */
191
192
193 /* Accessor to convert threads::shared::tie objects back shared_sv * */
194 shared_sv *
195 SV_to_sharedsv(pTHX_ SV *sv)
196 {
197     shared_sv *shared = 0;
198     if (SvROK(sv))
199      {
200       shared = INT2PTR(shared_sv *, SvIV(SvRV(sv)));
201      }
202     return shared;
203 }
204
205 =for apidoc sharedsv_find
206
207 Given a private side SV tries to find if the SV has a shared backend,
208 by looking for the magic.
209
210 =cut
211
212 shared_sv *
213 Perl_sharedsv_find(pTHX_ SV *sv)
214 {
215     MAGIC *mg;
216     if (SvTYPE(sv) >= SVt_PVMG) {
217         switch(SvTYPE(sv)) {
218         case SVt_PVAV:
219         case SVt_PVHV:
220             if ((mg = mg_find(sv, PERL_MAGIC_tied))
221                 && mg->mg_virtual == &sharedsv_array_vtbl) {
222                 return (shared_sv *) mg->mg_ptr;
223             }
224             break;
225         default:
226             /* This should work for elements as well as they
227              * have scalar magic as well as their element magic
228              */
229             if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
230                 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
231                 return (shared_sv *) mg->mg_ptr;
232             }
233             break;
234         }
235     }
236     /* Just for tidyness of API also handle tie objects */
237     if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
238         return SV_to_sharedsv(aTHX_ sv);
239     }
240     return NULL;
241 }
242
243 /*
244  *  Almost all the pain is in this routine.
245  *
246  */
247
248 shared_sv *
249 Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
250 {
251     dTHXc;
252     MAGIC *mg = 0;
253     SV *sv    = (psv) ? *psv : Nullsv;
254
255     /* If we are asked for an private ops we need a thread */
256     assert ( aTHX !=  PL_sharedsv_space );
257
258     /* To avoid need for recursive locks require caller to hold lock */
259     assert ( PL_sharedsv_lock.owner == aTHX );
260
261     /* First try and get existing global data structure */
262
263     /* Try shared SV as 1st choice */
264     if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
265         if (mg = mg_find(ssv, PERL_MAGIC_ext)) {
266             data = (shared_sv *) mg->mg_ptr;
267         }
268     }
269
270     /* Next see if private SV is associated with something */
271     if (!data && sv) {
272         data = Perl_sharedsv_find(aTHX_ sv);
273     }
274
275     /* If neither of those then create a new one */
276     if (!data) {
277             SHARED_CONTEXT;
278             if (!ssv)
279                 ssv = newSV(0);
280             data = PerlMemShared_malloc(sizeof(shared_sv));
281             Zero(data,1,shared_sv);
282             SHAREDSvPTR(data) = ssv;
283             /* Tag shared side SV with data pointer */
284             sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
285                    (char *)data, 0);
286             recursive_lock_init(aTHX_ &data->lock);
287             COND_INIT(&data->user_cond);
288             CALLER_CONTEXT;
289     }
290
291     if (!ssv)
292         ssv = SHAREDSvPTR(data);
293     if (!SHAREDSvPTR(data))
294         SHAREDSvPTR(data) = ssv;
295
296     /* If we know type upgrade shared side SV */
297     if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
298         SHARED_CONTEXT;
299         sv_upgrade(ssv, SvTYPE(*psv));
300         CALLER_CONTEXT;
301     }
302
303     /* Now if requested allocate private SV */
304     if (psv && !sv) {
305         *psv = sv = newSV(0);
306     }
307
308     /* Finally if private SV exists check and add magic */
309     if (sv) {
310         MAGIC *mg = 0;
311         if (SvTYPE(sv) < SvTYPE(ssv)) {
312             sv_upgrade(sv, SvTYPE(ssv));
313         }
314         switch(SvTYPE(sv)) {
315         case SVt_PVAV:
316         case SVt_PVHV:
317             if (!(mg = mg_find(sv, PERL_MAGIC_tied))
318                 || mg->mg_virtual != &sharedsv_array_vtbl
319                 || (shared_sv *) mg->mg_ptr != data) {
320                 SV *obj = newSV(0);
321                 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
322                 if (mg) {
323                     sv_unmagic(sv, PERL_MAGIC_tied);
324                 }
325                 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
326                                 (char *) data, 0);
327                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
328                 SvREFCNT_inc(ssv);
329                 SvREFCNT_dec(obj);
330             }
331             break;
332
333         default:
334             if ((SvTYPE(sv) < SVt_PVMG)
335                 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
336                 || mg->mg_virtual != &sharedsv_scalar_vtbl
337                 || (shared_sv *) mg->mg_ptr != data) {
338                 if (mg) {
339                     sv_unmagic(sv, PERL_MAGIC_shared_scalar);
340                 }
341                 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
342                                 &sharedsv_scalar_vtbl, (char *)data, 0);
343                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
344                 SvREFCNT_inc(ssv);
345             }
346             break;
347         }
348         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
349     }
350     return data;
351 }
352
353 void
354 Perl_sharedsv_free(pTHX_ shared_sv *shared)
355 {
356     if (shared) {
357         dTHXc;
358         SHARED_EDIT;
359         SvREFCNT_dec(SHAREDSvPTR(shared));
360         SHARED_RELEASE;
361     }
362 }
363
364 void
365 Perl_sharedsv_share(pTHX_ SV *sv)
366 {
367     switch(SvTYPE(sv)) {
368     case SVt_PVGV:
369         Perl_croak(aTHX_ "Cannot share globs yet");
370         break;
371
372     case SVt_PVCV:
373         Perl_croak(aTHX_ "Cannot share subs yet");
374         break;
375
376     default:
377         ENTER_LOCK;
378         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
379         LEAVE_LOCK;
380         SvSETMAGIC(sv);
381         break;
382     }
383 }
384
385 /* MAGIC (in mg.h sense) hooks */
386
387 int
388 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
389 {
390     shared_sv *shared = (shared_sv *) mg->mg_ptr;
391     assert(shared);
392
393     ENTER_LOCK;
394     if (SHAREDSvPTR(shared)) {
395         if (SvROK(SHAREDSvPTR(shared))) {
396             SV *obj = Nullsv;
397             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
398             sv_setsv_nomg(sv, &PL_sv_undef);
399             SvRV(sv) = obj;
400             SvROK_on(sv);
401         }
402         else {
403             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
404         }
405     }
406     LEAVE_LOCK;
407     return 0;
408 }
409
410 void
411 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
412 {
413     dTHXc;
414     bool allowed = TRUE;
415     if (SvROK(sv)) {
416         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
417         if (target) {
418             SV *tmp;
419             SHARED_CONTEXT;
420             tmp = newRV(SHAREDSvPTR(target));
421             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
422             SvREFCNT_dec(tmp);
423             CALLER_CONTEXT;
424         }
425         else {
426             allowed = FALSE;
427         }
428     }
429     else {
430                 SvTEMP_off(sv);
431         SHARED_CONTEXT;
432         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
433         CALLER_CONTEXT;
434     }
435     if (!allowed) {
436         Perl_croak(aTHX_ "Invalid value for shared scalar");
437     }
438 }
439
440 int
441 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
442 {
443     shared_sv *shared;
444     ENTER_LOCK;
445     /* We call associate to potentially upgrade shared side SV */
446     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
447     assert(shared);
448     sharedsv_scalar_store(aTHX_ sv, shared);
449     LEAVE_LOCK;
450     return 0;
451 }
452
453 int
454 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
455 {
456     shared_sv *shared = (shared_sv *) mg->mg_ptr;
457 #if 0
458     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
459 #endif
460     Perl_sharedsv_free(aTHX_ shared);
461     return 0;
462 }
463
464 int
465 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
466 {
467     return 0;
468 }
469
470 /*
471  * Called during cloning of new threads
472  */
473 int
474 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
475 {
476     shared_sv *shared = (shared_sv *) mg->mg_ptr;
477     if (shared) {
478         SvREFCNT_inc(SHAREDSvPTR(shared));
479     }
480     return 0;
481 }
482
483 MGVTBL sharedsv_scalar_vtbl = {
484  sharedsv_scalar_mg_get,        /* get */
485  sharedsv_scalar_mg_set,        /* set */
486  0,                             /* len */
487  sharedsv_scalar_mg_clear,      /* clear */
488  sharedsv_scalar_mg_free,       /* free */
489  0,                             /* copy */
490  sharedsv_scalar_mg_dup         /* dup */
491 };
492
493 /* Now the arrays/hashes stuff */
494 int
495 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
496 {
497     dTHXc;
498     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
499     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
500     SV** svp;
501
502     assert ( shared );
503     assert ( SHAREDSvPTR(shared) );
504
505     ENTER_LOCK;
506
507     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
508         assert ( mg->mg_ptr == 0 );
509         SHARED_CONTEXT;
510         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
511     }
512     else {
513         char *key = mg->mg_ptr;
514         STRLEN len = mg->mg_len;
515         assert ( mg->mg_ptr != 0 );
516         if (mg->mg_len == HEf_SVKEY) {
517            key = SvPV((SV *) mg->mg_ptr, len);
518         }
519         SHARED_CONTEXT;
520         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
521     }
522     CALLER_CONTEXT;
523     if (svp) {
524         /* Exists in the array */
525         target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
526         sv_setsv(sv, *svp);
527     }
528     else {
529         /* Not in the array */
530         sv_setsv(sv, &PL_sv_undef);
531     }
532     LEAVE_LOCK;
533     return 0;
534 }
535
536 int
537 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
538 {
539     dTHXc;
540     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
541     shared_sv *target;
542     SV **svp;
543     /* Theory - SV itself is magically shared - and we have ordered the
544        magic such that by the time we get here it has been stored
545        to its shared counterpart
546      */
547     ENTER_LOCK;
548     assert(shared);
549     assert(SHAREDSvPTR(shared));
550     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
551         assert ( mg->mg_ptr == 0 );
552         SHARED_CONTEXT;
553         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
554     }
555     else {
556         char *key = mg->mg_ptr;
557         STRLEN len = mg->mg_len;
558         assert ( mg->mg_ptr != 0 );
559         if (mg->mg_len == HEf_SVKEY)
560            key = SvPV((SV *) mg->mg_ptr, len);
561         SHARED_CONTEXT;
562         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
563     }
564     CALLER_CONTEXT;
565     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
566     sharedsv_scalar_store(aTHX_ sv, target);
567     LEAVE_LOCK;
568     return 0;
569 }
570
571 int
572 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
573 {
574     dTHXc;
575     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
576     ENTER_LOCK;
577     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
578     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
579         SHARED_CONTEXT;
580         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
581     }
582     else {
583         char *key = mg->mg_ptr;
584         STRLEN len = mg->mg_len;
585         assert ( mg->mg_ptr != 0 );
586         if (mg->mg_len == HEf_SVKEY)
587            key = SvPV((SV *) mg->mg_ptr, len);
588         SHARED_CONTEXT;
589         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
590     }
591     CALLER_CONTEXT;
592     LEAVE_LOCK;
593     return 0;
594 }
595
596 int
597 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
598 {
599     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
600     return 0;
601 }
602
603 int
604 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
605 {
606     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
607     SvREFCNT_inc(SHAREDSvPTR(shared));
608     mg->mg_flags |= MGf_DUP;
609     return 0;
610 }
611
612 MGVTBL sharedsv_elem_vtbl = {
613  sharedsv_elem_mg_FETCH,        /* get */
614  sharedsv_elem_mg_STORE,        /* set */
615  0,                             /* len */
616  sharedsv_elem_mg_DELETE,       /* clear */
617  sharedsv_elem_mg_free,         /* free */
618  0,                             /* copy */
619  sharedsv_elem_mg_dup           /* dup */
620 };
621
622 U32
623 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
624 {
625     dTHXc;
626     shared_sv *shared = (shared_sv *) mg->mg_ptr;
627     U32 val;
628     SHARED_EDIT;
629     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
630         val = av_len((AV*) SHAREDSvPTR(shared));
631     }
632     else {
633         /* not actually defined by tie API but ... */
634         val = HvKEYS((HV*) SHAREDSvPTR(shared));
635     }
636     SHARED_RELEASE;
637     return val;
638 }
639
640 int
641 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
642 {
643     dTHXc;
644     shared_sv *shared = (shared_sv *) mg->mg_ptr;
645     SHARED_EDIT;
646     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
647         av_clear((AV*) SHAREDSvPTR(shared));
648     }
649     else {
650         hv_clear((HV*) SHAREDSvPTR(shared));
651     }
652     SHARED_RELEASE;
653     return 0;
654 }
655
656 int
657 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
658 {
659     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
660     return 0;
661 }
662
663 /*
664  * This is called when perl is about to access an element of
665  * the array -
666  */
667 int
668 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
669                        SV *nsv, const char *name, int namlen)
670 {
671     shared_sv *shared = (shared_sv *) mg->mg_ptr;
672     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
673                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
674                             name, namlen);
675     SvREFCNT_inc(SHAREDSvPTR(shared));
676     nmg->mg_flags |= MGf_DUP;
677     return 1;
678 }
679
680 int
681 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
682 {
683     shared_sv *shared = (shared_sv *) mg->mg_ptr;
684     SvREFCNT_inc(SHAREDSvPTR(shared));
685     mg->mg_flags |= MGf_DUP;
686     return 0;
687 }
688
689 MGVTBL sharedsv_array_vtbl = {
690  0,                             /* get */
691  0,                             /* set */
692  sharedsv_array_mg_FETCHSIZE,   /* len */
693  sharedsv_array_mg_CLEAR,       /* clear */
694  sharedsv_array_mg_free,        /* free */
695  sharedsv_array_mg_copy,        /* copy */
696  sharedsv_array_mg_dup          /* dup */
697 };
698
699 =for apidoc sharedsv_unlock
700
701 Recursively unlocks a shared sv.
702
703 =cut
704
705 void
706 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
707 {
708     recursive_lock_release(aTHX_ &ssv->lock);
709 }
710
711 =for apidoc sharedsv_lock
712
713 Recursive locks on a sharedsv.
714 Locks are dynamically scoped at the level of the first lock.
715
716 =cut
717
718 void
719 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
720 {
721     if (!ssv)
722         return;
723     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
724 }
725
726 void
727 Perl_sharedsv_locksv(pTHX_ SV *sv)
728 {
729     Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv));
730 }
731
732 =head1 Shared SV Functions
733
734 =for apidoc sharedsv_init
735
736 Saves a space for keeping SVs wider than an interpreter,
737 currently only stores a pointer to the first interpreter.
738
739 =cut
740
741 void
742 Perl_sharedsv_init(pTHX)
743 {
744   dTHXc;
745   /* This pair leaves us in shared context ... */
746   PL_sharedsv_space = perl_alloc();
747   perl_construct(PL_sharedsv_space);
748   CALLER_CONTEXT;
749   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
750   PL_lockhook = &Perl_sharedsv_locksv;
751   PL_sharehook = &Perl_sharedsv_share;
752 }
753
754 #endif /* USE_ITHREADS */
755
756 MODULE = threads::shared        PACKAGE = threads::shared::tie
757
758 PROTOTYPES: DISABLE
759
760 #ifdef USE_ITHREADS
761
762 void
763 PUSH(shared_sv *shared, ...)
764 CODE:
765         dTHXc;
766         int i;
767         for(i = 1; i < items; i++) {
768             SV* tmp = newSVsv(ST(i));
769             shared_sv *target;
770             ENTER_LOCK;
771             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
772             sharedsv_scalar_store(aTHX_ tmp, target);
773             SHARED_CONTEXT;
774             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
775             SHARED_RELEASE;
776             SvREFCNT_dec(tmp);
777         }
778
779 void
780 UNSHIFT(shared_sv *shared, ...)
781 CODE:
782         dTHXc;
783         int i;
784         ENTER_LOCK;
785         SHARED_CONTEXT;
786         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
787         CALLER_CONTEXT;
788         for(i = 1; i < items; i++) {
789             SV* tmp = newSVsv(ST(i));
790             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
791             sharedsv_scalar_store(aTHX_ tmp, target);
792             SHARED_CONTEXT;
793             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
794             CALLER_CONTEXT;
795             SvREFCNT_dec(tmp);
796         }
797         LEAVE_LOCK;
798
799 void
800 POP(shared_sv *shared)
801 CODE:
802         dTHXc;
803         SV* sv;
804         ENTER_LOCK;
805         SHARED_CONTEXT;
806         sv = av_pop((AV*)SHAREDSvPTR(shared));
807         CALLER_CONTEXT;
808         ST(0) = Nullsv;
809         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
810         LEAVE_LOCK;
811         XSRETURN(1);
812
813 void
814 SHIFT(shared_sv *shared)
815 CODE:
816         dTHXc;
817         SV* sv;
818         ENTER_LOCK;
819         SHARED_CONTEXT;
820         sv = av_shift((AV*)SHAREDSvPTR(shared));
821         CALLER_CONTEXT;
822         ST(0) = Nullsv;
823         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
824         LEAVE_LOCK;
825         XSRETURN(1);
826
827 void
828 EXTEND(shared_sv *shared, IV count)
829 CODE:
830         dTHXc;
831         SHARED_EDIT;
832         av_extend((AV*)SHAREDSvPTR(shared), count);
833         SHARED_RELEASE;
834
835 void
836 STORESIZE(shared_sv *shared,IV count)
837 CODE:
838         dTHXc;
839         SHARED_EDIT;
840         av_fill((AV*) SHAREDSvPTR(shared), count);
841         SHARED_RELEASE;
842
843
844
845
846 void
847 EXISTS(shared_sv *shared, SV *index)
848 CODE:
849         dTHXc;
850         bool exists;
851         SHARED_EDIT;
852         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
853             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
854         }
855         else {
856             STRLEN len;
857             char *key = SvPV(index,len);
858             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
859         }
860         SHARED_RELEASE;
861         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
862         XSRETURN(1);
863
864
865 void
866 FIRSTKEY(shared_sv *shared)
867 CODE:
868         dTHXc;
869         char* key = NULL;
870         I32 len = 0;
871         HE* entry;
872         ENTER_LOCK;
873         SHARED_CONTEXT;
874         hv_iterinit((HV*) SHAREDSvPTR(shared));
875         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
876         if (entry) {
877                 key = hv_iterkey(entry,&len);
878                 CALLER_CONTEXT;
879                 ST(0) = sv_2mortal(newSVpv(key, len));
880         } else {
881              CALLER_CONTEXT;
882              ST(0) = &PL_sv_undef;
883         }
884         LEAVE_LOCK;
885         XSRETURN(1);
886
887 void
888 NEXTKEY(shared_sv *shared, SV *oldkey)
889 CODE:
890         dTHXc;
891         char* key = NULL;
892         I32 len = 0;
893         HE* entry;
894         ENTER_LOCK;
895         SHARED_CONTEXT;
896         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
897         if (entry) {
898                 key = hv_iterkey(entry,&len);
899                 CALLER_CONTEXT;
900                 ST(0) = sv_2mortal(newSVpv(key, len));
901         } else {
902              CALLER_CONTEXT;
903              ST(0) = &PL_sv_undef;
904         }
905         LEAVE_LOCK;
906         XSRETURN(1);
907
908 MODULE = threads::shared                PACKAGE = threads::shared
909
910 PROTOTYPES: ENABLE
911
912 void
913 _id(SV *ref)
914         PROTOTYPE: \[$@%]
915 CODE:
916         shared_sv *shared;
917         if(SvROK(ref))
918             ref = SvRV(ref);
919         if (shared = Perl_sharedsv_find(aTHX_ ref)) {
920             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
921             XSRETURN(1);
922         }
923         XSRETURN_UNDEF;
924
925
926 void
927 _refcnt(SV *ref)
928         PROTOTYPE: \[$@%]
929 CODE:
930         shared_sv *shared;
931         if(SvROK(ref))
932             ref = SvRV(ref);
933         if (shared = Perl_sharedsv_find(aTHX_ ref)) {
934           if (SHAREDSvPTR(shared)) {
935             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
936             XSRETURN(1);
937           }
938           else {
939              Perl_warn(aTHX_ "%_ s=%p has no shared SV",ST(0),shared);
940           }
941         }
942         else {
943              Perl_warn(aTHX_ "%_ is not shared",ST(0));
944         }
945         XSRETURN_UNDEF;
946
947 void
948 share(SV *ref)
949         PROTOTYPE: \[$@%]
950         CODE:
951         if(SvROK(ref))
952             ref = SvRV(ref);
953         Perl_sharedsv_share(aTHX, ref);
954
955 void
956 lock_enabled(SV *ref)
957         PROTOTYPE: \[$@%]
958         CODE:
959         shared_sv* shared;
960         if(SvROK(ref))
961             ref = SvRV(ref);
962         shared = Perl_sharedsv_find(aTHX, ref);
963         if(!shared)
964            croak("lock can only be used on shared values");
965         Perl_sharedsv_lock(aTHX_ shared);
966
967 void
968 cond_wait_enabled(SV *ref)
969         PROTOTYPE: \[$@%]
970         CODE:
971         shared_sv* shared;
972         int locks;
973         if(SvROK(ref))
974             ref = SvRV(ref);
975         shared = Perl_sharedsv_find(aTHX_ ref);
976         if(!shared)
977             croak("cond_wait can only be used on shared values");
978         if(shared->lock.owner != aTHX)
979             croak("You need a lock before you can cond_wait");
980         /* Stealing the members of the lock object worries me - NI-S */
981         MUTEX_LOCK(&shared->lock.mutex);
982         shared->lock.owner = NULL;
983         locks = shared->lock.locks;
984         shared->lock.locks = 0;
985         COND_WAIT(&shared->user_cond, &shared->lock.mutex);
986         shared->lock.owner = aTHX;
987         shared->lock.locks = locks;
988         MUTEX_UNLOCK(&shared->lock.mutex);
989
990 void
991 cond_signal_enabled(SV *ref)
992         PROTOTYPE: \[$@%]
993         CODE:
994         shared_sv* shared;
995         if(SvROK(ref))
996             ref = SvRV(ref);
997         shared = Perl_sharedsv_find(aTHX_ ref);
998         if(!shared)
999             croak("cond_signal can only be used on shared values");
1000         COND_SIGNAL(&shared->user_cond);
1001
1002 void
1003 cond_broadcast_enabled(SV *ref)
1004         PROTOTYPE: \[$@%]
1005         CODE:
1006         shared_sv* shared;
1007         if(SvROK(ref))
1008             ref = SvRV(ref);
1009         shared = Perl_sharedsv_find(aTHX_ ref);
1010         if(!shared)
1011             croak("cond_broadcast can only be used on shared values");
1012         COND_BROADCAST(&shared->user_cond);
1013
1014 #endif /* USE_ITHREADS */
1015
1016 BOOT:
1017 {
1018 #ifdef USE_ITHREADS
1019      Perl_sharedsv_init(aTHX);
1020 #endif /* USE_ITHREADS */
1021 }
1022
1023
1024