5 # run the log profiler test suite
7 my $builddir = shift || die "Usage: ptestrunner.pl mono_build_dir\n";
9 my $total_errors = 0; # this is reset before each test
10 my $global_errors = 0;
13 my $profbuilddir = $builddir . "/mono/profiler";
14 my $minibuilddir = $builddir . "/mono/mini";
16 # Setup the execution environment
17 # for the profiler module
18 append_path
("DYLD_LIBRARY_PATH", $minibuilddir . "/.libs");
20 append_path
("PATH", $profbuilddir);
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);
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);
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 # 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);
44 $report = run_test
("test-monitor.exe");
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);
51 $report = run_test
("test-excleave.exe");
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);
57 $report = run_test_sgen
("test-heapshot.exe", "report,heapshot");
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});
64 # test heapshot traces
65 $report = run_test_sgen
("test-heapshot.exe", "heapshot,output=-traces.mlpd", "--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,
73 check_heapshot_traces
($report, 1,
79 $report = run_test
("test-traces.exe", "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)"]
87 check_exception_traces
($report,
88 [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
90 check_alloc_traces
($report,
91 T
=> [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
94 # test traces without enter/leave events
95 $report = run_test
("test-traces.exe", "nocalls,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)"]
101 check_alloc_traces
($report,
102 T
=> [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
108 exit ($global_errors ?
1 : 0);
114 if (exists $ENV{$var}) {
115 $ENV{$var} = $value . ":" . $ENV{$var};
123 return run_test_bin
("$minibuilddir/mono", @_);
128 return run_test_bin
("$minibuilddir/mono-sgen", @_);
134 my $test_name = shift;
135 my $option = shift || "report";
136 my $roptions = shift;
140 print "Checking $test_name with $option ...";
142 print "missing $bin, skipped.\n";
143 return "missing binary";
145 my $report = `$bin --profile=log:$option $test_name`;
147 if (defined $roptions) {
148 return `$profbuilddir/mprof-report $roptions`;
155 foreach my $e (@errors) {
160 print "Total errors: $total_errors\n" if $total_errors;
164 sub emit_nunit_report
167 use POSIX
qw(strftime uname locale_h);
168 use Net
::Domain
qw(hostname hostfqdn);
171 my $failed = $global_errors ?
1 : 0;
174 my $mylocale = setlocale
(LC_CTYPE
);
175 $mylocale = substr($mylocale, 0, index($mylocale, '.'));
179 $successbool = "False";
181 $successbool = "True";
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\"";
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";
207 print $nunitxml " />\n";
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";
226 foreach (split (/\n/, $report)) {
228 #print "matching end $end vs $_\n";
233 #print "matching $start vs $_\n";
234 $insection = 1 if (/$start/);
244 return get_delim_data
($report, "^\Q$name\E", "^\\w.*summary");
251 return get_delim_data
($report, "Heap shot $num at", "^\$");
254 sub check_report_basics
257 check_report_threads
($report, "Finalizer", "Main");
258 check_report_metadata
($report, 2);
259 check_report_jit
($report);
262 sub check_report_metadata
266 my $section = get_section
($report, "Metadata");
267 push @errors, "Wrong loaded images $num." unless $section =~ /Loaded images:\s$num/s;
270 sub check_report_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;
280 sub check_call_traces
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) {
291 push @errors, "Wrong calls to $method." unless $num_calls == $num;
292 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
295 my $fm = pop @frames;
296 push @errors, "Wrong frame $fm to $method." unless $dm eq $fm;
299 push @errors, "No num calls for $method.";
304 sub check_alloc_traces
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) {
315 #push @errors, "Wrong calls to $method." unless $num_calls == $num;
316 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
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;
324 push @errors, "No alloc frames for $type.";
329 sub check_heapshot_traces
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) {
343 push @errors, "Wrong num refs to $type from $rtype." unless $num_refs == $num;
345 push @errors, "No refs to $type from $rtype.";
350 sub check_exception_traces
354 my $section = get_section
($report, "Exception");
355 foreach my $d (@etraces) {
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);
363 my $fm = pop @frames;
364 push @errors, "Wrong frame '$fm' in exceptions (should be '$dm')." unless $dm eq $fm;
367 push @errors, "No exceptions or incorrect number.";
372 sub check_report_samples
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});
382 sub check_report_allocation
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};
391 push @errors, "No allocs for type $type.";
396 sub check_report_heapshot
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};
408 push @errors, "No heapshot for type $type at heapshot $hshot.";
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));
423 sub check_report_locks
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));
433 sub check_report_exceptions
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));
445 sub check_report_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;