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 # for mprof-report
  20 append_path ("PATH", $profbuilddir);
  21
  22 # first a basic test
  23 $report = run_test ("test-alloc.exe");
  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");
  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,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 check_report_samples ($report, "T:test ()" => 40, "T:test3 ()" => 40);
  41 report_errors ();
  42 # test lock events
  43 $report = run_test ("test-monitor.exe");
  44 check_report_basics ($report);
  45 check_report_calls ($report, "T:Main (string[])" => 1);
  46 # we hope for at least some contention, this is not entirely reliable
  47 check_report_locks ($report, 1, 1);
  48 report_errors ();
  49 # test exceptions
  50 $report = run_test ("test-excleave.exe");
  51 check_report_basics ($report);
  52 check_report_calls ($report, "T:Main (string[])" => 1, "T:throw_ex ()" => 1000);
  53 check_report_exceptions ($report, 1000, 1000, 1000);
  54 report_errors ();
  55 # test heapshot
  56 $report = run_test_sgen ("test-heapshot.exe", "report,heapshot");
  57 if ($report ne "missing binary") {
  58         check_report_basics ($report);
  59         check_report_heapshot ($report, 0, {"T" => 5000});
  60         check_report_heapshot ($report, 1, {"T" => 5023});
  61         report_errors ();
  62 }
  63 # test heapshot traces
  64 $report = run_test_sgen ("test-heapshot.exe", "heapshot,output=-traces.mlpd", "--traces traces.mlpd");
  65 if ($report ne "missing binary") {
  66         check_report_basics ($report);
  67         check_report_heapshot ($report, 0, {"T" => 5000});
  68         check_report_heapshot ($report, 1, {"T" => 5023});
  69         check_heapshot_traces ($report, 0,
  70                 T => [4999, "T"]
  71         );
  72         check_heapshot_traces ($report, 1,
  73                 T => [5022, "T"]
  74         );
  75         report_errors ();
  76 }
  77 # test traces
  78 $report = run_test ("test-traces.exe", "output=-traces.mlpd", "--traces traces.mlpd");
  79 check_report_basics ($report);
  80 check_call_traces ($report,
  81         "T:level3 (int)" => [2020, "T:Main (string[])"],
  82         "T:level2 (int)" => [2020, "T:Main (string[])", "T:level3 (int)"],
  83         "T:level1 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)"],
  84         "T:level0 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)"]
  85 );
  86 check_exception_traces ($report,
  87         [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
  88 );
  89 check_alloc_traces ($report,
  90         T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
  91 );
  92 report_errors ();
  93 # test traces without enter/leave events
  94 $report = run_test ("test-traces.exe", "nocalls,output=-traces.mlpd", "--traces traces.mlpd");
  95 check_report_basics ($report);
  96 # this has been broken recently
  97 check_exception_traces ($report,
  98         [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
  99 );
 100 check_alloc_traces ($report,
 101         T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
 102 );
 103 report_errors ();
 104
 105 exit ($total_errors? 1: 0);
 106
 107 # utility functions
 108 sub append_path {
 109         my $var = shift;
 110         my $value = shift;
 111         if (exists $ENV {$var}) {
 112                 $ENV {$var} = $value . ";" . $ENV {$var};
 113         } else {
 114                 $ENV {$var} = $value;
 115         }
 116 }
 117
 118 sub run_test
 119 {
 120         return run_test_bin ("$minibuilddir/mono", @_);
 121 }
 122
 123 sub run_test_sgen
 124 {
 125         return run_test_bin ("$minibuilddir/mono-sgen", @_);
 126 }
 127
 128 sub run_test_bin
 129 {
 130         my $bin = shift;
 131         my $test_name = shift;
 132         my $option = shift || "report";
 133         my $roptions = shift;
 134         #clear the errors
 135         @errors = ();
 136         $total_errors = 0;
 137         print "Checking $test_name with $option ...";
 138         unless (-x $bin) {
 139                 print "missing $bin, skipped.\n";
 140                 return "missing binary";
 141         }
 142         my $report = `$bin --profile=log:$option $test_name`;
 143         print "\n";
 144         if (defined $roptions) {
 145                 return `$profbuilddir/mprof-report $roptions`;
 146         }
 147         return $report;
 148 }
 149
 150 sub report_errors
 151 {
 152         foreach my $e (@errors) {
 153                 print "Error: $e\n";
 154                 $total_errors++;
 155         }
 156         print "Total errors: $total_errors\n" if $total_errors;
 157         #print $report;
 158 }
 159
 160 sub get_delim_data
 161 {
 162         my $report = shift;
 163         my $start = shift;
 164         my $end = shift;
 165         my $section = "";
 166         my $insection = 0;
 167         foreach (split (/\n/, $report)) {
 168                 if ($insection) {
 169                         #print "matching end $end vs $_\n";
 170                         last if /$end/;
 171                         $section .= $_;
 172                         $section .= "\n";
 173                 } else {
 174                         #print "matching $start vs $_\n";
 175                         $insection = 1 if (/$start/);
 176                 }
 177         }
 178         return $section;
 179 }
 180
 181 sub get_section
 182 {
 183         my $report = shift;
 184         my $name = shift;
 185         return get_delim_data ($report, "^\Q$name\E", "^\\w.*summary");
 186 }
 187
 188 sub get_heap_shot
 189 {
 190         my $section = shift;
 191         my $num = shift;
 192         return get_delim_data ($report, "Heap shot $num at", "^\$");
 193 }
 194
 195 sub check_report_basics
 196 {
 197         my $report = shift;
 198         check_report_threads ($report, "Finalizer", "Main");
 199         check_report_metadata ($report, 2);
 200         check_report_jit ($report);
 201 }
 202
 203 sub check_report_metadata
 204 {
 205         my $report = shift;
 206         my $num = shift;
 207         my $section = get_section ($report, "Metadata");
 208         push @errors, "Wrong loaded images $num." unless $section =~ /Loaded images:\s$num/s;
 209 }
 210
 211 sub check_report_calls
 212 {
 213         my $report = shift;
 214         my %calls = @_;
 215         my $section = get_section ($report, "Method");
 216         foreach my $method (keys %calls) {
 217                 push @errors, "Wrong calls to $method." unless $section =~ /\d+\s+\d+\s+($calls{$method})\s+\Q$method\E/s;
 218         }
 219 }
 220
 221 sub check_call_traces
 222 {
 223         my $report = shift;
 224         my %calls = @_;
 225         my $section = get_section ($report, "Method");
 226         foreach my $method (keys %calls) {
 227                 my @desc = @{$calls{$method}};
 228                 my $num = shift @desc;
 229                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$method\E", "^\\s*\\d+\\s+\\d");
 230                 if ($trace =~ s/^\s+(\d+)\s+calls from:$//m) {
 231                         my $num_calls = $1;
 232                         push @errors, "Wrong calls to $method." unless $num_calls == $num;
 233                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 234                         while (@desc) {
 235                                 my $dm = pop @desc;
 236                                 my $fm = pop @frames;
 237                                 push @errors, "Wrong frame $fm to $method." unless $dm eq $fm;
 238                         }
 239                 } else {
 240                         push @errors, "No num calls for $method.";
 241                 }
 242         }
 243 }
 244
 245 sub check_alloc_traces
 246 {
 247         my $report = shift;
 248         my %types = @_;
 249         my $section = get_section ($report, "Allocation");
 250         foreach my $type (keys %types) {
 251                 my @desc = @{$types{$type}};
 252                 my $num = shift @desc;
 253                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^\\s*\\d+\\s+\\d");
 254                 if ($trace =~ s/^\s+(\d+)\s+bytes from:$//m) {
 255                         #my $num_calls = $1;
 256                         #push @errors, "Wrong calls to $method." unless $num_calls == $num;
 257                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 258                         while (@desc) {
 259                                 my $dm = pop @desc;
 260                                 my $fm = pop @frames;
 261                                 $fm = pop @frames if $fm =~ /wrapper/;
 262                                 push @errors, "Wrong frame $fm for alloc of $type." unless $dm eq $fm;
 263                         }
 264                 } else {
 265                         push @errors, "No alloc frames for $type.";
 266                 }
 267         }
 268 }
 269
 270 sub check_heapshot_traces
 271 {
 272         my $report = shift;
 273         my $hshot = shift;
 274         my %types = @_;
 275         my $section = get_section ($report, "Heap");
 276         $section = get_heap_shot ($section, $hshot);
 277         foreach my $type (keys %types) {
 278                 my @desc = @{$types{$type}};
 279                 my $num = shift @desc;
 280                 my $rtype = shift @desc;
 281                 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^\\s*\\d+\\s+\\d");
 282                 if ($trace =~ s/^\s+(\d+)\s+references from:\s+\Q$rtype\E$//m) {
 283                         my $num_refs = $1;
 284                         push @errors, "Wrong num refs to $type from $rtype." unless $num_refs == $num;
 285                 } else {
 286                         push @errors, "No refs to $type from $rtype.";
 287                 }
 288         }
 289 }
 290
 291 sub check_exception_traces
 292 {
 293         my $report = shift;
 294         my @etraces = @_;
 295         my $section = get_section ($report, "Exception");
 296         foreach my $d (@etraces) {
 297                 my @desc = @{$d};
 298                 my $num = shift @desc;
 299                 my $trace = get_delim_data ($section, "^\\s+$num\\s+throws from:\$", "^\\s+(\\d+|Executed)");
 300                 if (length ($trace)) {
 301                         my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
 302                         while (@desc) {
 303                                 my $dm = pop @desc;
 304                                 my $fm = pop @frames;
 305                                 push @errors, "Wrong frame '$fm' in exceptions (should be '$dm')." unless $dm eq $fm;
 306                         }
 307                 } else {
 308                         push @errors, "No exceptions or incorrect number.";
 309                 }
 310         }
 311 }
 312
 313 sub check_report_samples
 314 {
 315         my $report = shift;
 316         my %calls = @_;
 317         my $section = get_section ($report, "Statistical");
 318         foreach my $method (keys %calls) {
 319                 push @errors, "Wrong samples for $method." unless ($section =~ /\d+\s+(\d+\.\d+)\s+\Q$method\E/s && $1 >= $calls{$method});
 320         }
 321 }
 322
 323 sub check_report_allocation
 324 {
 325         my $report = shift;
 326         my %allocs = @_;
 327         my $section = get_section ($report, "Allocation");
 328         foreach my $type (keys %allocs) {
 329                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E$/m) {
 330                         push @errors, "Wrong allocs for type $type." unless $1 >= $allocs{$type};
 331                 } else {
 332                         push @errors, "No allocs for type $type.";
 333                 }
 334         }
 335 }
 336
 337 sub check_report_heapshot
 338 {
 339         my $report = shift;
 340         my $hshot = shift;
 341         my $typemap = shift;
 342         my %allocs = %{$typemap};
 343         my $section = get_section ($report, "Heap");
 344         $section = get_heap_shot ($section, $hshot);
 345         foreach my $type (keys %allocs) {
 346                 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E(\s+\(bytes.*\))?$/m) {
 347                         push @errors, "Wrong heapshot for type $type." unless $1 >= $allocs{$type};
 348                 } else {
 349                         push @errors, "No heapshot for type $type.";
 350                 }
 351         }
 352 }
 353
 354 sub check_report_jit
 355 {
 356         my $report = shift;
 357         my $min_methods = shift || 1;
 358         my $min_code = shift || 16;
 359         my $section = get_section ($report, "JIT");
 360         push @errors, "Not enough compiled method." unless (($section =~ /Compiled methods:\s(\d+)/s) && ($1 >= $min_methods));
 361         push @errors, "Not enough compiled code." unless (($section =~ /Generated code size:\s(\d+)/s) && ($1 >= $min_code));
 362 }
 363
 364 sub check_report_locks
 365 {
 366         my $report = shift;
 367         my $contentions = shift;
 368         my $acquired = shift;
 369         my $section = get_section ($report, "Monitor");
 370         push @errors, "Not enough contentions." unless (($section =~ /Lock contentions:\s(\d+)/s) && ($1 >= $contentions));
 371         push @errors, "Not enough acquired locks." unless (($section =~ /Lock acquired:\s(\d+)/s) && ($1 >= $acquired));
 372 }
 373
 374 sub check_report_exceptions
 375 {
 376         my $report = shift;
 377         my $throws = shift;
 378         my $catches = shift;
 379         my $finallies = shift;
 380         my $section = get_section ($report, "Exception");
 381         push @errors, "Not enough throws." unless (($section =~ /Throws:\s(\d+)/s) && ($1 >= $throws));
 382         push @errors, "Not enough catches." unless (($section =~ /Executed catch clauses:\s(\d+)/s) && ($1 >= $catches));
 383         push @errors, "Not enough finallies." unless (($section =~ /Executed finally clauses:\s(\d+)/s) && ($1 >= $finallies));
 384 }
 385
 386 sub check_report_threads
 387 {
 388         my $report = shift;
 389         my @threads = @_;
 390         my $section = get_section ($report, "Thread");
 391         foreach my $tname (@threads) {
 392                 push @errors, "Missing thread $tname." unless $section =~ /Thread:.*name:\s"\Q$tname\E"/s;
 393         }
 394 }
 395