view release on metacpan or  search on metacpan

Shared.xs  view on Meta::CPAN

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"
#include "pool.h"

/* slot_sv lifetime magic: returned scalar pins the pool object alive by
 * holding an incremented refcount, released when the scalar is freed. */
static int pool_scalar_magic_free(pTHX_ SV *sv, MAGIC *mg) {
    PERL_UNUSED_ARG(sv);
    if (mg->mg_obj) SvREFCNT_dec(mg->mg_obj);
    return 0;
}

static const MGVTBL pool_scalar_magic_vtbl = {
    NULL, NULL, NULL, NULL, pool_scalar_magic_free, NULL, NULL, NULL
};

#define EXTRACT_POOL(sv) \
    if (!sv_isobject(sv) || !sv_derived_from(sv, "Data::Pool::Shared")) \
        croak("Expected a Data::Pool::Shared object"); \
    PoolHandle *h = INT2PTR(PoolHandle*, SvIV(SvRV(sv))); \
    if (!h) croak("Attempted to use a destroyed Data::Pool::Shared object"); \
    PoolHandle *h0 = h; PERL_UNUSED_VAR(h0); \
    sv_2mortal(SvREFCNT_inc(SvRV(sv)))

/* Re-read the handle after a call that can run Perl code (tied/overloaded
 * argument magic, tied-array fetches).  That code may call $obj->DESTROY
 * explicitly, which frees the handle and zeroes the IV; EXTRACT's mortal
 * pins the referent only against refcount-driven destruction, not an
 * explicit DESTROY, so the local `h` would dangle.  Used only where magic
 * can actually intervene between EXTRACT and the first use of h. */
/* The same Perl can also REPLACE the invocant ($obj = 42 from an overload
 * handler mutates ST(0), because Perl passes aliases), so SvROK is re-checked
 * before SvRV -- otherwise SvRV would run on a non-reference. */
#define REEXTRACT_POOL(sv) \
    if (!SvROK(sv)) \
        croak("Data::Pool::Shared object was replaced during the call"); \
    h = INT2PTR(PoolHandle*, SvIV(SvRV(sv))); \
    if (h != h0) croak("Data::Pool::Shared object replaced or destroyed during the call")

#define MAKE_OBJ(class, handle) \
    SV *obj = newSViv(PTR2IV(handle)); \
    SV *ref = newRV_noinc(obj); \
    sv_bless(ref, gv_stashpv(class, GV_ADD)); \
    RETVAL = ref

#define CHECK_SLOT(h, slot) \
    if ((UV)(slot) >= (h)->capacity) \
        croak("slot %" UVuf " out of range (capacity %" UVuf ")", \
              (UV)(slot), (UV)(h)->capacity)

#define CHECK_ALLOCATED(h, slot) \
    if (!pool_is_allocated(h, slot)) \
        croak("slot %" UVuf " is not allocated", (UV)(slot))


MODULE = Data::Pool::Shared  PACKAGE = Data::Pool::Shared

PROTOTYPES: DISABLE

SV *
new(class, path, capacity, elem_size, ...)
    const char *class
    SV *path
    UV capacity
    UV elem_size

Shared.xs  view on Meta::CPAN

allocated_slots(self)
    SV *self
  PREINIT:
    EXTRACT_POOL(self);
  CODE:
    AV *av = newAV();
    uint64_t cap = h->capacity;
    uint32_t nwords = h->bitmap_words;
    for (uint32_t widx = 0; widx < nwords; widx++) {
        uint64_t word = __atomic_load_n(&h->bitmap[widx], __ATOMIC_RELAXED);
        while (word) {
            int bit = __builtin_ctzll(word);
            uint64_t slot = (uint64_t)widx * 64 + bit;
            if (slot < cap)
                av_push(av, newSViv((IV)slot));
            word &= word - 1;
        }
    }
    RETVAL = newRV_noinc((SV *)av);
  OUTPUT:
    RETVAL

UV
ptr(self, slot)
    SV *self
    UV slot
  PREINIT:
    EXTRACT_POOL(self);
  CODE:
    CHECK_SLOT(h, slot);
    CHECK_ALLOCATED(h, slot);
    RETVAL = PTR2UV(pool_slot_ptr(h, slot));
  OUTPUT:
    RETVAL

UV
data_ptr(self)
    SV *self
  PREINIT:
    EXTRACT_POOL(self);
  CODE:
    RETVAL = PTR2UV(h->data);
  OUTPUT:
    RETVAL

SV *
slot_sv(self, slot)
    SV *self
    UV slot
  PREINIT:
    EXTRACT_POOL(self);
  CODE:
    CHECK_SLOT(h, slot);
    CHECK_ALLOCATED(h, slot);
    RETVAL = newSV(0);
    sv_upgrade(RETVAL, SVt_PV);
    SvPV_set(RETVAL, (char *)pool_slot_ptr(h, slot));
    SvLEN_set(RETVAL, 0);
    SvCUR_set(RETVAL, h->elem_size);
    SvPOK_on(RETVAL);
    /* Pin pool alive while this SV is referenced -- magic before READONLY */
    MAGIC *mg = sv_magicext(RETVAL, NULL, PERL_MAGIC_ext, &pool_scalar_magic_vtbl, NULL, 0);
    /* Pin the REFERENT (the blessed handle), not the container RV: pinning self
     * lets `$pool = undef` still drop the referent -> DESTROY munmaps -> the
     * view SV's PV into the mapping dangles (SEGV).  Guard SvRV(self). */
    mg->mg_obj = SvREFCNT_inc_simple_NN(SvRV(self));
    SvREADONLY_on(RETVAL);
  OUTPUT:
    RETVAL


MODULE = Data::Pool::Shared  PACKAGE = Data::Pool::Shared::I64

PROTOTYPES: DISABLE

SV *
new(class, path, capacity, ...)
    const char *class
    SV *path
    UV capacity
  PREINIT:
    char errbuf[POOL_ERR_BUFLEN];
  CODE:
    mode_t mode = (items > 3 && (SvGETMAGIC(ST(3)), SvOK(ST(3)))) ? (mode_t)SvUV(ST(3)) : 0600;
    const char *p = (SvGETMAGIC(path), SvOK(path)) ? SvPV_nolen(path) : NULL;
    PoolHandle *h = pool_create(p, capacity, sizeof(int64_t), POOL_VAR_I64, mode, errbuf);
    if (!h) croak("Data::Pool::Shared::I64->new: %s", errbuf[0] ? errbuf : "out of memory");
    MAKE_OBJ(class, h);
  OUTPUT:
    RETVAL

SV *
new_memfd(class, name, capacity)
    const char *class
    const char *name
    UV capacity
  PREINIT:
    char errbuf[POOL_ERR_BUFLEN];
  CODE:
    PoolHandle *h = pool_create_memfd(name, capacity, sizeof(int64_t), POOL_VAR_I64, errbuf);
    if (!h) croak("Data::Pool::Shared::I64->new_memfd: %s", errbuf[0] ? errbuf : "out of memory");
    MAKE_OBJ(class, h);
  OUTPUT:
    RETVAL

SV *
new_from_fd(class, fd)
    const char *class
    int fd
  PREINIT:
    char errbuf[POOL_ERR_BUFLEN];
  CODE:
    PoolHandle *h = pool_open_fd(fd, POOL_VAR_I64, errbuf);
    if (!h) croak("Data::Pool::Shared::I64->new_from_fd: %s", errbuf[0] ? errbuf : "out of memory");
    MAKE_OBJ(class, h);
  OUTPUT:
    RETVAL

IV
get(self, slot)
    SV *self