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