Skip to content

Commit

Permalink
Added the first non-local transformation, it was pretty easy. This one
Browse files Browse the repository at this point in the history 
finds a prototype and its corresponding function, deletes the
prototype, and moves the function to where the prototype used to be.
  • Loading branch information
@regehr
regehr committed Jun 28, 2011
1 parent 6e2f288 commit bc1dbc2
Showing 1 changed file with 71 additions and 33 deletions.
104 changes: 71 additions & 33 deletions utah/scripts/reduce/c_delta.pl
View file
Expand Up @@ -4,7 +4,9 @@
use Regexp::Common;
use re 'eval';

# build up the regexes programmatically to support multiple replacement options
# run sanity check after each pass

# save a copy after each complete iteration

# make sure file starts and ends with a blank

Expand Down Expand Up @@ -33,7 +35,7 @@

# long term todo: rewrite this tool to operate on ASTs

my $INIT = "1";
my $DEBUG = 1;

my $num = "\\-?[xX0-9a-fA-F]+[UL]*";
my $field = "\\.f[0-9]+";
Expand All @@ -50,7 +52,13 @@
my $varnum = "($var)|($num)";
my $border = "[\\*\\{\\(\\[\\:\\,\\}\\)\\]\\;\\,]";
my $borderorspc = "(($border)|(\\s))";
my $type = "int|void";
my $inttype = "int|void|short|long|char|signed|unsigned|const|static|(union\\s+U[0-9]+)|(struct\\s+S[0-9+])";
my $functype = "(($inttype)\\s*|\\*\\s*)+";
my $fname = "(?<fname>[a-zA-Z0-9\\_]+)";
my $funcstart_orig = "$functype\\s+(?<fname>[a-zA-Z0-9\\_]+)\\s*$RE{balanced}{-parens=>'()'}";
my $funcstart = "$functype\\s+XXX\\s*$RE{balanced}{-parens=>'()'}";
my $proto = "$funcstart;";
my $func = "$funcstart\\s*$RE{balanced}{-parens=>'{}'}";
my $lbl = "lbl_[0-9]+:";

#print "$field\n";
Expand All @@ -64,7 +72,6 @@
["$RE{balanced}{-parens=>'()'}", ""],
["$RE{balanced}{-parens=>'{}'}", ""],
["=\\s*$RE{balanced}{-parens=>'{}'}", ""],
["($type)\\s+($varnum)\\s+$RE{balanced}{-parens=>'()'}\\s+$RE{balanced}{-parens=>'{}'}", ""],
["\\:\\s*[0-9]+\\s*;", ";"],
["\\;", ""],
["\\^\\=", "="],
Expand All @@ -83,13 +90,13 @@
["\\~", ""],
['"(.*?)"', ""],
['"(.*?)",', ""],
["($lbl)\\s*:", ""],
["goto\\s+($lbl)", ""],
);

# these match when preceded and followed by $borderorspc
my @delimited_regexes_to_replace = (
["($type)\\s+($var),", ""],
["($lbl)\\s*:", ""],
["goto\\s+($lbl);", ""],
["($inttype)\\s+($var),", ""],
["const", ""],
["volatile", ""],
["char", ""],
Expand All @@ -112,6 +119,7 @@
["for", ""],
["if\\s+\\(.*?\\)", ""],
["struct.*?;", ""],
["union.*?;", ""],
["if", ""],
["break", ""],
["inline", ""],
Expand All @@ -136,7 +144,12 @@
"for",
);

push @regexes_to_replace, ["($inttype)\\s+($varnum)\\s+$RE{balanced}{-parens=>'()'}\\s+$RE{balanced}{-parens=>'{}'}", ""];

foreach my $f (@function_prefixes) {

push @regexes_to_replace, ["($inttype)\\s+($f)\\s+$RE{balanced}{-parens=>'()'}\\s+$RE{balanced}{-parens=>'{}'}", ""];

push @delimited_regexes_to_replace, ["$f(.*?)$RE{balanced}{-parens=>'()'},", "0"];
push @delimited_regexes_to_replace, ["$f(.*?)$RE{balanced}{-parens=>'()'},", ""];
push @delimited_regexes_to_replace, ["$f(.*?)$RE{balanced}{-parens=>'()'}", "0"];
Expand Down Expand Up @@ -183,6 +196,7 @@ ($$$)
# these are set at startup time and never change
my $cfile;
my $test;
my $trial_num = 0;

sub read_file () {
open INF, "<$cfile" or die;
Expand All @@ -194,6 +208,12 @@ ()
}

sub write_file () {
if (defined($DEBUG) && $DEBUG) {
open OUTF, ">delta_tmp_${trial_num}.c" or die;
print OUTF $prog;
close OUTF;
}
$trial_num++;
open OUTF, ">$cfile" or die;
print OUTF $prog;
close OUTF;
Expand Down Expand Up @@ -221,46 +241,43 @@ ()
my %method_worked = ();
my %method_failed = ();
my $old_size = 1000000000;
sub delta_test ($) {
(my $method) = @_;

sub delta_test ($$) {
(my $method, my $ok_to_enlarge) = @_;
my $len = length ($prog);
print "[$pass_num $method ($pos / $len) s:$good_cnt f:$bad_cnt] ";

# my $result = $cache{$prog};
my $result;

my $hit = 0;
my $result = $cache{$prog};

if (defined($result)) {
$cache_hits++;
print "(hit) ";
$hit = 1;
} else {
write_file ();
$result = run_test ();
$cache{$prog} = $result;
$hit = 0;
print "failure\n";
read_file ();
$bad_cnt++;
$method_failed{$method}++;
return 0;
}

write_file ();
$result = run_test ();
$cache{$prog} = $result;

if ($result) {
print "success\n";
die if ($hit);
system "cp $cfile $cfile.bak";
$good_cnt++;
$method_worked{$method}++;
my $size = length ($prog);
die if ($size > $old_size);
die if (($size > $old_size) && !$ok_to_enlarge);
if ($size < $old_size) {
%cache = ();
}
$old_size = $size;
return 1;
} else {
print "failure\n";
if (!$hit) {
system "cp $cfile.bak $cfile";
}
system "cp $cfile.bak $cfile";
read_file ();
$bad_cnt++;
$method_failed{$method}++;
Expand Down Expand Up @@ -288,7 +305,7 @@ ($)
if ($rest =~ s/(^$str)/$repl/) {
print "replacing '$1' with '$repl' at $pos : ";
$prog = $first.$rest;
$worked |= delta_test ($method);
$worked |= delta_test ($method, 0);
}
}
foreach my $l (@delimited_regexes_to_replace) {
Expand All @@ -304,26 +321,26 @@ ($)
if ($rest =~ s/^(?<delim1>$borderorspc)(?<str>$str)(?<delim2>$borderorspc)/$+{delim1}$repl$+{delim2}/) {
print "delimited replacing '$+{str}' with '$repl' at $pos : ";
$prog = $first.$rest;
$worked |= delta_test ($method);
$worked |= delta_test ($method, 0);
}
}
} elsif ($method eq "del_blanks_all") {
if ($prog =~ s/\s{2,}/ /g) {
$worked |= delta_test ($method);
$worked |= delta_test ($method, 0);
}
return 0;
} elsif ($method eq "indent") {
} elsif ($method eq "indent") {
write_file();
system "indent $cfile";
read_file();
$worked |= delta_test ($method);
$worked |= delta_test ($method, 1);
return 0;
} elsif ($method eq "del_blanks") {
my $rest = substr($prog, $pos);
if ($rest =~ /^(\s{2,})/) {
my $len = length ($1);
substr ($prog, $pos, $len) = " ";
$worked |= delta_test ($method);
$worked |= delta_test ($method, 0);
}
} elsif ($method eq "parens_exclusive") {
if (substr($prog, $pos, 1) eq "(") {
Expand All @@ -334,9 +351,29 @@ ($)
substr ($prog, $p2, 1) = "";
substr ($prog, $pos, 1) = "";
print "deleting at $pos--$p2 : ";
$worked |= delta_test ($method);
$worked |= delta_test ($method, 0);
}
}
} elsif ($method eq "move_func") {
my $first = substr($prog, 0, $pos);
my $rest = substr($prog, $pos);
my $proto2 = $proto;
die if (!($proto2 =~ s/XXX/$fname/));
if ($rest =~ /^($proto2)/) {
my $realproto = $1;
my $fname = $+{fname};
print "found prototype for '$fname'\n";
my $func2 = $func;
die if (!($func2 =~ s/XXX/$fname/));
if ($rest =~ s/($func2)//) {
my $body = $1;
print "got body!\n";
print "replacing < $realproto > with < $body >\n";
substr ($rest, 0, length($realproto)) = $body;
$prog = $first.$rest;
$worked |= delta_test ($method, 0);
}
}
} elsif ($method eq "brackets_exclusive") {
if (substr($prog, $pos, 1) eq "{") {
my $p2 = find_match ($pos+1,"{","}");
Expand All @@ -346,7 +383,7 @@ ($)
substr ($prog, $p2, 1) = "";
substr ($prog, $pos, 1) = "";
print "deleting at $pos--$p2 : ";
$worked |= delta_test ($method);
$worked |= delta_test ($method, 0);
}
}
} else {
Expand All @@ -365,6 +402,7 @@ ($)

"del_blanks_all" => 0,
"del_blanks" => 1,
"move_func" => 2,
"brackets_exclusive" => 2,
"parens_exclusive" => 3,
"replace_regex" => 4,
Expand Down

0 comments on commit bc1dbc2

Please sign in to comment.