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     # START_DATA (function)
 304     if (/START_DATA/) {
 305       next;
 306     }
 307     # END_DATA (function)
 308     if (/END_DATA/) {
 309       next;
 310     }
 311     print OUTPUT;
 312   }
 313   close INPUT;
 314   close OUTPUT;
 315 }
 316
 317
 318
 319 # Parse ulps file
 320 sub parse_ulps {
 321   my ($file) = @_;
 322   my ($test, $type, $float, $eps, $kind);
 323
 324   # $type has the following values:
 325   # "normal": No complex variable
 326   # "real": Real part of complex result
 327   # "imag": Imaginary part of complex result
 328   open ULP, $file  or die ("Can't open $file: $!");
 329   while (<ULP>) {
 330     chop;
 331     # ignore comments and empty lines
 332     next if /^#/;
 333     next if /^\s*$/;
 334     if (/^Test/) {
 335       if (/Real part of:/) {
 336         s/Real part of: //;
 337         $type = 'real';
 338       } elsif (/Imaginary part of:/) {
 339         s/Imaginary part of: //;
 340         $type = 'imag';
 341       } else {
 342         $type = 'normal';
 343       }
 344       s/^.+\"(.*)\".*$/$1/;
 345       $test = $_;
 346       $kind = 'test';
 347       next;
 348     }
 349     if (/^Function: /) {
 350       if (/Real part of/) {
 351         s/Real part of //;
 352         $type = 'real';
 353       } elsif (/Imaginary part of/) {
 354         s/Imaginary part of //;
 355         $type = 'imag';
 356       } else {
 357         $type = 'normal';
 358       }
 359       ($test) = ($_ =~ /^Function:\s*\"([a-zA-Z0-9_]+)\"/);
 360       $kind = 'fct';
 361       next;
 362     }
 363     if (/^i?(float|double|ldouble):/) {
 364       ($float, $eps) = split /\s*:\s*/,$_,2;
 365
 366       if ($eps eq "0") {
 367         # ignore
 368         next;
 369       } else {
 370         $results{$test}{$type}{'ulp'}{$float} = $eps;
 371         $results{$test}{'has_ulps'} = 1;
 372       }
 373       if ($type =~ /^real|imag$/) {
 374         $results{$test}{'type'} = 'complex';
 375       } elsif ($type eq 'normal') {
 376         $results{$test}{'type'} = 'normal';
 377       }
 378       $results{$test}{'kind'} = $kind;
 379       next;
 380     }
 381     print "Skipping unknown entry: `$_'\n";
 382   }
 383   close ULP;
 384 }
 385
 386
 387 # Clean up a floating point number
 388 sub clean_up_number {
 389   my ($number) = @_;
 390
 391   # Remove trailing zeros after the decimal point
 392   if ($number =~ /\./) {
 393     $number =~ s/0+$//;
 394     $number =~ s/\.$//;
 395   }
 396   return $number;
 397 }
 398
 399 # Output a file which can be read in as ulps file.
 400 sub print_ulps_file {
 401   my ($file) = @_;
 402   my ($test, $type, $float, $eps, $fct, $last_fct);
 403
 404   $last_fct = '';
 405   open NEWULP, ">$file" or die ("Can't open $file: $!");
 406   print NEWULP "# Begin of automatic generation\n";
 407   # first the function calls
 408   foreach $test (sort keys %results) {
 409     next if ($results{$test}{'kind'} ne 'test');
 410     foreach $type ('real', 'imag', 'normal') {
 411       if (exists $results{$test}{$type}) {
 412         if (defined $results{$test}) {
 413           ($fct) = ($test =~ /^(\w+)\s/);
 414           if ($fct ne $last_fct) {
 415             $last_fct = $fct;
 416             print NEWULP "\n# $fct\n";
 417           }
 418         }
 419         if ($type eq 'normal') {
 420           print NEWULP "Test \"$test\":\n";
 421         } elsif ($type eq 'real') {
 422           print NEWULP "Test \"Real part of: $test\":\n";
 423         } elsif ($type eq 'imag') {
 424           print NEWULP "Test \"Imaginary part of: $test\":\n";
 425         }
 426         foreach $float (@all_floats) {
 427           if (exists $results{$test}{$type}{'ulp'}{$float}) {
 428             print NEWULP "$float: ",
 429             &clean_up_number ($results{$test}{$type}{'ulp'}{$float}),
 430             "\n";
 431           }
 432         }
 433       }
 434     }
 435   }
 436   print NEWULP "\n# Maximal error of functions:\n";
 437
 438   foreach $fct (sort keys %results) {
 439     next if ($results{$fct}{'kind'} ne 'fct');
 440     foreach $type ('real', 'imag', 'normal') {
 441       if (exists $results{$fct}{$type}) {
 442         if ($type eq 'normal') {
 443           print NEWULP "Function: \"$fct\":\n";
 444         } elsif ($type eq 'real') {
 445           print NEWULP "Function: Real part of \"$fct\":\n";
 446         } elsif ($type eq 'imag') {
 447           print NEWULP "Function: Imaginary part of \"$fct\":\n";
 448         }
 449         foreach $float (@all_floats) {
 450           if (exists $results{$fct}{$type}{'ulp'}{$float}) {
 451             print NEWULP "$float: ",
 452             &clean_up_number ($results{$fct}{$type}{'ulp'}{$float}),
 453             "\n";
 454           }
 455         }
 456         print NEWULP "\n";
 457       }
 458     }
 459   }
 460   print NEWULP "# end of automatic generation\n";
 461   close NEWULP;
 462 }
 463
 464 sub get_ulps {
 465   my ($test, $type, $float) = @_;
 466
 467   return (exists $results{$test}{$type}{'ulp'}{$float}
 468           ? $results{$test}{$type}{'ulp'}{$float} : "0");
 469 }
 470
 471 # Return the ulps value for a single test.
 472 sub get_all_ulps_for_test {
 473   my ($test, $type) = @_;
 474   my ($ldouble, $double, $float, $ildouble, $idouble, $ifloat);
 475
 476   if (exists $results{$test}{'has_ulps'}) {
 477     # XXX use all_floats (change order!)
 478     $ldouble = &get_ulps ($test, $type, "ldouble");
 479     $double = &get_ulps ($test, $type, "double");
 480     $float = &get_ulps ($test, $type, "float");
 481     $ildouble = &get_ulps ($test, $type, "ildouble");
 482     $idouble = &get_ulps ($test, $type, "idouble");
 483     $ifloat = &get_ulps ($test, $type, "ifloat");
 484     return "CHOOSE ($ldouble, $double, $float, $ildouble, $idouble, $ifloat)";
 485   } else {
 486     die "get_all_ulps_for_test called for \"$test\" with no ulps\n";
 487   }
 488 }
 489
 490 # Print include file
 491 sub output_ulps {
 492   my ($file, $ulps_filename) = @_;
 493   my ($i, $fct, $type, $ulp, $ulp_real, $ulp_imag);
 494   my (%test_ulps, %func_ulps, %func_real_ulps, %func_imag_ulps);
 495
 496   open ULP, ">$file" or die ("Can't open $file: $!");
 497
 498   print ULP "/* This file is automatically generated\n";
 499   print ULP "   from $ulps_filename with gen-libm-test.pl.\n";
 500   print ULP "   Don't change it - change instead the master files.  */\n\n";
 501
 502   foreach $fct (keys %results) {
 503     $type = $results{$fct}{'type'};
 504     if ($type eq 'normal') {
 505       $ulp = get_all_ulps_for_test ($fct, 'normal');
 506     } elsif ($type eq 'complex') {
 507       $ulp_real = get_all_ulps_for_test ($fct, 'real');
 508       $ulp_imag = get_all_ulps_for_test ($fct, 'imag');
 509     } else {
 510       die "unknown results ($fct) type $type\n";
 511     }
 512     if ($results{$fct}{'kind'} eq 'fct') {
 513       if ($type eq 'normal') {
 514         $func_ulps{$fct} = $ulp;
 515       } else {
 516         $func_real_ulps{$fct} = $ulp_real;
 517         $func_imag_ulps{$fct} = $ulp_imag;
 518       }
 519     } elsif ($results{$fct}{'kind'} eq 'test') {
 520       if ($type eq 'normal') {
 521         $test_ulps{$fct} = $ulp;
 522       } else {
 523         $test_ulps{"Real part of: $fct"} = $ulp_real;
 524         $test_ulps{"Imaginary part of: $fct"} = $ulp_imag;
 525       }
 526     } else {
 527       die "unknown results ($fct) kind $results{$fct}{'kind'}\n";
 528     }
 529   }
 530   print ULP "\n/* Maximal error of functions.  */\n";
 531   print ULP "static const struct ulp_data func_ulps[] =\n  {\n";
 532   foreach $fct (sort keys %func_ulps) {
 533     print ULP "    { \"$fct\", $func_ulps{$fct} },\n";
 534   }
 535   print ULP "  };\n";
 536   print ULP "static const struct ulp_data func_real_ulps[] =\n  {\n";
 537   foreach $fct (sort keys %func_real_ulps) {
 538     print ULP "    { \"$fct\", $func_real_ulps{$fct} },\n";
 539   }
 540   print ULP "  };\n";
 541   print ULP "static const struct ulp_data func_imag_ulps[] =\n  {\n";
 542   foreach $fct (sort keys %func_imag_ulps) {
 543     print ULP "    { \"$fct\", $func_imag_ulps{$fct} },\n";
 544   }
 545   print ULP "  };\n";
 546
 547   print ULP "\n/* Error of single function calls.  */\n";
 548   print ULP "static const struct ulp_data test_ulps[] =\n  {\n";
 549   foreach $fct (sort keys %test_ulps) {
 550     print ULP "    { \"$fct\", $test_ulps{$fct} },\n";
 551   }
 552   print ULP "  };\n";
 553   close ULP;
 554 }