Data-Pool-Shared
view release on metacpan or search on metacpan
Warning: The returned pointer becomes dangling if the pool object is
destroyed. Do not use after the pool goes out of scope.
Zero-Copy Access
my $sv = $pool->slot_sv($idx); # SV backed by slot memory
Returns a read-only scalar whose PV points directly into the shared
memory slot. Reading the scalar reads the slot with no "memcpy". Useful
for large slots where avoiding copy matters.
The scalar holds a reference to the pool object, keeping it alive for as
long as the scalar (or any copy of it) is live. However, the scalar
still reflects the current contents of the slot: if the slot is free()d
and later re-allocated, reads will see the new data. To modify the slot,
use set().
Status
my $ok = $pool->is_allocated($idx);
my $cap = $pool->capacity;
my $esz = $pool->elem_size;
my $n = $pool->used; # allocated count
#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
};
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->hdr->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);
mg->mg_obj = SvREFCNT_inc_simple_NN(self);
SvREADONLY_on(RETVAL);
OUTPUT:
RETVAL
MODULE = Data::Pool::Shared PACKAGE = Data::Pool::Shared::I64
PROTOTYPES: DISABLE
eg/guard.pl view on Meta::CPAN
warn "caught: $@" if $@;
printf "after die: used = %d\n\n", $pool->used;
# scalar context — only get the guard (index accessible via internals)
{
my $guard = $pool->alloc_guard;
printf "scalar guard: used = %d\n", $pool->used;
}
printf "after scalar guard: used = %d\n\n", $pool->used;
# try_alloc_guard — fill pool, guards keep slots alive
my @guards;
for (1..4) {
my ($idx, $guard) = $pool->try_alloc_guard;
printf "try_alloc_guard: %s (used=%d)\n",
defined $idx ? "slot $idx" : "full", $pool->used;
push @guards, $guard if $guard;
}
# 5th should fail — pool is full
my ($idx, $guard) = $pool->try_alloc_guard;
printf "try_alloc_guard when full: %s\n", defined $idx ? "slot $idx" : "undef (pool full)";
eg/opengl_particles.pl view on Meta::CPAN
# ── Physics process ──────────────────────────────────────────────
# Gravity, drag, aging — frees dead particles
my $physics_pid = fork // die "fork: $!";
if ($physics_pid == 0) {
my $gravity = 120;
my $drag = 0.98;
for my $frame (1 .. 120) {
my $alive = $pool->allocated_slots;
for my $s (@$alive) {
my ($x, $y, $vx, $vy, $r, $g, $b, $life) = unpack_particle($pool, $s);
# age
$life -= $DT;
if ($life <= 0) {
$pool->free($s);
next;
}
# physics
eg/opengl_particles.pl view on Meta::CPAN
# glBindBuffer(GL_ARRAY_BUFFER, $vbo);
# glBufferData_c(GL_ARRAY_BUFFER, $MAX * $SLOT_SIZE, 0, GL_STREAM_DRAW);
# # attrib 0: position (2 doubles at offset 0)
# glVertexAttribLPointer(0, 2, GL_DOUBLE, $SLOT_SIZE, 0);
# glEnableVertexAttribArray(0);
# # attrib 1: color (3 doubles at offset 32)
# glVertexAttribLPointer(1, 3, GL_DOUBLE, $SLOT_SIZE, 32);
# glEnableVertexAttribArray(1);
#
# # Per frame:
# my $alive = $pool->allocated_slots;
# my $n = scalar @$alive;
# # Upload only alive particles:
# for my $i (0 .. $n - 1) {
# glBufferSubData_c(GL_ARRAY_BUFFER, $i * $SLOT_SIZE, $SLOT_SIZE,
# $pool->ptr($alive->[$i]));
# }
# # Or bulk upload entire data region (includes dead slots):
# glBufferSubData_c(GL_ARRAY_BUFFER, 0, $pool->used * $SLOT_SIZE,
# $pool->data_ptr);
# glDrawArrays(GL_POINTS, 0, $n);
my $t0 = time;
my $frames = 0;
for (1 .. 20) {
sleep(0.1);
$frames++;
my $alive = $pool->allocated_slots;
my $n = scalar @$alive;
# sample a few particles for text display
if ($n > 0) {
my $sample = $alive->[int($n / 2)];
my ($x, $y, $vx, $vy, $r, $g, $b, $life) = unpack_particle($pool, $sample);
printf " frame %2d: %3d alive | sample pos=(%.0f,%.0f) vel=(%.0f,%.0f) "
. "rgb=(%.2f,%.2f,%.2f) life=%.1f\n",
$frames, $n, $x, $y, $vx, $vy, $r, $g, $b, $life;
} else {
printf " frame %2d: %3d alive\n", $frames, $n;
}
}
waitpid($spawner_pid, 0);
waitpid($physics_pid, 0);
my $dt = time - $t0;
my $st = $pool->stats;
printf "\n%d frames in %.1fs (%.0f fps)\n", $frames, $dt, $frames / $dt;
printf "stats: allocs=%d frees=%d (spawned and despawned)\n",
$st->{allocs}, $st->{frees};
printf "final: %d particles still alive\n", $pool->used;
$pool->reset;
lib/Data/Pool/Shared.pm view on Meta::CPAN
is destroyed. Do not use after the pool goes out of scope.
=head2 Zero-Copy Access
my $sv = $pool->slot_sv($idx); # SV backed by slot memory
Returns a read-only scalar whose PV points directly into the shared
memory slot. Reading the scalar reads the slot with no C<memcpy>.
Useful for large slots where avoiding copy matters.
The scalar holds a reference to the pool object, keeping it alive
for as long as the scalar (or any copy of it) is live. However, the
scalar still reflects the current contents of the slot: if the slot
is C<free()>d and later re-allocated, reads will see the new data.
To modify the slot, use C<set()>.
=head2 Status
my $ok = $pool->is_allocated($idx);
my $cap = $pool->capacity;
my $esz = $pool->elem_size;
char *path;
int notify_fd;
int backing_fd;
uint32_t scan_hint;
} PoolHandle;
/* ================================================================
* Utility
* ================================================================ */
static inline int pool_pid_alive(uint32_t pid) {
if (pid == 0) return 1;
return !(kill((pid_t)pid, 0) == -1 && errno == ESRCH);
}
static inline void pool_make_deadline(double timeout, struct timespec *deadline) {
clock_gettime(CLOCK_MONOTONIC, deadline);
deadline->tv_sec += (time_t)timeout;
deadline->tv_nsec += (long)((timeout - (double)(time_t)timeout) * 1e9);
if (deadline->tv_nsec >= 1000000000L) {
deadline->tv_sec++;
* Stale recovery — CAS owner to narrow race window
* ================================================================ */
static inline uint32_t pool_recover_stale(PoolHandle *h) {
uint32_t recovered = 0;
uint64_t cap = h->hdr->capacity;
for (uint64_t slot = 0; slot < cap; slot++) {
if (!pool_is_allocated(h, slot)) continue;
uint32_t owner = __atomic_load_n(&h->owners[slot], __ATOMIC_ACQUIRE);
if (owner == 0 || pool_pid_alive(owner)) continue;
/* CAS owner from dead PID to 0 — if it fails, slot was
* re-allocated or already recovered by another process */
if (!__atomic_compare_exchange_n(&h->owners[slot], &owner, 0,
0, __ATOMIC_ACQ_REL, __ATOMIC_RELAXED))
continue;
/* We now own the right to free this slot's bitmap bit */
uint32_t widx = (uint32_t)(slot / 64);
int bit = (int)(slot % 64);
t/04-edge-cases.t view on Meta::CPAN
# slot_sv not allocated
eval { $pool->slot_sv(0) };
like $@, qr/not allocated/, "slot_sv not allocated";
# double free returns false
$s = $pool->alloc;
ok $pool->free($s), "first free ok";
ok !$pool->free($s), "double free returns false";
# slot_sv pins pool alive across pool-object scope exit
{
my $sv;
{
my $p = Data::Pool::Shared->new(undef, 1, 16);
my $ps = $p->alloc;
$p->set($ps, "pintest\0\0\0\0\0\0\0\0\0");
$sv = $p->slot_sv($ps);
} # $p out of scope — magic must hold pool alive via refcount
is substr($sv, 0, 7), "pintest", "slot_sv pins pool across scope exit";
}
# free_n croaks on undef slot (Pass 10 hardening)
eval { $pool->free_n([undef]) };
like $@, qr/undef slot/, "free_n croaks on undef element";
my @slots = map $pool->alloc, 1..3;
eval { $pool->free_n([$slots[0], undef, $slots[2]]) };
like $@, qr/undef slot/, "free_n croaks mid-array on undef";
is $pool->free_n([$slots[0], $slots[1], $slots[2]]), 3, "free_n clean array works";
xt/pidfd_stale.t view on Meta::CPAN
# Fork a child, allocate a slot in the child's name
my $pid = fork // die;
if (!$pid) {
my $p2 = Data::Pool::Shared::I64->new_from_fd($p->memfd);
my $s = $p2->alloc;
$p2->set($s, 42);
_exit(0); # die immediately, leaving slot orphaned
}
# Open pidfd before child dies (need pid alive)
my $pidfd = syscall($nr, $pid, 0);
if ($pidfd < 0) {
waitpid $pid, 0;
plan skip_all => "pidfd_open failed: $!";
}
waitpid $pid, 0;
is $p->used, 1, "child allocated 1 slot before dying";
# pidfd should now be readable (child exited)
( run in 0.959 second using v1.01-cache-2.11-cpan-39bf76dae61 )