mono/profiler/ptestrunner.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 # run the log profiler test suite
   6
   7 my $builddir = shift || die "Usage: ptestrunner.pl mono_build_dir\n";
   8 my @errors = ();
   9 my $total_errors = 0; # this is reset before each test
  10 my $global_errors = 0;
  11 my $report;
  12
  13 my $profbuilddir = $builddir . "/mono/profiler";
  14 my $minibuilddir = $builddir . "/mono/mini";
  15
  16 # Setup the execution environment
  17 # for the profiler module
  18 append_path ("LD_LIBRARY_PATH", $profbuilddir . "/.libs");
  19 append_path ("DYLD_LIBRARY_PATH", $profbuilddir . "/.libs");
  20 append_path ("DYLD_LIBRARY_PATH", $minibuilddir . "/.libs");
  21 # for mprof-report
  22 append_path ("PATH", $profbuilddir);
  23
  24 # first a basic test
  25 $report = run_test ("test-alloc.exe");
  26 check_report_basics ($report);
  27 check_report_calls ($report, "T:Main (string[])" => 1);
  28 check_report_allocation ($report, "System.Object" => 1000000);
  29 report_errors ();
  30 # test additional named threads and method calls
  31 $report = run_test ("test-busy.exe");
  32 check_report_basics ($report);
  33 check_report_calls ($report, "T:Main (string[])" => 1);
  34 check_report_threads ($report, "BusyHelper");
  35 check_report_calls ($report, "T:test ()" => 10, "T:test3 ()" => 10, "T:test2 ()" => 1);
  36 report_errors ();
  37 # test with the sampling profiler
  38 $report = run_test ("test-busy.exe", "report,sample");
  39 check_report_basics ($report);
  40 check_report_threads ($report, "BusyHelper");
  41 # at least 40% of the samples should hit each of the two busy methods
  42 # This seems to fail on osx, where the main thread gets the majority of SIGPROF signals
  43 #check_report_samples ($report, "T:test ()" => 40, "T:test3 ()" => 40);
  44 report_errors ();
  45 # test lock events
  46 $report = run_test ("test-monitor.exe");
  47 check_report_basics ($report);
  48 check_report_calls ($report, "T:Main (string[])" => 1);
  49 # we hope for at least some contention, this is not entirely reliable
  50 check_report_locks ($report, 1, 1);
  51 report_errors ();
  52 # test exceptions
  53 $report = run_test ("test-excleave.exe");
  54 check_report_basics ($report);
  55 check_report_calls ($report, "T:Main (string[])" => 1, "T:throw_ex ()" => 1000);
  56 check_report_exceptions ($report, 1000, 1000, 1000);
  57 report_errors ();
  58 # test heapshot
  59 $report = run_test_sgen ("test-heapshot.exe", "report,heapshot");
  60 if ($report ne "missing binary") {
  61         check_report_basics ($report);
  62         check_report_heapshot ($report, 0, {"T" => 5000});
  63         check_report_heapshot ($report, 1, {"T" => 5023});
  64         report_errors ();
  65 }
  66 # test heapshot traces
  67 $report = run_test_sgen ("test-heapshot.exe", "heapshot,output=-traces.mlpd", "--traces traces.mlpd");
  68 if ($report ne "missing binary") {
  69         check_report_basics ($report);
  70         check_report_heapshot ($report, 0, {"T" => 5000});
  71         check_report_heapshot ($report, 1, {"T" => 5023});
  72         check_heapshot_traces ($report, 0,
  73                 T => [4999, "T"]
  74         );
  75         check_heapshot_traces ($report, 1,
  76                 T => [5022, "T"]
  77         );
  78         report_errors ();
  79 }
  80 # test traces
  81 $report = run_test ("test-traces.exe", "output=-traces.mlpd", "--traces traces.mlpd");
  82 check_report_basics ($report);
  83 check_call_traces ($report,
  84         "T:level3 (int)" => [2020, "T:Main (string[])"],
  85         "T:level2 (int)" => [2020, "T:Main (string[])", "T:level3 (int)"],
  86         "T:level1 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)"],
  87         "T:level0 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)"]
  88 );
  89 check_exception_traces ($report,
  90         [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
  91 );
  92 check_alloc_traces ($report,
  93         T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
  94 );
  95 report_errors ();
  96 # test traces without enter/leave events
  97 $report = run_test ("test-traces.exe", "nocalls,output=-traces.mlpd", "--traces traces.mlpd");
  98 check_report_basics ($report);
  99 # this has been broken recently
 100 check_exception_traces ($report,
 101         [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
 102 );
 103 check_alloc_traces ($report,
 104         T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
 105 );
 106 report_errors ();
 107
 108 emit_nunit_report();
 109
 110 exit ($global_errors ? 1 : 0);
 111
 112 # utility functions
 113 sub append_path {
 114         my $var = shift;
 115         my $value = shift;
 116         if (exists $ENV{$var}) {
 117                 $ENV{$var} = $value . ":" . $ENV{$var};
 118         } else {
 119                 $ENV{$var} = $value;
 120         }
 121 }
 122
 123 sub run_test
 124 {
 125         return run_test_bin ("$minibuilddir/mono", @_);
 126 }
 127
 128 sub run_test_sgen
 129 {
 130         return run_test_bin ("$minibuilddir/mono-sgen", @_);
 131 }
 132
 133 sub run_test_bin
 134 {
 135         my $bin = shift;
 136         my $test_name = shift;
 137         my $option = shift || "report";
 138         my $roptions = shift;
 139         #clear the errors
 140         @errors = ();
 141         $total_errors = 0;
 142         print "Checking $test_name with $option ...";
 143         unless (-x $bin) {
 144                 print "missing $bin, skipped.\n";
 145                 return "missing binary";
 146         }
 147         my $report = `$bin --profile=log:$option $test_name`;
 148         print "\n";
 149         if (defined $roptions) {
 150                 return `$profbuilddir/mprof-report $roptions`;
 151         }
 152         return $report;
 153 }
 154
 155 sub report_errors
 156 {
 157         foreach my $e (@errors) {
 158                 print "Error: $e\n";
 159                 $total_errors++;
 160                 $global_errors++;
 161         }
 162         print "Total errors: $total_errors\n" if $total_errors;
 163         #print $report;
 164 }
 165
 166 sub emit_nunit_report
 167 {
 168         use Cwd;
 169         use POSIX qw(strftime uname locale_h);
 170         use Net::Domain qw(hostname hostfqdn);
 171         use locale;
 172
 173         my $failed = $global_errors ? 1 : 0;
 174         my $successbool;
 175         my $total = 1;
 176         my $mylocale = setlocale (LC_CTYPE);
 177         $mylocale = substr($mylocale, 0, index($mylocale, '.'));
 178         $mylocale =~ s/_/-/;
 179
 180         if ($failed > 0) {
 181                 $successbool = "False";
 182         } else {
 183                 $successbool = "True";
 184         }
 185         open (my $nunitxml, '>', 'TestResult-profiler.xml') or die "Could not write to 'TestResult-profiler.xml' $!";
 186         print $nunitxml "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>\n";
 187         print $nunitxml "<!--This file represents the results of running a test suite-->\n";
 188         print $nunitxml "<test-results name=\"profiler-tests.dummy\" total=\"$total\" failures=\"$failed\" not-run=\"0\" date=\"" . strftime ("%F", localtime) . "\" time=\"" . strftime ("%T", localtime) . "\">\n";
 189         print $nunitxml "  <environment nunit-version=\"2.4.8.0\" clr-version=\"4.0.30319.17020\" os-version=\"Unix " . (uname ())[2]  . "\" platform=\"Unix\" cwd=\"" . getcwd . "\" machine-name=\"" . hostname . "\" user=\"" . getpwuid ($<) . "\" user-domain=\"" . hostfqdn  . "\" />\n";
 190         print $nunitxml "  <culture-info current-culture=\"$mylocale\" current-uiculture=\"$mylocale\" />\n";
 191         print $nunitxml "  <test-suite name=\"profiler-tests.dummy\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
 192         print $nunitxml "    <results>\n";
 193         print $nunitxml "      <test-suite name=\"MonoTests\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
 194         print $nunitxml "        <results>\n";
 195         print $nunitxml "          <test-suite name=\"profiler\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
 196         print $nunitxml "            <results>\n";
 197         print $nunitxml "              <test-case name=\"MonoTests.profiler.100percentsuccess\" executed=\"True\" success=\"$successbool\" time=\"0\" asserts=\"0\"";
 198         if ( $failed > 0) {
 199         print $nunitxml ">\n";
 200         print $nunitxml "                <failure>\n";
 201         print $nunitxml "                  <message><![CDATA[";
 202         print $nunitxml "The profiler tests returned an error. Check the log for more details.";
 203         print $nunitxml "]]></message>\n";
 204         print $nunitxml "                  <stack-trace>\n";
 205         print $nunitxml "                  </stack-trace>\n";
 206         print $nunitxml "                </failure>\n";
 207         print $nunitxml "              </test-case>\n";
 208         } else {
 209         print $nunitxml " />\n";
 210         }
 211         print $nunitxml "            </results>\n";
 212         print $nunitxml "          </test-suite>\n";
 213         print $nunitxml "        </results>\n";
 214         print $nunitxml "      </test-suite>\n";
 215         print $nunitxml "    </results>\n";
 216         print $nunitxml "  </test-suite>\n";
 217         print $nunitxml "</test-results>\n";
 218         close $nunitxml;
 219 }
 220
 221 sub get_delim_data
 222 {
 223         my $report = shift;
 224         my $start = shift;
 225         my $end = shift;
 226         my $section = "";
 227         my $insection = 0;
 228         foreach (split (/\n/, $report)) {
 229                 if ($insection) {
 230                         #print "matching end $end vs $_\n";
 231                         last if /$end/;
 232                         $section .= $_;
 233                         $section .= "\n";
 234                 } else {
 235                         #print "matching $start vs $_\n";
 236                         $insection = 1 if (/$start/);
 237                 }
 238         }
 239         return $section;
 240 }
 241
 242 sub get_section
 243 {
 244         my $report = shift;
 245         my $name = shift;
 246         return get_delim_data ($report, "^\Q$name\E", "^\\w.*summary");
 247 }
 248
 249 sub get_heap_shot
 250 {
 251         my $section = shift;
 252         my $num = shift;
 253         return get_delim_data ($report, "Heap shot $num at", "^\$");
 254 }
 255
 256 sub check_report_basics
 257 {
 258         my $report = shift;
 259         check_report_threads ($report, "Finalizer", "Main");
 260         check_report_metadata ($report, 2);
 261         check_report_jit ($report);
 262 }
 263
 264 sub check_report_metadata
 265 {
 266         my $report = shift;
 267         my $num = shift;
 268         my $section = get_section ($report, "Metadata");
 269         push @errors, "Wrong loaded images $num." unless $section =~ /Loaded images:\s$num/s;
 270 }
 271
 272 sub check_report_calls
 273 {
 274         my $report = shift;
 275         my %calls = @_;
 276         my $section = get_section ($report, "Method");
 277         foreach my $method (keys %calls) {
 278                 push @errors, "Wrong calls to $method." unless $section =~ /\d+\s+\d+\s+($calls{$method})\s+\Q$method\E/s;
 279         }
 280 }
 281
 282 sub check_call_traces
 283 {
 284         my $report = shift;
 285         my %calls = @_;
 286         my $section = get_section ($report, "Method");
 287         foreach my $method (keys %calls) {
 288                 my @desc = @{$calls{$method}};
 289                 my $num = shift @desc;
 290                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$method\E", "^(\\s*\\d+\\s+\\d)|(^Total calls)");
 291                 if ($trace =~ s/^\s+(\d+)\s+calls from:$//m) {
 292                         my $num_calls = $1;
 293                         push @errors, "Wrong calls to $method." unless $num_calls == $num;
 294                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 295                         while (@desc) {
 296                                 my $dm = pop @desc;
 297                                 my $fm = pop @frames;
 298                                 push @errors, "Wrong frame $fm to $method." unless $dm eq $fm;
 299                         }
 300                 } else {
 301                         push @errors, "No num calls for $method.";
 302                 }
 303         }
 304 }
 305
 306 sub check_alloc_traces
 307 {
 308         my $report = shift;
 309         my %types = @_;
 310         my $section = get_section ($report, "Allocation");
 311         foreach my $type (keys %types) {
 312                 my @desc = @{$types{$type}};
 313                 my $num = shift @desc;
 314                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^(\\s*\\d+\\s+\\d)|(^Total)");
 315                 if ($trace =~ s/^\s+(\d+)\s+bytes from:$//m) {
 316                         #my $num_calls = $1;
 317                         #push @errors, "Wrong calls to $method." unless $num_calls == $num;
 318                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 319                         while (@desc) {
 320                                 my $dm = pop @desc;
 321                                 my $fm = pop @frames;
 322                                 $fm = pop @frames if $fm =~ /wrapper/;
 323                                 push @errors, "Wrong frame $fm for alloc of $type." unless $dm eq $fm;
 324                         }
 325                 } else {
 326                         push @errors, "No alloc frames for $type.";
 327                 }
 328         }
 329 }
 330
 331 sub check_heapshot_traces
 332 {
 333         my $report = shift;
 334         my $hshot = shift;
 335         my %types = @_;
 336         my $section = get_section ($report, "Heap");
 337         $section = get_heap_shot ($section, $hshot);
 338         foreach my $type (keys %types) {
 339                 my @desc = @{$types{$type}};
 340                 my $num = shift @desc;
 341                 my $rtype = shift @desc;
 342                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^\\s*\\d+\\s+\\d");
 343                 if ($trace =~ s/^\s+(\d+)\s+references from:\s+\Q$rtype\E$//m) {
 344                         my $num_refs = $1;
 345                         push @errors, "Wrong num refs to $type from $rtype." unless $num_refs == $num;
 346                 } else {
 347                         push @errors, "No refs to $type from $rtype.";
 348                 }
 349         }
 350 }
 351
 352 sub check_exception_traces
 353 {
 354         my $report = shift;
 355         my @etraces = @_;
 356         my $section = get_section ($report, "Exception");
 357         foreach my $d (@etraces) {
 358                 my @desc = @{$d};
 359                 my $num = shift @desc;
 360                 my $trace = get_delim_data ($section, "^\\s+$num\\s+throws from:\$", "^\\s+(\\d+|Executed)");
 361                 if (length ($trace)) {
 362                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 363                         while (@desc) {
 364                                 my $dm = pop @desc;
 365                                 my $fm = pop @frames;
 366                                 push @errors, "Wrong frame '$fm' in exceptions (should be '$dm')." unless $dm eq $fm;
 367                         }
 368                 } else {
 369                         push @errors, "No exceptions or incorrect number.";
 370                 }
 371         }
 372 }
 373
 374 sub check_report_samples
 375 {
 376         my $report = shift;
 377         my %calls = @_;
 378         my $section = get_section ($report, "Statistical");
 379         foreach my $method (keys %calls) {
 380                 push @errors, "Wrong samples for $method." unless ($section =~ /\d+\s+(\d+\.\d+)\s+\Q$method\E/s && $1 >= $calls{$method});
 381         }
 382 }
 383
 384 sub check_report_allocation
 385 {
 386         my $report = shift;
 387         my %allocs = @_;
 388         my $section = get_section ($report, "Allocation");
 389         foreach my $type (keys %allocs) {
 390                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E$/m) {
 391                         push @errors, "Wrong allocs for type $type." unless $1 >= $allocs{$type};
 392                 } else {
 393                         push @errors, "No allocs for type $type.";
 394                 }
 395         }
 396 }
 397
 398 sub check_report_heapshot
 399 {
 400         my $report = shift;
 401         my $hshot = shift;
 402         my $typemap = shift;
 403         my %allocs = %{$typemap};
 404         my $section = get_section ($report, "Heap");
 405         $section = get_heap_shot ($section, $hshot);
 406         foreach my $type (keys %allocs) {
 407                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E(\s+\(bytes.*\))?$/m) {
 408                         push @errors, "Wrong heapshot for type $type at $hshot ($1, $allocs{$type})." unless $1 >= $allocs{$type};
 409                 } else {
 410                         push @errors, "No heapshot for type $type at heapshot $hshot.";
 411                 }
 412         }
 413 }
 414
 415 sub check_report_jit
 416 {
 417         my $report = shift;
 418         my $min_methods = shift || 1;
 419         my $min_code = shift || 16;
 420         my $section = get_section ($report, "JIT");
 421         push @errors, "Not enough compiled method." unless (($section =~ /Compiled methods:\s(\d+)/s) && ($1 >= $min_methods));
 422         push @errors, "Not enough compiled code." unless (($section =~ /Generated code size:\s(\d+)/s) && ($1 >= $min_code));
 423 }
 424
 425 sub check_report_locks
 426 {
 427         my $report = shift;
 428         my $contentions = shift;
 429         my $acquired = shift;
 430         my $section = get_section ($report, "Monitor");
 431         push @errors, "Not enough contentions." unless (($section =~ /Lock contentions:\s(\d+)/s) && ($1 >= $contentions));
 432         push @errors, "Not enough acquired locks." unless (($section =~ /Lock acquired:\s(\d+)/s) && ($1 >= $acquired));
 433 }
 434
 435 sub check_report_exceptions
 436 {
 437         my $report = shift;
 438         my $throws = shift;
 439         my $catches = shift;
 440         my $finallies = shift;
 441         my $section = get_section ($report, "Exception");
 442         push @errors, "Not enough throws." unless (($section =~ /Throws:\s(\d+)/s) && ($1 >= $throws));
 443         push @errors, "Not enough catches." unless (($section =~ /Executed catch clauses:\s(\d+)/s) && ($1 >= $catches));
 444         push @errors, "Not enough finallies." unless (($section =~ /Executed finally clauses:\s(\d+)/s) && ($1 >= $finallies));
 445 }
 446
 447 sub check_report_threads
 448 {
 449         my $report = shift;
 450         my @threads = @_;
 451         my $section = get_section ($report, "Thread");
 452         foreach my $tname (@threads) {
 453                 push @errors, "Missing thread $tname." unless $section =~ /Thread:.*name:\s"\Q$tname\E"/s;
 454         }
 455 }
 456