shared.xs

source of perl for linux application,

/*    shared.xs
 *
 *    Copyright (c) 2001-2002, 2006 Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 * "Hand any two wizards a piece of rope and they would instinctively pull in
 * opposite directions."
 *                         --Sourcery
 *
 * Contributed by Artur Bergman <sky AT crucially DOT net>
 * Pulled in the (an)other direction by Nick Ing-Simmons
 *      <nick AT ing-simmons DOT net>
 * CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org>
 */

/*
 * Shared variables are implemented by a scheme similar to tieing.
 * Each thread has a proxy SV with attached magic -- "private SVs" --
 * which all point to a single SV in a separate shared interpreter
 * (PL_sharedsv_space) -- "shared SVs".
 *
 * The shared SV holds the variable's true values, and its state is
 * copied between the shared and private SVs with the usual
 * mg_get()/mg_set() arrangement.
 *
 * Aggregates (AVs and HVs) are implemented using tie magic, except that
 * the vtable used is one defined in this file rather than the standard one.
 * This means that where a tie function like FETCH is normally invoked by
 * the tie magic's mg_get() function, we completely bypass the calling of a
 * perl-level function, and directly call C-level code to handle it. On
 * the other hand, calls to functions like PUSH are done directly by code
 * in av.c, etc., which we can't bypass. So the best we can do is to provide
 * XS versions of these functions. We also have to attach a tie object,
 * blessed into the class threads::shared::tie, to keep the method-calling
 * code happy.
 *
 * Access to aggregate elements is done the usual tied way by returning a
 * proxy PVLV element with attached element magic.
 *
 * Pointers to the shared SV are squirrelled away in the mg->mg_ptr field
 * of magic (with mg_len == 0), and in the IV2PTR(SvIV(sv)) field of tied
 * object SVs. These pointers have to be hidden like this because they
 * cross interpreter boundaries, and we don't want sv_clear() and friends
 * following them.
 *
 * The three basic shared types look like the following:
 *
 * -----------------
 *
 * Shared scalar (my $s : shared):
 *
 *  SV = PVMG(0x7ba238) at 0x7387a8
 *   FLAGS = (PADMY,GMG,SMG)
 *   MAGIC = 0x824d88
 *     MG_TYPE = PERL_MAGIC_shared_scalar(n)
 *     MG_PTR = 0x810358                <<<< pointer to the shared SV
 *
 * -----------------
 *
 * Shared aggregate (my @a : shared;  my %h : shared):
 *
 * SV = PVAV(0x7175d0) at 0x738708
 *   FLAGS = (PADMY,RMG)
 *   MAGIC = 0x824e48
 *     MG_TYPE = PERL_MAGIC_tied(P)
 *     MG_OBJ = 0x7136e0                <<<< ref to the tied object
 *     SV = RV(0x7136f0) at 0x7136e0
 *       RV = 0x738640
 *       SV = PVMG(0x7ba238) at 0x738640 <<<< the tied object
 *         FLAGS = (OBJECT,IOK,pIOK)
 *         IV = 8455000                 <<<< pointer to the shared AV
 *         STASH = 0x80abf0 "threads::shared::tie"
 *     MG_PTR = 0x810358 ""             <<<< another pointer to the shared AV
 *   ARRAY = 0x0
 *
 * -----------------
 *
 * Aggregate element (my @a : shared; $a[0])
 *
 * SV = PVLV(0x77f628) at 0x713550
 *   FLAGS = (GMG,SMG,RMG,pIOK)
 *   MAGIC = 0x72bd58
 *     MG_TYPE = PERL_MAGIC_shared_scalar(n)
 *     MG_PTR = 0x8103c0 ""             <<<< pointer to the shared element
 *   MAGIC = 0x72bd18
 *     MG_TYPE = PERL_MAGIC_tiedelem(p)
 *     MG_OBJ = 0x7136e0                <<<< ref to the tied object
 *     SV = RV(0x7136f0) at 0x7136e0
 *       RV = 0x738660
 *       SV = PVMG(0x7ba278) at 0x738660 <<<< the tied object
 *         FLAGS = (OBJECT,IOK,pIOK)
 *         IV = 8455064                 <<<< pointer to the shared AV
 *         STASH = 0x80ac30 "threads::shared::tie"
 *   TYPE = t
 *
 * Note that PERL_MAGIC_tiedelem(p) magic doesn't have a pointer to a
 * shared SV in mg_ptr; instead this is used to store the hash key,
 * if any, like normal tied elements. Note also that element SVs may have
 * pointers to both the shared aggregate and the shared element.
 *
 *
 * Userland locks:
 *
 * If a shared variable is used as a perl-level lock or condition
 * variable, then PERL_MAGIC_ext magic is attached to the associated
 * *shared* SV, whose mg_ptr field points to a malloc'ed structure
 * containing the necessary mutexes and condition variables.
 *
 * Nomenclature:
 *
 * In this file, any variable name prefixed with 's' (e.g., ssv, stmp or sobj)
 * usually represents a shared SV which corresponds to a private SV named
 * without the prefix (e.g., sv, tmp or obj).
 */

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef HAS_PPPORT_H
#  define NEED_sv_2pv_flags
#  define NEED_vnewSVpvf
#  define NEED_warner
#  include "ppport.h"
#  include "shared.h"
#endif

#ifdef USE_ITHREADS

/* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */
#define UL_MAGIC_SIG 0x554C  /* UL = user lock */

/*
 * The shared things need an intepreter to live in ...
 */
PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
/* To access shared space we fake aTHX in this scope and thread's context */

/* 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                                  \
    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.
 */

typedef struct {
    perl_mutex          mutex;
    PerlInterpreter    *owner;
    I32                 locks;
    perl_cond           cond;
#ifdef DEBUG_LOCKS
    char *              file;
    int                 line;
#endif
} recursive_lock_t;

recursive_lock_t PL_sharedsv_lock;   /* Mutex protecting the shared sv space */

void
recursive_lock_init(pTHX_ recursive_lock_t *lock)
{
    Zero(lock,1,recursive_lock_t);
    MUTEX_INIT(&lock->mutex);
    COND_INIT(&lock->cond);
}

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);
    if (lock->owner == aTHX) {
        if (--lock->locks == 0) {
            lock->owner = NULL;
            COND_SIGNAL(&lock->cond);
        }
    }
    MUTEX_UNLOCK(&lock->mutex);
}

void
recursive_lock_acquire(pTHX_ recursive_lock_t *lock, char *file, int line)
{
    assert(aTHX);
    MUTEX_LOCK(&lock->mutex);
    if (lock->owner == aTHX) {
        lock->locks++;
    } else {
        while (lock->owner) {
#ifdef DEBUG_LOCKS
            Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
                      aTHX, lock->owner, lock->file, lock->line);
#endif
            COND_WAIT(&lock->cond,&lock->mutex);
        }
        lock->locks = 1;
        lock->owner = aTHX;
#ifdef DEBUG_LOCKS
        lock->file  = file;
        lock->line  = line;
#endif
    }
    MUTEX_UNLOCK(&lock->mutex);
    SAVEDESTRUCTOR_X(recursive_lock_release,lock);
}

#define ENTER_LOCK                                                          \
    STMT_START {                                                            \
        ENTER;                                                              \
        recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\
    } STMT_END

/* The unlocking is done automatically at scope exit */
#define LEAVE_LOCK      LEAVE


/* A common idiom is to acquire access and switch in ... */
#define SHARED_EDIT     \
    STMT_START {        \
        ENTER_LOCK;     \
        SHARED_CONTEXT; \
    } STMT_END

/* ... then switch out and release access. */
#define SHARED_RELEASE  \
    STMT_START {        \
        CALLER_CONTEXT; \
        LEAVE_LOCK;     \
    } STMT_END


/* User-level locks:
   This structure is attached (using ext magic) to any shared SV that
   is used by user-level locking or condition code
*/

typedef struct {
    recursive_lock_t    lock;           /* For user-levl locks */
    perl_cond           user_cond;      /* For user-level conditions */
} user_lock;

/* Magic used for attaching user_lock structs to shared SVs

   The vtable used has just one entry - when the SV goes away
   we free the memory for the above.
 */

int
sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg)
{
    user_lock *ul = (user_lock *) mg->mg_ptr;
    assert(aTHX == PL_sharedsv_space);
    if (ul) {
        recursive_lock_destroy(aTHX_ &ul->lock);
        COND_DESTROY(&ul->user_cond);
        PerlMemShared_free(ul);
        mg->mg_ptr = NULL;
    }
    return (0);
}

MGVTBL sharedsv_userlock_vtbl = {
    0,                          /* get */
    0,                          /* set */
    0,                          /* len */
    0,                          /* clear */
    sharedsv_userlock_free,     /* free */
    0,                          /* copy */
    0,                          /* dup */
#ifdef MGf_LOCAL
    0,                          /* local */
#endif
};

/*
 * Access to shared things is heavily based on MAGIC
 *      - in mg.h/mg.c/sv.c sense
 */

/* In any thread that has access to a shared thing there is a "proxy"
   for it in its own space which has 'MAGIC' associated which accesses
   the shared thing.
 */

extern MGVTBL sharedsv_scalar_vtbl;    /* Scalars have this vtable */
extern MGVTBL sharedsv_array_vtbl;     /* Hashes and arrays have this
                                            - like 'tie' */
extern MGVTBL sharedsv_elem_vtbl;      /* Elements of hashes and arrays have
                                          this _AS WELL AS_ the scalar magic:
   The sharedsv_elem_vtbl associates the element with the array/hash and
   the sharedsv_scalar_vtbl associates it with the value
 */


/* Get shared aggregate SV pointed to by threads::shared::tie magic object */

STATIC SV *
S_sharedsv_from_obj(pTHX_ SV *sv)
{
     return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL);
}


/* Return the user_lock structure (if any) associated with a shared SV.
 * If create is true, create one if it doesn't exist
 */
STATIC user_lock *
S_get_userlock(pTHX_ SV* ssv, bool create)
{
    MAGIC *mg;
    user_lock *ul = NULL;

    assert(ssv);
    /* XXX Redesign the storage of user locks so we don't need a global
     * lock to access them ???? DAPM */
    ENTER_LOCK;

    /* Version of mg_find that also checks the private signature */
    for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) {
        if ((mg->mg_type == PERL_MAGIC_ext) &&
            (mg->mg_private == UL_MAGIC_SIG))
        {
            break;
        }
    }

    if (mg) {
        ul = (user_lock*)(mg->mg_ptr);
    } else if (create) {
        dTHXc;
        SHARED_CONTEXT;
        ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock));
        Zero(ul, 1, user_lock);
        /* Attach to shared SV using ext magic */
        mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
                            (char *)ul, 0);
        mg->mg_private = UL_MAGIC_SIG;  /* Set private signature */
        recursive_lock_init(aTHX_ &ul->lock);
        COND_INIT(&ul->user_cond);
        CALLER_CONTEXT;
    }
    LEAVE_LOCK;
    return (ul);
}


/* Given a private side SV tries to find if the SV has a shared backend,
 * by looking for the magic.
 */
SV *
Perl_sharedsv_find(pTHX_ SV *sv)
{
    MAGIC *mg;
    if (SvTYPE(sv) >= SVt_PVMG) {
        switch(SvTYPE(sv)) {
        case SVt_PVAV:
        case SVt_PVHV:
            if ((mg = mg_find(sv, PERL_MAGIC_tied))
                && mg->mg_virtual == &sharedsv_array_vtbl) {
                return ((SV *)mg->mg_ptr);
            }
            break;
        default:
            /* This should work for elements as well as they
             * have scalar magic as well as their element magic
             */
            if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
                && mg->mg_virtual == &sharedsv_scalar_vtbl) {
                return ((SV *)mg->mg_ptr);
            }
            break;
        }
    }
    /* Just for tidyness of API also handle tie objects */
    if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
        return (S_sharedsv_from_obj(aTHX_ sv));
    }
    return (NULL);
}


/* Associate a private SV  with a shared SV by pointing the appropriate
 * magics at it.
 * Assumes lock is held.
 */
void
Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv)
{
    MAGIC *mg = 0;

    /* If we are asked for any private ops we need a thread */
    assert ( aTHX !=  PL_sharedsv_space );

    /* To avoid need for recursive locks require caller to hold lock */
    assert ( PL_sharedsv_lock.owner == aTHX );

    switch(SvTYPE(sv)) {
    case SVt_PVAV:
    case SVt_PVHV:
        if (!(mg = mg_find(sv, PERL_MAGIC_tied))
            || mg->mg_virtual != &sharedsv_array_vtbl
            || (SV*) mg->mg_ptr != ssv)
        {
            SV *obj = newSV(0);
            sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv));
            if (mg) {
                sv_unmagic(sv, PERL_MAGIC_tied);
            }
            mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
                            (char *)ssv, 0);
            mg->mg_flags |= (MGf_COPY|MGf_DUP);
            SvREFCNT_inc_void(ssv);
            SvREFCNT_dec(obj);
        }
        break;

    default:
        if ((SvTYPE(sv) < SVt_PVMG)
            || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
            || mg->mg_virtual != &sharedsv_scalar_vtbl
            || (SV*) mg->mg_ptr != ssv)
        {
            if (mg) {
                sv_unmagic(sv, PERL_MAGIC_shared_scalar);
            }
            mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
                            &sharedsv_scalar_vtbl, (char *)ssv, 0);
            mg->mg_flags |= (MGf_DUP
#ifdef MGf_LOCAL
                                    |MGf_LOCAL
#endif
                            );
            SvREFCNT_inc_void(ssv);
        }
        break;
    }

    assert ( Perl_sharedsv_find(aTHX_ sv) == ssv );
}


/* Given a private SV, create and return an associated shared SV.
 * Assumes lock is held.
 */
STATIC SV *
S_sharedsv_new_shared(pTHX_ SV *sv)
{
    dTHXc;
    SV *ssv;

    assert(PL_sharedsv_lock.owner == aTHX);
    assert(aTHX !=  PL_sharedsv_space);

    SHARED_CONTEXT;
    ssv = newSV(0);
    SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */
    sv_upgrade(ssv, SvTYPE(sv));
    CALLER_CONTEXT;
    Perl_sharedsv_associate(aTHX_ sv, ssv);
    return (ssv);
}


/* Given a shared SV, create and return an associated private SV.
 * Assumes lock is held.
 */
STATIC SV *
S_sharedsv_new_private(pTHX_ SV *ssv)
{
    SV *sv;

    assert(PL_sharedsv_lock.owner == aTHX);
    assert(aTHX !=  PL_sharedsv_space);

    sv = newSV(0);
    sv_upgrade(sv, SvTYPE(ssv));
    Perl_sharedsv_associate(aTHX_ sv, ssv);
    return (sv);
}


/* A threadsafe version of SvREFCNT_dec(ssv) */

STATIC void
S_sharedsv_dec(pTHX_ SV* ssv)
{
    if (! ssv)
        return;
    ENTER_LOCK;
    if (SvREFCNT(ssv) > 1) {
        /* No side effects, so can do it lightweight */
        SvREFCNT_dec(ssv);
    } else {