From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on dcvr.yhbt.net X-Spam-Level: X-Spam-ASN: X-Spam-Status: No, score=-4.0 required=3.0 tests=ALL_TRUSTED,BAYES_00 shortcircuit=no autolearn=ham autolearn_force=no version=3.4.2 Received: from localhost (dcvr.yhbt.net [127.0.0.1]) by dcvr.yhbt.net (Postfix) with ESMTP id C2A931FB06 for ; Sun, 3 Oct 2021 07:41:24 +0000 (UTC) From: Eric Wong To: mwrap-perl@80x24.org Subject: [PATCH 4/4] add PSGI front-end Date: Sun, 3 Oct 2021 07:41:24 +0000 Message-Id: <20211003074124.12921-5-e@80x24.org> In-Reply-To: <20211003074124.12921-1-e@80x24.org> References: <20211003074124.12921-1-e@80x24.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit List-Id: This will make diagnosing memory problems in PSGI applications easier. --- MANIFEST | 2 + Mwrap.xs | 34 +++++++- examples/mwrap.psgi | 22 ++++++ lib/Devel/Mwrap/PSGI.pm | 169 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 223 insertions(+), 4 deletions(-) create mode 100644 examples/mwrap.psgi create mode 100644 lib/Devel/Mwrap/PSGI.pm diff --git a/MANIFEST b/MANIFEST index caea857..4db1455 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4,8 +4,10 @@ MANIFEST Makefile.PL Mwrap.xs README +examples/mwrap.psgi jhash.h lib/Devel/Mwrap.pm +lib/Devel/Mwrap/PSGI.pm ppport.h script/mwrap-perl t/mwrap.t diff --git a/Mwrap.xs b/Mwrap.xs index 4d3e8af..e9b8b3f 100644 --- a/Mwrap.xs +++ b/Mwrap.xs @@ -63,6 +63,9 @@ static int resolving_malloc; } while (0) static __thread size_t locating; +#ifndef PERL_IMPLICIT_CONTEXT +static size_t *root_locating; /* determines if PL_curcop is our thread */ +#endif static size_t page_size; static struct cds_lfht *totals; union padded_mutex { @@ -92,6 +95,9 @@ lfht_new(void) __attribute__((constructor)) static void resolve_malloc(void) { int err; +#ifndef PERL_IMPLICIT_CONTEXT + root_locating = &locating; +#endif ++locating; #ifdef __FreeBSD__ @@ -319,13 +325,17 @@ update_stats_rcu_lock(size_t *generation, size_t size, uintptr_t caller) static const size_t xlen = sizeof(caller); char *dst; const COP *cop; + struct cds_lfht *t = rcu_dereference(totals); - if (caa_unlikely(!totals)) return 0; + if (caa_unlikely(!t)) return 0; if (locating++) goto out; /* do not recurse into another *alloc */ *generation = uatomic_add_return(&total_bytes_inc, size); - cop = PL_curcop; - +#ifdef PERL_IMPLICIT_CONTEXT + cop = aTHX ? PL_curcop : 0; +#else + cop = &locating == root_locating ? PL_curcop : 0; +#endif rcu_read_lock(); if (cop) { const char *ptr = OutCopFILE(cop); @@ -775,6 +785,9 @@ out: MODULE = Devel::Mwrap PACKAGE = Devel::Mwrap PREFIX = mwrap_ BOOT: +#ifndef PERL_IMPLICIT_CONTEXT + root_locating = &locating; +#endif totals = lfht_new(); if (!totals) fprintf(stderr, "failed to allocate totals table\n"); @@ -979,16 +992,29 @@ src_loc_mean_lifespan(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 -PREINIT: CODE: ++locating; RETVAL = location_string(self); diff --git a/examples/mwrap.psgi b/examples/mwrap.psgi new file mode 100644 index 0000000..be814fe --- /dev/null +++ b/examples/mwrap.psgi @@ -0,0 +1,22 @@ +# Copyright (C) all contributors +# License: GPL-2.0+ +# A startup command for development: +# plackup -I ./blib/lib -I ./blib/arch -o 127.0.0.1 examples/mwrap.psgi +use v5.12; +use Devel::Mwrap::PSGI; +use Plack::Builder; +my $mw = Devel::Mwrap::PSGI->new; +delete $ENV{LD_PRELOAD}; + +builder { + eval { + enable 'Deflater', + content_type => [ qw( + text/html + text/plain + application/atom+xml + )] + }; # Plack::Middleware::Deflater may not be installed + enable 'Head'; + sub { $mw->call($_[0]) }; +} diff --git a/lib/Devel/Mwrap/PSGI.pm b/lib/Devel/Mwrap/PSGI.pm new file mode 100644 index 0000000..b6e660c --- /dev/null +++ b/lib/Devel/Mwrap/PSGI.pm @@ -0,0 +1,169 @@ +# Copyright (C) all contributors +# License: GPL-2.0+ +package Devel::Mwrap::PSGI; +use v5.12; # strict +use warnings; +use Devel::Mwrap; +use Fcntl qw(SEEK_SET); + +sub new { + my ($class) = @_; + bless {}, $class; +} + +my %HTML_ESC = ( + '&' => '&', + '>' => '>', + '<' => '<', + '"' => '"', + "'" => ''' +); + +sub encode_html { + my ($str) = @_; + $str =~ s/[&><"']/$HTML_ESC{$1}/sge; + $str; +} + +my %URI_ESC; +for (0..255) { $URI_ESC{chr($_)} = sprintf('%%%02X', $_) } +sub uri_escape { + my ($str) = @_; + $str =~ s/([^A-Za-z0-9\-\._~])/$URI_ESC{$1}/sge; + $str; +} + +sub uri_unescape { + my ($str) = @_; + $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/sge; + $str; +} + +my @COLS = qw(total allocations frees mean_life max_life location); +my $HDR = '' . join('', @COLS) . ''; +my @FIELDS = qw(total allocations frees mean_life max_life location); + +sub accumulate_i { # callback for Devel::Mwrap::each + my ($all, $src_loc) = @_; + push @$all, [ $src_loc->total, $src_loc->allocations, $src_loc->frees, + $src_loc->mean_lifespan, $src_loc->max_lifespan, + $src_loc->name ]; +} + +sub fh_response { + my ($fh) = @_; + $fh->flush or die "flush: $!"; + seek($fh, 0, SEEK_SET) or die "seek: $!"; + [ 200, [ + 'Expires' => 'Fri, 01 Jan 1980 00:00:00 GMT', + 'Pragma' => 'no-cache', + 'Cache-Control' => 'no-cache, max-age=0, must-revalidate', + 'Content-Type' => 'text/html; charset=UTF-8', + 'Content-Length' => -s $fh + ], $fh]; +} + +sub each_gt { + my ($env, $min, $sort) = @_; + open my $fh, '+>', undef or die "open: $!"; + $sort //= 'total'; + my $sn = $env->{SCRIPT_NAME}; + my $t = "Devel::Mwrap::each($min)"; + my $all = []; + my @f = @FIELDS; + my $sc = 0; + for (my $i = 0; $i <= $#FIELDS; $i++) { + next if $FIELDS[$i] ne $sort; + $sc = $i; + last; + } + $f[$sc] = "$f[$sc]"; + @f = (join('', map {; + if (/\A/) { + $_; + } else { + qq($_); + } + } @f)); + my @all; + Devel::Mwrap::each($min, \&accumulate_i, \@all); + @all = sort { $b->[$sc] <=> $a->[$sc] } @all; + my $age = Devel::Mwrap::current_age(); + print $fh <$t

$t

+

Current age: $age

+ +EOM + while (my $cols = shift @all) { + # cols: [ total, allocations, frees, mean_lifespan, + # max_lifespan, name ] + my $loc_name = pop @$cols; + $cols->[3] = sprintf('%0.3f', $cols->[3]); # mean_life + my $href = "$sn/at/".uri_escape($loc_name); + print $fh '\n"; + fh_response($fh); +} + +sub each_at_i { + my ($fh, $size, $gen) = @_; + print $fh "\n"; +} + +sub each_at { + my ($env, $src_loc) = @_; + my $t = encode_html($src_loc->name); + open my $fh, '+>', undef or die "open: $!"; + my $age = Devel::Mwrap::current_age(); + print $fh <$t

live allocations at $t

+

Current age: $age

\n
@f
', join('', @$cols), + qq(), encode_html($loc_name), + "
$size$gen
+ +EOM + $src_loc->each(0, \&each_at_i, $fh); + print $fh "
sizegeneration
\n"; + fh_response($fh); +} + +sub r404 { + my $t404 = "Not Found\n"; + [ 404, [ qw(Content-Type text/plain + Content-Length), length($t404) ], [ $t404 ] ]; +} + +my $default_min = 2000; +my $url = 'https://80x24.org/mwrap-perl.git/about'; +chomp(my $root = <Mwrap demo

allocations >$default_min bytes

$url +EOM + +sub call { # PSGI entry point + Devel::Mwrap::quiet(1); + my (undef, $env) = @_; + my $path_info = $env->{PATH_INFO}; + my $ret; + if ($path_info =~ m!\A/each/([0-9]+)\z!) { + my $min = $1 + 0; + my ($sort) = ($env->{QUERY_STRING} =~ /\bsort=([a-z+])\b/); + $ret = each_gt($env, $min, $sort); + } elsif ($path_info =~ m!\A/at/(.*)\z!) { + my $src_loc = Devel::Mwrap::get(uri_unescape($1)); + $ret = $src_loc ? each_at($env, $src_loc) : r404(); + } elsif ($path_info eq '/') { + $ret = [ 200, [ qw(Content-Type text/html + Content-Length), length($root) ], [ $root ] ] + } else { + r404(); + } + Devel::Mwrap::quiet(0); + $ret; +} + +1;