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