From: Vincent Pit Date: Sat, 26 Feb 2011 19:18:09 +0000 (+0100) Subject: Always skip seen ops in our peep replacement X-Git-Tag: rt66146^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=commitdiff_plain;h=a649807e15b3ab4103dbb51823950c29e7ed9fb4 Always skip seen ops in our peep replacement Sometimes, there are loops in the next chain as e.g. with infinite loops like "for (;;) { ... }". We can't reuse the op_opt member because it's almost always set after the first pass. This fixes RT #66146. --- diff --git a/MANIFEST b/MANIFEST index 53ad9ce..9d43dcd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -16,6 +16,7 @@ t/13-padsv.t t/14-ro.t t/15-constants.t t/16-scope.t +t/17-peep.t t/20-object.t t/21-tie.t t/22-magic.t diff --git a/Types.xs b/Types.xs index 8367cba..1e76369 100644 --- a/Types.xs +++ b/Types.xs @@ -145,8 +145,6 @@ typedef SV lt_hint_t; /* ... "Seen" pointer table ................................................ */ -#if !LT_HAS_RPEEP - #define PTABLE_NAME ptable_seen #define PTABLE_VAL_FREE(V) NOOP @@ -157,8 +155,6 @@ typedef SV lt_hint_t; #define ptable_seen_clear(T) ptable_seen_clear(aPTBLMS_ (T)) #define ptable_seen_free(T) ptable_seen_free(aPTBLMS_ (T)) -#endif /* !LT_HAS_RPEEP */ - /* ... Global data ......................................................... */ #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION @@ -168,9 +164,7 @@ typedef struct { ptable *tbl; /* It really is a ptable_hints */ tTHX owner; #endif -#if !LT_HAS_RPEEP ptable *seen; /* It really is a ptable_seen */ -#endif SV *default_meth; } my_cxt_t; @@ -233,9 +227,7 @@ STATIC void lt_thread_cleanup(pTHX_ void *ud) { dMY_CXT; ptable_hints_free(MY_CXT.tbl); -#if !LT_HAS_RPEEP ptable_seen_free(MY_CXT.seen); -#endif /* !LT_HAS_RPEEP */ } #endif /* LT_THREADSAFE */ @@ -653,31 +645,15 @@ STATIC OP *lt_ck_padsv(pTHX_ OP *o) { STATIC peep_t lt_old_peep = 0; /* This is actually the rpeep past 5.13.5 */ -#if !LT_HAS_RPEEP -# define LT_PEEP_REC_PROTO STATIC void lt_peep_rec(pTHX_ OP *o, ptable *seen) -#else /* !LT_HAS_RPEEP */ -# define LT_PEEP_REC_PROTO STATIC void lt_peep_rec(pTHX_ OP *o) -#endif /* LT_HAS_RPEEP */ - -LT_PEEP_REC_PROTO; -LT_PEEP_REC_PROTO { -#if !LT_HAS_RPEEP -# define lt_peep_rec(O) lt_peep_rec(aTHX_ (O), seen) -#else /* !LT_HAS_RPEEP */ -# define lt_peep_rec(O) lt_peep_rec(aTHX_ (O)) -#endif /* LT_HAS_RPEEP */ - -#if !LT_HAS_RPEEP - if (ptable_fetch(seen, o)) - return; -#endif - +STATIC void lt_peep_rec(pTHX_ OP *o, ptable *seen) { +#define lt_peep_rec(O) lt_peep_rec(aTHX_ (O), seen) for (; o; o = o->op_next) { lt_op_info *oi = NULL; -#if !LT_HAS_RPEEP + if (ptable_fetch(seen, o)) + break; ptable_seen_store(seen, o, o); -#endif + switch (o->op_type) { case OP_PADSV: if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) { @@ -731,15 +707,14 @@ LT_PEEP_REC_PROTO { } STATIC void lt_peep(pTHX_ OP *o) { -#if !LT_HAS_RPEEP dMY_CXT; ptable *seen = MY_CXT.seen; - ptable_seen_clear(seen); -#endif /* !LT_HAS_RPEEP */ - lt_old_peep(aTHX_ o); + + ptable_seen_clear(seen); lt_peep_rec(o); + ptable_seen_clear(seen); } /* --- Interpreter setup/teardown ------------------------------------------ */ @@ -761,9 +736,7 @@ STATIC void lt_teardown(pTHX_ void *root) { #if LT_THREADSAFE ptable_hints_free(MY_CXT.tbl); #endif -#if !LT_HAS_RPEEP ptable_seen_free(MY_CXT.seen); -#endif SvREFCNT_dec(MY_CXT.default_meth); } @@ -793,9 +766,7 @@ STATIC void lt_setup(pTHX) { MY_CXT.tbl = ptable_new(); MY_CXT.owner = aTHX; #endif -#if !LT_HAS_RPEEP MY_CXT.seen = ptable_new(); -#endif MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11); SvREADONLY_on(MY_CXT.default_meth); } @@ -857,9 +828,7 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; -#if !LT_HAS_RPEEP ptable *s; -#endif SV *cloned_default_meth; PPCODE: { @@ -873,17 +842,13 @@ PPCODE: cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud); lt_ptable_clone_ud_deinit(ud); } -#if !LT_HAS_RPEEP s = ptable_new(); -#endif } { MY_CXT_CLONE; MY_CXT.tbl = t; MY_CXT.owner = aTHX; -#if !LT_HAS_RPEEP MY_CXT.seen = s; -#endif MY_CXT.default_meth = cloned_default_meth; } reap(3, lt_thread_cleanup, NULL); diff --git a/t/17-peep.t b/t/17-peep.t new file mode 100644 index 0000000..87a14a5 --- /dev/null +++ b/t/17-peep.t @@ -0,0 +1,204 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 11 + 6 * 3; + +our $counter; + +sub Int::TYPEDSCALAR { ++$counter } + +{ + my $desc = 'peephole optimization of conditionals'; + + local $counter; + local $@; + my $code = eval <<' TESTCASE'; + use Lexical::Types; + sub { + if ($_[0]) { + my Int $z; + return 1; + } elsif ($_[1] || $_[2]) { + my Int $z; + return 2; + } elsif ($_[3] && $_[4]) { + my Int $z; + return 3; + } elsif ($_[5] ? $_[6] : 0) { + my Int $z; + return 4; + } else { + my Int $z; + return 5; + } + return 0; + } + TESTCASE + is $@, '', "$desc compiled fine"; + + my $ret = $code->(1); + is $counter, 1, "$desc : first branch was properly compiled"; + is $ret, 1, "$desc : first branch returned 1"; + + $ret = $code->(0, 1); + is $counter, 2, "$desc : second branch was properly compiled"; + is $ret, 2, "$desc : second branch returned 2"; + + $ret = $code->(0, 0, 0, 1, 1); + is $counter, 3, "$desc : third branch was properly compiled"; + is $ret, 3, "$desc : third branch returned 3"; + + $ret = $code->(0, 0, 0, 0, 0, 1, 1); + is $counter, 4, "$desc : fourth branch was properly compiled"; + is $ret, 4, "$desc : fourth branch returned 4"; + + $ret = $code->(); + is $counter, 5, "$desc : fifth branch was properly compiled"; + is $ret, 5, "$desc : fifth branch returned 5"; +} + +{ + my $desc = 'peephole optimization of C-style loops'; + + local $counter; + + local $@; + my $code = eval <<' TESTCASE'; + use Lexical::Types; + sub { + my $ret = 0; + for ( + my Int $i = 0 + ; + do { my Int $x; $i < 4 } + ; + do { my Int $y; ++$i } + ) { + my Int $z; + $ret += $i; + } + return $ret; + } + TESTCASE + is $@, '', "$desc compiled fine"; + + my $ret = $code->(); + is $counter, 1 + 5 + 4 + 4, "$desc was properly compiled"; + is $ret, 6, "$desc returned 0+1+2+3"; +} + +{ + my $desc = 'peephole optimization of range loops'; + + local $counter; + local $@; + my $code = eval <<' TESTCASE'; + use Lexical::Types; + sub { + my $ret = 0; + for ((do { my Int $z; 0 }) .. (do { my Int $z; 3 })) { + my Int $z; + $ret += $_; + } + return $ret; + } + TESTCASE + is $@, '', "$desc compiled fine"; + + my $ret = $code->(); + is $counter, 2 + 4, "$desc was properly compiled"; + is $ret, 6, "$desc returned 0+1+2+3"; +} + +{ + my $desc = 'peephole optimization of empty loops (RT #66164)'; + + local $counter; + local $@; + my $code = eval <<' TESTCASE'; + use Lexical::Types; + sub { + my $ret = 0; + for (;;) { + my Int $z; + ++$ret; + return $ret; + } + return $ret; + } + TESTCASE + is $@, '', "$desc compiled fine"; + + my $ret = $code->(); + is $counter, 1, "$desc was properly compiled"; + is $ret, 1, "$desc returned 1"; +} + +{ + my $desc = 'peephole optimization of map'; + + local $counter; + local $@; + my $code = eval <<' TESTCASE'; + use Lexical::Types; + sub { + join ':', map { + my Int $z; + "x${_}y" + } @_ + } + TESTCASE + is $@, '', "$desc compiled fine"; + + my $ret = $code->(1, 2); + is $counter, 2, "$desc was properly compiled"; + is $ret, 'x1y:x2y', "$desc returned the right value"; +} + +{ + my $desc = 'peephole optimization of grep'; + + local $counter; + local $@; + my $code = eval <<' TESTCASE'; + use Lexical::Types; + sub { + join ':', grep { + my Int $z; + $_ <= 3 + } @_ + } + TESTCASE + is $@, '', "$desc compiled fine"; + + my $ret = $code->(1 .. 5); + is $counter, 5, "$desc was properly compiled"; + is $ret, '1:2:3', "$desc returned the right value"; +} + +{ + my $desc = 'peephole optimization of substitutions'; + + local $counter; + local $@; + my $code = eval <<' TESTCASE'; + use Lexical::Types; + sub { + my $str = $_[0]; + $str =~ s{ + ([0-9]) + }{ + my Int $z; + 9 - $1; + }xge; + $str; + } + TESTCASE + is $@, '', "$desc compiled fine"; + + my $ret = $code->('0123456789'); + is $counter, 10, "$desc was properly compiled"; + is $ret, '9876543210', "$desc returned the right value"; +}