package Loop_unroll;

use strict;
use Filter::Simple;

FILTER {

    my $unroll_limit = 10;  #max unrolling depth
    my ($var1, $cons2, $var3, $cons4, $var5, $body6);

    #This is the macro replacement pattern we're looking for...
    my $macro = 'for ($var1=$cons2;$var3<$cons4;$var5++) {$body6}';

    print "MACRO (NOT-COMPILED): $macro\n";

    #run the macro snippet through B::Deparse (better way to grab outp
+ut?)
    my $compiled_macro=`perl -MO=Deparse,-x9 -e'$macro'`; #screws with
+ ', FIX ME.
    
    print "MACRO (COMPILED & DEPARSED): $compiled_macro\n";
    
    print "SOURCE (NOT-COMPILED): $_\n";
    
    #compile the main script
    my $source = `perl -MO=Deparse,-x9 -e'$_'` if $_;     #same proble
+m, Bad dog.

    print "SOURCE (COMPILED & DEPARSED): $source\n";

    #These are crude regex to try to match perl variables and integers
    $var1 = $var3 = $var5 = '(\$[a-zA-Z][a-zA-Z0-9]*)';
    $cons2 = $cons4 = '(\d+)';
    $body6 = '([^}]+)'; #barf, should be something nicer, no nested bl
+ocks

    #deswizzle variable order (mangled by compile)
    #variables should be guarenteed to occur only once because of side
+-effects
    my $i; my $reorder;
    while ($compiled_macro=~/(var1|cons2|var3|cons4|var5|body6)/g)
    {
        $reorder.="\$$1 = \$".++$i.";"; # map vars to capturing parens
    }

    print "REORDER: $reorder\n";

    $compiled_macro=~s/([|(){}\^*+?.\[\]])/\\\\$1/g; #de-meta stuff, n
+ot $ (ick)

    my $regexed_macro;
    eval '$regexed_macro=qq/'."$compiled_macro".'/'; #interpolate patt
+ern match junk
    
    print "REG-EXED MACRO: $regexed_macro\n";    
    
    $source =~ s{$regexed_macro}
                {   eval $reorder;  # better method?
                   ($var1 eq $var3  and
                    $var1 eq $var5  and
                    $cons4 - $cons2 < $unroll_limit) ?   
                        "$var1 = $cons2;".("{$body6;} $var1++;") x ($c
+ons4-$cons2)
                        : 
                        $&;  #Lazy like a fox.
                }eg;
            
    $_ = $source;
    print "FINAL SOURCE: $source\n";
};

1;
[download]