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