X-Git-Url: https://git.xonotic.org/?p=xonotic%2Fxonotic.git;a=blobdiff_plain;f=misc%2Ftools%2Fprogs-analyzer.pl;h=af97908d935299d04f3013be0cee8262b0a59b75;hp=9f45e52a560795362bd533a8de99972a92d4d10e;hb=14c7702062d1a41a661d5b10f710eed167e00250;hpb=b6f053a53151df4b19e35522a73772e0e55a5b70 diff --git a/misc/tools/progs-analyzer.pl b/misc/tools/progs-analyzer.pl old mode 100644 new mode 100755 index 9f45e52a..af97908d --- 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' }; } @@ -180,13 +191,26 @@ use constant DFUNCTION_T => [ [uchar8 => 'parm_size'], ]; +use constant LNOHEADER_T => [ + [int => 'lnotype'], + [int => 'version'], + [int => 'numglobaldefs'], + [int => 'numglobals'], + [int => 'numfielddefs'], + [int => 'numstatements'], +]; + +use constant LNO_T => [ + [int => 'v'], +]; + sub get_section($$$) { my ($fh, $start, $len) = @_; 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 +238,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]}) @@ -274,7 +298,7 @@ sub run_nfa($$$$$$) my $func = $s->{a}; my $funcid = $progs->{globals}[$func]{v}{int}; last - if $progs->{error_func}{$funcid}; + if $progs->{builtins}{error}{$funcid}; $ip += 1; } elsif($c->{isjump}) @@ -312,28 +336,32 @@ sub run_nfa($$$$$$) $nfa->($ip, $copy_handler->($state)); } -sub get_constant($$) +sub get_constant($$$) { - my ($progs, $g) = @_; - if($g->{int} == 0) - { - return 0; - } - elsif($g->{int} > 0 && $g->{int} < 8388608) - { - if($g->{int} < length $progs->{strings} && $g->{int} > 0) - { - return str($progs->{getstring}->($g->{int})); - } - else - { - return $g->{int} . "i"; - } - } - else - { - return $g->{float}; + my ($progs, $g, $type) = @_; + + if (!defined $type) { + $type = 'float'; + $type = 'int' + if $g->{int} > 0 && $g->{int} < 8388608; + $type = 'string' + if $g->{int} > 0 && $g->{int} < length $progs->{strings}; } + + return str($progs->{getstring}->($g->{int})) + if $type eq 'string'; + return $g->{float} + if $type eq 'float'; + return "'$g->{float} _ _'" + if $type eq 'vector'; + return "entity $g->{int}" + if $type eq 'entity'; + return ".$progs->{entityfieldnames}[$g->{int}][0]" + if $type eq 'field' and defined $progs->{entityfieldnames}[$g->{int}][0]; + return "$g->{int}i" + if $type eq 'int'; + + return "$type($g->{int})"; } use constant PRE_MARK_STATEMENT => ""; @@ -353,16 +381,39 @@ sub str($) return "\"$str\""; } +sub debugpos($$$) { + my ($progs, $func, $ip) = @_; + my $s = $func->{debugname}; + if ($progs->{cno}) { + my $column = $progs->{cno}[$ip]{v}; + $s =~ s/:/:$column:/; + } + if ($progs->{lno}) { + my $line = $progs->{lno}[$ip]{v}; + $s =~ s/:/:$line:/; + } + return $s; +} + sub disassemble_function($$;$) { my ($progs, $func, $highlight) = @_; 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) = @_; - my $g = get_constant($progs, $progs->{globals}[$ofs]{v}); + # TODO: Can we know its type? + my $g = get_constant($progs, $progs->{globals}[$ofs]{v}, undef); print " = $g" if defined $g; }; @@ -488,11 +539,12 @@ sub disassemble_function($$;$) { for(values %{$highlight->{$ip}}) { - for(@$_) + for(sort keys %$_) { print PRE_MARK_STATEMENT; - printf INSTRUCTION_FORMAT, '', '', '.WARN'; - printf OPERAND_FORMAT, "$_ (in $func->{debugname})"; + printf INSTRUCTION_FORMAT, '', '', '.WARN'; + my $pos = debugpos $progs, $func, $ip; + printf OPERAND_FORMAT, "$_ (in $pos)"; print INSTRUCTION_SEPARATOR; } } @@ -502,7 +554,7 @@ sub disassemble_function($$;$) 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)) @@ -529,7 +581,6 @@ sub find_uninitialized_locals($$) { my ($progs, $func) = @_; - return if $func->{first_statement} < 0; # builtin @@ -605,32 +656,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 = (); @@ -687,6 +712,10 @@ sub find_uninitialized_locals($$) } } + if($c->{isinvalid}) + { + ++$warned{$ip}{''}{"Invalid opcode"}; + } for(qw(a b c)) { my $type = $c->{$_}; @@ -708,7 +737,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')) { - push @{$warned{$ip}{$_}}, "Use of uninitialized value"; + ++$warned{$ip}{$_}{"Use of uninitialized value"}; } } elsif($valid->[0] < 0) @@ -716,7 +745,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')) { - push @{$warned{$ip}{$_}}, "Use of temporary across CALL"; + ++$warned{$ip}{$_}{"Use of temporary across CALL"}; } } else @@ -755,6 +784,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}) { @@ -843,11 +879,63 @@ sub find_uninitialized_locals($$) if(!$isread) { - push @{$warned{$ip}{$operand}}, "Value is never used"; + ++$warned{$ip}{$operand}{"Value is never used"}; } } } - + + my %solid_seen = (); + run_nfa $progs, $func->{first_statement}, do { my $state = -1; \$state; }, + sub + { + my $state = ${$_[0]}; + return \$state; + }, + sub + { + my ($ip, $state) = @_; + return $solid_seen{"$ip $$state"}++; + }, + sub + { + my ($ip, $state, $s, $c) = @_; + + if($s->{op} eq 'ADDRESS') + { + my $field_ptr_ofs = $s->{b}; + my $def = $progs->{globaldef_byoffset}->($field_ptr_ofs); + use Data::Dumper; + if (($def->{globaltype} eq 'read_only' || $def->{globaltype} eq 'const') && + grep { $_ eq 'solid' } @{$progs->{entityfieldnames}[$progs->{globals}[$field_ptr_ofs]{v}{int}]}) + { + # Taking address of 'solid' for subsequent write! + # TODO check if this address is then actually used in STOREP. + $$state = $ip; + } + } + + if($c->{iscall}) + { + # TODO check if the entity passed is actually the one on which solid was set. + my $func = $s->{a}; + my $funcid = $progs->{globals}[$func]{v}{int}; + if ($progs->{builtins}{setmodel}{$funcid} || $progs->{builtins}{setsize}{$funcid}) + { + # All is clean. + $$state = -1; + } + } + + if($c->{isreturn}) + { + if ($$state >= 0) { + ++$warned{$$state}{''}{"Changing .solid without setmodel/setsize breaks area grid linking in Quake"}; + } + } + + return 0; + }; + disassemble_function($progs, $func, \%warned) if keys %warned; } @@ -903,7 +991,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}}) { @@ -922,6 +1012,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 = (); @@ -929,21 +1071,46 @@ sub detect_constants($) { my $type = $_->{type}; my $name = $progs->{getstring}->($_->{s_name}); + $name = '' + if $name eq 'IMMEDIATE'; # for fteqcc I had: 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)) { @@ -991,15 +1158,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) { @@ -1014,13 +1188,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}] //= $_ @@ -1035,7 +1203,8 @@ sub detect_constants($) $globaldefs[$_] //= { ofs => $_, s_name => undef, - debugname => undef + debugname => undef, + type => undef }; } for(0..(@{(DEFAULTGLOBALS)}-1)) @@ -1053,7 +1222,7 @@ sub detect_constants($) } elsif($_->{globaltype} eq 'const') { - $_->{debugname} = get_constant($progs, $progs->{globals}[$_->{ofs}]{v}); + $_->{debugname} = get_constant($progs, $progs->{globals}[$_->{ofs}]{v}, $_->{type}{type}); } else { @@ -1064,7 +1233,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}"; } @@ -1076,15 +1245,40 @@ sub detect_constants($) }; } -sub parse_progs($) +sub parse_progs($$) { - my ($fh) = @_; + my ($fh, $lnofh) = @_; my %p = (); print STDERR "Parsing header...\n"; $p{header} = parse_section $fh, DPROGRAMS_T, 0, undef, 1; + if (defined $lnofh) { + print STDERR "Parsing LNO...\n"; + my $lnoheader = parse_section $lnofh, LNOHEADER_T, 0, undef, 1; + eval { + die "Not a LNOF" + if $lnoheader->{lnotype} != unpack 'V', 'LNOF'; + die "Not version 1" + if $lnoheader->{version} != 1; + die "Not same count of globaldefs" + if $lnoheader->{numglobaldefs} != $p{header}{numglobaldefs}; + die "Not same count of globals" + if $lnoheader->{numglobals} != $p{header}{numglobals}; + die "Not same count of fielddefs" + if $lnoheader->{numfielddefs} != $p{header}{numfielddefs}; + die "Not same count of statements" + if $lnoheader->{numstatements} != $p{header}{numstatements}; + $p{lno} = [parse_section $lnofh, LNO_T, 24, undef, $lnoheader->{numstatements}]; + eval { + $p{lno} = [parse_section $lnofh, LNO_T, 24, undef, $lnoheader->{numstatements} * 2]; + $p{cno} = [splice $p{lno}, $lnoheader->{numstatements}]; + print STDERR "Cool, this LNO even has column number info!\n"; + }; + } or warn "Skipping LNO: $@"; + } + print STDERR "Parsing strings...\n"; $p{strings} = get_section $fh, $p{header}{ofs_strings}, $p{header}{numstrings}; $p{getstring} = sub @@ -1094,12 +1288,82 @@ 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}; + push @{$p{entityfieldnames}[$g->{ofs}]}, $name; + } + 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}}; + if($f->{first_statement} >= 0) + { + 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}}; + 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->{parm_start} + $totalparms > @{$p{globals}}; + die "More parms than locals in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})" + if $totalparms > $f->{locals}; + } + } + + 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)) @@ -1111,49 +1375,60 @@ 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} = {}; + print STDERR "Looking for error(), setmodel(), setsize()...\n"; + $p{builtins} = { error => {}, setmodel => {}, setsize => {} }; for(@{$p{globaldefs}}) { + my $name = $p{getstring}($_->{s_name}); next - if $p{getstring}($_->{s_name}) ne 'error'; + if not exists $p{builtins}{$name}; my $v = $p{globals}[$_->{ofs}]{v}{int}; next if $v <= 0 || $v >= @{$p{functions}}; my $first = $p{functions}[$v]{first_statement}; next if $first >= 0; - print STDERR "Detected error() at offset $_->{ofs} (builtin #@{[-$first]})\n"; - $p{error_func}{$_->{ofs}} = 1; + print STDERR "Detected $name() at offset $_->{ofs} (builtin #@{[-$first]})\n"; + $p{builtins}{$name}{$_->{ofs}} = 1; } print STDERR "Scanning functions...\n"; @@ -1175,62 +1450,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') - { - $read->($ofs); - } - elsif($type eq 'inglobalvec') - { - $read->($ofs); - $read->($ofs+1); - $read->($ofs+2); - } - elsif($type eq 'outglobal') + if(my $j = $c->{isjump}) { - $write->($ofs); + my $t = $ip + $s->{$j}; + $come_from{$t}{$ip} = $c->{isconditional}; + $go_to{$ip}{$t} = $c->{isconditional}; } - 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; @@ -1245,14 +1523,34 @@ 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, $_); } } -open my $fh, '<', $ARGV[0]; -parse_progs $fh; +for my $progs (@ARGV) { + my $lno = "$progs.lno"; + $lno =~ s/\.dat\.lno$/.lno/; + + open my $fh, '<', $progs + or die "$progs: $!"; + + open my $lnofh, '<', $lno + or warn "$lno: $!"; + + parse_progs $fh, $lnofh; +}