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 ("DYLD_LIBRARY_PATH", $minibuilddir . "/.libs");
  19 # for mprof-report
  20 append_path ("PATH", $profbuilddir);
  21
  22 # first a basic test
  23 $report = run_test ("test-alloc.exe", "report,legacy,calls,alloc");
  24 check_report_basics ($report);
  25 check_report_calls ($report, "T:Main (string[])" => 1);
  26 check_report_allocation ($report, "System.Object" => 1000000);
  27 report_errors ();
  28 # test additional named threads and method calls
  29 $report = run_test ("test-busy.exe", "report,legacy,calls,alloc");
  30 check_report_basics ($report);
  31 check_report_calls ($report, "T:Main (string[])" => 1);
  32 check_report_threads ($report, "BusyHelper");
  33 check_report_calls ($report, "T:test ()" => 10, "T:test3 ()" => 10, "T:test2 ()" => 1);
  34 report_errors ();
  35 # test with the sampling profiler
  36 $report = run_test ("test-busy.exe", "report,legacy,sample");
  37 check_report_basics ($report);
  38 check_report_threads ($report, "BusyHelper");
  39 # at least 40% of the samples should hit each of the two busy methods
  40 # This seems to fail on osx, where the main thread gets the majority of SIGPROF signals
  41 #check_report_samples ($report, "T:test ()" => 40, "T:test3 ()" => 40);
  42 report_errors ();
  43 # test lock events
  44 $report = run_test ("test-monitor.exe", "report,legacy,calls,alloc");
  45 check_report_basics ($report);
  46 check_report_calls ($report, "T:Main (string[])" => 1);
  47 # we hope for at least some contention, this is not entirely reliable
  48 check_report_locks ($report, 1, 1);
  49 report_errors ();
  50 # test exceptions
  51 $report = run_test ("test-excleave.exe", "report,legacy,calls");
  52 check_report_basics ($report);
  53 check_report_calls ($report, "T:Main (string[])" => 1, "T:throw_ex ()" => 1000);
  54 check_report_exceptions ($report, 1000, 1000, 1000);
  55 report_errors ();
  56 # test heapshot
  57 $report = run_test_sgen ("test-heapshot.exe", "report,heapshot,legacy");
  58 if ($report ne "missing binary") {
  59         check_report_basics ($report);
  60         check_report_heapshot ($report, 0, {"T" => 5000});
  61         check_report_heapshot ($report, 1, {"T" => 5023});
  62         report_errors ();
  63 }
  64 # test heapshot traces
  65 $report = run_test_sgen ("test-heapshot.exe", "heapshot,output=traces.mlpd,legacy", "--traces traces.mlpd");
  66 if ($report ne "missing binary") {
  67         check_report_basics ($report);
  68         check_report_heapshot ($report, 0, {"T" => 5000});
  69         check_report_heapshot ($report, 1, {"T" => 5023});
  70         check_heapshot_traces ($report, 0,
  71                 T => [4999, "T"]
  72         );
  73         check_heapshot_traces ($report, 1,
  74                 T => [5022, "T"]
  75         );
  76         report_errors ();
  77 }
  78 # test traces
  79 $report = run_test ("test-traces.exe", "legacy,calls,alloc,output=traces.mlpd", "--maxframes=7 --traces traces.mlpd");
  80 check_report_basics ($report);
  81 check_call_traces ($report,
  82         "T:level3 (int)" => [2020, "T:Main (string[])"],
  83         "T:level2 (int)" => [2020, "T:Main (string[])", "T:level3 (int)"],
  84         "T:level1 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)"],
  85         "T:level0 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)"]
  86 );
  87 check_exception_traces ($report,
  88         [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
  89 );
  90 check_alloc_traces ($report,
  91         T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
  92 );
  93 report_errors ();
  94 # test traces without enter/leave events
  95 $report = run_test ("test-traces.exe", "legacy,alloc,output=traces.mlpd", "--traces traces.mlpd");
  96 check_report_basics ($report);
  97 # this has been broken recently
  98 check_exception_traces ($report,
  99         [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
 100 );
 101 check_alloc_traces ($report,
 102         T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
 103 );
 104 report_errors ();
 105
 106 emit_nunit_report();
 107
 108 exit ($global_errors ? 1 : 0);
 109
 110 # utility functions
 111 sub append_path {
 112         my $var = shift;
 113         my $value = shift;
 114         if (exists $ENV{$var}) {
 115                 $ENV{$var} = $value . ":" . $ENV{$var};
 116         } else {
 117                 $ENV{$var} = $value;
 118         }
 119 }
 120
 121 sub run_test
 122 {
 123         return run_test_bin ("$minibuilddir/mono", @_);
 124 }
 125
 126 sub run_test_sgen
 127 {
 128         return run_test_bin ("$minibuilddir/mono-sgen", @_);
 129 }
 130
 131 sub run_test_bin
 132 {
 133         my $bin = shift;
 134         my $test_name = shift;
 135         my $option = shift || "report";
 136         my $roptions = shift;
 137         #clear the errors
 138         @errors = ();
 139         $total_errors = 0;
 140         print "Checking $test_name with $option ...";
 141         unless (-x $bin) {
 142                 print "missing $bin, skipped.\n";
 143                 return "missing binary";
 144         }
 145         my $report = `$bin --profile=log:$option $test_name`;
 146         print "\n";
 147         if (defined $roptions) {
 148                 return `$profbuilddir/mprof-report $roptions`;
 149         }
 150         return $report;
 151 }
 152
 153 sub report_errors
 154 {
 155         foreach my $e (@errors) {
 156                 print "Error: $e\n";
 157                 $total_errors++;
 158                 $global_errors++;
 159         }
 160         print "Total errors: $total_errors\n" if $total_errors;
 161         #print $report;
 162 }
 163
 164 sub emit_nunit_report
 165 {
 166         use Cwd;
 167         use POSIX qw(strftime uname locale_h);
 168         use Net::Domain qw(hostname hostfqdn);
 169         use locale;
 170
 171         my $failed = $global_errors ? 1 : 0;
 172         my $successbool;
 173         my $total = 1;
 174         my $mylocale = setlocale (LC_CTYPE);
 175         $mylocale = substr($mylocale, 0, index($mylocale, '.'));
 176         $mylocale =~ s/_/-/;
 177
 178         if ($failed > 0) {
 179                 $successbool = "False";
 180         } else {
 181                 $successbool = "True";
 182         }
 183         open (my $nunitxml, '>', 'TestResult-profiler.xml') or die "Could not write to 'TestResult-profiler.xml' $!";
 184         print $nunitxml "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>\n";
 185         print $nunitxml "<!--This file represents the results of running a test suite-->\n";
 186         print $nunitxml "<test-results name=\"profiler-tests.dummy\" total=\"$total\" failures=\"$failed\" not-run=\"0\" date=\"" . strftime ("%F", localtime) . "\" time=\"" . strftime ("%T", localtime) . "\">\n";
 187         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";
 188         print $nunitxml "  <culture-info current-culture=\"$mylocale\" current-uiculture=\"$mylocale\" />\n";
 189         print $nunitxml "  <test-suite name=\"profiler-tests.dummy\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
 190         print $nunitxml "    <results>\n";
 191         print $nunitxml "      <test-suite name=\"MonoTests\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
 192         print $nunitxml "        <results>\n";
 193         print $nunitxml "          <test-suite name=\"profiler\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
 194         print $nunitxml "            <results>\n";
 195         print $nunitxml "              <test-case name=\"MonoTests.profiler.100percentsuccess\" executed=\"True\" success=\"$successbool\" time=\"0\" asserts=\"0\"";
 196         if ( $failed > 0) {
 197         print $nunitxml ">\n";
 198         print $nunitxml "                <failure>\n";
 199         print $nunitxml "                  <message><![CDATA[";
 200         print $nunitxml "The profiler tests returned an error. Check the log for more details.";
 201         print $nunitxml "]]></message>\n";
 202         print $nunitxml "                  <stack-trace>\n";
 203         print $nunitxml "                  </stack-trace>\n";
 204         print $nunitxml "                </failure>\n";
 205         print $nunitxml "              </test-case>\n";
 206         } else {
 207         print $nunitxml " />\n";
 208         }
 209         print $nunitxml "            </results>\n";
 210         print $nunitxml "          </test-suite>\n";
 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 "</test-results>\n";
 216         close $nunitxml;
 217 }
 218
 219 sub get_delim_data
 220 {
 221         my $report = shift;
 222         my $start = shift;
 223         my $end = shift;
 224         my $section = "";
 225         my $insection = 0;
 226         foreach (split (/\n/, $report)) {
 227                 if ($insection) {
 228                         #print "matching end $end vs $_\n";
 229                         last if /$end/;
 230                         $section .= $_;
 231                         $section .= "\n";
 232                 } else {
 233                         #print "matching $start vs $_\n";
 234                         $insection = 1 if (/$start/);
 235                 }
 236         }
 237         return $section;
 238 }
 239
 240 sub get_section
 241 {
 242         my $report = shift;
 243         my $name = shift;
 244         return get_delim_data ($report, "^\Q$name\E", "^\\w.*summary");
 245 }
 246
 247 sub get_heap_shot
 248 {
 249         my $section = shift;
 250         my $num = shift;
 251         return get_delim_data ($report, "Heap shot $num at", "^\$");
 252 }
 253
 254 sub check_report_basics
 255 {
 256         my $report = shift;
 257         check_report_threads ($report, "Finalizer", "Main");
 258         check_report_metadata ($report, 2);
 259         check_report_jit ($report);
 260 }
 261
 262 sub check_report_metadata
 263 {
 264         my $report = shift;
 265         my $num = shift;
 266         my $section = get_section ($report, "Metadata");
 267         push @errors, "Wrong loaded images $num." unless $section =~ /Loaded images:\s$num/s;
 268 }
 269
 270 sub check_report_calls
 271 {
 272         my $report = shift;
 273         my %calls = @_;
 274         my $section = get_section ($report, "Method");
 275         foreach my $method (keys %calls) {
 276                 push @errors, "Wrong calls to $method." unless $section =~ /\d+\s+\d+\s+($calls{$method})\s+\Q$method\E/s;
 277         }
 278 }
 279
 280 sub check_call_traces
 281 {
 282         my $report = shift;
 283         my %calls = @_;
 284         my $section = get_section ($report, "Method");
 285         foreach my $method (keys %calls) {
 286                 my @desc = @{$calls{$method}};
 287                 my $num = shift @desc;
 288                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$method\E", "^(\\s*\\d+\\s+\\d)|(^Total calls)");
 289                 if ($trace =~ s/^\s+(\d+)\s+calls from:$//m) {
 290                         my $num_calls = $1;
 291                         push @errors, "Wrong calls to $method." unless $num_calls == $num;
 292                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 293                         while (@desc) {
 294                                 my $dm = pop @desc;
 295                                 my $fm = pop @frames;
 296                                 push @errors, "Wrong frame $fm to $method." unless $dm eq $fm;
 297                         }
 298                 } else {
 299                         push @errors, "No num calls for $method.";
 300                 }
 301         }
 302 }
 303
 304 sub check_alloc_traces
 305 {
 306         my $report = shift;
 307         my %types = @_;
 308         my $section = get_section ($report, "Allocation");
 309         foreach my $type (keys %types) {
 310                 my @desc = @{$types{$type}};
 311                 my $num = shift @desc;
 312                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^(\\s*\\d+\\s+\\d)|(^Total)");
 313                 if ($trace =~ s/^\s+(\d+)\s+bytes from:$//m) {
 314                         #my $num_calls = $1;
 315                         #push @errors, "Wrong calls to $method." unless $num_calls == $num;
 316                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 317                         while (@desc) {
 318                                 my $dm = pop @desc;
 319                                 my $fm = pop @frames;
 320                                 while ($fm =~ /wrapper/) {
 321                                         $fm = pop @frames;
 322                                 }
 323                                 push @errors, "Wrong frame $fm for alloc of $type (expected $dm)." 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