This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Shared scalars working, some shared array ops working.
[perl5.git] / ext / threads / shared / shared.xs
CommitLineData
68795e93
NIS
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 */
b050c948 9
68795e93 10/*
21312124
NIS
11 *
12 * "Hand any two wizards a piece of rope and they would instinctively pull in
13 * opposite directions."
14 * --Sourcery
15 *
16 * Contributed by Arthur Bergman arthur@contiller.se
17 * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net
18 */
68795e93
NIS
19
20#define PERL_NO_GET_CONTEXT
b050c948
AB
21#include "EXTERN.h"
22#include "perl.h"
23#include "XSUB.h"
24
21312124
NIS
25#define SHAREDSvPTR(a) ((a)->sv)
26
27/*
28 * The shared things need an intepreter to live in ...
29 */
30PerlInterpreter *PL_sharedsv_space; /* The shared sv space */
31/* To access shared space we fake aTHX in this scope and thread's context */
32#define SHARED_CONTEXT PERL_SET_CONTEXT((aTHX = PL_sharedsv_space))
33
34/* So we need a way to switch back to the caller's context... */
35/* So we declare _another_ copy of the aTHX variable ... */
36#define dTHXc PerlInterpreter *caller_perl = aTHX
37/* and use it to switch back */
38#define CALLER_CONTEXT PERL_SET_CONTEXT((aTHX = caller_perl))
39
40/*
41 * Only one thread at a time is allowed to mess with shared space.
42 */
43perl_mutex PL_sharedsv_space_mutex; /* Mutex protecting the shared sv space */
a446a88f
NIS
44PerlInterpreter *PL_shared_owner; /* For locking assertions */
45
46#define SHARED_LOCK STMT_START { \
47 MUTEX_LOCK(&PL_sharedsv_space_mutex); \
48 PL_shared_owner = aTHX; \
49 } STMT_END
50
51#define SHARED_UNLOCK STMT_START { \
52 PL_shared_owner = NULL; \
53 MUTEX_UNLOCK(&PL_sharedsv_space_mutex); \
54 } STMT_END
21312124 55
21312124
NIS
56
57/* A common idiom is to acquire access and switch in ... */
58#define SHARED_EDIT STMT_START { \
59 SHARED_LOCK; \
60 SHARED_CONTEXT; \
61 } STMT_END
62
63/* then switch out and release access. */
64#define SHARED_RELEASE STMT_START { \
65 CALLER_CONTEXT; \
66 SHARED_UNLOCK; \
67 } STMT_END
68
69
70/*
71
72 Shared SV
73
74 Shared SV is a structure for keeping the backend storage
75 of shared svs.
76
77 Shared-ness really only needs the SV * - the rest is for locks.
78 (Which suggests further space optimization ... )
79
80*/
68795e93
NIS
81
82typedef struct {
21312124 83 SV *sv; /* The actual SV - in shared space */
68795e93
NIS
84 perl_mutex mutex; /* Our mutex */
85 perl_cond cond; /* Our condition variable */
86 perl_cond user_cond; /* For user-level conditions */
87 IV locks; /* Number of locks held */
88 PerlInterpreter *owner; /* Who owns the lock? */
68795e93
NIS
89} shared_sv;
90
21312124
NIS
91/* The SV in shared-space has a back-pointer to the shared_sv
92 struct associated with it PERL_MAGIC_ext.
68795e93 93
21312124
NIS
94 The vtable used has just one entry - when the SV goes away
95 we free the memory for the above.
68795e93 96
21312124 97 */
68795e93 98
21312124
NIS
99int
100sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
101{
102 shared_sv *shared = (shared_sv *) mg->mg_ptr;
103 if (shared) {
a446a88f 104 PerlIO_debug(__FUNCTION__ "Free %p\n",shared);
21312124
NIS
105 PerlMemShared_free(shared);
106 mg->mg_ptr = NULL;
107 }
108 return 0;
109}
110
111
112MGVTBL sharedsv_shared_vtbl = {
113 0, /* get */
114 0, /* set */
115 0, /* len */
116 0, /* clear */
117 sharedsv_shared_mg_free, /* free */
118 0, /* copy */
119 0, /* dup */
120};
121
122/* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */
123
124/* In any thread that has access to a shared thing there is a "proxy"
125 for it in its own space which has 'MAGIC' associated which accesses
126 the shared thing.
127 */
128
129MGVTBL sharedsv_scalar_vtbl; /* scalars have this vtable */
130MGVTBL sharedsv_array_vtbl; /* hashes and arrays have this - like 'tie' */
131MGVTBL sharedsv_elem_vtbl; /* elements of hashes and arrays have this
132 _AS WELL AS_ the scalar magic */
133
134/* The sharedsv_elem_vtbl associates the element with the array/hash and
135 the sharedsv_scalar_vtbl associates it with the value
136 */
137
138=for apidoc sharedsv_find
139
140Given a private side SV tries to find if a given SV has a shared backend,
141by looking for the magic.
142
143=cut
144
145shared_sv *
146Perl_sharedsv_find(pTHX_ SV *sv)
147{
148 MAGIC *mg;
a446a88f
NIS
149 if (SvTYPE(sv) >= SVt_PVMG) {
150 switch(SvTYPE(sv)) {
151 case SVt_PVAV:
152 case SVt_PVHV:
153 if ((mg = mg_find(sv, PERL_MAGIC_tied))
154 && mg->mg_virtual == &sharedsv_array_vtbl) {
21312124
NIS
155 return (shared_sv *) mg->mg_ptr;
156 }
157 break;
a446a88f
NIS
158 default:
159 if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
160 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
21312124 161 return (shared_sv *) mg->mg_ptr;
a446a88f
NIS
162 }
163 break;
21312124
NIS
164 }
165 }
166 return NULL;
167}
68795e93
NIS
168
169/*
21312124
NIS
170 * Almost all the pain is in this routine.
171 *
172 */
68795e93 173
21312124
NIS
174shared_sv *
175Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
176{
177 /* First try and get global data structure */
178 dTHXc;
a446a88f 179 MAGIC *mg = 0;
21312124 180 SV *sv;
a446a88f
NIS
181
182 /* If we are asked for an private ops we need a thread */
183 assert ( aTHX != PL_sharedsv_space );
184
185 /* To avoid need for recursive locks require caller to hold lock */
186 if ( PL_shared_owner != aTHX )
187 abort();
188 assert ( PL_shared_owner == aTHX );
68795e93 189
21312124 190 /* Try shared SV as 1st choice */
a446a88f 191 if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
21312124
NIS
192 if (mg = mg_find(ssv, PERL_MAGIC_ext)) {
193 data = (shared_sv *) mg->mg_ptr;
194 }
195 }
196 /* Next try private SV */
197 if (!data && psv && *psv) {
a446a88f 198 data = Perl_sharedsv_find(aTHX,*psv);
21312124
NIS
199 }
200 /* If neither of those then create a new one */
201 if (!data) {
202 data = PerlMemShared_malloc(sizeof(shared_sv));
203 Zero(data,1,shared_sv);
204 MUTEX_INIT(&data->mutex);
205 COND_INIT(&data->cond);
206 COND_INIT(&data->user_cond);
207 data->owner = 0;
208 data->locks = 0;
209 }
68795e93 210
21312124
NIS
211 if (!ssv)
212 ssv = SHAREDSvPTR(data);
213
214 /* If we know type allocate shared side SV */
215 if (psv && *psv && !ssv) {
216 SHARED_CONTEXT;
217 ssv = newSV(0);
218 sv_upgrade(ssv, SvTYPE(*psv));
219 /* Tag shared side SV with data pointer */
220 sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
221 (char *)data, 0);
222 CALLER_CONTEXT;
223 }
68795e93 224
21312124
NIS
225 if (!SHAREDSvPTR(data))
226 SHAREDSvPTR(data) = ssv;
68795e93 227
21312124
NIS
228 /* Now if requested allocate private SV */
229 if (psv && !*psv && ssv) {
230 sv = newSV(0);
231 sv_upgrade(sv, SvTYPE(SHAREDSvPTR(data)));
232 *psv = sv;
233 }
234
235 /* Finally if private SV exists check and add magic */
a446a88f
NIS
236 if (psv && (sv = *psv)) {
237 MAGIC *mg = 0;
21312124
NIS
238 switch(SvTYPE(sv)) {
239 case SVt_PVAV:
240 case SVt_PVHV:
241 if (!(mg = mg_find(sv, PERL_MAGIC_tied))
242 || mg->mg_virtual != &sharedsv_array_vtbl) {
a446a88f
NIS
243 SV *obj = newSV(0);
244 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
21312124
NIS
245 if (mg)
246 sv_unmagic(sv, PERL_MAGIC_tied);
a446a88f 247 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
21312124
NIS
248 (char *) data, 0);
249 mg->mg_flags |= (MGf_COPY|MGf_DUP);
a446a88f
NIS
250 SvREFCNT_inc(SHAREDSvPTR(data));
251 PerlIO_debug(__FUNCTION__ " %p %d\n",data,SvREFCNT(SHAREDSvPTR(data)));
252 SvREFCNT_dec(obj);
21312124
NIS
253 }
254 break;
255
256 default:
a446a88f 257 if (SvTYPE(sv) < SVt_PVMG || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) ||
21312124
NIS
258 mg->mg_virtual != &sharedsv_scalar_vtbl) {
259 if (mg)
260 sv_unmagic(sv, PERL_MAGIC_shared_scalar);
261 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
262 &sharedsv_scalar_vtbl, (char *)data, 0);
263 mg->mg_flags |= (MGf_COPY|MGf_DUP);
a446a88f
NIS
264 SvREFCNT_inc(SHAREDSvPTR(data));
265 PerlIO_debug(__FUNCTION__ " %p %d\n",data,SvREFCNT(SHAREDSvPTR(data)));
21312124
NIS
266 }
267 break;
268 }
269 }
21312124
NIS
270 return data;
271}
68795e93
NIS
272
273void
21312124 274Perl_sharedsv_free(pTHX_ shared_sv *shared)
68795e93 275{
21312124
NIS
276 if (shared) {
277 dTHXc;
278 SHARED_EDIT;
279 SvREFCNT_dec(SHAREDSvPTR(shared));
280 SHARED_RELEASE;
281 }
68795e93
NIS
282}
283
21312124
NIS
284void
285Perl_sharedsv_share(pTHX_ SV *sv)
286{
287 switch(SvTYPE(sv)) {
288 case SVt_PVGV:
289 Perl_croak(aTHX_ "Cannot share globs yet");
290 break;
291
292 case SVt_PVCV:
293 Perl_croak(aTHX_ "Cannot share subs yet");
294 break;
295
296 default:
a446a88f 297 SHARED_LOCK;
21312124 298 Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
a446a88f
NIS
299 SHARED_UNLOCK;
300 SvSETMAGIC(sv);
301 break;
21312124
NIS
302 }
303}
68795e93 304
21312124 305/* MAGIC (in mg.h sense) hooks */
68795e93 306
21312124
NIS
307int
308sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
68795e93 309{
21312124
NIS
310 shared_sv *shared = (shared_sv *) mg->mg_ptr;
311
312 SHARED_LOCK;
21312124
NIS
313 if (SHAREDSvPTR(shared)) {
314 if (SvROK(SHAREDSvPTR(shared))) {
a446a88f
NIS
315 SV *obj = Nullsv;
316 Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
317 sv_setsv_nomg(sv, &PL_sv_undef);
318 SvRV(sv) = obj;
319 SvROK_on(sv);
21312124
NIS
320 }
321 else {
a446a88f 322 sv_setsv_nomg(sv, SHAREDSvPTR(shared));
21312124
NIS
323 }
324 }
325 SHARED_UNLOCK;
326 return 0;
327}
328
329int
330sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
331{
332 dTHXc;
a446a88f 333 shared_sv *shared;
21312124 334 bool allowed = TRUE;
a446a88f
NIS
335 SHARED_LOCK;
336 shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
21312124 337
21312124
NIS
338 if (SvROK(sv)) {
339 shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
340 if (target) {
a446a88f
NIS
341 SV *tmp;
342 SHARED_CONTEXT;
343 tmp = newRV(SHAREDSvPTR(target));
344 sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
21312124 345 SvREFCNT_dec(tmp);
a446a88f 346 CALLER_CONTEXT;
21312124
NIS
347 }
348 else {
349 allowed = FALSE;
350 }
351 }
352 else {
a446a88f
NIS
353 SHARED_CONTEXT;
354 sv_setsv_nomg(SHAREDSvPTR(shared), sv);
355 CALLER_CONTEXT;
21312124
NIS
356 }
357 SHARED_RELEASE;
358
359 if (!allowed) {
360 Perl_croak(aTHX_ "Invalid value for shared scalar");
361 }
362 return 0;
68795e93
NIS
363}
364
21312124
NIS
365int
366sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
367{
a446a88f
NIS
368 shared_sv *shared = (shared_sv *) mg->mg_ptr;
369 PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared))-1);
370 assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
371 Perl_sharedsv_free(aTHX_ shared);
372 return 0;
373}
374
375int
376sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
377{
378 shared_sv *shared = (shared_sv *) mg->mg_ptr;
379 PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
21312124
NIS
380 return 0;
381}
68795e93
NIS
382
383/*
21312124
NIS
384 * Called during cloning of new threads
385 */
386int
387sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
388{
389 shared_sv *shared = (shared_sv *) mg->mg_ptr;
390 if (shared) {
391 SvREFCNT_inc(SHAREDSvPTR(shared));
392 }
a446a88f 393 PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
21312124
NIS
394 return 0;
395}
68795e93 396
21312124
NIS
397MGVTBL sharedsv_scalar_vtbl = {
398 sharedsv_scalar_mg_get, /* get */
399 sharedsv_scalar_mg_set, /* set */
400 0, /* len */
a446a88f 401 sharedsv_scalar_mg_clear, /* clear */
21312124
NIS
402 sharedsv_scalar_mg_free, /* free */
403 0, /* copy */
404 sharedsv_scalar_mg_dup /* dup */
405};
68795e93 406
21312124 407/* Now the arrays/hashes stuff */
68795e93 408
21312124
NIS
409int
410sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
68795e93 411{
21312124
NIS
412 dTHXc;
413 shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
414 shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
415 SV** svp;
416
a446a88f
NIS
417 assert ( shared );
418 assert ( SHAREDSvPTR(shared) );
419
21312124
NIS
420 SHARED_EDIT;
421 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
a446a88f
NIS
422 assert ( mg->mg_ptr == 0 );
423 svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
21312124
NIS
424 }
425 else {
a446a88f 426 assert ( mg->mg_ptr != 0 );
21312124
NIS
427 svp = hv_fetch((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len, 0);
428 }
429
430 if (svp) {
a446a88f
NIS
431 if (target) {
432 if (SHAREDSvPTR(target) != *svp) {
433 if (SHAREDSvPTR(target)) {
434 PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
435 SvREFCNT_dec(SHAREDSvPTR(target));
436 }
437 SHAREDSvPTR(target) = SvREFCNT_inc(*svp);
21312124 438 }
a446a88f
NIS
439 }
440 else {
441 CALLER_CONTEXT;
442 Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
443 SHARED_CONTEXT;
21312124
NIS
444 }
445 }
a446a88f 446 else if (target) {
21312124
NIS
447 if (SHAREDSvPTR(target)) {
448 SvREFCNT_dec(SHAREDSvPTR(target));
68795e93 449 }
21312124 450 SHAREDSvPTR(target) = Nullsv;
68795e93 451 }
21312124
NIS
452 SHARED_RELEASE;
453 return 0;
68795e93
NIS
454}
455
21312124
NIS
456int
457sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
458{
459 dTHXc;
460 shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
a446a88f
NIS
461 shared_sv *target;
462 SV *val;
21312124
NIS
463 /* Theory - SV itself is magically shared - and we have ordered the
464 magic such that by the time we get here it has been stored
465 to its shared counterpart
466 */
a446a88f
NIS
467 SHARED_LOCK;
468 target = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, 0);
469 SHARED_CONTEXT;
470 val = SHAREDSvPTR(target);
21312124 471 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
a446a88f 472 av_store((AV*) SHAREDSvPTR(shared), mg->mg_len, SvREFCNT_inc(val));
21312124
NIS
473 }
474 else {
475 hv_store((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len,
a446a88f 476 SvREFCNT_inc(val), 0);
21312124
NIS
477 }
478 SHARED_RELEASE;
479 return 0;
480}
68795e93 481
21312124
NIS
482int
483sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
68795e93 484{
21312124
NIS
485 dTHXc;
486 shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
487 SV* ssv;
488 SHARED_EDIT;
489 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
490 ssv = av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
68795e93 491 }
21312124
NIS
492 else {
493 ssv = hv_delete((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len, 0);
494 }
495 SHARED_RELEASE;
496 /* It is no longer in the array - so remove that magic */
497 sv_unmagic(sv, PERL_MAGIC_tiedelem);
498 Perl_sharedsv_associate(aTHX_ &sv, ssv, 0);
499 return 0;
500}
501
502
503int
504sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
505{
506 Perl_sharedsv_free(aTHX_ Perl_sharedsv_find(aTHX_ mg->mg_obj));
507 return 0;
508}
509
510int
511sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
512{
513 shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj);
514 SvREFCNT_inc(SHAREDSvPTR(shared));
a446a88f 515 PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
21312124
NIS
516 mg->mg_flags |= MGf_DUP;
517 return 0;
518}
519
520MGVTBL sharedsv_elem_vtbl = {
521 sharedsv_elem_mg_FETCH, /* get */
522 sharedsv_elem_mg_STORE, /* set */
523 0, /* len */
524 sharedsv_elem_mg_DELETE, /* clear */
525 sharedsv_elem_mg_free, /* free */
526 0, /* copy */
527 sharedsv_elem_mg_dup /* dup */
528};
529
530U32
531sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
532{
533 dTHXc;
534 shared_sv *shared = (shared_sv *) mg->mg_ptr;
535 U32 val;
536 SHARED_EDIT;
537 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
538 val = av_len((AV*) SHAREDSvPTR(shared));
539 }
540 else {
541 /* not actually defined by tie API but ... */
542 val = HvKEYS((HV*) SHAREDSvPTR(shared));
543 }
544 SHARED_RELEASE;
545 return val;
546}
547
548int
549sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
550{
551 dTHXc;
552 shared_sv *shared = (shared_sv *) mg->mg_ptr;
553 SHARED_EDIT;
554 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
555 av_clear((AV*) SHAREDSvPTR(shared));
556 }
557 else {
558 hv_clear((HV*) SHAREDSvPTR(shared));
559 }
560 SHARED_RELEASE;
561 return 0;
562}
563
564int
565sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
566{
567 Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
568 return 0;
68795e93
NIS
569}
570
571/*
21312124
NIS
572 * This is called when perl is about to access an element of
573 * the array -
574 */
575int
576sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
577 SV *nsv, const char *name, int namlen)
578{
579 shared_sv *shared = (shared_sv *) mg->mg_ptr;
580 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
581 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
582 name, namlen);
a446a88f 583 SvREFCNT_inc(SHAREDSvPTR(shared));
21312124
NIS
584 nmg->mg_flags |= MGf_DUP;
585#if 0
586 /* Maybe do this to associate shared value immediately ? */
587 sharedsv_elem_FIND(aTHX_ nsv, nmg);
588#endif
589 return 1;
590}
591
592int
593sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
594{
595 shared_sv *shared = (shared_sv *) mg->mg_ptr;
596 SvREFCNT_inc(SHAREDSvPTR(shared));
a446a88f 597 PerlIO_debug(__FUNCTION__ " %p %d\n",shared,SvREFCNT(SHAREDSvPTR(shared)));
21312124
NIS
598 mg->mg_flags |= MGf_DUP;
599 return 0;
600}
601
602MGVTBL sharedsv_array_vtbl = {
603 0, /* get */
604 0, /* set */
605 sharedsv_array_mg_FETCHSIZE, /* len */
606 sharedsv_array_mg_CLEAR, /* clear */
607 sharedsv_array_mg_free, /* free */
608 sharedsv_array_mg_copy, /* copy */
609 sharedsv_array_mg_dup /* dup */
610};
611
612=for apidoc sharedsv_unlock
68795e93
NIS
613
614Recursively unlocks a shared sv.
615
21312124 616=cut
68795e93
NIS
617
618void
619Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
620{
621 MUTEX_LOCK(&ssv->mutex);
21312124
NIS
622 if (ssv->owner != aTHX) {
623 Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own");
624 MUTEX_UNLOCK(&ssv->mutex);
625 return;
68795e93
NIS
626 }
627
21312124
NIS
628 if (--ssv->locks == 0) {
629 ssv->owner = NULL;
68795e93
NIS
630 COND_SIGNAL(&ssv->cond);
631 }
632 MUTEX_UNLOCK(&ssv->mutex);
633 }
634
635void
636Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv)
637{
638 MUTEX_LOCK(&ssv->mutex);
21312124
NIS
639 if (ssv->owner != aTHX) {
640 MUTEX_UNLOCK(&ssv->mutex);
641 return;
68795e93
NIS
642 }
643 ssv->locks = 0;
644 ssv->owner = NULL;
645 COND_SIGNAL(&ssv->cond);
646 MUTEX_UNLOCK(&ssv->mutex);
647}
648
21312124 649=for apidoc sharedsv_lock
68795e93 650
21312124
NIS
651Recursive locks on a sharedsv.
652Locks are dynamically scoped at the level of the first lock.
68795e93 653
21312124 654=cut
68795e93
NIS
655
656void
21312124 657Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
68795e93 658{
21312124
NIS
659 if (!ssv)
660 return;
661 MUTEX_LOCK(&ssv->mutex);
662 if (ssv->owner && ssv->owner == aTHX) {
663 ssv->locks++;
664 MUTEX_UNLOCK(&ssv->mutex);
665 return;
68795e93 666 }
21312124
NIS
667 while (ssv->owner)
668 COND_WAIT(&ssv->cond,&ssv->mutex);
669 ssv->locks++;
670 ssv->owner = aTHX;
671 if (ssv->locks == 1)
672 SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv);
673 MUTEX_UNLOCK(&ssv->mutex);
68795e93
NIS
674}
675
21312124
NIS
676void
677Perl_sharedsv_locksv(pTHX_ SV *sv)
678{
679 Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv));
b050c948
AB
680}
681
21312124 682=head1 Shared SV Functions
b050c948 683
21312124 684=for apidoc sharedsv_init
b050c948 685
21312124
NIS
686Saves a space for keeping SVs wider than an interpreter,
687currently only stores a pointer to the first interpreter.
b050c948 688
21312124
NIS
689=cut
690
691void
692Perl_sharedsv_init(pTHX)
693{
694 dTHXc;
695 /* This pair leaves us in shared context ... */
696 PL_sharedsv_space = perl_alloc();
697 perl_construct(PL_sharedsv_space);
698 CALLER_CONTEXT;
699 MUTEX_INIT(&PL_sharedsv_space_mutex);
700 PL_lockhook = &Perl_sharedsv_locksv;
701 PL_sharehook = &Perl_sharedsv_share;
b050c948
AB
702}
703
21312124
NIS
704/* Accessor to convert threads::shared::tie objects back shared_sv * */
705shared_sv *
706SV_to_sharedsv(pTHX_ SV *sv)
ba14dd9a 707{
21312124
NIS
708 shared_sv *shared = 0;
709 if (SvROK(sv))
710 {
711 shared = INT2PTR(shared_sv *, SvIV(SvRV(sv)));
712 }
713 return shared;
b050c948
AB
714}
715
21312124 716MODULE = threads::shared PACKAGE = threads::shared::tie
b050c948 717
21312124 718PROTOTYPES: DISABLE
b050c948 719
21312124
NIS
720void
721PUSH(shared_sv *shared, ...)
722CODE:
723 dTHXc;
724 int i;
21312124
NIS
725 for(i = 1; i < items; i++) {
726 SV* tmp = newSVsv(ST(i));
a446a88f
NIS
727 shared_sv *target;
728 SHARED_LOCK;
729 target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
21312124
NIS
730 SHARED_CONTEXT;
731 av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
a446a88f 732 SHARED_RELEASE;
21312124
NIS
733 SvREFCNT_dec(tmp);
734 }
b050c948 735
21312124
NIS
736void
737UNSHIFT(shared_sv *shared, ...)
738CODE:
739 dTHXc;
740 int i;
741 SHARED_LOCK;
742 SHARED_CONTEXT;
743 av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
744 CALLER_CONTEXT;
745 for(i = 1; i < items; i++) {
746 SV* tmp = newSVsv(ST(i));
747 shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
748 SHARED_CONTEXT;
749 av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
750 CALLER_CONTEXT;
751 SvREFCNT_dec(tmp);
752 }
753 SHARED_UNLOCK;
b050c948 754
21312124
NIS
755void
756POP(shared_sv *shared)
757CODE:
758 dTHXc;
759 SV* sv;
760 SHARED_LOCK;
761 SHARED_CONTEXT;
762 sv = av_pop((AV*)SHAREDSvPTR(shared));
763 CALLER_CONTEXT;
764 ST(0) = Nullsv;
765 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
766 SHARED_UNLOCK;
767 XSRETURN(1);
b050c948 768
21312124
NIS
769void
770SHIFT(shared_sv *shared)
771CODE:
772 dTHXc;
773 SV* sv;
774 SHARED_LOCK;
775 SHARED_CONTEXT;
776 sv = av_shift((AV*)SHAREDSvPTR(shared));
777 CALLER_CONTEXT;
778 ST(0) = Nullsv;
779 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
780 SHARED_UNLOCK;
781 XSRETURN(1);
b050c948 782
21312124
NIS
783void
784EXTEND(shared_sv *shared, IV count)
785CODE:
786 dTHXc;
787 SHARED_EDIT;
788 av_extend((AV*)SHAREDSvPTR(shared), count);
789 SHARED_RELEASE;
b050c948 790
21312124
NIS
791void
792EXISTS(shared_sv *shared, SV *index)
793CODE:
794 dTHXc;
795 bool exists;
796 SHARED_EDIT;
797 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
798 exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
799 }
800 else {
801 exists = hv_exists_ent((HV*) SHAREDSvPTR(shared), index, 0);
802 }
803 SHARED_RELEASE;
804 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
805 XSRETURN(1);
b050c948 806
21312124
NIS
807void
808STORESIZE(shared_sv *shared,IV count)
809CODE:
810 dTHXc;
811 SHARED_EDIT;
812 av_fill((AV*) SHAREDSvPTR(shared), count);
813 SHARED_RELEASE;
b050c948
AB
814
815void
21312124
NIS
816FIRSTKEY(shared_sv *shared)
817CODE:
818 dTHXc;
819 char* key = NULL;
820 I32 len = 0;
821 HE* entry;
822 SHARED_LOCK;
823 SHARED_CONTEXT;
824 hv_iterinit((HV*) SHAREDSvPTR(shared));
825 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
826 if (entry) {
827 key = hv_iterkey(entry,&len);
828 CALLER_CONTEXT;
829 ST(0) = sv_2mortal(newSVpv(key, len));
830 } else {
831 CALLER_CONTEXT;
832 ST(0) = &PL_sv_undef;
833 }
834 SHARED_UNLOCK;
835 XSRETURN(1);
b050c948 836
866fba46 837void
21312124
NIS
838NEXTKEY(shared_sv *shared, SV *oldkey)
839CODE:
840 dTHXc;
841 char* key = NULL;
842 I32 len = 0;
843 HE* entry;
844 SHARED_LOCK;
845 SHARED_CONTEXT;
846 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
847 if(entry) {
848 key = hv_iterkey(entry,&len);
849 CALLER_CONTEXT;
850 ST(0) = sv_2mortal(newSVpv(key, len));
851 } else {
852 CALLER_CONTEXT;
853 ST(0) = &PL_sv_undef;
854 }
855 SHARED_UNLOCK;
856 XSRETURN(1);
857
858MODULE = threads::shared PACKAGE = threads::shared
859
860PROTOTYPES: ENABLE
866fba46 861
68795e93 862void
a446a88f
NIS
863_thrcnt(SV *ref)
864 PROTOTYPE: \[$@%]
865CODE:
866 shared_sv *shared;
867 if(SvROK(ref))
868 ref = SvRV(ref);
869 if (shared = Perl_sharedsv_find(aTHX_ ref)) {
870 if (SHAREDSvPTR(shared)) {
871 ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
872 XSRETURN(1);
873 }
874 else {
875 Perl_warn(aTHX_ "%_ s=%p has no shared SV",ST(0),shared);
876 }
877 }
878 else {
879 Perl_warn(aTHX_ "%_ is not shared",ST(0));
880 }
881 XSRETURN_UNDEF;
882
883void
884share(SV *ref)
885 PROTOTYPE: \[$@%]
886 CODE:
887 if(SvROK(ref))
888 ref = SvRV(ref);
889 Perl_sharedsv_share(aTHX, ref);
890
891void
21312124 892lock_enabled(SV *ref)
ce127893 893 PROTOTYPE: \[$@%]
6f942b98
AB
894 CODE:
895 shared_sv* shared;
896 if(SvROK(ref))
897 ref = SvRV(ref);
898 shared = Perl_sharedsv_find(aTHX, ref);
21312124
NIS
899 if(!shared)
900 croak("lock can only be used on shared values");
901 Perl_sharedsv_lock(aTHX_ shared);
6f942b98
AB
902
903void
21312124 904cond_wait_enabled(SV *ref)
ce127893 905 PROTOTYPE: \[$@%]
6f942b98
AB
906 CODE:
907 shared_sv* shared;
908 int locks;
909 if(SvROK(ref))
910 ref = SvRV(ref);
911 shared = Perl_sharedsv_find(aTHX_ ref);
912 if(!shared)
913 croak("cond_wait can only be used on shared values");
21312124 914 if(shared->owner != aTHX)
6f942b98
AB
915 croak("You need a lock before you can cond_wait");
916 MUTEX_LOCK(&shared->mutex);
917 shared->owner = NULL;
918 locks = shared->locks = 0;
919 COND_WAIT(&shared->user_cond, &shared->mutex);
21312124 920 shared->owner = aTHX;
6f942b98 921 shared->locks = locks;
a6b94e59 922 MUTEX_UNLOCK(&shared->mutex);
6f942b98 923
21312124
NIS
924void
925cond_signal_enabled(SV *ref)
ce127893 926 PROTOTYPE: \[$@%]
6f942b98
AB
927 CODE:
928 shared_sv* shared;
929 if(SvROK(ref))
930 ref = SvRV(ref);
931 shared = Perl_sharedsv_find(aTHX_ ref);
932 if(!shared)
933 croak("cond_signal can only be used on shared values");
934 COND_SIGNAL(&shared->user_cond);
935
21312124
NIS
936void
937cond_broadcast_enabled(SV *ref)
ce127893 938 PROTOTYPE: \[$@%]
6f942b98
AB
939 CODE:
940 shared_sv* shared;
941 if(SvROK(ref))
942 ref = SvRV(ref);
943 shared = Perl_sharedsv_find(aTHX_ ref);
944 if(!shared)
945 croak("cond_broadcast can only be used on shared values");
946 COND_BROADCAST(&shared->user_cond);
b050c948 947
68795e93
NIS
948BOOT:
949{
950 Perl_sharedsv_init(aTHX);
951}