This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Nearly-working threads re-structuring. Do not integrate,
[perl5.git] / ext / threads / shared / shared.xs
1 /*    sharedsv.c
2  *
3  *    Copyright (c) 2001, 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  */
9
10 /*
11 * Contributed by Arthur Bergman arthur@contiller.se
12 *
13 * "Hand any two wizards a piece of rope and they would instinctively pull in
14 * opposite directions."
15 *                         --Sourcery
16 *
17 */
18
19 #define PERL_NO_GET_CONTEXT
20 #include "EXTERN.h"
21 #include "perl.h"
22 #include "XSUB.h"
23
24 PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
25 perl_mutex       PL_sharedsv_space_mutex;       /* Mutex protecting the shared sv space */
26
27 typedef struct {
28     SV                 *sv;             /* The actual SV */
29     perl_mutex          mutex;          /* Our mutex */
30     perl_cond           cond;           /* Our condition variable */
31     perl_cond           user_cond;      /* For user-level conditions */
32     IV                  locks;          /* Number of locks held */
33     PerlInterpreter    *owner;          /* Who owns the lock? */
34     U16                 index;          /* Update index */
35 } shared_sv;
36
37 #define SHAREDSvGET(a)      (a->sv)
38 #define SHAREDSvLOCK(a)     Perl_sharedsv_lock(aTHX_ a)
39 #define SHAREDSvUNLOCK(a)   Perl_sharedsv_unlock(aTHX_ a)
40
41 #define SHAREDSvEDIT(a)     STMT_START {                                \
42                                 MUTEX_LOCK(&PL_sharedsv_space_mutex);   \
43                                 SHAREDSvLOCK((a));                      \
44                                 PERL_SET_CONTEXT(PL_sharedsv_space);    \
45                             } STMT_END
46
47 #define SHAREDSvRELEASE(a)  STMT_START {                                \
48                                 PERL_SET_CONTEXT((a)->owner);           \
49                                 SHAREDSvUNLOCK((a));                    \
50                                 MUTEX_UNLOCK(&PL_sharedsv_space_mutex); \
51                             } STMT_END
52
53 extern void     Perl_sharedsv_init(pTHX);
54 extern shared_sv*       Perl_sharedsv_new(pTHX);
55 extern shared_sv*       Perl_sharedsv_find(pTHX_ SV* sv);
56 extern void     Perl_sharedsv_lock(pTHX_ shared_sv* ssv);
57 extern void     Perl_sharedsv_unlock(pTHX_ shared_sv* ssv);
58 extern void     Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv);
59 extern void     Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv);
60 extern void     Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv);
61
62 /*
63   Shared SV
64
65   Shared SV is a structure for keeping the backend storage
66   of shared svs.
67
68 */
69
70 /*
71
72  =head1 Shared SV Functions
73
74  =for apidoc sharedsv_init 
75
76 Saves a space for keeping SVs wider than an interpreter,
77 currently only stores a pointer to the first interpreter.
78
79  =cut
80
81 */
82
83 void
84 Perl_sharedsv_init(pTHX)
85 {
86   PerlInterpreter* old_context = PERL_GET_CONTEXT;
87   PL_sharedsv_space = perl_alloc();
88   perl_construct(PL_sharedsv_space);
89   PERL_SET_CONTEXT(old_context);
90   MUTEX_INIT(&PL_sharedsv_space_mutex);
91 }
92
93 /*
94  =for apidoc sharedsv_new
95
96 Allocates a new shared sv struct, you must yourself create the SV/AV/HV.
97  =cut
98 */
99
100 shared_sv *
101 Perl_sharedsv_new(pTHX)
102 {
103     shared_sv* ssv;
104     New(2555,ssv,1,shared_sv);
105     MUTEX_INIT(&ssv->mutex);
106     COND_INIT(&ssv->cond);
107     COND_INIT(&ssv->user_cond);
108     ssv->owner = 0;
109     ssv->locks = 0;
110     ssv->index = 0;
111     return ssv;
112 }
113
114
115 /*
116  =for apidoc sharedsv_find
117
118 Tries to find if a given SV has a shared backend, either by
119 looking at magic, or by checking if it is tied again threads::shared.
120
121  =cut
122 */
123
124 shared_sv *
125 Perl_sharedsv_find(pTHX_ SV* sv)
126 {
127   /* does all it can to find a shared_sv struct, returns NULL otherwise */
128     shared_sv* ssv = NULL;
129     switch (SvTYPE(sv)) {
130         case SVt_PVMG:
131         case SVt_PVAV:
132         case SVt_PVHV: {
133             MAGIC* mg = mg_find(sv, PERL_MAGIC_ext);
134             if(mg) {
135                 if(strcmp(mg->mg_ptr,"threads::shared"))
136                     break;
137                 ssv = INT2PTR(shared_sv *, SvIV(mg->mg_obj));
138                 break;
139              }
140         
141              mg = mg_find(sv,PERL_MAGIC_tied);
142              if(mg) {
143                  SV* obj = SvTIED_obj(sv,mg);
144                  if(sv_derived_from(obj, "threads::shared"))
145                      ssv = INT2PTR(shared_sv *, SvIV(SvRV(obj)));
146                  break;
147              }
148         }
149     }
150     return ssv;
151 }
152
153 /*
154  =for apidoc sharedsv_lock
155
156 Recursive locks on a sharedsv.
157 Locks are dynamically scoped at the level of the first lock.
158  =cut
159 */
160 void
161 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
162 {
163     if(!ssv)
164         return;
165     MUTEX_LOCK(&ssv->mutex);
166     if(ssv->owner && ssv->owner == my_perl) {
167         ssv->locks++;
168         MUTEX_UNLOCK(&ssv->mutex);
169         return;
170     }
171     while(ssv->owner)
172       COND_WAIT(&ssv->cond,&ssv->mutex);
173     ssv->locks++;
174     ssv->owner = my_perl;
175     if(ssv->locks == 1)
176         SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv);
177     MUTEX_UNLOCK(&ssv->mutex);
178 }
179
180 /*
181  =for apidoc sharedsv_unlock
182
183 Recursively unlocks a shared sv.
184
185  =cut
186 */
187
188 void
189 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
190 {
191     MUTEX_LOCK(&ssv->mutex);
192     if(ssv->owner != my_perl) {
193         Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own");
194         MUTEX_UNLOCK(&ssv->mutex);
195         return;
196     }
197
198     if(--ssv->locks == 0) {
199         ssv->owner = NULL;
200         COND_SIGNAL(&ssv->cond);
201     }
202     MUTEX_UNLOCK(&ssv->mutex);
203  }
204
205 void
206 Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv)
207 {
208     MUTEX_LOCK(&ssv->mutex);
209     if(ssv->owner != my_perl) {
210         MUTEX_UNLOCK(&ssv->mutex);
211         return;
212     }
213     ssv->locks = 0;
214     ssv->owner = NULL;
215     COND_SIGNAL(&ssv->cond);
216     MUTEX_UNLOCK(&ssv->mutex);
217 }
218
219 /*
220  =for apidoc sharedsv_thrcnt_inc
221
222 Increments the threadcount of a sharedsv.
223  =cut
224 */
225 void
226 Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv)
227 {
228   SHAREDSvLOCK(ssv);
229   SvREFCNT_inc(ssv->sv);
230   SHAREDSvUNLOCK(ssv);
231 }
232
233 /*
234  =for apidoc sharedsv_thrcnt_dec
235
236 Decrements the threadcount of a shared sv. When a threads frontend is freed
237 this function should be called.
238
239  =cut
240 */
241
242 void
243 Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv)
244 {
245     SV* sv;
246     SHAREDSvLOCK(ssv);
247     sv = SHAREDSvGET(ssv);
248     if (SvREFCNT(sv) == 1) {
249         switch (SvTYPE(sv)) {
250         case SVt_RV:
251             if (SvROK(sv))
252             Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(SvRV(sv))));
253             break;
254         case SVt_PVAV: {
255             SV **src_ary  = AvARRAY((AV *)sv);
256             SSize_t items = AvFILLp((AV *)sv) + 1;
257
258             while (items-- > 0) {
259             if(SvTYPE(*src_ary))
260                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(*src_ary)));
261                 src_ary++;
262             }
263             break;
264         }
265         case SVt_PVHV: {
266             HE *entry;
267             (void)hv_iterinit((HV *)sv);
268             while ((entry = hv_iternext((HV *)sv)))
269                 Perl_sharedsv_thrcnt_dec(
270                     aTHX_ INT2PTR(shared_sv *, SvIV(hv_iterval((HV *)sv, entry)))
271                 );
272             break;
273         }
274         }
275     }
276     Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv));
277     SHAREDSvUNLOCK(ssv);
278 }
279
280
281 MGVTBL svtable;
282
283 SV* Perl_shared_sv_attach_sv (pTHX_ SV* sv, shared_sv* shared) {
284     HV* shared_hv = get_hv("threads::shared::shared", FALSE);
285     SV* id = newSViv(PTR2IV(shared));
286     STRLEN length = sv_len(id);
287     SV* tiedobject;
288     SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0);
289     if(tiedobject_) {
290         tiedobject = (*tiedobject_);
291         if(sv) {
292             SvROK_on(sv);
293             SvRV(sv) = SvRV(tiedobject);
294         } else {
295             sv = newRV(SvRV(tiedobject));
296         }
297     } else {
298         switch(SvTYPE(SHAREDSvGET(shared))) {
299             case SVt_PVAV: {
300                 SV* weakref;
301                 SV* obj_ref = newSViv(0);
302                 SV* obj = newSVrv(obj_ref,"threads::shared::av");
303                 AV* hv = newAV();
304                 sv_setiv(obj,PTR2IV(shared));
305                 weakref = newRV((SV*)hv);
306                 sv = newRV_noinc((SV*)hv);
307                 sv_rvweaken(weakref);
308                 sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0);
309                 hv_store(shared_hv, SvPV(id,length), length, weakref, 0);
310                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);         
311             }
312             break;
313             case SVt_PVHV: {
314                 SV* weakref;
315                 SV* obj_ref = newSViv(0);
316                 SV* obj = newSVrv(obj_ref,"threads::shared::hv");
317                 HV* hv = newHV();
318                 sv_setiv(obj,PTR2IV(shared));
319                 weakref = newRV((SV*)hv);
320                 sv = newRV_noinc((SV*)hv);
321                 sv_rvweaken(weakref);
322                 sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0);
323                 hv_store(shared_hv, SvPV(id,length), length, weakref, 0);
324                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);         
325             }
326             break;
327             default: {
328                 MAGIC* shared_magic;
329                 SV* value = newSVsv(SHAREDSvGET(shared));
330                 SV* obj = newSViv(PTR2IV(shared));
331                 sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
332                 shared_magic = mg_find(value, PERL_MAGIC_ext);
333                 shared_magic->mg_virtual = &svtable;
334                 shared_magic->mg_obj = newSViv(PTR2IV(shared));
335                 shared_magic->mg_flags |= MGf_REFCOUNTED;
336                 shared_magic->mg_private = 0;
337                 SvMAGICAL_on(value);
338                 sv = newRV_noinc(value);
339                 value = newRV(value);
340                 sv_rvweaken(value);
341                 hv_store(shared_hv, SvPV(id,length),length, value, 0);
342                 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
343             }
344                 
345         }
346     }
347     return sv;
348 }
349
350
351 int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
352     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
353     SHAREDSvLOCK(shared);
354     if(mg->mg_private != shared->index) {
355         if(SvROK(SHAREDSvGET(shared))) {
356             shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared))));
357             shared_sv_attach_sv(sv, target);
358         } else {
359             sv_setsv(sv, SHAREDSvGET(shared));
360         }
361         mg->mg_private = shared->index;
362     }
363     SHAREDSvUNLOCK(shared);
364
365     return 0;
366 }
367
368 int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
369     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
370     SHAREDSvLOCK(shared);
371     if(SvROK(SHAREDSvGET(shared)))
372         Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared)))));
373     if(SvROK(sv)) {
374         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
375         if(!target) {
376             sv_setsv(sv,SHAREDSvGET(shared));
377             SHAREDSvUNLOCK(shared);
378             Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
379         }
380         SHAREDSvEDIT(shared);
381         Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
382         SHAREDSvGET(shared) = newRV_noinc(newSViv(PTR2IV(target)));
383     } else {
384             SHAREDSvEDIT(shared);
385         sv_setsv(SHAREDSvGET(shared), sv);
386     }
387     shared->index++;
388     mg->mg_private = shared->index;
389     SHAREDSvRELEASE(shared);
390     if(SvROK(SHAREDSvGET(shared)))
391        Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared)))));
392     SHAREDSvUNLOCK(shared);
393     return 0;
394 }
395
396 int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) {
397     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
398     if(!shared)
399         return 0;
400     {
401         HV* shared_hv = get_hv("threads::shared::shared", FALSE);
402         SV* id = newSViv(PTR2IV(shared));
403         STRLEN length = sv_len(id);
404         hv_delete(shared_hv, SvPV(id,length), length,0);
405     }
406     Perl_sharedsv_thrcnt_dec(aTHX_ shared);
407 }
408
409 MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg),
410                   MEMBER_TO_FPTR(shared_sv_store_mg),
411                   0,
412                   0,
413                   MEMBER_TO_FPTR(shared_sv_destroy_mg)
414 };
415
416 MODULE = threads::shared                PACKAGE = threads::shared               
417
418
419 PROTOTYPES: ENABLE
420
421
422 SV*
423 ptr(ref)
424         SV* ref
425         CODE:
426         RETVAL = newSViv(SvIV(SvRV(ref)));
427         OUTPUT:
428         RETVAL
429
430
431 SV*
432 _thrcnt(ref)
433         SV* ref
434         CODE:
435         shared_sv* shared;
436         if(SvROK(ref))
437             ref = SvRV(ref);
438         shared = Perl_sharedsv_find(aTHX, ref);
439         if(!shared)
440            croak("thrcnt can only be used on shared values");
441         SHAREDSvLOCK(shared);
442         RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
443         SHAREDSvUNLOCK(shared);
444         OUTPUT:
445         RETVAL
446
447
448 void
449 thrcnt_inc(ref,perl)
450         SV* ref
451         SV* perl
452         CODE:
453         shared_sv* shared;
454         PerlInterpreter* origperl = INT2PTR(PerlInterpreter*, SvIV(perl));
455         PerlInterpreter* oldperl = PERL_GET_CONTEXT;
456         if(SvROK(ref))
457             ref = SvRV(ref);
458         shared = Perl_sharedsv_find(aTHX, ref);
459         if(!shared)
460            croak("thrcnt can only be used on shared values");
461         PERL_SET_CONTEXT(origperl);
462         Perl_sharedsv_thrcnt_inc(aTHX_ shared);
463         PERL_SET_CONTEXT(oldperl);      
464
465 void
466 _thrcnt_dec(ref)
467         SV* ref
468         CODE:
469         shared_sv* shared = INT2PTR(shared_sv*, SvIV(ref));
470         if(!shared)
471            croak("thrcnt can only be used on shared values");
472         Perl_sharedsv_thrcnt_dec(aTHX_ shared);
473
474 void
475 unlock_enabled(ref)
476         SV* ref
477         PROTOTYPE: \[$@%]
478         CODE:
479         shared_sv* shared;
480         if(SvROK(ref))
481             ref = SvRV(ref);
482         shared = Perl_sharedsv_find(aTHX, ref);
483         if(!shared)
484            croak("unlock can only be used on shared values");
485         SHAREDSvUNLOCK(shared);
486
487 void
488 lock_enabled(ref)
489         SV* ref
490         CODE:
491         shared_sv* shared;
492         if(SvROK(ref))
493             ref = SvRV(ref);
494         shared = Perl_sharedsv_find(aTHX, ref);
495         if(!shared)
496            croak("lock can only be used on shared values");
497         SHAREDSvLOCK(shared);
498
499
500 void
501 cond_wait_enabled(ref)
502         SV* ref
503         PROTOTYPE: \[$@%]
504         CODE:
505         shared_sv* shared;
506         int locks;
507         if(SvROK(ref))
508             ref = SvRV(ref);
509         shared = Perl_sharedsv_find(aTHX_ ref);
510         if(!shared)
511             croak("cond_wait can only be used on shared values");
512         if(shared->owner != PERL_GET_CONTEXT)
513             croak("You need a lock before you can cond_wait");
514         MUTEX_LOCK(&shared->mutex);
515         shared->owner = NULL;
516         locks = shared->locks = 0;
517         COND_WAIT(&shared->user_cond, &shared->mutex);
518         shared->owner = PERL_GET_CONTEXT;
519         shared->locks = locks;
520         MUTEX_UNLOCK(&shared->mutex);
521
522 void cond_signal_enabled(ref)
523         SV* ref
524         PROTOTYPE: \[$@%]
525         CODE:
526         shared_sv* shared;
527         if(SvROK(ref))
528             ref = SvRV(ref);
529         shared = Perl_sharedsv_find(aTHX_ ref);
530         if(!shared)
531             croak("cond_signal can only be used on shared values");
532         COND_SIGNAL(&shared->user_cond);
533
534
535 void cond_broadcast_enabled(ref)
536         SV* ref
537         PROTOTYPE: \[$@%]
538         CODE:
539         shared_sv* shared;
540         if(SvROK(ref))
541             ref = SvRV(ref);
542         shared = Perl_sharedsv_find(aTHX_ ref);
543         if(!shared)
544             croak("cond_broadcast can only be used on shared values");
545         COND_BROADCAST(&shared->user_cond);
546
547 MODULE = threads::shared                PACKAGE = threads::shared::sv           
548
549 SV*
550 new(class, value)
551         SV* class
552         SV* value
553         CODE:
554         shared_sv* shared = Perl_sharedsv_new(aTHX);
555         MAGIC* shared_magic;
556         SV* obj = newSViv(PTR2IV(shared));
557         SHAREDSvEDIT(shared);
558         SHAREDSvGET(shared) = newSVsv(value);
559         SHAREDSvRELEASE(shared);
560         sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
561         shared_magic = mg_find(value, PERL_MAGIC_ext);
562         shared_magic->mg_virtual = &svtable;
563         shared_magic->mg_obj = newSViv(PTR2IV(shared));
564         shared_magic->mg_flags |= MGf_REFCOUNTED;
565         shared_magic->mg_private = 0;
566         SvMAGICAL_on(value);
567         RETVAL = obj;
568         OUTPUT:         
569         RETVAL
570
571
572 MODULE = threads::shared                PACKAGE = threads::shared::av
573
574 SV*
575 new(class, value)
576         SV* class
577         SV* value
578         CODE:
579         shared_sv* shared = Perl_sharedsv_new(aTHX);
580         SV* obj = newSViv(PTR2IV(shared));
581         SHAREDSvEDIT(shared);
582         SHAREDSvGET(shared) = (SV*) newAV();
583         SHAREDSvRELEASE(shared);
584         RETVAL = obj;
585         OUTPUT:
586         RETVAL
587
588 void
589 STORE(self, index, value)
590         SV* self
591         SV* index
592         SV* value
593         CODE:
594         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
595         shared_sv* slot;
596         SV* aentry;
597         SV** aentry_;
598         if(SvROK(value)) {
599             shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value));
600             if(!target) {
601                  Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
602             }
603             value = newRV_noinc(newSViv(PTR2IV(target)));
604         }
605         SHAREDSvLOCK(shared);
606         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index), 0);
607         if(aentry_ && SvIV((*aentry_))) {
608             aentry = (*aentry_);
609             slot = INT2PTR(shared_sv*, SvIV(aentry));
610             if(SvROK(SHAREDSvGET(slot)))
611                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
612             SHAREDSvEDIT(slot);
613             sv_setsv(SHAREDSvGET(slot), value);
614             SHAREDSvRELEASE(slot);
615         } else {
616             slot = Perl_sharedsv_new(aTHX);
617             SHAREDSvEDIT(shared);
618             SHAREDSvGET(slot) = newSVsv(value);
619             aentry = newSViv(PTR2IV(slot));
620             av_store((AV*) SHAREDSvGET(shared), SvIV(index), aentry);
621             SHAREDSvRELEASE(shared);
622         }
623         if(SvROK(SHAREDSvGET(slot)))
624             Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
625
626         SHAREDSvUNLOCK(shared);
627
628 SV*
629 FETCH(self, index)
630         SV* self
631         SV* index
632         CODE:
633         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
634         shared_sv* slot;
635         SV* aentry;
636         SV** aentry_;
637         SV* retval;
638         SHAREDSvLOCK(shared);
639         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index),0);
640         if(aentry_) {
641             aentry = (*aentry_);
642             if(SvTYPE(aentry) == SVt_NULL) {
643                 retval = &PL_sv_undef;
644             } else {
645                 slot = INT2PTR(shared_sv*, SvIV(aentry));
646                 if(SvROK(SHAREDSvGET(slot))) {
647                      shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
648                      retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
649                 } else {
650                      retval = newSVsv(SHAREDSvGET(slot));
651                 }
652             }
653         } else {
654             retval = &PL_sv_undef;
655         }
656         SHAREDSvUNLOCK(shared); 
657         RETVAL = retval;
658         OUTPUT:
659         RETVAL
660
661 void
662 PUSH(self, ...)
663         SV* self
664         CODE:
665         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
666         int i;
667         SHAREDSvLOCK(shared);
668         for(i = 1; i < items; i++) {
669             shared_sv* slot = Perl_sharedsv_new(aTHX);
670             SV* tmp = ST(i);
671             if(SvROK(tmp)) {
672                  shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp));
673                  if(!target) {
674                      Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
675                  }
676                  tmp = newRV_noinc(newSViv(PTR2IV(target)));
677             }
678             SHAREDSvEDIT(slot);
679             SHAREDSvGET(slot) = newSVsv(tmp);
680             av_push((AV*) SHAREDSvGET(shared), newSViv(PTR2IV(slot)));
681             SHAREDSvRELEASE(slot);
682             if(SvROK(SHAREDSvGET(slot)))
683                 Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
684         }
685         SHAREDSvUNLOCK(shared);
686
687 void
688 UNSHIFT(self, ...)
689         SV* self
690         CODE:
691         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
692         int i;
693         SHAREDSvLOCK(shared);
694         SHAREDSvEDIT(shared);
695         av_unshift((AV*)SHAREDSvGET(shared), items - 1);
696         SHAREDSvRELEASE(shared);
697         for(i = 1; i < items; i++) {
698             shared_sv* slot = Perl_sharedsv_new(aTHX);
699             SV* tmp = ST(i);
700             if(SvROK(tmp)) {
701                  shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp));
702                  if(!target) {
703                      Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array");
704                  }
705                  tmp = newRV_noinc(newSViv(PTR2IV(target)));
706             }
707             SHAREDSvEDIT(slot);
708             SHAREDSvGET(slot) = newSVsv(tmp);
709             av_store((AV*) SHAREDSvGET(shared), i - 1, newSViv(PTR2IV(slot)));
710             SHAREDSvRELEASE(slot);
711             if(SvROK(SHAREDSvGET(slot)))
712                 Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
713         }
714         SHAREDSvUNLOCK(shared);
715
716 SV*
717 POP(self)
718         SV* self
719         CODE:
720         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
721         shared_sv* slot;
722         SV* retval;
723         SHAREDSvLOCK(shared);
724         SHAREDSvEDIT(shared);
725         retval = av_pop((AV*)SHAREDSvGET(shared));
726         SHAREDSvRELEASE(shared);
727         if(retval && SvIV(retval)) {
728             slot = INT2PTR(shared_sv*, SvIV(retval));
729             if(SvROK(SHAREDSvGET(slot))) {
730                  shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
731                  retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
732             } else {
733                  retval = newSVsv(SHAREDSvGET(slot));
734             }
735             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
736         } else {
737             retval = &PL_sv_undef;
738         }
739         SHAREDSvUNLOCK(shared);
740         RETVAL = retval;
741         OUTPUT:
742         RETVAL
743
744
745 SV*
746 SHIFT(self)
747         SV* self
748         CODE:
749         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
750         shared_sv* slot;
751         SV* retval;
752         SHAREDSvLOCK(shared);
753         SHAREDSvEDIT(shared);
754         retval = av_shift((AV*)SHAREDSvGET(shared));
755         SHAREDSvRELEASE(shared);
756         if(retval && SvIV(retval)) {
757             slot = INT2PTR(shared_sv*, SvIV(retval));
758             if(SvROK(SHAREDSvGET(slot))) {
759                  shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
760                  retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
761             } else {
762                  retval = newSVsv(SHAREDSvGET(slot));
763             }
764             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
765         } else {
766             retval = &PL_sv_undef;
767         }
768         SHAREDSvUNLOCK(shared);
769         RETVAL = retval;
770         OUTPUT:
771         RETVAL
772
773 void
774 CLEAR(self)
775         SV* self
776         CODE:
777         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
778         shared_sv* slot;
779         SV** svp;
780         I32 i;
781         SHAREDSvLOCK(shared);
782         svp = AvARRAY((AV*)SHAREDSvGET(shared));
783         i   = AvFILLp((AV*)SHAREDSvGET(shared));
784         while ( i >= 0) {
785             if(SvIV(svp[i])) {
786                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(svp[i])));
787             }
788             i--;
789         }
790         SHAREDSvEDIT(shared);
791         av_clear((AV*)SHAREDSvGET(shared));
792         SHAREDSvRELEASE(shared);
793         SHAREDSvUNLOCK(shared);
794         
795 void
796 EXTEND(self, count)
797         SV* self
798         SV* count
799         CODE:
800         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
801         SHAREDSvEDIT(shared);
802         av_extend((AV*)SHAREDSvGET(shared), (I32) SvIV(count));
803         SHAREDSvRELEASE(shared);
804
805
806
807
808 SV*
809 EXISTS(self, index)
810         SV* self
811         SV* index
812         CODE:
813         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
814         I32 exists;
815         SHAREDSvLOCK(shared);
816         exists = av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index));
817         if(exists) {
818             RETVAL = &PL_sv_yes;
819         } else {
820             RETVAL = &PL_sv_no;
821         }
822         SHAREDSvUNLOCK(shared);
823
824 void
825 STORESIZE(self,count)
826         SV* self
827         SV* count
828         CODE:
829         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
830         SHAREDSvEDIT(shared);
831         av_fill((AV*) SHAREDSvGET(shared), (I32) SvIV(count));
832         SHAREDSvRELEASE(shared);
833
834 SV*
835 FETCHSIZE(self)
836         SV* self
837         CODE:
838         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
839         SHAREDSvLOCK(shared);
840         RETVAL = newSViv(av_len((AV*) SHAREDSvGET(shared)) + 1);
841         SHAREDSvUNLOCK(shared);
842         OUTPUT:
843         RETVAL
844
845 SV*
846 DELETE(self,index)
847         SV* self
848         SV* index
849         CODE:
850         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
851         shared_sv* slot;
852         SHAREDSvLOCK(shared);
853         if(av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index))) {
854             SV* tmp;
855             SHAREDSvEDIT(shared);
856             tmp = av_delete((AV*)SHAREDSvGET(shared), (I32) SvIV(index),0);
857             SHAREDSvRELEASE(shared);
858             if(SvIV(tmp)) {
859                 slot = INT2PTR(shared_sv*, SvIV(tmp));
860                 if(SvROK(SHAREDSvGET(slot))) {
861                    shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
862                    RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
863                 } else {
864                    RETVAL = newSVsv(SHAREDSvGET(slot));
865                 }
866                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
867             } else {
868                 RETVAL = &PL_sv_undef;
869             }   
870         } else {
871             RETVAL = &PL_sv_undef;
872         }       
873         SHAREDSvUNLOCK(shared);
874         OUTPUT:
875         RETVAL
876
877 AV*
878 SPLICE(self, offset, length, ...)
879         SV* self
880         SV* offset
881         SV* length
882         CODE:
883         croak("Splice is not implmented for shared arrays");
884         
885 MODULE = threads::shared                PACKAGE = threads::shared::hv
886
887 SV*
888 new(class, value)
889         SV* class
890         SV* value
891         CODE:
892         shared_sv* shared = Perl_sharedsv_new(aTHX);
893         SV* obj = newSViv(PTR2IV(shared));
894         SHAREDSvEDIT(shared);
895         SHAREDSvGET(shared) = (SV*) newHV();
896         SHAREDSvRELEASE(shared);
897         RETVAL = obj;
898         OUTPUT:
899         RETVAL
900
901 void
902 STORE(self, key, value)
903         SV* self
904         SV* key
905         SV* value
906         CODE:
907         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
908         shared_sv* slot;
909         SV* hentry;
910         SV** hentry_;
911         STRLEN len;
912         char* ckey = SvPV(key, len);
913         SHAREDSvLOCK(shared);
914         if(SvROK(value)) {
915             shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value));
916             if(!target) {
917                 Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared hash");
918             }
919             SHAREDSvEDIT(shared);
920             value = newRV_noinc(newSViv(PTR2IV(target)));
921             SHAREDSvRELEASE(shared);
922         }
923         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len, 0);
924         if(hentry_ && SvIV((*hentry_))) {
925             hentry = (*hentry_);
926             slot = INT2PTR(shared_sv*, SvIV(hentry));
927             if(SvROK(SHAREDSvGET(slot)))
928                 Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
929             SHAREDSvEDIT(slot);
930             sv_setsv(SHAREDSvGET(slot), value);
931             SHAREDSvRELEASE(slot);
932         } else {
933             slot = Perl_sharedsv_new(aTHX);
934             SHAREDSvEDIT(shared);
935             SHAREDSvGET(slot) = newSVsv(value);
936             hentry = newSViv(PTR2IV(slot));
937             hv_store((HV*) SHAREDSvGET(shared), ckey,len , hentry, 0);
938             SHAREDSvRELEASE(shared);
939         }
940         if(SvROK(SHAREDSvGET(slot)))
941             Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))));
942         SHAREDSvUNLOCK(shared);
943
944
945 SV*
946 FETCH(self, key)
947         SV* self
948         SV* key
949         CODE:
950         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
951         shared_sv* slot;
952         SV* hentry;
953         SV** hentry_;
954         SV* retval;
955         STRLEN len;
956         char* ckey = SvPV(key, len);
957         SHAREDSvLOCK(shared);
958         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len,0);
959         if(hentry_) {
960             hentry = (*hentry_);
961             if(SvTYPE(hentry) == SVt_NULL) {
962                 retval = &PL_sv_undef;
963             } else {
964                 slot = INT2PTR(shared_sv*, SvIV(hentry));
965                 if(SvROK(SHAREDSvGET(slot))) {
966                     shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
967                     retval = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
968                 } else {
969                     retval = newSVsv(SHAREDSvGET(slot));
970                 }
971             }
972         } else {
973             retval = &PL_sv_undef;
974         }
975         SHAREDSvUNLOCK(shared);
976         RETVAL = retval;
977         OUTPUT:
978         RETVAL
979
980 void
981 CLEAR(self)
982         SV* self
983         CODE:
984         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
985         shared_sv* slot;
986         HE* entry;
987         SHAREDSvLOCK(shared);
988         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
989         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
990         while(entry) {
991                 slot = INT2PTR(shared_sv*, SvIV(Perl_hv_iterval(PL_sharedsv_space, (HV*) SHAREDSvGET(shared), entry)));
992                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
993                 entry = Perl_hv_iternext(PL_sharedsv_space,(HV*) SHAREDSvGET(shared));
994         }
995         SHAREDSvEDIT(shared);
996         hv_clear((HV*) SHAREDSvGET(shared));
997         SHAREDSvRELEASE(shared);
998         SHAREDSvUNLOCK(shared);
999
1000 SV*
1001 FIRSTKEY(self)
1002         SV* self
1003         CODE:
1004         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1005         char* key = NULL;
1006         I32 len;
1007         HE* entry;
1008         SHAREDSvLOCK(shared);
1009         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1010         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1011         if(entry) {
1012                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
1013                 RETVAL = newSVpv(key, len);
1014         } else {
1015              RETVAL = &PL_sv_undef;
1016         }
1017         SHAREDSvUNLOCK(shared);
1018         OUTPUT:
1019         RETVAL
1020
1021
1022 SV*
1023 NEXTKEY(self, oldkey)
1024         SV* self
1025         SV* oldkey
1026         CODE:
1027         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1028         char* key = NULL;
1029         I32 len;
1030         HE* entry;
1031         SHAREDSvLOCK(shared);
1032         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
1033         if(entry) {
1034                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
1035                 RETVAL = newSVpv(key, len);
1036         } else {
1037              RETVAL = &PL_sv_undef;
1038         }
1039         SHAREDSvUNLOCK(shared);
1040         OUTPUT:
1041         RETVAL
1042
1043
1044 SV*
1045 EXISTS(self, key)
1046         SV* self
1047         SV* key
1048         CODE:
1049         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1050         STRLEN len;
1051         char* ckey = SvPV(key, len);
1052         SHAREDSvLOCK(shared);
1053         if(hv_exists((HV*)SHAREDSvGET(shared), ckey, len)) {
1054                 RETVAL = &PL_sv_yes;
1055         } else {
1056                 RETVAL = &PL_sv_no;
1057         }
1058         SHAREDSvUNLOCK(shared);
1059         OUTPUT:
1060         RETVAL
1061
1062 SV*
1063 DELETE(self, key)
1064         SV* self
1065         SV* key
1066         CODE:
1067         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
1068         shared_sv* slot;
1069         STRLEN len;
1070         char* ckey = SvPV(key, len);
1071         SV* tmp;
1072         SHAREDSvLOCK(shared);
1073         SHAREDSvEDIT(shared);
1074         tmp = hv_delete((HV*) SHAREDSvGET(shared), ckey, len,0);
1075         SHAREDSvRELEASE(shared);
1076         if(tmp) {
1077                 slot = INT2PTR(shared_sv*, SvIV(tmp));
1078                 if(SvROK(SHAREDSvGET(slot))) {
1079                     shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
1080                     RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
1081                 } else {
1082                     RETVAL = newSVsv(SHAREDSvGET(slot));
1083                 }
1084                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
1085         } else {
1086                 RETVAL = &PL_sv_undef;
1087         }
1088         SHAREDSvUNLOCK(shared);
1089         OUTPUT:
1090         RETVAL
1091
1092 BOOT:
1093 {
1094      Perl_sharedsv_init(aTHX);
1095 }