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 ("LD_LIBRARY_PATH", $profbuilddir . "/.libs");
19 append_path ("DYLD_LIBRARY_PATH", $profbuilddir . "/.libs");
20 append_path ("DYLD_LIBRARY_PATH", $minibuilddir . "/.libs");
22 append_path ("PATH", $profbuilddir);
25 $report = run_test ("test-alloc.exe");
26 check_report_basics ($report);
27 check_report_calls ($report, "T:Main (string[])" => 1);
28 check_report_allocation ($report, "System.Object" => 1000000);
30 # test additional named threads and method calls
31 $report = run_test ("test-busy.exe");
32 check_report_basics ($report);
33 check_report_calls ($report, "T:Main (string[])" => 1);
34 check_report_threads ($report, "BusyHelper");
35 check_report_calls ($report, "T:test ()" => 10, "T:test3 ()" => 10, "T:test2 ()" => 1);
37 # test with the sampling profiler
38 $report = run_test ("test-busy.exe", "report,sample");
39 check_report_basics ($report);
40 check_report_threads ($report, "BusyHelper");
41 # at least 40% of the samples should hit each of the two busy methods
42 # This seems to fail on osx, where the main thread gets the majority of SIGPROF signals
43 #check_report_samples ($report, "T:test ()" => 40, "T:test3 ()" => 40);
46 $report = run_test ("test-monitor.exe");
47 check_report_basics ($report);
48 check_report_calls ($report, "T:Main (string[])" => 1);
49 # we hope for at least some contention, this is not entirely reliable
50 check_report_locks ($report, 1, 1);
53 $report = run_test ("test-excleave.exe");
54 check_report_basics ($report);
55 check_report_calls ($report, "T:Main (string[])" => 1, "T:throw_ex ()" => 1000);
56 check_report_exceptions ($report, 1000, 1000, 1000);
59 $report = run_test_sgen ("test-heapshot.exe", "report,heapshot");
60 if ($report ne "missing binary") {
61 check_report_basics ($report);
62 check_report_heapshot ($report, 0, {"T" => 5000});
63 check_report_heapshot ($report, 1, {"T" => 5023});
66 # test heapshot traces
67 $report = run_test_sgen ("test-heapshot.exe", "heapshot,output=-traces.mlpd", "--traces traces.mlpd");
68 if ($report ne "missing binary") {
69 check_report_basics ($report);
70 check_report_heapshot ($report, 0, {"T" => 5000});
71 check_report_heapshot ($report, 1, {"T" => 5023});
72 check_heapshot_traces ($report, 0,
75 check_heapshot_traces ($report, 1,
81 $report = run_test ("test-traces.exe", "output=-traces.mlpd", "--traces traces.mlpd");
82 check_report_basics ($report);
83 check_call_traces ($report,
84 "T:level3 (int)" => [2020, "T:Main (string[])"],
85 "T:level2 (int)" => [2020, "T:Main (string[])", "T:level3 (int)"],
86 "T:level1 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)"],
87 "T:level0 (int)" => [2020, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)"]
89 check_exception_traces ($report,
90 [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
92 check_alloc_traces ($report,
93 T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
96 # test traces without enter/leave events
97 $report = run_test ("test-traces.exe", "nocalls,output=-traces.mlpd", "--traces traces.mlpd");
98 check_report_basics ($report);
99 # this has been broken recently
100 check_exception_traces ($report,
101 [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
103 check_alloc_traces ($report,
104 T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
110 exit ($global_errors ? 1 : 0);
116 if (exists $ENV{$var}) {
117 $ENV{$var} = $value . ":" . $ENV{$var};
125 return run_test_bin ("$minibuilddir/mono", @_);
130 return run_test_bin ("$minibuilddir/mono-sgen", @_);
136 my $test_name = shift;
137 my $option = shift || "report";
138 my $roptions = shift;
142 print "Checking $test_name with $option ...";
144 print "missing $bin, skipped.\n";
145 return "missing binary";
147 my $report = `$bin --profile=log:$option $test_name`;
149 if (defined $roptions) {
150 return `$profbuilddir/mprof-report $roptions`;
157 foreach my $e (@errors) {
162 print "Total errors: $total_errors\n" if $total_errors;
166 sub emit_nunit_report
169 use POSIX qw(strftime uname locale_h);
170 use Net::Domain qw(hostname hostfqdn);
173 my $failed = $global_errors ? 1 : 0;
176 my $mylocale = setlocale (LC_CTYPE);
177 $mylocale = substr($mylocale, 0, index($mylocale, '.'));
181 $successbool = "False";
183 $successbool = "True";
185 open (my $nunitxml, '>', 'TestResult-profiler.xml') or die "Could not write to 'TestResult-profiler.xml' $!";
186 print $nunitxml "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>\n";
187 print $nunitxml "<!--This file represents the results of running a test suite-->\n";
188 print $nunitxml "<test-results name=\"profiler-tests.dummy\" total=\"$total\" failures=\"$failed\" not-run=\"0\" date=\"" . strftime ("%F", localtime) . "\" time=\"" . strftime ("%T", localtime) . "\">\n";
189 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";
190 print $nunitxml " <culture-info current-culture=\"$mylocale\" current-uiculture=\"$mylocale\" />\n";
191 print $nunitxml " <test-suite name=\"profiler-tests.dummy\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
192 print $nunitxml " <results>\n";
193 print $nunitxml " <test-suite name=\"MonoTests\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
194 print $nunitxml " <results>\n";
195 print $nunitxml " <test-suite name=\"profiler\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
196 print $nunitxml " <results>\n";
197 print $nunitxml " <test-case name=\"MonoTests.profiler.100percentsuccess\" executed=\"True\" success=\"$successbool\" time=\"0\" asserts=\"0\"";
199 print $nunitxml ">\n";
200 print $nunitxml " <failure>\n";
201 print $nunitxml " <message><![CDATA[";
202 print $nunitxml "The profiler tests returned an error. Check the log for more details.";
203 print $nunitxml "]]></message>\n";
204 print $nunitxml " <stack-trace>\n";
205 print $nunitxml " </stack-trace>\n";
206 print $nunitxml " </failure>\n";
207 print $nunitxml " </test-case>\n";
209 print $nunitxml " />\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 " </results>\n";
216 print $nunitxml " </test-suite>\n";
217 print $nunitxml "</test-results>\n";
228 foreach (split (/\n/, $report)) {
230 #print "matching end $end vs $_\n";
235 #print "matching $start vs $_\n";
236 $insection = 1 if (/$start/);
246 return get_delim_data ($report, "^\Q$name\E", "^\\w.*summary");
253 return get_delim_data ($report, "Heap shot $num at", "^\$");
256 sub check_report_basics
259 check_report_threads ($report, "Finalizer", "Main");
260 check_report_metadata ($report, 2);
261 check_report_jit ($report);
264 sub check_report_metadata
268 my $section = get_section ($report, "Metadata");
269 push @errors, "Wrong loaded images $num." unless $section =~ /Loaded images:\s$num/s;
272 sub check_report_calls
276 my $section = get_section ($report, "Method");
277 foreach my $method (keys %calls) {
278 push @errors, "Wrong calls to $method." unless $section =~ /\d+\s+\d+\s+($calls{$method})\s+\Q$method\E/s;
282 sub check_call_traces
286 my $section = get_section ($report, "Method");
287 foreach my $method (keys %calls) {
288 my @desc = @{$calls{$method}};
289 my $num = shift @desc;
290 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$method\E", "^(\\s*\\d+\\s+\\d)|(^Total calls)");
291 if ($trace =~ s/^\s+(\d+)\s+calls from:$//m) {
293 push @errors, "Wrong calls to $method." unless $num_calls == $num;
294 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
297 my $fm = pop @frames;
298 push @errors, "Wrong frame $fm to $method." unless $dm eq $fm;
301 push @errors, "No num calls for $method.";
306 sub check_alloc_traces
310 my $section = get_section ($report, "Allocation");
311 foreach my $type (keys %types) {
312 my @desc = @{$types{$type}};
313 my $num = shift @desc;
314 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^(\\s*\\d+\\s+\\d)|(^Total)");
315 if ($trace =~ s/^\s+(\d+)\s+bytes from:$//m) {
317 #push @errors, "Wrong calls to $method." unless $num_calls == $num;
318 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
321 my $fm = pop @frames;
322 $fm = pop @frames if $fm =~ /wrapper/;
323 push @errors, "Wrong frame $fm for alloc of $type." 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;