Data-Pool-Shared
view release on metacpan or search on metacpan
out as "data_ptr + idx * elem_size".
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 returned scalar reads the slot with no "memcpy", which
matters for large slots. It keeps the pool object alive for as long as
that scalar (or a reference to it) is live.
Note that binding it with plain assignment makes an ordinary private
*copy* -- Perl copies the string on assignment, so
my $snap = $pool->slot_sv($idx); # a SNAPSHOT of the slot right now
is frozen and does not track later writes. To keep the live zero-copy view
that continues to reflect the slot's current contents (including after a
free()/re-allocation), use the return value directly or hold a reference:
#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->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
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
B<Warning>: The returned pointer becomes dangling if the pool object
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 returned scalar reads the slot with no C<memcpy>,
which matters for large slots. It keeps the pool object alive for as long
as that scalar (or a reference to it) is live.
Note that binding it with plain assignment makes an ordinary private
I<copy> -- Perl copies the string on assignment, so
my $snap = $pool->slot_sv($idx); # a SNAPSHOT of the slot right now
is frozen and does not track later writes. To keep the live zero-copy view
that continues to reflect the slot's current contents (including after a
C<free()>/re-allocation), use the return value directly or hold a reference:
char *path;
int notify_fd;
int backing_fd;
uint32_t scan_hint;
} PoolHandle;
/* ================================================================
* Utility
* ================================================================ */
/* A zombie (dead but not yet reaped) still answers kill(pid,0) as alive, so a
* process that crashed while holding the lock and lingers unreaped would never
* be recovered. Treat /proc/<pid>/stat state 'Z' as dead. Linux-only (as is
* this module); if /proc is unreadable we fall back to "alive" (safe: we never
* force-recover a possibly-live holder). */
static inline int pool_pid_is_zombie(uint32_t pid) {
char path[32], buf[256];
snprintf(path, sizeof(path), "/proc/%u/stat", (unsigned)pid);
int fd = open(path, O_RDONLY | O_CLOEXEC);
if (fd < 0) return 0;
ssize_t n = read(fd, buf, sizeof(buf) - 1);
close(fd);
if (n <= 0) return 0;
buf[n] = '\0';
/* "pid (comm) state ..."; comm may contain ')', so scan to the last one. */
char *rp = strrchr(buf, ')');
if (!rp || rp + 2 >= buf + n) return 0; /* need ") X" within the bytes read */
return rp[1] == ' ' && rp[2] == 'Z';
}
static inline int pool_pid_alive(uint32_t pid) {
if (pid == 0) return 1; /* no owner recorded, assume alive */
if (kill((pid_t)pid, 0) == -1 && errno == ESRCH) return 0; /* definitely dead */
return !pool_pid_is_zombie(pid); /* kill() also succeeds for a zombie -> treat as dead */
}
static inline void pool_make_deadline(double timeout, struct timespec *deadline) {
clock_gettime(CLOCK_MONOTONIC, deadline);
if (!(timeout < 1e9)) timeout = 1e9; /* clamp Inf/NaN/huge: avoid UB (time_t) cast -> instant spurious timeout */
deadline->tv_sec += (time_t)timeout;
deadline->tv_nsec += (long)((timeout - (double)(time_t)timeout) * 1e9);
if (deadline->tv_nsec >= 1000000000L) {
* 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->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.
*
* Race window: between our owner-CAS and the bitmap-CAS below,
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 1.711 second using v1.01-cache-2.11-cpan-14f38c9f855 )