diff options
Diffstat (limited to 'Mwrap.xs')
| -rw-r--r-- | Mwrap.xs | 309 |
1 files changed, 309 insertions, 0 deletions
diff --git a/Mwrap.xs b/Mwrap.xs new file mode 100644 index 0000000..4d4c996 --- /dev/null +++ b/Mwrap.xs @@ -0,0 +1,309 @@ +/* + * Copyright (C) mwrap hackers <mwrap-perl@80x24.org> + * License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> + * Disclaimer: I don't really know my way around XS or Perl internals well + */ +#define MWRAP_PERL 1 +#include "mwrap_core.h" + +/* + * I hate typedefs, especially when they're hiding the fact that there's + * a pointer, but XS needs this, apparently, and it does s/__/::/g + */ +typedef struct src_loc * Devel__Mwrap__SrcLoc; + +/* keep this consistent with httpd.h write_loc_name */ +static SV *location_string(struct src_loc *l) +{ + SV *ret = newSV(0); + + if (l->f) { + sv_catpv(ret, l->f->fn); + if (l->lineno == U24_MAX) + sv_catpvs(ret, ":-"); + else + sv_catpvf(ret, ":%u", l->lineno); + } + if (l->bt_len) { + AUTO_FREE char **s = bt_syms(l->bt, l->bt_len); + if (s) { + if (l->f) + sv_catpvs(ret, "\n"); + sv_catpv(ret, s[0]); + for (uint32_t i = 1; i < l->bt_len; ++i) + sv_catpvf(ret, "\n%s", s[i]); + } + } + return ret; +} + +MODULE = Devel::Mwrap PACKAGE = Devel::Mwrap PREFIX = mwrap_ + +BOOT: +#ifndef PERL_IMPLICIT_CONTEXT + root_locating = &locating; +#endif + +PROTOTYPES: ENABLE + +size_t +mwrap_quiet(int on_off) +CODE: + RETVAL = on_off ? locating++ : locating--; +OUTPUT: + RETVAL + +size_t +mwrap_current_age() +CODE: + RETVAL = uatomic_read(&total_bytes_inc); +OUTPUT: + RETVAL + +size_t +mwrap_total_bytes_allocated() +CODE: + RETVAL = uatomic_read(&total_bytes_inc); +OUTPUT: + RETVAL + +size_t +mwrap_total_bytes_freed() +CODE: + RETVAL = uatomic_read(&total_bytes_dec); +OUTPUT: + RETVAL + +void +mwrap_each(min, cb, arg = &PL_sv_undef) + size_t min; + SV *cb; + SV *arg; +PREINIT: + struct cds_lfht *t; + struct cds_lfht_iter iter; + struct src_loc *l; +CODE: + ++locating; + rcu_read_lock(); + t = CMM_LOAD_SHARED(totals); + if (t) { + bool err = false; + + cds_lfht_for_each_entry(t, &iter, l, hnode) { + size_t total = uatomic_read(&l->total); + + if (total > min) { + SV *loc; + dSP; + ENTER; + SAVETMPS; + + PUSHMARK(SP); + loc = sv_newmortal(); + sv_setref_pv(loc, "Devel::Mwrap::SrcLoc", l); + XPUSHs(arg); + XPUSHs(loc); + PUTBACK; + + call_sv(cb, G_DISCARD|G_EVAL); + + SPAGAIN; + if (SvTRUE(ERRSV)) + err = true; + + FREETMPS; + LEAVE; + } + if (err) + break; + mwrap_assert(rcu_read_ongoing()); + } + } + if (SvTRUE(ERRSV)) + croak(NULL); +CLEANUP: + rcu_read_unlock(); + --locating; + + +void +mwrap_reset() +CODE: + mwrap_reset(); + +unsigned +mwrap_bt_depth(arg = &PL_sv_undef) + SV *arg; +CODE: + if (SvOK(arg)) { + UV n = SvUVx(arg); + if (n > MWRAP_BT_MAX) + n = MWRAP_BT_MAX; + CMM_STORE_SHARED(bt_req_depth, (uint32_t)n); + RETVAL = n; + } else { + RETVAL = CMM_LOAD_SHARED(bt_req_depth); + } +OUTPUT: + RETVAL + +Devel::Mwrap::SrcLoc +mwrap_get(loc) + SV *loc; +PREINIT: + STRLEN len; + const char *str; + struct src_loc *l; +CODE: + ++locating; + if (!SvPOK(loc)) + XSRETURN_UNDEF; + str = SvPV(loc, len); + l = mwrap_get(str, len); + if (!l) + XSRETURN_UNDEF; + RETVAL = l; +OUTPUT: + RETVAL +CLEANUP: + --locating; + +MODULE = Devel::Mwrap PACKAGE = Devel::Mwrap::SrcLoc PREFIX = src_loc_ + +PROTOTYPES: ENABLE + +size_t +src_loc_frees(self) + Devel::Mwrap::SrcLoc self +PREINIT: +CODE: + ++locating; + RETVAL = uatomic_read(&self->frees); +OUTPUT: + RETVAL +CLEANUP: + --locating; + +size_t +src_loc_freed_bytes(self) + Devel::Mwrap::SrcLoc self +PREINIT: +CODE: + ++locating; + RETVAL = uatomic_read(&self->freed_bytes); +OUTPUT: + RETVAL +CLEANUP: + --locating; + +size_t +src_loc_allocations(self) + Devel::Mwrap::SrcLoc self +PREINIT: +CODE: + ++locating; + RETVAL = uatomic_read(&self->allocations); +OUTPUT: + RETVAL +CLEANUP: + --locating; + +size_t +src_loc_total(self) + Devel::Mwrap::SrcLoc self +PREINIT: +CODE: + ++locating; + RETVAL = uatomic_read(&self->total); +OUTPUT: + RETVAL +CLEANUP: + --locating; + +double +src_loc_mean_lifespan(self) + Devel::Mwrap::SrcLoc self +PREINIT: + size_t tot, frees; +CODE: + ++locating; + frees = uatomic_read(&self->frees); + tot = uatomic_read(&self->age_total); + RETVAL = frees ? ((double)tot/(double)frees) : HUGE_VAL; +OUTPUT: + RETVAL +CLEANUP: + --locating; + +double +src_loc_max_lifespan(self) + Devel::Mwrap::SrcLoc self +CODE: + ++locating; + RETVAL = uatomic_read(&self->max_lifespan); +OUTPUT: + RETVAL +CLEANUP: + --locating; + +SV * +src_loc_name(self) + Devel::Mwrap::SrcLoc self +CODE: + ++locating; + RETVAL = location_string(self); +OUTPUT: + RETVAL +CLEANUP: + --locating; + +void +src_loc_each(self, min, cb, arg = &PL_sv_undef) + Devel::Mwrap::SrcLoc self; + size_t min; + SV *cb; + SV *arg; +PREINIT: + struct alloc_hdr *h; + bool err = false; +CODE: + ++locating; + rcu_read_lock(); + cds_list_for_each_entry_rcu(h, &self->allocs, anode) { + size_t size = uatomic_read(&h->size); + if (size > min) { + dSP; + ENTER; + SAVETMPS; + + PUSHMARK(SP); + + /* + * note: we MUST NOT expose alloc_hdr to Perl code + * since that opens us up to use-after-free + */ + XPUSHs(arg); + XPUSHs(sv_2mortal(newSVuv(size))); + XPUSHs(sv_2mortal(newSVuv(h->as.live.gen))); + XPUSHs(sv_2mortal(newSVuv((uintptr_t)h->real))); + PUTBACK; + + call_sv(cb, G_DISCARD|G_EVAL); + + SPAGAIN; + if (SvTRUE(ERRSV)) + err = true; + + FREETMPS; + LEAVE; + if (err) + break; + mwrap_assert(rcu_read_ongoing()); + } + } + if (SvTRUE(ERRSV)) + croak(NULL); +CLEANUP: + rcu_read_unlock(); + --locating; |