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