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