X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/caf25f3be4a66b8fbb51db2cfdfa658f6b9704e7..a5063e7cd8fef802efd25ffe9df2c3748f4254f6:/ext/threads/shared/shared.xs diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index 2a08fb0..18a752c 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -27,13 +27,29 @@ */ PerlInterpreter *PL_sharedsv_space; /* The shared sv space */ /* To access shared space we fake aTHX in this scope and thread's context */ -#define SHARED_CONTEXT PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)) + +/* bug #24255: we include ENTER+SAVETMPS/FREETMPS+LEAVE with + * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals etc created + * while in the shared interpreter context don't languish */ + +#define SHARED_CONTEXT \ + STMT_START { \ + PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \ + ENTER; \ + SAVETMPS; \ + } STMT_END /* So we need a way to switch back to the caller's context... */ /* So we declare _another_ copy of the aTHX variable ... */ #define dTHXc PerlInterpreter *caller_perl = aTHX + /* and use it to switch back */ -#define CALLER_CONTEXT PERL_SET_CONTEXT((aTHX = caller_perl)) +#define CALLER_CONTEXT \ + STMT_START { \ + FREETMPS; \ + LEAVE; \ + PERL_SET_CONTEXT((aTHX = caller_perl)); \ + } STMT_END /* * Only one thread at a time is allowed to mess with shared space. @@ -62,6 +78,13 @@ recursive_lock_init(pTHX_ recursive_lock_t *lock) } void +recursive_lock_destroy(pTHX_ recursive_lock_t *lock) +{ + MUTEX_DESTROY(&lock->mutex); + COND_DESTROY(&lock->cond); +} + +void recursive_lock_release(pTHX_ recursive_lock_t *lock) { MUTEX_LOCK(&lock->mutex); @@ -157,6 +180,8 @@ sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg) shared_sv *shared = (shared_sv *) mg->mg_ptr; assert( aTHX == PL_sharedsv_space ); if (shared) { + recursive_lock_destroy(aTHX_ &shared->lock); + COND_DESTROY(&shared->user_cond); PerlMemShared_free(shared); mg->mg_ptr = NULL; } @@ -171,6 +196,7 @@ MGVTBL sharedsv_shared_vtbl = { sharedsv_shared_mg_free, /* free */ 0, /* copy */ 0, /* dup */ + 0 /* local */ }; /* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */ @@ -275,9 +301,11 @@ Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data) /* If neither of those then create a new one */ if (!data) { SHARED_CONTEXT; - if (!ssv) + if (!ssv) { ssv = newSV(0); - data = PerlMemShared_malloc(sizeof(shared_sv)); + SvREFCNT(ssv) = 0; + } + data = (shared_sv *) PerlMemShared_malloc(sizeof(shared_sv)); Zero(data,1,shared_sv); SHAREDSvPTR(data) = ssv; /* Tag shared side SV with data pointer */ @@ -297,6 +325,8 @@ Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data) if (sv && SvTYPE(ssv) < SvTYPE(sv)) { SHARED_CONTEXT; sv_upgrade(ssv, SvTYPE(*psv)); + if (SvTYPE(ssv) == SVt_PVAV) /* #24061 */ + AvREAL_on(ssv); CALLER_CONTEXT; } @@ -327,6 +357,13 @@ Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data) mg->mg_flags |= (MGf_COPY|MGf_DUP); SvREFCNT_inc(ssv); SvREFCNT_dec(obj); + if(SvOBJECT(ssv)) { + STRLEN len; + char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len); + HV* stash = gv_stashpvn(stash_ptr, len, TRUE); + SvOBJECT_on(sv); + SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash)); + } } break; @@ -340,8 +377,15 @@ Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data) } mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &sharedsv_scalar_vtbl, (char *)data, 0); - mg->mg_flags |= (MGf_COPY|MGf_DUP); + mg->mg_flags |= (MGf_COPY|MGf_DUP|MGf_LOCAL); SvREFCNT_inc(ssv); + if(SvOBJECT(ssv)) { + STRLEN len; + char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len); + HV* stash = gv_stashpvn(stash_ptr, len, TRUE); + SvOBJECT_on(sv); + SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash)); + } } break; } @@ -382,6 +426,77 @@ Perl_sharedsv_share(pTHX_ SV *sv) } } +#if defined(WIN32) || defined(OS2) +# define ABS2RELMILLI(abs) \ + do { \ + abs -= (double)time(NULL); \ + if (abs > 0) { abs *= 1000; } \ + else { abs = 0; } \ + } while (0) +#endif /* WIN32 || OS2 */ + +bool +Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) +{ +#if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS) + Perl_croak_nocontext("cond_timedwait not supported on this platform"); +#else +# ifdef WIN32 + int got_it = 0; + + ABS2RELMILLI(abs); + + cond->waiters++; + MUTEX_UNLOCK(mut); + /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */ + switch (WaitForSingleObject(cond->sem, (DWORD)abs)) { + case WAIT_OBJECT_0: got_it = 1; break; + case WAIT_TIMEOUT: break; + default: + /* WAIT_FAILED? WAIT_ABANDONED? others? */ + Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError()); + break; + } + MUTEX_LOCK(mut); + cond->waiters--; + return got_it; +# else +# ifdef OS2 + int rc, got_it = 0; + STRLEN n_a; + + ABS2RELMILLI(abs); + + if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET)) + Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset"); + MUTEX_UNLOCK(mut); + if (CheckOSError(DosWaitEventSem(*cond,abs)) + && (rc != ERROR_INTERRUPT)) + croak_with_os2error("panic: cond_timedwait"); + if (rc == ERROR_INTERRUPT) errno = EINTR; + MUTEX_LOCK(mut); + return got_it; +# else /* hope you're I_PTHREAD! */ + struct timespec ts; + int got_it = 0; + + ts.tv_sec = (long)abs; + abs -= (NV)ts.tv_sec; + ts.tv_nsec = (long)(abs * 1000000000.0); + + switch (pthread_cond_timedwait(cond, mut, &ts)) { + case 0: got_it = 1; break; + case ETIMEDOUT: break; + default: + Perl_croak_nocontext("panic: cond_timedwait"); + break; + } + return got_it; +# endif /* OS2 */ +# endif /* WIN32 */ +#endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */ +} + /* MAGIC (in mg.h sense) hooks */ int @@ -396,8 +511,9 @@ sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) SV *obj = Nullsv; Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL); sv_setsv_nomg(sv, &PL_sv_undef); - SvRV(sv) = obj; + SvRV_set(sv, obj); SvROK_on(sv); + } else { sv_setsv_nomg(sv, SHAREDSvPTR(shared)); @@ -420,6 +536,11 @@ sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared) tmp = newRV(SHAREDSvPTR(target)); sv_setsv_nomg(SHAREDSvPTR(shared), tmp); SvREFCNT_dec(tmp); + if(SvOBJECT(SvRV(sv))) { + SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(SvRV(sv))),0); + SvOBJECT_on(SHAREDSvPTR(target)); + SvSTASH_set(SHAREDSvPTR(target), (HV*)fake_stash); + } CALLER_CONTEXT; } else { @@ -427,9 +548,14 @@ sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared) } } else { - SvTEMP_off(sv); + SvTEMP_off(sv); SHARED_CONTEXT; sv_setsv_nomg(SHAREDSvPTR(shared), sv); + if(SvOBJECT(sv)) { + SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); + SvOBJECT_on(SHAREDSvPTR(shared)); + SvSTASH_set(SHAREDSvPTR(shared), (HV*)fake_stash); + } CALLER_CONTEXT; } if (!allowed) { @@ -480,6 +606,28 @@ sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) return 0; } + +/* + * Called during local $shared + */ +int +sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg) +{ + MAGIC *nmg; + shared_sv *shared = (shared_sv *) mg->mg_ptr; + if (shared) { + ENTER_LOCK; + SvREFCNT_inc(SHAREDSvPTR(shared)); + LEAVE_LOCK; + } + nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual, + mg->mg_ptr, mg->mg_len); + nmg->mg_flags = mg->mg_flags; + nmg->mg_private = mg->mg_private; + + return 0; +} + MGVTBL sharedsv_scalar_vtbl = { sharedsv_scalar_mg_get, /* get */ sharedsv_scalar_mg_set, /* set */ @@ -487,7 +635,8 @@ MGVTBL sharedsv_scalar_vtbl = { sharedsv_scalar_mg_clear, /* clear */ sharedsv_scalar_mg_free, /* free */ 0, /* copy */ - sharedsv_scalar_mg_dup /* dup */ + sharedsv_scalar_mg_dup, /* dup */ + sharedsv_scalar_mg_local /* local */ }; /* Now the arrays/hashes stuff */ @@ -503,7 +652,6 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) assert ( SHAREDSvPTR(shared) ); ENTER_LOCK; - if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { assert ( mg->mg_ptr == 0 ); SHARED_CONTEXT; @@ -522,8 +670,18 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) CALLER_CONTEXT; if (svp) { /* Exists in the array */ - target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target); - sv_setsv(sv, *svp); + if (SvROK(*svp)) { + SV *obj = Nullsv; + Perl_sharedsv_associate(aTHX_ &obj, SvRV(*svp), NULL); + sv_setsv_nomg(sv, &PL_sv_undef); + SvRV_set(sv, obj); + SvROK_on(sv); + SvSETMAGIC(sv); + } + else { + target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target); + sv_setsv(sv, *svp); + } } else { /* Not in the array */ @@ -572,9 +730,12 @@ int sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) { dTHXc; + MAGIC *shmg; shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj); ENTER_LOCK; sharedsv_elem_mg_FETCH(aTHX_ sv, mg); + if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) + sharedsv_scalar_mg_get(aTHX_ sv, shmg); if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { SHARED_CONTEXT; av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD); @@ -616,7 +777,8 @@ MGVTBL sharedsv_elem_vtbl = { sharedsv_elem_mg_DELETE, /* clear */ sharedsv_elem_mg_free, /* free */ 0, /* copy */ - sharedsv_elem_mg_dup /* dup */ + sharedsv_elem_mg_dup, /* dup */ + 0 /* local */ }; U32 @@ -672,7 +834,9 @@ sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, toLOWER(mg->mg_type),&sharedsv_elem_vtbl, name, namlen); + ENTER_LOCK; SvREFCNT_inc(SHAREDSvPTR(shared)); + LEAVE_LOCK; nmg->mg_flags |= MGf_DUP; return 1; } @@ -693,7 +857,8 @@ MGVTBL sharedsv_array_vtbl = { sharedsv_array_mg_CLEAR, /* clear */ sharedsv_array_mg_free, /* free */ sharedsv_array_mg_copy, /* copy */ - sharedsv_array_mg_dup /* dup */ + sharedsv_array_mg_dup, /* dup */ + 0 /* local */ }; =for apidoc sharedsv_unlock @@ -780,6 +945,7 @@ CODE: sharedsv_scalar_store(aTHX_ tmp, target); SHARED_CONTEXT; av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target)); + SvREFCNT_inc(SHAREDSvPTR(target)); SHARED_RELEASE; SvREFCNT_dec(tmp); } @@ -799,6 +965,7 @@ CODE: sharedsv_scalar_store(aTHX_ tmp, target); SHARED_CONTEXT; av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target)); + SvREFCNT_inc(SHAREDSvPTR(target)); CALLER_CONTEXT; SvREFCNT_dec(tmp); } @@ -813,8 +980,9 @@ CODE: SHARED_CONTEXT; sv = av_pop((AV*)SHAREDSvPTR(shared)); CALLER_CONTEXT; - ST(0) = Nullsv; + ST(0) = sv_newmortal(); Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); + SvREFCNT_dec(sv); LEAVE_LOCK; XSRETURN(1); @@ -827,8 +995,9 @@ CODE: SHARED_CONTEXT; sv = av_shift((AV*)SHAREDSvPTR(shared)); CALLER_CONTEXT; - ST(0) = Nullsv; + ST(0) = sv_newmortal(); Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); + SvREFCNT_dec(sv); LEAVE_LOCK; XSRETURN(1); @@ -856,13 +1025,14 @@ EXISTS(shared_sv *shared, SV *index) CODE: dTHXc; bool exists; - SHARED_EDIT; if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + SHARED_EDIT; exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index)); } else { STRLEN len; char *key = SvPV(index,len); + SHARED_EDIT; exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len); } SHARED_RELEASE; @@ -958,6 +1128,8 @@ SV* share(SV *ref) PROTOTYPE: \[$@%] CODE: + if(!SvROK(ref)) + Perl_croak(aTHX_ "Argument to share needs to be passed as ref"); ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); @@ -971,6 +1143,8 @@ lock_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: shared_sv* shared; + if(!SvROK(ref)) + Perl_croak(aTHX_ "Argument to lock needs to be passed as ref"); ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); @@ -980,17 +1154,36 @@ lock_enabled(SV *ref) Perl_sharedsv_lock(aTHX_ shared); void -cond_wait_enabled(SV *ref) - PROTOTYPE: \[$@%] - CODE: +cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0) + PROTOTYPE: \[$@%];\[$@%] + PREINIT: shared_sv* shared; + perl_cond* user_condition; int locks; - ref = SvRV(ref); - if(SvROK(ref)) - ref = SvRV(ref); - shared = Perl_sharedsv_find(aTHX_ ref); + int same = 0; + + CODE: + if (!ref_lock || ref_lock == ref_cond) same = 1; + + if(!SvROK(ref_cond)) + Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); + ref_cond = SvRV(ref_cond); + if(SvROK(ref_cond)) + ref_cond = SvRV(ref_cond); + shared = Perl_sharedsv_find(aTHX_ ref_cond); if(!shared) croak("cond_wait can only be used on shared values"); + + user_condition = &shared->user_cond; + if (! same) { + if (!SvROK(ref_lock)) + Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); + ref_lock = SvRV(ref_lock); + if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); + shared = Perl_sharedsv_find(aTHX_ ref_lock); + if (!shared) + croak("cond_wait lock must be a shared value"); + } if(shared->lock.owner != aTHX) croak("You need a lock before you can cond_wait"); /* Stealing the members of the lock object worries me - NI-S */ @@ -1002,28 +1195,86 @@ cond_wait_enabled(SV *ref) /* since we are releasing the lock here we need to tell other people that is ok to go ahead and use it */ COND_SIGNAL(&shared->lock.cond); - COND_WAIT(&shared->user_cond, &shared->lock.mutex); + COND_WAIT(user_condition, &shared->lock.mutex); while(shared->lock.owner != NULL) { - COND_WAIT(&shared->lock.cond,&shared->lock.mutex); - } + /* OK -- must reacquire the lock */ + COND_WAIT(&shared->lock.cond, &shared->lock.mutex); + } + shared->lock.owner = aTHX; + shared->lock.locks = locks; + MUTEX_UNLOCK(&shared->lock.mutex); + +int +cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0) + PROTOTYPE: \[$@%]$;\[$@%] + PREINIT: + shared_sv* shared; + perl_cond* user_condition; + int locks; + int same = 0; + + CODE: + if (!ref_lock || ref_cond == ref_lock) same = 1; + + if(!SvROK(ref_cond)) + Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); + ref_cond = SvRV(ref_cond); + if(SvROK(ref_cond)) + ref_cond = SvRV(ref_cond); + shared = Perl_sharedsv_find(aTHX_ ref_cond); + if(!shared) + croak("cond_timedwait can only be used on shared values"); + + user_condition = &shared->user_cond; + if (! same) { + if (!SvROK(ref_lock)) + Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); + ref_lock = SvRV(ref_lock); + if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); + shared = Perl_sharedsv_find(aTHX_ ref_lock); + if (!shared) + croak("cond_timedwait lock must be a shared value"); + } + if(shared->lock.owner != aTHX) + croak("You need a lock before you can cond_wait"); + + MUTEX_LOCK(&shared->lock.mutex); + shared->lock.owner = NULL; + locks = shared->lock.locks; + shared->lock.locks = 0; + /* since we are releasing the lock here we need to tell other + people that is ok to go ahead and use it */ + COND_SIGNAL(&shared->lock.cond); + RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs); + while (shared->lock.owner != NULL) { + /* OK -- must reacquire the lock... */ + COND_WAIT(&shared->lock.cond, &shared->lock.mutex); + } shared->lock.owner = aTHX; shared->lock.locks = locks; MUTEX_UNLOCK(&shared->lock.mutex); + if (RETVAL == 0) + XSRETURN_UNDEF; + OUTPUT: + RETVAL + void cond_signal_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: shared_sv* shared; + if(!SvROK(ref)) + Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); shared = Perl_sharedsv_find(aTHX_ ref); + if(!shared) + croak("cond_signal can only be used on shared values"); if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX) Perl_warner(aTHX_ packWARN(WARN_THREADS), "cond_signal() called on unlocked variable"); - if(!shared) - croak("cond_signal can only be used on shared values"); COND_SIGNAL(&shared->user_cond); void @@ -1031,6 +1282,8 @@ cond_broadcast_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: shared_sv* shared; + if(!SvROK(ref)) + Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); @@ -1042,6 +1295,48 @@ cond_broadcast_enabled(SV *ref) "cond_broadcast() called on unlocked variable"); COND_BROADCAST(&shared->user_cond); + +SV* +bless(SV* ref, ...); + PROTOTYPE: $;$ + CODE: + { + HV* stash; + shared_sv* shared; + if (items == 1) + stash = CopSTASH(PL_curcop); + else { + SV* ssv = ST(1); + STRLEN len; + char *ptr; + + if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) + Perl_croak(aTHX_ "Attempt to bless into a reference"); + ptr = SvPV(ssv,len); + if (ckWARN(WARN_MISC) && len == 0) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Explicit blessing to '' (assuming package main)"); + stash = gv_stashpvn(ptr, len, TRUE); + } + SvREFCNT_inc(ref); + (void)sv_bless(ref, stash); + RETVAL = ref; + shared = Perl_sharedsv_find(aTHX_ ref); + if(shared) { + dTHXc; + ENTER_LOCK; + SHARED_CONTEXT; + { + SV* fake_stash = newSVpv(HvNAME_get(stash),0); + (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash); + } + CALLER_CONTEXT; + LEAVE_LOCK; + } + } + OUTPUT: + RETVAL + #endif /* USE_ITHREADS */ BOOT: