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