shared.xs

source of perl for linux application,

    nmg->mg_flags |= MGf_DUP;
    return (1);
}

/* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */

int
sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
    SvREFCNT_inc_void((SV*)mg->mg_ptr);
    assert(mg->mg_flags & MGf_DUP);
    return (0);
}

MGVTBL sharedsv_array_vtbl = {
    0,                          /* get */
    0,                          /* set */
    sharedsv_array_mg_FETCHSIZE,/* len */
    sharedsv_array_mg_CLEAR,    /* clear */
    sharedsv_array_mg_free,     /* free */
    sharedsv_array_mg_copy,     /* copy */
    sharedsv_array_mg_dup,      /* dup */
#ifdef MGf_LOCAL
    0,                          /* local */
#endif
};


/* Recursively unlocks a shared sv. */

void
Perl_sharedsv_unlock(pTHX_ SV *ssv)
{
    user_lock *ul = S_get_userlock(aTHX_ ssv, 0);
    assert(ul);
    recursive_lock_release(aTHX_ &ul->lock);
}


/* Recursive locks on a sharedsv.
 * Locks are dynamically scoped at the level of the first lock.
 */
void
Perl_sharedsv_lock(pTHX_ SV *ssv)
{
    user_lock *ul;
    if (! ssv)
        return;
    ul = S_get_userlock(aTHX_ ssv, 1);
    recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__);
}

/* Handles calls from lock() builtin via PL_lockhook */

void
Perl_sharedsv_locksv(pTHX_ SV *sv)
{
    SV *ssv;

    if (SvROK(sv))
        sv = SvRV(sv);
    ssv = Perl_sharedsv_find(aTHX_ sv);
    if (!ssv)
       croak("lock can only be used on shared values");
    Perl_sharedsv_lock(aTHX_ ssv);
}


/* Saves a space for keeping SVs wider than an interpreter. */

void
Perl_sharedsv_init(pTHX)
{
    dTHXc;
    /* This pair leaves us in shared context ... */
    PL_sharedsv_space = perl_alloc();
    perl_construct(PL_sharedsv_space);
    CALLER_CONTEXT;
    recursive_lock_init(aTHX_ &PL_sharedsv_lock);
    PL_lockhook = &Perl_sharedsv_locksv;
    PL_sharehook = &Perl_sharedsv_share;
}

#endif /* USE_ITHREADS */

MODULE = threads::shared        PACKAGE = threads::shared::tie

PROTOTYPES: DISABLE

#ifdef USE_ITHREADS

void
PUSH(SV *obj, ...)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        int i;
        for (i = 1; i < items; i++) {
            SV* tmp = newSVsv(ST(i));
            SV *stmp;
            ENTER_LOCK;
            stmp = S_sharedsv_new_shared(aTHX_ tmp);
            sharedsv_scalar_store(aTHX_ tmp, stmp);
            SHARED_CONTEXT;
            av_push((AV*) sobj, stmp);
            SvREFCNT_inc_void(stmp);
            SHARED_RELEASE;
            SvREFCNT_dec(tmp);
        }


void
UNSHIFT(SV *obj, ...)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        int i;
        ENTER_LOCK;
        SHARED_CONTEXT;
        av_unshift((AV*)sobj, items - 1);
        CALLER_CONTEXT;
        for (i = 1; i < items; i++) {
            SV *tmp = newSVsv(ST(i));
            SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
            sharedsv_scalar_store(aTHX_ tmp, stmp);
            SHARED_CONTEXT;
            av_store((AV*) sobj, i - 1, stmp);
            SvREFCNT_inc_void(stmp);
            CALLER_CONTEXT;
            SvREFCNT_dec(tmp);
        }
        LEAVE_LOCK;


void
POP(SV *obj)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        SV* ssv;
        ENTER_LOCK;
        SHARED_CONTEXT;
        ssv = av_pop((AV*)sobj);
        CALLER_CONTEXT;
        ST(0) = sv_newmortal();
        Perl_sharedsv_associate(aTHX_ ST(0), ssv);
        SvREFCNT_dec(ssv);
        LEAVE_LOCK;
        /* XSRETURN(1); - implied */


void
SHIFT(SV *obj)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        SV* ssv;
        ENTER_LOCK;
        SHARED_CONTEXT;
        ssv = av_shift((AV*)sobj);
        CALLER_CONTEXT;
        ST(0) = sv_newmortal();
        Perl_sharedsv_associate(aTHX_ ST(0), ssv);
        SvREFCNT_dec(ssv);
        LEAVE_LOCK;
        /* XSRETURN(1); - implied */


void
EXTEND(SV *obj, IV count)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        SHARED_EDIT;
        av_extend((AV*)sobj, count);
        SHARED_RELEASE;


void
STORESIZE(SV *obj,IV count)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        SHARED_EDIT;
        av_fill((AV*) sobj, count);
        SHARED_RELEASE;


void
EXISTS(SV *obj, SV *index)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        bool exists;
        if (SvTYPE(sobj) == SVt_PVAV) {
            SHARED_EDIT;
            exists = av_exists((AV*) sobj, SvIV(index));
        } else {
            STRLEN len;
            char *key = SvPV(index,len);
            SHARED_EDIT;
            exists = hv_exists((HV*) sobj, key, len);
        }
        SHARED_RELEASE;
        ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
        /* XSRETURN(1); - implied */


void
FIRSTKEY(SV *obj)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        char* key = NULL;
        I32 len = 0;
        HE* entry;
        ENTER_LOCK;
        SHARED_CONTEXT;
        hv_iterinit((HV*) sobj);
        entry = hv_iternext((HV*) sobj);
        if (entry) {
            key = hv_iterkey(entry,&len);
            CALLER_CONTEXT;
            ST(0) = sv_2mortal(newSVpv(key, len));
        } else {
            CALLER_CONTEXT;
            ST(0) = &PL_sv_undef;
        }
        LEAVE_LOCK;
        /* XSRETURN(1); - implied */


void
NEXTKEY(SV *obj, SV *oldkey)
    CODE:
        dTHXc;
        SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
        char* key = NULL;
        I32 len = 0;
        HE* entry;

        PERL_UNUSED_VAR(oldkey);

        ENTER_LOCK;
        SHARED_CONTEXT;
        entry = hv_iternext((HV*) sobj);
        if (entry) {
            key = hv_iterkey(entry,&len);
            CALLER_CONTEXT;
            ST(0) = sv_2mortal(newSVpv(key, len));
        } else {
            CALLER_CONTEXT;
            ST(0) = &PL_sv_undef;
        }
        LEAVE_LOCK;
        /* XSRETURN(1); - implied */


MODULE = threads::shared        PACKAGE = threads::shared

PROTOTYPES: ENABLE

void
_id(SV *myref)
    PROTOTYPE: \[$@%]
    PREINIT:
        SV *ssv;
    CODE:
        myref = SvRV(myref);
        if (SvROK(myref))
            myref = SvRV(myref);
        ssv = Perl_sharedsv_find(aTHX_ myref);
        if (! ssv)
            XSRETURN_UNDEF;
        ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
        /* XSRETURN(1); - implied */


void
_refcnt(SV *myref)
    PROTOTYPE: \[$@%]
    PREINIT:
        SV *ssv;
    CODE:
        myref = SvRV(myref);
        if (SvROK(myref))
            myref = SvRV(myref);
        ssv = Perl_sharedsv_find(aTHX_ myref);
        if (! ssv) {
            if (ckWARN(WARN_THREADS)) {
                Perl_warner(aTHX_ packWARN(WARN_THREADS),
                                "%" SVf " is not shared", ST(0));
            }
            XSRETURN_UNDEF;
        }
        ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
        /* XSRETURN(1); - implied */


void
share(SV *myref)
    PROTOTYPE: \[$@%]
    CODE:
        if (! SvROK(myref))
            Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
        myref = SvRV(myref);
        if (SvROK(myref))
            myref = SvRV(myref);
        Perl_sharedsv_share(aTHX_ myref);
        ST(0) = sv_2mortal(newRV_inc(myref));
        /* XSRETURN(1); - implied */


void
cond_wait(SV *ref_cond, SV *ref_lock = 0)
    PROTOTYPE: \[$@%];\[$@%]
    PREINIT:
        SV *ssv;
        perl_cond* user_condition;
        int locks;
        user_lock *ul;
    CODE:
        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);
        ssv = Perl_sharedsv_find(aTHX_ ref_cond);
        if (! ssv)
            Perl_croak(aTHX_ "cond_wait can only be used on shared values");
        ul = S_get_userlock(aTHX_ ssv, 1);

        user_condition = &ul->user_cond;
        if (ref_lock && (ref_cond != ref_lock)) {
            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);
            ssv = Perl_sharedsv_find(aTHX_ ref_lock);
            if (! ssv)
                Perl_croak(aTHX_ "cond_wait lock must be a shared value");
            ul = S_get_userlock(aTHX_ ssv, 1);
        }
        if (ul->lock.owner != aTHX)
            croak("You need a lock before you can cond_wait");

        /* Stealing the members of the lock object worries me - NI-S */
        MUTEX_LOCK(&ul->lock.mutex);
        ul->lock.owner = NULL;
        locks = ul->lock.locks;
        ul->lock.locks = 0;

        /* Since we are releasing the lock here, we need to tell other
         * people that it is ok to go ahead and use it */
        COND_SIGNAL(&ul->lock.cond);
        COND_WAIT(user_condition, &ul->lock.mutex);
        while (ul->lock.owner != NULL) {
            /* OK -- must reacquire the lock */
            COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
        }
        ul->lock.owner = aTHX;
        ul->lock.locks = locks;
        MUTEX_UNLOCK(&ul->lock.mutex);


int
cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0)
    PROTOTYPE: \[$@%]$;\[$@%]
    PREINIT:
        SV *ssv;
        perl_cond* user_condition;
        int locks;
        user_lock *ul;
    CODE:
        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);
        ssv = Perl_sharedsv_find(aTHX_ ref_cond);
        if (! ssv)
            Perl_croak(aTHX_ "cond_timedwait can only be used on shared values");
        ul = S_get_userlock(aTHX_ ssv, 1);

        user_condition = &ul->user_cond;
        if (ref_lock && (ref_cond != ref_lock)) {
            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);
            ssv = Perl_sharedsv_find(aTHX_ ref_lock);
            if (! ssv)
                Perl_croak(aTHX_ "cond_timedwait lock must be a shared value");
            ul = S_get_userlock(aTHX_ ssv, 1);
        }
        if (ul->lock.owner != aTHX)
            Perl_croak(aTHX_ "You need a lock before you can cond_wait");

        MUTEX_LOCK(&ul->lock.mutex);
        ul->lock.owner = NULL;
        locks = ul->lock.locks;
        ul->lock.locks = 0;
        /* Since we are releasing the lock here, we need to tell other
         * people that it is ok to go ahead and use it */
        COND_SIGNAL(&ul->lock.cond);
        RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs);
        while (ul->lock.owner != NULL) {
            /* OK -- must reacquire the lock... */
            COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
        }
        ul->lock.owner = aTHX;
        ul->lock.locks = locks;
        MUTEX_UNLOCK(&ul->lock.mutex);

        if (RETVAL == 0)
            XSRETURN_UNDEF;
    OUTPUT:
        RETVAL


void
cond_signal(SV *myref)
    PROTOTYPE: \[$@%]
    PREINIT:
        SV *ssv;
        user_lock *ul;
    CODE:
        if (! SvROK(myref))
            Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
        myref = SvRV(myref);
        if (SvROK(myref))
            myref = SvRV(myref);
        ssv = Perl_sharedsv_find(aTHX_ myref);
        if (! ssv)
            Perl_croak(aTHX_ "cond_signal can only be used on shared values");
        ul = S_get_userlock(aTHX_ ssv, 1);
        if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
            Perl_warner(aTHX_ packWARN(WARN_THREADS),
                            "cond_signal() called on unlocked variable");
        }
        COND_SIGNAL(&ul->user_cond);


void
cond_broadcast(SV *myref)
    PROTOTYPE: \[$@%]
    PREINIT:
        SV *ssv;
        user_lock *ul;
    CODE:
        if (! SvROK(myref))
            Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
        myref = SvRV(myref);
        if (SvROK(myref))
            myref = SvRV(myref);
        ssv = Perl_sharedsv_find(aTHX_ myref);
        if (! ssv)
            Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
        ul = S_get_userlock(aTHX_ ssv, 1);
        if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
            Perl_warner(aTHX_ packWARN(WARN_THREADS),
                            "cond_broadcast() called on unlocked variable");
        }
        COND_BROADCAST(&ul->user_cond);


void
bless(SV* myref, ...);
    PROTOTYPE: $;$
    PREINIT:
        HV* stash;
        SV *ssv;
    CODE:
        if (items == 1) {
            stash = CopSTASH(PL_curcop);
        } else {
            SV* classname = ST(1);
            STRLEN len;
            char *ptr;

            if (classname &&
                ! SvGMAGICAL(classname) &&
                ! SvAMAGIC(classname) &&
                SvROK(classname))
            {
                Perl_croak(aTHX_ "Attempt to bless into a reference");
            }
            ptr = SvPV(classname, 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_void(myref);
        (void)sv_bless(myref, stash);
        ST(0) = sv_2mortal(myref);
        ssv = Perl_sharedsv_find(aTHX_ myref);
        if (ssv) {
            dTHXc;
            ENTER_LOCK;
            SHARED_CONTEXT;
            {
                SV* fake_stash = newSVpv(HvNAME_get(stash), 0);
                (void)sv_bless(ssv, (HV*)fake_stash);
            }
            CALLER_CONTEXT;
            LEAVE_LOCK;
        }
        /* XSRETURN(1); - implied */

#endif /* USE_ITHREADS */

BOOT:
{
#ifdef USE_ITHREADS
     Perl_sharedsv_init(aTHX);
#endif /* USE_ITHREADS */
}