t/profiling/profiling.t

   1 #!./parrot-nqp
   2
   3 # Copyright (C) 2010, Parrot Foundation.
   4 # $Id$
   5
   6 INIT {
   7     pir::load_bytecode('ProfTest.pbc');
   8 }
   9
  10
  11 plan(12);
  12
  13 my $pir_code :=
  14 '.sub main
  15   say "what"
  16 .end';
  17
  18 my $prof := ProfTest::PIRProfile.new($pir_code);
  19
  20
  21 ok(1, "profile creation didn't explode");
  22
  23 #Does the profile have a version string?
  24 my $matcher := ProfTest::Matcher.new(
  25     version()
  26 );
  27
  28 ok( $matcher.matches($prof), "profile has a version number");
  29
  30 #Does the profile have a CLI invocation?
  31 $matcher := ProfTest::Matcher.new(
  32     cli()
  33 );
  34
  35 ok( $matcher.matches($prof), "profile contains a CLI string");
  36
  37 #Does the profile have a 'say' op somewhere?
  38 $matcher := ProfTest::Matcher.new(
  39     op('say')
  40 );
  41
  42 ok( $matcher.matches($prof), "profile has a say op");
  43
  44 #Does the profile have expected timing values?
  45 $matcher := ProfTest::Matcher.new(
  46     op('say', :time(1))
  47 );
  48
  49 ok( $matcher.matches($prof), "profile has canonical timing information");
  50
  51 #Does the matcher fail to find the non-existent 'lollercoaster' opcode?
  52 $matcher := ProfTest::Matcher.new(
  53     op('lollercoaster')
  54 );
  55
  56 ok( !$matcher.matches($prof), "matcher didn't find non-existent opcode");
  57
  58 #Does the profile show a 'say' op inside the 'main' sub?
  59 $matcher := ProfTest::Matcher.new(
  60     cs(:ns('main')),
  61     any(:except('cs')),
  62     op('say'),
  63 );
  64
  65 ok( $matcher.matches($prof), "profile shows 'say' inside main sub");
  66
  67
  68 $pir_code :=
  69 ".sub first :main
  70   .local int i
  71   i = 0
  72   'second'()
  73   inc i
  74 .end
  75
  76 .sub second
  77   .local pmc p
  78   p = new ['Interger']
  79   p = 1
  80 .end";
  81
  82 $prof := ProfTest::PIRProfile.new($pir_code);
  83
  84 $matcher := ProfTest::Matcher.new(
  85     cs(:ns('parrot;first'),  :slurp_until('cs')),
  86     cs(:ns('parrot;second'), :slurp_until('cs')),
  87     cs(:ns('parrot;first')),
  88 );
  89
  90 ok( $matcher.matches($prof), "profile properly reflects normal control flow (simple)");
  91
  92
  93 $pir_code :=
  94 ".sub first :main
  95   .local int i
  96   i = 0
  97   'second'()
  98   inc i
  99 .end
 100
 101 .sub second
 102   .local pmc p
 103   p = new ['Interger']
 104   'third'()
 105   p = 1
 106 .end
 107
 108 .sub third
 109   say 'in third'
 110 .end";
 111
 112 $prof := ProfTest::PIRProfile.new($pir_code);
 113
 114 $matcher := ProfTest::Matcher.new(
 115     cs(:ns('parrot;first'),  :slurp_until('cs')),
 116     cs(:ns('parrot;second'), :slurp_until('cs')),
 117     cs(:ns('parrot;third'),  :slurp_until('cs')),
 118     cs(:ns('parrot;second'), :slurp_until('cs')),
 119     cs(:ns('parrot;first')),
 120 );
 121
 122 ok( $matcher.matches($prof), "profile properly reflects normal control flow (slightly less simple)");
 123
 124
 125 #test: main calls foo, foo tailcalls bar, bar returns to main
 126 $pir_code :=
 127 ".sub first :main
 128   .local int i
 129   i = 'foo'(9)
 130   say i
 131 .end
 132
 133 .sub foo
 134   .param int i
 135   i = i * i
 136   .tailcall bar(i)
 137 .end
 138
 139 .sub bar
 140   .param int i
 141   i = i + 2
 142   .return (i)
 143 .end";
 144
 145 $prof := ProfTest::PIRProfile.new($pir_code);
 146
 147 $matcher := ProfTest::Matcher.new(
 148     cs(:ns('parrot;first'), :slurp_until('cs')),
 149     cs(:ns('parrot;foo'),   :slurp_until('cs')),
 150     cs(:ns('parrot;bar'),   :slurp_until('cs')),
 151     cs(:ns('parrot;first')),
 152 );
 153
 154 ok( $matcher.matches($prof), "profile properly reflects tailcall control flow");
 155
 156
 157 #Does the profile show a 'say' op on line 2?
 158 $matcher := ProfTest::Matcher.new(
 159     op('say', :line('3')),
 160 );
 161
 162 ok( $matcher.matches($prof), "profile shows say on the correct line");
 163
 164
 165 my $nqp_code :=
 166 'main();
 167 sub main() {
 168     pir::say("nqp");
 169 }';
 170
 171 $prof := ProfTest::NQPProfile.new($nqp_code);
 172
 173 $matcher := ProfTest::Matcher.new(
 174     cs(:ns('parrot;main') ),
 175     any(:except('cs')),
 176     op('say'),
 177 );
 178
 179 ok( $matcher.matches($prof), "profile shows 'say' inside nqp sub");
 180
 181 #convenience subs to avoid repetitive typing and visual noise
 182
 183 sub version(*@p, *%n) { ProfTest::Want::Version.new(|@p, |%n) }
 184 sub cli(*@p, *%n)     { ProfTest::Want::CLI.new(|@p, |%n) }
 185 sub eor(*@p, *%n)     { ProfTest::Want::EndOfRunloop.new(|@p, |%n) }
 186 sub op(*@p, *%n)      { ProfTest::Want::Op.new(|@p, |%n) }
 187 sub cs(*@p, *%n)      { ProfTest::Want::CS.new(|@p, |%n) }
 188 sub any(*@p, *%n)     { ProfTest::Want::Any.new(|@p, |%n) }
 189
 190 # Local Variables:
 191 #   mode: perl6
 192 #   fill-column: 100
 193 # End:
 194 # vim: expandtab shiftwidth=4 ft=perl6