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", "--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                                 $fm = pop @frames if $fm =~ /wrapper/;
 321                                 push @errors, "Wrong frame $fm for alloc of $type." unless $dm eq $fm;
 322                         }
 323                 } else {
 324                         push @errors, "No alloc frames for $type.";
 325                 }
 326         }
 327 }
 328
 329 sub check_heapshot_traces
 330 {
 331         my $report = shift;
 332         my $hshot = shift;
 333         my %types = @_;
 334         my $section = get_section ($report, "Heap");
 335         $section = get_heap_shot ($section, $hshot);
 336         foreach my $type (keys %types) {
 337                 my @desc = @{$types{$type}};
 338                 my $num = shift @desc;
 339                 my $rtype = shift @desc;
 340                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^\\s*\\d+\\s+\\d");
 341                 if ($trace =~ s/^\s+(\d+)\s+references from:\s+\Q$rtype\E$//m) {
 342                         my $num_refs = $1;
 343                         push @errors, "Wrong num refs to $type from $rtype." unless $num_refs == $num;
 344                 } else {
 345                         push @errors, "No refs to $type from $rtype.";
 346                 }
 347         }
 348 }
 349
 350 sub check_exception_traces
 351 {
 352         my $report = shift;
 353         my @etraces = @_;
 354         my $section = get_section ($report, "Exception");
 355         foreach my $d (@etraces) {
 356                 my @desc = @{$d};
 357                 my $num = shift @desc;
 358                 my $trace = get_delim_data ($section, "^\\s+$num\\s+throws from:\$", "^\\s+(\\d+|Executed)");
 359                 if (length ($trace)) {
 360                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 361                         while (@desc) {
 362                                 my $dm = pop @desc;
 363                                 my $fm = pop @frames;
 364                                 push @errors, "Wrong frame '$fm' in exceptions (should be '$dm')." unless $dm eq $fm;
 365                         }
 366                 } else {
 367                         push @errors, "No exceptions or incorrect number.";
 368                 }
 369         }
 370 }
 371
 372 sub check_report_samples
 373 {
 374         my $report = shift;
 375         my %calls = @_;
 376         my $section = get_section ($report, "Statistical");
 377         foreach my $method (keys %calls) {
 378                 push @errors, "Wrong samples for $method." unless ($section =~ /\d+\s+(\d+\.\d+)\s+\Q$method\E/s && $1 >= $calls{$method});
 379         }
 380 }
 381
 382 sub check_report_allocation
 383 {
 384         my $report = shift;
 385         my %allocs = @_;
 386         my $section = get_section ($report, "Allocation");
 387         foreach my $type (keys %allocs) {
 388                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E$/m) {
 389                         push @errors, "Wrong allocs for type $type." unless $1 >= $allocs{$type};
 390                 } else {
 391                         push @errors, "No allocs for type $type.";
 392                 }
 393         }
 394 }
 395
 396 sub check_report_heapshot
 397 {
 398         my $report = shift;
 399         my $hshot = shift;
 400         my $typemap = shift;
 401         my %allocs = %{$typemap};
 402         my $section = get_section ($report, "Heap");
 403         $section = get_heap_shot ($section, $hshot);
 404         foreach my $type (keys %allocs) {
 405                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E(\s+\(bytes.*\))?$/m) {
 406                         push @errors, "Wrong heapshot for type $type at $hshot ($1, $allocs{$type})." unless $1 >= $allocs{$type};
 407                 } else {
 408                         push @errors, "No heapshot for type $type at heapshot $hshot.";
 409                 }
 410         }
 411 }
 412
 413 sub check_report_jit
 414 {
 415         my $report = shift;
 416         my $min_methods = shift || 1;
 417         my $min_code = shift || 16;
 418         my $section = get_section ($report, "JIT");
 419         push @errors, "Not enough compiled method." unless (($section =~ /Compiled methods:\s(\d+)/s) && ($1 >= $min_methods));
 420         push @errors, "Not enough compiled code." unless (($section =~ /Generated code size:\s(\d+)/s) && ($1 >= $min_code));
 421 }
 422
 423 sub check_report_locks
 424 {
 425         my $report = shift;
 426         my $contentions = shift;
 427         my $acquired = shift;
 428         my $section = get_section ($report, "Monitor");
 429         push @errors, "Not enough contentions." unless (($section =~ /Lock contentions:\s(\d+)/s) && ($1 >= $contentions));
 430         push @errors, "Not enough acquired locks." unless (($section =~ /Lock acquired:\s(\d+)/s) && ($1 >= $acquired));
 431 }
 432
 433 sub check_report_exceptions
 434 {
 435         my $report = shift;
 436         my $throws = shift;
 437         my $catches = shift;
 438         my $finallies = shift;
 439         my $section = get_section ($report, "Exception");
 440         push @errors, "Not enough throws." unless (($section =~ /Throws:\s(\d+)/s) && ($1 >= $throws));
 441         push @errors, "Not enough catches." unless (($section =~ /Executed catch clauses:\s(\d+)/s) && ($1 >= $catches));
 442         push @errors, "Not enough finallies." unless (($section =~ /Executed finally clauses:\s(\d+)/s) && ($1 >= $finallies));
 443 }
 444
 445 sub check_report_threads
 446 {
 447         my $report = shift;
 448         my @threads = @_;
 449         my $section = get_section ($report, "Thread");
 450         foreach my $tname (@threads) {
 451                 push @errors, "Missing thread $tname." unless $section =~ /Thread:.*name:\s"\Q$tname\E"/s;
 452         }
 453 }
 454