X-Git-Url: http://git.xonotic.org/?a=blobdiff_plain;f=misc%2Ftools%2Fprogs-analyzer.pl;h=e8d7a21260382821c053077e18343beee5f151c2;hb=86fe07aec96d25dd1c47ba14ca23467ce0fbed7d;hp=95a66132abfaad2ed3299fa825e7b0e58e72a51e;hpb=99737dee776f8b60436c2b944b2ca3ae69f2efde;p=xonotic%2Fxonotic.git diff --git a/misc/tools/progs-analyzer.pl b/misc/tools/progs-analyzer.pl old mode 100644 new mode 100755 index 95a66132..e8d7a212 --- a/misc/tools/progs-analyzer.pl +++ b/misc/tools/progs-analyzer.pl @@ -1,6 +1,9 @@ +#!/usr/bin/perl + use strict; use warnings; use Digest::SHA; +use Carp; sub id() { @@ -120,6 +123,14 @@ sub checkop($) { return { a => 'inglobalvec', isreturn => 1 }; } + if($op eq 'STATE') + { + return { a => 'inglobal', b => 'inglobalfunc' }; + } + if($op =~ /^INVALID#/) + { + return { isinvalid => 1 }; + } return { a => 'inglobal', b => 'inglobal', c => 'outglobal' }; } @@ -186,7 +197,7 @@ sub get_section($$$) seek $fh, $start, 0 or die "seek: $!"; $len == read $fh, my $buf, $len - or die "short read"; + or die "short read from $start length $len (malformed progs header)"; return $buf; } @@ -214,7 +225,7 @@ sub parse_section($$$$$) my @out = map { $itemlen == read $fh, my $buf, $itemlen - or die "short read"; + or die "short read from $start length $cnt * $itemlen $(malformed progs header)"; my %h = (); @h{@packnames} = unpack $packspec, $buf; $h{$_->[1]} = TYPES->{$_->[0]}->[2]->($h{$_->[1]}) @@ -359,6 +370,14 @@ sub disassemble_function($$;$) print "$func->{debugname}:\n"; + if($func->{first_statement} < 0) # builtin + { + printf INSTRUCTION_FORMAT, '', '', '.BUILTIN'; + printf OPERAND_FORMAT, -$func->{first_statement}; + print INSTRUCTION_SEPARATOR; + return; + } + my $initializer = sub { my ($ofs) = @_; @@ -484,11 +503,25 @@ sub disassemble_function($$;$) my $ipt = $progs->{statements}[$ip]; my $opprop = checkop $op; + if($highlight and $highlight->{$ip}) + { + for(values %{$highlight->{$ip}}) + { + for(sort keys %$_) + { + print PRE_MARK_STATEMENT; + printf INSTRUCTION_FORMAT, '', '', '.WARN'; + printf OPERAND_FORMAT, "$_ (in $func->{debugname})"; + print INSTRUCTION_SEPARATOR; + } + } + } + print PRE_MARK_STATEMENT if $highlight and $highlight->{$ip}; my $showip = $opprop->{isjump}; - printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? "" : "", $op; + printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? '' : '', $op; my $cnt = 0; for my $o(qw(a b c)) @@ -515,7 +548,6 @@ sub find_uninitialized_locals($$) { my ($progs, $func) = @_; - return if $func->{first_statement} < 0; # builtin @@ -591,32 +623,6 @@ sub find_uninitialized_locals($$) $watchme{$_}{valid} = [1, undef, undef] if defined $watchme{$_}; } - # an initial run of STORE instruction is for receiving extra parameters - # (beyond 8). Only possible if the function is declared as having 8 params. - # Extra parameters behave otherwise like temps, but are initialized at - # startup. - for($func->{first_statement} .. (@{$progs->{statements}}-1)) - { - my $s = $progs->{statements}[$_]; - if($s->{op} eq 'STORE_V') - { - $watchme{$s->{a}}{valid} = [1, undef, undef] - if defined $watchme{$s->{a}}; - $watchme{$s->{a}+1}{valid} = [1, undef, undef] - if defined $watchme{$s->{a}+1}; - $watchme{$s->{a}+2}{valid} = [1, undef, undef] - if defined $watchme{$s->{a}+2}; - } - elsif($s->{op} =~ /^STORE_/) - { - $watchme{$s->{a}}{valid} = [1, undef, undef] - if defined $watchme{$s->{a}}; - } - else - { - last; - } - } my %warned = (); my %ip_seen = (); @@ -673,6 +679,10 @@ sub find_uninitialized_locals($$) } } + if($c->{isinvalid}) + { + ++$warned{$ip}{''}{"Invalid opcode"}; + } for(qw(a b c)) { my $type = $c->{$_}; @@ -694,8 +704,7 @@ sub find_uninitialized_locals($$) # COMPILER BUG of FTEQCC: AND and OR may take uninitialized as second argument (logicops) if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b')) { - print "; Use of uninitialized value $ofs in $func->{debugname} at $ip.$_\n"; - ++$warned{$ip}{$_}; + ++$warned{$ip}{$_}{"Use of uninitialized value"}; } } elsif($valid->[0] < 0) @@ -703,8 +712,7 @@ sub find_uninitialized_locals($$) # COMPILER BUG of FTEQCC: AND and OR may take uninitialized as second argument (logicops) if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b')) { - print "; Use of temporary $ofs across CALL in $func->{debugname} at $ip.$_\n"; - ++$warned{$ip}{$_}; + ++$warned{$ip}{$_}{"Use of temporary across CALL"}; } } else @@ -743,6 +751,13 @@ sub find_uninitialized_locals($$) $write->($ofs+1); $write->($ofs+2); } + elsif($type eq 'ipoffset') + { + ++$warned{$ip}{$_}{"Endless loop"} + if $ofs == 0; + ++$warned{$ip}{$_}{"No-operation jump"} + if $ofs == 1; + } } if($c->{iscall}) { @@ -831,8 +846,7 @@ sub find_uninitialized_locals($$) if(!$isread) { - print "; Value is never used in $func->{debugname} at $ip.$operand\n"; - ++$warned{$ip}{$operand}; + ++$warned{$ip}{$operand}{"Value is never used"}; } } } @@ -892,7 +906,9 @@ sub detect_constants($) use constant GLOBALFLAG_N => 16; # named use constant GLOBALFLAG_Q => 32; # unique to function use constant GLOBALFLAG_U => 64; # unused - my @globalflags = (GLOBALFLAG_Q | GLOBALFLAG_U) x @{$progs->{globals}}; + use constant GLOBALFLAG_P => 128; # possibly parameter passing + use constant GLOBALFLAG_D => 256; # has a def + my @globalflags = (GLOBALFLAG_Q | GLOBALFLAG_U) x (@{$progs->{globals}} + 2); for(@{$progs->{functions}}) { @@ -911,6 +927,58 @@ sub detect_constants($) for keys %{$_->{globals_read}}; $globalflags[$_] |= GLOBALFLAG_W for keys %{$_->{globals_written}}; + next + if $_->{first_statement} < 0; + for my $ip($_->{first_statement} .. (@{$progs->{statements}}-1)) + { + my $s = $progs->{statements}[$ip]; + if($s->{op} eq 'STORE_V') + { + $globalflags[$s->{a}] |= GLOBALFLAG_P + if $s->{b} >= $_->{parm_start} and $s->{b} < $_->{parm_start} + $_->{locals}; + $globalflags[$s->{a}+1] |= GLOBALFLAG_P + if $s->{b}+1 >= $_->{parm_start} and $s->{b}+1 < $_->{parm_start} + $_->{locals}; + $globalflags[$s->{a}+2] |= GLOBALFLAG_P + if $s->{b}+2 >= $_->{parm_start} and $s->{b}+2 < $_->{parm_start} + $_->{locals}; + } + elsif($s->{op} =~ /^STORE_/) + { + $globalflags[$s->{a}] |= GLOBALFLAG_P + if $s->{b} >= $_->{parm_start} and $s->{b} < $_->{parm_start} + $_->{locals}; + } + else + { + last; + } + } + } + + # parameter passing globals are only ever used in STORE_ instructions + for my $s(@{$progs->{statements}}) + { + next + if $s->{op} =~ /^STORE_/; + + my $c = checkop $s->{op}; + + for(qw(a b c)) + { + my $type = $c->{$_}; + next + unless defined $type; + + my $ofs = $s->{$_}; + if($type eq 'inglobal' || $type eq 'inglobalfunc' || $type eq 'outglobal') + { + $globalflags[$ofs] &= ~GLOBALFLAG_P; + } + if($type eq 'inglobalvec' || $type eq 'outglobalvec') + { + $globalflags[$ofs] &= ~GLOBALFLAG_P; + $globalflags[$ofs+1] &= ~GLOBALFLAG_P; + $globalflags[$ofs+2] &= ~GLOBALFLAG_P; + } + } } my %offsets_saved = (); @@ -918,21 +986,46 @@ sub detect_constants($) { my $type = $_->{type}; my $name = $progs->{getstring}->($_->{s_name}); + $name = '' + if $name eq 'IMMEDIATE' or $name =~ /^\./; + $_->{debugname} = $name + if $name ne ''; + $globalflags[$_->{ofs}] |= GLOBALFLAG_D; if($type->{save}) { - for my $i(0..(typesize($_->{type}{type})-1)) - { - $globalflags[$_->{ofs}] |= GLOBALFLAG_S; - } + $globalflags[$_->{ofs}] |= GLOBALFLAG_S; + } + if(defined $_->{debugname}) + { + $globalflags[$_->{ofs}] |= GLOBALFLAG_N; } - if($name ne "") + } + # fix up vectors + my @extradefs = (); + for(@{$progs->{globaldefs}}) + { + my $type = $_->{type}; + for my $i(1..(typesize($type->{type})-1)) { - for my $i(0..(typesize($_->{type}{type})-1)) + # add missing def + if(!($globalflags[$_->{ofs}+$i] & GLOBALFLAG_D)) { - $globalflags[$_->{ofs}] |= GLOBALFLAG_N; + print "Missing globaldef for a component@{[defined $_->{debugname} ? ' of ' . $_->{debugname} : '']} at $_->{ofs}+$i\n"; + push @extradefs, { + type => { + saved => 0, + type => 'float' + }, + ofs => $_->{ofs} + $i, + debugname => defined $_->{debugname} ? $_->{debugname} . "[$i]" : undef + }; } + # "saved" and "named" states hit adjacent globals too + $globalflags[$_->{ofs}+$i] |= $globalflags[$_->{ofs}] & (GLOBALFLAG_S | GLOBALFLAG_N | GLOBALFLAG_D); } } + push @{$progs->{globaldefs}}, @extradefs; + my %offsets_initialized = (); for(0..(@{$progs->{globals}}-1)) { @@ -980,15 +1073,22 @@ sub detect_constants($) { $globaltypes[$_] = "global"; } - elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I | GLOBALFLAG_Q)) == GLOBALFLAG_Q) - { - $globaltypes[$_] = "uniquetemp"; - $istemp{$_} = 0; - } - elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I | GLOBALFLAG_Q)) == 0) + elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == 0) { - $globaltypes[$_] = "temp"; - $istemp{$_} = 1; + if($globalflags[$_] & GLOBALFLAG_P) + { + $globaltypes[$_] = "OFS_PARM"; + } + elsif($globalflags[$_] & GLOBALFLAG_Q) + { + $globaltypes[$_] = "uniquetemp"; + $istemp{$_} = 0; + } + else + { + $globaltypes[$_] = "temp"; + $istemp{$_} = 1; + } } elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == GLOBALFLAG_I) { @@ -1003,13 +1103,7 @@ sub detect_constants($) $progs->{temps} = \%istemp; # globaldefs - my @globaldefs = (undef) x @{$progs->{globaldefs}}; - for(@{$progs->{globaldefs}}) - { - my $s = $progs->{getstring}->($_->{s_name}); - $_->{debugname} //= "\$" . "$s" - if length $s; - } + my @globaldefs = (undef) x @{$progs->{globals}}; for(@{$progs->{globaldefs}}) { $globaldefs[$_->{ofs}] //= $_ @@ -1024,7 +1118,8 @@ sub detect_constants($) $globaldefs[$_] //= { ofs => $_, s_name => undef, - debugname => undef + debugname => undef, + type => undef }; } for(0..(@{(DEFAULTGLOBALS)}-1)) @@ -1053,7 +1148,7 @@ sub detect_constants($) for(@globaldefs) { next - if $globaldefs_namecount{$_->{debugname}} <= 1; + if $globaldefs_namecount{$_->{debugname}} <= 1 && !$ENV{FORCE_OFFSETS}; #print "Not unique: $_->{debugname} at $_->{ofs}\n"; $_->{debugname} .= "\@$_->{ofs}"; } @@ -1083,12 +1178,79 @@ sub parse_progs($) return substr $p{strings}, $startpos, $endpos - $startpos; }; + print STDERR "Parsing globals...\n"; + $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}]; + + print STDERR "Parsing globaldefs...\n"; + $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}]; + + print STDERR "Range checking globaldefs...\n"; + for(0 .. (@{$p{globaldefs}}-1)) + { + my $g = $p{globaldefs}[$_]; + die "Out of range name in globaldef $_" + if $g->{s_name} < 0 || $g->{s_name} >= length $p{strings}; + my $name = $p{getstring}->($g->{s_name}); + die "Out of range ofs $g->{ofs} in globaldef $_ (name: \"$name\")" + if $g->{ofs} >= $p{globals}; + } + + print STDERR "Parsing fielddefs...\n"; + $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}]; + + print STDERR "Range checking fielddefs...\n"; + for(0 .. (@{$p{fielddefs}}-1)) + { + my $g = $p{fielddefs}[$_]; + die "Out of range name in fielddef $_" + if $g->{s_name} < 0 || $g->{s_name} >= length $p{strings}; + my $name = $p{getstring}->($g->{s_name}); + die "Out of range ofs $g->{ofs} in fielddef $_ (name: \"$name\")" + if $g->{ofs} >= $p{header}{entityfields}; + } + print STDERR "Parsing statements...\n"; $p{statements} = [parse_section $fh, DSTATEMENT_T, $p{header}{ofs_statements}, undef, $p{header}{numstatements}]; - print STDERR "Fixing statements...\n"; - for my $s(@{$p{statements}}) + print STDERR "Parsing functions...\n"; + $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}]; + + print STDERR "Range checking functions...\n"; + for(0 .. (@{$p{functions}} - 1)) { + my $f = $p{functions}[$_]; + die "Out of range name in function $_" + if $f->{s_name} < 0 || $f->{s_name} >= length $p{strings}; + my $name = $p{getstring}->($f->{s_name}); + die "Out of range file in function $_" + if $f->{s_file} < 0 || $f->{s_file} >= length $p{strings}; + my $file = $p{getstring}->($f->{s_file}); + die "Out of range first_statement in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})" + if $f->{first_statement} >= @{$p{statements}}; + die "Out of range parm_start in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})" + if $f->{parm_start} < 0 || $f->{parm_start} >= @{$p{globals}}; + die "Out of range locals in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})" + if $f->{locals} < 0 || $f->{parm_start} + $f->{locals} >= @{$p{globals}}; + if($f->{first_statement} >= 0) + { + die "Out of range numparms $f->{numparms} in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})" + if $f->{numparms} < 0 || $f->{numparms} > 8; + my $totalparms = 0; + for(0..($f->{numparms}-1)) + { + die "Out of range parm_size[$_] in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})" + unless { 0 => 1, 1 => 1, 3 => 1 }->{$f->{parm_size}[$_]}; + $totalparms += $f->{parm_size}[$_]; + } + die "Out of range parms in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})" + if $f->{locals} < 0 || $f->{parm_start} + $totalparms >= @{$p{globals}}; + } + } + + print STDERR "Range checking statements...\n"; + for my $ip(0 .. (@{$p{statements}}-1)) + { + my $s = $p{statements}[$ip]; my $c = checkop $s->{op}; for(qw(a b c)) @@ -1100,35 +1262,45 @@ sub parse_progs($) if($type eq 'inglobal' || $type eq 'inglobalfunc') { $s->{$_} &= 0xFFFF; + die "Out of range global offset in statement $ip - cannot continue" + if $s->{$_} >= @{$p{globals}}; } elsif($type eq 'inglobalvec') { $s->{$_} &= 0xFFFF; + if($c->{isreturn}) + { + die "Out of range global offset in statement $ip - cannot continue" + if $s->{$_} >= @{$p{globals}}; + print "Potentially out of range global offset in statement $ip - may crash engines" + if $s->{$_} >= @{$p{globals}}-2; + } + else + { + die "Out of range global offset in statement $ip - cannot continue" + if $s->{$_} >= @{$p{globals}}-2; + } } elsif($type eq 'outglobal') { $s->{$_} &= 0xFFFF; + die "Out of range global offset in statement $ip - cannot continue" + if $s->{$_} >= @{$p{globals}}; } elsif($type eq 'outglobalvec') { $s->{$_} &= 0xFFFF; + die "Out of range global offset in statement $ip - cannot continue" + if $s->{$_} >= @{$p{globals}}-2; + } + elsif($type eq 'ipoffset') + { + die "Out of range GOTO/IF/IFNOT in statement $ip - cannot continue" + if $ip + $s->{$_} < 0 || $ip + $s->{$_} >= @{$p{statements}}; } } - } - print STDERR "Parsing globaldefs...\n"; - $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}]; - - print STDERR "Parsing fielddefs...\n"; - $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}]; - - print STDERR "Parsing globals...\n"; - $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}]; - - print STDERR "Parsing functions...\n"; - $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}]; - print STDERR "Looking for error()...\n"; $p{error_func} = {}; for(@{$p{globaldefs}}) @@ -1164,62 +1336,65 @@ sub parse_progs($) my %globals_written = (); my %globals_used = (); - run_nfa \%p, $_->{first_statement}, "", id, nfa_default_state_checker, - sub - { - my ($ip, $state, $s, $c) = @_; - ++$statements{$ip}; - - if(my $j = $c->{isjump}) - { - my $t = $ip + $s->{$j}; - $come_from{$t}{$ip} = $c->{isconditional}; - $go_to{$ip}{$t} = $c->{isconditional}; - } - - for my $o(qw(a b c)) + if($_->{first_statement} >= 0) + { + run_nfa \%p, $_->{first_statement}, "", id, nfa_default_state_checker, + sub { - my $type = $c->{$o} - or next; - my $ofs = $s->{$o}; - - my $read = sub - { - my ($ofs) = @_; - $globals_read{$ofs}{$ip}{$o} = 1; - $globals_used{$ofs} = 1; - }; - my $write = sub - { - my ($ofs) = @_; - $globals_written{$ofs}{$ip}{$o} = 1; - $globals_used{$ofs} = 1; - }; + my ($ip, $state, $s, $c) = @_; + ++$statements{$ip}; - if($type eq 'inglobal' || $type eq 'inglobalfunc') + if(my $j = $c->{isjump}) { - $read->($ofs); + my $t = $ip + $s->{$j}; + $come_from{$t}{$ip} = $c->{isconditional}; + $go_to{$ip}{$t} = $c->{isconditional}; } - elsif($type eq 'inglobalvec') - { - $read->($ofs); - $read->($ofs+1); - $read->($ofs+2); - } - elsif($type eq 'outglobal') - { - $write->($ofs); - } - elsif($type eq 'outglobalvec') + + for my $o(qw(a b c)) { - $write->($ofs); - $write->($ofs+1); - $write->($ofs+2); + my $type = $c->{$o} + or next; + my $ofs = $s->{$o}; + + my $read = sub + { + my ($ofs) = @_; + $globals_read{$ofs}{$ip}{$o} = 1; + $globals_used{$ofs} = 1; + }; + my $write = sub + { + my ($ofs) = @_; + $globals_written{$ofs}{$ip}{$o} = 1; + $globals_used{$ofs} = 1; + }; + + if($type eq 'inglobal' || $type eq 'inglobalfunc') + { + $read->($ofs); + } + elsif($type eq 'inglobalvec') + { + $read->($ofs); + $read->($ofs+1); + $read->($ofs+2); + } + elsif($type eq 'outglobal') + { + $write->($ofs); + } + elsif($type eq 'outglobalvec') + { + $write->($ofs); + $write->($ofs+1); + $write->($ofs+2); + } } - } - return 0; - }; + return 0; + }; + } $_->{statements} = \%statements; $_->{come_from} = \%come_from; @@ -1234,9 +1409,19 @@ sub parse_progs($) print STDERR "Detecting constants and temps, and naming...\n"; detect_constants \%p; + if($ENV{DUMP}) + { + use Data::Dumper; + print Dumper \%p; + return; + } + # what do we want to do? my $checkfunc = \&find_uninitialized_locals; - #my $checkfunc = \&disassemble_function; + if($ENV{DISASSEMBLE}) + { + $checkfunc = \&disassemble_function; + } for(sort { $a->{debugname} cmp $b->{debugname} } @{$p{functions}}) { $checkfunc->(\%p, $_);