math/gen-libm-test.pl

   1 #!/usr/bin/perl -w
   2 # Copyright (C) 1999-2013 Free Software Foundation, Inc.
   3 # This file is part of the GNU C Library.
   4 # Contributed by Andreas Jaeger <aj@suse.de>, 1999.
   5
   6 # The GNU C Library is free software; you can redistribute it and/or
   7 # modify it under the terms of the GNU Lesser General Public
   8 # License as published by the Free Software Foundation; either
   9 # version 2.1 of the License, or (at your option) any later version.
  10
  11 # The GNU C Library is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 # Lesser General Public License for more details.
  15
  16 # You should have received a copy of the GNU Lesser General Public
  17 # License along with the GNU C Library; if not, see
  18 # <http://www.gnu.org/licenses/>.
  19
  20 # This file needs to be tidied up
  21 # Note that functions and tests share the same namespace.
  22
  23 # Information about tests are stored in: %results
  24 # $results{$test}{"kind"} is either "fct" or "test" and flags whether this
  25 # is a maximal error of a function or a single test.
  26 # $results{$test}{"type"} is the result type, e.g. normal or complex.
  27 # $results{$test}{"has_ulps"} is set if deltas exist.
  28 # In the following description $type and $float are:
  29 # - $type is either "normal", "real" (for the real part of a complex number)
  30 #   or "imag" (for the imaginary part # of a complex number).
  31 # - $float is either of float, ifloat, double, idouble, ldouble, ildouble;
  32 #   It represents the underlying floating point type (float, double or long
  33 #   double) and if inline functions (the leading i stands for inline)
  34 #   are used.
  35 # $results{$test}{$type}{"ulp"}{$float} is defined and has a delta as value
  36
  37
  38 use Getopt::Std;
  39
  40 use strict;
  41
  42 use vars qw ($input $output);
  43 use vars qw (%results);
  44 use vars qw (@functions);
  45 use vars qw (%beautify @all_floats);
  46 use vars qw ($output_dir $ulps_file);
  47
  48 # all_floats is sorted and contains all recognised float types
  49 @all_floats = ('double', 'float', 'idouble',
  50                'ifloat', 'ildouble', 'ldouble');
  51
  52 %beautify =
  53   ( "minus_zero" => "-0",
  54     "plus_zero" => "+0",
  55     "minus_infty" => "-inf",
  56     "plus_infty" => "inf",
  57     "qnan_value" => "qNaN",
  58     "M_El" => "e",
  59     "M_E2l" => "e^2",
  60     "M_E3l" => "e^3",
  61     "M_LOG10El", "log10(e)",
  62     "M_PIl" => "pi",
  63     "M_PI_34l" => "3/4 pi",
  64     "M_PI_2l" => "pi/2",
  65     "M_PI_4l" => "pi/4",
  66     "M_PI_6l" => "pi/6",
  67     "M_PI_34_LOG10El" => "3/4 pi*log10(e)",
  68     "M_PI_LOG10El" => "pi*log10(e)",
  69     "M_PI2_LOG10El" => "pi/2*log10(e)",
  70     "M_PI4_LOG10El" => "pi/4*log10(e)",
  71     "M_LOG_SQRT_PIl" => "log(sqrt(pi))",
  72     "M_LOG_2_SQRT_PIl" => "log(2*sqrt(pi))",
  73     "M_2_SQRT_PIl" => "2 sqrt (pi)",
  74     "M_SQRT_PIl" => "sqrt (pi)",
  75   );
  76
  77
  78 # get Options
  79 # Options:
  80 # u: ulps-file
  81 # h: help
  82 # o: output-directory
  83 # n: generate new ulps file
  84 use vars qw($opt_u $opt_h $opt_o $opt_n);
  85 getopts('u:o:nh');
  86
  87 $ulps_file = 'libm-test-ulps';
  88 $output_dir = '';
  89
  90 if ($opt_h) {
  91   print "Usage: gen-libm-test.pl [OPTIONS]\n";
  92   print " -h         print this help, then exit\n";
  93   print " -o DIR     directory where generated files will be placed\n";
  94   print " -n         only generate sorted file NewUlps from libm-test-ulps\n";
  95   print " -u FILE    input file with ulps\n";
  96   exit 0;
  97 }
  98
  99 $ulps_file = $opt_u if ($opt_u);
 100 $output_dir = $opt_o if ($opt_o);
 101
 102 $input = "libm-test.inc";
 103 $output = "${output_dir}libm-test.c";
 104
 105 &parse_ulps ($ulps_file);
 106 &generate_testfile ($input, $output) unless ($opt_n);
 107 &output_ulps ("${output_dir}libm-test-ulps.h", $ulps_file) unless ($opt_n);
 108 &print_ulps_file ("${output_dir}NewUlps") if ($opt_n);
 109
 110 # Return a nicer representation
 111 sub beautify {
 112   my ($arg) = @_;
 113   my ($tmp);
 114
 115   if (exists $beautify{$arg}) {
 116     return $beautify{$arg};
 117   }
 118   if ($arg =~ /^-/) {
 119     $tmp = $arg;
 120     $tmp =~ s/^-//;
 121     if (exists $beautify{$tmp}) {
 122       return '-' . $beautify{$tmp};
 123     }
 124   }
 125   if ($arg =~ /[0-9]L$/) {
 126     $arg =~ s/L$//;
 127   }
 128   return $arg;
 129 }
 130
 131 # Return a nicer representation of a complex number
 132 sub build_complex_beautify {
 133   my ($r, $i) = @_;
 134   my ($str1, $str2);
 135
 136   $str1 = &beautify ($r);
 137   $str2 = &beautify ($i);
 138   if ($str2 =~ /^-/) {
 139     $str2 =~ s/^-//;
 140     $str1 .= ' - ' . $str2;
 141   } else {
 142     $str1 .= ' + ' . $str2;
 143   }
 144   $str1 .= ' i';
 145   return $str1;
 146 }
 147
 148 # Return the text to put in an initializer for a test's exception
 149 # information.
 150 sub show_exceptions {
 151   my ($exception) = @_;
 152   if (defined $exception) {
 153     return ", $exception";
 154   } else {
 155     return ', 0';
 156   }
 157 }
 158
 159 # Parse the arguments to TEST_x_y
 160 sub parse_args {
 161   my ($file, $descr, $fct, $args) = @_;
 162   my (@args, $str, $descr_args, $descr_res, @descr);
 163   my ($current_arg, $cline, $i);
 164   my (@special);
 165   my ($call);
 166
 167   ($descr_args, $descr_res) = split /_/,$descr, 2;
 168
 169   @args = split /,\s*/, $args;
 170
 171   $call = "$fct (";
 172
 173   # Generate first the string that's shown to the user
 174   $current_arg = 1;
 175   @descr = split //,$descr_args;
 176   for ($i = 0; $i <= $#descr; $i++) {
 177     my $comma = "";
 178     if ($current_arg > 1) {
 179       $comma = ', ';
 180     }
 181     # FLOAT, int, long int, long long int
 182     if ($descr[$i] =~ /f|i|l|L/) {
 183       $call .= $comma . &beautify ($args[$current_arg]);
 184       ++$current_arg;
 185       next;
 186     }
 187     # &FLOAT, &int - simplify call by not showing argument.
 188     if ($descr[$i] =~ /F|I/) {
 189       next;
 190     }
 191     # complex
 192     if ($descr[$i] eq 'c') {
 193       $call .= $comma . &build_complex_beautify ($args[$current_arg], $args[$current_arg+1]);
 194       $current_arg += 2;
 195       next;
 196     }
 197
 198     die ("$descr[$i] is unknown");
 199   }
 200   $call .= ')';
 201   $str = "$call == ";
 202
 203   # Result
 204   @descr = split //,$descr_res;
 205   foreach (@descr) {
 206     if ($_ =~ /f|i|l|L/) {
 207       $str .= &beautify ($args[$current_arg]);
 208       ++$current_arg;
 209     } elsif ($_ eq 'c') {
 210       $str .= &build_complex_beautify ($args[$current_arg], $args[$current_arg+1]);
 211       $current_arg += 2;
 212     } elsif ($_ eq 'b') {
 213       # boolean
 214       $str .= ($args[$current_arg] == 0) ? "false" : "true";
 215       ++$current_arg;
 216     } elsif ($_ eq '1') {
 217       ++$current_arg;
 218     } else {
 219       die ("$_ is unknown");
 220     }
 221   }
 222   # consistency check
 223   if ($current_arg == $#args) {
 224     die ("wrong number of arguments")
 225       unless ($args[$current_arg] =~ /EXCEPTION|ERRNO|IGNORE_ZERO_INF_SIGN/);
 226   } elsif ($current_arg < $#args) {
 227     die ("wrong number of arguments");
 228   } elsif ($current_arg > ($#args+1)) {
 229     die ("wrong number of arguments");
 230   }
 231
 232
 233   # Put the C program line together
 234   # Reset some variables to start again
 235   $current_arg = 1;
 236   $cline = "{ \"$str\"";
 237   @descr = split //,$descr_args;
 238   for ($i=0; $i <= $#descr; $i++) {
 239     # FLOAT, int, long int, long long int
 240     if ($descr[$i] =~ /f|i|l|L/) {
 241       $cline .= ", $args[$current_arg]";
 242       $current_arg++;
 243       next;
 244     }
 245     # &FLOAT, &int
 246     if ($descr[$i] =~ /F|I/) {
 247       next;
 248     }
 249     # complex
 250     if ($descr[$i] eq 'c') {
 251       $cline .= ", $args[$current_arg], $args[$current_arg+1]";
 252       $current_arg += 2;
 253       next;
 254     }
 255   }
 256
 257   @descr = split //,$descr_res;
 258   foreach (@descr) {
 259     if ($_ =~ /b|f|i|l|L/ ) {
 260       $cline .= ", $args[$current_arg]";
 261       $current_arg++;
 262     } elsif ($_ eq 'c') {
 263       $cline .= ", $args[$current_arg], $args[$current_arg+1]";
 264       $current_arg += 2;
 265     } elsif ($_ eq '1') {
 266       push @special, $args[$current_arg];
 267       ++$current_arg;
 268     }
 269   }
 270   # Add exceptions.
 271   $cline .= show_exceptions (($current_arg <= $#args)
 272                              ? $args[$current_arg]
 273                              : undef);
 274
 275   # special treatment for some functions
 276   $i = 0;
 277   foreach (@special) {
 278     ++$i;
 279     my ($extra_expected) = $_;
 280     my ($run_extra) = ($extra_expected ne "IGNORE" ? 1 : 0);
 281     my ($str) = "$call extra output $i";
 282     if (!$run_extra) {
 283       $str = "";
 284       $extra_expected = "0";
 285     }
 286     $cline .= ", \"$str\", $run_extra, $extra_expected";
 287   }
 288   print $file "    $cline },\n";
 289 }
 290
 291 # Generate libm-test.c
 292 sub generate_testfile {
 293   my ($input, $output) = @_;
 294   my ($lasttext);
 295   my (@args, $i, $str, $thisfct);
 296
 297   open INPUT, $input or die ("Can't open $input: $!");
 298   open OUTPUT, ">$output" or die ("Can't open $output: $!");
 299
 300   # Replace the special macros
 301   while (<INPUT>) {
 302
 303     # TEST_...
 304     if (/^\s*TEST_/) {
 305       my ($descr, $args);
 306       chop;
 307       ($descr, $args) = ($_ =~ /TEST_(\w+)\s*\((.*)\)/);
 308       &parse_args (\*OUTPUT, $descr, $thisfct, $args);
 309       next;
 310     }
 311     # START_DATA (function)
 312     if (/START_DATA/) {
 313       ($thisfct) = ($_ =~ /START_DATA\s*\((.*)\)/);
 314       next;
 315     }
 316     # START (function)
 317     if (/START/) {
 318       ($thisfct) = ($_ =~ /START\s*\((.*)\)/);
 319       print OUTPUT "  init_max_error ();\n";
 320       next;
 321     }
 322     # END_DATA (function)
 323     if (/END_DATA/) {
 324       next;
 325     }
 326     # END (function)
 327     if (/END/) {
 328       my ($fct, $line, $type);
 329       if (/complex/) {
 330         s/,\s*complex\s*//;
 331         $type = 'complex';
 332       } else {
 333         $type = 'normal';
 334       }
 335       ($fct) = ($_ =~ /END\s*\((.*)\)/);
 336       if ($type eq 'complex') {
 337         $line = "  print_complex_max_error (\"$fct\");\n";
 338       } else {
 339         $line = "  print_max_error (\"$fct\");\n";
 340       }
 341       print OUTPUT $line;
 342       push @functions, $fct;
 343       next;
 344     }
 345     print OUTPUT;
 346   }
 347   close INPUT;
 348   close OUTPUT;
 349 }
 350
 351
 352
 353 # Parse ulps file
 354 sub parse_ulps {
 355   my ($file) = @_;
 356   my ($test, $type, $float, $eps, $kind);
 357
 358   # $type has the following values:
 359   # "normal": No complex variable
 360   # "real": Real part of complex result
 361   # "imag": Imaginary part of complex result
 362   open ULP, $file  or die ("Can't open $file: $!");
 363   while (<ULP>) {
 364     chop;
 365     # ignore comments and empty lines
 366     next if /^#/;
 367     next if /^\s*$/;
 368     if (/^Test/) {
 369       if (/Real part of:/) {
 370         s/Real part of: //;
 371         $type = 'real';
 372       } elsif (/Imaginary part of:/) {
 373         s/Imaginary part of: //;
 374         $type = 'imag';
 375       } else {
 376         $type = 'normal';
 377       }
 378       s/^.+\"(.*)\".*$/$1/;
 379       $test = $_;
 380       $kind = 'test';
 381       next;
 382     }
 383     if (/^Function: /) {
 384       if (/Real part of/) {
 385         s/Real part of //;
 386         $type = 'real';
 387       } elsif (/Imaginary part of/) {
 388         s/Imaginary part of //;
 389         $type = 'imag';
 390       } else {
 391         $type = 'normal';
 392       }
 393       ($test) = ($_ =~ /^Function:\s*\"([a-zA-Z0-9_]+)\"/);
 394       $kind = 'fct';
 395       next;
 396     }
 397     if (/^i?(float|double|ldouble):/) {
 398       ($float, $eps) = split /\s*:\s*/,$_,2;
 399
 400       if ($eps eq "0") {
 401         # ignore
 402         next;
 403       } else {
 404         $results{$test}{$type}{'ulp'}{$float} = $eps;
 405         $results{$test}{'has_ulps'} = 1;
 406       }
 407       if ($type =~ /^real|imag$/) {
 408         $results{$test}{'type'} = 'complex';
 409       } elsif ($type eq 'normal') {
 410         $results{$test}{'type'} = 'normal';
 411       }
 412       $results{$test}{'kind'} = $kind;
 413       next;
 414     }
 415     print "Skipping unknown entry: `$_'\n";
 416   }
 417   close ULP;
 418 }
 419
 420
 421 # Clean up a floating point number
 422 sub clean_up_number {
 423   my ($number) = @_;
 424
 425   # Remove trailing zeros after the decimal point
 426   if ($number =~ /\./) {
 427     $number =~ s/0+$//;
 428     $number =~ s/\.$//;
 429   }
 430   return $number;
 431 }
 432
 433 # Output a file which can be read in as ulps file.
 434 sub print_ulps_file {
 435   my ($file) = @_;
 436   my ($test, $type, $float, $eps, $fct, $last_fct);
 437
 438   $last_fct = '';
 439   open NEWULP, ">$file" or die ("Can't open $file: $!");
 440   print NEWULP "# Begin of automatic generation\n";
 441   # first the function calls
 442   foreach $test (sort keys %results) {
 443     next if ($results{$test}{'kind'} ne 'test');
 444     foreach $type ('real', 'imag', 'normal') {
 445       if (exists $results{$test}{$type}) {
 446         if (defined $results{$test}) {
 447           ($fct) = ($test =~ /^(\w+)\s/);
 448           if ($fct ne $last_fct) {
 449             $last_fct = $fct;
 450             print NEWULP "\n# $fct\n";
 451           }
 452         }
 453         if ($type eq 'normal') {
 454           print NEWULP "Test \"$test\":\n";
 455         } elsif ($type eq 'real') {
 456           print NEWULP "Test \"Real part of: $test\":\n";
 457         } elsif ($type eq 'imag') {
 458           print NEWULP "Test \"Imaginary part of: $test\":\n";
 459         }
 460         foreach $float (@all_floats) {
 461           if (exists $results{$test}{$type}{'ulp'}{$float}) {
 462             print NEWULP "$float: ",
 463             &clean_up_number ($results{$test}{$type}{'ulp'}{$float}),
 464             "\n";
 465           }
 466         }
 467       }
 468     }
 469   }
 470   print NEWULP "\n# Maximal error of functions:\n";
 471
 472   foreach $fct (sort keys %results) {
 473     next if ($results{$fct}{'kind'} ne 'fct');
 474     foreach $type ('real', 'imag', 'normal') {
 475       if (exists $results{$fct}{$type}) {
 476         if ($type eq 'normal') {
 477           print NEWULP "Function: \"$fct\":\n";
 478         } elsif ($type eq 'real') {
 479           print NEWULP "Function: Real part of \"$fct\":\n";
 480         } elsif ($type eq 'imag') {
 481           print NEWULP "Function: Imaginary part of \"$fct\":\n";
 482         }
 483         foreach $float (@all_floats) {
 484           if (exists $results{$fct}{$type}{'ulp'}{$float}) {
 485             print NEWULP "$float: ",
 486             &clean_up_number ($results{$fct}{$type}{'ulp'}{$float}),
 487             "\n";
 488           }
 489         }
 490         print NEWULP "\n";
 491       }
 492     }
 493   }
 494   print NEWULP "# end of automatic generation\n";
 495   close NEWULP;
 496 }
 497
 498 sub get_ulps {
 499   my ($test, $type, $float) = @_;
 500
 501   return (exists $results{$test}{$type}{'ulp'}{$float}
 502           ? $results{$test}{$type}{'ulp'}{$float} : "0");
 503 }
 504
 505 # Return the ulps value for a single test.
 506 sub get_all_ulps_for_test {
 507   my ($test, $type) = @_;
 508   my ($ldouble, $double, $float, $ildouble, $idouble, $ifloat);
 509
 510   if (exists $results{$test}{'has_ulps'}) {
 511     # XXX use all_floats (change order!)
 512     $ldouble = &get_ulps ($test, $type, "ldouble");
 513     $double = &get_ulps ($test, $type, "double");
 514     $float = &get_ulps ($test, $type, "float");
 515     $ildouble = &get_ulps ($test, $type, "ildouble");
 516     $idouble = &get_ulps ($test, $type, "idouble");
 517     $ifloat = &get_ulps ($test, $type, "ifloat");
 518     return "CHOOSE ($ldouble, $double, $float, $ildouble, $idouble, $ifloat)";
 519   } else {
 520     die "get_all_ulps_for_test called for \"$test\" with no ulps\n";
 521   }
 522 }
 523
 524 # Print include file
 525 sub output_ulps {
 526   my ($file, $ulps_filename) = @_;
 527   my ($i, $fct, $type, $ulp, $ulp_real, $ulp_imag);
 528   my (%test_ulps, %func_ulps, %func_real_ulps, %func_imag_ulps);
 529
 530   open ULP, ">$file" or die ("Can't open $file: $!");
 531
 532   print ULP "/* This file is automatically generated\n";
 533   print ULP "   from $ulps_filename with gen-libm-test.pl.\n";
 534   print ULP "   Don't change it - change instead the master files.  */\n\n";
 535
 536   foreach $fct (keys %results) {
 537     $type = $results{$fct}{'type'};
 538     if ($type eq 'normal') {
 539       $ulp = get_all_ulps_for_test ($fct, 'normal');
 540     } elsif ($type eq 'complex') {
 541       $ulp_real = get_all_ulps_for_test ($fct, 'real');
 542       $ulp_imag = get_all_ulps_for_test ($fct, 'imag');
 543     } else {
 544       die "unknown results ($fct) type $type\n";
 545     }
 546     if ($results{$fct}{'kind'} eq 'fct') {
 547       if ($type eq 'normal') {
 548         $func_ulps{$fct} = $ulp;
 549       } else {
 550         $func_real_ulps{$fct} = $ulp_real;
 551         $func_imag_ulps{$fct} = $ulp_imag;
 552       }
 553     } elsif ($results{$fct}{'kind'} eq 'test') {
 554       if ($type eq 'normal') {
 555         $test_ulps{$fct} = $ulp;
 556       } else {
 557         $test_ulps{"Real part of: $fct"} = $ulp_real;
 558         $test_ulps{"Imaginary part of: $fct"} = $ulp_imag;
 559       }
 560     } else {
 561       die "unknown results ($fct) kind $results{$fct}{'kind'}\n";
 562     }
 563   }
 564   print ULP "\n/* Maximal error of functions.  */\n";
 565   print ULP "static const struct ulp_data func_ulps[] =\n  {\n";
 566   foreach $fct (sort keys %func_ulps) {
 567     print ULP "    { \"$fct\", $func_ulps{$fct} },\n";
 568   }
 569   print ULP "  };\n";
 570   print ULP "static const struct ulp_data func_real_ulps[] =\n  {\n";
 571   foreach $fct (sort keys %func_real_ulps) {
 572     print ULP "    { \"$fct\", $func_real_ulps{$fct} },\n";
 573   }
 574   print ULP "  };\n";
 575   print ULP "static const struct ulp_data func_imag_ulps[] =\n  {\n";
 576   foreach $fct (sort keys %func_imag_ulps) {
 577     print ULP "    { \"$fct\", $func_imag_ulps{$fct} },\n";
 578   }
 579   print ULP "  };\n";
 580
 581   print ULP "\n/* Error of single function calls.  */\n";
 582   print ULP "static const struct ulp_data test_ulps[] =\n  {\n";
 583   foreach $fct (sort keys %test_ulps) {
 584     print ULP "    { \"$fct\", $test_ulps{$fct} },\n";
 585   }
 586   print ULP "  };\n";
 587   close ULP;
 588 }