This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
First support of threads::shared, support shared svs and references.
[perl5.git] / ext / threads / shared / shared.xs
CommitLineData
b050c948
AB
1
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6
7void shared_sv_attach_sv (SV* sv, shared_sv* shared) {
8 HV* shared_hv = get_hv("threads::shared::shared", FALSE);
9 SV* id = newSViv((IV)shared);
10 STRLEN length = sv_len(id);
11 SV* tiedobject;
12 SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0);
13 if(tiedobject_) {
14 tiedobject = (*tiedobject_);
15 SvROK_on(sv);
16 SvRV(sv) = SvRV(tiedobject);
17
18 } else {
19 croak("die\n");
20 }
21}
22
23
24int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
25 shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
26 SHAREDSvLOCK(shared);
27 if(SvROK(SHAREDSvGET(shared))) {
28 shared_sv* target = (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared)));
29 shared_sv_attach_sv(sv, target);
30 } else {
31 sv_setsv(sv, SHAREDSvGET(shared));
32 }
33 SHAREDSvUNLOCK(shared);
34
35 return 0;
36}
37
38int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
39 shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
40 SHAREDSvLOCK(shared);
41 if(SvROK(SHAREDSvGET(shared)))
42 Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));
43 SHAREDSvEDIT(shared);
44 if(SvROK(sv)) {
45 shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
46 if(!target) {
47 SHAREDSvRELEASE(shared);
48 sv_setsv(sv,SHAREDSvGET(shared));
49 SHAREDSvUNLOCK(shared);
50 Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
51 }
52 Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
53 SHAREDSvGET(shared) = newRV_noinc(newSViv((IV)target));
54 SvROK_off(sv);
55 } else {
56 sv_setsv(SHAREDSvGET(shared), sv);
57 }
58 SHAREDSvRELEASE(shared);
59 if(SvROK(SHAREDSvGET(shared)))
60 Perl_sharedsv_thrcnt_inc(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));
61 SHAREDSvUNLOCK(shared);
62 return 0;
63}
64
65int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) {
66 shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
67 if(!shared)
68 return 0;
69 Perl_sharedsv_thrcnt_dec(aTHX_ shared);
70}
71
72MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg),
73 MEMBER_TO_FPTR(shared_sv_store_mg),
74 0,
75 0,
76 MEMBER_TO_FPTR(shared_sv_destroy_mg)
77};
78
79MODULE = threads::shared PACKAGE = threads::shared
80
81
82PROTOTYPES: DISABLE
83
84
85SV*
86ptr(ref)
87 SV* ref
88 CODE:
89 RETVAL = newSViv(SvIV(SvRV(ref)));
90 OUTPUT:
91 RETVAL
92
93
94SV*
95_thrcnt(ref)
96 SV* ref
97 CODE:
98 shared_sv* shared = Perl_sharedsv_find(aTHX, ref);
99 if(!shared)
100 croak("thrcnt can only be used on shared values");
101 SHAREDSvLOCK(shared);
102 RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
103 SHAREDSvUNLOCK(shared);
104 OUTPUT:
105 RETVAL
106
107
108void
109thrcnt_inc(ref)
110 SV* ref
111 CODE:
112 shared_sv* shared;
113 if(SvROK(ref))
114 ref = SvRV(ref);
115 shared = Perl_sharedsv_find(aTHX, ref);
116 if(!shared)
117 croak("thrcnt can only be used on shared values");
118 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
119
120
121MODULE = threads::shared PACKAGE = threads::shared::sv
122
123SV*
124new(class, value)
125 SV* class
126 SV* value
127 CODE:
128 shared_sv* shared = Perl_sharedsv_new(aTHX);
129 MAGIC* shared_magic;
130 SV* obj = newSViv((IV)shared);
131 SHAREDSvEDIT(shared);
132 SHAREDSvGET(shared) = newSVsv(value);
133 SHAREDSvRELEASE(shared);
134 sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
135 shared_magic = mg_find(value, PERL_MAGIC_ext);
136 shared_magic->mg_virtual = &svtable;
137 shared_magic->mg_obj = newSViv((IV)shared);
138 shared_magic->mg_flags |= MGf_REFCOUNTED;
139 SvMAGICAL_on(value);
140 RETVAL = obj;
141 OUTPUT:
142 RETVAL
143
144