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", "report,legacy,calls,alloc");
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", "report,legacy,calls,alloc");
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,legacy,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", "report,legacy,calls,alloc");
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", "report,legacy,calls");
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,legacy");
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,legacy", "--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", "legacy,calls,alloc,output=traces.mlpd", "--maxframes=7 --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", "legacy,alloc,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 while ($fm =~ /wrapper/) {
323 push @errors, "Wrong frame $fm for alloc of $type (expected $dm)." unless $dm eq $fm;
326 push @errors, "No alloc frames for $type.";
331 sub check_heapshot_traces
336 my $section = get_section ($report, "Heap");
337 $section = get_heap_shot ($section, $hshot);
338 foreach my $type (keys %types) {
339 my @desc = @{$types{$type}};
340 my $num = shift @desc;
341 my $rtype = shift @desc;
342 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^\\s*\\d+\\s+\\d");
343 if ($trace =~ s/^\s+(\d+)\s+references from:\s+\Q$rtype\E$//m) {
345 push @errors, "Wrong num refs to $type from $rtype." unless $num_refs == $num;
347 push @errors, "No refs to $type from $rtype.";
352 sub check_exception_traces
356 my $section = get_section ($report, "Exception");
357 foreach my $d (@etraces) {
359 my $num = shift @desc;
360 my $trace = get_delim_data ($section, "^\\s+$num\\s+throws from:\$", "^\\s+(\\d+|Executed)");
361 if (length ($trace)) {
362 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
365 my $fm = pop @frames;
366 push @errors, "Wrong frame '$fm' in exceptions (should be '$dm')." unless $dm eq $fm;
369 push @errors, "No exceptions or incorrect number.";
374 sub check_report_samples
378 my $section = get_section ($report, "Statistical");
379 foreach my $method (keys %calls) {
380 push @errors, "Wrong samples for $method." unless ($section =~ /\d+\s+(\d+\.\d+)\s+\Q$method\E/s && $1 >= $calls{$method});
384 sub check_report_allocation
388 my $section = get_section ($report, "Allocation");
389 foreach my $type (keys %allocs) {
390 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E$/m) {
391 push @errors, "Wrong allocs for type $type." unless $1 >= $allocs{$type};
393 push @errors, "No allocs for type $type.";
398 sub check_report_heapshot
403 my %allocs = %{$typemap};
404 my $section = get_section ($report, "Heap");
405 $section = get_heap_shot ($section, $hshot);
406 foreach my $type (keys %allocs) {
407 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E(\s+\(bytes.*\))?$/m) {
408 push @errors, "Wrong heapshot for type $type at $hshot ($1, $allocs{$type})." unless $1 >= $allocs{$type};
410 push @errors, "No heapshot for type $type at heapshot $hshot.";
418 my $min_methods = shift || 1;
419 my $min_code = shift || 16;
420 my $section = get_section ($report, "JIT");
421 push @errors, "Not enough compiled method." unless (($section =~ /Compiled methods:\s(\d+)/s) && ($1 >= $min_methods));
422 push @errors, "Not enough compiled code." unless (($section =~ /Generated code size:\s(\d+)/s) && ($1 >= $min_code));
425 sub check_report_locks
428 my $contentions = shift;
429 my $acquired = shift;
430 my $section = get_section ($report, "Monitor");
431 push @errors, "Not enough contentions." unless (($section =~ /Lock contentions:\s(\d+)/s) && ($1 >= $contentions));
432 push @errors, "Not enough acquired locks." unless (($section =~ /Lock acquired:\s(\d+)/s) && ($1 >= $acquired));
435 sub check_report_exceptions
440 my $finallies = shift;
441 my $section = get_section ($report, "Exception");
442 push @errors, "Not enough throws." unless (($section =~ /Throws:\s(\d+)/s) && ($1 >= $throws));
443 push @errors, "Not enough catches." unless (($section =~ /Executed catch clauses:\s(\d+)/s) && ($1 >= $catches));
444 push @errors, "Not enough finallies." unless (($section =~ /Executed finally clauses:\s(\d+)/s) && ($1 >= $finallies));
447 sub check_report_threads
451 my $section = get_section ($report, "Thread");
452 foreach my $tname (@threads) {
453 push @errors, "Missing thread $tname." unless $section =~ /Thread:.*name:\s"\Q$tname\E"/s;