3 * Copyright (c) 2001, Larry Wall
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.
8 * "Hand any two wizards a piece of rope and they would instinctively pull in
9 * opposite directions."
12 * Contributed by Arthur Bergman arthur@contiller.se
13 * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net
16 #define PERL_NO_GET_CONTEXT
21 #define SHAREDSvPTR(a) ((a)->sv)
24 * The shared things need an intepreter to live in ...
26 PerlInterpreter *PL_sharedsv_space; /* The shared sv space */
27 /* To access shared space we fake aTHX in this scope and thread's context */
28 #define SHARED_CONTEXT PERL_SET_CONTEXT((aTHX = PL_sharedsv_space))
30 /* So we need a way to switch back to the caller's context... */
31 /* So we declare _another_ copy of the aTHX variable ... */
32 #define dTHXc PerlInterpreter *caller_perl = aTHX
33 /* and use it to switch back */
34 #define CALLER_CONTEXT PERL_SET_CONTEXT((aTHX = caller_perl))
37 * Only one thread at a time is allowed to mess with shared space.
43 PerlInterpreter *owner;
52 recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */
55 recursive_lock_init(pTHX_ recursive_lock_t *lock)
57 Zero(lock,1,recursive_lock_t);
58 MUTEX_INIT(&lock->mutex);
59 COND_INIT(&lock->cond);
63 recursive_lock_release(pTHX_ recursive_lock_t *lock)
65 MUTEX_LOCK(&lock->mutex);
66 if (lock->owner != aTHX) {
67 MUTEX_UNLOCK(&lock->mutex);
70 if (--lock->locks == 0) {
72 COND_SIGNAL(&lock->cond);
75 MUTEX_UNLOCK(&lock->mutex);
79 recursive_lock_acquire(pTHX_ recursive_lock_t *lock,char *file,int line)
82 MUTEX_LOCK(&lock->mutex);
83 if (lock->owner == aTHX) {
89 Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
90 aTHX, lock->owner, lock->file, lock->line);
92 COND_WAIT(&lock->cond,&lock->mutex);
101 MUTEX_UNLOCK(&lock->mutex);
102 SAVEDESTRUCTOR_X(recursive_lock_release,lock);
105 #define ENTER_LOCK STMT_START { \
107 recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__); \
110 #define LEAVE_LOCK LEAVE
113 /* A common idiom is to acquire access and switch in ... */
114 #define SHARED_EDIT STMT_START { \
119 /* then switch out and release access. */
120 #define SHARED_RELEASE STMT_START { \
130 Shared SV is a structure for keeping the backend storage
133 Shared-ness really only needs the SV * - the rest is for locks.
134 (Which suggests further space optimization ... )
139 SV *sv; /* The actual SV - in shared space */
140 recursive_lock_t lock;
141 perl_cond user_cond; /* For user-level conditions */
144 /* The SV in shared-space has a back-pointer to the shared_sv
145 struct associated with it PERL_MAGIC_ext.
147 The vtable used has just one entry - when the SV goes away
148 we free the memory for the above.
153 sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
155 shared_sv *shared = (shared_sv *) mg->mg_ptr;
156 assert( aTHX == PL_sharedsv_space );
158 PerlMemShared_free(shared);
164 MGVTBL sharedsv_shared_vtbl = {
169 sharedsv_shared_mg_free, /* free */
174 /* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */
176 /* In any thread that has access to a shared thing there is a "proxy"
177 for it in its own space which has 'MAGIC' associated which accesses
181 MGVTBL sharedsv_scalar_vtbl; /* scalars have this vtable */
182 MGVTBL sharedsv_array_vtbl; /* hashes and arrays have this - like 'tie' */
183 MGVTBL sharedsv_elem_vtbl; /* elements of hashes and arrays have this
184 _AS WELL AS_ the scalar magic */
186 /* The sharedsv_elem_vtbl associates the element with the array/hash and
187 the sharedsv_scalar_vtbl associates it with the value
191 /* Accessor to convert threads::shared::tie objects back shared_sv * */
193 SV_to_sharedsv(pTHX_ SV *sv)
195 shared_sv *shared = 0;
198 shared = INT2PTR(shared_sv *, SvIV(SvRV(sv)));
203 =for apidoc sharedsv_find
205 Given a private side SV tries to find if the SV has a shared backend,
206 by looking for the magic.
211 Perl_sharedsv_find(pTHX_ SV *sv)
214 if (SvTYPE(sv) >= SVt_PVMG) {
218 if ((mg = mg_find(sv, PERL_MAGIC_tied))
219 && mg->mg_virtual == &sharedsv_array_vtbl) {
220 return (shared_sv *) mg->mg_ptr;
224 /* This should work for elements as well as they
225 * have scalar magic as well as their element magic
227 if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
228 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
229 return (shared_sv *) mg->mg_ptr;
234 /* Just for tidyness of API also handle tie objects */
235 if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
236 return SV_to_sharedsv(aTHX_ sv);
242 * Almost all the pain is in this routine.
247 Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
251 SV *sv = (psv) ? *psv : Nullsv;
253 /* If we are asked for an private ops we need a thread */
254 assert ( aTHX != PL_sharedsv_space );
256 /* To avoid need for recursive locks require caller to hold lock */
257 assert ( PL_sharedsv_lock.owner == aTHX );
259 /* First try and get existing global data structure */
261 /* Try shared SV as 1st choice */
262 if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
263 if (mg = mg_find(ssv, PERL_MAGIC_ext)) {
264 data = (shared_sv *) mg->mg_ptr;
268 /* Next see if private SV is associated with something */
270 data = Perl_sharedsv_find(aTHX_ sv);
273 /* If neither of those then create a new one */
278 data = PerlMemShared_malloc(sizeof(shared_sv));
279 Zero(data,1,shared_sv);
280 SHAREDSvPTR(data) = ssv;
281 /* Tag shared side SV with data pointer */
282 sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
284 recursive_lock_init(aTHX_ &data->lock);
285 COND_INIT(&data->user_cond);
290 ssv = SHAREDSvPTR(data);
291 if (!SHAREDSvPTR(data))
292 SHAREDSvPTR(data) = ssv;
294 /* If we know type upgrade shared side SV */
295 if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
297 sv_upgrade(ssv, SvTYPE(*psv));
301 /* Now if requested allocate private SV */
303 *psv = sv = newSV(0);
306 /* Finally if private SV exists check and add magic */
309 if (SvTYPE(sv) < SvTYPE(ssv)) {
310 sv_upgrade(sv, SvTYPE(ssv));
315 if (!(mg = mg_find(sv, PERL_MAGIC_tied))
316 || mg->mg_virtual != &sharedsv_array_vtbl
317 || (shared_sv *) mg->mg_ptr != data) {
319 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
321 sv_unmagic(sv, PERL_MAGIC_tied);
323 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
325 mg->mg_flags |= (MGf_COPY|MGf_DUP);
332 if ((SvTYPE(sv) < SVt_PVMG)
333 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
334 || mg->mg_virtual != &sharedsv_scalar_vtbl
335 || (shared_sv *) mg->mg_ptr != data) {
337 sv_unmagic(sv, PERL_MAGIC_shared_scalar);
339 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
340 &sharedsv_scalar_vtbl, (char *)data, 0);
341 mg->mg_flags |= (MGf_COPY|MGf_DUP);
346 assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
352 Perl_sharedsv_free(pTHX_ shared_sv *shared)
357 SvREFCNT_dec(SHAREDSvPTR(shared));
363 Perl_sharedsv_share(pTHX_ SV *sv)
367 Perl_croak(aTHX_ "Cannot share globs yet");
371 Perl_croak(aTHX_ "Cannot share subs yet");
376 Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
383 /* MAGIC (in mg.h sense) hooks */
386 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
388 shared_sv *shared = (shared_sv *) mg->mg_ptr;
392 if (SHAREDSvPTR(shared)) {
393 if (SvROK(SHAREDSvPTR(shared))) {
395 Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
396 sv_setsv_nomg(sv, &PL_sv_undef);
401 sv_setsv_nomg(sv, SHAREDSvPTR(shared));
409 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
414 shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
418 tmp = newRV(SHAREDSvPTR(target));
419 sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
430 sv_setsv_nomg(SHAREDSvPTR(shared), sv);
434 Perl_croak(aTHX_ "Invalid value for shared scalar");
439 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
443 /* We call associate to potentially upgrade shared side SV */
444 shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
446 sharedsv_scalar_store(aTHX_ sv, shared);
452 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
454 shared_sv *shared = (shared_sv *) mg->mg_ptr;
456 assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
458 Perl_sharedsv_free(aTHX_ shared);
463 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
469 * Called during cloning of new threads
472 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
474 shared_sv *shared = (shared_sv *) mg->mg_ptr;
476 SvREFCNT_inc(SHAREDSvPTR(shared));
481 MGVTBL sharedsv_scalar_vtbl = {
482 sharedsv_scalar_mg_get, /* get */
483 sharedsv_scalar_mg_set, /* set */
485 sharedsv_scalar_mg_clear, /* clear */
486 sharedsv_scalar_mg_free, /* free */
488 sharedsv_scalar_mg_dup /* dup */
491 /* Now the arrays/hashes stuff */
493 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
496 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
497 shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
501 assert ( SHAREDSvPTR(shared) );
505 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
506 assert ( mg->mg_ptr == 0 );
508 svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
511 char *key = mg->mg_ptr;
512 STRLEN len = mg->mg_len;
513 assert ( mg->mg_ptr != 0 );
514 if (mg->mg_len == HEf_SVKEY) {
515 key = SvPV((SV *) mg->mg_ptr, len);
518 svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
522 /* Exists in the array */
523 target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
527 /* Not in the array */
528 sv_setsv(sv, &PL_sv_undef);
535 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
538 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
541 /* Theory - SV itself is magically shared - and we have ordered the
542 magic such that by the time we get here it has been stored
543 to its shared counterpart
547 assert(SHAREDSvPTR(shared));
548 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
549 assert ( mg->mg_ptr == 0 );
551 svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
554 char *key = mg->mg_ptr;
555 STRLEN len = mg->mg_len;
556 assert ( mg->mg_ptr != 0 );
557 if (mg->mg_len == HEf_SVKEY)
558 key = SvPV((SV *) mg->mg_ptr, len);
560 svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
563 target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
564 sharedsv_scalar_store(aTHX_ sv, target);
570 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
573 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
575 sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
576 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
578 av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
581 char *key = mg->mg_ptr;
582 STRLEN len = mg->mg_len;
583 assert ( mg->mg_ptr != 0 );
584 if (mg->mg_len == HEf_SVKEY)
585 key = SvPV((SV *) mg->mg_ptr, len);
587 hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
595 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
597 Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
602 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
604 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
605 SvREFCNT_inc(SHAREDSvPTR(shared));
606 mg->mg_flags |= MGf_DUP;
610 MGVTBL sharedsv_elem_vtbl = {
611 sharedsv_elem_mg_FETCH, /* get */
612 sharedsv_elem_mg_STORE, /* set */
614 sharedsv_elem_mg_DELETE, /* clear */
615 sharedsv_elem_mg_free, /* free */
617 sharedsv_elem_mg_dup /* dup */
621 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
624 shared_sv *shared = (shared_sv *) mg->mg_ptr;
627 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
628 val = av_len((AV*) SHAREDSvPTR(shared));
631 /* not actually defined by tie API but ... */
632 val = HvKEYS((HV*) SHAREDSvPTR(shared));
639 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
642 shared_sv *shared = (shared_sv *) mg->mg_ptr;
644 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
645 av_clear((AV*) SHAREDSvPTR(shared));
648 hv_clear((HV*) SHAREDSvPTR(shared));
655 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
657 Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
662 * This is called when perl is about to access an element of
666 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
667 SV *nsv, const char *name, int namlen)
669 shared_sv *shared = (shared_sv *) mg->mg_ptr;
670 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
671 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
673 SvREFCNT_inc(SHAREDSvPTR(shared));
674 nmg->mg_flags |= MGf_DUP;
679 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
681 shared_sv *shared = (shared_sv *) mg->mg_ptr;
682 SvREFCNT_inc(SHAREDSvPTR(shared));
683 mg->mg_flags |= MGf_DUP;
687 MGVTBL sharedsv_array_vtbl = {
690 sharedsv_array_mg_FETCHSIZE, /* len */
691 sharedsv_array_mg_CLEAR, /* clear */
692 sharedsv_array_mg_free, /* free */
693 sharedsv_array_mg_copy, /* copy */
694 sharedsv_array_mg_dup /* dup */
697 =for apidoc sharedsv_unlock
699 Recursively unlocks a shared sv.
704 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
706 recursive_lock_release(aTHX_ &ssv->lock);
709 =for apidoc sharedsv_lock
711 Recursive locks on a sharedsv.
712 Locks are dynamically scoped at the level of the first lock.
717 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
721 recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
725 Perl_sharedsv_locksv(pTHX_ SV *sv)
727 Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv));
730 =head1 Shared SV Functions
732 =for apidoc sharedsv_init
734 Saves a space for keeping SVs wider than an interpreter,
735 currently only stores a pointer to the first interpreter.
740 Perl_sharedsv_init(pTHX)
743 /* This pair leaves us in shared context ... */
744 PL_sharedsv_space = perl_alloc();
745 perl_construct(PL_sharedsv_space);
747 recursive_lock_init(aTHX_ &PL_sharedsv_lock);
748 PL_lockhook = &Perl_sharedsv_locksv;
749 PL_sharehook = &Perl_sharedsv_share;
752 MODULE = threads::shared PACKAGE = threads::shared::tie
758 PUSH(shared_sv *shared, ...)
762 for(i = 1; i < items; i++) {
763 SV* tmp = newSVsv(ST(i));
766 target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
767 sharedsv_scalar_store(aTHX_ tmp, target);
769 av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
775 UNSHIFT(shared_sv *shared, ...)
781 av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
783 for(i = 1; i < items; i++) {
784 SV* tmp = newSVsv(ST(i));
785 shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
786 sharedsv_scalar_store(aTHX_ tmp, target);
788 av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
795 POP(shared_sv *shared)
801 sv = av_pop((AV*)SHAREDSvPTR(shared));
804 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
809 SHIFT(shared_sv *shared)
815 sv = av_shift((AV*)SHAREDSvPTR(shared));
818 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
823 EXTEND(shared_sv *shared, IV count)
827 av_extend((AV*)SHAREDSvPTR(shared), count);
831 STORESIZE(shared_sv *shared,IV count)
835 av_fill((AV*) SHAREDSvPTR(shared), count);
842 EXISTS(shared_sv *shared, SV *index)
847 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
848 exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
852 char *key = SvPV(index,len);
853 exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
856 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
861 FIRSTKEY(shared_sv *shared)
869 hv_iterinit((HV*) SHAREDSvPTR(shared));
870 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
872 key = hv_iterkey(entry,&len);
874 ST(0) = sv_2mortal(newSVpv(key, len));
877 ST(0) = &PL_sv_undef;
883 NEXTKEY(shared_sv *shared, SV *oldkey)
891 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
893 key = hv_iterkey(entry,&len);
895 ST(0) = sv_2mortal(newSVpv(key, len));
898 ST(0) = &PL_sv_undef;
903 MODULE = threads::shared PACKAGE = threads::shared
914 if (shared = Perl_sharedsv_find(aTHX_ ref)) {
915 ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
928 if (shared = Perl_sharedsv_find(aTHX_ ref)) {
929 if (SHAREDSvPTR(shared)) {
930 ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
934 Perl_warn(aTHX_ "%_ s=%p has no shared SV",ST(0),shared);
938 Perl_warn(aTHX_ "%_ is not shared",ST(0));
948 Perl_sharedsv_share(aTHX, ref);
951 lock_enabled(SV *ref)
957 shared = Perl_sharedsv_find(aTHX, ref);
959 croak("lock can only be used on shared values");
960 Perl_sharedsv_lock(aTHX_ shared);
963 cond_wait_enabled(SV *ref)
970 shared = Perl_sharedsv_find(aTHX_ ref);
972 croak("cond_wait can only be used on shared values");
973 if(shared->lock.owner != aTHX)
974 croak("You need a lock before you can cond_wait");
975 /* Stealing the members of the lock object worries me - NI-S */
976 MUTEX_LOCK(&shared->lock.mutex);
977 shared->lock.owner = NULL;
978 locks = shared->lock.locks = 0;
979 COND_WAIT(&shared->user_cond, &shared->lock.mutex);
980 shared->lock.owner = aTHX;
981 shared->lock.locks = locks;
982 MUTEX_UNLOCK(&shared->lock.mutex);
985 cond_signal_enabled(SV *ref)
991 shared = Perl_sharedsv_find(aTHX_ ref);
993 croak("cond_signal can only be used on shared values");
994 COND_SIGNAL(&shared->user_cond);
997 cond_broadcast_enabled(SV *ref)
1003 shared = Perl_sharedsv_find(aTHX_ ref);
1005 croak("cond_broadcast can only be used on shared values");
1006 COND_BROADCAST(&shared->user_cond);
1010 Perl_sharedsv_init(aTHX);