Commit 638029ee29 for perl
commit 638029ee29ae02cfd94f4a9b9921256a7ebb1a9a
Author: Yves Orton <demerphq@gmail.com>
Date: Fri Oct 16 23:48:00 2026 +0200
Porting: add reproducible trie corpus comparisons
We need comparisons which distinguish ASCII, high native bytes and
upgraded input, using the same words and text for each Perl build.
Add t/re/trie_bench_corpus.pl to provide fixed HTML, prose, Perl-source
and FASTA workloads. Add t/re/trie_bench_corpus.t to check that we can
recreate the inputs and get the expected matches.
Add Porting/bench-trie.pl to run alternating samples across Perl builds
and report each workload separately. It checks match spans and AC start
classes before timing and records the inputs, build settings and raw
samples so we can repeat the comparison and investigate regressions.
diff --git a/MANIFEST b/MANIFEST
index 94a6576384..437da2f8d8 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5990,6 +5990,7 @@ Porting/acknowledgements.pl Generate perldelta acknowledgements text
Porting/add-package.pl Add/Update CPAN modules that are part of Core
Porting/add-pod-file Utility to add new pod/*.pod file to core distribution
Porting/bench.pl Run benchmarks against t/perf/benchmarks
+Porting/bench-trie.pl Compare trie corpus scans across Perl builds
Porting/bisect.pl A tool to make bisecting easy
Porting/bisect-example.sh Example script to use with git bisect run
Porting/bisect-runner.pl Tool to be called by git bisect run
@@ -6763,6 +6764,8 @@ t/re/subst_wamp.t See if substitution works with $& present
t/re/substT.t See if substitution works with -T
t/re/trie_bench.pl Shared trie benchmark and regression cases
t/re/trie_bench.t Trie benchmark regression tests
+t/re/trie_bench_corpus.pl Frozen corpora for trie scanning benchmarks
+t/re/trie_bench_corpus.t Test trie corpus generation and scan validation
t/re/trie_byte.t Test byte-oriented trie construction
t/re/uniprops01.t Test unicode \p{} regex constructs
t/re/uniprops02.t Test unicode \p{} regex constructs
diff --git a/Porting/README.pod b/Porting/README.pod
index 740d792ab4..dfe24cdb47 100644
--- a/Porting/README.pod
+++ b/Porting/README.pod
@@ -24,6 +24,13 @@ Program to facilitate addition of new F<.pod> files to F<pod/>.
Do performance analysis on the code snippets in F<t/perf/benchmarks>.
+=head2 F<bench-trie.pl>
+
+Compare regex scanning across Perl builds using frozen HTML, prose, Perl
+source and FASTA corpora in byte and UTF-8 representations. Extends
+F<t/re/trie_bench.pl> and exports workloads for instruction profiling with
+F<bench.pl>. See the script's POD for usage and measurement details.
+
=head2 F<bisect-example.sh>, F<bisect.pl> and F<bisect-runner.pl>
Use C<git bisect> to pinpoint changes.
diff --git a/Porting/bench-trie.pl b/Porting/bench-trie.pl
new file mode 100644
index 0000000000..71b1bb0841
--- /dev/null
+++ b/Porting/bench-trie.pl
@@ -0,0 +1,657 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Cwd qw(abs_path);
+use Data::Dumper;
+use Digest::SHA qw(sha256_hex);
+use File::Basename qw(dirname);
+use File::Path qw(make_path);
+use File::Spec;
+use Getopt::Long qw(GetOptions);
+use IO::Handle;
+use JSON::PP;
+use POSIX qw(ceil strftime);
+
+my ( @perls, @args, $out, $base, $cpu, $perf, $report, $help );
+my ( $runs, $seconds, $size ) = ( 12, 0.05, 32 );
+my ( $wanted, $encodings ) =
+ ( '', 'native-ascii,native,utf8-latin1,utf8-wide' );
+
+GetOptions(
+ 'perl=s@' => \@perls,
+ 'arg=s@' => \@args,
+ 'out=s' => \$out,
+ 'base=s' => \$base,
+ 'cpu=i' => \$cpu,
+ 'perf!' => \$perf,
+ 'runs=i' => \$runs,
+ 'seconds=f' => \$seconds,
+ 'size=i' => \$size,
+ 'case=s' => \$wanted,
+ 'encoding=s' => \$encodings,
+ 'report=s' => \$report,
+ 'help' => \$help
+) or die "See --help\n";
+
+if ($help) {
+ print
+"Usage: perl $0 --perl before=/path/perl --perl after=/path/perl [options]\n"
+ . " --arg label=argument Extra argument (repeatable, e.g. before=-Ilib)\n"
+ . " --base label Baseline (default: first Perl)\n"
+ . " --case name,name Select corpus families\n"
+ . " --encoding name,name native-ascii,native,utf8-latin1,utf8-wide (default: all)\n"
+ . " --runs N --seconds S Samples and target scan time (default: 12, 0.05)\n"
+ . " --size KiB --out DIR Fixture size (default: 32) and result directory\n"
+ . " --cpu N --perf Optional Linux CPU affinity and counters\n"
+ . " --report DIR Regenerate report from saved samples\n"
+ . "See perldoc $0 for methodology and instruction profiling.\n";
+ exit;
+}
+
+my $json = JSON::PP->new->canonical->utf8;
+my $root = dirname( dirname( abs_path($0) ) );
+my $worker = File::Spec->catfile( $root, 't', 're', 'trie_bench.pl' );
+my $module = File::Spec->catfile( $root, 't', 're', 'trie_bench_corpus.pl' );
+my $dumbbench = eval { require Dumbbench::Stats; 1 };
+
+sub read_file {
+ open my $fh, '<:raw', $_[0] or die "open $_[0]: $!\n";
+
+ local $/;
+
+ return <$fh>;
+}
+
+sub write_file {
+ open my $fh, '>:raw', $_[0] or die "write $_[0]: $!\n";
+ print {$fh} $_[1] or die "write $_[0]: $!\n";
+ close $fh or die "close $_[0]: $!\n";
+}
+
+sub median {
+ my @v = sort { $a <=> $b } @_;
+
+ return @v % 2
+ ? $v[ @v / 2 ]
+ : ( $v[ @v / 2 - 1 ] + $v[ @v / 2 ] ) / 2;
+}
+
+sub estimate {
+ my @values = @_;
+ my @good = @values;
+
+ if ($dumbbench) {
+ my ($good) =
+ Dumbbench::Stats->new( data => \@values )->filter_outliers(
+ variability_measure => 'mad',
+ nsigma_outliers => 3
+ );
+
+ @good = @$good if @$good;
+ }
+
+ my $mean = 0;
+ $mean += $_ / @good for @good;
+
+ my $mid = median(@good);
+ my $mad = median( map { abs( $_ - $mid ) } @good );
+
+ return ( $mean, $mad / sqrt(@good), scalar @good );
+}
+
+sub render {
+ my ($directory) = @_;
+
+ my $meta = $json->decode(
+ read_file( File::Spec->catfile( $directory, 'run.json' ) ) );
+
+ if ( exists $meta->{stats_filter} ) {
+ die "This run's report needs Dumbbench::Stats\n"
+ if $meta->{stats_filter} eq 'dumbbench-3mad' && !$dumbbench;
+ $dumbbench = $meta->{stats_filter} eq 'dumbbench-3mad';
+ }
+
+ my %samples;
+ for my $line ( split /\n/,
+ read_file( File::Spec->catfile( $directory, 'samples.jsonl' ) ) )
+ {
+ my $row = $json->decode($line);
+ $samples{ $row->{id} }{ $row->{label} }{ $row->{trial} } = $row;
+ }
+
+ my $text =
+ "# Trie corpus comparison\n\nBaseline: `$meta->{base}`. "
+ . "Target: $meta->{seconds} seconds/sample, $meta->{runs} interleaved samples.\n\n"
+ . "Elapsed time includes scanning and offset/length accumulation; corpus loading, "
+ . "decoding, compilation and validation are outside the timed region. "
+ . "Perf counters, when requested, cover the whole child process.\n\n"
+ . "Paired changes use "
+ . ( $dumbbench ? 'Dumbbench 3-MAD filtering' : 'unfiltered samples' )
+ . "; uncertainties are MAD/sqrt(n), not confidence intervals. "
+ . "Each case has its own baseline; no overall average hides regressions.\n\n"
+ . "| Case | Perl | Start class | Base ms | Perl ms | Time change % | n |\n"
+ . "|---|---|---|---:|---:|---:|---:|\n";
+
+ for my $id ( @{ $meta->{cases} } ) {
+ for my $label ( @{ $meta->{order} } ) {
+ next if $label eq $meta->{base};
+
+ my ( @before, @after, @changes );
+
+ for my $trial ( 0 .. $meta->{runs} - 1 ) {
+ my $a = $samples{$id}{ $meta->{base} }{$trial} or next;
+ my $b = $samples{$id}{$label}{$trial} or next;
+
+ push @before, $a->{elapsed};
+ push @after, $b->{elapsed};
+ push @changes, 100 * ( $b->{elapsed} / $a->{elapsed} - 1 );
+ }
+
+ next unless @changes;
+
+ my ( $change, $uncertainty, $n ) = estimate(@changes);
+ my $stclass = $meta->{engines}{$id}{$label} // 'unknown';
+
+ $text .=
+ sprintf
+ "| %s | %s | %s | %.3f | %.3f | %+.2f +/- %.2f | %d/%d |\n",
+ $id, $label, $stclass, 1000 * median(@before),
+ 1000 * median(@after),
+ $change, $uncertainty, $n, scalar @changes;
+ }
+ }
+
+ if ( $meta->{perf} ) {
+ $text .=
+ "\n## Whole-process hardware counters\n\n"
+ . "Paired percentage changes include startup, loading and compilation. "
+ . "Use the Cachegrind export to subtract setup for scan instruction counts.\n\n"
+ . "| Case | Perl | Cycles % | Instructions % | Branch misses % |\n"
+ . "|---|---|---:|---:|---:|\n";
+
+ for my $id ( @{ $meta->{cases} } ) {
+ for my $label ( grep { $_ ne $meta->{base} } @{ $meta->{order} } ) {
+ my @cells;
+ for
+ my $event ( 'cycles:u', 'instructions:u', 'branch-misses:u' )
+ {
+ my @changes;
+
+ for my $trial ( 0 .. $meta->{runs} - 1 ) {
+ my $a =
+ $samples{$id}{ $meta->{base} }{$trial}{perf}{$event};
+ my $b = $samples{$id}{$label}{$trial}{perf}{$event};
+
+ push @changes, 100 * ( $b / $a - 1 )
+ if $a && defined $b;
+ }
+
+ push @cells,
+ @changes
+ ? sprintf( '%+.2f +/- %.2f',
+ ( estimate(@changes) )[ 0, 1 ] )
+ : 'n/a';
+ }
+
+ $text .= '| ' . join( ' | ', $id, $label, @cells ) . " |\n";
+ }
+ }
+ }
+
+ my $manifest = $json->decode(
+ read_file(
+ File::Spec->catfile(
+ $directory, $meta->{corpus_subdir} // 'corpus',
+ 'manifest.json'
+ )
+ )
+ );
+
+ $text .=
+ "\n## Workloads\n\n"
+ . "Sizes are target storage bytes; matches and characters are per scan.\n\n"
+ . "| Case | Bytes | Characters | Codepoints >=128 | Codepoints >255 | Alternatives | Matches | Baseline start class |\n"
+ . "|---|---:|---:|---:|---:|---:|---:|---|\n";
+
+ for my $id ( @{ $meta->{cases} } ) {
+ my $case = $manifest->{cases}{$id};
+
+ $text .= '| '
+ . join( ' | ',
+ $id,
+ @{$case}{qw(octets characters)},
+ $case->{non_ascii_characters} // 'unknown',
+ $case->{wide_characters} // 'unknown',
+ $case->{alternatives},
+ $case->{expected}{matches},
+ $meta->{engines}{$id}{ $meta->{base} } // 'unknown' )
+ . " |\n";
+ }
+
+ $text .= "\n## Build configurations\n\n";
+
+ for my $label ( @{ $meta->{order} } ) {
+ my $p = $meta->{perls}{$label};
+
+ $text .=
+ "- `$label`: `$p->{config}{version}`, `$p->{binary}`; "
+ . "optimize=`$p->{config}{optimize}`, threads=`$p->{config}{useithreads}`, "
+ . "debugging="
+ . (
+ exists $p->{config}{debugging}
+ ? ( $p->{config}{debugging} ? 'on' : 'off' )
+ : 'unrecorded'
+ )
+ . ", "
+ . "arch=`$p->{config}{archname}`; binary SHA-256 `$p->{sha256}`.\n";
+ }
+
+ $text .=
+ "\nFull flags, corpus/pattern hashes, checksums, repetition counts, "
+ . "start-class traces and raw samples are in this run directory. "
+ . "Different compilers/build flags make historical comparisons contextual; "
+ . "matched before/after builds isolate the current patch.\n";
+
+ write_file( File::Spec->catfile( $directory, 'report.md' ), $text );
+ print $text;
+}
+
+if ($report) { render( abs_path($report) ); exit }
+
+die "Specify at least two --perl label=/path/to/perl options\n"
+ unless @perls >= 2;
+die "runs must be >= 6; seconds must be positive\n"
+ unless $runs >= 6 && $seconds > 0;
+
+my ( %p, @order );
+
+for my $spec (@perls) {
+ my ( $label, $binary ) = split /=/, $spec, 2;
+
+ die "bad or duplicate --perl $spec\n"
+ unless defined($binary)
+ && $label =~ /^[A-Za-z0-9_-]+$/
+ && !$p{$label};
+
+ $binary = abs_path($binary) // die "no such Perl: $binary\n";
+ die "not executable: $binary\n" unless -x $binary;
+
+ $p{$label} = {
+ binary => $binary,
+ args => [],
+ sha256 => sha256_hex( read_file($binary) )
+ };
+ push @order, $label;
+}
+
+for my $spec (@args) {
+ my ( $label, $arg ) = split /=/, $spec, 2;
+ die "bad --arg $spec\n" unless defined($arg) && $p{$label};
+ push @{ $p{$label}{args} }, $arg;
+}
+
+$base //= $order[0];
+die "unknown baseline $base\n" unless $p{$base};
+
+$out //= File::Spec->catdir( $root, 'tmp',
+ strftime( 'trie-corpus-%Y%m%d-%H%M%S', localtime ) );
+make_path($out);
+$out = abs_path($out);
+die "run.json already exists in $out; use --report or a new directory\n"
+ if -e File::Spec->catfile( $out, 'run.json' );
+make_path( File::Spec->catdir( $out, 'logs' ) );
+
+local $ENV{PERL_HASH_SEED} = 0;
+local $ENV{PERL_PERTURB_KEYS} = 0;
+local $ENV{LC_ALL} = 'C';
+local @ENV{qw(PERL5OPT PERL5LIB PERLLIB PERL_UNICODE TRIE_BENCH_MODE)};
+delete @ENV{qw(PERL5OPT PERL5LIB PERLLIB PERL_UNICODE TRIE_BENCH_MODE)};
+
+sub command {
+ my ( $label, @tail ) = @_;
+
+ my @command = (
+ $p{$label}{binary},
+ @{ $p{$label}{args} },
+ $worker, '--corpus', @tail
+ );
+ unshift @command, ( 'taskset', '-c', $cpu ) if defined $cpu;
+
+ return @command;
+}
+
+sub invoke {
+ my ( $log, @command ) = @_;
+ my $data;
+
+ {
+ my $pid = open my $child, '-|';
+ die "fork: $!\n" unless defined $pid;
+
+ if ( !$pid ) {
+ open STDERR, '>:raw', $log or die "write $log: $!\n";
+ exec { $command[0] } @command;
+ die "exec $command[0]: $!\n";
+ }
+
+ local $/;
+ $data = <$child>;
+ close $child or die "child failed; see $log\n";
+ }
+
+ return $json->decode($data);
+}
+
+for my $label (@order) {
+ $p{$label}{config} =
+ invoke( File::Spec->catfile( $out, 'logs', "$label.config" ),
+ command( $label, 'config' ) );
+
+ die "$label is a debugging Perl; use a nondebugging build\n"
+ if $p{$label}{config}{debugging};
+ die "$label is a threaded Perl; use an unthreaded build\n"
+ if $p{$label}{config}{threaded};
+}
+
+my $corpus = File::Spec->catdir( $out, '.corpus' );
+my $manifest = invoke(
+ File::Spec->catfile( $out, 'logs', 'prepare' ),
+ command( $base, 'prepare', $corpus, $size )
+);
+
+my %names = map { $_->{name} => 1 } values %{ $manifest->{cases} };
+my %selected = $wanted ? map { $_ => 1 } split( /,/, $wanted ) : %names;
+die "unknown case $_\n" for grep { !$names{$_} } keys %selected;
+
+my %enc = map { $_ => 1 } split /,/, $encodings;
+die "unknown encoding $_\n"
+ for grep { !/^(?:native-ascii|native|utf8-latin1|utf8-wide)$/ } keys %enc;
+
+my @cases = sort grep {
+ $selected{ $manifest->{cases}{$_}{name} }
+ && $enc{ $manifest->{cases}{$_}{encoding} }
+ }
+ keys %{ $manifest->{cases} };
+die "no cases selected\n" unless @cases;
+
+my $meta = {
+ schema => 1,
+ base => $base,
+ runs => $runs,
+ seconds => $seconds,
+ perls => \%p,
+ order => \@order,
+ cases => \@cases,
+ engines => {},
+ repetitions => {},
+ cpu => $cpu,
+ perf => 0 + !!$perf,
+ corpus_subdir => '.corpus',
+ generator_sha256 => sha256_hex( read_file($module) ),
+ driver_sha256 => sha256_hex( read_file(__FILE__) ),
+ started => strftime( '%Y-%m-%dT%H:%M:%SZ', gmtime ),
+ stats_filter => $dumbbench ? 'dumbbench-3mad' : 'none'
+};
+
+# Export this exact frozen corpus to the existing instruction-profiling tool.
+my @grind;
+
+for my $id (@cases) {
+ my $name = $id;
+ $name =~ s/[^A-Za-z0-9_]/_/g;
+
+ my $quote =
+ sub { Data::Dumper->new( [ $_[0] ] )->Terse(1)->Useqq(1)->Dump };
+ my $setup =
+ 'require '
+ . $quote->($module)
+ . '; my $case = TrieBenchCorpus::load_case('
+ . $quote->($corpus) . ', '
+ . $quote->($id)
+ . '); my $re = TrieBenchCorpus::compile($case, 0);';
+
+ push @grind, "regex::ac_corpus::$name",
+ {
+ desc => $manifest->{cases}{$id}{description},
+ setup => $setup,
+ code =>
+'my $got = TrieBenchCorpus::scan($case, $re, 1); TrieBenchCorpus::check($case, $got, 1);'
+ };
+}
+
+write_file(
+ File::Spec->catfile( $out, 'cachegrind-benchmarks' ),
+ Data::Dumper->new( [ \@grind ] )->Terse(1)->Useqq(1)->Dump
+);
+write_file( File::Spec->catfile( $out, 'run.json' ), $json->encode($meta) );
+
+open my $samples, '>:raw', File::Spec->catfile( $out, 'samples.jsonl' )
+ or die "$!\n";
+$| = 1;
+
+for my $id (@cases) {
+ for my $label (@order) {
+ invoke(
+ File::Spec->catfile( $out, 'logs', "$id.$label.verify" ),
+ command( $label, 'verify', $corpus, $id, 1 )
+ );
+
+ my $trace = File::Spec->catfile( $out, 'logs', "$id.$label.explain" );
+ invoke( $trace, command( $label, 'explain', $corpus, $id ) );
+
+ my $debug = read_file($trace);
+ my ($stclass) = $debug =~ /^stclass\s+([^\s]+)/m;
+ $meta->{engines}{$id}{$label} = $stclass
+ // ( $debug =~ /^anchored /m ? 'anchored-prefix' : 'none' );
+
+ die "expected AC start class: $id ($label); see $trace\n"
+ if $manifest->{cases}{$id}{role} eq 'ac'
+ && ( $stclass // '' ) !~ /^AHOCORASICK/;
+ }
+}
+
+write_file( File::Spec->catfile( $out, 'run.json' ), $json->encode($meta) );
+
+print "Verified all match spans and start classes across "
+ . scalar(@order)
+ . " Perls.\n";
+printf "Measuring %d cases x %d Perls x %d samples = %d samples.\n",
+ scalar(@cases), scalar(@order), $runs, @cases * @order * $runs;
+
+my $case_number = 0;
+
+for my $id (@cases) {
+ my ( $calibration, $slowest );
+
+ for my $label (@order) {
+ my $sample =
+ invoke( File::Spec->catfile( $out, 'logs', "$id.$label.calibrate" ),
+ command( $label, 'run', $corpus, $id, 1 ) );
+
+ if ( !$calibration || $sample->{elapsed} > $calibration->{elapsed} ) {
+ ( $calibration, $slowest ) = ( $sample, $label );
+ }
+ }
+
+ my $repeats = ceil( $seconds / ( $calibration->{elapsed} || 0.000001 ) );
+ $repeats = 1000000 if $repeats > 1000000;
+ $meta->{repetitions}{$id} = $repeats;
+ write_file( File::Spec->catfile( $out, 'run.json' ), $json->encode($meta) );
+
+ printf "[%d/%d] %s: calibrated %.3f seconds/sample for %s (%d scans)\n",
+ ++$case_number, scalar(@cases), $id, $calibration->{elapsed} * $repeats,
+ $slowest, $repeats;
+ warn
+"$id ($slowest): one scan exceeds twice --seconds; consider a smaller --size\n"
+ if $calibration->{elapsed} > 2 * $seconds;
+
+ for my $label (@order) {
+ invoke(
+ File::Spec->catfile( $out, 'logs', "$id.$label.warmup" ),
+ command( $label, 'run', $corpus, $id, $repeats )
+ );
+ }
+
+ for my $trial ( 0 .. $runs - 1 ) {
+ for my $offset ( 0 .. $#order ) {
+ my $label = $order[ ( $trial + $offset ) % @order ];
+ my @command = command( $label, 'run', $corpus, $id, $repeats );
+ my $stem = File::Spec->catfile( $out, 'logs', "$id.$label.$trial" );
+
+ unshift @command,
+ (
+ 'perf',
+ 'stat',
+ '-x',
+ ',',
+ '-e',
+'cycles:u,instructions:u,branches:u,branch-misses:u,task-clock,context-switches,cpu-migrations',
+ '-o',
+ "$stem.perf",
+ '--'
+ ) if $perf;
+
+ my $row = invoke( "$stem.stderr", @command );
+ $row->{label} = $label;
+ $row->{trial} = $trial;
+
+ if ($perf) {
+ for my $line ( split /\n/, read_file("$stem.perf") ) {
+ my @fields = split /,/, $line;
+ next unless @fields > 2 && $fields[0] =~ /^\d+(?:\.\d+)?$/;
+
+ $row->{perf}{ $fields[2] } = 0 + $fields[0];
+ }
+
+ die "perf counters unavailable: $stem.perf\n"
+ unless $row->{perf}{'cycles:u'};
+ }
+
+ print {$samples} $json->encode($row), "\n" or die "$!\n";
+ }
+ }
+
+ $samples->flush or die "$!\n";
+ print "$id: $repeats scans/sample, $runs samples/Perl\n";
+}
+
+close $samples or die "$!\n";
+render($out);
+
+__END__
+
+=head1 NAME
+
+bench-trie.pl - Compare corpus scanning across Perl builds
+
+=head1 SYNOPSIS
+
+ perl Porting/bench-trie.pl \
+ --perl before=/path/to/before/perl --arg before=-I/path/to/core/lib \
+ --perl after=/path/to/after/perl --arg after=-I/path/to/core/lib \
+ --base before --cpu 2 --perf --out tmp/trie-corpus-run
+
+ perl Porting/bench-trie.pl --report tmp/trie-corpus-run
+
+=head1 DESCRIPTION
+
+Extends F<t/re/trie_bench.pl> with a small reproducible corpus basket. It does
+not replace the existing short-string, compilation, large-alternation or
+Statistics::Regression benchmarks. It requires Perl 5.14 or later and core
+modules; installed Dumbbench::Stats is optional for outlier filtering.
+
+The ten corpus families cover HTML tokens and rare attributes, prefixed HTML
+tag extraction, technical prose terminology, whole-word searches, Unicode
+folding, a variable watchlist extracted from real Perl source, whitespace-heavy
+source, and balanced/repetitive FASTA. All have ASCII-only native-byte,
+native-byte Latin-1 containing characters above 127, UTF-8-flagged Latin-1,
+and genuinely wide UTF-8 variants. DNA bases remain ASCII; FASTA
+descriptions carry the non-ASCII text. Motifs do not cross line breaks.
+
+HTML and FASTA are deterministic generated fixtures. Prose comes from
+F<pod/perlintro.pod>; variables and source come from F<Porting/bench.pl>.
+Internationalized comments/text are added. C<native-ascii> transliterates the
+accented fixture letters to single ASCII characters and replaces remaining
+non-ASCII characters with spaces, preserving offsets and the pattern dictionary.
+C<native> retains characters in 128..255 with the UTF-8 flag off. These are
+mixed ASCII/Latin-1 texts, not texts consisting entirely of high bytes. Reports
+include non-ASCII and wide character counts. The native and UTF-8-Latin-1 pair
+has identical characters and patterns. Wide variants include Greek, CJK and
+emoji text. The run freezes UTF-8 fixture files, patterns, SHA-256 hashes,
+expected counts, offsets and lengths in F<.corpus/manifest.json>. The fixture
+directory is hidden so source POD copied into the corpus is not mistaken for
+distribution documentation by the porting checks.
+
+Preparation compares every match span with trie construction disabled.
+Each executable then validates its own complete span stream before timing.
+Measured scans accumulate match counts, offsets and lengths rather than
+running an empty match loop. Every sample checks those results. Corpus setup,
+decoding, pattern compilation and validation are outside the timed region.
+
+Leading word boundaries and shared literal prefixes can disable AC. The tool
+records actual start-class traces for every Perl/case and includes those
+patterns as controls. Cases intended to exercise AC must actually select it.
+It does not silently remove a realistic boundary to improve the result.
+The folded watchlist uses Latin-1 terms against all four text encodings;
+mixing wide folded literals can create separate branches and prevent AC.
+Exact prose watchlists include wide terms as well.
+
+Use C<--case=perl_variables,dna_motifs> and
+C<--encoding=native-ascii,native> to compare ASCII-only and high-byte-containing
+native subjects. C<--encoding=utf8-latin1,utf8-wide> selects the UTF-8 subjects.
+C<--runs> defaults to 12;
+C<--seconds> to 0.05; C<--size> to 32 KiB characters per fixture. The slowest
+executable calibrates one repetition count used by all executables. Faster
+builds may take less than the target time. Their order rotates
+between samples, with warmup and deterministic hash settings. Raw data is
+retained in F<samples.jsonl>; the report keeps each workload separate.
+The default is a screening run comparing two builds. Add older release Perls
+when a historical comparison is needed. Confirm questionable cases with
+C<--case>, C<--runs=20> and C<--seconds=0.2>, rather than lengthening the whole
+basket. Use C<--size> explicitly to study larger inputs or cache effects.
+The time target is approximate: a single scan is the minimum sample, and dense
+UTF-8 matches can become disproportionately expensive as input size grows.
+Calibration prints the expected slowest scan time before measuring each case.
+Child processes ignore inherited Perl library, startup-option, Unicode-I/O
+and C<TRIE_BENCH_MODE> environment settings; supply explicit C<--arg> options.
+
+Perl executables and their extra arguments are explicit: repeat
+C<--arg label=argument> as necessary. Give core-build library paths only to
+the corresponding builds; installed Perls should use their own libraries.
+Build versions, flags, threading and executable hashes are recorded. Historical
+build differences are context, not evidence isolating a compiler optimization.
+Measured executables must be unthreaded and nondebugging; the runner checks
+their configuration and compile options and rejects unsuitable builds.
+
+C<--cpu> optionally uses Linux taskset. C<--perf> adds Linux perf user-mode
+counters; these cover the whole process, including setup. They are not the
+same measurement as the internal scan timer. Do not run wall-time and
+Cachegrind jobs concurrently on the measured CPU.
+Raw samples also retain task-clock milliseconds, context switches and CPU
+migrations to help assess interference from other activity.
+
+=head1 DETAILED INSTRUCTION PROFILING
+
+Every run emits F<cachegrind-benchmarks> using the existing F<Porting/bench.pl>
+format and the same frozen corpus. Its setup/loop subtraction isolates scanning
+from fixture loading and compilation. For example, select a few cases first:
+
+ perl Porting/bench.pl \
+ --benchfile=tmp/trie-corpus-run/cachegrind-benchmarks \
+ --tests='/perl_variables_native|prose_folded_utf8_wide/' \
+ --fields=Ir,Dr,Dw,COND,COND_m \
+ --write=tmp/trie-corpus-instructions.json \
+ /path/to/before/perl=before --args=-I/path/to/core/lib \
+ /path/to/after/perl=after --args=-I/path/to/core/lib
+
+Read the saved instruction results using the existing C<--read>, C<--fields>,
+C<--norm> and C<--sort> options. Cachegrind counts explain work and simulated
+cache/branch behavior; they do not measure native CPU cycles.
+
+Individual workers are also available for perf record/annotate:
+
+ ./perl -Ilib t/re/trie_bench.pl --corpus run \
+ tmp/trie-corpus-run/.corpus perl_variables.native 100
+
+=cut
diff --git a/t/re/trie_bench.pl b/t/re/trie_bench.pl
index fa2a90b449..3fa4cdb250 100644
--- a/t/re/trie_bench.pl
+++ b/t/re/trie_bench.pl
@@ -6,6 +6,16 @@ use Cwd qw(abs_path);
use File::Basename qw(dirname);
use File::Spec;
+if ( !caller && @ARGV && $ARGV[0] eq '--corpus' ) {
+ shift @ARGV;
+
+ my $root = dirname( dirname( dirname( abs_path($0) ) ) );
+ require File::Spec->catfile( $root, 't', 're', 'trie_bench_corpus.pl' );
+
+ TrieBenchCorpus::main( $root, @ARGV );
+ exit;
+}
+
my $has_octet_trie;
BEGIN {
@@ -58,6 +68,7 @@ sub numeric_case {
sub benchmark_case {
my ( $name, $re, $inputs, $expected, $repeats ) = @_;
+
return [ $name, $re, $inputs, $expected, undef, $repeats ];
}
diff --git a/t/re/trie_bench_corpus.pl b/t/re/trie_bench_corpus.pl
new file mode 100644
index 0000000000..f9d9e58933
--- /dev/null
+++ b/t/re/trie_bench_corpus.pl
@@ -0,0 +1,469 @@
+package TrieBenchCorpus;
+
+use strict;
+use warnings;
+use Config;
+use Digest::SHA qw(sha256_hex);
+use Encode qw(encode decode FB_CROAK);
+use File::Path qw(make_path);
+use File::Spec;
+use JSON::PP;
+use Time::HiRes ();
+
+my $json = JSON::PP->new->utf8->canonical;
+my @encodings = qw(native-ascii native utf8-latin1 utf8-wide);
+
+sub read_file {
+ my ($path) = @_;
+
+ open my $fh, '<:raw', $path or die "open $path: $!\n";
+ local $/;
+
+ return <$fh>;
+}
+
+sub write_file {
+ my ( $path, $data ) = @_;
+
+ open my $fh, '>:raw', $path or die "write $path: $!\n";
+ print {$fh} $data or die "write $path: $!\n";
+ close $fh or die "close $path: $!\n";
+}
+
+sub clock {
+ return
+ eval { Time::HiRes::clock_gettime( Time::HiRes::CLOCK_MONOTONIC() ) }
+ // Time::HiRes::time();
+}
+
+sub definitions {
+ return (
+ [ 'html_tokens', 'HTML tag and attribute-name searches', 'ac', 0 ],
+ [
+ 'html_absent', 'Rare HTML/security attributes absent from the page',
+ 'ac', 0
+ ],
+ [ 'html_tags', 'Tag extraction with a leading < prefix', 'control', 1 ],
+ [
+ 'prose_terms',
+ 'Technical prose terminology, trailing word boundary',
+ 'ac', 0
+ ],
+ [
+ 'prose_words', 'Whole-word terminology with a leading boundary',
+ 'control', 0
+ ],
+ [
+ 'prose_folded', 'Case-insensitive multilingual terminology', 'ac',
+ 1
+ ],
+ [
+ 'perl_variables',
+ 'Variable watchlist extracted from Porting/bench.pl',
+ 'ac', 0
+ ],
+ [
+ 'perl_whitespace',
+ 'The same Perl source with extra indentation and blank lines',
+ 'ac', 0
+ ],
+ [
+ 'dna_motifs',
+ 'Restriction sites and start/stop motifs in wrapped FASTA',
+ 'ac', 0
+ ],
+ [
+ 'dna_repeats',
+ 'The same motif list in low-complexity FASTA regions',
+ 'ac', 0
+ ],
+ );
+}
+
+sub build {
+ my ( $root, $name, $wide ) = @_;
+
+ my $intro =
+ read_file( File::Spec->catfile( $root, 'pod', 'perlintro.pod' ) );
+ my $source =
+ read_file( File::Spec->catfile( $root, 'Porting', 'bench.pl' ) );
+
+ my $note =
+ "caf\x{e9}, na\x{ef}ve, r\x{e9}sum\x{e9}, fa\x{e7}ade, Stra\x{df}e";
+ $note .= " \x{3a9} \x{4e2d}\x{6587} \x{1f600}" if $wide;
+
+ my ( @words, $text, $prefix, $suffix );
+ $prefix = $suffix = '';
+
+ if ( $name =~ /^html_/ ) {
+ @words =
+ qw(article section nav aside header footer main form input button
+ label table tbody thead tr td ul ol li script style link meta title
+ body html figure figcaption img source video audio iframe canvas
+ data-testid aria-label aria-expanded autocomplete crossorigin
+ viewport charset href src class id role hidden tabindex disabled
+ checked selected action method content value);
+
+ my $paragraph = substr( $intro, 1000, 2500 );
+ $paragraph =~ s/[<>&]/ /g;
+ $text =
+ "<!doctype html>\n<html><head><title>$note</title></head><body>\n";
+
+ for my $i ( 1 .. 24 ) {
+ $text .=
+ "<section id=\"item-$i\" class=\"card\" data-testid=\"entry\">\n"
+ . " <header><h2>$note $i</h2></header>\n"
+ . " <article><p>$paragraph</p><a href=\"/entry/$i\">Details</a></article>\n"
+ . " <form action=\"/submit\" method=\"post\"><label>Name</label>\n"
+ . " <input autocomplete=\"name\"><button>Save</button></form>\n"
+ . "</section>\n";
+ }
+
+ $text .= "</body></html>\n";
+
+ if ( $name eq 'html_absent' ) {
+ @words =
+ qw(onpointerrawupdate onbeforexrselect onsecuritypolicyviolation
+ feDisplacementMap feComponentTransfer http-equiv integrity nonce
+ sandbox referrerpolicy allowfullscreen credentialless);
+ }
+ elsif ( $name eq 'html_tags' ) {
+ @words =
+ qw(article section nav aside header footer main form input button
+ label table tbody thead tr td ul ol li script style link meta title
+ body html figure figcaption img source video audio iframe canvas);
+
+ $prefix = '</?';
+ }
+
+ $suffix = '\\b';
+ }
+ elsif ( $name =~ /^prose_/ ) {
+ $text =
+"$note. STRASSE and CAF\x{c9} appear in translated documentation.\n$intro";
+ $text =~ s/^=\w+[^\n]*\n//mg;
+ $text =~ s/\b[A-Z]<([^<>]*)>/$1/g for 1 .. 3;
+
+ @words = (
+ qw(variable scalar array hash reference package function subroutine
+ module Unicode encoding pattern regular expression scope lexical return
+ argument filename string number operator context list file program
+ input output warning example document),
+ "caf\x{e9}", "r\x{e9}sum\x{e9}", "Stra\x{df}e", "na\x{ef}ve",
+ "fa\x{e7}ade", "\x{3a9}", "\x{4e2d}\x{6587}"
+ );
+
+ # Wide folded literals can compile into separate REQ8 branches and
+ # prevent AC conversion. Keep this folding watchlist Latin-1; the
+ # exact watchlists still include wide terms, and all scan wide text.
+ @words = grep { !/[^\x00-\xff]/ } @words if $name eq 'prose_folded';
+ $prefix = '\\b' if $name eq 'prose_words';
+ $suffix = '\\b';
+ }
+ elsif ( $name =~ /^perl_/ ) {
+ my %vars;
+
+ while ( $source =~ /\b(?:my|our)\s+(\([^;]*?\)|[\$\@%][A-Za-z_]\w*)/sg )
+ {
+ $vars{$_} = 1 for $1 =~ /([\$\@%][A-Za-z_]\w*)/g;
+ }
+
+ for my $sigil ( '$', '@', '%' ) {
+ my @group = sort grep { substr( $_, 0, 1 ) eq $sigil } keys %vars;
+ splice @group, 40 if @group > 40;
+ push @words, @group;
+ }
+
+ die "source watchlist is too small\n" if @words < 20;
+
+ $text = "# Internationalized comments: $note\n$source";
+ $text =~ s/^/ /mg if $name eq 'perl_whitespace';
+ $text =~ s/\n/\n\n\n/g if $name eq 'perl_whitespace';
+ $suffix = '(?!\\w)';
+ }
+ elsif ( $name =~ /^dna_/ ) {
+ @words = qw(ATG TAA TAG TGA TATAAA AATAAA CCAAT GAATTC GGATCC AAGCTT
+ GGTCTC CGTCTC CACGTG GCGGCCGC GATATC CTGCAG GTCGAC ACTAGT
+ TCATGA GCCACC GGCC CCGG GATC TCGA);
+
+ my $seed = 1729;
+ $text = '';
+
+ for my $record ( 1 .. 64 ) {
+ $text .= ">gene_$record $note\n";
+ my $seq = '';
+
+ for ( 1 .. 960 ) {
+ $seed = ( 1664525 * $seed + 1013904223 ) % 4294967296;
+ $seq .= substr( 'ACGT', int( $seed / 65536 ) % 4, 1 );
+ }
+
+ $seq = ( 'N' x 180 ) . ( 'AT' x 90 ) . substr( $seq, 360 )
+ if $name eq 'dna_repeats';
+ substr( $seq, 480, 24 ) = 'GAATTCATGGGATCCAAGCTTTGAA';
+ $seq =~ s/(.{60})/$1\n/g;
+ $text .= "$seq\n";
+ }
+ }
+ else { die "unknown corpus $name\n" }
+
+ @words = sort { length($b) <=> length($a) || $a cmp $b } @words;
+ my $pattern =
+ $prefix . '(?:'
+ . join( '|', map { quotemeta($_) } @words ) . ')'
+ . $suffix;
+
+ return ( $text, $pattern, scalar @words );
+}
+
+sub compile {
+ my ( $case, $off, $debug ) = @_;
+
+ local ${^RE_TRIE_MAXBUF} = $off ? -1 : 65536;
+ my $pattern = $case->{pattern};
+ my $code = ( $debug ? "use re 'debug'; " : '' )
+ . ( $case->{fold} ? 'qr/$pattern/iu' : 'qr/$pattern/u' );
+ my $re = eval $code;
+ die "compile $case->{id}: $@\n" if $@;
+
+ return $re;
+}
+
+sub scan {
+ my ( $case, $re, $repeats, $spans ) = @_;
+
+ my ( $count, $starts, $lengths ) = ( 0, 0, 0 );
+ my $target = \$case->{target};
+
+ for ( 1 .. $repeats ) {
+ pos($$target) = 0;
+
+ while ( $$target =~ /$re/g ) {
+ ++$count;
+ $starts = ( $starts + $-[0] ) & 0x7fffffff;
+ $lengths += $+[0] - $-[0];
+ push @$spans, "$-[0]:$+[0]" if $spans;
+ }
+ }
+
+ return { matches => $count, starts => $starts, lengths => $lengths };
+}
+
+sub check {
+ my ( $case, $got, $repeats ) = @_;
+
+ for my $key (qw(matches starts lengths)) {
+ my $expected = $case->{expected}{$key} * $repeats;
+ $expected &= 0x7fffffff if $key eq 'starts';
+
+ die "$case->{id}: $key: got $got->{$key}, expected $expected\n"
+ unless $got->{$key} == $expected;
+ }
+}
+
+sub prepare {
+ my ( $root, $dir, $kib ) = @_;
+
+ die "corpus size must be 1..4096 KiB\n"
+ unless $kib =~ /^\d+$/ && $kib >= 1 && $kib <= 4096;
+
+ make_path($dir);
+ die "manifest already exists in $dir\n"
+ if -e File::Spec->catfile( $dir, 'manifest.json' );
+
+ my $manifest = {
+ schema => 1,
+ kib => 0 + $kib,
+ cases => {},
+ sources => {},
+ generator_sha256 => sha256_hex( read_file(__FILE__) )
+ };
+
+ for my $file ( 'Porting/bench.pl', 'pod/perlintro.pod' ) {
+ $manifest->{sources}{$file} = sha256_hex(
+ read_file( File::Spec->catfile( $root, split '/', $file ) ) );
+ }
+
+ for my $definition ( definitions() ) {
+ my ( $name, $description, $role, $fold ) = @$definition;
+
+ for my $encoding (@encodings) {
+ my ( $unit, $pattern, $alternatives ) =
+ build( $root, $name, $encoding eq 'utf8-wide' );
+ my $target =
+ substr( $unit x ( 1 + int( $kib * 1024 / length($unit) ) ),
+ 0, $kib * 1024 );
+
+ if ( $encoding eq 'native-ascii' ) {
+
+ # Keep the dictionary and character offsets unchanged while
+ # making the subject entirely ASCII. The accented fixture
+ # letters have single-character ASCII counterparts here.
+ $target =~ tr/\x{e9}\x{ef}\x{e7}\x{df}\x{c9}/eicsE/;
+ $target =~ s/[^\x00-\x7f]/ /g;
+ }
+ else {
+ die "fixture lost its Latin-1 text: $name\n"
+ unless $target =~ /[\x80-\xff]/;
+ }
+
+ die "fixture lost its wide text: $name\n"
+ if $encoding eq 'utf8-wide' && $target !~ /[^\x00-\xff]/;
+
+ utf8::downgrade( $target, 1 )
+ or die "not native: $name\n"
+ if $encoding =~ /^native/;
+ utf8::upgrade($target) if $encoding !~ /^native/;
+
+ my $id = "$name.$encoding";
+ my $encoded = encode( 'UTF-8', $target );
+ my $case = {
+ id => $id,
+ name => $name,
+ description => $description,
+ encoding => $encoding,
+ role => $role,
+ fold => 0 + $fold,
+ alternatives => $alternatives,
+ pattern => $pattern,
+ pattern_sha256 => sha256_hex( encode( 'UTF-8', $pattern ) ),
+ corpus_sha256 => sha256_hex($encoded),
+ characters => length($target),
+ non_ascii_characters =>
+ scalar( () = $target =~ /[^\x00-\x7f]/g ),
+ wide_characters => scalar( () = $target =~ /[^\x00-\xff]/g ),
+ octets => do { use bytes; length($target) },
+ file => "$id.utf8",
+ target => $target
+ };
+
+ my ( @plain, @trie );
+ $case->{expected} = scan( $case, compile( $case, 1 ), 1, \@plain );
+ check( $case, scan( $case, compile( $case, 0 ), 1, \@trie ), 1 );
+
+ die "span mismatch: $id\n"
+ unless join( ',', @plain ) eq join( ',', @trie );
+ $case->{span_sha256} = sha256_hex( join( ',', @plain ) );
+
+ write_file( File::Spec->catfile( $dir, $case->{file} ), $encoded );
+ delete $case->{target};
+ $manifest->{cases}{$id} = $case;
+ }
+ }
+
+ write_file( File::Spec->catfile( $dir, 'manifest.json' ),
+ $json->encode($manifest) );
+
+ return $manifest;
+}
+
+sub load_case {
+ my ( $dir, $id ) = @_;
+
+ my $manifest = $json->decode(
+ read_file( File::Spec->catfile( $dir, 'manifest.json' ) ) );
+
+ # The generator hash records provenance. Frozen inputs remain replayable
+ # after generator changes; validate their stored schema and hashes instead.
+ die "unsupported corpus schema\n" unless $manifest->{schema} == 1;
+
+ my $saved = $manifest->{cases}{$id} or die "unknown case $id\n";
+ my %case = %$saved;
+
+ die "pattern hash mismatch: $id\n"
+ unless sha256_hex( encode( 'UTF-8', $case{pattern} ) ) eq
+ $case{pattern_sha256};
+
+ my $bytes = read_file( File::Spec->catfile( $dir, $case{file} ) );
+ die "corpus hash mismatch: $id\n"
+ unless sha256_hex($bytes) eq $case{corpus_sha256};
+
+ $case{target} = decode( 'UTF-8', $bytes, FB_CROAK );
+
+ if ( $case{encoding} =~ /^native(?:-ascii)?$/ ) {
+ utf8::downgrade( $case{target}, 1 ) or die "not native: $id\n";
+ }
+ else { utf8::upgrade( $case{target} ) }
+
+ return \%case;
+}
+
+sub main {
+ my ( $root, $action, @args ) = @_;
+
+ if ( $action eq 'prepare' ) {
+ print $json->encode( prepare( $root, $args[0], $args[1] // 32 ) ), "\n";
+ return;
+ }
+
+ if ( $action eq 'config' ) {
+ my $options = eval { join ' ', Internals::V() } // '';
+
+ print $json->encode(
+ {
+ version => "$^V",
+ executable => $^X,
+ compile_options => $options,
+ debugging => 0 + !!(
+ $options =~ /\bDEBUGGING\b/
+ || ( $Config{ccflags} // '' ) =~ /(?:^|\s)-DDEBUGGING\b/
+ ),
+ threaded => 0 + !!(
+ ( $Config{useithreads} // '' ) eq 'define'
+ || $options =~ /\bUSE_ITHREADS\b/
+ ),
+ map { $_ => $Config{$_} // '' }
+ qw(archname cc ccflags optimize
+ useithreads usemultiplicity use64bitint use64bitall git_commit_id)
+ }
+ ),
+ "\n";
+ return;
+ }
+
+ my ( $dir, $id, $repeats ) = @args;
+ my $case = load_case( $dir, $id );
+ my $re = compile( $case, 0, $action eq 'explain' );
+
+ if ( $action eq 'explain' ) {
+ print $json->encode( { id => $id } ), "\n";
+ return;
+ }
+
+ die "repeats must be 1..1000000\n"
+ unless defined($repeats)
+ && $repeats =~ /^\d+$/
+ && $repeats >= 1
+ && $repeats <= 1000000;
+
+ my @spans;
+
+ if ( $action eq 'verify' ) {
+ my $got = scan( $case, $re, 1, \@spans );
+ check( $case, $got, 1 );
+ die "span hash mismatch: $id\n"
+ unless sha256_hex( join( ',', @spans ) ) eq $case->{span_sha256};
+ }
+ elsif ( $action ne 'run' ) { die "unknown corpus action $action\n" }
+
+ my $start = clock();
+ my $got = scan( $case, $re, $repeats );
+ my $elapsed = clock() - $start;
+
+ check( $case, $got, $repeats );
+
+ print $json->encode(
+ {
+ %$got,
+ id => $id,
+ repeats => 0 + $repeats,
+ elapsed => $elapsed,
+ corpus_sha256 => $case->{corpus_sha256},
+ pattern_sha256 => $case->{pattern_sha256},
+ utf8 => 0 + utf8::is_utf8( $case->{target} )
+ }
+ ),
+ "\n";
+}
+
+1;
diff --git a/t/re/trie_bench_corpus.t b/t/re/trie_bench_corpus.t
new file mode 100644
index 0000000000..5a39bc11c5
--- /dev/null
+++ b/t/re/trie_bench_corpus.t
@@ -0,0 +1,127 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+ skip_all_without_dynamic_extension($_)
+ for qw(Digest::SHA Encode Time::HiRes);
+}
+
+use strict;
+use warnings;
+use Cwd qw(abs_path);
+use Digest::SHA qw(sha256_hex);
+use File::Spec;
+use File::Temp qw(tempdir);
+
+require './re/trie_bench_corpus.pl';
+
+plan tests => 534;
+
+my $dir = tempdir( 'trie-corpus-XXXXXX', DIR => '.', CLEANUP => 1 );
+my $manifest = TrieBenchCorpus::prepare( abs_path('..'), $dir, 32 );
+my @ids = sort keys %{ $manifest->{cases} };
+
+is( scalar @ids, 40, 'ten corpus families in four target representations' );
+
+for my $id (@ids) {
+ my $case = TrieBenchCorpus::load_case( $dir, $id );
+
+ is(
+ 0 + utf8::is_utf8( $case->{target} ),
+ 0 + ( $case->{encoding} !~ /^native/ ),
+ "$id target flag"
+ );
+ is( length( $case->{target} ), $case->{characters}, "$id character count" );
+
+ if ( $case->{encoding} eq 'native-ascii' ) {
+ unlike( $case->{target}, qr/[^\x00-\x7f]/,
+ "$id contains only ASCII characters" );
+ }
+ else {
+ like( $case->{target}, qr/[\x80-\xff]/,
+ "$id contains actual Latin-1 characters" );
+ }
+
+ my $non_ascii = () = $case->{target} =~ /[^\x00-\x7f]/g;
+ my $wide = () = $case->{target} =~ /[^\x00-\xff]/g;
+ is( $case->{non_ascii_characters},
+ $non_ascii, "$id non-ASCII character count" );
+ is( $case->{wide_characters}, $wide, "$id wide character count" );
+ like( $case->{target}, qr/[^\x00-\xff]/,
+ "$id contains actual wide characters" )
+ if $case->{encoding} eq 'utf8-wide';
+
+ my $re = TrieBenchCorpus::compile( $case, 0 );
+ my @spans;
+ my $got = TrieBenchCorpus::scan( $case, $re, 1, \@spans );
+
+ is( $got->{$_}, $case->{expected}{$_}, "$id $_" )
+ for qw(matches starts lengths);
+ is( sha256_hex( join( ',', @spans ) ),
+ $case->{span_sha256}, "$id complete span stream" );
+
+ my $twice = TrieBenchCorpus::scan( $case, $re, 2 );
+
+ for my $key (qw(matches starts lengths)) {
+ my $expected = $case->{expected}{$key} * 2;
+ $expected &= 0x7fffffff if $key eq 'starts';
+ is( $twice->{$key}, $expected, "$id repeated scan $key" );
+ }
+}
+
+for my $definition ( TrieBenchCorpus::definitions() ) {
+ my $name = $definition->[0];
+
+ for my $key (qw(corpus_sha256 pattern_sha256)) {
+ is(
+ $manifest->{cases}{"$name.native"}{$key},
+ $manifest->{cases}{"$name.utf8-latin1"}{$key},
+ "$name native/upgraded pair has identical $key"
+ );
+ }
+
+ is(
+ $manifest->{cases}{"$name.native-ascii"}{pattern_sha256},
+ $manifest->{cases}{"$name.native"}{pattern_sha256},
+ "$name ASCII and Latin-1 subjects use identical dictionaries"
+ );
+ is(
+ $manifest->{cases}{"$name.native-ascii"}{characters},
+ $manifest->{cases}{"$name.native"}{characters},
+ "$name ASCII conversion preserves subject length"
+ );
+}
+
+eval { TrieBenchCorpus::prepare( abs_path('..'), $dir, 32 ) };
+like(
+ $@,
+ qr/manifest already exists/,
+ 'refuse to overwrite an existing snapshot'
+);
+
+my $manifest_path = File::Spec->catfile( $dir, 'manifest.json' );
+my $saved_manifest = TrieBenchCorpus::read_file($manifest_path);
+my $older_generator = JSON::PP::decode_json($saved_manifest);
+$older_generator->{generator_sha256} = '0' x 64;
+TrieBenchCorpus::write_file( $manifest_path,
+ JSON::PP::encode_json($older_generator) );
+is(
+ TrieBenchCorpus::load_case( $dir, $ids[0] )->{corpus_sha256},
+ $manifest->{cases}{ $ids[0] }{corpus_sha256},
+ 'replay a frozen corpus from an older generator'
+);
+
+TrieBenchCorpus::write_file( $manifest_path, $saved_manifest );
+
+my $case = $manifest->{cases}{ $ids[0] };
+my $path = File::Spec->catfile( $dir, $case->{file} );
+TrieBenchCorpus::write_file( $path,
+ TrieBenchCorpus::read_file($path) . 'corrupt' );
+eval { TrieBenchCorpus::load_case( $dir, $ids[0] ) };
+like(
+ $@,
+ qr/corpus hash mismatch/,
+ 'detect a changed corpus instead of comparing different inputs'
+);