[svn:parrot] r45320 - in trunk: . config/gen/makefiles lib/Parrot/Harness runtime/parrot/library/ProfTest t/profiling

cotto at svn.parrot.org cotto at svn.parrot.org
Tue Mar 30 16:00:06 UTC 2010


Author: cotto
Date: Tue Mar 30 16:00:01 2010
New Revision: 45320
URL: https://trac.parrot.org/parrot/changeset/45320

Log:
[profiling] manually apply a diff from the profiling testing branch because svn-- can't sync the branch

Added:
   trunk/runtime/parrot/library/ProfTest/
   trunk/runtime/parrot/library/ProfTest/Matcher.nqp
   trunk/runtime/parrot/library/ProfTest/NQPProfile.nqp
   trunk/runtime/parrot/library/ProfTest/PIRProfile.nqp
   trunk/runtime/parrot/library/ProfTest/Want.nqp
   trunk/t/profiling/
   trunk/t/profiling/profiling.t
Modified:
   trunk/MANIFEST
   trunk/MANIFEST.SKIP
   trunk/config/gen/makefiles/root.in
   trunk/lib/Parrot/Harness/DefaultTests.pm

Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST	Tue Mar 30 14:06:34 2010	(r45319)
+++ trunk/MANIFEST	Tue Mar 30 16:00:01 2010	(r45320)
@@ -1,7 +1,7 @@
 # ex: set ro:
 # $Id$
 #
-# generated by tools/dev/mk_manifest_and_skip.pl Mon Mar 22 06:25:52 2010 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Tue Mar 30 15:58:20 2010 UT
 #
 # See below for documentation on the format of this file.
 #
@@ -1239,6 +1239,10 @@
 runtime/parrot/library/Parrot/Coroutine.pir                 [library]
 runtime/parrot/library/Parrot/Exception.pir                 [library]
 runtime/parrot/library/Pg.pir                               [library]
+runtime/parrot/library/ProfTest/Matcher.nqp                 [library]
+runtime/parrot/library/ProfTest/NQPProfile.nqp              [library]
+runtime/parrot/library/ProfTest/PIRProfile.nqp              [library]
+runtime/parrot/library/ProfTest/Want.nqp                    [library]
 runtime/parrot/library/Protoobject.pir                      [library]
 runtime/parrot/library/Range.pir                            [library]
 runtime/parrot/library/Rules.mak                            [library]
@@ -1970,6 +1974,7 @@
 t/postconfigure/02-data_get_PConfig.t                       [test]
 t/postconfigure/05-trace.t                                  [test]
 t/postconfigure/06-data_get_PConfig_Temp.t                  [test]
+t/profiling/profiling.t                                     [test]
 t/run/README                                                []doc
 t/run/exit.t                                                [test]
 t/run/options.t                                             [test]

Modified: trunk/MANIFEST.SKIP
==============================================================================
--- trunk/MANIFEST.SKIP	Tue Mar 30 14:06:34 2010	(r45319)
+++ trunk/MANIFEST.SKIP	Tue Mar 30 16:00:01 2010	(r45320)
@@ -1,6 +1,6 @@
 # ex: set ro:
 # $Id$
-# generated by tools/dev/mk_manifest_and_skip.pl Thu Mar 25 00:51:24 2010 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Tue Mar 30 15:54:37 2010 UT
 #
 # This file should contain a transcript of the svn:ignore properties
 # of the directories in the Parrot subversion repository. (Needed for
@@ -1062,6 +1062,11 @@
 ^t/tools/pmc2c\..*\.h/
 ^t/tools/pmc2c\..*\.pmc$
 ^t/tools/pmc2c\..*\.pmc/
+# generated from svn:ignore of 'tools/build/'
+^tools/build/dynoplibs\.pl$
+^tools/build/dynoplibs\.pl/
+^tools/build/dynpmc\.pl$
+^tools/build/dynpmc\.pl/
 # Local variables:
 #   mode: text
 #   buffer-read-only: t

Modified: trunk/config/gen/makefiles/root.in
==============================================================================
--- trunk/config/gen/makefiles/root.in	Tue Mar 30 14:06:34 2010	(r45319)
+++ trunk/config/gen/makefiles/root.in	Tue Mar 30 16:00:01 2010	(r45320)
@@ -295,6 +295,11 @@
 #IF(has_opengl):    $(LIBRARY_DIR)/OpenGL_funcs.pbc \
 #IF(has_opengl):    $(LIBRARY_DIR)/OpenGL/Math.pbc \
     $(LIBRARY_DIR)/P6object.pbc \
+    $(LIBRARY_DIR)/ProfTest.pbc \
+	$(LIBRARY_DIR)/ProfTest/PIRProfile.pir \
+	$(LIBRARY_DIR)/ProfTest/NQPProfile.pir \
+	$(LIBRARY_DIR)/ProfTest/Matcher.pir \
+	$(LIBRARY_DIR)/ProfTest/Want.pir \
     $(LIBRARY_DIR)/parrotlib.pbc \
     $(LIBRARY_DIR)/pcore.pbc \
     $(LIBRARY_DIR)/pcre.pbc \
@@ -1038,6 +1043,46 @@
     @rpath_lib@ $(ALL_PARROT_LIBS) $(LINKFLAGS)
 #IF(win32):	if exist $@.manifest mt.exe -nologo -manifest $@.manifest -outputresource:$@;1
 
+#
+# Profiling runcore test supporting code
+#
+
+$(LIBRARY_DIR)/ProfTest.pbc: $(LIBRARY_DIR)/ProfTest/PIRProfile.pbc \
+	$(LIBRARY_DIR)/ProfTest/NQPProfile.pbc $(LIBRARY_DIR)/ProfTest/Matcher.pbc \
+	$(LIBRARY_DIR)/ProfTest/Want.pbc
+	$(PBC_MERGE) -o $@ $(LIBRARY_DIR)/ProfTest/PIRProfile.pbc \
+	$(LIBRARY_DIR)/ProfTest/NQPProfile.pbc $(LIBRARY_DIR)/ProfTest/Matcher.pbc \
+	$(LIBRARY_DIR)/ProfTest/Want.pbc
+
+
+$(LIBRARY_DIR)/ProfTest/PIRProfile.pbc: $(LIBRARY_DIR)/ProfTest/PIRProfile.pir
+	$(PARROT) -o $@ $(LIBRARY_DIR)/ProfTest/PIRProfile.pir
+
+$(LIBRARY_DIR)/ProfTest/PIRProfile.pir: $(LIBRARY_DIR)/ProfTest/PIRProfile.nqp $(NQP_RX)
+	$(NQP_RX) --target=pir $(LIBRARY_DIR)/ProfTest/PIRProfile.nqp > $@
+
+
+$(LIBRARY_DIR)/ProfTest/NQPProfile.pbc: $(LIBRARY_DIR)/ProfTest/NQPProfile.pir
+	$(PARROT) -o $@ $(LIBRARY_DIR)/ProfTest/NQPProfile.pir
+
+$(LIBRARY_DIR)/ProfTest/NQPProfile.pir: $(LIBRARY_DIR)/ProfTest/NQPProfile.nqp $(NQP_RX)
+	$(NQP_RX) --target=pir $(LIBRARY_DIR)/ProfTest/NQPProfile.nqp > $@
+
+
+$(LIBRARY_DIR)/ProfTest/Want.pbc: $(LIBRARY_DIR)/ProfTest/Want.pir
+	$(PARROT) -o $@ $(LIBRARY_DIR)/ProfTest/Want.pir
+
+$(LIBRARY_DIR)/ProfTest/Want.pir: $(LIBRARY_DIR)/ProfTest/Want.nqp $(NQP_RX)
+	$(NQP_RX) --target=pir $(LIBRARY_DIR)/ProfTest/Want.nqp > $@
+
+
+$(LIBRARY_DIR)/ProfTest/Matcher.pbc: $(LIBRARY_DIR)/ProfTest/Matcher.pir
+	$(PARROT) -o $@ $(LIBRARY_DIR)/ProfTest/Matcher.pir
+
+$(LIBRARY_DIR)/ProfTest/Matcher.pir: $(LIBRARY_DIR)/ProfTest/Matcher.nqp $(NQP_RX)
+	$(NQP_RX) --target=pir $(LIBRARY_DIR)/ProfTest/Matcher.nqp > $@
+
+
 
 ###############################################################################
 #

Modified: trunk/lib/Parrot/Harness/DefaultTests.pm
==============================================================================
--- trunk/lib/Parrot/Harness/DefaultTests.pm	Tue Mar 30 14:06:34 2010	(r45319)
+++ trunk/lib/Parrot/Harness/DefaultTests.pm	Tue Mar 30 16:00:01 2010	(r45320)
@@ -86,6 +86,7 @@
     t/compilers/tge/*.t
     t/library/*.t
     t/tools/*.t
+    t/profiling/*.t
 );
 
 # configure tests are tests to be run at the beginning of 'make test';

Added: trunk/runtime/parrot/library/ProfTest/Matcher.nqp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/runtime/parrot/library/ProfTest/Matcher.nqp	Tue Mar 30 16:00:01 2010	(r45320)
@@ -0,0 +1,88 @@
+
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+class ProfTest::Matcher is Hash;
+
+method new(*@wants) {
+    self<wants> := ();
+    for @wants -> $want {
+        self<wants>.push($want);
+        self.say("pushed a thing:"~$want.get_str);
+    }
+    self<wants>.push(
+        ProfTest::Want::Goal.new()
+    );
+    self;
+}
+
+method matches($profile) {
+
+    my @backtracks := ();
+    my $line_idx   := 0;
+    my $want_idx   := 0;
+    my $start_line := 0;
+    my $max_line   := +$profile.profile_array;
+
+    my $curr_line;
+    my $curr_want;
+
+    while ($line_idx < $max_line) {
+
+        $curr_line := $profile.profile_array[$line_idx];
+        $curr_want := self<wants>[$want_idx];
+        self.say("current want: "~$curr_want.get_str);
+        self.say("current line: "~ ~$curr_line);
+
+        if $curr_want.goal {
+            self.say("SUCCESS\n");
+            return 1;
+        }
+        elsif ($curr_want.accepts($curr_line)) {
+
+            self.say("ACCEPTED");
+            $line_idx++;
+            # +0 is a workaround for crappy lvalue semantics
+            @backtracks.push( [$line_idx+0, $want_idx+0] );
+            self.say("saving line $line_idx, want $want_idx");
+            self.say("now have "~ ~@backtracks ~ " elements in the stack");
+            $want_idx++;
+        }
+        else {
+            self.say("REJECTED");
+            if !@backtracks && $start_line == $max_line {
+                self.say("FAILURE\n");
+                return 0;
+            }
+            elsif !@backtracks {
+                $start_line++;
+                $line_idx := $start_line+0;
+                self.say("FAILURE: restarting at $line_idx\n");
+            }
+            else {
+                my @a := @backtracks.pop;
+                $line_idx := @a[0];
+                $want_idx := @a[1];
+                self.say("backtracking to line $line_idx, want $want_idx");
+                self.say("now have "~ ~@backtracks ~ " elements in the stack");
+            }
+        }
+        self.say('');
+    }
+}
+
+method say($str) {
+    if self<debugging> {
+        pir::say($str);
+    }
+}
+
+method debugging($i) {
+    self<debugging> := $i+0;
+}
+
+# Local Variables:
+#   mode: perl6
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=perl

Added: trunk/runtime/parrot/library/ProfTest/NQPProfile.nqp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/runtime/parrot/library/ProfTest/NQPProfile.nqp	Tue Mar 30 16:00:01 2010	(r45320)
@@ -0,0 +1,17 @@
+
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+class ProfTest::NQPProfile is ProfTest::PIRProfile;
+
+method new($nqp_code, $canonical? = 1) {
+    my $nqp_compiler := pir::compreg__ps("NQP-rx");
+    my $pir_code     := $nqp_compiler.compile($nqp_code, :target('pir'));
+    ProfTest::PIRProfile.new($pir_code, $canonical);
+}
+
+# Local Variables:
+#   mode: perl6
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=perl

Added: trunk/runtime/parrot/library/ProfTest/PIRProfile.nqp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/runtime/parrot/library/ProfTest/PIRProfile.nqp	Tue Mar 30 16:00:01 2010	(r45320)
@@ -0,0 +1,94 @@
+
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+class ProfTest::PIRProfile is Hash;
+
+method new($pir_code, $canonical? = 1) {
+    self<canonical> := $canonical;
+    self<pir_code>  := $pir_code;
+    self.build_pir_profile;
+    self.build_profile_array;
+    self;
+}
+
+method profile_array() {
+    self<profile_array>;
+}
+
+method build_profile_array() {
+
+    my @pprof_lines := pir::split("\n", self<profile>);
+    self<profile_array> := ();
+
+    grammar pprof_line {
+        rule TOP { ^^ [ <variable_line> | <fixed_line> ] $$ }
+
+        rule line_type { [ 'VERSION' | 'CLI' | 'END_OF_RUNLOOP' | 'CS' | 'OP' ] }
+
+        rule fixed_line { <line_type> ':' <fixed_data> }
+        rule fixed_data { \N* }
+
+        rule variable_line { <line_type> ':' <variable_data>* }
+        rule variable_data { '{x{' <field_name> ':' <field_data> '}x}' }
+        rule field_name    { <.ident> }
+        #XXX: really need to find something better 
+        rule field_data    { <[a..zA..Z0..9_\-;\/.]>* }
+    }
+
+    for @pprof_lines -> $line {
+        my $line_match := pprof_line.parse($line);
+        #pir::say($line);
+        #_dumper($line_match);
+        self<profile_array>.push($line_match);
+    }
+}
+
+method build_pir_profile() {
+
+    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(self<pir_code>);
+    $fh.close();
+
+    my %config := self.get_config();
+    my $parrot_exe := %config<prefix> ~ %config<slash> ~ %config<test_prog>;
+    my $hash_seed_opt := '';
+
+    my %env := pir::new__p_sc('Env');
+    %env{'PARROT_PROFILING_FILENAME'} := $tmp_pprof;
+    if self<canonical> {
+        %env{'PARROT_PROFILING_CANONICAL_OUTPUT'} := 1;
+        $hash_seed_opt := '--hash-seed=1234';
+    }
+
+    my $cli := "$parrot_exe $hash_seed_opt --runcore profiling $tmp_pir";
+
+    my $pipe := pir::new__p_sc('FileHandle');
+    $pipe.open($cli, "rp");
+    $pipe.readall();
+    self<exit_status> := $pipe.exit_status();
+
+    my $pprof_fh  := pir::new__p_sc('FileHandle');
+    self<profile> := $pprof_fh.readall($tmp_pprof);
+
+    pir::new__p_sc('OS').rm($tmp_pir);
+    pir::new__p_sc('OS').rm($tmp_pprof);
+}
+
+method get_config() {
+    return Q:PIR {
+        .include 'iglobals.pasm'
+        .local pmc i
+        i = getinterp
+        %r = i[.IGLOBALS_CONFIG_HASH]
+    };
+}
+
+# Local Variables:
+#   mode: perl6
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=perl

Added: trunk/runtime/parrot/library/ProfTest/Want.nqp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/runtime/parrot/library/ProfTest/Want.nqp	Tue Mar 30 16:00:01 2010	(r45320)
@@ -0,0 +1,204 @@
+
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+class ProfTest::Want is Hash;
+
+method new() { die('...'); }
+
+method accepts() { 1; }
+
+method hashify_profile_data($data) {
+    my %h := {};
+    for $data -> $match {
+        %h{ $match<field_name> } := $match<field_data>;
+    }
+    %h;
+}
+
+method goal() { 0; }
+
+
+class ProfTest::Want::Goal;
+
+method new() { self; }
+
+method goal() { 1; }
+
+method get_str() { 'Goal' };
+
+
+
+class ProfTest::Want::Any is ProfTest::Want;
+
+method new(@except?) {
+    self<except> := @except;
+    self;
+}
+
+method accepts($prof_line) {
+    my $line_type := $prof_line<variable_line> ?? 
+        $prof_line<variable_line><line_type> !! 
+        $prof_line<variable_line><line_type> ;
+
+    for self<except> -> $except_type {
+        if $except_type eq $line_type {
+            return 0;
+        }
+    }
+    return 1;
+}
+
+method get_str() {
+    my $str := 'Any(';
+    if self<except> {
+        $str := $str ~ 'except(' ~ join(',', self<except>) ~ '),';
+    }
+    $str := $str ~ ')';
+    $str;
+}
+
+
+
+class ProfTest::Want::Version is ProfTest::Want;
+
+method new($version?) {
+    self<version>   := $version;
+    self;
+}
+
+method accepts($prof_line) {
+    if $prof_line<fixed_line> &&
+        $prof_line<fixed_line><line_type> eq 'VERSION' {
+        return 1;
+    }
+}
+
+method get_str() {
+    my $str := 'Version(';
+    if self<version> {
+        $str := $str ~ 'version(' ~ self<version> ~ ')';
+    }
+    $str := $str ~ ')';
+    $str;
+}
+
+
+
+class ProfTest::Want::CLI is ProfTest::Want;
+
+method new() { 
+    self;
+}
+
+method accepts($prof_line) {
+    if $prof_line<fixed_line> &&
+        $prof_line<fixed_line><line_type> eq 'CLI' {
+        return 1;
+    }
+}
+
+method get_str() { "CLI()" }
+
+
+
+class ProfTest::Want::EndOfRunloop is ProfTest::Want;
+
+method new() { self; }
+
+method accepts($prof_line) {
+    if $prof_line<fixed_line> &&
+        $prof_line<fixed_line><line_type> eq 'END_OF_RUNLOOP' {
+        return 1;
+    }
+}
+
+method get_str() { 'EndOfRunloop()' }
+
+
+
+class ProfTest::Want::Op is ProfTest::Want;
+
+method new($name, $line?) {
+    self<name> := $name;
+    if $line {
+        self<line> := $line;
+    }
+    self;
+}
+
+method accepts($prof_line) {
+    if $prof_line<variable_line> && $prof_line<variable_line><line_type> eq 'OP' {
+        my %variable_data := self.hashify_profile_data($prof_line<variable_line><variable_data>);
+        if self<name> ne %variable_data<op> {
+            return 0;
+        }
+        if self<line> && self<line> != %variable_data<line> {
+            return 0;
+        }
+        return 1;
+    }
+    return 0;
+}
+
+method get_str() {
+    my $str := 'Op(' ~ self<name>;
+    if self<line> {
+        $str := $str ~ ', :line(' ~ self<line> ~ ')';
+    }
+    $str := $str ~ ')';
+    $str;
+}
+
+
+
+class ProfTest::Want::CS is ProfTest::Want;
+
+method new(:$ns?, :$slurp_until?) {
+    self<ns> := $ns;
+    if $slurp_until {
+        self<slurp_until> := $slurp_until;
+    }
+    self<found_cs> := 0;
+    self;
+}
+
+method accepts($prof_line) {
+    if self<found_cs> && self<slurp_until> {
+        if pir::downcase($prof_line<variable_line><line_type>) ne self<slurp_until> {
+            return 1;
+        }
+        return 0;
+    }
+    elsif $prof_line<variable_line> && $prof_line<variable_line><line_type> eq 'CS' {
+        if !self<ns> {
+            self<found_cs> := 1;
+            return 1;
+        }
+        my %h := self.hashify_profile_data($prof_line<variable_line><variable_data>);
+        if %h<ns> eq self<ns> {
+            self<found_cs> := 1;
+            return 1;
+        }
+    }
+    return 0;
+}
+
+method get_str() {
+    my $str := 'CS(';
+    if self<ns> {
+        $str := $str ~ ':ns(' ~ self<ns> ~ ')';
+    }
+    if self<slurp_until> {
+        $str := $str ~ ', :slurp_until(' ~ self<slurp_until> ~ ')';
+    }
+    $str := $str ~ ')';
+    $str;
+}
+
+
+# Local Variables:
+#   mode: perl6
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=perl

Added: trunk/t/profiling/profiling.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/t/profiling/profiling.t	Tue Mar 30 16:00:01 2010	(r45320)
@@ -0,0 +1,194 @@
+#!./parrot-nqp
+
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+INIT {
+    pir::load_bytecode('ProfTest.pbc');
+}
+
+
+plan(12);
+
+my $pir_code := 
+'.sub main
+  say "what"
+.end';
+
+my $prof := ProfTest::PIRProfile.new($pir_code);
+
+
+ok(1, "profile creation didn't explode");
+
+#Does the profile have a version string?
+my $matcher := ProfTest::Matcher.new(
+    version()
+);
+
+ok( $matcher.matches($prof), "profile has a version number");
+
+#Does the profile have a CLI invocation?
+$matcher := ProfTest::Matcher.new(
+    cli()
+); 
+
+ok( $matcher.matches($prof), "profile contains a CLI string");
+
+#Does the profile have a 'say' op somewhere?
+$matcher := ProfTest::Matcher.new(
+    op('say')
+);
+
+ok( $matcher.matches($prof), "profile has a say op");
+
+#Does the profile have expected timing values?
+$matcher := ProfTest::Matcher.new(
+    op('say', :time(1))
+);
+
+ok( $matcher.matches($prof), "profile has canonical timing information");
+
+#Does the matcher fail to find the non-existent 'lollercoaster' opcode?
+$matcher := ProfTest::Matcher.new(
+    op('lollercoaster')
+);
+
+ok( !$matcher.matches($prof), "matcher didn't find non-existent opcode");
+
+#Does the profile show a 'say' op inside the 'main' sub?
+$matcher := ProfTest::Matcher.new(
+    cs(:ns('main')),
+    any(:except('cs')),
+    op('say'),
+);
+ 
+ok( $matcher.matches($prof), "profile shows 'say' inside main sub");
+
+
+$pir_code :=
+".sub first :main
+  .local int i
+  i = 0
+  'second'()
+  inc i
+.end
+
+.sub second
+  .local pmc p
+  p = new ['Interger']
+  p = 1
+.end";
+
+$prof := ProfTest::PIRProfile.new($pir_code);
+
+$matcher := ProfTest::Matcher.new(
+    cs(:ns('parrot;first'),  :slurp_until('cs')),
+    cs(:ns('parrot;second'), :slurp_until('cs')),
+    cs(:ns('parrot;first')),
+);
+
+ok( $matcher.matches($prof), "profile properly reflects normal control flow (simple)");
+
+
+$pir_code :=
+".sub first :main
+  .local int i
+  i = 0
+  'second'()
+  inc i
+.end
+
+.sub second
+  .local pmc p
+  p = new ['Interger']
+  'third'()
+  p = 1
+.end
+
+.sub third
+  say 'in third'
+.end";
+
+$prof := ProfTest::PIRProfile.new($pir_code);
+
+$matcher := ProfTest::Matcher.new(
+    cs(:ns('parrot;first'),  :slurp_until('cs')),
+    cs(:ns('parrot;second'), :slurp_until('cs')),
+    cs(:ns('parrot;third'),  :slurp_until('cs')),
+    cs(:ns('parrot;second'), :slurp_until('cs')),
+    cs(:ns('parrot;first')),
+);
+
+ok( $matcher.matches($prof), "profile properly reflects normal control flow (slightly less simple)");
+
+
+#test: main calls foo, foo tailcalls bar, bar returns to main
+$pir_code :=
+".sub first :main
+  .local int i
+  i = 'foo'(9)
+  say i
+.end
+
+.sub foo
+  .param int i
+  i = i * i
+  .tailcall bar(i)
+.end
+
+.sub bar
+  .param int i
+  i = i + 2
+  .return (i)
+.end";
+
+$prof := ProfTest::PIRProfile.new($pir_code);
+
+$matcher := ProfTest::Matcher.new(
+    cs(:ns('parrot;first'), :slurp_until('cs')),
+    cs(:ns('parrot;foo'),   :slurp_until('cs')),
+    cs(:ns('parrot;bar'),   :slurp_until('cs')),
+    cs(:ns('parrot;first')),
+);
+
+ok( $matcher.matches($prof), "profile properly reflects tailcall control flow");
+
+
+#Does the profile show a 'say' op on line 2?
+$matcher := ProfTest::Matcher.new(
+    op('say', :line('3')),
+);
+
+ok( $matcher.matches($prof), "profile shows say on the correct line");
+
+
+my $nqp_code :=
+'main();
+sub main() {
+    pir::say("nqp");
+}';
+
+$prof := ProfTest::NQPProfile.new($nqp_code);
+
+$matcher := ProfTest::Matcher.new(
+    cs(:ns('parrot;main') ),
+    any(:except('cs')), 
+    op('say'),
+);
+
+ok( $matcher.matches($prof), "profile shows 'say' inside nqp sub");
+
+#convenience subs to avoid repetitive typing and visual noise
+
+sub version(*@p, *%n) { ProfTest::Want::Version.new(|@p, |%n) }
+sub cli(*@p, *%n)     { ProfTest::Want::CLI.new(|@p, |%n) }
+sub eor(*@p, *%n)     { ProfTest::Want::EndOfRunloop.new(|@p, |%n) }
+sub op(*@p, *%n)      { ProfTest::Want::Op.new(|@p, |%n) }
+sub cs(*@p, *%n)      { ProfTest::Want::CS.new(|@p, |%n) }
+sub any(*@p, *%n)     { ProfTest::Want::Any.new(|@p, |%n) }
+
+# Local Variables:
+#   mode: perl6
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=perl6


More information about the parrot-commits mailing list