Merge pull request #2154 from BrennanConroy/bug_30018
[mono.git] / 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, '>', 'TestResults_profiler.xml') or die "Could not write to 'TestResults_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