regen/mph.pl

   1 package MinimalPerfectHash;
   2 use strict;
   3 use warnings;
   4 use Data::Dumper;
   5 use Carp;
   6 use Text::Wrap;
   7
   8 my $DEBUG= 0;
   9 my $RSHIFT= 8;
  10 my $FNV_CONST= 16777619;
  11
  12 sub _fnv {
  13     my ($key, $seed)= @_;
  14     use integer;
  15     my $hash = 0+$seed;
  16     foreach my $char (split //, $key) {
  17         $hash = $hash ^ ord($char);
  18         $hash = ($hash * $FNV_CONST) & 0xFFFFFFFF;
  19     }
  20     return $hash;
  21 }
  22
  23 sub build_perfect_hash {
  24     my ($hash, $split_pos)= @_;
  25
  26     my $n= 0+keys %$hash;
  27     my $max_h= 0xFFFFFFFF;
  28     $max_h -= $max_h % $n; # this just avoids a tiny bit bias
  29     my $seed1= unpack("N", "Perl") - 1;
  30     my $hash_to_key;
  31     my $key_to_hash;
  32     my $length_all_keys;
  33     my $key_buckets;
  34     SEED1:
  35     for ($seed1++;1;$seed1++) {
  36         my %hash_to_key;
  37         my %key_to_hash;
  38         my %key_buckets;
  39         my %high;
  40         $length_all_keys= 0;
  41         foreach my $key (sort keys %$hash) {
  42             $length_all_keys += length $key;
  43             my $h= _fnv($key,$seed1);
  44             next SEED1 if $h >= $max_h; # check if this hash would bias, and if so find a new seed
  45             next SEED1 if exists $hash_to_key{$h};
  46             next SEED1 if $high{$h >> $RSHIFT}++;
  47             $hash_to_key{$h}= $key;
  48             $key_to_hash{$key}= $h;
  49             push @{$key_buckets{$h % $n}}, $key;
  50         }
  51         $hash_to_key= \%hash_to_key;
  52         $key_to_hash= \%key_to_hash;
  53         $key_buckets= \%key_buckets;
  54         last SEED1;
  55     }
  56
  57     my %token;
  58     my @first_level;
  59     my @second_level;
  60     foreach my $first_idx (sort { @{$key_buckets->{$b}} <=> @{$key_buckets->{$a}} || $a <=> $b } keys %$key_buckets) {
  61         my $keys= $key_buckets->{$first_idx};
  62         #printf "got %d keys in bucket %d\n", 0+@$keys, $first_idx;
  63         my $seed2;
  64         SEED2:
  65         for ($seed2=1;1;$seed2++) {
  66             goto FIND_SEED if $seed2 > 0xFFFF;
  67             my @idx= map {
  68                 ( ( ( $key_to_hash->{$_} >> $RSHIFT ) ^ $seed2 ) & 0xFFFFFFFF ) % $n
  69             } @$keys;
  70             my %seen;
  71             next SEED2 if grep { $second_level[$_] || $seen{$_}++ } @idx;
  72             $first_level[$first_idx]= $seed2;
  73             @second_level[@idx]= map {
  74                 my $sp= $split_pos->{$_} // die "no split pos for '$_':$!";
  75                 my ($prefix,$suffix)= unpack "A${sp}A*", $_;
  76
  77                 +{
  78                     key     => $_,
  79                     prefix  => $prefix,
  80                     suffix  => $suffix,
  81                     hash    => $key_to_hash->{$_},
  82                     value   => $hash->{$_},
  83                     seed2   => 0,
  84                 }
  85             } @$keys;
  86             last;
  87         }
  88
  89     }
  90     $second_level[$_]{seed2}= $first_level[$_]||0, $second_level[$_]{idx}= $_ for 0 .. $#second_level;
  91
  92     return $seed1, \@second_level, $length_all_keys;
  93 }
  94
  95 sub build_split_words {
  96     my ($hash, $preprocess, $blob, $old_res)= @_;
  97     my %appended;
  98     $blob //= "";
  99     if ($preprocess) {
 100         my %parts;
 101         foreach my $key (sort {length($b) <=> length($a) || $a cmp $b } keys %$hash) {
 102             my ($prefix,$suffix);
 103             if ($key=~/^([^=]+=)([^=]+)\z/) {
 104                 ($prefix,$suffix)= ($1, $2);
 105                 $parts{$suffix}++;
 106                 #$parts{$prefix}++;
 107             } else {
 108                 $prefix= $key;
 109                 $parts{$prefix}++;
 110             }
 111
 112         }
 113         foreach my $key (sort {length($b) <=> length($a) || $a cmp $b } keys %parts) {
 114             $blob .= $key . "\0";
 115         }
 116         printf "Using preprocessing, initial blob size %d\n", length($blob);
 117     } else {
 118         printf "No preprocessing, initial blob size %d\n", length($blob);
 119     }
 120     my %res;
 121
 122     REDO:
 123     %res= ();
 124     KEY:
 125     foreach my $key (
 126         sort {
 127             (length($b) <=> length($a)) ||
 128             ($a cmp $b)
 129         }
 130         keys %$hash
 131     ) {
 132         next if exists $res{$key};
 133         if (index($blob,$key) >= 0 ) {
 134             my $idx= length($key);
 135             if ($DEBUG and $old_res and $old_res->{$key} != $idx) {
 136                 print "changing: $key => $old_res->{$key} : $idx\n";
 137             }
 138             $res{$key}= $idx;
 139             next KEY;
 140         }
 141         my $best= length($key);
 142         my $append= $key;
 143         my $min= 0; #length $key >= 4 ? 4 : 0;
 144         my $best_prefix;
 145         my $best_suffix;
 146         foreach my $idx (reverse $min .. length($key)) {
 147             my $prefix= substr($key,0,$idx);
 148             my $suffix= substr($key,$idx);
 149             my $i1= index($blob,$prefix)>=0;
 150             my $i2= index($blob,$suffix)>=0;
 151             if ($i1 and $i2) {
 152                 if ($DEBUG and $old_res and $old_res->{$key} != $idx) {
 153                     print "changing: $key => $old_res->{$key} : $idx\n";
 154                 }
 155                 $res{$key}= $idx;
 156                 $appended{$prefix}++;
 157                 $appended{$suffix}++;
 158                 next KEY;
 159             } elsif ($i1) {
 160                 if (length $suffix <= length $append) {
 161                     $best= $idx;
 162                     $append= $suffix;
 163                     $best_prefix= $prefix;
 164                     $best_suffix= $suffix;
 165                 }
 166             } elsif ($i2) {
 167                 if (length $prefix <= length $append) {
 168                     $best= $idx;
 169                     $append= $prefix;
 170                     $best_prefix= $prefix;
 171                     $best_suffix= $suffix;
 172                 }
 173             }
 174         }
 175         if ($DEBUG and $old_res and $old_res->{$key} != $best) {
 176             print "changing: $key => $old_res->{$key} : $best\n";
 177         }
 178         #print "$best_prefix|$best_suffix => $best => $append\n";
 179         $res{$key}= $best;
 180         $blob .= $append;
 181         $appended{$best_prefix}++;
 182         $appended{$best_suffix}++;
 183     }
 184     my $b2 = "";
 185     foreach my $key (sort { length($b) <=> length($a) || $a cmp $b } keys %appended) {
 186         $b2 .= $key unless index($b2,$key)>=0;
 187     }
 188     if (length($b2)<length($blob)) {
 189         printf "Length old blob: %d length new blob: %d, recomputing using new blob\n", length($blob),length($b2);
 190         $blob= $b2;
 191         %appended=();
 192         goto REDO;
 193     } else {
 194         printf "Length old blob: %d length new blob: %d, keeping old blob\n", length($blob),length($b2);
 195     }
 196     die sprintf "not same size? %d != %d", 0+keys %res, 0+keys %$hash unless keys %res == keys %$hash;
 197     return ($blob,\%res);
 198 }
 199
 200
 201 sub blob_as_code {
 202     my ($blob,$blob_name)= @_;
 203
 204     $blob_name ||= "mph_blob";
 205
 206     # output the blob as C code.
 207     my @code= (sprintf "STATIC const unsigned char %s[] =\n",$blob_name);
 208     my $blob_len= length $blob;
 209     while (length($blob)) {
 210         push @code, sprintf qq(    "%s"), substr($blob,0,65,"");
 211         push @code, length $blob ? "\n" : ";\n";
 212     }
 213     push @code, "/* $blob_name length: $blob_len */\n";
 214     return join "",@code;
 215 }
 216
 217 sub print_includes {
 218     my $ofh= shift;
 219     print $ofh "#include <stdio.h>\n";
 220     print $ofh "#include <string.h>\n";
 221     print $ofh "#include <stdint.h>\n";
 222     print $ofh "\n";
 223 }
 224
 225 sub print_defines {
 226     my ($ofh,$defines)= @_;
 227
 228     my $key_len;
 229     foreach my $def (keys %$defines) {
 230         $key_len //= length $def;
 231         $key_len= length $def if $key_len < length $def;
 232     }
 233     foreach my $def (sort keys %$defines) {
 234         printf $ofh "#define %*s %5d\n", -$key_len, $def, $defines->{$def};
 235     }
 236     print $ofh "\n";
 237 }
 238
 239
 240 sub build_array_of_struct {
 241     my ($second_level,$blob)= @_;
 242
 243     my %defines;
 244     my %tests;
 245     my @rows;
 246     foreach my $row (@$second_level) {
 247         $defines{$row->{value}}= $row->{idx}+1;
 248         $tests{$row->{key}}= $defines{$row->{value}};
 249         my @u16= (
 250             $row->{seed2},
 251             index($blob,$row->{prefix}//0),
 252             index($blob,$row->{suffix}//0),
 253         );
 254         $_ > 0xFFFF and die "panic: value exceeds range of U16"
 255             for @u16;
 256         my @u8= (
 257             length($row->{prefix}),
 258             length($row->{suffix}),
 259         );
 260         $_ > 0xFF and die "panic: value exceeds range of U8"
 261             for @u8;
 262         push @rows, sprintf("  { %5d, %5d, %5d, %3d, %3d, %s }   /* %s%s */",
 263             @u16, @u8, $row->{value}, $row->{prefix}, $row->{suffix});
 264     }
 265     return \@rows,\%defines,\%tests;
 266 }
 267
 268 sub make_algo {
 269     my ($second_level, $seed1, $length_all_keys, $smart_blob, $rows,
 270         $blob_name, $struct_name, $table_name, $match_name, $prefix) = @_;
 271
 272     $blob_name ||= "mph_blob";
 273     $struct_name ||= "mph_struct";
 274     $table_name ||= "mph_table";
 275     $prefix ||= "MPH";
 276
 277     my $n= 0+@$second_level;
 278     my $data_size= 0+@$second_level * 8 + length $smart_blob;
 279
 280     my @code = "#define ${prefix}_VALt I16\n\n";
 281     push @code, "/*\n";
 282     push @code, sprintf "rows: %s\n", $n;
 283     push @code, sprintf "seed: %s\n", $seed1;
 284     push @code, sprintf "full length of keys: %d\n", $length_all_keys;
 285     push @code, sprintf "blob length: %d\n", length $smart_blob;
 286     push @code, sprintf "ref length: %d\n", 0+@$second_level * 8;
 287     push @code, sprintf "data size: %d (%%%.2f)\n", $data_size, ($data_size / $length_all_keys) * 100;
 288     push @code, "*/\n\n";
 289
 290     push @code, blob_as_code($smart_blob, $blob_name);
 291     push @code, <<"EOF_CODE";
 292
 293 struct $struct_name {
 294     U16 seed2;
 295     U16 pfx;
 296     U16 sfx;
 297     U8  pfx_len;
 298     U8  sfx_len;
 299     ${prefix}_VALt value;
 300 };
 301
 302 EOF_CODE
 303
 304     push @code, "#define ${prefix}_RSHIFT $RSHIFT\n";
 305     push @code, "#define ${prefix}_BUCKETS $n\n\n";
 306     push @code, sprintf "STATIC const U32 ${prefix}_SEED1 = 0x%08x;\n", $seed1;
 307     push @code, sprintf "STATIC const U32 ${prefix}_FNV_CONST = 0x%08x;\n\n", $FNV_CONST;
 308
 309     push @code, "/* The comments give the input key for the row it is in */\n";
 310     push @code, "STATIC const struct $struct_name $table_name\[${prefix}_BUCKETS] = {\n", join(",\n", @$rows)."\n};\n\n";
 311     push @code, <<"EOF_CODE";
 312 ${prefix}_VALt $match_name( const unsigned char * const key, const U16 key_len ) {
 313     const unsigned char * ptr= key;
 314     const unsigned char * ptr_end= key + key_len;
 315     U32 h= ${prefix}_SEED1;
 316     U32 s;
 317     U32 n;
 318     do {
 319         h ^= *ptr;
 320         h *= ${prefix}_FNV_CONST;
 321     } while ( ++ptr < ptr_end );
 322     n= h % ${prefix}_BUCKETS;
 323     s = $table_name\[n].seed2;
 324     if (s) {
 325         h= (h >> ${prefix}_RSHIFT) ^ s;
 326         n = h % ${prefix}_BUCKETS;
 327         if (
 328             ( $table_name\[n].pfx_len + $table_name\[n].sfx_len == key_len ) &&
 329             ( memcmp($blob_name + $table_name\[n].pfx, key, $table_name\[n].pfx_len) == 0 ) &&
 330             ( !$table_name\[n].sfx_len || memcmp($blob_name + $table_name\[n].sfx,
 331                 key + $table_name\[n].pfx_len, $table_name\[n].sfx_len) == 0 )
 332         ) {
 333             return $table_name\[n].value;
 334         }
 335     }
 336     return 0;
 337 }
 338 EOF_CODE
 339
 340     return join "", @code;
 341 }
 342
 343 sub print_algo {
 344     my ($ofh, $second_level, $seed1, $long_blob, $smart_blob, $rows,
 345         $blob_name, $struct_name, $table_name, $match_name ) = @_;
 346
 347     if (!ref $ofh) {
 348         my $file= $ofh;
 349         undef $ofh;
 350         open $ofh, ">", $file
 351             or die "Failed to open '$file': $!";
 352     }
 353
 354     my $code = make_algo(
 355         $second_level, $seed1, $long_blob, $smart_blob, $rows,
 356         $blob_name, $struct_name, $table_name, $match_name );
 357     print $ofh $code;
 358 }
 359
 360 sub print_main {
 361     my ($ofh,$h_file,$match_name,$prefix)=@_;
 362     print $ofh <<"EOF_CODE";
 363 #include "$h_file"
 364
 365 int main(int argc, char *argv[]){
 366     int i;
 367     for (i=1; i<argc; i++) {
 368         unsigned char *key = (unsigned char *)argv[i];
 369         int key_len = strlen(argv[i]);
 370         printf("key: %s got: %d\\n", key, $match_name((unsigned char *)key,key_len));
 371     }
 372     return 0;
 373 }
 374 EOF_CODE
 375 }
 376
 377 # output the test Perl code.
 378 sub print_tests {
 379     my ($file, $tests_hash)= @_;
 380     open my $ofh, ">", $file
 381         or die "Failed to open '$file' for writing: $!";
 382     my $num_tests= 2 + keys %$tests_hash;
 383     print $ofh "use strict;\nuse warnings;\nuse Test::More tests => $num_tests;\nmy \@res;";
 384     my $bytes= 0;
 385     my @tests= sort keys %$tests_hash;
 386     print $ofh "\@res=`./mph_test '$tests[0]/should-not-match' 'should-not-match/$tests[0]'`;\n";
 387     print $ofh "ok( \$res[0] =~ /got: 0/,'proper prefix does not match');\n";
 388     print $ofh "ok( \$res[1] =~ /got: 0/,'proper suffix does not match');\n";
 389     while (@tests) {
 390         my @batch= splice @tests,0,10;
 391         my $batch_args= join " ", map { "'$_'" } @batch;
 392         print $ofh "\@res=`./mph_test $batch_args`;\n";
 393         foreach my $i (0..$#batch) {
 394             my $key= $batch[$i];
 395             my $want= $tests_hash->{$key};
 396             print $ofh "ok(\$res[$i]=~/got: (\\d+)/ && \$1 == $want, '$key');\n";
 397         }
 398     }
 399     close $ofh;
 400 }
 401
 402 sub print_test_binary {
 403     my ($file,$h_file, $second_level, $seed1, $length_all_keys,
 404         $smart_blob, $rows, $defines, $match_name, $prefix)= @_;
 405     open my $ofh, ">", $file
 406         or die "Failed to open '$file': $!";
 407     print_includes($ofh);
 408     print_defines($ofh, $defines);
 409     print_main($ofh,$h_file,$match_name,$prefix);
 410     close $ofh;
 411 }
 412
 413 sub make_mph_from_hash {
 414     my $hash= shift;
 415
 416     # we do this twice because often we can find longer prefixes on the second pass.
 417     my @keys= sort {length($b) <=> length($a) || $a cmp $b } keys %$hash;
 418
 419     my ($smart_blob, $res_to_split)= build_split_words($hash,0);
 420     {
 421         my ($smart_blob2, $res_to_split2)= build_split_words($hash,1);
 422         if (length($smart_blob) > length($smart_blob2)) {
 423             printf "Using preprocess-smart blob, length: %d (vs %d)\n", length $smart_blob2, length $smart_blob;
 424             $smart_blob= $smart_blob2;
 425             $res_to_split= $res_to_split2;
 426         } else {
 427             printf "Using greedy-smart blob, length: %d (vs %d)\n", length $smart_blob, length $smart_blob2;
 428         }
 429     }
 430     my ($seed1, $second_level, $length_all_keys)= build_perfect_hash($hash, $res_to_split);
 431     my ($rows, $defines, $tests)= build_array_of_struct($second_level, $smart_blob);
 432     return ($second_level, $seed1, $length_all_keys, $smart_blob, $rows, $defines, $tests);
 433 }
 434
 435 sub make_files {
 436     my ($hash,$base_name)= @_;
 437
 438     my $h_name= $base_name . "_algo.h";
 439     my $c_name= $base_name . "_test.c";
 440     my $p_name= $base_name . "_test.pl";
 441     my $blob_name= $base_name . "_blob";
 442     my $struct_name= $base_name . "_bucket_info";
 443     my $table_name= $base_name . "_table";
 444     my $match_name= $base_name . "_match";
 445     my $prefix= uc($base_name);
 446
 447     my ($second_level, $seed1, $length_all_keys,
 448         $smart_blob, $rows, $defines, $tests)= make_mph_from_hash( $hash );
 449     print_algo( $h_name,
 450         $second_level, $seed1, $length_all_keys, $smart_blob, $rows,
 451         $blob_name, $struct_name, $table_name, $match_name, $prefix );
 452     print_test_binary( $c_name, $h_name, $second_level, $seed1, $length_all_keys,
 453         $smart_blob, $rows, $defines,
 454         $match_name, $prefix );
 455     print_tests( $p_name, $tests );
 456 }
 457
 458 unless (caller) {
 459     my %hash;
 460     {
 461         no warnings;
 462         do "../perl/lib/unicore/Heavy.pl";
 463         %hash= %utf8::loose_to_file_of;
 464     }
 465     if ($ENV{MERGE_KEYS}) {
 466         my @keys= keys %hash;
 467         foreach my $loose (keys %utf8::loose_property_name_of) {
 468             my $to= $utf8::loose_property_name_of{$loose};
 469             next if $to eq $loose;
 470             foreach my $key (@keys) {
 471                 my $copy= $key;
 472                 if ($copy=~s/^\Q$to\E(=|\z)/$loose$1/) {
 473                     #print "$key => $copy\n";
 474                     $hash{$copy}= $key;
 475                 }
 476             }
 477         }
 478     }
 479     foreach my $key (keys %hash) {
 480         my $munged= uc($key);
 481         $munged=~s/\W/__/g;
 482         $hash{$key} = $munged;
 483     }
 484
 485     my $name= shift @ARGV;
 486     $name ||= "mph";
 487     make_files(\%hash,$name);
 488 }
 489
 490 1;
 491 __END__