I hope this is an appropriate forum, I want to get the topic off of p5p, and return there later with a more polished solution...
Rafael Garcia-Suarez wrote:
jim cromie wrote:
I picked this back up recently, I think it now incorporates all comments
from this thread started 1/6/04, plus a few off-list suggestions.
Thanks, I applied the Concise.pm part of your patch as change #22539.
I didn't apply the test patch, because : 1. you probably missed the fact that Concise returns different output with threaded and unthreaded perls 2. you gave me an idea for a Grand Plan.
The other day I added an optimisation that basically transforms my $x = undef; into my $x; but I didn't add a test for it, because I didn't knew how to do it. Thus, if we then modify the optree building in a way that breaks this optimisation, this will go unnoticed, and this is not a good thing. But your patch to B::Concise gives a tool to test such things.
So what I'd like is a new test file, let's say ext/B/t/optrees.t, that lists code snippets and expected optrees in a way perhaps inspired by the things under t/lib/warnings/*, in a way that it's easy to add new stuff ; that takes into account perl configuration differences (useithreads for example) ; and in which in the future we would add regression tests for optree optimisations. (@x = sort @x in place comes to mind as well.) What do you think about this ?
Lots to think about. But rather than start a design by committee thing, heres a strawman to start with. It falls short on the 'framework' question, but tests are still easy to add.
Attached patch pbc2.4 reworks the tests:
ext/B/t/concise.t tests B::Concise API ext/B/t/optree.t defines test function & helper calls to test-func use heredocs to give args
tests are in 3 grps;
selftests - harness works as intended.
canonical example - from B::Concise docs
may add more B::Concise tests for Outside O Framework
optimizations
my $a = undef;
@a = sort @a;BIGGEST ISSUE:
B::Concise gives different format for threaded vs non-threaded builds.
Note that the gvsv op is the only one different - in this sample.
with '[]' replaced by '()'
and leading <#> replaced by <$>[EMAIL PROTECTED] bc3]$ ./perl -Ilib -MO=Concise -e '$a++' 5 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v ->3 4 <1> preinc[t2] vK/1 ->5 - <1> ex-rv2sv sKRM/1 ->4 3 <#> gvsv[*a] s ->4 -e syntax OK
[EMAIL PROTECTED] bleadnothread]$ ./perl -Ilib -MO=Concise -e '$a++' 5 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v ->3 4 <1> preinc[t1] vK/1 ->5 - <1> ex-rv2sv sKRM/1 ->4 3 <$> gvsv(*a) s ->4 -e syntax OK
The tests now pass for both threaded and non-threaded, via a non-thread fixup stage, but is is done opcode by opcode, and WILL NEED enhancement as new opcodes are added into tests.
are threaded/non-threaded differences considered to be a feature ? is eliminating the diff a wrong-headed fix ?
diff -ru bleadperl/MANIFEST bc3/MANIFEST
--- bleadperl/MANIFEST Fri Mar 19 05:19:30 2004
+++ bc3/MANIFEST Tue Mar 23 12:15:49 2004
@@ -118,6 +118,7 @@
ext/B/t/lint.t See if B::Lint works
ext/B/Todo Compiler backend Todo list
ext/B/t/o.t See if O works
+ext/B/t/optree.t See if optimization works
ext/B/t/showlex.t See if B::ShowLex works
ext/B/t/stash.t See if B::Stash works
ext/B/t/terse.t See if B::Terse works
Only in bc3: MANIFEST~
diff -ru bleadperl/ext/B/t/concise.t bc3/ext/B/t/concise.t
--- bleadperl/ext/B/t/concise.t Tue Feb 4 14:17:24 2003
+++ bc3/ext/B/t/concise.t Tue Mar 23 01:23:03 2004
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 38;
require_ok("B::Concise");
@@ -34,4 +34,134 @@
stderr => 1,
);
-like($out, qr/print/, "-exec option with //=");
+like($out, qr/print/, "'-exec' option output has print opcode");
+
+######## API tests v.60
+
+use Config; # used for perlio check
+B::Concise->import(qw(set_style set_style_standard add_callback
+ add_style walk_output));
+
+## walk_output argument checking
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { walk_output($foo) };
+ is ($@, '', "walk_output() accepts STD* " . ref $foo);
+}
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string",[], {}) {
+ eval { walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects arg '$foo'");
+ [EMAIL PROTECTED]''; # clear the fail for next test
+}
+
+{ # any object that can print should be ok for walk_output
+ package Hugo;
+ sub new { my $foo = bless {} };
+ sub print { CORE::print @_ }
+}
+my $foo = new Hugo; # suggested this API fix
+eval { walk_output($foo) };
+is ($@, '', "walk_output() accepts obj that can print");
+
+# now test a ref to scalar
+eval { walk_output(\my $junk) };
+is ($@, '', "walk_output() accepts ref-to-sprintf target");
+
+$junk = "non-empty";
+eval { walk_output(\$junk) };
+is ($@, '', "walk_output() accepts ref-to-non-empty-scalar");
+
+## add_style
+my @stylespec;
[EMAIL PROTECTED]'';
+eval { add_style ('junk_B' => @stylespec) };
+like ($@, 'expecting 3 style-format args',
+ "add_style rejects insufficient args");
+
[EMAIL PROTECTED] = (0,0,0); # right length, invalid values
[EMAIL PROTECTED]'';
+eval { add_style ('junk' => @stylespec) };
+is ($@, '', "add_style accepts: stylename => 3-arg-array");
+
[EMAIL PROTECTED]'';
+eval { add_style (junk => @stylespec) };
+like ($@, qr/style 'junk' already exists, choose a new name/,
+ "add_style correctly disallows re-adding same style-name" );
+
+# test new arg-checks on set_style
[EMAIL PROTECTED]'';
+eval { set_style (@stylespec) };
+is ($@, '', "set_style accepts 3 style-format args");
+
[EMAIL PROTECTED] = (); # bad style
+
+eval { set_style (@stylespec) };
+like ($@, qr/expecting 3 style-format args/,
+ "set_style rejects bad style-format args");
+
+
+#### for content with doc'd options
+
+set_style_standard('concise'); # MUST CALL b4 output needed
+my $func = sub{ $a = $b+42 };
+
[EMAIL PROTECTED] = qw(
+ -basic -exec -tree -compact -loose -vt -ascii -main
+ -base10 -bigendian -littleendian
+ );
+foreach $opt (@options) {
+ walk_output(\my $out);
+ my $treegen = B::Concise::compile($opt, $func);
+ $treegen->();
+ #print "foo:$out\n";
+ isnt($out, '', "got output with option $opt");
+}
+
+## test output control via walk_output
+
+my $treegen = B::Concise::compile('-basic', $func); # reused
+
+{ # test output into a package global string (sprintf-ish)
+ our $thing;
+ walk_output(\$thing);
+ $treegen->();
+ ok($thing, "walk_output to our SCALAR, output seen");
+}
+
+{ # test output to GLOB, using perlio feature directly
+ skip 1, "no perlio on this build" unless $Config{useperlio};
+ open (my $fh, '>', \my $buf);
+ walk_output($fh);
+ $treegen->();
+ ok($buf, "walk_output to GLOB, output seen");
+}
+
+## Test B::Concise::compile error checking
+
+# call compile on non-CODE ref items
+foreach my $ref ([], {}) {
+ my $typ = ref $ref;
+ walk_output(\my $out);
+ eval { B::Concise::compile('-basic', $ref)->() };
+ like ($@, qr/^err: not a coderef: $typ/,
+ "compile detects $typ-ref where expecting subref");
+ # is($out,'', "no output when errd"); # announcement prints
+}
+
+# test against a bogus autovivified subref.
+# in debugger, it should look like:
+# 1 CODE(0x84840cc)
+# -> &CODE(0x84840cc) in ???
+sub nosuchfunc;
+eval { B::Concise::compile('-basic', \&nosuchfunc)->() };
+like ($@, qr/^err: coderef has no START/,
+ "compile detects CODE-ref w/o actual code");
+
+foreach my $opt (qw( -concise -exec )) {
+ eval { B::Concise::compile($opt,'non_existent_function')->() };
+ like ($@, qr/unknown function \(main::non_existent_function\)/,
+ "'$opt' reports non-existent-function properly");
+}
diff -ru bleadperl/ext/B/t/optree.t bc3/ext/B/t/optree.t
--- bleadperl/ext/B/t/optree.t Tue Mar 23 12:31:07 2004
+++ bc3/ext/B/t/optree.t Tue Mar 23 17:42:31 2004
@@ -0,0 +1,299 @@
+#!perl
+
+use Test::More (tests => 19);
+
+require_ok("B::Concise");
+
+B::Concise->import(qw(set_style set_style_standard add_callback
+ add_style walk_output));
+
+my %gopts = ( rextract => 0 );
+
+if (@ARGV) {
+ $gopts{rextract} = 1;
+ print "use re 'debug';\n";
+}
+
+sub checkOptree {
+ my %opts = @_;
+ SKIP: {
+ skip 1, $opts{name} if $opts{skip};
+
+ my $treegen = B::Concise::compile($opts{option}, $opts{code});
+ die unless ref $treegen eq 'CODE';
+ my $reftext = fixup_reftext($opts{expect});
+
+ B::Concise::reset_sequence();
+ walk_output(\my $out);
+ $treegen->();
+ like ($out, qr/^$reftext$/ms, $opts{name});
+ #print "<$out>\nVS\n<$reftext>\n";
+
+ # save this output and edit for an extract of regexs
+ print ("\$str = q{$out};\n".
+ "\$rex = qr{$reftext};\n".
+ "print \"\$str =~ m{\$rex}ms \";\n".
+ "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
+ if $opts{rextract} or $gopts{rextract};
+ }
+}
+
+
+# needless complexity due to 'too much info' from B::Concise v.60
+my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
+
+sub fixup_reftext {
+ my $str = shift;
+ # converts arg to Regexp which should match against unaltered version
+ # also responsible for threaded/non-threaded adjustments
+
+ # escape metachars. manual \Q (doesnt escape '+')
+ $str =~ s/([\[\]()[EMAIL PROTECTED])/\\$1/msg;
+
+ # replace padsv, padav args
+ $str =~ s/padsv\\\[.*?\\\]/padsv\\\[.*?\\\]/msg;
+ $str =~ s/padav\\\[.*?\\\]/padav\\\[.*?\\\]/msg;
+
+ $str =~ s/add\\\[.*?\\\]/add\\\[.*?\\\]/msg;
+ $str =~ s/rv2av\\\[.*?\\\]/rv2av\\\[.*?\\\]/msg;
+
+ # replace nextstate args
+ $str =~ s/state\\\(.*?\\\) /state\\\(.*?\\\) /msg;
+
+ # leavesub fixup
+ $str =~ s/\d+ refs?/\\d+ refs?/msg;
+
+ # fix to run under debugger
+ $str =~ s/nextstate/(?:db|next)state/msg;
+
+
+ #print "str: $str";
+
+ unless ($Config::Config{usethreads}) {
+
+ # for the most part, these are ok
+ #$str =~ s/\[/\(/msg;
+ #$str =~ s/\]/\)/msg;
+
+ # hacky
+ #$str =~ s{ \\\[ } {[\\\(\\\[]}msgx;
+ #$str =~ s{ \\\] } {[\\\)\\\]]}msgx;
+
+ $str =~ s/<\\#>/<\\\$>/msg;
+
+ # these opcodes switch bracing:
+ $str =~ s/(gv\w*)\\\[.*?\\\]/$1\\\(.*?\\\)/msg;
+ $str =~ s/(const)\\\[.*?\\\]/$1\\\(.*?\\\)/msg;
+
+ }
+ return "$announce\n$str";
+}
+
+#################################
+# add new tests here
+
+# expect => $data must be from threaded builds. theyre converted for
+# use in testing on non-threaded builds.
+
+pass("REGEX TEST HARNESS SELFTEST");
+
+checkOptree ( name => "TODO: minimal search confounded by announcement",
+ option => '-exec',
+ code => sub {my $a},
+ expect => 'leavesub');
+
+checkOptree ( name => 'nextstate fixup',
+ option => '-exec',
+ code => sub {my $a},
+ #skip => 1,
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main 22 (eval 10):1) v
+2 <0> padsv[$a:-\d+,-\d+] M/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'padsv fixup',
+ option => '-exec',
+ code => sub {my $a},
+ #skip => 1,
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main 22 (eval 10):1) v
+2 <0> padsv[$a:-33,-44] M/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'unneeded manual rexification by test author',
+ option => '-exec',
+ code => sub {my $a},
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(.*?) v
+2 <0> padsv[.*?] M/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'FALSE POSITIVE: skip works silently, wo notice',
+ option => '-exec',
+ code => sub {my $a},
+ #skip => 1,
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(.*?) v
+2 <0> padsv[.*?] M/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+pass("CANONICAL B::Concise EXAMPLE");
+
+checkOptree ( name => 'canonical example: -basic',
+ option => '-basic',
+ code => sub{$a=$b+42},
+ expect => <<'=====================');
+7 <1> leavesub[\d+ refs?] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(foo bar) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t\d+] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <#> gvsv[*b] s ->3
+3 <$> const[IV 42] s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <#> gvsv[*a] s ->6
+=====================
+
+
+checkOptree ( name => 'canonical example: -concise',
+ option => '-concise',
+ code => sub{$a=$b+42},
+ expect => <<'=====================');
+7 <1> leavesub[\d+ refs?] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(foo bar) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t\d+] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <#> gvsv[*b] s ->3
+3 <$> const[IV 42] s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <#> gvsv[*a] s ->6
+=====================
+
+checkOptree ( name => 'canonical example: -exec',
+ option => '-exec',
+ code => sub{$a=$b+42},
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main 12 (eval 6):1) v
+2 <#> gvsv[*b] s
+3 <$> const[IV 42] s
+4 <2> add[t3] sK/2
+5 <#> gvsv[*a] s
+6 <2> sassign sKS/2
+7 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+
+pass("OPTIMIZER TESTS");
+
+checkOptree ( name => 'my-var no-init baseline',
+ option => '-exec',
+ code => sub {my $a},
+ #skip => 1,
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main 22 (eval 10):1) v
+2 <0> padsv[$a:-\d+,-\d+] M/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'same code, diff results 2nd time',
+ todo => 'FIX "goto" FUDGED INTO MOST TESTS',
+ option => '-exec',
+ code => sub {my $a},
+ #skip => 1,
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main 22 (eval 10):1) v
+2 <0> padsv[$a:-\d+,-\d+] M/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'my-var init w undef. This optimization is working',
+ option => '-exec',
+ code => sub {my $a=undef},
+ #skip => 1,
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main 22 (eval 10):1) v
+2 <0> padsv[$a:-\d+,-\d+] sRM*/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'TODO: my-var init w empty list',
+ todo => 'optimize out steps 2,3',
+ option => '-exec',
+ code => sub {my $a=()},
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main -439 optree.t:105) v
+2 <0> stub sP
+3 <0> padsv[$a:-439,-438] sRM*/LVINTRO
+4 <2> sassign sKS/2
+5 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+
+checkOptree ( name => 'sort baseline',
+ option => '-exec',
+ code => sub {sort @a},
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main -437 optree.t:231) v
+2 <0> pushmark s
+3 <#> gv[*a] s
+4 <1> rv2av[t2] lK/1
+5 <@> sort K
+6 <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'sort optimization',
+ option => '-exec',
+ code => sub [EMAIL PROTECTED] = sort @a},
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main -438 optree.t:244) v
+2 <0> pushmark s
+3 <0> pushmark s
+4 <#> gv[*a] s
+5 <1> rv2av[t2] lK/1
+6 <@> sort lK
+7 <0> pushmark s
+8 <#> gv[*a] s
+9 <1> rv2av[t2] lKRM*/1
+a <2> aassign[t\d+] KS/COMMON
+b <1> leavesub[1 ref] K/REFC,1
+=====================
+
+checkOptree ( name => 'sort optimization on my-var',
+ option => '-exec',
+ code => sub {my @a; @a = sort @a},
+ expect => <<'=====================');
+ goto -
+1 <;> nextstate(main -437 optree.t:254) v
+2 <0> [EMAIL PROTECTED]:-437,-436] vM/LVINTRO
+3 <;> nextstate(main -436 optree.t:256) v
+4 <0> pushmark s
+5 <0> pushmark s
+6 <0> [EMAIL PROTECTED]:-437,-436] l
+7 <@> sort lK
+8 <0> pushmark s
+9 <0> [EMAIL PROTECTED]:-437,-436] lRM*
+a <2> aassign[t\d+] KS/COMMON
+b <1> leavesub[1 ref] K/REFC,1
+=====================
+
+
+__END__
+
Only in bc3/ext/B/t: optree.t~
Only in bc3: junk
Only in bc3: junk.pl
Only in bc3: junk.pl~
Only in bc3: junk.t
Only in bc3: opmatch.t
Only in bc3: opmatch.t~
Only in bc3/t: misctmp001
