This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dd7724e805f570f0f38dc997a2be1f6ec1bac278
[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 = 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(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             }
382             break;
383         }
384         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
385     }
386     return data;
387 }
388
389 void
390 Perl_sharedsv_free(pTHX_ shared_sv *shared)
391 {
392     if (shared) {
393         dTHXc;
394         SHARED_EDIT;
395         SvREFCNT_dec(SHAREDSvPTR(shared));
396         SHARED_RELEASE;
397     }
398 }
399
400 void
401 Perl_sharedsv_share(pTHX_ SV *sv)
402 {
403     switch(SvTYPE(sv)) {
404     case SVt_PVGV:
405         Perl_croak(aTHX_ "Cannot share globs yet");
406         break;
407
408     case SVt_PVCV:
409         Perl_croak(aTHX_ "Cannot share subs yet");
410         break;
411
412     default:
413         ENTER_LOCK;
414         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
415         LEAVE_LOCK;
416         SvSETMAGIC(sv);
417         break;
418     }
419 }
420
421 /* MAGIC (in mg.h sense) hooks */
422
423 int
424 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
425 {
426     shared_sv *shared = (shared_sv *) mg->mg_ptr;
427     assert(shared);
428
429     ENTER_LOCK;
430     if (SHAREDSvPTR(shared)) {
431         if (SvROK(SHAREDSvPTR(shared))) {
432             SV *obj = Nullsv;
433             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
434             sv_setsv_nomg(sv, &PL_sv_undef);
435             SvRV(sv) = obj;
436             SvROK_on(sv);
437             
438         }
439         else {
440             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
441         }
442     }
443     LEAVE_LOCK;
444     return 0;
445 }
446
447 void
448 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
449 {
450     dTHXc;
451     bool allowed = TRUE;
452     if (SvROK(sv)) {
453         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
454         if (target) {
455             SV *tmp;
456             SHARED_CONTEXT;
457             tmp = newRV(SHAREDSvPTR(target));
458             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
459             SvREFCNT_dec(tmp);
460             if(SvOBJECT(SvRV(sv))) {
461               SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0);
462               SvOBJECT_on(SHAREDSvPTR(target));
463               SvSTASH(SHAREDSvPTR(target)) = (HV*)fake_stash;
464             }
465             CALLER_CONTEXT;
466         }
467         else {
468             allowed = FALSE;
469         }
470     }
471     else {
472         SvTEMP_off(sv);
473         SHARED_CONTEXT;
474         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
475         if(SvOBJECT(sv)) {
476           SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0);
477           SvOBJECT_on(SHAREDSvPTR(shared));
478           SvSTASH(SHAREDSvPTR(shared)) = (HV*)fake_stash;
479         }
480         CALLER_CONTEXT;
481     }
482     if (!allowed) {
483         Perl_croak(aTHX_ "Invalid value for shared scalar");
484     }
485 }
486
487 int
488 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
489 {
490     shared_sv *shared;
491     ENTER_LOCK;
492     /* We call associate to potentially upgrade shared side SV */
493     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
494     assert(shared);
495     sharedsv_scalar_store(aTHX_ sv, shared);
496     LEAVE_LOCK;
497     return 0;
498 }
499
500 int
501 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
502 {
503     shared_sv *shared = (shared_sv *) mg->mg_ptr;
504 #if 0
505     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
506 #endif
507     Perl_sharedsv_free(aTHX_ shared);
508     return 0;
509 }
510
511 int
512 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
513 {
514     return 0;
515 }
516
517 /*
518  * Called during cloning of new threads
519  */
520 int
521 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
522 {
523     shared_sv *shared = (shared_sv *) mg->mg_ptr;
524     if (shared) {
525         SvREFCNT_inc(SHAREDSvPTR(shared));
526     }
527     return 0;
528 }
529
530 MGVTBL sharedsv_scalar_vtbl = {
531  sharedsv_scalar_mg_get,        /* get */
532  sharedsv_scalar_mg_set,        /* set */
533  0,                             /* len */
534  sharedsv_scalar_mg_clear,      /* clear */
535  sharedsv_scalar_mg_free,       /* free */
536  0,                             /* copy */
537  sharedsv_scalar_mg_dup         /* dup */
538 };
539
540 /* Now the arrays/hashes stuff */
541 int
542 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
543 {
544     dTHXc;
545     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
546     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
547     SV** svp;
548
549     assert ( shared );
550     assert ( SHAREDSvPTR(shared) );
551
552     ENTER_LOCK;
553     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
554         assert ( mg->mg_ptr == 0 );
555         SHARED_CONTEXT;
556         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
557     }
558     else {
559         char *key = mg->mg_ptr;
560         STRLEN len = mg->mg_len;
561         assert ( mg->mg_ptr != 0 );
562         if (mg->mg_len == HEf_SVKEY) {
563            key = SvPV((SV *) mg->mg_ptr, len);
564         }
565         SHARED_CONTEXT;
566         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
567     }
568     CALLER_CONTEXT;
569     if (svp) {
570         /* Exists in the array */
571         target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
572         sv_setsv(sv, *svp);
573     }
574     else {
575         /* Not in the array */
576         sv_setsv(sv, &PL_sv_undef);
577     }
578     LEAVE_LOCK;
579     return 0;
580 }
581
582 int
583 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
584 {
585     dTHXc;
586     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
587     shared_sv *target;
588     SV **svp;
589     /* Theory - SV itself is magically shared - and we have ordered the
590        magic such that by the time we get here it has been stored
591        to its shared counterpart
592      */
593     ENTER_LOCK;
594     assert(shared);
595     assert(SHAREDSvPTR(shared));
596     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
597         assert ( mg->mg_ptr == 0 );
598         SHARED_CONTEXT;
599         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
600     }
601     else {
602         char *key = mg->mg_ptr;
603         STRLEN len = mg->mg_len;
604         assert ( mg->mg_ptr != 0 );
605         if (mg->mg_len == HEf_SVKEY)
606            key = SvPV((SV *) mg->mg_ptr, len);
607         SHARED_CONTEXT;
608         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
609     }
610     CALLER_CONTEXT;
611     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
612     sharedsv_scalar_store(aTHX_ sv, target);
613     LEAVE_LOCK;
614     return 0;
615 }
616
617 int
618 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
619 {
620     dTHXc;
621     MAGIC *shmg;
622     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
623     ENTER_LOCK;
624     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
625     if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
626         sharedsv_scalar_mg_get(aTHX_ sv, shmg);
627     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
628         SHARED_CONTEXT;
629         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
630     }
631     else {
632         char *key = mg->mg_ptr;
633         STRLEN len = mg->mg_len;
634         assert ( mg->mg_ptr != 0 );
635         if (mg->mg_len == HEf_SVKEY)
636            key = SvPV((SV *) mg->mg_ptr, len);
637         SHARED_CONTEXT;
638         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
639     }
640     CALLER_CONTEXT;
641     LEAVE_LOCK;
642     return 0;
643 }
644
645 int
646 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
647 {
648     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
649     return 0;
650 }
651
652 int
653 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
654 {
655     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
656     SvREFCNT_inc(SHAREDSvPTR(shared));
657     mg->mg_flags |= MGf_DUP;
658     return 0;
659 }
660
661 MGVTBL sharedsv_elem_vtbl = {
662  sharedsv_elem_mg_FETCH,        /* get */
663  sharedsv_elem_mg_STORE,        /* set */
664  0,                             /* len */
665  sharedsv_elem_mg_DELETE,       /* clear */
666  sharedsv_elem_mg_free,         /* free */
667  0,                             /* copy */
668  sharedsv_elem_mg_dup           /* dup */
669 };
670
671 U32
672 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
673 {
674     dTHXc;
675     shared_sv *shared = (shared_sv *) mg->mg_ptr;
676     U32 val;
677     SHARED_EDIT;
678     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
679         val = av_len((AV*) SHAREDSvPTR(shared));
680     }
681     else {
682         /* not actually defined by tie API but ... */
683         val = HvKEYS((HV*) SHAREDSvPTR(shared));
684     }
685     SHARED_RELEASE;
686     return val;
687 }
688
689 int
690 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
691 {
692     dTHXc;
693     shared_sv *shared = (shared_sv *) mg->mg_ptr;
694     SHARED_EDIT;
695     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
696         av_clear((AV*) SHAREDSvPTR(shared));
697     }
698     else {
699         hv_clear((HV*) SHAREDSvPTR(shared));
700     }
701     SHARED_RELEASE;
702     return 0;
703 }
704
705 int
706 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
707 {
708     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
709     return 0;
710 }
711
712 /*
713  * This is called when perl is about to access an element of
714  * the array -
715  */
716 int
717 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
718                        SV *nsv, const char *name, int namlen)
719 {
720     shared_sv *shared = (shared_sv *) mg->mg_ptr;
721     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
722                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
723                             name, namlen);
724     ENTER_LOCK;
725     SvREFCNT_inc(SHAREDSvPTR(shared));
726     LEAVE_LOCK;
727     nmg->mg_flags |= MGf_DUP;
728     return 1;
729 }
730
731 int
732 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
733 {
734     shared_sv *shared = (shared_sv *) mg->mg_ptr;
735     SvREFCNT_inc(SHAREDSvPTR(shared));
736     mg->mg_flags |= MGf_DUP;
737     return 0;
738 }
739
740 MGVTBL sharedsv_array_vtbl = {
741  0,                             /* get */
742  0,                             /* set */
743  sharedsv_array_mg_FETCHSIZE,   /* len */
744  sharedsv_array_mg_CLEAR,       /* clear */
745  sharedsv_array_mg_free,        /* free */
746  sharedsv_array_mg_copy,        /* copy */
747  sharedsv_array_mg_dup          /* dup */
748 };
749
750 =for apidoc sharedsv_unlock
751
752 Recursively unlocks a shared sv.
753
754 =cut
755
756 void
757 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
758 {
759     recursive_lock_release(aTHX_ &ssv->lock);
760 }
761
762 =for apidoc sharedsv_lock
763
764 Recursive locks on a sharedsv.
765 Locks are dynamically scoped at the level of the first lock.
766
767 =cut
768
769 void
770 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
771 {
772     if (!ssv)
773         return;
774     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
775 }
776
777 /* handles calls from lock() builtin via PL_lockhook */
778
779 void
780 Perl_sharedsv_locksv(pTHX_ SV *sv)
781 {
782     shared_sv* shared;
783
784     if(SvROK(sv))
785         sv = SvRV(sv);
786     shared = Perl_sharedsv_find(aTHX_ sv);
787     if(!shared)
788        croak("lock can only be used on shared values");
789     Perl_sharedsv_lock(aTHX_ shared);
790 }
791
792 =head1 Shared SV Functions
793
794 =for apidoc sharedsv_init
795
796 Saves a space for keeping SVs wider than an interpreter,
797
798 =cut
799
800 void
801 Perl_sharedsv_init(pTHX)
802 {
803   dTHXc;
804   /* This pair leaves us in shared context ... */
805   PL_sharedsv_space = perl_alloc();
806   perl_construct(PL_sharedsv_space);
807   CALLER_CONTEXT;
808   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
809   PL_lockhook = &Perl_sharedsv_locksv;
810   PL_sharehook = &Perl_sharedsv_share;
811 }
812
813 #endif /* USE_ITHREADS */
814
815 MODULE = threads::shared        PACKAGE = threads::shared::tie
816
817 PROTOTYPES: DISABLE
818
819 #ifdef USE_ITHREADS
820
821 void
822 PUSH(shared_sv *shared, ...)
823 CODE:
824         dTHXc;
825         int i;
826         for(i = 1; i < items; i++) {
827             SV* tmp = newSVsv(ST(i));
828             shared_sv *target;
829             ENTER_LOCK;
830             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
831             sharedsv_scalar_store(aTHX_ tmp, target);
832             SHARED_CONTEXT;
833             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
834             SvREFCNT_inc(SHAREDSvPTR(target));
835             SHARED_RELEASE;
836             SvREFCNT_dec(tmp);
837         }
838
839 void
840 UNSHIFT(shared_sv *shared, ...)
841 CODE:
842         dTHXc;
843         int i;
844         ENTER_LOCK;
845         SHARED_CONTEXT;
846         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
847         CALLER_CONTEXT;
848         for(i = 1; i < items; i++) {
849             SV* tmp = newSVsv(ST(i));
850             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
851             sharedsv_scalar_store(aTHX_ tmp, target);
852             SHARED_CONTEXT;
853             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
854             SvREFCNT_inc(SHAREDSvPTR(target));
855             CALLER_CONTEXT;
856             SvREFCNT_dec(tmp);
857         }
858         LEAVE_LOCK;
859
860 void
861 POP(shared_sv *shared)
862 CODE:
863         dTHXc;
864         SV* sv;
865         ENTER_LOCK;
866         SHARED_CONTEXT;
867         sv = av_pop((AV*)SHAREDSvPTR(shared));
868         CALLER_CONTEXT;
869         ST(0) = sv_newmortal();
870         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
871         SvREFCNT_dec(sv);
872         LEAVE_LOCK;
873         XSRETURN(1);
874
875 void
876 SHIFT(shared_sv *shared)
877 CODE:
878         dTHXc;
879         SV* sv;
880         ENTER_LOCK;
881         SHARED_CONTEXT;
882         sv = av_shift((AV*)SHAREDSvPTR(shared));
883         CALLER_CONTEXT;
884         ST(0) = sv_newmortal();
885         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
886         SvREFCNT_dec(sv);
887         LEAVE_LOCK;
888         XSRETURN(1);
889
890 void
891 EXTEND(shared_sv *shared, IV count)
892 CODE:
893         dTHXc;
894         SHARED_EDIT;
895         av_extend((AV*)SHAREDSvPTR(shared), count);
896         SHARED_RELEASE;
897
898 void
899 STORESIZE(shared_sv *shared,IV count)
900 CODE:
901         dTHXc;
902         SHARED_EDIT;
903         av_fill((AV*) SHAREDSvPTR(shared), count);
904         SHARED_RELEASE;
905
906
907
908
909 void
910 EXISTS(shared_sv *shared, SV *index)
911 CODE:
912         dTHXc;
913         bool exists;
914         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
915             SHARED_EDIT;
916             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
917         }
918         else {
919             STRLEN len;
920             char *key = SvPV(index,len);
921             SHARED_EDIT;
922             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
923         }
924         SHARED_RELEASE;
925         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
926         XSRETURN(1);
927
928
929 void
930 FIRSTKEY(shared_sv *shared)
931 CODE:
932         dTHXc;
933         char* key = NULL;
934         I32 len = 0;
935         HE* entry;
936         ENTER_LOCK;
937         SHARED_CONTEXT;
938         hv_iterinit((HV*) SHAREDSvPTR(shared));
939         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
940         if (entry) {
941                 key = hv_iterkey(entry,&len);
942                 CALLER_CONTEXT;
943                 ST(0) = sv_2mortal(newSVpv(key, len));
944         } else {
945              CALLER_CONTEXT;
946              ST(0) = &PL_sv_undef;
947         }
948         LEAVE_LOCK;
949         XSRETURN(1);
950
951 void
952 NEXTKEY(shared_sv *shared, SV *oldkey)
953 CODE:
954         dTHXc;
955         char* key = NULL;
956         I32 len = 0;
957         HE* entry;
958         ENTER_LOCK;
959         SHARED_CONTEXT;
960         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
961         if (entry) {
962                 key = hv_iterkey(entry,&len);
963                 CALLER_CONTEXT;
964                 ST(0) = sv_2mortal(newSVpv(key, len));
965         } else {
966              CALLER_CONTEXT;
967              ST(0) = &PL_sv_undef;
968         }
969         LEAVE_LOCK;
970         XSRETURN(1);
971
972 MODULE = threads::shared                PACKAGE = threads::shared
973
974 PROTOTYPES: ENABLE
975
976 void
977 _id(SV *ref)
978         PROTOTYPE: \[$@%]
979 CODE:
980         shared_sv *shared;
981         ref = SvRV(ref);
982         if(SvROK(ref))
983             ref = SvRV(ref);
984         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
985             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
986             XSRETURN(1);
987         }
988         XSRETURN_UNDEF;
989
990
991 void
992 _refcnt(SV *ref)
993         PROTOTYPE: \[$@%]
994 CODE:
995         shared_sv *shared;
996         ref = SvRV(ref);
997         if(SvROK(ref))
998             ref = SvRV(ref);
999         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1000           if (SHAREDSvPTR(shared)) {
1001             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
1002             XSRETURN(1);
1003           }
1004           else {
1005              Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
1006           }
1007         }
1008         else {
1009              Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
1010         }
1011         XSRETURN_UNDEF;
1012
1013 SV*
1014 share(SV *ref)
1015         PROTOTYPE: \[$@%]
1016         CODE:
1017         if(!SvROK(ref))
1018             Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
1019         ref = SvRV(ref);
1020         if(SvROK(ref))
1021             ref = SvRV(ref);
1022         Perl_sharedsv_share(aTHX_ ref);
1023         RETVAL = newRV(ref);
1024         OUTPUT:
1025         RETVAL
1026
1027 void
1028 lock_enabled(SV *ref)
1029         PROTOTYPE: \[$@%]
1030         CODE:
1031         shared_sv* shared;
1032         if(!SvROK(ref))
1033             Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
1034         ref = SvRV(ref);
1035         if(SvROK(ref))
1036             ref = SvRV(ref);
1037         shared = Perl_sharedsv_find(aTHX_ ref);
1038         if(!shared)
1039            croak("lock can only be used on shared values");
1040         Perl_sharedsv_lock(aTHX_ shared);
1041
1042 void
1043 cond_wait_enabled(SV *ref)
1044         PROTOTYPE: \[$@%]
1045         CODE:
1046         shared_sv* shared;
1047         int locks;
1048         if(!SvROK(ref))
1049             Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
1050         ref = SvRV(ref);
1051         if(SvROK(ref))
1052             ref = SvRV(ref);
1053         shared = Perl_sharedsv_find(aTHX_ ref);
1054         if(!shared)
1055             croak("cond_wait can only be used on shared values");
1056         if(shared->lock.owner != aTHX)
1057             croak("You need a lock before you can cond_wait");
1058         /* Stealing the members of the lock object worries me - NI-S */
1059         MUTEX_LOCK(&shared->lock.mutex);
1060         shared->lock.owner = NULL;
1061         locks = shared->lock.locks;
1062         shared->lock.locks = 0;
1063
1064         /* since we are releasing the lock here we need to tell other
1065         people that is ok to go ahead and use it */
1066         COND_SIGNAL(&shared->lock.cond);
1067         COND_WAIT(&shared->user_cond, &shared->lock.mutex);
1068         while(shared->lock.owner != NULL) {
1069                 COND_WAIT(&shared->lock.cond,&shared->lock.mutex);
1070         }       
1071         shared->lock.owner = aTHX;
1072         shared->lock.locks = locks;
1073         MUTEX_UNLOCK(&shared->lock.mutex);
1074
1075 void
1076 cond_signal_enabled(SV *ref)
1077         PROTOTYPE: \[$@%]
1078         CODE:
1079         shared_sv* shared;
1080         if(!SvROK(ref))
1081             Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
1082         ref = SvRV(ref);
1083         if(SvROK(ref))
1084             ref = SvRV(ref);
1085         shared = Perl_sharedsv_find(aTHX_ ref);
1086         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1087             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1088                             "cond_signal() called on unlocked variable");
1089         if(!shared)
1090             croak("cond_signal can only be used on shared values");
1091         COND_SIGNAL(&shared->user_cond);
1092
1093 void
1094 cond_broadcast_enabled(SV *ref)
1095         PROTOTYPE: \[$@%]
1096         CODE:
1097         shared_sv* shared;
1098         if(!SvROK(ref))
1099             Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
1100         ref = SvRV(ref);
1101         if(SvROK(ref))
1102             ref = SvRV(ref);
1103         shared = Perl_sharedsv_find(aTHX_ ref);
1104         if(!shared)
1105             croak("cond_broadcast can only be used on shared values");
1106         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1107             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1108                             "cond_broadcast() called on unlocked variable");
1109         COND_BROADCAST(&shared->user_cond);
1110
1111
1112 SV*
1113 bless(SV* ref, ...);
1114         PROTOTYPE: $;$
1115         CODE:
1116         {
1117           HV* stash;
1118           shared_sv* shared;
1119           if (items == 1)
1120             stash = CopSTASH(PL_curcop);
1121           else {
1122             SV* ssv = ST(1);
1123             STRLEN len;
1124             char *ptr;
1125             
1126             if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
1127               Perl_croak(aTHX_ "Attempt to bless into a reference");
1128             ptr = SvPV(ssv,len);
1129             if (ckWARN(WARN_MISC) && len == 0)
1130               Perl_warner(aTHX_ packWARN(WARN_MISC),
1131                           "Explicit blessing to '' (assuming package main)");
1132             stash = gv_stashpvn(ptr, len, TRUE);
1133           }
1134           SvREFCNT_inc(ref);
1135           (void)sv_bless(ref, stash);
1136           RETVAL = ref;
1137           shared = Perl_sharedsv_find(aTHX_ ref);
1138           if(shared) {
1139             dTHXc;
1140             ENTER_LOCK;
1141             SHARED_CONTEXT;
1142             {
1143               SV* fake_stash = newSVpv(HvNAME(stash),0);
1144               (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
1145             }
1146             CALLER_CONTEXT;
1147             LEAVE_LOCK;
1148           }
1149         }
1150         OUTPUT:
1151         RETVAL          
1152
1153 #endif /* USE_ITHREADS */
1154
1155 BOOT:
1156 {
1157 #ifdef USE_ITHREADS
1158      Perl_sharedsv_init(aTHX);
1159 #endif /* USE_ITHREADS */
1160 }
1161
1162
1163