[svn:parrot] r45144 - in branches/profiling_testing: runtime/parrot/library/ProfTest t/profiling

cotto at svn.parrot.org cotto at svn.parrot.org
Wed Mar 24 04:19:12 UTC 2010


Author: cotto
Date: Wed Mar 24 04:19:05 2010
New Revision: 45144
URL: https://trac.parrot.org/parrot/changeset/45144

Log:
[profiling] add some initial non-runnable test cases
supporting code will be added later

Added:
   branches/profiling_testing/runtime/parrot/library/ProfTest/
   branches/profiling_testing/runtime/parrot/library/ProfTest/ProfTest.nqp
Replaced:
   branches/profiling_testing/t/profiling/profiling.t

Added: branches/profiling_testing/runtime/parrot/library/ProfTest/ProfTest.nqp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ branches/profiling_testing/runtime/parrot/library/ProfTest/ProfTest.nqp	Wed Mar 24 04:19:05 2010	(r45144)
@@ -0,0 +1,77 @@
+#!/usr/bin/env parrot-nqp
+
+INIT {
+    # Load the Test::More library
+    pir::load_language('parrot');
+    pir::compreg__PS('parrot').import('Test::More');
+
+    pir::load_bytecode('dumper.pbc');
+}
+
+
+sub get_profile_array($pprof) {
+
+    my @pprof_lines := pir::split("\n", $pprof);
+    my @pprof := ();
+
+    grammar pprof_line {
+        rule TOP { ^^ [ <fixed_line> | <variable_line> ] $$ }
+        
+        rule fixed_line      { <fixed_line_type> ':' <fixed_line_data> }
+        rule fixed_line_type { [ 'VERSION' | 'CLI' | 'END_OF_RUNLOOP' ] }
+        rule fixed_line_data { \N* }
+
+        rule variable_line      { <variable_line_type> ':' <variable_line_data>* }
+        rule variable_line_type { [ 'CS' | 'OP' ] }
+        rule variable_line_data { '{x{' <field_name> ':' <field_data> '}x}' }
+        rule field_name         { <.ident> }
+        rule field_data         { <[a..zA..Z0..9_\-]>* }
+    }
+
+    for @pprof_lines -> $line {
+        my $line_match := pprof_line.parse($line);
+        #pir::say($line);
+        _dumper($line_match);
+        @pprof.push($line_match);
+    }
+    @pprof;
+}
+
+sub get_profile_from_pir($pir, $canonical? = 1) {
+
+    my $tmp_pir := '/tmp/test.pir';
+    my $tmp_pprof := '/tmp/test.pprof';
+    my $fh := pir::new__p_sc('FileHandle');
+    $fh.open($tmp_pir, "w");
+    $fh.puts($pir);
+    $fh.close();
+
+    my %env := pir::new__p_sc('Env');
+    %env{'PARROT_PROFILING_FILENAME'} := $tmp_pprof;
+    if $canonical {
+        %env{'PARROT_PROFILING_CANONICAL_OUTPUT'} := 1;
+    }
+    
+    my %config := get_config();
+    my $parrot_exe := %config<prefix> ~ %config<slash> ~ %config<test_prog>;
+
+    my $cli := "$parrot_exe --hash-seed=1234 --runcore profiling $tmp_pir";  
+
+    my $pipe := pir::new__p_sc('FileHandle');
+    $pipe.open($cli, "rp");
+    $pipe.readall();
+    my $exit_status := $pipe.exit_status();
+
+    my $pprof_fh := pir::new__p_sc('FileHandle');
+    $pprof_fh.readall($tmp_pprof);
+}
+
+sub get_config() {
+    return Q:PIR {
+        .include 'iglobals.pasm'
+        .local pmc i
+        i = getinterp
+        %r = i[.IGLOBALS_CONFIG_HASH]
+    };
+}
+        

Added: branches/profiling_testing/t/profiling/profiling.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ branches/profiling_testing/t/profiling/profiling.t	Wed Mar 24 04:19:05 2010	(r45144)
@@ -0,0 +1,72 @@
+#!/usr/bin/env parrot-nqp
+
+INIT {
+    pir::load_bytecode('ProfTest/ProfTest.pbc');
+}
+
+# XXX: Don't bother tryting to run these tests.  None of the supporting code
+# exists.  This code is only here to help me figure out the final interface.
+
+my $pir_code := 
+'.sub main
+  say "what"
+.end';
+
+my $prof := ProfTest::PirProfile.new($pir);
+
+#Does the profile have a version string?
+my $matcher := ProfTest::Matcher.new();
+$matcher.push( ProfTest::Want::Version() ): #use count=1 by default
+
+
+ok( $matcher.matches($prof), "profile has a version number");
+
+#Does the profile have a CLI invocation?
+$matcher := ProfTest::Matcher.new();
+$matcher.push( ProfTest::Want::CLI() );
+
+ok( $matcher.matches($prof), "profile contains a CLI string");
+
+
+#Does the profile have a 'say' op somewhere?
+$matcher := ProfTest::Matcher.new();
+$matcher.push( ProfTest::Want::Op( 'say' ));
+
+ok( $matcher.matches($prof), "profile has a say op");
+
+
+#Does the profile show a 'say' op inside the 'main' sub?
+$matcher := ProfTest::Matcher.new(
+    ProfTest::Want::CS.new( :ns('main')),
+    ProfTest::Want.new( :count('*'), :type_isnt('CS')),
+    ProfTest::Want::Op.new( :op('say')),
+);
+ 
+ok( $matcher.matches($prof), "profile shows 'say' inside main sub");
+
+
+#Does the profile show a 'say' op on line 2?
+$match := ProfTest::Matcher.new();
+$matcher.push (ProfTest::Want::Op.new( :count(1), :op('say'), :line('2')));
+
+ok( $matcher.matches($prof), "profile shows say on the correct line");
+
+
+
+#test: main calls foo, foo tailcalls bar, bar returns to main
+
+my $nqp_code := '
+main();
+sub main() {
+    pir:say("nqp");
+}';
+
+$prof := ProfTest::NQPProfile.new($nqp_code);
+
+$matcher := ProfTest::Matcher.new();
+$matcher.push( ProfTest::Want::CS.new( :ns('*main') ) ); #matches parrot::foo::main
+$matcher.push( ProfTest::Want.new(    :count('*'), :type_isnt('CS') ) );
+$matcher.push( ProfTest::Want::Op.new( :op('say') ) );
+
+ok( $matcher.matches($prof), "profile shows 'say' inside nqp sub");
+


More information about the parrot-commits mailing list