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;
  10 my $report;
  11
  12 my $profbuilddir = $builddir . "/mono/profiler";
  13 my $minibuilddir = $builddir . "/mono/mini";
  14
  15 # Setup the execution environment
  16 # for the profiler module
  17 append_path ("LD_LIBRARY_PATH", $profbuilddir . "/.libs");
  18 append_path ("DYLD_LIBRARY_PATH", $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 ($total_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         }
 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 = $total_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