This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
When we copy things out of a hash and increment the
[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             data = PerlMemShared_malloc(sizeof(shared_sv));
281             Zero(data,1,shared_sv);
282             SHAREDSvPTR(data) = ssv;
283             /* Tag shared side SV with data pointer */
284             sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
285                    (char *)data, 0);
286             recursive_lock_init(aTHX_ &data->lock);
287             COND_INIT(&data->user_cond);
288             CALLER_CONTEXT;
289     }
290
291     if (!ssv)
292         ssv = SHAREDSvPTR(data);
293     if (!SHAREDSvPTR(data))
294         SHAREDSvPTR(data) = ssv;
295
296     /* If we know type upgrade shared side SV */
297     if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
298         SHARED_CONTEXT;
299         sv_upgrade(ssv, SvTYPE(*psv));
300         CALLER_CONTEXT;
301     }
302
303     /* Now if requested allocate private SV */
304     if (psv && !sv) {
305         *psv = sv = newSV(0);
306     }
307
308     /* Finally if private SV exists check and add magic */
309     if (sv) {
310         MAGIC *mg = 0;
311         if (SvTYPE(sv) < SvTYPE(ssv)) {
312             sv_upgrade(sv, SvTYPE(ssv));
313         }
314         switch(SvTYPE(sv)) {
315         case SVt_PVAV:
316         case SVt_PVHV:
317             if (!(mg = mg_find(sv, PERL_MAGIC_tied))
318                 || mg->mg_virtual != &sharedsv_array_vtbl
319                 || (shared_sv *) mg->mg_ptr != data) {
320                 SV *obj = newSV(0);
321                 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
322                 if (mg) {
323                     sv_unmagic(sv, PERL_MAGIC_tied);
324                 }
325                 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
326                                 (char *) data, 0);
327                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
328                 SvREFCNT_inc(ssv);
329                 SvREFCNT_dec(obj);
330             }
331             break;
332
333         default:
334             if ((SvTYPE(sv) < SVt_PVMG)
335                 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
336                 || mg->mg_virtual != &sharedsv_scalar_vtbl
337                 || (shared_sv *) mg->mg_ptr != data) {
338                 if (mg) {
339                     sv_unmagic(sv, PERL_MAGIC_shared_scalar);
340                 }
341                 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
342                                 &sharedsv_scalar_vtbl, (char *)data, 0);
343                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
344                 SvREFCNT_inc(ssv);
345             }
346             break;
347         }
348         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
349     }
350     return data;
351 }
352
353 void
354 Perl_sharedsv_free(pTHX_ shared_sv *shared)
355 {
356     if (shared) {
357         dTHXc;
358         SHARED_EDIT;
359         SvREFCNT_dec(SHAREDSvPTR(shared));
360         SHARED_RELEASE;
361     }
362 }
363
364 void
365 Perl_sharedsv_share(pTHX_ SV *sv)
366 {
367     switch(SvTYPE(sv)) {
368     case SVt_PVGV:
369         Perl_croak(aTHX_ "Cannot share globs yet");
370         break;
371
372     case SVt_PVCV:
373         Perl_croak(aTHX_ "Cannot share subs yet");
374         break;
375
376     default:
377         ENTER_LOCK;
378         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
379         LEAVE_LOCK;
380         SvSETMAGIC(sv);
381         break;
382     }
383 }
384
385 /* MAGIC (in mg.h sense) hooks */
386
387 int
388 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
389 {
390     shared_sv *shared = (shared_sv *) mg->mg_ptr;
391     assert(shared);
392
393     ENTER_LOCK;
394     if (SHAREDSvPTR(shared)) {
395         if (SvROK(SHAREDSvPTR(shared))) {
396             SV *obj = Nullsv;
397             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
398             sv_setsv_nomg(sv, &PL_sv_undef);
399             SvRV(sv) = obj;
400             SvROK_on(sv);
401         }
402         else {
403             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
404         }
405     }
406     LEAVE_LOCK;
407     return 0;
408 }
409
410 void
411 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
412 {
413     dTHXc;
414     bool allowed = TRUE;
415     if (SvROK(sv)) {
416         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
417         if (target) {
418             SV *tmp;
419             SHARED_CONTEXT;
420             tmp = newRV(SHAREDSvPTR(target));
421             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
422             SvREFCNT_dec(tmp);
423             CALLER_CONTEXT;
424         }
425         else {
426             allowed = FALSE;
427         }
428     }
429     else {
430                 SvTEMP_off(sv);
431         SHARED_CONTEXT;
432         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
433         CALLER_CONTEXT;
434     }
435     if (!allowed) {
436         Perl_croak(aTHX_ "Invalid value for shared scalar");
437     }
438 }
439
440 int
441 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
442 {
443     shared_sv *shared;
444     ENTER_LOCK;
445     /* We call associate to potentially upgrade shared side SV */
446     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
447     assert(shared);
448     sharedsv_scalar_store(aTHX_ sv, shared);
449     LEAVE_LOCK;
450     return 0;
451 }
452
453 int
454 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
455 {
456     shared_sv *shared = (shared_sv *) mg->mg_ptr;
457 #if 0
458     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
459 #endif
460     Perl_sharedsv_free(aTHX_ shared);
461     return 0;
462 }
463
464 int
465 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
466 {
467     return 0;
468 }
469
470 /*
471  * Called during cloning of new threads
472  */
473 int
474 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
475 {
476     shared_sv *shared = (shared_sv *) mg->mg_ptr;
477     if (shared) {
478         SvREFCNT_inc(SHAREDSvPTR(shared));
479     }
480     return 0;
481 }
482
483 MGVTBL sharedsv_scalar_vtbl = {
484  sharedsv_scalar_mg_get,        /* get */
485  sharedsv_scalar_mg_set,        /* set */
486  0,                             /* len */
487  sharedsv_scalar_mg_clear,      /* clear */
488  sharedsv_scalar_mg_free,       /* free */
489  0,                             /* copy */
490  sharedsv_scalar_mg_dup         /* dup */
491 };
492
493 /* Now the arrays/hashes stuff */
494 int
495 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
496 {
497     dTHXc;
498     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
499     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
500     SV** svp;
501
502     assert ( shared );
503     assert ( SHAREDSvPTR(shared) );
504
505     ENTER_LOCK;
506
507     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
508         assert ( mg->mg_ptr == 0 );
509         SHARED_CONTEXT;
510         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
511     }
512     else {
513         char *key = mg->mg_ptr;
514         STRLEN len = mg->mg_len;
515         assert ( mg->mg_ptr != 0 );
516         if (mg->mg_len == HEf_SVKEY) {
517            key = SvPV((SV *) mg->mg_ptr, len);
518         }
519         SHARED_CONTEXT;
520         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
521     }
522     CALLER_CONTEXT;
523     if (svp) {
524         /* Exists in the array */
525         target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
526         sv_setsv(sv, *svp);
527     }
528     else {
529         /* Not in the array */
530         sv_setsv(sv, &PL_sv_undef);
531     }
532     LEAVE_LOCK;
533     return 0;
534 }
535
536 int
537 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
538 {
539     dTHXc;
540     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
541     shared_sv *target;
542     SV **svp;
543     /* Theory - SV itself is magically shared - and we have ordered the
544        magic such that by the time we get here it has been stored
545        to its shared counterpart
546      */
547     ENTER_LOCK;
548     assert(shared);
549     assert(SHAREDSvPTR(shared));
550     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
551         assert ( mg->mg_ptr == 0 );
552         SHARED_CONTEXT;
553         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
554     }
555     else {
556         char *key = mg->mg_ptr;
557         STRLEN len = mg->mg_len;
558         assert ( mg->mg_ptr != 0 );
559         if (mg->mg_len == HEf_SVKEY)
560            key = SvPV((SV *) mg->mg_ptr, len);
561         SHARED_CONTEXT;
562         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
563     }
564     CALLER_CONTEXT;
565     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
566     sharedsv_scalar_store(aTHX_ sv, target);
567     LEAVE_LOCK;
568     return 0;
569 }
570
571 int
572 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
573 {
574     dTHXc;
575     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
576     ENTER_LOCK;
577     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
578     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
579         SHARED_CONTEXT;
580         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
581     }
582     else {
583         char *key = mg->mg_ptr;
584         STRLEN len = mg->mg_len;
585         assert ( mg->mg_ptr != 0 );
586         if (mg->mg_len == HEf_SVKEY)
587            key = SvPV((SV *) mg->mg_ptr, len);
588         SHARED_CONTEXT;
589         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
590     }
591     CALLER_CONTEXT;
592     LEAVE_LOCK;
593     return 0;
594 }
595
596 int
597 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
598 {
599     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
600     return 0;
601 }
602
603 int
604 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
605 {
606     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
607     SvREFCNT_inc(SHAREDSvPTR(shared));
608     mg->mg_flags |= MGf_DUP;
609     return 0;
610 }
611
612 MGVTBL sharedsv_elem_vtbl = {
613  sharedsv_elem_mg_FETCH,        /* get */
614  sharedsv_elem_mg_STORE,        /* set */
615  0,                             /* len */
616  sharedsv_elem_mg_DELETE,       /* clear */
617  sharedsv_elem_mg_free,         /* free */
618  0,                             /* copy */
619  sharedsv_elem_mg_dup           /* dup */
620 };
621
622 U32
623 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
624 {
625     dTHXc;
626     shared_sv *shared = (shared_sv *) mg->mg_ptr;
627     U32 val;
628     SHARED_EDIT;
629     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
630         val = av_len((AV*) SHAREDSvPTR(shared));
631     }
632     else {
633         /* not actually defined by tie API but ... */
634         val = HvKEYS((HV*) SHAREDSvPTR(shared));
635     }
636     SHARED_RELEASE;
637     return val;
638 }
639
640 int
641 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
642 {
643     dTHXc;
644     shared_sv *shared = (shared_sv *) mg->mg_ptr;
645     SHARED_EDIT;
646     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
647         av_clear((AV*) SHAREDSvPTR(shared));
648     }
649     else {
650         hv_clear((HV*) SHAREDSvPTR(shared));
651     }
652     SHARED_RELEASE;
653     return 0;
654 }
655
656 int
657 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
658 {
659     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
660     return 0;
661 }
662
663 /*
664  * This is called when perl is about to access an element of
665  * the array -
666  */
667 int
668 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
669                        SV *nsv, const char *name, int namlen)
670 {
671     shared_sv *shared = (shared_sv *) mg->mg_ptr;
672     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
673                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
674                             name, namlen);
675     ENTER_LOCK;
676     SvREFCNT_inc(SHAREDSvPTR(shared));
677     LEAVE_LOCK;
678     nmg->mg_flags |= MGf_DUP;
679     return 1;
680 }
681
682 int
683 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
684 {
685     shared_sv *shared = (shared_sv *) mg->mg_ptr;
686     SvREFCNT_inc(SHAREDSvPTR(shared));
687     mg->mg_flags |= MGf_DUP;
688     return 0;
689 }
690
691 MGVTBL sharedsv_array_vtbl = {
692  0,                             /* get */
693  0,                             /* set */
694  sharedsv_array_mg_FETCHSIZE,   /* len */
695  sharedsv_array_mg_CLEAR,       /* clear */
696  sharedsv_array_mg_free,        /* free */
697  sharedsv_array_mg_copy,        /* copy */
698  sharedsv_array_mg_dup          /* dup */
699 };
700
701 =for apidoc sharedsv_unlock
702
703 Recursively unlocks a shared sv.
704
705 =cut
706
707 void
708 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
709 {
710     recursive_lock_release(aTHX_ &ssv->lock);
711 }
712
713 =for apidoc sharedsv_lock
714
715 Recursive locks on a sharedsv.
716 Locks are dynamically scoped at the level of the first lock.
717
718 =cut
719
720 void
721 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
722 {
723     if (!ssv)
724         return;
725     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
726 }
727
728 /* handles calls from lock() builtin via PL_lockhook */
729
730 void
731 Perl_sharedsv_locksv(pTHX_ SV *sv)
732 {
733     shared_sv* shared;
734
735     if(SvROK(sv))
736         sv = SvRV(sv);
737     shared = Perl_sharedsv_find(aTHX_ sv);
738     if(!shared)
739        croak("lock can only be used on shared values");
740     Perl_sharedsv_lock(aTHX_ shared);
741 }
742
743 =head1 Shared SV Functions
744
745 =for apidoc sharedsv_init
746
747 Saves a space for keeping SVs wider than an interpreter,
748
749 =cut
750
751 void
752 Perl_sharedsv_init(pTHX)
753 {
754   dTHXc;
755   /* This pair leaves us in shared context ... */
756   PL_sharedsv_space = perl_alloc();
757   perl_construct(PL_sharedsv_space);
758   CALLER_CONTEXT;
759   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
760   PL_lockhook = &Perl_sharedsv_locksv;
761   PL_sharehook = &Perl_sharedsv_share;
762 }
763
764 #endif /* USE_ITHREADS */
765
766 MODULE = threads::shared        PACKAGE = threads::shared::tie
767
768 PROTOTYPES: DISABLE
769
770 #ifdef USE_ITHREADS
771
772 void
773 PUSH(shared_sv *shared, ...)
774 CODE:
775         dTHXc;
776         int i;
777         for(i = 1; i < items; i++) {
778             SV* tmp = newSVsv(ST(i));
779             shared_sv *target;
780             ENTER_LOCK;
781             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
782             sharedsv_scalar_store(aTHX_ tmp, target);
783             SHARED_CONTEXT;
784             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
785             SHARED_RELEASE;
786             SvREFCNT_dec(tmp);
787         }
788
789 void
790 UNSHIFT(shared_sv *shared, ...)
791 CODE:
792         dTHXc;
793         int i;
794         ENTER_LOCK;
795         SHARED_CONTEXT;
796         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
797         CALLER_CONTEXT;
798         for(i = 1; i < items; i++) {
799             SV* tmp = newSVsv(ST(i));
800             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
801             sharedsv_scalar_store(aTHX_ tmp, target);
802             SHARED_CONTEXT;
803             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
804             CALLER_CONTEXT;
805             SvREFCNT_dec(tmp);
806         }
807         LEAVE_LOCK;
808
809 void
810 POP(shared_sv *shared)
811 CODE:
812         dTHXc;
813         SV* sv;
814         ENTER_LOCK;
815         SHARED_CONTEXT;
816         sv = av_pop((AV*)SHAREDSvPTR(shared));
817         CALLER_CONTEXT;
818         ST(0) = sv_newmortal();
819         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
820         SvREFCNT_dec(sv);
821         LEAVE_LOCK;
822         XSRETURN(1);
823
824 void
825 SHIFT(shared_sv *shared)
826 CODE:
827         dTHXc;
828         SV* sv;
829         ENTER_LOCK;
830         SHARED_CONTEXT;
831         sv = av_shift((AV*)SHAREDSvPTR(shared));
832         CALLER_CONTEXT;
833         ST(0) = sv_newmortal();
834         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
835         SvREFCNT_dec(sv);
836         LEAVE_LOCK;
837         XSRETURN(1);
838
839 void
840 EXTEND(shared_sv *shared, IV count)
841 CODE:
842         dTHXc;
843         SHARED_EDIT;
844         av_extend((AV*)SHAREDSvPTR(shared), count);
845         SHARED_RELEASE;
846
847 void
848 STORESIZE(shared_sv *shared,IV count)
849 CODE:
850         dTHXc;
851         SHARED_EDIT;
852         av_fill((AV*) SHAREDSvPTR(shared), count);
853         SHARED_RELEASE;
854
855
856
857
858 void
859 EXISTS(shared_sv *shared, SV *index)
860 CODE:
861         dTHXc;
862         bool exists;
863         SHARED_EDIT;
864         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
865             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
866         }
867         else {
868             STRLEN len;
869             char *key = SvPV(index,len);
870             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
871         }
872         SHARED_RELEASE;
873         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
874         XSRETURN(1);
875
876
877 void
878 FIRSTKEY(shared_sv *shared)
879 CODE:
880         dTHXc;
881         char* key = NULL;
882         I32 len = 0;
883         HE* entry;
884         ENTER_LOCK;
885         SHARED_CONTEXT;
886         hv_iterinit((HV*) SHAREDSvPTR(shared));
887         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
888         if (entry) {
889                 key = hv_iterkey(entry,&len);
890                 CALLER_CONTEXT;
891                 ST(0) = sv_2mortal(newSVpv(key, len));
892         } else {
893              CALLER_CONTEXT;
894              ST(0) = &PL_sv_undef;
895         }
896         LEAVE_LOCK;
897         XSRETURN(1);
898
899 void
900 NEXTKEY(shared_sv *shared, SV *oldkey)
901 CODE:
902         dTHXc;
903         char* key = NULL;
904         I32 len = 0;
905         HE* entry;
906         ENTER_LOCK;
907         SHARED_CONTEXT;
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 MODULE = threads::shared                PACKAGE = threads::shared
921
922 PROTOTYPES: ENABLE
923
924 void
925 _id(SV *ref)
926         PROTOTYPE: \[$@%]
927 CODE:
928         shared_sv *shared;
929         ref = SvRV(ref);
930         if(SvROK(ref))
931             ref = SvRV(ref);
932         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
933             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
934             XSRETURN(1);
935         }
936         XSRETURN_UNDEF;
937
938
939 void
940 _refcnt(SV *ref)
941         PROTOTYPE: \[$@%]
942 CODE:
943         shared_sv *shared;
944         ref = SvRV(ref);
945         if(SvROK(ref))
946             ref = SvRV(ref);
947         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
948           if (SHAREDSvPTR(shared)) {
949             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
950             XSRETURN(1);
951           }
952           else {
953              Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
954           }
955         }
956         else {
957              Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
958         }
959         XSRETURN_UNDEF;
960
961 SV*
962 share(SV *ref)
963         PROTOTYPE: \[$@%]
964         CODE:
965         ref = SvRV(ref);
966         if(SvROK(ref))
967             ref = SvRV(ref);
968         Perl_sharedsv_share(aTHX_ ref);
969         RETVAL = newRV(ref);
970         OUTPUT:
971         RETVAL
972
973 void
974 lock_enabled(SV *ref)
975         PROTOTYPE: \[$@%]
976         CODE:
977         shared_sv* shared;
978         ref = SvRV(ref);
979         if(SvROK(ref))
980             ref = SvRV(ref);
981         shared = Perl_sharedsv_find(aTHX_ ref);
982         if(!shared)
983            croak("lock can only be used on shared values");
984         Perl_sharedsv_lock(aTHX_ shared);
985
986 void
987 cond_wait_enabled(SV *ref)
988         PROTOTYPE: \[$@%]
989         CODE:
990         shared_sv* shared;
991         int locks;
992         ref = SvRV(ref);
993         if(SvROK(ref))
994             ref = SvRV(ref);
995         shared = Perl_sharedsv_find(aTHX_ ref);
996         if(!shared)
997             croak("cond_wait can only be used on shared values");
998         if(shared->lock.owner != aTHX)
999             croak("You need a lock before you can cond_wait");
1000         /* Stealing the members of the lock object worries me - NI-S */
1001         MUTEX_LOCK(&shared->lock.mutex);
1002         shared->lock.owner = NULL;
1003         locks = shared->lock.locks;
1004         shared->lock.locks = 0;
1005
1006         /* since we are releasing the lock here we need to tell other
1007         people that is ok to go ahead and use it */
1008         COND_SIGNAL(&shared->lock.cond);
1009         COND_WAIT(&shared->user_cond, &shared->lock.mutex);
1010         while(shared->lock.owner != NULL) {
1011                 COND_WAIT(&shared->lock.cond,&shared->lock.mutex);
1012         }       
1013         shared->lock.owner = aTHX;
1014         shared->lock.locks = locks;
1015         MUTEX_UNLOCK(&shared->lock.mutex);
1016
1017 void
1018 cond_signal_enabled(SV *ref)
1019         PROTOTYPE: \[$@%]
1020         CODE:
1021         shared_sv* shared;
1022         ref = SvRV(ref);
1023         if(SvROK(ref))
1024             ref = SvRV(ref);
1025         shared = Perl_sharedsv_find(aTHX_ ref);
1026         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1027             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1028                             "cond_signal() called on unlocked variable");
1029         if(!shared)
1030             croak("cond_signal can only be used on shared values");
1031         COND_SIGNAL(&shared->user_cond);
1032
1033 void
1034 cond_broadcast_enabled(SV *ref)
1035         PROTOTYPE: \[$@%]
1036         CODE:
1037         shared_sv* shared;
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_broadcast can only be used on shared values");
1044         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1045             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1046                             "cond_broadcast() called on unlocked variable");
1047         COND_BROADCAST(&shared->user_cond);
1048
1049 #endif /* USE_ITHREADS */
1050
1051 BOOT:
1052 {
1053 #ifdef USE_ITHREADS
1054      Perl_sharedsv_init(aTHX);
1055 #endif /* USE_ITHREADS */
1056 }
1057
1058
1059