diff --git a/dev/bench/README.md b/dev/bench/README.md index 744eb6f5c..78770efb6 100644 --- a/dev/bench/README.md +++ b/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 diff --git a/dev/bench/analyze_performance_portfolio.pl b/dev/bench/analyze_performance_portfolio.pl new file mode 100644 index 000000000..1bd54850a --- /dev/null +++ b/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 } diff --git a/dev/bench/performance_workload.pl b/dev/bench/performance_workload.pl new file mode 100644 index 000000000..201da5954 --- /dev/null +++ b/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"; +} diff --git a/dev/bench/run_performance_portfolio.pl b/dev/bench/run_performance_portfolio.pl new file mode 100644 index 000000000..f89456690 --- /dev/null +++ b/dev/bench/run_performance_portfolio.pl @@ -0,0 +1,202 @@ +#!/usr/bin/env perl + +# Run the performance portfolio in alternating fresh Perl/PerlOnJava pairs. +use strict; +use warnings; +use Cwd qw(abs_path); +use Digest::SHA qw(sha256_hex); +use File::Path qw(make_path); +use File::Spec; +use FindBin qw($Bin); +use Getopt::Long qw(GetOptions); +use IPC::Open3 qw(open3); +use JSON::PP; +use Symbol qw(gensym); + +my %option = (pairs => 7, warmup_min => 10, warmup_max => 60, windows => 15, + window_seconds => 1, timeout => 180, output_dir => 'dev/bench/results', + jfr => 0, jfr_max_size => '32m', call_layer_diagnostics => 0); +GetOptions( + 'pairs=i' => \$option{pairs}, 'warmup-min=i' => \$option{warmup_min}, + 'warmup-max=i' => \$option{warmup_max}, 'windows=i' => \$option{windows}, + 'window-seconds=i' => \$option{window_seconds}, 'timeout=i' => \$option{timeout}, + 'output-dir=s' => \$option{output_dir}, 'workload=s@' => \$option{workloads}, + 'jfr!' => \$option{jfr}, 'jfr-tool=s' => \$option{jfr_tool}, + 'jfr-max-size=s' => \$option{jfr_max_size}, + 'call-layer-diagnostics!' => \$option{call_layer_diagnostics}, + 'help' => \$option{help}, +) or usage(2); +usage(0) if $option{help}; +die "all numeric options must be positive\n" if grep { $option{$_} < 1 } qw(pairs warmup_min warmup_max windows window_seconds timeout); +die "--warmup-max must be at least --warmup-min\n" if $option{warmup_max} < $option{warmup_min}; +die "--jfr-max-size must be a positive JFR size such as 32m\n" + unless $option{jfr_max_size} =~ /^[1-9][0-9]*[kKmMgG]$/; +my @workloads = @{$option{workloads} || [qw(closure method numeric string regex life json)]}; +my $root = abs_path(File::Spec->catdir($Bin, '..', '..')); +my $worker = File::Spec->catfile($Bin, 'performance_workload.pl'); +my $jperl = File::Spec->catfile($root, 'jperl'); +die "missing launcher $jperl; run make before collecting a portfolio\n" unless -x $jperl; +my $stamp = timestamp(); +my $output_root = File::Spec->file_name_is_absolute($option{output_dir}) + ? $option{output_dir} : File::Spec->catdir($root, $option{output_dir}); +my $directory = File::Spec->catdir($output_root, $stamp); +make_path($directory); +my %result = (schema_version => 1, kind => 'perlonjava-performance-portfolio', + protocol_compliant => protocol_compliant(\%option), generated_at_utc => $stamp, + configuration => \%option, workloads => \@workloads, host => host_identity(), + engines => engine_identity($root, $jperl), results => []); +for my $workload (@workloads) { + my @pairs; + for my $pair (1 .. $option{pairs}) { + my @order = $pair % 2 ? qw(perl perlonjava) : qw(perlonjava perl); + my %runs; + for my $engine (@order) { + my $jfr = $option{jfr} && $engine eq 'perlonjava' + ? File::Spec->catfile($directory, sprintf('%s-pair-%02d.jfr', $workload, $pair)) + : undef; + my $call_layer = $option{call_layer_diagnostics} && $engine eq 'perlonjava' + ? File::Spec->catfile($directory, sprintf('%s-pair-%02d-call-layer.json', $workload, $pair)) + : undef; + $runs{$engine} = invoke($engine, $workload, \%option, $worker, $jperl, $jfr, $call_layer); + if (defined $jfr) { + $runs{$engine}{jfr} = artifact($jfr); + $runs{$engine}{jfr_metrics} = jfr_metrics($jfr, $option{jfr_tool}); + } + if (defined $call_layer) { + die "expected call-layer diagnostics were not created: $call_layer\n" unless -s $call_layer; + $runs{$engine}{call_layer_diagnostics} = artifact($call_layer); + $runs{$engine}{call_layer_metrics} = decode_file($call_layer); + } + } + die "semantic checksum mismatch for $workload pair $pair\n" + unless $runs{perl}{semantic_checksum} eq $runs{perlonjava}{semantic_checksum}; + push @pairs, { pair => $pair, execution_order => \@order, engines => \%runs }; + } + push @{$result{results}}, { workload => $workload, pairs => \@pairs }; +} +my $output = File::Spec->catfile($directory, 'portfolio.json'); +$result{conclusive} = portfolio_conclusive(\%result); +open my $fh, '>:raw', $output or die "cannot write $output: $!\n"; +print {$fh} JSON::PP->new->canonical->pretty->encode(\%result); +close $fh or die "cannot close $output: $!\n"; +print "$output\n"; + +sub invoke { + my ($engine, $workload, $option, $worker, $jperl, $jfr, $call_layer) = @_; + my @engine = $engine eq 'perl' ? ('perl') : ('timeout', $option->{timeout}, $jperl); + my @command = (@engine, $worker, '--workload', $workload, '--window-seconds', $option->{window_seconds}, '--windows', $option->{windows}, '--warmup-min', $option->{warmup_min}, '--warmup-max', $option->{warmup_max}); + local %ENV = %ENV; + if (defined $jfr) { + die "JFR output path may not contain whitespace: $jfr\n" if $jfr =~ /\s/; + $ENV{JPERL_OPTS} = join ' ', grep { length } ($ENV{JPERL_OPTS} // '', + "-XX:StartFlightRecording=filename=$jfr,dumponexit=true,settings=profile,maxsize=$option->{jfr_max_size}"); + } + if (defined $call_layer) { + die "call-layer output path may not contain whitespace: $call_layer\n" if $call_layer =~ /\s/; + $ENV{JPERL_OPTS} = join ' ', grep { length } ($ENV{JPERL_OPTS} // '', + '-Dperlonjava.callLayerDiagnostics=true', + "-Dperlonjava.callLayerDiagnosticsOutput=$call_layer"); + } + open my $fh, '-|', @command or die "cannot start @command: $!\n"; + local $/; my $raw = <$fh>; close $fh; + die "benchmark failed for $engine/$workload (exit $?)\n" if $? != 0; + my ($payload) = grep { /^\{/ } reverse split /\n/, ($raw // ''); + my $decoded = eval { JSON::PP->new->decode($payload // '') }; + die "invalid benchmark JSON for $engine/$workload: $@\n" unless ref($decoded) eq 'HASH'; + return $decoded; +} +sub artifact { + my ($path) = @_; + die "expected profiling artifact was not created: $path\n" unless -f $path && -s $path; + return { path => abs_path($path), sha256 => sha256_hex(slurp($path)), bytes => -s $path }; +} +sub jfr_metrics { + my ($recording, $tool) = @_; + $tool //= find_jfr_tool(); + die "JFR tool not found; pass --jfr-tool PATH\n" unless defined $tool && -x $tool; + my $raw = command_output($tool, 'print', '--json', '--events', + 'jdk.GarbageCollection,jdk.ThreadAllocationStatistics', $recording); + my $document = eval { JSON::PP->new->decode($raw // '') }; + die "cannot parse JFR JSON from $tool: $@\n" unless ref($document) eq 'HASH'; + my (@gc, %latest_thread, $samples); + for my $event (@{$document->{recording}{events} || []}) { + my $value = $event->{values} || {}; + if ($event->{type} eq 'jdk.GarbageCollection') { push @gc, duration_seconds($value->{duration}); } + if ($event->{type} eq 'jdk.ThreadAllocationStatistics') { + my $id = $value->{thread}{javaThreadId} // 'unknown'; + $latest_thread{$id} = $value->{allocated} if !exists($latest_thread{$id}) || $value->{allocated} > $latest_thread{$id}; + } + } + my $summary = command_output($tool, 'summary', $recording) // ''; + ($samples) = $summary =~ /^\s*jdk\.ObjectAllocationSample\s+(\d+)\s+/m; + my $gc_seconds = 0; $gc_seconds += $_ for @gc; + my $allocated = 0; $allocated += $_ for values %latest_thread; + return { gc_count => 0 + @gc, gc_pause_seconds => 0 + $gc_seconds, + gc_longest_pause_seconds => @gc ? 0 + (sort { $b <=> $a } @gc)[0] : 0, + thread_allocated_bytes => 0 + $allocated, allocation_sample_count => 0 + ($samples // 0) }; +} +sub duration_seconds { my ($duration) = @_; return 0 unless defined $duration && $duration =~ /^PT([0-9.]+)S$/; return 0 + $1 } +sub find_jfr_tool { + return "$ENV{JAVA_HOME}/bin/jfr" if defined($ENV{JAVA_HOME}) && -x "$ENV{JAVA_HOME}/bin/jfr"; + if (-x '/usr/libexec/java_home') { my $home = chomped(command_output('/usr/libexec/java_home')); return "$home/bin/jfr" if defined($home) && -x "$home/bin/jfr"; } + return undef; +} + +sub engine_identity { + my ($root, $jperl) = @_; + my $jar = active_jar($root); + return { + perl_version => command_output('perl', '-V'), + jvm_version => command_output($ENV{PERLONJAVA_JAVA_BIN} || 'java', '-version'), + jvm_flags => { map { $_ => $ENV{$_} } grep { defined $ENV{$_} } + qw(JPERL_OPTS JAVA_TOOL_OPTIONS JDK_JAVA_OPTIONS) }, + jperl_launcher_sha256 => sha256_hex(slurp($jperl)), + jar => $jar, + source_commit => chomped(command_output('git', '-C', $root, 'rev-parse', 'HEAD')), + source_status => command_output('git', '-C', $root, 'status', '--short'), + }; +} +sub host_identity { + return { + uname => chomped(command_output('uname', '-a')), + uptime => chomped(command_output('uptime')), + }; +} +sub active_jar { + my ($root) = @_; + my $path = $ENV{PERLONJAVA_JAR}; + if (!defined $path) { + my @candidate = grep { $_ !~ m{/original-} } glob(File::Spec->catfile($root, 'target', 'perlonjava-*.jar')); + ($path) = sort { (stat($b))[9] <=> (stat($a))[9] } @candidate; + } + return undef unless defined $path && -f $path; + return { path => abs_path($path), sha256 => sha256_hex(slurp($path)) }; +} +sub command_output { + my @command = @_; + my $stderr = gensym; + my $stdout; + my $pid = eval { open3(undef, $stdout, $stderr, @command) }; + return undef unless $pid; + my $output = do { local $/; <$stdout> // '' }; + $output .= do { local $/; <$stderr> // '' }; + waitpid($pid, 0); + return $output; +} +sub chomped { my ($value) = @_; return undef unless defined $value; chomp $value; return $value } +sub slurp { my ($path) = @_; open my $fh, '<:raw', $path or die $!; local $/; return <$fh> } +sub decode_file { my ($path) = @_; return JSON::PP->new->decode(slurp($path)) } +sub protocol_compliant { my ($o) = @_; return ($o->{pairs} >= 7 && $o->{warmup_min} >= 10 && $o->{warmup_max} >= 60 && $o->{windows} >= 15 && $o->{window_seconds} == 1) ? JSON::PP::true : JSON::PP::false } +sub portfolio_conclusive { + my ($result) = @_; + for my $workload (@{$result->{results}}) { + for my $pair (@{$workload->{pairs}}) { + for my $engine (qw(perl perlonjava)) { + return JSON::PP::false unless $pair->{engines}{$engine}{warmup_stabilized}; + } + } + } + return JSON::PP::true; +} +sub timestamp { my @t = gmtime; return sprintf('%04d%02d%02dT%02d%02d%02dZ', $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]) } +sub usage { my ($status) = @_; print "usage: $0 [--workload NAME] [--pairs N] [--output-dir DIR] [--jfr-max-size 32m] [--call-layer-diagnostics]\n"; exit $status } diff --git a/dev/design/performance-over-perl.md b/dev/design/performance-over-perl.md new file mode 100644 index 000000000..6abdbfe5b --- /dev/null +++ b/dev/design/performance-over-perl.md @@ -0,0 +1,292 @@ +# Performance over Perl + +Issue: [#1196](https://github.com/fglock/PerlOnJava/issues/1196) + +## Goal and acceptance contract + +The default JVM compiler backend must beat a pinned optimized maintained Perl +build on the reference host. Startup, parsing, bytecode generation, and JVM +warmup are excluded. Completion requires a portfolio geometric mean of at +least 1.05x Perl with a 95% confidence interval wholly above 1.00x, the same +result for the closure and Life anchors, no scored workload below 0.90x Perl, +and preserved Perl semantics and backend parity. + +## Benchmark authority + +`dev/bench/run_performance_portfolio.pl` is the versioned orchestrator and +`dev/bench/performance_workload.pl` emits deterministic per-window JSON. The +default protocol uses seven alternating fresh-process pairs per workload, at +least ten one-second warmup windows, a maximum sixty-second stabilization +period, and fifteen one-second measurement windows. Stability requires the +last five warmup windows to have a throughput slope below 2% and coefficient +of variation below 3%; otherwise the result is inconclusive. Shorter runs are +allowed only for smoke testing and are marked `protocol_compliant: false`. + +On a reference host that cannot be made quiet, the analyzer's explicit +`--allow-noisy-host` mode may classify a completed default protocol as +`noisy-paired`. It never permits an acceptance claim. It can only establish a +decisive negative baseline when the paired portfolio bootstrap interval's +upper bound is below 1.00x Perl; the report retains the host state and noisy +quality label. + +The scored groups are closure invocation, method dispatch/blessed-hash access, +lexical/global numeric loops, strings, regexes, bit-packed Life (word kernel), +and deterministic JSON::PP encode/decode. Each window reports elapsed time, +iteration and operation counts, throughput, and a workload checksum. + +Raw output must also identify the source/JAR, Perl/JDK versions and flags, host +state, process CPU time, allocation rate, GC time, and profiling artifacts. +The runner records source/JAR/launcher hashes, Perl/JVM identity and flags, +host state, and wall/process-CPU time. `--jfr` emits one HotSpot profile +recording per PerlOnJava pair and hashes it into the JSON evidence. Recordings +are capped at 32 MB by default (`--jfr-max-size` may set another bounded JFR +size); extract a compact report and remove raw recordings when the +investigation ends. It extracts GC count, aggregate/longest pause, per-thread +allocation counters, and sampled allocation-event count. Async-profiler +collection is still required before a complete attribution report. + +## Optimization gates + +Do not merge a production shortcut based on sampling alone. Gather JFR CPU, +allocation, GC, lock, thread, and code-cache events; async-profiler CPU and +allocation profiles; HotSpot compilation/inlining/deoptimization logs; and +generated-bytecode evidence. Diagnostic-only call-layer ablations must report +exclusive and inclusive nanoseconds and allocated bytes per operation. + +An optimization advances only when it explains at least 10% of an anchor or 5% +of portfolio time. If call scaffolding qualifies, consolidate the general call +boundary before a closure-only fast path. Primitive numeric specialization is +a separate later phase; preserve unsigned IV and Math::BigInt behavior. + +## Progress Tracking + +### Current Status: Phase 3 in progress — copy-on-write pristine arguments evaluated + +The initial runner and deterministic workload protocol are implemented. Its +JSON contract now captures wall/process-CPU window timing and execution +identity; JFR artifacts and GC/allocation summaries, plus workload and +portfolio-report contract tests, are in place. `analyze_performance_portfolio.pl` +computes paired medians, geometric means, deterministic bootstrap intervals, +and refuses to label a protocol-inconclusive input authoritative, including +when noisy-host mode establishes a one-sided negative conclusion. + +The first full candidate was collected at source commit `3b2da750b` on +2026-09-08 with the default 7-pair/15-window/60-second-max-warmup protocol. +It completed semantically but was **rejected as non-authoritative**: the +strict last-five-window stability rule failed in 19 engine/workload runs (CV +3–17%, slope up to 35%). Its compact analysis measured a 0.139x portfolio +geometric mean (bootstrap 95% CI 0.097–0.192) and a 0.158x closure median; +these values are diagnostic only, not acceptance evidence. + +The seven closure JFR recordings nevertheless identify a qualifying general +call-boundary bottleneck: `RuntimeCode.apply` occurred in 15,771 of 15,956 +sampled execution stacks (98.8%). This exceeds the 10% anchor threshold by a +wide margin. The next implementation phase must consolidate the general call +boundary, not add a closure-only shortcut. + +A second full candidate was collected at source commit `e0db10de7` on +2026-09-08 on the same loaded reference host. It was protocol-compliant, +semantically matched, and contained seven fresh pairs for each workload, but +five engine/workload samples did not stabilize (one closure Perl sample and +four regex samples). Its explicit `--allow-noisy-host` analysis is therefore +**noisy-paired, not authoritative**; it establishes only a decisive negative +result. The portfolio geometric mean was 0.146x Perl (bootstrap 95% CI +0.103–0.199; upper bound below 1.00), and every individual workload interval +was below 1.00. This is sufficient to prioritize the identified call-boundary +bottleneck, but cannot satisfy the positive 1.05x acceptance gate. + +A third full candidate at source commit `f774d3b7c` finally produced the +required **stable authoritative baseline** on 2026-09-08. All seven default +pairs for every workload completed, every warmup stabilized, and all semantic +checks matched. Its portfolio geometric mean was 0.144x Perl (bootstrap 95% CI +0.102–0.197); closure was 0.155x and Life was 0.371x. The slowest workload was +JSON at 0.0083x. The report is authoritative evidence, not a passing +acceptance result: its confidence interval lies wholly below 1.00x and it +fails the 1.05x portfolio, anchor, and minimum-workload gates. This is the +baseline against which the call-boundary redesign must be measured. + +| Workload | Median ratio to Perl | Bootstrap 95% CI | +| --- | ---: | --- | +| Closure | 0.155x | 0.153–0.161x | +| Method | 0.167x | 0.156–0.175x | +| Numeric | 0.298x | 0.296–0.301x | +| String | 0.277x | 0.257–0.284x | +| Regex | 0.173x | 0.171–0.205x | +| Life | 0.371x | 0.368–0.376x | +| JSON | 0.0083x | 0.0084–0.0097x | + +Phase 2 attribution was completed with a 47-second JFR closure capture on +2026-09-08 (source commit `5b5b69569`) recorded 2,756 execution samples, of +which 1,445 (52.4%) contained `RuntimeCode.apply`; its frames occurred 3,476 +times because nested calls can put more than one facade frame on a sampled +stack. Of 13,239 weighted allocation samples (106.2 GB estimated allocation +weight), 73.0 GB (68.7%) were on stacks containing that facade. The largest +allocation classes were `RuntimeScalar` (35.9 GB), `Object[]` (25.0 GB), and +`RuntimeList` (10.4 GB). The same recording saw 164 young GCs, one monitor +enter event, no thread parks, and no code-cache-full events. The raw 2.7 MB +recording and temporary expanded files were removed after these results were +extracted. + +A separate HotSpot compilation capture recorded 24 `RuntimeCode.apply` and +50 generated `anon*.apply` compilation records, including 95 deoptimizations +but no code-cache-full event. The selected compilation tasks contained 1,866 +failed inline decisions, 235 because a callee was too large. A bytecode-size +probe while compiling/running the closure workload emitted 270 generated +classes; the largest generated `apply` body was 8,683 bytes, exceeding the +2 KB target in [the apply-bytecode design](reduce-apply-bytecode.md). These +independent CPU, allocation, compilation, and bytecode signals qualify the +general call boundary for redesign. + +Async-profiler 4.5 became available on the host later that day. A separate +closure capture used its stack filter for `RuntimeCode.apply`, so each flat +profile below is scoped to call-boundary-inclusive stacks rather than reported +as whole-process time. The 30-second CPU profile collected 3,004 samples: +`RuntimeCode.apply` itself was 10.99% exclusive CPU, independently exceeding +the 10% anchor gate. Its direct supporting operations were also prominent: +caller-warning restoration (6.09%), frame-level cleanup (4.96%), argument +popping (4.26%), and callee-warning setup (1.90%). The allocation profile ran +until the target's normal exit (21.6 seconds of the requested 30) and collected +125,262 samples / 32.83 GB of sampled allocation on those stacks. Its leading +classes were `Object[]` (27.34%), `RuntimeScalar` (24.07%), `RuntimeList` +(9.02%), `ArrayList` (5.98%), and `RuntimeArray` (5.91%). This completes the +required async-profiler CPU/allocation evidence; all profile files and the +workload log were removed after compact extraction. + +The first Phase 3 candidate, commit `91b081e17`, centralized the two general +instance paths' direct invocation, scalar coercion, closure protection, and +diagnostic mark in `RuntimeCode.invokeCallable`. Its focused permanent +boundary-semantics test passed on Perl, JVM, and interpreter, and its exact +commit passed the complete `make` gate. A subsequent full default portfolio +was semantically successful but protocol-inconclusive on the loaded host: its +geometric mean was 0.147x Perl (bootstrap 95% CI 0.105–0.200), compared with +the 0.144x authoritative baseline. It is diagnostic evidence only and cannot +support an acceptance claim. + +Post-candidate async-profiler captures confirm that this safe consolidation +did not remove the dominant boundary. A 20-second unfiltered CPU capture +contained `RuntimeCode.apply` on 1,995 of 2,221 sampled stacks (89.82%). A +15-second allocation capture attributed 99.91% of its collapsed allocation +weight to stacks containing that method. The raw profiles and workload logs +were removed after extracting these compact figures. The next candidate must +reduce the frame/argument lifecycle structurally while retaining the covered +caller, warning, control-flow, context, and argument-alias semantics. + +A second Phase 3 candidate, commit `5402b099a`, moved the complete general +call-frame lifecycle into one private method with an explicit fresh-versus- +shared `@_` parameter. It added permanent coverage for exceptional boundary +unwind, including argument aliasing and restored frame stacks; the test passed +on Perl, JVM, and interpreter, and the exact commit passed `make`. Its complete +seven-pair portfolio was stable and authoritative but still failed acceptance: +0.1472x Perl (bootstrap 95% CI 0.104–0.200), with a 0.00924x minimum workload. +This is only a modest change from the 0.144x baseline and is not a passing +performance result. + +Post-candidate async-profiler again confirms that the general boundary remains +dominant: `RuntimeCode.apply` appeared on 1,984 of 2,125 closure CPU stacks +(93.36%) and 99.72% of the collapsed allocation weight in a separate +15-second capture. The full portfolio, analysis, CPU profile, allocation +profile, and workload logs were removed after compact extraction. Future work +must remove frame/argument lifecycle cost rather than only centralizing it; +if that structural redesign cannot materially reduce this attribution, advance +to primitive numeric specialization as the next larger phase. + +A follow-up general candidate made the active lexical-pad map and JVM closure +tracking collections lazy: ordinary calls retain their stack entries but avoid +allocating empty maps/lists unless they create a closure, return one, or expose +a live lexical. Its permanent boundary tests passed on Perl, JVM, and +interpreter, and a clean `make` gate passed. The completed seven-pair +portfolio on the routinely loaded host was protocol-inconclusive and nearly +flat (0.1481x Perl; bootstrap 95% CI 0.105–0.200; minimum 0.00976x), so this +is retained only as a safe allocation reduction, not evidence of a material +speedup. The temporary portfolio directory, log, and report were deleted. + +The next Phase 3 candidate, commit `c32d45d54`, made the pristine `@_` +snapshot copy-on-write. An active argument frame initially retains the live +argument array and snapshots only immediately before a mutation; the permanent +`runtime_code_pristine_args_cow.t` coverage verifies both entry-time +`@DB::args` values and its scalar-slot aliasing. The test passed on system +Perl, the JVM backend, and the interpreter, and the exact commit passed +`make`. A 49-recording JFR/diagnostic portfolio measured the closure named- +argument boundary at 1,432 ns/op inclusive, 567 ns/op exclusive, and 3,154 / +1,261 B/op inclusive/exclusive; it is attribution evidence only because JFR +perturbs timing. The corresponding default seven-pair portfolio was stable +and authoritative but still failed acceptance: 0.1457x Perl (bootstrap 95% CI +0.1036–0.1976), with a 0.00930x minimum workload. This nearly flat result +retains the change for its safe lazy-copy behavior, but it does not justify a +positive performance claim. All JFR recordings, portfolio directories, logs, +and reports were removed after compact extraction. + +The next Phase 3 candidate, commit `059614214`, replaced the unconditional +per-call `JvmClosureFrame` allocation with a shared stack sentinel, creating a +real frame only when a captured closure is made. This remains a general call +boundary change: it retains nesting, returned-closure protection, and capture +cleanup rather than adding a closure-only dispatch path. The permanent +returned-closure capture-lifetime regression passed on system Perl, JVM, and +interpreter, and the exact commit passed `make`. Its 49-recording JFR and +call-layer portfolio measured the closure named-argument boundary at 1,372 +ns/op inclusive, 543 ns/op exclusive, and 3,082 / 1,238 B/op +inclusive/exclusive (333 million operations); JFR timing is attribution only. +The non-JFR seven-pair portfolio was protocol-inconclusive on the loaded host, +with 0.1458x Perl (bootstrap 95% CI 0.1039–0.1973) and a 0.00954x minimum +workload. The small diagnostic change does not demonstrate the required +structural reduction, so it is retained only as a safe allocation improvement. +All profile recordings, portfolios, logs, and reports were removed after +compact extraction. + +### Completed Phases + +- [x] Phase 1: Benchmark authority (2026-09-08; stable authoritative + baseline recorded, decisively below the positive performance target) +- [x] Phase 2: Attribution report (2026-09-08; JFR, HotSpot, bytecode, and + async-profiler evidence qualify the general `RuntimeCode.apply` boundary) +- [ ] Phase 3: Call-boundary redesign (safe general-body consolidation and + lazy argument/closure frame reductions evaluated; remaining frame lifecycle + work) +- [ ] Phase 4: Primitive numeric specialization +- [ ] Phase 5: Generated-code/JIT quality + +### Next Steps + +1. Design a structural general-boundary candidate that makes inactive caller, + context, warning, and control-flow bookkeeping lazy without changing + caller/`@DB::args`, warning, control-flow, context, or alias semantics. + If that cannot materially reduce `RuntimeCode.apply` exclusive cost or + allocation, begin Phase 4 primitive numeric specialization. +2. Extend permanent boundary coverage for each lazily materialized state, then + use the call-layer diagnostics on closure and method before and after each + candidate; retain only compact JSON summaries and require a material + reduction in the `RuntimeCode.apply` exclusive cost or allocation. +3. Repeat the complete default protocol after a candidate passes focused + semantic coverage; only a stable report meeting every acceptance gate may + make a positive claim. + +### Latest candidate evidence (2026-09-09) + +The plain implicit-`$_` foreach alias candidate (`b5300e777`) safely avoids +wrapper/root bookkeeping when replacing one existing plain scalar alias with +another. Its complete default seven-pair portfolio was protocol-compliant and +conclusive, but still decisively failed the acceptance gates: closure 0.1594x, +method 0.1665x, numeric 0.3350x, string 0.2911x, regex 0.1870x, life 0.3815x, +and JSON 0.0102x Perl. Numeric improved from the preceding 0.3021x result, +but no scored workload reached the required 0.90x floor. + +The required 49-recording JFR plus call-layer-diagnostic portfolio also +completed successfully. It confirms that general named-argument calls still +carry substantial boundary allocation and inclusive time; for the numeric +workload, the sampled named-argument category measured about 2.41 MB/op +inclusive allocation and 289 us/op inclusive time. JFR timing is attribution +evidence only. The 160 MB fixed temporary profile directory, ordinary +portfolio directory, logs, and commit-message scratch file were deleted after +extracting these figures. + +This candidate is retained as a small safe loop improvement, but its evidence +advances the active work to Phase 4: prove and introduce primitive numeric +representation/code-generation only for statically safe scalar flows, with a +full semantic fallback for overload, taint, references, warnings, localization, +and aliasing. + +### Open Questions + +- Which reference host can be kept sufficiently quiet for the acceptance gate? +- Should Life retain the application-level flat/parallel workloads alongside + the deterministic word-kernel score? diff --git a/dev/tools/tests/performance_portfolio_analysis.t b/dev/tools/tests/performance_portfolio_analysis.t new file mode 100644 index 000000000..1dff3cf01 --- /dev/null +++ b/dev/tools/tests/performance_portfolio_analysis.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; +use JSON::PP; +use File::Temp qw(tempdir); +use File::Spec; + +my $root = File::Spec->rel2abs(File::Spec->catdir(File::Spec->curdir)); +my $script = File::Spec->catfile($root, 'dev', 'bench', 'analyze_performance_portfolio.pl'); +my $dir = tempdir(CLEANUP => 1); my $input = File::Spec->catfile($dir, 'portfolio.json'); +my $window = sub { { throughput => $_[0] } }; +my @workloads = map { { workload => $_, pairs => [ map { { engines => { perl => { windows => [$window->(100), $window->(100), $window->(100)] }, perlonjava => { windows => [$window->(50), $window->(50), $window->(50)] } } } } 1..2 ] } } qw(closure life numeric); +open my $fh, '>:raw', $input or die $!; +print {$fh} JSON::PP->new->encode({ kind => 'perlonjava-performance-portfolio', protocol_compliant => JSON::PP::true, conclusive => JSON::PP::false, results => \@workloads }); close $fh; +my $raw = qx{$^X $script --input $input --bootstrap 100}; +is($? >> 8, 0, 'analysis succeeds'); +my $report = JSON::PP->new->decode($raw); +ok(!$report->{authoritative}, 'inconclusive input cannot become authoritative'); +is($report->{acceptance}{reason}, 'input is protocol-inconclusive; not an authoritative baseline', 'reports conclusive gate'); +is($report->{workloads}[0]{median_ratio}, .5, 'computes paired median ratio'); +my $noisy_raw = qx{$^X $script --input $input --bootstrap 100 --allow-noisy-host}; +is($? >> 8, 0, 'noisy-host analysis succeeds'); +my $noisy = JSON::PP->new->decode($noisy_raw); +ok(!$noisy->{authoritative}, 'noisy-host mode does not upgrade an inconclusive input'); +is($noisy->{measurement_quality}, 'noisy-paired', 'labels noisy-host evidence'); +ok($noisy->{decisive_negative_result}, 'confidence interval proves negative result'); +done_testing; diff --git a/dev/tools/tests/performance_workload_contract.t b/dev/tools/tests/performance_workload_contract.t new file mode 100644 index 000000000..98c7b5d53 --- /dev/null +++ b/dev/tools/tests/performance_workload_contract.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use File::Spec; +use FindBin; +use JSON::PP; +use Test::More; + +my $root = File::Spec->rel2abs( + File::Spec->catdir($FindBin::Bin, '..', '..', '..')); +my $worker = File::Spec->catfile( + $root, 'dev', 'bench', 'performance_workload.pl'); + +open my $command, '-|', $^X, $worker, + '--workload', 'closure', + '--window-seconds', '1', + '--windows', '1', + '--warmup-min', '1', + '--warmup-max', '1' + or die "cannot start workload: $!"; +my $output = do { local $/; <$command> }; +ok(close $command, 'workload process completes') or diag($output // ''); + +my $document = JSON::PP->new->decode($output); +is($document->{schema_version}, 1, 'schema version is stable'); +is($document->{workload}, 'closure', 'requested workload is recorded'); +is($document->{semantic_checksum}, '9216', 'closure result is checksummed'); +is(scalar @{$document->{warmup_windows}}, 1, 'warmup window is emitted'); +is(scalar @{$document->{windows}}, 1, 'measurement window is emitted'); + +my $window = $document->{windows}[0]; +ok($window->{elapsed_seconds} >= 1, 'measurement has a full wall-time window'); +ok(defined $window->{process_cpu_seconds}, 'measurement records process CPU time'); +ok($window->{operations} > 0, 'measurement records completed operations'); +ok($window->{throughput} > 0, 'measurement records throughput'); + +done_testing; diff --git a/docs/about/changelog.md b/docs/about/changelog.md index c654bb2fe..8d262157f 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,10 @@ priorities and future plans. ## Work in progress +- Add a versioned, deterministic performance-portfolio runner for #1196, + establishing alternating Perl/PerlOnJava measurements and JSON evidence + before runtime fast-path work begins. + - Preserve IO::Async thread callback results in scalar and list context on both execution backends, and align its notifier-loop refcount expectation with native Perl. diff --git a/src/main/java/org/perlonjava/runtime/operators/MathOperators.java b/src/main/java/org/perlonjava/runtime/operators/MathOperators.java index 17349b128..92f8e6459 100644 --- a/src/main/java/org/perlonjava/runtime/operators/MathOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/MathOperators.java @@ -835,6 +835,13 @@ public static RuntimeScalar modulus(RuntimeScalar arg1, RuntimeScalar arg2) { } private static RuntimeScalar modulusUnpropagated(RuntimeScalar arg1, RuntimeScalar arg2) { + // The overwhelmingly common numeric case needs neither overload + // lookup nor numeric coercion. Keep this before blessedId(): a + // blessed scalar cannot have the plain INTEGER representation. + if (arg1.type == INTEGER && arg2.type == INTEGER && !hasWideInteger(arg1, arg2)) { + return modulusFromLongs(arg1.getLong(), arg2.getLong()); + } + // Prepare overload context and check if object is eligible for overloading int blessId = blessedId(arg1); int blessId2 = blessedId(arg2); @@ -850,22 +857,7 @@ private static RuntimeScalar modulusUnpropagated(RuntimeScalar arg1, RuntimeScal return modulusFromDoubles(arg1.getDouble(), arg2.getDouble()); } - // Use long arithmetic to handle large integers (beyond int range) - long dividend = arg1.getLong(); - long divisor = arg2.getLong(); - long result = dividend % divisor; - - // Adjust result for Perl-style modulus behavior - // In Perl, the result has the same sign as the divisor - if (result != 0 && ((divisor > 0 && result < 0) || (divisor < 0 && result > 0))) { - result += divisor; - } - - // Return as int if it fits, otherwise as long - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) { - return new RuntimeScalar((int) result); - } - return new RuntimeScalar(result); + return modulusFromLongs(arg1.getLong(), arg2.getLong()); } /** @@ -881,6 +873,13 @@ public static RuntimeScalar modulusWarn(RuntimeScalar arg1, RuntimeScalar arg2) } private static RuntimeScalar modulusWarnUnpropagated(RuntimeScalar arg1, RuntimeScalar arg2) { + // Defined integer operands cannot emit an uninitialized warning, so + // they share the ordinary fast path while retaining outer taint + // propagation in modulusWarn(). + if (arg1.type == INTEGER && arg2.type == INTEGER && !hasWideInteger(arg1, arg2)) { + return modulusFromLongs(arg1.getLong(), arg2.getLong()); + } + // Prepare overload context and check if object is eligible for overloading int blessId = blessedId(arg1); int blessId2 = blessedId(arg2); @@ -897,22 +896,7 @@ private static RuntimeScalar modulusWarnUnpropagated(RuntimeScalar arg1, Runtime return modulusFromDoubles(arg1.getDouble(), arg2.getDouble()); } - // Use long arithmetic to handle large integers (beyond int range) - long dividend = arg1.getLong(); - long divisor = arg2.getLong(); - long result = dividend % divisor; - - // Adjust result for Perl-style modulus behavior - // In Perl, the result has the same sign as the divisor - if (result != 0 && ((divisor > 0 && result < 0) || (divisor < 0 && result > 0))) { - result += divisor; - } - - // Return as int if it fits, otherwise as long - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) { - return new RuntimeScalar((int) result); - } - return new RuntimeScalar(result); + return modulusFromLongs(arg1.getLong(), arg2.getLong()); } /** @@ -1256,6 +1240,15 @@ public static RuntimeScalar integerModulus(RuntimeScalar arg1, RuntimeScalar arg return new RuntimeScalar(result); } + /** Native-integer modulus with Perl's divisor-sign result rule. */ + private static RuntimeScalar modulusFromLongs(long dividend, long divisor) { + long result = dividend % divisor; + if (result != 0 && ((divisor > 0 && result < 0) || (divisor < 0 && result > 0))) { + result += divisor; + } + return getScalarInt(result); + } + /** Modulus when at least one operand is already a DOUBLE (see {@link #modulus}). */ private static RuntimeScalar modulusFromDoubles(double dividend, double divisor) { if (divisor == 0.0) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/CallLayerDiagnostics.java b/src/main/java/org/perlonjava/runtime/runtimetypes/CallLayerDiagnostics.java new file mode 100644 index 000000000..bf4477b80 --- /dev/null +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/CallLayerDiagnostics.java @@ -0,0 +1,133 @@ +package org.perlonjava.runtime.runtimetypes; + +import com.sun.management.ThreadMXBean; +import java.io.IOException; +import java.lang.management.ManagementFactory; +import java.nio.file.Files; +import java.nio.file.Path; +import java.util.LinkedHashMap; +import java.util.Map; + +/** + * Opt-in attribution for the general Perl subroutine call boundary. + * + *

This is intentionally controlled by a JVM property, rather than a Perl + * option: the collector changes both timing and allocation behaviour and must + * never be enabled for normal benchmarks. When enabled, nested invocations + * are accounted with a per-thread stack. Each reported category therefore + * has inclusive and exclusive wall-clock nanoseconds and allocated bytes per + * operation. The phase-3 benchmark runner writes the compact JSON result and + * removes any larger profiler artefacts after extracting its evidence.

+ */ +final class CallLayerDiagnostics { + static final boolean ENABLED = Boolean.getBoolean("perlonjava.callLayerDiagnostics"); + private static final String OUTPUT = System.getProperty("perlonjava.callLayerDiagnosticsOutput"); + private static final ThreadMXBean ALLOCATION_BEAN = allocationBean(); + private static final ThreadLocal CURRENT = new ThreadLocal<>(); + private static final Map TOTALS = new LinkedHashMap<>(); + + static { + if (ENABLED && OUTPUT != null && !OUTPUT.isBlank()) { + Runtime.getRuntime().addShutdownHook(new Thread(CallLayerDiagnostics::writeReport, + "perlonjava-call-layer-diagnostics")); + } + } + + private CallLayerDiagnostics() { } + + static Token enter(String category) { + if (!ENABLED) return null; + Token parent = CURRENT.get(); + Token token = new Token(category, parent, System.nanoTime(), allocatedBytes()); + CURRENT.set(token); + return token; + } + + static void markDispatch(Token token) { + if (token != null) token.dispatchNanos = System.nanoTime(); + } + + static void markBodyComplete(Token token) { + if (token != null) token.bodyCompleteNanos = System.nanoTime(); + } + + static void exit(Token token) { + if (token == null) return; + long endNanos = System.nanoTime(); + long endBytes = allocatedBytes(); + CURRENT.set(token.parent); + long inclusiveNanos = Math.max(0, endNanos - token.startNanos); + long inclusiveBytes = Math.max(0, endBytes - token.startBytes); + long exclusiveNanos = Math.max(0, inclusiveNanos - token.childNanos); + long exclusiveBytes = Math.max(0, inclusiveBytes - token.childBytes); + synchronized (TOTALS) { + Totals totals = TOTALS.computeIfAbsent(token.category, ignored -> new Totals()); + totals.operations++; + totals.inclusiveNanos += inclusiveNanos; + totals.exclusiveNanos += exclusiveNanos; + totals.inclusiveBytes += inclusiveBytes; + totals.exclusiveBytes += exclusiveBytes; + if (token.dispatchNanos != 0) totals.setupNanos += token.dispatchNanos - token.startNanos; + if (token.dispatchNanos != 0 && token.bodyCompleteNanos != 0) { + totals.bodyNanos += token.bodyCompleteNanos - token.dispatchNanos; + } + if (token.parent != null) { + token.parent.childNanos += inclusiveNanos; + token.parent.childBytes += inclusiveBytes; + } + } + } + + private static ThreadMXBean allocationBean() { + java.lang.management.ThreadMXBean bean = ManagementFactory.getThreadMXBean(); + if (bean instanceof ThreadMXBean allocationBean && allocationBean.isThreadAllocatedMemorySupported()) { + if (!allocationBean.isThreadAllocatedMemoryEnabled()) allocationBean.setThreadAllocatedMemoryEnabled(true); + return allocationBean; + } + return null; + } + + private static long allocatedBytes() { + return ALLOCATION_BEAN == null ? 0 : ALLOCATION_BEAN.getThreadAllocatedBytes(Thread.currentThread().threadId()); + } + + private static void writeReport() { + StringBuilder json = new StringBuilder("{\n \"kind\": \"perlonjava-call-layer-diagnostics\",\n \"categories\": {"); + synchronized (TOTALS) { + boolean first = true; + for (Map.Entry entry : TOTALS.entrySet()) { + if (!first) json.append(','); + first = false; + Totals value = entry.getValue(); + double operations = Math.max(1, value.operations); + json.append("\n \"").append(entry.getKey()).append("\": {") + .append("\"operations\": ").append(value.operations) + .append(", \"inclusive_nanoseconds_per_operation\": ").append(value.inclusiveNanos / operations) + .append(", \"exclusive_nanoseconds_per_operation\": ").append(value.exclusiveNanos / operations) + .append(", \"inclusive_allocated_bytes_per_operation\": ").append(value.inclusiveBytes / operations) + .append(", \"exclusive_allocated_bytes_per_operation\": ").append(value.exclusiveBytes / operations) + .append(", \"setup_nanoseconds_per_operation\": ").append(value.setupNanos / operations) + .append(", \"body_nanoseconds_per_operation\": ").append(value.bodyNanos / operations) + .append('}'); + } + } + json.append("\n }\n}\n"); + try { + Files.writeString(Path.of(OUTPUT), json); + } catch (IOException e) { + System.err.println("cannot write call-layer diagnostics: " + e.getMessage()); + } + } + + static final class Token { + final String category; final Token parent; final long startNanos; final long startBytes; + long dispatchNanos; long bodyCompleteNanos; long childNanos; long childBytes; + Token(String category, Token parent, long startNanos, long startBytes) { + this.category = category; this.parent = parent; this.startNanos = startNanos; this.startBytes = startBytes; + } + } + + private static final class Totals { + long operations, inclusiveNanos, exclusiveNanos, inclusiveBytes, exclusiveBytes, setupNanos, bodyNanos; + } +} diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java index 96c002994..2ca71388c 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java @@ -49,12 +49,14 @@ public final class ExecutionRuntimeState { public final ArrayDeque> syntheticCallerFrames = new ArrayDeque<>(); public final Deque argsStack = new ArrayDeque<>(); public final Deque activeCodeStack = new ArrayDeque<>(); - final Deque jvmClosureFrames = new ArrayDeque<>(); + // Entries are RuntimeCode's shared no-closure sentinel until a call + // actually creates a captured closure, then a JvmClosureFrame. + final Deque jvmClosureFrames = new ArrayDeque<>(); /** Match-time callback locations, preserved through builtin wrapper frames. */ public final Deque activeRegexCallbackLocations = new ArrayDeque<>(); public final Deque activeRegexCallbackPackages = new ArrayDeque<>(); public final Deque activeLexicalFrames = new ArrayDeque<>(); - public final Deque> pristineArgsStack = new ArrayDeque<>(); + public final Deque pristineArgsStack = new ArrayDeque<>(); final IdentityHashMap deferredArgumentAggregateCleanup = new IdentityHashMap<>(); public final Deque hasArgsStack = new ArrayDeque<>(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index 600ac795b..c42ec9fff 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -1226,6 +1226,19 @@ public static void restoreTemporaryGlobalVariable( } public static void aliasForeachGlobalVariable(String key, RuntimeScalar var) { + RuntimeScalar previous = foreachGlobalAliases().get(key); + if (previous != null + && (previous.type & RuntimeScalarType.REFERENCE_BIT) == 0 + && (var.type & RuntimeScalarType.REFERENCE_BIT) == 0 + && globalState().scalarValues().get(key) == previous) { + // A range-backed implicit $_ loop replaces one already-installed + // plain scalar with another. No reference edge or localization has + // changed, so avoid wrapper-map/root-snapshot bookkeeping. + var.isPackageGlobalRoot = true; + foreachGlobalAliases().put(key, var); + globalState().scalarValues().put(key, var); + return; + } clearForeachGlobalAlias(key); retainForeachAlias(var); foreachGlobalAliases().put(key, var); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java index 366f287f1..c75fa4514 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java @@ -63,6 +63,9 @@ private static Stack dynamicStateStack() { // Direct lvalue stores into ordinary arrays can flip elementsOwned on, but // alias arrays must stay non-owning so shift/pop do not consume caller refs. public boolean elementsAliased; + // Number of active RuntimeCode argument frames using this array as @_. + // RuntimeArrayElementList snapshots their pristine view on first mutation. + int activeArgumentFrameCount; // For mixed @_ arrays: elementsAliased remains true for caller aliases, // while mutating ops such as unshift can insert new counted elements that // this array must release during tail-call/scope cleanup. @@ -104,6 +107,7 @@ private RuntimeArrayElementList newElementList(List values) { } void resetElementListAfterAutovivification() { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(this); elements = newElementList(); } @@ -168,6 +172,7 @@ private RuntimeArrayElementList(RuntimeArray owner, int initialCapacity) { @Override public boolean add(RuntimeScalar value) { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); if (owner.threadShared) { SharedPerlStorage.validateStoredValue(value); SharedPerlStorage.publishBlessing(value); @@ -181,6 +186,7 @@ public boolean add(RuntimeScalar value) { @Override public void add(int index, RuntimeScalar element) { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); if (owner.threadShared) { SharedPerlStorage.validateStoredValue(element); SharedPerlStorage.publishBlessing(element); @@ -194,6 +200,7 @@ public void add(int index, RuntimeScalar element) { @Override public boolean addAll(java.util.Collection c) { + if (!c.isEmpty()) RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); if (!owner.threadShared) { if (!c.isEmpty()) owner.noteIsaMutation(); owner.notePackageRootMutationIf(owner.hasRootEdge(c)); @@ -213,6 +220,7 @@ public boolean addAll(java.util.Collection c) { @Override public boolean addAll(int index, java.util.Collection c) { + if (!c.isEmpty()) RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); if (!owner.threadShared) { if (!c.isEmpty()) owner.noteIsaMutation(); owner.notePackageRootMutationIf(owner.hasRootEdge(c)); @@ -233,6 +241,7 @@ public boolean addAll(int index, java.util.Collection c @Override public RuntimeScalar set(int index, RuntimeScalar element) { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); RuntimeScalar previous = super.get(index); if (owner.threadShared) { SharedPerlStorage.validateStoredValue(element); @@ -247,14 +256,41 @@ public RuntimeScalar set(int index, RuntimeScalar element) { @Override public RuntimeScalar remove(int index) { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); RuntimeScalar previous = super.remove(index); owner.noteIsaMutation(); owner.notePackageRootMutation(previous, null); return previous; } + // ArrayList's Java 21 deque-style methods bypass remove(int) in some + // JDK implementations. Perl's shift/pop map directly to these calls, + // so preserve active @_ frames here as well. + @Override + public RuntimeScalar removeFirst() { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); + return super.removeFirst(); + } + + @Override + public RuntimeScalar removeLast() { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); + return super.removeLast(); + } + + @Override + public void addFirst(RuntimeScalar element) { + add(0, element); + } + + @Override + public void addLast(RuntimeScalar element) { + add(element); + } + @Override public boolean remove(Object o) { + if (contains(o)) RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); boolean removed = super.remove(o); if (removed && o instanceof RuntimeScalar scalar) { owner.noteIsaMutation(); @@ -266,11 +302,32 @@ public boolean remove(Object o) { @Override public void clear() { if (!isEmpty()) { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); owner.noteIsaMutation(); owner.notePackageRootClear(this); } super.clear(); } + + @Override + public boolean removeAll(java.util.Collection c) { + if (!isEmpty() && !c.isEmpty()) { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); + } + return super.removeAll(c); + } + + @Override + public boolean retainAll(java.util.Collection c) { + if (!isEmpty()) RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); + return super.retainAll(c); + } + + @Override + protected void removeRange(int fromIndex, int toIndex) { + if (fromIndex != toIndex) RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(owner); + super.removeRange(fromIndex, toIndex); + } } public void markIsaArray() { @@ -1329,6 +1386,29 @@ public RuntimeArray setFromListAliased(RuntimeList list) { return this; } + /** + * Replace this array with existing scalar slots without copying them. + * + *

{@code @DB::args} is an alias view of a caller's {@code @_}, not a + * value list. Unlike {@link #setFromListAliased(RuntimeList)}, whose list + * materialization intentionally creates scalar values, this path retains + * the exact slots so a write through {@code $DB::args[N]} reaches the + * caller's argument.

+ */ + public RuntimeArray setFromScalarSlotsAliased(List slots) { + if (type != PLAIN_ARRAY) { + return setFromList(new RuntimeArray(slots).getList()); + } + notePackageRootMutation(); + MortalList.deferDestroyForContainerClear(this.elements); + this.elements.clear(); + this.elements.addAll(slots); + this.elementsOwned = false; + this.elementsAliased = true; + this.ownedAliasElements = null; + return this; + } + /** * Creates a reference to the array. * @@ -1960,6 +2040,7 @@ public void dynamicSaveState() { public void dynamicRestoreState() { Stack dynamicStateStack = dynamicStateStack(); if (!dynamicStateStack.isEmpty()) { + RuntimeCode.snapshotActiveArgumentFramesBeforeMutation(this); // Pop the most recent saved state from the stack RuntimeArray previousState = dynamicStateStack.pop(); // Before discarding the current (local scope's) elements, defer diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 235e40e53..3445f1979 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -53,27 +53,58 @@ * It provides functionality to compile, store, and execute Perl subroutines and eval strings. */ public class RuntimeCode extends RuntimeBase implements RuntimeScalarReference { + /** Shared stack marker for calls that never create a captured closure. */ + private static final Object NO_JVM_CLOSURE_FRAME = new Object(); + static final class JvmClosureFrame { - final java.util.ArrayList created = new java.util.ArrayList<>(); - final java.util.IdentityHashMap returned = new java.util.IdentityHashMap<>(); + private java.util.ArrayList created; + private java.util.IdentityHashMap returned; + + void registerCreated(RuntimeCode closure) { + if (created == null) created = new java.util.ArrayList<>(); + created.add(closure); + } + + void protectReturned(RuntimeCode closure) { + if (returned == null) returned = new java.util.IdentityHashMap<>(); + returned.put(closure, Boolean.TRUE); + } + + boolean isReturned(RuntimeCode closure) { + return returned != null && returned.containsKey(closure); + } } - private static JvmClosureFrame pushJvmClosureFrame() { - JvmClosureFrame frame = new JvmClosureFrame(); - PerlRuntime.current().executionState().jvmClosureFrames.push(frame); - return frame; + private static void pushJvmClosureFrame() { + // Most calls do not create a closure. A shared marker keeps their + // nesting position without allocating a JvmClosureFrame; creation + // below replaces only the current call's marker on demand. + PerlRuntime.current().executionState().jvmClosureFrames.push(NO_JVM_CLOSURE_FRAME); } private static void registerJvmClosure(RuntimeCode closure) { - Deque frames = PerlRuntime.current().executionState().jvmClosureFrames; - if (!frames.isEmpty()) frames.peek().created.add(closure); + Deque frames = PerlRuntime.current().executionState().jvmClosureFrames; + if (frames.isEmpty()) return; + Object entry = frames.peek(); + if (entry == NO_JVM_CLOSURE_FRAME) { + entry = new JvmClosureFrame(); + frames.pop(); + frames.push(entry); + } + ((JvmClosureFrame) entry).registerCreated(closure); } - private static void protectReturnedJvmClosures(JvmClosureFrame frame, RuntimeBase value) { + private static void protectReturnedJvmClosures(RuntimeBase value) { if (value == null) return; + Deque frames = PerlRuntime.current().executionState().jvmClosureFrames; + if (frames.isEmpty() || frames.peek() == NO_JVM_CLOSURE_FRAME) return; + protectReturnedJvmClosures((JvmClosureFrame) frames.peek(), value); + } + + private static void protectReturnedJvmClosures(JvmClosureFrame frame, RuntimeBase value) { if (value instanceof RuntimeScalar scalar) { if (scalar.type == RuntimeScalarType.CODE && scalar.value instanceof RuntimeCode code) { - frame.returned.put(code, Boolean.TRUE); + frame.protectReturned(code); } return; } @@ -88,17 +119,20 @@ private static void protectReturnedJvmClosures(JvmClosureFrame frame, RuntimeBas } } - private static void popJvmClosureFrame(JvmClosureFrame frame) { - Deque frames = PerlRuntime.current().executionState().jvmClosureFrames; - if (!frames.isEmpty() && frames.peek() == frame) frames.pop(); - else frames.removeFirstOccurrence(frame); + private static void popJvmClosureFrame() { + Deque frames = PerlRuntime.current().executionState().jvmClosureFrames; + if (frames.isEmpty()) return; + Object entry = frames.pop(); + if (entry == NO_JVM_CLOSURE_FRAME) return; + JvmClosureFrame frame = (JvmClosureFrame) entry; + if (frame.created == null) return; for (RuntimeCode closure : frame.created) { if ((closure.capturedScalars != null || closure.capturedAggregates != null) && closure.refCount == 0 && closure.stashRefCount <= 0 && !closure.localBindingExists - && !frame.returned.containsKey(closure)) { + && !frame.isReturned(closure)) { closure.releaseCaptures(); } } @@ -256,7 +290,33 @@ private static Deque activeCodeStack(ExecutionRuntimeState executio return executionState.activeCodeStack; } - private record ActiveLexicalFrame(RuntimeCode code, Map cells) {} + /** + * An active CV always needs a stack entry, but its live lexical pad is + * only observed by PadWalker/Devel::LexAlias, runtime-regex compilation, + * or package-DB eval. Keep the map absent until generated code actually + * binds a lexical, avoiding an otherwise empty HashMap on ordinary calls. + */ + private static final class ActiveLexicalFrame { + private final RuntimeCode code; + private Map cells; + + private ActiveLexicalFrame(RuntimeCode code) { + this.code = code; + } + + private RuntimeCode code() { + return code; + } + + private Map cellsForWrite() { + if (cells == null) cells = new HashMap<>(); + return cells; + } + + private Map cellsOrEmpty() { + return cells != null ? cells : Collections.emptyMap(); + } + } @SuppressWarnings("unchecked") private static Deque activeLexicalFrames( ExecutionRuntimeState executionState) { @@ -264,8 +324,8 @@ private static Deque activeLexicalFrames( } /** - * Thread-local stack of pristine (unshifted) @_ snapshots taken at sub-entry - * time. Used to populate {@code @DB::args} for {@code caller(N)} from package DB. + * Thread-local stack of copy-on-write pristine {@code @_} frames. Used to + * populate {@code @DB::args} for {@code caller(N)} from package DB. *

* In Perl, {@code @DB::args} reflects the args the sub was called with, * regardless of whether the sub later shifted or otherwise mutated @_. @@ -274,13 +334,46 @@ private static Deque activeLexicalFrames( * to the object being destroyed — would break once the callee does * {@code shift(@_)}. *

- * The snapshot is a cheap new ArrayList of the same RuntimeScalar element - * references; subsequent shifts/modifications of the live @_ don't affect it. + * The original slots are copied only when the active argument array is about + * to mutate. Most calls never mutate {@code @_}, so eagerly copying every + * argument list would make debugger compatibility an unconditional call + * boundary allocation. */ - private static Deque> pristineArgsStack() { + static final class PristineArgsFrame { + final RuntimeArray args; + java.util.List snapshot; + + PristineArgsFrame(RuntimeArray args) { + this.args = args; + } + + java.util.List originalOrLive() { + return snapshot != null ? snapshot : args.elements; + } + + void snapshotBeforeMutation() { + if (snapshot == null) snapshot = new java.util.ArrayList<>(args.elements); + } + } + + private static Deque pristineArgsStack() { return PerlRuntime.current().executionState().pristineArgsStack; } + /** + * Called by {@link RuntimeArray} immediately before a structural or slot + * mutation. A shared {@code @_} can be active in more than one frame, and + * each frame must retain the values it saw at entry. + */ + static void snapshotActiveArgumentFramesBeforeMutation(RuntimeArray array) { + if (array == null || array.activeArgumentFrameCount == 0) return; + PerlRuntime runtime = PerlRuntime.currentOrNull(); + if (runtime == null) return; + for (PristineArgsFrame frame : runtime.executionState().pristineArgsStack) { + if (frame.args == array) frame.snapshotBeforeMutation(); + } + } + /** * Thread-local stack tracking whether each call frame created a fresh @_ (hasargs). * In Perl 5, caller()[4] (hasargs) is 1 when the subroutine was called with explicit @@ -349,8 +442,8 @@ public static RuntimeArray getActiveArgsAt(int depth) { */ public static java.util.List> snapshotPristineArgsStack() { java.util.List> snapshot = new java.util.ArrayList<>(); - for (java.util.List args : pristineArgsStack()) { - snapshot.add(new java.util.ArrayList<>(args)); + for (PristineArgsFrame frame : pristineArgsStack()) { + snapshot.add(new java.util.ArrayList<>(frame.originalOrLive())); } return snapshot; } @@ -366,8 +459,7 @@ public static void pushActiveCode(RuntimeCode code) { // Keep the live pad for every active CV. Besides Devel::LexAlias and // runtime regex sources, eval STRING in package DB must resolve the // debugged caller's lexicals rather than DB's own closure. - activeLexicalFrames(executionState).push( - new ActiveLexicalFrame(code, new HashMap<>())); + activeLexicalFrames(executionState).push(new ActiveLexicalFrame(code)); } public static void popActiveCode(RuntimeCode code) { @@ -437,7 +529,7 @@ private static void registerActiveLexical( Deque frames = activeLexicalFrames(runtime.executionState()); for (ActiveLexicalFrame frame : frames) { if (sameLogicalCode(frame.code(), code)) { - frame.cells().put(variableName, cell); + frame.cellsForWrite().put(variableName, cell); return; } } @@ -448,7 +540,7 @@ private static void registerActiveLexical( // cell is being initialized. Without this fallback the child frame is // left empty and runtime regex source captures undef for outer cells. if (!frames.isEmpty()) { - frames.peek().cells().put(variableName, cell); + frames.peek().cellsForWrite().put(variableName, cell); } } @@ -457,7 +549,7 @@ public static RuntimeBase findActiveLexical(RuntimeCode code, String variableNam if (!runtime.runtimeCodeState().lexicalAliasSupportEnabled) return null; for (ActiveLexicalFrame frame : activeLexicalFrames(runtime.executionState())) { if (sameLogicalCode(frame.code(), code)) { - RuntimeBase cell = frame.cells().get(variableName); + RuntimeBase cell = frame.cellsOrEmpty().get(variableName); if (cell != null) return cell; } } @@ -470,7 +562,7 @@ public static String findActiveLexicalName(RuntimeBase cell) { PerlRuntime runtime = PerlRuntime.current(); if (!runtime.runtimeCodeState().lexicalAliasSupportEnabled) return null; for (ActiveLexicalFrame frame : activeLexicalFrames(runtime.executionState())) { - for (Map.Entry entry : frame.cells().entrySet()) { + for (Map.Entry entry : frame.cellsOrEmpty().entrySet()) { if (entry.getValue() == cell) return entry.getKey(); } } @@ -483,7 +575,7 @@ public static Map snapshotActiveLexicals(RuntimeCode code) PerlRuntime runtime = PerlRuntime.current(); for (ActiveLexicalFrame frame : activeLexicalFrames(runtime.executionState())) { if (sameLogicalCode(frame.code(), code)) { - return new LinkedHashMap<>(frame.cells()); + return new LinkedHashMap<>(frame.cellsOrEmpty()); } } return Collections.emptyMap(); @@ -548,10 +640,13 @@ public static RuntimeArray getCallerArgs() { */ public static void pushArgs(RuntimeArray args) { argsStack().push(args); - // Snapshot the args list so @DB::args stays pristine even if the sub - // later shifts/pops from @_. - pristineArgsStack().push( - args != null ? new java.util.ArrayList<>(args.elements) : new java.util.ArrayList<>()); + RuntimeArray frameArgs = args != null ? args : new RuntimeArray(); + // Keep the entry array live until it mutates. This makes pristine + // @DB::args support copy-on-write rather than an allocation on every + // call; RuntimeArray snapshots all matching active frames before a + // mutation, including nested &sub calls sharing the same @_. + frameArgs.activeArgumentFrameCount++; + pristineArgsStack().push(new PristineArgsFrame(frameArgs)); } public static void pushCallContext(int callContext) { @@ -573,9 +668,10 @@ public static void popArgs() { if (!stack.isEmpty()) { stack.pop(); } - Deque> pStack = pristineArgsStack(); + Deque pStack = pristineArgsStack(); if (!pStack.isEmpty()) { - pStack.pop(); + PristineArgsFrame frame = pStack.pop(); + frame.args.activeArgumentFrameCount--; } drainDeferredArgumentAggregateCleanup(); Deque haStack = hasArgsStack(); @@ -596,13 +692,13 @@ public static void popArgs() { * @return a RuntimeArray wrapping the snapshot, or null if frame is out of range */ public static RuntimeArray getOriginalArgsAt(int frame) { - Deque> stack = pristineArgsStack(); + Deque stack = pristineArgsStack(); if (frame < 0 || frame >= stack.size()) return null; int i = 0; - for (java.util.List list : stack) { + for (PristineArgsFrame pristine : stack) { if (i++ == frame) { RuntimeArray ra = new RuntimeArray(); - ra.elements = new java.util.ArrayList<>(list); + ra.elements = new java.util.ArrayList<>(pristine.originalOrLive()); return ra; } } @@ -613,9 +709,9 @@ public static RuntimeArray getOriginalArgsAt(int frame) { public static boolean isCurrentArgumentAlias(RuntimeScalar scalar) { if (scalar == null) return false; if (PerlRuntime.currentOrNull() == null) return false; - Deque> stack = pristineArgsStack(); + Deque stack = pristineArgsStack(); if (stack.isEmpty()) return false; - for (RuntimeScalar argument : stack.peek()) { + for (RuntimeScalar argument : stack.peek().originalOrLive()) { if (argument == scalar) return true; } return false; @@ -624,9 +720,9 @@ public static boolean isCurrentArgumentAlias(RuntimeScalar scalar) { /** Identity token for the active argument frame containing {@code scalar}. */ static Object currentArgumentAliasFrame(RuntimeScalar scalar) { if (scalar == null || PerlRuntime.currentOrNull() == null) return null; - Deque> stack = pristineArgsStack(); + Deque stack = pristineArgsStack(); if (stack.isEmpty()) return null; - java.util.List frame = stack.peek(); + java.util.List frame = stack.peek().originalOrLive(); for (RuntimeScalar argument : frame) { if (argument == scalar) return frame; } @@ -636,8 +732,8 @@ static Object currentArgumentAliasFrame(RuntimeScalar scalar) { /** True only while the argument frame represented by {@code token} is active. */ static boolean isArgumentFrameActive(Object token) { if (token == null || PerlRuntime.currentOrNull() == null) return false; - for (java.util.List frame : pristineArgsStack()) { - if (frame == token) return true; + for (PristineArgsFrame frame : pristineArgsStack()) { + if (frame.originalOrLive() == token) return true; } return false; } @@ -657,8 +753,8 @@ static boolean deferCleanupForActiveArgumentAggregate(RuntimeBase aggregate) { } private static boolean isActiveArgumentReferent(RuntimeBase aggregate) { - for (java.util.List frame : pristineArgsStack()) { - for (RuntimeScalar argument : frame) { + for (PristineArgsFrame pristine : pristineArgsStack()) { + for (RuntimeScalar argument : pristine.originalOrLive()) { if (argument != null && (argument.type & RuntimeScalarType.REFERENCE_BIT) != 0 && argument.value == aggregate) { @@ -693,10 +789,10 @@ private static void drainDeferredArgumentAggregateCleanup() { private static RuntimeArray getOriginalArgsForCode(RuntimeCode target) { if (target == null) return null; Iterator codeIt = activeCodeStack().iterator(); - Iterator> argsIt = pristineArgsStack().iterator(); + Iterator argsIt = pristineArgsStack().iterator(); while (codeIt.hasNext() && argsIt.hasNext()) { if (codeIt.next() == target) { - java.util.List list = argsIt.next(); + java.util.List list = argsIt.next().originalOrLive(); RuntimeArray result = new RuntimeArray(); result.elements = new java.util.ArrayList<>(list); return result; @@ -4559,7 +4655,7 @@ public static RuntimeList callerWithSub(RuntimeList args, int ctx, RuntimeScalar if (DebugState.isDebugMode()) { RuntimeArray frameArgs = DebugState.getArgsForFrame(frame); if (frameArgs != null) { - dbArgs.setFromListAliased(frameArgs.getList()); + dbArgs.setFromScalarSlotsAliased(frameArgs.elements); } else { dbArgs.setFromListAliased(new RuntimeList()); } @@ -4584,7 +4680,7 @@ public static RuntimeList callerWithSub(RuntimeList args, int ctx, RuntimeScalar frameArgs = getOriginalArgsAt(trackedActiveCodeFrame); } if (frameArgs != null) { - dbArgs.setFromListAliased(frameArgs.getList()); + dbArgs.setFromScalarSlotsAliased(frameArgs.elements); } else { dbArgs.setFromListAliased(new RuntimeList()); } @@ -5295,6 +5391,7 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int : null; requireLvalueCallable(code, callContext, resolvedSubroutineName); int effectiveContext = effectiveCallContext(code, callContext); + CallLayerDiagnostics.Token diagnostic = CallLayerDiagnostics.enter("shared-args-static-facade"); // Look up warning bits for the code's class and push to context stack // This enables FATAL warnings to work even at top-level (no caller frame) org.perlonjava.runtime.CompilationRuntimeState compilationState = @@ -5343,7 +5440,9 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int RuntimeArray argsForCall = curArgs; try { // Cast the value to RuntimeCode and call apply() + CallLayerDiagnostics.markDispatch(diagnostic); RuntimeList result = code.apply(argsForCall, callContext); + CallLayerDiagnostics.markBodyComplete(diagnostic); if (code.isSortComparator && result instanceof RuntimeControlFlowList flow) { throw new PerlCompilerException("Can't \"goto\" out of a pseudo block at " + flow.marker.fileName + " line " + flow.marker.lineNumber + ".\n"); @@ -5456,6 +5555,7 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int if (code.isEvalBlock) { code.releaseCaptures(); } + CallLayerDiagnostics.exit(diagnostic); } // If we get here, the body returned a tailcall. Iterate // with the new code ref / args instead of recursing. @@ -6518,6 +6618,89 @@ protected static void restoreCallerWarningScope(int savedScope) { getGlobalVariable(GlobalContext.WARNING_SCOPE).set(savedScope); } + /** + * The common execution half of the two general JVM call paths. Keeping + * dispatch and return coercion here prevents their bytecode and inline + * decisions from diverging between normal calls and shared-{@code @_} + * calls; the callers retain their distinct frame/hasargs setup. + */ + private RuntimeList invokeCallable(RuntimeArray args, int effectiveContext, int callContext, + CallLayerDiagnostics.Token diagnostic) throws Throwable { + CallLayerDiagnostics.markDispatch(diagnostic); + RuntimeList result; + if (this.subroutine != null) { + result = this.subroutine.apply(args, effectiveContext); + } else if (isStatic) { + result = (RuntimeList) this.methodHandle.invoke(args, effectiveContext); + } else { + result = (RuntimeList) this.methodHandle.invoke(this.codeObject, args, effectiveContext); + } + CallLayerDiagnostics.markBodyComplete(diagnostic); + RuntimeList returned = detachTryExpressionLvalueResult( + coerceScalarCallResult(result, effectiveContext, callContext, !isLvalueCode(this)), + callContext); + protectReturnedJvmClosures(returned); + return returned; + } + + /** + * Owns the runtime state that makes a Perl subroutine invocation a call + * boundary. The two JVM paths differ only in whether they install a fresh + * {@code @_}; keeping the remainder here prevents their warning, caller, + * closure, and cleanup protocols from drifting apart and gives HotSpot one + * general lifecycle to optimize. + */ + private RuntimeList invokeWithCallFrame(RuntimeArray args, int effectiveContext, int callContext, + boolean hasFreshArgs, String fallbackSubroutineName, + CallLayerDiagnostics.Token diagnostic) throws Throwable { + boolean debugging = DebugState.isDebugMode(); + if (debugging) { + String debugSubName = this.subName != null + ? NameNormalizer.normalizeVariableName(this.subName, + this.packageName != null ? this.packageName : "main") + : (fallbackSubroutineName != null ? fallbackSubroutineName : ""); + DebugState.pushArgs(args); + DebugHooks.enterSubroutine(debugSubName); + } + pushArgs(args); + pushCallContext(callContext); + pushActiveCode(this); + hasArgsStack().push(hasFreshArgs); + enterCall(); + String warningBits = getWarningBitsForCode(this); + if (warningBits != null) { + WarningBitsRegistry.pushCurrent(warningBits); + } + String savedRuntimeWarningBits = WarningBitsRegistry.getRuntimeWarningBits(); + WarningBitsRegistry.setRuntimeWarningBits(warningBits); + Set savedRuntimeDisabledWarnings = + WarningBitsRegistry.getRuntimeDisabledWarningCategories(); + WarningBitsRegistry.setRuntimeDisabledWarningCategories(lexicalDisabledWarningCategories); + int savedRuntimeWarningScope = enterCalleeWarningScope(); + pushJvmClosureFrame(); + try { + return invokeCallable(args, effectiveContext, callContext, diagnostic); + } catch (RuntimeException e) { + throw WarnDie.maybeInvokeUnhandledDieHandler(e); + } finally { + WarningBitsRegistry.setRuntimeWarningBits(savedRuntimeWarningBits); + WarningBitsRegistry.setRuntimeDisabledWarningCategories(savedRuntimeDisabledWarnings); + restoreCallerWarningScope(savedRuntimeWarningScope); + if (warningBits != null) { + WarningBitsRegistry.popCurrent(); + } + exitCall(); + popJvmClosureFrame(); + popActiveCode(this); + popArgs(); + if (debugging) { + DebugHooks.exitSubroutine(); + DebugState.popArgs(); + } + CallLayerDiagnostics.exit(diagnostic); + } + } + public RuntimeList apply(RuntimeArray a, int callContext) { if (boundRuntime != null && PerlRuntime.currentOrNull() != boundRuntime) { try (PerlRuntime.Binding ignored = boundRuntime.bind()) { @@ -6584,80 +6767,8 @@ public RuntimeList apply(RuntimeArray a, int callContext) { requireLvalueCallable(this, callContext, null); int effectiveContext = effectiveCallContext(this, callContext); - - // Debug mode: push args and track subroutine entry - if (DebugState.isDebugMode()) { - String debugSubName = (this.subName != null) - ? NameNormalizer.normalizeVariableName(this.subName, this.packageName != null ? this.packageName : "main") - : ""; - DebugState.pushArgs(a); - DebugHooks.enterSubroutine(debugSubName); - } - // Always push args for getCurrentArgs() support (used by List::Util::any/all/etc.) - pushArgs(a); - pushCallContext(callContext); - pushActiveCode(this); - - // hasArgs tracking for caller()[4]: - // This is the 2-arg instance method, called from the 3-arg static apply(scalar, array, ctx). - // That static method is the "shared args" path — used when Perl code calls &func (no parens), - // which inherits the caller's @_ instead of creating a fresh one. - // Perl's caller()[4] (hasargs) should be false/empty for these calls. - // See also: the 3-arg instance method apply(name, array, ctx) which pushes true. - hasArgsStack().push(false); - - // Check deep recursion BEFORE pushing the callee's warning bits, - // so the "Deep recursion on subroutine" warning is gated on the - // caller's lexical warning bits (matching Perl's ckWARN at the - // call site, not inside the callee). - enterCall(); - // Push warning bits for FATAL warnings support - String warningBits = getWarningBitsForCode(this); - if (warningBits != null) { - WarningBitsRegistry.pushCurrent(warningBits); - } - String savedRuntimeWarningBits = WarningBitsRegistry.getRuntimeWarningBits(); - WarningBitsRegistry.setRuntimeWarningBits(warningBits); - Set savedRuntimeDisabledWarnings = - WarningBitsRegistry.getRuntimeDisabledWarningCategories(); - WarningBitsRegistry.setRuntimeDisabledWarningCategories( - lexicalDisabledWarningCategories); - int savedRuntimeWarningScope = enterCalleeWarningScope(); - JvmClosureFrame closureFrame = pushJvmClosureFrame(); - try { - RuntimeList result; - // Prefer functional interface over MethodHandle for better performance - if (this.subroutine != null) { - result = this.subroutine.apply(a, effectiveContext); - } else if (isStatic) { - result = (RuntimeList) this.methodHandle.invoke(a, effectiveContext); - } else { - result = (RuntimeList) this.methodHandle.invoke(this.codeObject, a, effectiveContext); - } - RuntimeList returned = detachTryExpressionLvalueResult( - coerceScalarCallResult(result, effectiveContext, callContext, !isLvalueCode(this)), - callContext); - protectReturnedJvmClosures(closureFrame, returned); - return returned; - } catch (RuntimeException e) { - throw WarnDie.maybeInvokeUnhandledDieHandler(e); - } finally { - WarningBitsRegistry.setRuntimeWarningBits(savedRuntimeWarningBits); - WarningBitsRegistry.setRuntimeDisabledWarningCategories( - savedRuntimeDisabledWarnings); - restoreCallerWarningScope(savedRuntimeWarningScope); - if (warningBits != null) { - WarningBitsRegistry.popCurrent(); - } - exitCall(); - popJvmClosureFrame(closureFrame); - popActiveCode(this); - popArgs(); // also pops hasArgsStack — see popArgs() implementation - if (DebugState.isDebugMode()) { - DebugHooks.exitSubroutine(); - DebugState.popArgs(); - } - } + CallLayerDiagnostics.Token diagnostic = CallLayerDiagnostics.enter("shared-args-instance-apply"); + return invokeWithCallFrame(a, effectiveContext, callContext, false, null, diagnostic); } catch (InvocationTargetException e) { Throwable targetException = e.getTargetException(); // Handle fork-open completion (from exec in fork-open emulation) @@ -6734,84 +6845,8 @@ public RuntimeList apply(String subroutineName, RuntimeArray a, int callContext) requireLvalueCallable(this, callContext, subroutineName); int effectiveContext = effectiveCallContext(this, callContext); - - // Debug mode: push args and track subroutine entry - if (DebugState.isDebugMode()) { - String debugSubName; - if (this.subName != null) { - debugSubName = NameNormalizer.normalizeVariableName(this.subName, this.packageName != null ? this.packageName : "main"); - } else if (subroutineName != null) { - debugSubName = subroutineName; - } else { - debugSubName = ""; - } - DebugState.pushArgs(a); - DebugHooks.enterSubroutine(debugSubName); - } - // Always push args for getCurrentArgs() support (used by List::Util::any/all/etc.) - pushArgs(a); - pushCallContext(callContext); - pushActiveCode(this); - - // hasArgs tracking for caller()[4]: - // This is the 3-arg instance method, called from the 4-arg static apply(scalar, name, args[], ctx). - // That static method is the "fresh args" path — used for normal func(args) and &func(args) calls, - // which create a new @_ from the supplied arguments. - // Perl's caller()[4] (hasargs) should be true (1) for these calls. - // See also: the 2-arg instance method apply(array, ctx) which pushes false. - hasArgsStack().push(true); - - // Check deep recursion BEFORE pushing the callee's warning bits, - // so the "Deep recursion on subroutine" warning is gated on the - // caller's lexical warning bits. - enterCall(); - // Push warning bits for FATAL warnings support - String warningBits = getWarningBitsForCode(this); - if (warningBits != null) { - WarningBitsRegistry.pushCurrent(warningBits); - } - String savedRuntimeWarningBits = WarningBitsRegistry.getRuntimeWarningBits(); - WarningBitsRegistry.setRuntimeWarningBits(warningBits); - Set savedRuntimeDisabledWarnings = - WarningBitsRegistry.getRuntimeDisabledWarningCategories(); - WarningBitsRegistry.setRuntimeDisabledWarningCategories( - lexicalDisabledWarningCategories); - int savedRuntimeWarningScope = enterCalleeWarningScope(); - JvmClosureFrame closureFrame = pushJvmClosureFrame(); - try { - RuntimeList result; - // Prefer functional interface over MethodHandle for better performance - if (this.subroutine != null) { - result = this.subroutine.apply(a, effectiveContext); - } else if (isStatic) { - result = (RuntimeList) this.methodHandle.invoke(a, effectiveContext); - } else { - result = (RuntimeList) this.methodHandle.invoke(this.codeObject, a, effectiveContext); - } - RuntimeList returned = detachTryExpressionLvalueResult( - coerceScalarCallResult(result, effectiveContext, callContext, !isLvalueCode(this)), - callContext); - protectReturnedJvmClosures(closureFrame, returned); - return returned; - } catch (RuntimeException e) { - throw WarnDie.maybeInvokeUnhandledDieHandler(e); - } finally { - WarningBitsRegistry.setRuntimeWarningBits(savedRuntimeWarningBits); - WarningBitsRegistry.setRuntimeDisabledWarningCategories( - savedRuntimeDisabledWarnings); - restoreCallerWarningScope(savedRuntimeWarningScope); - if (warningBits != null) { - WarningBitsRegistry.popCurrent(); - } - exitCall(); - popJvmClosureFrame(closureFrame); - popActiveCode(this); - popArgs(); // also pops hasArgsStack — see popArgs() implementation - if (DebugState.isDebugMode()) { - DebugHooks.exitSubroutine(); - DebugState.popArgs(); - } - } + CallLayerDiagnostics.Token diagnostic = CallLayerDiagnostics.enter("named-args-instance-apply"); + return invokeWithCallFrame(a, effectiveContext, callContext, true, subroutineName, diagnostic); } catch (InvocationTargetException e) { Throwable targetException = e.getTargetException(); // Handle fork-open completion (from exec in fork-open emulation) diff --git a/src/test/resources/unit/math_modulus_integer_fast_path.t b/src/test/resources/unit/math_modulus_integer_fast_path.t new file mode 100644 index 000000000..866d35405 --- /dev/null +++ b/src/test/resources/unit/math_modulus_integer_fast_path.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More tests => 8; + +# INTEGER/INTEGER modulus is a hot arithmetic path. These cases cover the +# result-sign rule and the values which must remain on the native-integer path. +is(7 % 3, 1, 'positive dividend and divisor'); +is(-7 % 3, 2, 'positive divisor determines a negative dividend result sign'); +is(7 % -3, -2, 'negative divisor determines a positive dividend result sign'); +is(-7 % -3, -1, 'both negative operands preserve divisor sign'); + +my $large = 4_611_686_018_427_387_911; +is($large % 1_000_003, 837_681, 'large integer modulus remains exact'); + +my ($lexical, $global) = (11, 7); +for (1 .. 2_048) { + $lexical = ($lexical * 33 + $_) % 1_000_003; + $global = ($global + $lexical) % 1_000_003; +} +is($lexical ^ $global, 37_478, 'numeric workload recurrence remains stable'); + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + is(17 % 5, 2, 'ordinary integer modulus has the expected result with warnings enabled'); +} +is_deeply(\@warnings, [], 'defined integer operands do not warn'); diff --git a/src/test/resources/unit/runtime_code_apply_boundary.t b/src/test/resources/unit/runtime_code_apply_boundary.t new file mode 100644 index 000000000..ab1086008 --- /dev/null +++ b/src/test/resources/unit/runtime_code_apply_boundary.t @@ -0,0 +1,67 @@ +use strict; +use warnings; +use Test::More; + +# This is the semantic contract that a Phase 3 RuntimeCode.apply consolidation +# must retain for the high-frequency normal (named-argument) call path. +sub mutate_and_identify_caller { + $_[0] = 'callee-mutated'; + return (caller(1))[3]; +} + +sub named_call_boundary { + my ($value) = @_; + return mutate_and_identify_caller($value); +} + +is(named_call_boundary('caller-value'), 'main::named_call_boundary', + 'normal sub call preserves the immediate caller frame'); +my $value = 'caller-value'; +mutate_and_identify_caller($value); +is($value, 'callee-mutated', 'normal sub arguments remain aliases to caller variables'); + +sub hasargs { return (caller(0))[4] ? 1 : 0 } +sub normal_hasargs { return hasargs() } +sub shared_hasargs { + @_ = ('shared'); + return &hasargs; +} + +is(normal_hasargs(), 1, 'normal call records caller hasargs'); +is(shared_hasargs(), 0, 'shared-argument call remains distinguishable to caller'); + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + sub callee_suppresses_uninitialized { + no warnings 'uninitialized'; + my $missing; + return $missing . 'callee'; + } + is(callee_suppresses_uninitialized(), 'callee', + 'callee lexical warning scope applies during the call'); + my $missing; + my $result = $missing . 'caller'; + is($result, 'caller', 'caller continues after callee warning scope exits'); +} +is(scalar @warnings, 1, 'caller warning scope is restored after the callee returns'); + +sub die_after_mutating_argument { + $_[0] = 'mutated-before-die'; + die "boundary failure\n"; +} + +my $exception_argument = 'original'; +my $exception_ok = eval { die_after_mutating_argument($exception_argument); 1 }; +ok(!$exception_ok, 'exception crosses the call boundary'); +like($@, qr/boundary failure/, 'callee exception reaches the caller'); +is($exception_argument, 'mutated-before-die', + 'argument aliases survive cleanup after an exceptional call'); +is(normal_hasargs(), 1, + 'call-frame stacks are restored after an exceptional call'); + +sub return_from_map { return map { $_ * 2 } @_ } +is_deeply([return_from_map(2, 3)], [4, 6], + 'nonlocal return through a nested map block preserves list context'); + +done_testing; diff --git a/src/test/resources/unit/runtime_code_pristine_args_cow.t b/src/test/resources/unit/runtime_code_pristine_args_cow.t new file mode 100644 index 000000000..2b6390c28 --- /dev/null +++ b/src/test/resources/unit/runtime_code_pristine_args_cow.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use Test::More; + +# caller() from package DB must expose the invocation-time aliases, even after +# the callee has shifted @_ before the debugger query. This is the semantic +# contract behind RuntimeCode's copy-on-write pristine-argument frames. +{ + package DB; + sub snapshot_and_rewrite_caller_args { + my ($depth) = @_; + my @caller = caller($depth); + my @args = @DB::args; + $DB::args[0] = 'rewritten-through-db'; + return ($caller[3], \@args); + } +} + +sub shift_then_query_db_args { + shift @_; + return DB::snapshot_and_rewrite_caller_args(1); +} + +my ($first, $second) = ('first', 'second'); +my ($caller, $snapshot) = shift_then_query_db_args($first, $second); + +is($caller, 'main::shift_then_query_db_args', + 'DB caller query selects the shifted callee frame'); +is_deeply($snapshot, ['first', 'second'], + '@DB::args retains the entry-time argument slots after shift @_'); +is($first, 'rewritten-through-db', + '@DB::args remains aliased to the original first argument'); +is($second, 'second', + 'copy-on-write snapshot does not alter untouched argument aliases'); + +done_testing;