perf: establish benchmark authority for #1196

dev/bench/README.md

@@ -38,6 +38,33 @@ perl  dev/bench/benchmark_closure.pl
 ./jperl dev/bench/benchmark_closure.pl
 ```
 
+## Portfolio runner
+
+`run_performance_portfolio.pl` is the reproducible performance authority for
+issue #1196.  It runs system Perl and PerlOnJava in alternating fresh-process
+pairs and writes a JSON evidence bundle.  Its defaults are intentionally long:
+
+```bash
+perl dev/bench/run_performance_portfolio.pl
+```
+
+For a non-authoritative smoke test of one workload:
+
+```bash
+perl dev/bench/run_performance_portfolio.pl --workload closure --pairs 1 \
+  --warmup-min 1 --warmup-max 1 --windows 1
+```
+
+For call-boundary attribution, add `--call-layer-diagnostics`.  This is an
+instrumented diagnostic run, not an acceptance benchmark: it writes a compact
+per-process JSON report with inclusive and exclusive nanoseconds and allocated
+bytes per operation for the shared-argument facade and the two general instance
+call paths.  The files are stored beside `portfolio.json`; extract the required
+summary and remove the diagnostic directory after the investigation.
+
+See `dev/design/performance-over-perl.md` for the acceptance contract and
+evidence requirements.
+
 ## See Also
 
 - `dev/design/optimization.md` — optimization design decisions

dev/bench/analyze_performance_portfolio.pl

@@ -0,0 +1,82 @@
+#!/usr/bin/env perl
+
+# Summarize a portfolio evidence bundle without ever upgrading an
+# inconclusive run into an authoritative performance claim.
+use strict;
+use warnings;
+use Getopt::Long qw(GetOptions);
+use JSON::PP;
+
+my %option = (bootstrap => 10_000);
+GetOptions('input=s' => \$option{input}, 'output=s' => \$option{output},
+    'bootstrap=i' => \$option{bootstrap}, 'allow-noisy-host!' => \$option{allow_noisy_host},
+    'help' => \$option{help}) or usage(2);
+usage(0) if $option{help};
+die "--input is required\n" unless defined $option{input};
+die "--bootstrap must be positive\n" unless $option{bootstrap} > 0;
+
+my $portfolio = decode_file($option{input});
+die "not a performance portfolio\n" unless ($portfolio->{kind} // '') eq 'perlonjava-performance-portfolio';
+my @workloads;
+for my $entry (@{$portfolio->{results} || []}) {
+    my @ratios;
+    for my $pair (@{$entry->{pairs} || []}) {
+        my $perl = median([map { $_->{throughput} } @{$pair->{engines}{perl}{windows} || []}]);
+        my $pj = median([map { $_->{throughput} } @{$pair->{engines}{perlonjava}{windows} || []}]);
+        die "missing positive window throughput for $entry->{workload}\n" unless $perl > 0 && $pj > 0;
+        push @ratios, $pj / $perl;
+    }
+    die "need at least two pairs for $entry->{workload}\n" unless @ratios >= 2;
+    push @workloads, { workload => $entry->{workload}, pair_ratios => \@ratios,
+        median_ratio => median(\@ratios), geometric_mean_ratio => geometric_mean(\@ratios),
+        confidence_interval => bootstrap_ci(\@ratios, $option{bootstrap}) };
+}
+die "no workload results\n" unless @workloads;
+my @all = map { @{$_->{pair_ratios}} } @workloads;
+my @anchors = grep { $_->{workload} eq 'closure' || $_->{workload} eq 'life' } @workloads;
+my $strict_authority = ($portfolio->{protocol_compliant} && $portfolio->{conclusive}) ? JSON::PP::true : JSON::PP::false;
+my $noisy_paired = ($portfolio->{protocol_compliant} && $option{allow_noisy_host}) ? JSON::PP::true : JSON::PP::false;
+my $portfolio_ci = bootstrap_ci(\@all, $option{bootstrap});
+my $negative = $noisy_paired && $portfolio_ci->{upper} < 1.00
+    ? JSON::PP::true : JSON::PP::false;
+my $report = {
+    schema_version => 1, kind => 'perlonjava-performance-portfolio-report',
+    evidence => { input => $option{input}, generated_at_utc => $portfolio->{generated_at_utc},
+        source_commit => $portfolio->{engines}{source_commit}, protocol_compliant => $portfolio->{protocol_compliant},
+        conclusive => $portfolio->{conclusive}, allow_noisy_host => $option{allow_noisy_host} ? JSON::PP::true : JSON::PP::false },
+    # A noisy paired run can establish a one-sided negative conclusion, but it
+    # must never become an authoritative baseline or pass an acceptance gate.
+    authoritative => $strict_authority,
+    measurement_quality => $strict_authority ? 'stable' : ($noisy_paired ? 'noisy-paired' : 'inconclusive'),
+    decisive_negative_result => $negative, workloads => \@workloads,
+    portfolio_geometric_mean_ratio => geometric_mean(\@all),
+    portfolio_confidence_interval => $portfolio_ci,
+    minimum_workload_ratio => (sort { $a <=> $b } map { $_->{median_ratio} } @workloads)[0],
+    acceptance => acceptance($strict_authority, \@workloads, \@anchors),
+};
+my $json = JSON::PP->new->canonical->pretty->encode($report);
+if (defined $option{output}) { open my $fh, '>:raw', $option{output} or die "cannot write $option{output}: $!\n"; print {$fh} $json; close $fh or die "cannot close $option{output}: $!\n"; }
+print $json;
+
+sub acceptance {
+    my ($authority, $workloads, $anchors) = @_;
+    return { passed => JSON::PP::false, reason => 'input is protocol-inconclusive; not an authoritative baseline' } unless $authority;
+    my $portfolio = geometric_mean([map { $_->{median_ratio} } @$workloads]);
+    return { passed => JSON::PP::false, reason => 'portfolio geometric mean is below 1.05x Perl' } if $portfolio < 1.05;
+    return { passed => JSON::PP::false, reason => 'a scored workload is below 0.90x Perl' }
+        if grep { $_->{median_ratio} < .90 } @$workloads;
+    return { passed => JSON::PP::false, reason => 'closure or Life anchor is below 1.05x Perl' }
+        if @$anchors != 2 || grep { $_->{median_ratio} < 1.05 } @$anchors;
+    return { passed => JSON::PP::true, reason => 'all performance gates passed' };
+}
+sub bootstrap_ci {
+    my ($values, $count) = @_;
+    srand(1196); my @samples;
+    for (1 .. $count) { push @samples, geometric_mean([map { $values->[int rand @$values] } 1 .. @$values]); }
+    @samples = sort { $a <=> $b } @samples;
+    return { lower => $samples[int(.025 * $#samples)], upper => $samples[int(.975 * $#samples)] };
+}
+sub median { my ($v) = @_; my @v = sort { $a <=> $b } @$v; return $v[@v / 2] if @v % 2; return ($v[@v / 2 - 1] + $v[@v / 2]) / 2 }
+sub geometric_mean { my ($v) = @_; my $sum = 0; $sum += log $_ for @$v; return exp($sum / @$v) }
+sub decode_file { my ($path) = @_; open my $fh, '<:raw', $path or die "cannot read $path: $!\n"; local $/; return JSON::PP->new->decode(<$fh>) }
+sub usage { my ($s) = @_; print "usage: $0 --input portfolio.json [--output report.json] [--bootstrap N] [--allow-noisy-host]\n"; exit $s }

dev/bench/performance_workload.pl

@@ -0,0 +1,128 @@
+#!/usr/bin/env perl
+
+# Emits deterministic, per-window measurements for one portfolio workload.
+# It intentionally contains no engine-selection logic; run_performance_portfolio.pl
+# owns fresh-process ordering and evidence collection.
+use strict;
+use warnings;
+use Getopt::Long qw(GetOptions);
+use JSON::PP;
+use Time::HiRes qw(time);
+
+my %option = (window_seconds => 1, windows => 15, warmup_min => 0, warmup_max => 0);
+GetOptions(
+    'workload=s'       => \$option{workload},
+    'window-seconds=i' => \$option{window_seconds},
+    'windows=i'        => \$option{windows},
+    'warmup-min=i'     => \$option{warmup_min},
+    'warmup-max=i'     => \$option{warmup_max},
+) or die "invalid options\n";
+die "--workload is required\n" unless defined $option{workload};
+die "window length must be positive\n" unless $option{window_seconds} > 0;
+die "window count must be positive\n" unless $option{windows} > 0;
+die "warmup maximum must be at least warmup minimum\n"
+    if $option{warmup_max} < $option{warmup_min};
+
+my ($operation, $operations_per_iteration, $checksum) = workload($option{workload});
+$checksum = $operation->() unless defined $checksum;
+my @warmup;
+for my $window (1 .. $option{warmup_max}) {
+    push @warmup, run_window($operation, $operations_per_iteration,
+        $option{window_seconds}, $window);
+    last if warmup_stabilized(\@warmup) && $window >= $option{warmup_min};
+}
+my @windows = map { run_window($operation, $operations_per_iteration,
+    $option{window_seconds}, $_) } 1 .. $option{windows};
+
+print JSON::PP->new->canonical->encode({
+    schema_version => 1,
+    kind => 'perlonjava-performance-workload',
+    workload => $option{workload},
+    warmup_stabilized => warmup_stabilized(\@warmup),
+    semantic_checksum => "$checksum",
+    operations_per_iteration => $operations_per_iteration,
+    warmup_windows => \@warmup,
+    windows => \@windows,
+}), "\n";
+
+sub run_window {
+    my ($operation, $operations_per_iteration, $seconds, $window) = @_;
+    my ($iterations, $value) = (0, 0);
+    my $started = time;
+    my $cpu_started = process_cpu_seconds();
+    do {
+        my $result = $operation->();
+        die "workload semantic checksum changed\n" if $result != $checksum;
+        $value ^= $result;
+        ++$iterations;
+    } while (time - $started < $seconds);
+    my $elapsed = time - $started;
+    my $cpu_elapsed = process_cpu_seconds() - $cpu_started;
+    return {
+        index => $window,
+        elapsed_seconds => 0 + $elapsed,
+        process_cpu_seconds => 0 + $cpu_elapsed,
+        iterations => $iterations,
+        operations => $iterations * $operations_per_iteration,
+        throughput => ($iterations * $operations_per_iteration) / $elapsed,
+        rolling_value => 0 + $value,
+    };
+}
+
+sub process_cpu_seconds {
+    my @times = times;
+    return $times[0] + $times[1];
+}
+
+sub warmup_stabilized {
+    my ($samples) = @_;
+    return JSON::PP::false if @$samples < 5;
+    my @rates = map { $_->{throughput} } @$samples[-5 .. -1];
+    my $mean = sum(\@rates) / @rates;
+    my $cv = sqrt(sum([map { ($_ - $mean) ** 2 } @rates]) / @rates) / $mean;
+    my $slope = abs($rates[-1] - $rates[0]) / $mean;
+    return ($cv < .03 && $slope < .02) ? JSON::PP::true : JSON::PP::false;
+}
+
+sub sum { my ($values) = @_; my $sum = 0; $sum += $_ for @$values; return $sum }
+
+sub workload {
+    my ($name) = @_;
+    if ($name eq 'closure') {
+        my ($a, $b, $c) = (1, 2, 3);
+        my $make = sub { my ($x, $y, $z) = @_; my ($u, $v, $w) = ($x + 1, $y + 2, $z + 3); return sub { $u + $v + $w + $a + $b + $c } };
+        my $f = $make->(10, 20, 30);
+        return (sub { my $sum = 0; $sum += $f->() for 1 .. 128; return $sum }, 128, undef);
+    }
+    if ($name eq 'method') {
+        my $class = 'PortfolioMethod';
+        no strict 'refs'; ## no critic
+        *{"${class}::new"} = sub { bless { x => 1, y => 2 }, shift };
+        *{"${class}::add"} = sub { my ($self, $n) = @_; $self->{x} += $n; $self->{y} += $n; return $self->{x} + $self->{y} };
+        return (sub { my $o = $class->new; my $sum = 0; $sum += $o->add(1) for 1 .. 64; return $sum }, 64, 4352);
+    }
+    if ($name eq 'numeric') {
+        our $global;
+        return (sub { $global = 7; my $lexical = 11; for (1 .. 2048) { $lexical = ($lexical * 33 + $_) % 1_000_003; $global = ($global + $lexical) % 1_000_003 } return $lexical ^ $global }, 2048, undef);
+    }
+    if ($name eq 'string') {
+        return (sub { my $s = 'PerlOnJava'; for (1 .. 256) { $s = substr($s . ':' . $_, -24) } return length($s) }, 256, 24);
+    }
+    if ($name eq 'regex') {
+        my $text = join ':', qw(alpha beta 42 gamma delta 42 epsilon zeta);
+        return (sub { my $count = 0; for (1 .. 256) { pos($text) = 0; ++$count while $text =~ /(?:42|gamma|epsilon)/g } return $count }, 768, undef);
+    }
+    if ($name eq 'json') {
+        my $json = JSON::PP->new->canonical;
+        my $input = { alpha => [1, 2, 3], beta => { enabled => JSON::PP::true, text => 'PerlOnJava' } };
+        return (sub { my $text = $json->encode($input); my $out = $json->decode($text); return scalar @{$out->{alpha}} + length($out->{beta}{text}) }, 2, 13);
+    }
+    if ($name eq 'life') {
+        # A fixed flat word-level kernel.  The full application's parallel and
+        # flat layouts remain companion diagnostics; this kernel is
+        # deterministic and window-friendly.
+        my @seed = map { (($_ * 2_654_435_761) ^ 0x5a5a5a5a) & 0xffff_ffff } 1 .. 128;
+        return (sub { my @grid = @seed; for (1 .. 16) { my @next; for my $i (0 .. $#grid) { my $left = $grid[($i - 1) % @grid]; my $cell = $grid[$i]; my $right = $grid[($i + 1) % @grid]; $next[$i] = ((($cell << 1) | ($left >> 31)) ^ (($cell >> 1) | (($right & 1) << 31)) ^ ($left & $right)) & 0xffff_ffff } @grid = @next } my $sum = 0; $sum ^= $_ for @grid; return $sum }, 2048, undef);
+    }
+    die "unknown workload '$name' (expected closure, method, numeric, string, regex, life, or json)\n";
+}