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 exit ($total_errors? 1: 0);
 108
 109 # utility functions
 110 sub append_path {
 111         my $var = shift;
 112         my $value = shift;
 113         if (exists $ENV{$var}) {
 114                 $ENV{$var} = $value . ":" . $ENV{$var};
 115         } else {
 116                 $ENV{$var} = $value;
 117         }
 118 }
 119
 120 sub run_test
 121 {
 122         return run_test_bin ("$minibuilddir/mono", @_);
 123 }
 124
 125 sub run_test_sgen
 126 {
 127         return run_test_bin ("$minibuilddir/mono-sgen", @_);
 128 }
 129
 130 sub run_test_bin
 131 {
 132         my $bin = shift;
 133         my $test_name = shift;
 134         my $option = shift || "report";
 135         my $roptions = shift;
 136         #clear the errors
 137         @errors = ();
 138         $total_errors = 0;
 139         print "Checking $test_name with $option ...";
 140         unless (-x $bin) {
 141                 print "missing $bin, skipped.\n";
 142                 return "missing binary";
 143         }
 144         my $report = `$bin --profile=log:$option $test_name`;
 145         print "\n";
 146         if (defined $roptions) {
 147                 return `$profbuilddir/mprof-report $roptions`;
 148         }
 149         return $report;
 150 }
 151
 152 sub report_errors
 153 {
 154         foreach my $e (@errors) {
 155                 print "Error: $e\n";
 156                 $total_errors++;
 157         }
 158         print "Total errors: $total_errors\n" if $total_errors;
 159         #print $report;
 160 }
 161
 162 sub get_delim_data
 163 {
 164         my $report = shift;
 165         my $start = shift;
 166         my $end = shift;
 167         my $section = "";
 168         my $insection = 0;
 169         foreach (split (/\n/, $report)) {
 170                 if ($insection) {
 171                         #print "matching end $end vs $_\n";
 172                         last if /$end/;
 173                         $section .= $_;
 174                         $section .= "\n";
 175                 } else {
 176                         #print "matching $start vs $_\n";
 177                         $insection = 1 if (/$start/);
 178                 }
 179         }
 180         return $section;
 181 }
 182
 183 sub get_section
 184 {
 185         my $report = shift;
 186         my $name = shift;
 187         return get_delim_data ($report, "^\Q$name\E", "^\\w.*summary");
 188 }
 189
 190 sub get_heap_shot
 191 {
 192         my $section = shift;
 193         my $num = shift;
 194         return get_delim_data ($report, "Heap shot $num at", "^\$");
 195 }
 196
 197 sub check_report_basics
 198 {
 199         my $report = shift;
 200         check_report_threads ($report, "Finalizer", "Main");
 201         check_report_metadata ($report, 2);
 202         check_report_jit ($report);
 203 }
 204
 205 sub check_report_metadata
 206 {
 207         my $report = shift;
 208         my $num = shift;
 209         my $section = get_section ($report, "Metadata");
 210         push @errors, "Wrong loaded images $num." unless $section =~ /Loaded images:\s$num/s;
 211 }
 212
 213 sub check_report_calls
 214 {
 215         my $report = shift;
 216         my %calls = @_;
 217         my $section = get_section ($report, "Method");
 218         foreach my $method (keys %calls) {
 219                 push @errors, "Wrong calls to $method." unless $section =~ /\d+\s+\d+\s+($calls{$method})\s+\Q$method\E/s;
 220         }
 221 }
 222
 223 sub check_call_traces
 224 {
 225         my $report = shift;
 226         my %calls = @_;
 227         my $section = get_section ($report, "Method");
 228         foreach my $method (keys %calls) {
 229                 my @desc = @{$calls{$method}};
 230                 my $num = shift @desc;
 231                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$method\E", "^(\\s*\\d+\\s+\\d)|(^Total calls)");
 232                 if ($trace =~ s/^\s+(\d+)\s+calls from:$//m) {
 233                         my $num_calls = $1;
 234                         push @errors, "Wrong calls to $method." unless $num_calls == $num;
 235                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 236                         while (@desc) {
 237                                 my $dm = pop @desc;
 238                                 my $fm = pop @frames;
 239                                 push @errors, "Wrong frame $fm to $method." unless $dm eq $fm;
 240                         }
 241                 } else {
 242                         push @errors, "No num calls for $method.";
 243                 }
 244         }
 245 }
 246
 247 sub check_alloc_traces
 248 {
 249         my $report = shift;
 250         my %types = @_;
 251         my $section = get_section ($report, "Allocation");
 252         foreach my $type (keys %types) {
 253                 my @desc = @{$types{$type}};
 254                 my $num = shift @desc;
 255                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^(\\s*\\d+\\s+\\d)|(^Total)");
 256                 if ($trace =~ s/^\s+(\d+)\s+bytes from:$//m) {
 257                         #my $num_calls = $1;
 258                         #push @errors, "Wrong calls to $method." unless $num_calls == $num;
 259                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 260                         while (@desc) {
 261                                 my $dm = pop @desc;
 262                                 my $fm = pop @frames;
 263                                 $fm = pop @frames if $fm =~ /wrapper/;
 264                                 push @errors, "Wrong frame $fm for alloc of $type." unless $dm eq $fm;
 265                         }
 266                 } else {
 267                         push @errors, "No alloc frames for $type.";
 268                 }
 269         }
 270 }
 271
 272 sub check_heapshot_traces
 273 {
 274         my $report = shift;
 275         my $hshot = shift;
 276         my %types = @_;
 277         my $section = get_section ($report, "Heap");
 278         $section = get_heap_shot ($section, $hshot);
 279         foreach my $type (keys %types) {
 280                 my @desc = @{$types{$type}};
 281                 my $num = shift @desc;
 282                 my $rtype = shift @desc;
 283                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^\\s*\\d+\\s+\\d");
 284                 if ($trace =~ s/^\s+(\d+)\s+references from:\s+\Q$rtype\E$//m) {
 285                         my $num_refs = $1;
 286                         push @errors, "Wrong num refs to $type from $rtype." unless $num_refs == $num;
 287                 } else {
 288                         push @errors, "No refs to $type from $rtype.";
 289                 }
 290         }
 291 }
 292
 293 sub check_exception_traces
 294 {
 295         my $report = shift;
 296         my @etraces = @_;
 297         my $section = get_section ($report, "Exception");
 298         foreach my $d (@etraces) {
 299                 my @desc = @{$d};
 300                 my $num = shift @desc;
 301                 my $trace = get_delim_data ($section, "^\\s+$num\\s+throws from:\$", "^\\s+(\\d+|Executed)");
 302                 if (length ($trace)) {
 303                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 304                         while (@desc) {
 305                                 my $dm = pop @desc;
 306                                 my $fm = pop @frames;
 307                                 push @errors, "Wrong frame '$fm' in exceptions (should be '$dm')." unless $dm eq $fm;
 308                         }
 309                 } else {
 310                         push @errors, "No exceptions or incorrect number.";
 311                 }
 312         }
 313 }
 314
 315 sub check_report_samples
 316 {
 317         my $report = shift;
 318         my %calls = @_;
 319         my $section = get_section ($report, "Statistical");
 320         foreach my $method (keys %calls) {
 321                 push @errors, "Wrong samples for $method." unless ($section =~ /\d+\s+(\d+\.\d+)\s+\Q$method\E/s && $1 >= $calls{$method});
 322         }
 323 }
 324
 325 sub check_report_allocation
 326 {
 327         my $report = shift;
 328         my %allocs = @_;
 329         my $section = get_section ($report, "Allocation");
 330         foreach my $type (keys %allocs) {
 331                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E$/m) {
 332                         push @errors, "Wrong allocs for type $type." unless $1 >= $allocs{$type};
 333                 } else {
 334                         push @errors, "No allocs for type $type.";
 335                 }
 336         }
 337 }
 338
 339 sub check_report_heapshot
 340 {
 341         my $report = shift;
 342         my $hshot = shift;
 343         my $typemap = shift;
 344         my %allocs = %{$typemap};
 345         my $section = get_section ($report, "Heap");
 346         $section = get_heap_shot ($section, $hshot);
 347         foreach my $type (keys %allocs) {
 348                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E(\s+\(bytes.*\))?$/m) {
 349                         push @errors, "Wrong heapshot for type $type at $hshot ($1, $allocs{$type})." unless $1 >= $allocs{$type};
 350                 } else {
 351                         push @errors, "No heapshot for type $type at heapshot $hshot.";
 352                 }
 353         }
 354 }
 355
 356 sub check_report_jit
 357 {
 358         my $report = shift;
 359         my $min_methods = shift || 1;
 360         my $min_code = shift || 16;
 361         my $section = get_section ($report, "JIT");
 362         push @errors, "Not enough compiled method." unless (($section =~ /Compiled methods:\s(\d+)/s) && ($1 >= $min_methods));
 363         push @errors, "Not enough compiled code." unless (($section =~ /Generated code size:\s(\d+)/s) && ($1 >= $min_code));
 364 }
 365
 366 sub check_report_locks
 367 {
 368         my $report = shift;
 369         my $contentions = shift;
 370         my $acquired = shift;
 371         my $section = get_section ($report, "Monitor");
 372         push @errors, "Not enough contentions." unless (($section =~ /Lock contentions:\s(\d+)/s) && ($1 >= $contentions));
 373         push @errors, "Not enough acquired locks." unless (($section =~ /Lock acquired:\s(\d+)/s) && ($1 >= $acquired));
 374 }
 375
 376 sub check_report_exceptions
 377 {
 378         my $report = shift;
 379         my $throws = shift;
 380         my $catches = shift;
 381         my $finallies = shift;
 382         my $section = get_section ($report, "Exception");
 383         push @errors, "Not enough throws." unless (($section =~ /Throws:\s(\d+)/s) && ($1 >= $throws));
 384         push @errors, "Not enough catches." unless (($section =~ /Executed catch clauses:\s(\d+)/s) && ($1 >= $catches));
 385         push @errors, "Not enough finallies." unless (($section =~ /Executed finally clauses:\s(\d+)/s) && ($1 >= $finallies));
 386 }
 387
 388 sub check_report_threads
 389 {
 390         my $report = shift;
 391         my @threads = @_;
 392         my $section = get_section ($report, "Thread");
 393         foreach my $tname (@threads) {
 394                 push @errors, "Missing thread $tname." unless $section =~ /Thread:.*name:\s"\Q$tname\E"/s;
 395         }
 396 }
 397