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