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 ("MONO_PROFILER_LIB_DIR", $profbuilddir . "/.libs");
19 append_path ("DYLD_LIBRARY_PATH", $minibuilddir . "/.libs");
21 append_path ("PATH", $profbuilddir);
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);
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);
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);
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);
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);
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});
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,
74 check_heapshot_traces ($report, 1,
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)"]
88 check_exception_traces ($report,
89 [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
91 check_alloc_traces ($report,
92 T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
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)"]
102 check_alloc_traces ($report,
103 T => [1010, "T:Main (string[])", "T:level3 (int)", "T:level2 (int)", "T:level1 (int)", "T:level0 (int)"]
109 exit ($global_errors ? 1 : 0);
115 if (exists $ENV{$var}) {
116 $ENV{$var} = $value . ":" . $ENV{$var};
124 return run_test_bin ("$minibuilddir/mono", @_);
129 return run_test_bin ("$minibuilddir/mono-sgen", @_);
135 my $test_name = shift;
136 my $option = shift || "report";
137 my $roptions = shift;
141 print "Checking $test_name with $option ...";
143 print "missing $bin, skipped.\n";
144 return "missing binary";
146 my $report = `$bin --profile=log:$option $test_name`;
148 if (defined $roptions) {
149 return `$profbuilddir/mprof-report $roptions`;
156 foreach my $e (@errors) {
161 print "Total errors: $total_errors\n" if $total_errors;
165 sub emit_nunit_report
168 use POSIX qw(strftime uname locale_h);
169 use Net::Domain qw(hostname hostfqdn);
172 my $failed = $global_errors ? 1 : 0;
175 my $mylocale = setlocale (LC_CTYPE);
176 $mylocale = substr($mylocale, 0, index($mylocale, '.'));
180 $successbool = "False";
182 $successbool = "True";
184 open (my $nunitxml, '>', 'TestResult-profiler.xml') or die "Could not write to 'TestResult-profiler.xml' $!";
185 print $nunitxml "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>\n";
186 print $nunitxml "<!--This file represents the results of running a test suite-->\n";
187 print $nunitxml "<test-results name=\"profiler-tests.dummy\" total=\"$total\" failures=\"$failed\" not-run=\"0\" date=\"" . strftime ("%F", localtime) . "\" time=\"" . strftime ("%T", localtime) . "\">\n";
188 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";
189 print $nunitxml " <culture-info current-culture=\"$mylocale\" current-uiculture=\"$mylocale\" />\n";
190 print $nunitxml " <test-suite name=\"profiler-tests.dummy\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
191 print $nunitxml " <results>\n";
192 print $nunitxml " <test-suite name=\"MonoTests\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
193 print $nunitxml " <results>\n";
194 print $nunitxml " <test-suite name=\"profiler\" success=\"$successbool\" time=\"0\" asserts=\"0\">\n";
195 print $nunitxml " <results>\n";
196 print $nunitxml " <test-case name=\"MonoTests.profiler.100percentsuccess\" executed=\"True\" success=\"$successbool\" time=\"0\" asserts=\"0\"";
198 print $nunitxml ">\n";
199 print $nunitxml " <failure>\n";
200 print $nunitxml " <message><![CDATA[";
201 print $nunitxml "The profiler tests returned an error. Check the log for more details.";
202 print $nunitxml "]]></message>\n";
203 print $nunitxml " <stack-trace>\n";
204 print $nunitxml " </stack-trace>\n";
205 print $nunitxml " </failure>\n";
206 print $nunitxml " </test-case>\n";
208 print $nunitxml " />\n";
210 print $nunitxml " </results>\n";
211 print $nunitxml " </test-suite>\n";
212 print $nunitxml " </results>\n";
213 print $nunitxml " </test-suite>\n";
214 print $nunitxml " </results>\n";
215 print $nunitxml " </test-suite>\n";
216 print $nunitxml "</test-results>\n";
227 foreach (split (/\n/, $report)) {
229 #print "matching end $end vs $_\n";
234 #print "matching $start vs $_\n";
235 $insection = 1 if (/$start/);
245 return get_delim_data ($report, "^\Q$name\E", "^\\w.*summary");
252 return get_delim_data ($report, "Heap shot $num at", "^\$");
255 sub check_report_basics
258 check_report_threads ($report, "Finalizer", "Main");
259 check_report_metadata ($report, 2);
260 check_report_jit ($report);
263 sub check_report_metadata
267 my $section = get_section ($report, "Metadata");
268 push @errors, "Wrong loaded images $num." unless $section =~ /Loaded images:\s$num/s;
271 sub check_report_calls
275 my $section = get_section ($report, "Method");
276 foreach my $method (keys %calls) {
277 push @errors, "Wrong calls to $method." unless $section =~ /\d+\s+\d+\s+($calls{$method})\s+\Q$method\E/s;
281 sub check_call_traces
285 my $section = get_section ($report, "Method");
286 foreach my $method (keys %calls) {
287 my @desc = @{$calls{$method}};
288 my $num = shift @desc;
289 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$method\E", "^(\\s*\\d+\\s+\\d)|(^Total calls)");
290 if ($trace =~ s/^\s+(\d+)\s+calls from:$//m) {
292 push @errors, "Wrong calls to $method." unless $num_calls == $num;
293 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
296 my $fm = pop @frames;
297 push @errors, "Wrong frame $fm to $method." unless $dm eq $fm;
300 push @errors, "No num calls for $method.";
305 sub check_alloc_traces
309 my $section = get_section ($report, "Allocation");
310 foreach my $type (keys %types) {
311 my @desc = @{$types{$type}};
312 my $num = shift @desc;
313 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^(\\s*\\d+\\s+\\d)|(^Total)");
314 if ($trace =~ s/^\s+(\d+)\s+bytes from:$//m) {
316 #push @errors, "Wrong calls to $method." unless $num_calls == $num;
317 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
320 my $fm = pop @frames;
321 $fm = pop @frames if $fm =~ /wrapper/;
322 push @errors, "Wrong frame $fm for alloc of $type." unless $dm eq $fm;
325 push @errors, "No alloc frames for $type.";
330 sub check_heapshot_traces
335 my $section = get_section ($report, "Heap");
336 $section = get_heap_shot ($section, $hshot);
337 foreach my $type (keys %types) {
338 my @desc = @{$types{$type}};
339 my $num = shift @desc;
340 my $rtype = shift @desc;
341 my $trace = get_delim_data ($section, "\\s+\\d+\\s+\\d+\\s+\\d+\\s+\Q$type\E", "^\\s*\\d+\\s+\\d");
342 if ($trace =~ s/^\s+(\d+)\s+references from:\s+\Q$rtype\E$//m) {
344 push @errors, "Wrong num refs to $type from $rtype." unless $num_refs == $num;
346 push @errors, "No refs to $type from $rtype.";
351 sub check_exception_traces
355 my $section = get_section ($report, "Exception");
356 foreach my $d (@etraces) {
358 my $num = shift @desc;
359 my $trace = get_delim_data ($section, "^\\s+$num\\s+throws from:\$", "^\\s+(\\d+|Executed)");
360 if (length ($trace)) {
361 my @frames = map {s/^\s+(.*)\s*$/$1/; $_} split (/\n/, $trace);
364 my $fm = pop @frames;
365 push @errors, "Wrong frame '$fm' in exceptions (should be '$dm')." unless $dm eq $fm;
368 push @errors, "No exceptions or incorrect number.";
373 sub check_report_samples
377 my $section = get_section ($report, "Statistical");
378 foreach my $method (keys %calls) {
379 push @errors, "Wrong samples for $method." unless ($section =~ /\d+\s+(\d+\.\d+)\s+\Q$method\E/s && $1 >= $calls{$method});
383 sub check_report_allocation
387 my $section = get_section ($report, "Allocation");
388 foreach my $type (keys %allocs) {
389 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E$/m) {
390 push @errors, "Wrong allocs for type $type." unless $1 >= $allocs{$type};
392 push @errors, "No allocs for type $type.";
397 sub check_report_heapshot
402 my %allocs = %{$typemap};
403 my $section = get_section ($report, "Heap");
404 $section = get_heap_shot ($section, $hshot);
405 foreach my $type (keys %allocs) {
406 if ($section =~ /\d+\s+(\d+)\s+\d+\s+\Q$type\E(\s+\(bytes.*\))?$/m) {
407 push @errors, "Wrong heapshot for type $type at $hshot ($1, $allocs{$type})." unless $1 >= $allocs{$type};
409 push @errors, "No heapshot for type $type at heapshot $hshot.";
417 my $min_methods = shift || 1;
418 my $min_code = shift || 16;
419 my $section = get_section ($report, "JIT");
420 push @errors, "Not enough compiled method." unless (($section =~ /Compiled methods:\s(\d+)/s) && ($1 >= $min_methods));
421 push @errors, "Not enough compiled code." unless (($section =~ /Generated code size:\s(\d+)/s) && ($1 >= $min_code));
424 sub check_report_locks
427 my $contentions = shift;
428 my $acquired = shift;
429 my $section = get_section ($report, "Monitor");
430 push @errors, "Not enough contentions." unless (($section =~ /Lock contentions:\s(\d+)/s) && ($1 >= $contentions));
431 push @errors, "Not enough acquired locks." unless (($section =~ /Lock acquired:\s(\d+)/s) && ($1 >= $acquired));
434 sub check_report_exceptions
439 my $finallies = shift;
440 my $section = get_section ($report, "Exception");
441 push @errors, "Not enough throws." unless (($section =~ /Throws:\s(\d+)/s) && ($1 >= $throws));
442 push @errors, "Not enough catches." unless (($section =~ /Executed catch clauses:\s(\d+)/s) && ($1 >= $catches));
443 push @errors, "Not enough finallies." unless (($section =~ /Executed finally clauses:\s(\d+)/s) && ($1 >= $finallies));
446 sub check_report_threads
450 my $section = get_section ($report, "Thread");
451 foreach my $tname (@threads) {
452 push @errors, "Missing thread $tname." unless $section =~ /Thread:.*name:\s"\Q$tname\E"/s;