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