misc/tools/progs-analyzer.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use Digest::SHA;
   6 use Carp;
   7
   8 sub id()
   9 {
  10         return sub { $_[0]; };
  11 }
  12
  13 sub signed($)
  14 {
  15         my ($bits) = @_;
  16         return sub { $_[0] >= (2**($bits-1)) ? $_[0]-(2**$bits) : $_[0]; };
  17 }
  18
  19 use constant OPCODE_E => [qw[
  20         DONE
  21         MUL_F MUL_V MUL_FV MUL_VF
  22         DIV_F
  23         ADD_F ADD_V
  24         SUB_F SUB_V
  25         EQ_F EQ_V EQ_S EQ_E EQ_FNC
  26         NE_F NE_V NE_S NE_E NE_FNC
  27         LE GE LT GT
  28         LOAD_F LOAD_V LOAD_S LOAD_ENT LOAD_FLD LOAD_FNC
  29         ADDRESS
  30         STORE_F STORE_V STORE_S STORE_ENT STORE_FLD STORE_FNC
  31         STOREP_F STOREP_V STOREP_S STOREP_ENT STOREP_FLD STOREP_FNC
  32         RETURN
  33         NOT_F NOT_V NOT_S NOT_ENT NOT_FNC
  34         IF IFNOT
  35         CALL0 CALL1 CALL2 CALL3 CALL4 CALL5 CALL6 CALL7 CALL8
  36         STATE
  37         GOTO
  38         AND OR
  39         BITAND BITOR
  40 ]];
  41 use constant ETYPE_E => [qw[
  42         void
  43         string
  44         float
  45         vector
  46         entity
  47         field
  48         function
  49         pointer
  50 ]];
  51 use constant DEF_SAVEGLOBAL => 32768;
  52 sub typesize($)
  53 {
  54         my ($type) = @_;
  55         return 3 if $type eq 'vector';
  56         return 1;
  57 }
  58
  59 sub checkop($)
  60 {
  61         my ($op) = @_;
  62         if($op =~ /^IF.*_V$/)
  63         {
  64                 return { a => 'inglobalvec', b => 'ipoffset', isjump => 'b', isconditional => 1 };
  65         }
  66         if($op =~ /^IF/)
  67         {
  68                 return { a => 'inglobal', b => 'ipoffset', isjump => 'b', isconditional => 1 };
  69         }
  70         if($op eq 'GOTO')
  71         {
  72                 return { a => 'ipoffset', isjump => 'a', isconditional => 0 };
  73         }
  74         if($op =~ /^ADD_V$|^SUB_V$/)
  75         {
  76                 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobalvec' };
  77         }
  78         if($op =~ /^MUL_V$|^EQ_V$|^NE_V$/)
  79         {
  80                 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobal' };
  81         }
  82         if($op eq 'MUL_FV')
  83         {
  84                 return { a => 'inglobal', b => 'inglobalvec', c => 'outglobalvec' };
  85         }
  86         if($op eq 'MUL_VF')
  87         {
  88                 return { a => 'inglobalvec', b => 'inglobal', c => 'outglobalvec' };
  89         }
  90         if($op eq 'LOAD_V')
  91         {
  92                 return { a => 'inglobal', b => 'inglobal', c => 'outglobalvec' };
  93         }
  94         if($op =~ /^NOT_V/)
  95         {
  96                 return { a => 'inglobalvec', c => 'outglobal' };
  97         }
  98         if($op =~ /^NOT_/)
  99         {
 100                 return { a => 'inglobal', c => 'outglobal' };
 101         }
 102         if($op eq 'STOREP_V')
 103         {
 104                 return { a => 'inglobalvec', b => 'inglobal' };
 105         }
 106         if($op eq 'STORE_V')
 107         {
 108                 return { a => 'inglobalvec', b => 'outglobalvec' };
 109         }
 110         if($op =~ /^STOREP_/)
 111         {
 112                 return { a => 'inglobal', b => 'inglobal' };
 113         }
 114         if($op =~ /^STORE_/)
 115         {
 116                 return { a => 'inglobal', b => 'outglobal' };
 117         }
 118         if($op =~ /^CALL/)
 119         {
 120                 return { a => 'inglobalfunc', iscall => 1 };
 121         }
 122         if($op =~ /^DONE$|^RETURN$/)
 123         {
 124                 return { a => 'inglobalvec', isreturn => 1 };
 125         }
 126         if($op eq 'STATE')
 127         {
 128                 return { a => 'inglobal', b => 'inglobalfunc' };
 129         }
 130         if($op =~ /^INVALID#/)
 131         {
 132                 return { isinvalid => 1 };
 133         }
 134         return { a => 'inglobal', b => 'inglobal', c => 'outglobal' };
 135 }
 136
 137 use constant TYPES => {
 138         int => ['V', 4, signed 32],
 139         ushort => ['v', 2, id],
 140         short => ['v', 2, signed 16],
 141         opcode => ['v', 2, sub { OPCODE_E->[$_[0]] or do { warn "Invalid opcode: $_[0]"; "INVALID#$_[0]"; }; }],
 142         float => ['f', 4, id],
 143         uchar8 => ['a8', 8, sub { [unpack 'C8', $_[0]] }],
 144         global => ['i', 4, sub { { int => $_[0], float => unpack "f", pack "L", $_[0] }; }],
 145         deftype => ['v', 2, sub { { type => ETYPE_E->[$_[0] & ~DEF_SAVEGLOBAL], save => !!($_[0] & DEF_SAVEGLOBAL) }; }],
 146 };
 147
 148 use constant DPROGRAMS_T => [
 149         [int => 'version'],
 150         [int => 'crc'],
 151         [int => 'ofs_statements'],
 152         [int => 'numstatements'],
 153         [int => 'ofs_globaldefs'],
 154         [int => 'numglobaldefs'],
 155         [int => 'ofs_fielddefs'],
 156         [int => 'numfielddefs'],
 157         [int => 'ofs_functions'],
 158         [int => 'numfunctions'],
 159         [int => 'ofs_strings'],
 160         [int => 'numstrings'],
 161         [int => 'ofs_globals'],
 162         [int => 'numglobals'],
 163         [int => 'entityfields']
 164 ];
 165
 166 use constant DSTATEMENT_T => [
 167         [opcode => 'op'],
 168         [short => 'a'],
 169         [short => 'b'],
 170         [short => 'c']
 171 ];
 172
 173 use constant DDEF_T => [
 174         [deftype => 'type'],
 175         [ushort => 'ofs'],
 176         [int => 's_name']
 177 ];
 178
 179 use constant DGLOBAL_T => [
 180         [global => 'v'],
 181 ];
 182
 183 use constant DFUNCTION_T => [
 184         [int => 'first_statement'],
 185         [int => 'parm_start'],
 186         [int => 'locals'],
 187         [int => 'profile'],
 188         [int => 's_name'],
 189         [int => 's_file'],
 190         [int => 'numparms'],
 191         [uchar8 => 'parm_size'],
 192 ];
 193
 194 sub get_section($$$)
 195 {
 196         my ($fh, $start, $len) = @_;
 197         seek $fh, $start, 0
 198                 or die "seek: $!";
 199         $len == read $fh, my $buf, $len
 200                 or die "short read from $start length $len (malformed progs header)";
 201         return $buf;
 202 }
 203
 204 sub parse_section($$$$$)
 205 {
 206         my ($fh, $struct, $start, $len, $cnt) = @_;
 207
 208         my $itemlen = 0;
 209         $itemlen += TYPES->{$_->[0]}->[1]
 210                 for @$struct;
 211         my $packspec = join '', map { TYPES->{$_->[0]}->[0]; } @$struct;
 212         my @packnames = map { $_->[1]; } @$struct;
 213
 214         $len = $cnt * $itemlen
 215                 if not defined $len and defined $cnt;
 216         $cnt = int($len / $itemlen)
 217                 if not defined $cnt and defined $len;
 218         die "Invalid length specification"
 219                 unless defined $len and defined $cnt and $len == $cnt * $itemlen;
 220         die "Invalid length specification in scalar context"
 221                 unless wantarray or $cnt == 1;
 222
 223         seek $fh, $start, 0
 224                 or die "seek: $!";
 225         my @out = map
 226         {
 227                 $itemlen == read $fh, my $buf, $itemlen
 228                         or die "short read from $start length $cnt * $itemlen $(malformed progs header)";
 229                 my %h = ();
 230                 @h{@packnames} = unpack $packspec, $buf;
 231                 $h{$_->[1]} = TYPES->{$_->[0]}->[2]->($h{$_->[1]})
 232                         for @$struct;
 233                 \%h;
 234         }
 235         0..($cnt-1);
 236         return @out
 237                 if wantarray;
 238         return $out[0];
 239 }
 240
 241 sub nfa_default_state_checker()
 242 {
 243         my %seen;
 244         return sub
 245         {
 246                 my ($ip, $state) = @_;
 247                 return $seen{"$ip $state"}++;
 248         };
 249 }
 250
 251 sub run_nfa($$$$$$)
 252 {
 253         my ($progs, $ip, $state, $copy_handler, $state_checker, $instruction_handler) = @_;
 254
 255         my $statements = $progs->{statements};
 256
 257         my $nfa;
 258         $nfa = sub
 259         {
 260                 no warnings 'recursion';
 261
 262                 my ($ip, $state) = @_;
 263                 my $ret = 0;
 264
 265                 for(;;)
 266                 {
 267                         return $ret
 268                                 if $state_checker->($ip, $state);
 269
 270                         my $s = $statements->[$ip];
 271                         my $c = checkop $s->{op};
 272
 273                         if(($ret = $instruction_handler->($ip, $state, $s, $c)))
 274                         {
 275                                 # abort execution
 276                                 last;
 277                         }
 278
 279                         if($c->{isreturn})
 280                         {
 281                                 last;
 282                         }
 283                         elsif($c->{iscall})
 284                         {
 285                                 my $func = $s->{a};
 286                                 my $funcid = $progs->{globals}[$func]{v}{int};
 287                                 last
 288                                         if $progs->{error_func}{$funcid};
 289                                 $ip += 1;
 290                         }
 291                         elsif($c->{isjump})
 292                         {
 293                                 if($c->{isconditional})
 294                                 {
 295                                         if(rand 2)
 296                                         {
 297                                                 if(($ret = $nfa->($ip+$s->{$c->{isjump}}, $copy_handler->($state))) < 0)
 298                                                 {
 299                                                         last;
 300                                                 }
 301                                                 $ip += 1;
 302                                         }
 303                                         else
 304                                         {
 305                                                 $nfa->($ip+1, $copy_handler->($state));
 306                                                 $ip += $s->{$c->{isjump}};
 307                                         }
 308                                 }
 309                                 else
 310                                 {
 311                                         $ip += $s->{$c->{isjump}};
 312                                 }
 313                         }
 314                         else
 315                         {
 316                                 $ip += 1;
 317                         }
 318                 }
 319
 320                 return $ret;
 321         };
 322
 323         $nfa->($ip, $copy_handler->($state));
 324 }
 325
 326 sub get_constant($$)
 327 {
 328         my ($progs, $g) = @_;
 329         if($g->{int} == 0)
 330         {
 331                 return 0;
 332         }
 333         elsif($g->{int} > 0 && $g->{int} < 8388608)
 334         {
 335                 if($g->{int} < length $progs->{strings} && $g->{int} > 0)
 336                 {
 337                         return str($progs->{getstring}->($g->{int}));
 338                 }
 339                 else
 340                 {
 341                         return $g->{int} . "i";
 342                 }
 343         }
 344         else
 345         {
 346                 return $g->{float};
 347         }
 348 }
 349
 350 use constant PRE_MARK_STATEMENT => "";
 351 use constant POST_MARK_STATEMENT => "";
 352 use constant PRE_MARK_OPERAND => "*** ";
 353 use constant POST_MARK_OPERAND => " ***";
 354
 355 use constant INSTRUCTION_FORMAT => "%8s %3s | %-12s ";
 356 use constant OPERAND_FORMAT => "%s";
 357 use constant OPERAND_SEPARATOR => ", ";
 358 use constant INSTRUCTION_SEPARATOR => "\n";
 359
 360 sub str($)
 361 {
 362         my ($str) = @_;
 363         $str =~ s/[\000-\037\\\"\177-\377]/sprintf "\\%03o", ord $&/ge;
 364         return "\"$str\"";
 365 }
 366
 367 sub disassemble_function($$;$)
 368 {
 369         my ($progs, $func, $highlight) = @_;
 370
 371         print "$func->{debugname}:\n";
 372
 373         if($func->{first_statement} < 0) # builtin
 374         {
 375                 printf INSTRUCTION_FORMAT, '', '', '.BUILTIN';
 376                 printf OPERAND_FORMAT, -$func->{first_statement};
 377                 print INSTRUCTION_SEPARATOR;
 378                 return;
 379         }
 380
 381         my $initializer = sub
 382         {
 383                 my ($ofs) = @_;
 384                 my $g = get_constant($progs, $progs->{globals}[$ofs]{v});
 385                 print " = $g"
 386                         if defined $g;
 387         };
 388
 389         printf INSTRUCTION_FORMAT, '', '', '.PARM_START';
 390         printf OPERAND_FORMAT, "$func->{parm_start}";
 391         print INSTRUCTION_SEPARATOR;
 392
 393         printf INSTRUCTION_FORMAT, '', '', '.LOCALS';
 394         printf OPERAND_FORMAT, "$func->{locals}";
 395         print INSTRUCTION_SEPARATOR;
 396
 397         my %override_locals = ();
 398         my $p = $func->{parm_start};
 399         for(0..($func->{numparms}-1))
 400         {
 401                 $override_locals{$p} //= "argv_$_";
 402                 for my $comp(0..($func->{parm_size}[$_]-1))
 403                 {
 404                         $override_locals{$p} //= "argv_$_\[$comp]";
 405                         ++$p;
 406                 }
 407                 printf INSTRUCTION_FORMAT, '', '', '.ARG';
 408                 printf OPERAND_FORMAT, "argv_$_";
 409                 print OPERAND_SEPARATOR;
 410                 printf OPERAND_FORMAT, $func->{parm_size}[$_];
 411                 print INSTRUCTION_SEPARATOR;
 412         }
 413         for($func->{parm_start}..($func->{parm_start} + $func->{locals} - 1))
 414         {
 415                 next
 416                         if exists $override_locals{$_};
 417                 $override_locals{$_} = "local_$_";
 418
 419                 printf INSTRUCTION_FORMAT, '', '', '.LOCAL';
 420                 printf OPERAND_FORMAT, "local_$_";
 421                 $initializer->($_);
 422                 print INSTRUCTION_SEPARATOR;
 423         }
 424
 425         my $getname = sub
 426         {
 427                 my ($ofs) = @_;
 428                 return $override_locals{$ofs}
 429                         if exists $override_locals{$ofs};
 430                 my $def = $progs->{globaldef_byoffset}->($ofs);
 431                 return $def->{debugname};
 432         };
 433
 434         my $operand = sub
 435         {
 436                 my ($ip, $type, $operand) = @_;
 437                 if($type eq 'inglobal')
 438                 {
 439                         my $name = $getname->($operand);
 440                         printf OPERAND_FORMAT, "$name";
 441                 }
 442                 elsif($type eq 'outglobal')
 443                 {
 444                         my $name = $getname->($operand);
 445                         printf OPERAND_FORMAT, "&$name";
 446                 }
 447                 elsif($type eq 'inglobalvec')
 448                 {
 449                         my $name = $getname->($operand);
 450                         printf OPERAND_FORMAT, "$name\[\]";
 451                 }
 452                 elsif($type eq 'outglobalvec')
 453                 {
 454                         my $name = $getname->($operand);
 455                         printf OPERAND_FORMAT, "&$name\[\]";
 456                 }
 457                 elsif($type eq 'inglobalfunc')
 458                 {
 459                         my $name = $getname->($operand);
 460                         printf OPERAND_FORMAT, "$name()";
 461                 }
 462                 elsif($type eq 'ipoffset')
 463                 {
 464                         printf OPERAND_FORMAT, "@{[$ip + $operand]}" . sprintf ' ($%+d)', $operand;
 465                 }
 466                 else
 467                 {
 468                         die "unknown type: $type";
 469                 }
 470         };
 471
 472         my $statements = $func->{statements};
 473         my $come_from = $func->{come_from};
 474
 475         my $ipprev = undef;
 476         for my $ip(sort { $a <=> $b } keys %$statements)
 477         {
 478                 if($ip == $func->{first_statement})
 479                 {
 480                         printf INSTRUCTION_FORMAT, $ip, '', '.ENTRY';
 481                         print INSTRUCTION_SEPARATOR;
 482                 }
 483                 if(defined $ipprev && $ip != $ipprev + 1)
 484                 {
 485                         printf INSTRUCTION_FORMAT, $ip, '', '.SKIP';
 486                         printf OPERAND_FORMAT, $ip - $ipprev - 1;
 487                         print INSTRUCTION_SEPARATOR;
 488                 }
 489                 if(my $cf = $come_from->{$ip})
 490                 {
 491                         printf INSTRUCTION_FORMAT, $ip, '', '.XREF';
 492                         my $cnt = 0;
 493                         for(sort { $a <=> $b } keys %$cf)
 494                         {
 495                                 print OPERAND_SEPARATOR
 496                                         if $cnt++;
 497                                 printf OPERAND_FORMAT, ($cf->{$_} ? 'c' : 'j') . $_ . sprintf ' ($%+d)', $_ - $ip;
 498                         }
 499                         print INSTRUCTION_SEPARATOR;
 500                 }
 501
 502                 my $op = $progs->{statements}[$ip]{op};
 503                 my $ipt = $progs->{statements}[$ip];
 504                 my $opprop = checkop $op;
 505
 506                 if($highlight and $highlight->{$ip})
 507                 {
 508                         for(values %{$highlight->{$ip}})
 509                         {
 510                                 for(sort keys %$_)
 511                                 {
 512                                         print PRE_MARK_STATEMENT;
 513                                         printf INSTRUCTION_FORMAT, '', '<!>', '.WARN';
 514                                         printf OPERAND_FORMAT, "$_ (in $func->{debugname})";
 515                                         print INSTRUCTION_SEPARATOR;
 516                                 }
 517                         }
 518                 }
 519
 520                 print PRE_MARK_STATEMENT
 521                         if $highlight and $highlight->{$ip};
 522
 523                 my $showip = $opprop->{isjump};
 524                 printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? '<!>' : '', $op;
 525
 526                 my $cnt = 0;
 527                 for my $o(qw(a b c))
 528                 {
 529                         next
 530                                 if not defined $opprop->{$o};
 531                         print OPERAND_SEPARATOR
 532                                 if $cnt++;
 533                         print PRE_MARK_OPERAND
 534                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 535                         $operand->($ip, $opprop->{$o}, $ipt->{$o});
 536                         print POST_MARK_OPERAND
 537                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 538                 }
 539
 540                 print POST_MARK_STATEMENT
 541                         if $highlight and $highlight->{$ip};
 542
 543                 print INSTRUCTION_SEPARATOR;
 544         }
 545 }
 546
 547 sub find_uninitialized_locals($$)
 548 {
 549         my ($progs, $func) = @_;
 550
 551         return
 552                 if $func->{first_statement} < 0; # builtin
 553
 554         print STDERR "Checking $func->{debugname}...\n";
 555
 556         my $p = $func->{parm_start};
 557         for(0..($func->{numparms}-1))
 558         {
 559                 $p += $func->{parm_size}[$_];
 560         }
 561
 562         use constant WATCHME_R => 1;
 563         use constant WATCHME_W => 2;
 564         use constant WATCHME_X => 4;
 565         use constant WATCHME_T => 8;
 566         my %watchme = map { $_ => WATCHME_X } ($func->{parm_start} .. ($func->{parm_start} + $func->{locals} - 1));
 567
 568         for(keys %{$progs->{temps}})
 569         {
 570                 next
 571                         if exists $watchme{$_};
 572                 if($progs->{temps}{$_})
 573                 {
 574                         # shared temp
 575                         $watchme{$_} = WATCHME_T | WATCHME_X
 576                 }
 577                 else
 578                 {
 579                         # unique temp
 580                         $watchme{$_} = WATCHME_X
 581                 }
 582         }
 583
 584         $watchme{$_} |= WATCHME_R
 585                 for keys %{$func->{globals_read}};
 586         $watchme{$_} |= WATCHME_W
 587                 for keys %{$func->{globals_written}};
 588
 589         my %write_places = ();
 590         for my $ofs(keys %{$func->{globals_written}})
 591         {
 592                 next
 593                         unless exists $watchme{$ofs} and $watchme{$ofs} & WATCHME_X;
 594                 for my $ip(keys %{$func->{globals_written}{$ofs}})
 595                 {
 596                         for my $op(keys %{$func->{globals_written}{$ofs}{$ip}})
 597                         {
 598                                 push @{$write_places{$ip}{$op}}, $ofs;
 599                         }
 600                 }
 601         }
 602
 603         for(keys %watchme)
 604         {
 605                 delete $watchme{$_}
 606                         if ($watchme{$_} & (WATCHME_R | WATCHME_W | WATCHME_X)) != (WATCHME_R | WATCHME_W | WATCHME_X);
 607         }
 608
 609         return
 610                 if not keys %watchme;
 611
 612         for(keys %watchme)
 613         {
 614                 $watchme{$_} = {
 615                         flags => $watchme{$_},
 616                         valid => [0, undef, undef]
 617                 };
 618         }
 619
 620         # mark parameters as initialized
 621         for($func->{parm_start} .. ($p-1))
 622         {
 623                 $watchme{$_}{valid} = [1, undef, undef]
 624                         if defined $watchme{$_};
 625         }
 626
 627         my %warned = ();
 628         my %ip_seen = ();
 629         run_nfa $progs, $func->{first_statement}, \%watchme,
 630                 sub {
 631                         my ($h) = @_;
 632                         return { map { $_ => { %{$h->{$_}} } } keys %$h };
 633                 },
 634                 sub {
 635                         my ($ip, $state) = @_;
 636
 637                         my $s = $ip_seen{$ip};
 638                         if($s)
 639                         {
 640                                 # if $state is stronger or equal to $s, return 1
 641
 642                                 for(keys %$state)
 643                                 {
 644                                         if($state->{$_}{valid}[0] < $s->{$_})
 645                                         {
 646                                                 # The current state is LESS valid than the previously run one. We NEED to run this.
 647                                                 # The saved state can safely become the intersection [citation needed].
 648                                                 for(keys %$state)
 649                                                 {
 650                                                         $s->{$_} = $state->{$_}{valid}[0]
 651                                                                 if $state->{$_}{valid}[0] < $s->{$_};
 652                                                 }
 653                                                 return 0;
 654                                         }
 655                                 }
 656                                 # if we get here, $state is stronger or equal. No need to try it.
 657                                 return 1;
 658                         }
 659                         else
 660                         {
 661                                 # Never seen this IP yet.
 662                                 $ip_seen{$ip} = { map { ($_ => $state->{$_}{valid}[0]); } keys %$state };
 663                                 return 0;
 664                         }
 665                 },
 666                 sub {
 667                         my ($ip, $state, $s, $c) = @_;
 668                         my $op = $s->{op};
 669
 670                         # QCVM BUG: RETURN always takes vector, there is no float equivalent
 671                         my $return_hack = $c->{isreturn} // 0;
 672
 673                         if($op eq 'STORE_V')
 674                         {
 675                                 # COMPILER BUG of QCC: params are always copied using STORE_V
 676                                 if($s->{b} >= 4 && $s->{b} < 28) # parameter range
 677                                 {
 678                                         $return_hack = 1;
 679                                 }
 680                         }
 681
 682                         if($c->{isinvalid})
 683                         {
 684                                 ++$warned{$ip}{''}{"Invalid opcode"};
 685                         }
 686                         for(qw(a b c))
 687                         {
 688                                 my $type = $c->{$_};
 689                                 next
 690                                         unless defined $type;
 691
 692                                 my $ofs = $s->{$_};
 693
 694                                 my $read = sub
 695                                 {
 696                                         my ($ofs) = @_;
 697                                         ++$return_hack
 698                                                 if $return_hack;
 699                                         return
 700                                                 if not exists $state->{$ofs};
 701                                         my $valid = $state->{$ofs}{valid};
 702                                         if($valid->[0] == 0)
 703                                         {
 704                                                 # COMPILER BUG of FTEQCC: AND and OR may take uninitialized as second argument (logicops)
 705                                                 if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b'))
 706                                                 {
 707                                                         ++$warned{$ip}{$_}{"Use of uninitialized value"};
 708                                                 }
 709                                         }
 710                                         elsif($valid->[0] < 0)
 711                                         {
 712                                                 # COMPILER BUG of FTEQCC: AND and OR may take uninitialized as second argument (logicops)
 713                                                 if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b'))
 714                                                 {
 715                                                         ++$warned{$ip}{$_}{"Use of temporary across CALL"};
 716                                                 }
 717                                         }
 718                                         else
 719                                         {
 720                                                 # it's VALID
 721                                                 if(defined $valid->[1])
 722                                                 {
 723                                                         delete $write_places{$valid->[1]}{$valid->[2]};
 724                                                 }
 725                                         }
 726                                 };
 727                                 my $write = sub
 728                                 {
 729                                         my ($ofs) = @_;
 730                                         $state->{$ofs}{valid} = [1, $ip, $_]
 731                                                 if exists $state->{$ofs};
 732                                 };
 733
 734                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 735                                 {
 736                                         $read->($ofs);
 737                                 }
 738                                 elsif($type eq 'inglobalvec')
 739                                 {
 740                                         $read->($ofs);
 741                                         $read->($ofs+1);
 742                                         $read->($ofs+2);
 743                                 }
 744                                 elsif($type eq 'outglobal')
 745                                 {
 746                                         $write->($ofs);
 747                                 }
 748                                 elsif($type eq 'outglobalvec')
 749                                 {
 750                                         $write->($ofs);
 751                                         $write->($ofs+1);
 752                                         $write->($ofs+2);
 753                                 }
 754                                 elsif($type eq 'ipoffset')
 755                                 {
 756                                         ++$warned{$ip}{$_}{"Endless loop"}
 757                                                 if $ofs == 0;
 758                                         ++$warned{$ip}{$_}{"No-operation jump"}
 759                                                 if $ofs == 1;
 760                                 }
 761                         }
 762                         if($c->{iscall})
 763                         {
 764                                 # builtin calls may clobber stuff
 765                                 my $func = $s->{a};
 766                                 my $funcid = $progs->{globals}[$func]{v}{int};
 767                                 my $funcobj = $progs->{functions}[$funcid];
 768                                 if(!$funcobj || $funcobj->{first_statement} >= 0)
 769                                 {
 770                                         # invalidate temps
 771                                         for(values %$state)
 772                                         {
 773                                                 if($_->{flags} & WATCHME_T)
 774                                                 {
 775                                                         $_->{valid} = [-1, undef, undef];
 776                                                 }
 777                                         }
 778                                 }
 779                         }
 780
 781                         return 0;
 782                 };
 783
 784         for my $ip(keys %write_places)
 785         {
 786                 for my $operand(keys %{$write_places{$ip}})
 787                 {
 788                         # TODO verify it
 789                         my %left = map { $_ => 1 } @{$write_places{$ip}{$operand}};
 790                         my $isread = 0;
 791
 792                         my %writeplace_seen = ();
 793                         run_nfa $progs, $ip+1, \%left,
 794                                 sub
 795                                 {
 796                                         return { %{$_[0]} };
 797                                 },
 798                                 sub
 799                                 {
 800                                         my ($ip, $state) = @_;
 801                                         return $writeplace_seen{"$ip " . join " ", sort keys %$state}++;
 802                                 },
 803                                 sub
 804                                 {
 805                                         my ($ip, $state, $s, $c) = @_;
 806                                         for(qw(a b c))
 807                                         {
 808                                                 my $type = $c->{$_};
 809                                                 next
 810                                                         unless defined $type;
 811
 812                                                 my $ofs = $s->{$_};
 813                                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 814                                                 {
 815                                                         if($state->{$ofs})
 816                                                         {
 817                                                                 $isread = 1;
 818                                                                 return -1; # exit TOTALLY
 819                                                         }
 820                                                 }
 821                                                 elsif($type eq 'inglobalvec')
 822                                                 {
 823                                                         if($state->{$ofs} || $state->{$ofs+1} || $state->{$ofs+2})
 824                                                         {
 825                                                                 $isread = 1;
 826                                                                 return -1; # exit TOTALLY
 827                                                         }
 828                                                 }
 829                                                 elsif($type eq 'outglobal')
 830                                                 {
 831                                                         delete $state->{$ofs};
 832                                                         return 1
 833                                                                 if !%$state;
 834                                                 }
 835                                                 elsif($type eq 'outglobalvec')
 836                                                 {
 837                                                         delete $state->{$ofs};
 838                                                         delete $state->{$ofs+1};
 839                                                         delete $state->{$ofs+2};
 840                                                         return 1
 841                                                                 if !%$state;
 842                                                 }
 843                                         }
 844                                         return 0;
 845                                 };
 846
 847                         if(!$isread)
 848                         {
 849                                 ++$warned{$ip}{$operand}{"Value is never used"};
 850                         }
 851                 }
 852         }
 853
 854         disassemble_function($progs, $func, \%warned)
 855                 if keys %warned;
 856 }
 857
 858 use constant DEFAULTGLOBALS => [
 859         "OFS_NULL",
 860         "OFS_RETURN",
 861         "OFS_RETURN[1]",
 862         "OFS_RETURN[2]",
 863         "OFS_PARM0",
 864         "OFS_PARM0[1]",
 865         "OFS_PARM0[2]",
 866         "OFS_PARM1",
 867         "OFS_PARM1[1]",
 868         "OFS_PARM1[2]",
 869         "OFS_PARM2",
 870         "OFS_PARM2[1]",
 871         "OFS_PARM2[2]",
 872         "OFS_PARM3",
 873         "OFS_PARM3[1]",
 874         "OFS_PARM3[2]",
 875         "OFS_PARM4",
 876         "OFS_PARM4[1]",
 877         "OFS_PARM4[2]",
 878         "OFS_PARM5",
 879         "OFS_PARM5[1]",
 880         "OFS_PARM5[2]",
 881         "OFS_PARM6",
 882         "OFS_PARM6[1]",
 883         "OFS_PARM6[2]",
 884         "OFS_PARM7",
 885         "OFS_PARM7[1]",
 886         "OFS_PARM7[2]"
 887 ];
 888
 889 sub defaultglobal($)
 890 {
 891         my ($ofs) = @_;
 892         if($ofs < @{(DEFAULTGLOBALS)})
 893         {
 894                 return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
 895         }
 896         return { ofs => $ofs, s_name => undef, debugname => "<undefined>\@$ofs", type => undef };
 897 }
 898
 899 sub detect_constants($)
 900 {
 901         my ($progs) = @_;
 902         use constant GLOBALFLAG_R => 1; # read
 903         use constant GLOBALFLAG_W => 2; # written
 904         use constant GLOBALFLAG_S => 4; # saved
 905         use constant GLOBALFLAG_I => 8; # initialized
 906         use constant GLOBALFLAG_N => 16; # named
 907         use constant GLOBALFLAG_Q => 32; # unique to function
 908         use constant GLOBALFLAG_U => 64; # unused
 909         use constant GLOBALFLAG_P => 128; # possibly parameter passing
 910         use constant GLOBALFLAG_D => 256; # has a def
 911         my @globalflags = (GLOBALFLAG_Q | GLOBALFLAG_U) x (@{$progs->{globals}} + 2);
 912
 913         for(@{$progs->{functions}})
 914         {
 915                 for(keys %{$_->{globals_used}})
 916                 {
 917                         if($globalflags[$_] & GLOBALFLAG_U)
 918                         {
 919                                 $globalflags[$_] &= ~GLOBALFLAG_U;
 920                         }
 921                         elsif($globalflags[$_] & GLOBALFLAG_Q)
 922                         {
 923                                 $globalflags[$_] &= ~GLOBALFLAG_Q;
 924                         }
 925                 }
 926                 $globalflags[$_] |= GLOBALFLAG_R
 927                         for keys %{$_->{globals_read}};
 928                 $globalflags[$_] |= GLOBALFLAG_W
 929                         for keys %{$_->{globals_written}};
 930                 next
 931                         if $_->{first_statement} < 0;
 932                 for my $ip($_->{first_statement} .. (@{$progs->{statements}}-1))
 933                 {
 934                         my $s = $progs->{statements}[$ip];
 935                         if($s->{op} eq 'STORE_V')
 936                         {
 937                                 $globalflags[$s->{a}] |= GLOBALFLAG_P
 938                                         if $s->{b} >= $_->{parm_start} and $s->{b} < $_->{parm_start} + $_->{locals};
 939                                 $globalflags[$s->{a}+1] |= GLOBALFLAG_P
 940                                         if $s->{b}+1 >= $_->{parm_start} and $s->{b}+1 < $_->{parm_start} + $_->{locals};
 941                                 $globalflags[$s->{a}+2] |= GLOBALFLAG_P
 942                                         if $s->{b}+2 >= $_->{parm_start} and $s->{b}+2 < $_->{parm_start} + $_->{locals};
 943                         }
 944                         elsif($s->{op} =~ /^STORE_/)
 945                         {
 946                                 $globalflags[$s->{a}] |= GLOBALFLAG_P
 947                                         if $s->{b} >= $_->{parm_start} and $s->{b} < $_->{parm_start} + $_->{locals};
 948                         }
 949                         else
 950                         {
 951                                 last;
 952                         }
 953                 }
 954         }
 955
 956         # parameter passing globals are only ever used in STORE_ instructions
 957         for my $s(@{$progs->{statements}})
 958         {
 959                 next
 960                         if $s->{op} =~ /^STORE_/;
 961
 962                 my $c = checkop $s->{op};
 963
 964                 for(qw(a b c))
 965                 {
 966                         my $type = $c->{$_};
 967                         next
 968                                 unless defined $type;
 969
 970                         my $ofs = $s->{$_};
 971                         if($type eq 'inglobal' || $type eq 'inglobalfunc' || $type eq 'outglobal')
 972                         {
 973                                 $globalflags[$ofs] &= ~GLOBALFLAG_P;
 974                         }
 975                         if($type eq 'inglobalvec' || $type eq 'outglobalvec')
 976                         {
 977                                 $globalflags[$ofs] &= ~GLOBALFLAG_P;
 978                                 $globalflags[$ofs+1] &= ~GLOBALFLAG_P;
 979                                 $globalflags[$ofs+2] &= ~GLOBALFLAG_P;
 980                         }
 981                 }
 982         }
 983
 984         my %offsets_saved = ();
 985         for(@{$progs->{globaldefs}})
 986         {
 987                 my $type = $_->{type};
 988                 my $name = $progs->{getstring}->($_->{s_name});
 989                 $name = ''
 990                         if $name eq 'IMMEDIATE' or $name =~ /^\./;
 991                 $_->{debugname} = $name
 992                         if $name ne '';
 993                 $globalflags[$_->{ofs}] |= GLOBALFLAG_D;
 994                 if($type->{save})
 995                 {
 996                         $globalflags[$_->{ofs}] |= GLOBALFLAG_S;
 997                 }
 998                 if(defined $_->{debugname})
 999                 {
1000                         $globalflags[$_->{ofs}] |= GLOBALFLAG_N;
1001                 }
1002         }
1003         # fix up vectors
1004         my @extradefs = ();
1005         for(@{$progs->{globaldefs}})
1006         {
1007                 my $type = $_->{type};
1008                 for my $i(1..(typesize($type->{type})-1))
1009                 {
1010                         # add missing def
1011                         if(!($globalflags[$_->{ofs}+$i] & GLOBALFLAG_D))
1012                         {
1013                                 print "Missing globaldef for a component@{[defined $_->{debugname} ? ' of ' . $_->{debugname} : '']} at $_->{ofs}+$i\n";
1014                                 push @extradefs, {
1015                                         type => {
1016                                                 saved => 0,
1017                                                 type => 'float'
1018                                         },
1019                                         ofs => $_->{ofs} + $i,
1020                                         debugname => defined $_->{debugname} ? $_->{debugname} . "[$i]" : undef
1021                                 };
1022                         }
1023                         # "saved" and "named" states hit adjacent globals too
1024                         $globalflags[$_->{ofs}+$i] |= $globalflags[$_->{ofs}] & (GLOBALFLAG_S | GLOBALFLAG_N | GLOBALFLAG_D);
1025                 }
1026         }
1027         push @{$progs->{globaldefs}}, @extradefs;
1028
1029         my %offsets_initialized = ();
1030         for(0..(@{$progs->{globals}}-1))
1031         {
1032                 if($progs->{globals}[$_]{v}{int})
1033                 {
1034                         $globalflags[$_] |= GLOBALFLAG_I;
1035                 }
1036         }
1037
1038         my @globaltypes = (undef) x @{$progs->{globals}};
1039
1040         my %istemp = ();
1041         for(0..(@{$progs->{globals}}-1))
1042         {
1043                 next
1044                         if $_ < @{(DEFAULTGLOBALS)};
1045                 if(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == 0)
1046                 {
1047                         $globaltypes[$_] = "unused";
1048                 }
1049                 elsif(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == GLOBALFLAG_R)
1050                 {
1051                         # so it is ro
1052                         if(($globalflags[$_] & GLOBALFLAG_N) == GLOBALFLAG_N)
1053                         {
1054                                 $globaltypes[$_] = "read_only";
1055                         }
1056                         elsif(($globalflags[$_] & GLOBALFLAG_S) == 0)
1057                         {
1058                                 $globaltypes[$_] = "const";
1059                         }
1060                         else
1061                         {
1062                                 $globaltypes[$_] = "read_only";
1063                         }
1064                 }
1065                 elsif(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == GLOBALFLAG_W)
1066                 {
1067                         $globaltypes[$_] = "write_only";
1068                 }
1069                 else
1070                 {
1071                         # now we know it is rw
1072                         if(($globalflags[$_] & GLOBALFLAG_N) == GLOBALFLAG_N)
1073                         {
1074                                 $globaltypes[$_] = "global";
1075                         }
1076                         elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == 0)
1077                         {
1078                                 if($globalflags[$_] & GLOBALFLAG_P)
1079                                 {
1080                                         $globaltypes[$_] = "OFS_PARM";
1081                                 }
1082                                 elsif($globalflags[$_] & GLOBALFLAG_Q)
1083                                 {
1084                                         $globaltypes[$_] = "uniquetemp";
1085                                         $istemp{$_} = 0;
1086                                 }
1087                                 else
1088                                 {
1089                                         $globaltypes[$_] = "temp";
1090                                         $istemp{$_} = 1;
1091                                 }
1092                         }
1093                         elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == GLOBALFLAG_I)
1094                         {
1095                                 $globaltypes[$_] = "not_saved";
1096                         }
1097                         else
1098                         {
1099                                 $globaltypes[$_] = "global";
1100                         }
1101                 }
1102         }
1103         $progs->{temps} = \%istemp;
1104
1105         # globaldefs
1106         my @globaldefs = (undef) x @{$progs->{globals}};
1107         for(@{$progs->{globaldefs}})
1108         {
1109                 $globaldefs[$_->{ofs}] //= $_
1110                         if defined $_->{debugname};
1111         }
1112         for(@{$progs->{globaldefs}})
1113         {
1114                 $globaldefs[$_->{ofs}] //= $_;
1115         }
1116         for(0..(@{$progs->{globals}}-1))
1117         {
1118                 $globaldefs[$_] //= {
1119                         ofs => $_,
1120                         s_name => undef,
1121                         debugname => undef,
1122                         type => undef
1123                 };
1124         }
1125         for(0..(@{(DEFAULTGLOBALS)}-1))
1126         {
1127                 $globaldefs[$_] = { ofs => $_, s_name => undef, debugname => DEFAULTGLOBALS->[$_], type => undef };
1128                 $globaltypes[$_] = 'defglobal';
1129         }
1130         my %globaldefs_namecount = ();
1131         for(@globaldefs)
1132         {
1133                 $_->{globaltype} = $globaltypes[$_->{ofs}];
1134                 if(defined $_->{debugname})
1135                 {
1136                         # already has debugname
1137                 }
1138                 elsif($_->{globaltype} eq 'const')
1139                 {
1140                         $_->{debugname} = get_constant($progs, $progs->{globals}[$_->{ofs}]{v});
1141                 }
1142                 else
1143                 {
1144                         $_->{debugname} = "$_->{globaltype}_$_->{ofs}";
1145                 }
1146                 ++$globaldefs_namecount{$_->{debugname}};
1147         }
1148         for(@globaldefs)
1149         {
1150                 next
1151                         if $globaldefs_namecount{$_->{debugname}} <= 1 && !$ENV{FORCE_OFFSETS};
1152                 #print "Not unique: $_->{debugname} at $_->{ofs}\n";
1153                 $_->{debugname} .= "\@$_->{ofs}";
1154         }
1155         $progs->{globaldef_byoffset} = sub
1156         {
1157                 my ($ofs) = @_;
1158                 my $def = $globaldefs[$ofs];
1159                 return $def;
1160         };
1161 }
1162
1163 sub parse_progs($)
1164 {
1165         my ($fh) = @_;
1166
1167         my %p = ();
1168
1169         print STDERR "Parsing header...\n";
1170         $p{header} = parse_section $fh, DPROGRAMS_T, 0, undef, 1;
1171
1172         print STDERR "Parsing strings...\n";
1173         $p{strings} = get_section $fh, $p{header}{ofs_strings}, $p{header}{numstrings};
1174         $p{getstring} = sub
1175         {
1176                 my ($startpos) = @_;
1177                 my $endpos = index $p{strings}, "\0", $startpos;
1178                 return substr $p{strings}, $startpos, $endpos - $startpos;
1179         };
1180
1181         print STDERR "Parsing globals...\n";
1182         $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}];
1183
1184         print STDERR "Parsing globaldefs...\n";
1185         $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}];
1186
1187         print STDERR "Range checking globaldefs...\n";
1188         for(0 .. (@{$p{globaldefs}}-1))
1189         {
1190                 my $g = $p{globaldefs}[$_];
1191                 die "Out of range name in globaldef $_"
1192                         if $g->{s_name} < 0 || $g->{s_name} >= length $p{strings};
1193                 my $name = $p{getstring}->($g->{s_name});
1194                 die "Out of range ofs $g->{ofs} in globaldef $_ (name: \"$name\")"
1195                         if $g->{ofs} >= $p{globals};
1196         }
1197
1198         print STDERR "Parsing fielddefs...\n";
1199         $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}];
1200
1201         print STDERR "Range checking fielddefs...\n";
1202         for(0 .. (@{$p{fielddefs}}-1))
1203         {
1204                 my $g = $p{fielddefs}[$_];
1205                 die "Out of range name in fielddef $_"
1206                         if $g->{s_name} < 0 || $g->{s_name} >= length $p{strings};
1207                 my $name = $p{getstring}->($g->{s_name});
1208                 die "Out of range ofs $g->{ofs} in fielddef $_ (name: \"$name\")"
1209                         if $g->{ofs} >= $p{header}{entityfields};
1210         }
1211
1212         print STDERR "Parsing statements...\n";
1213         $p{statements} = [parse_section $fh, DSTATEMENT_T, $p{header}{ofs_statements}, undef, $p{header}{numstatements}];
1214
1215         print STDERR "Parsing functions...\n";
1216         $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}];
1217
1218         print STDERR "Range checking functions...\n";
1219         for(0 .. (@{$p{functions}} - 1))
1220         {
1221                 my $f = $p{functions}[$_];
1222                 die "Out of range name in function $_"
1223                         if $f->{s_name} < 0 || $f->{s_name} >= length $p{strings};
1224                 my $name = $p{getstring}->($f->{s_name});
1225                 die "Out of range file in function $_"
1226                         if $f->{s_file} < 0 || $f->{s_file} >= length $p{strings};
1227                 my $file = $p{getstring}->($f->{s_file});
1228                 die "Out of range first_statement in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1229                         if $f->{first_statement} >= @{$p{statements}};
1230                 if($f->{first_statement} >= 0)
1231                 {
1232                         die "Out of range parm_start in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1233                                 if $f->{parm_start} < 0 || $f->{parm_start} >= @{$p{globals}};
1234                         die "Out of range locals in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1235                                 if $f->{locals} < 0 || $f->{parm_start} + $f->{locals} > @{$p{globals}};
1236                         die "Out of range numparms $f->{numparms} in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1237                                 if $f->{numparms} < 0 || $f->{numparms} > 8;
1238                         my $totalparms = 0;
1239                         for(0..($f->{numparms}-1))
1240                         {
1241                                 die "Out of range parm_size[$_] in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1242                                         unless { 0 => 1, 1 => 1, 3 => 1 }->{$f->{parm_size}[$_]};
1243                                 $totalparms += $f->{parm_size}[$_];
1244                         }
1245                         die "Out of range parms in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1246                                 if $f->{parm_start} + $totalparms > @{$p{globals}};
1247                         die "More parms than locals in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1248                                 if $totalparms > $f->{locals};
1249                 }
1250         }
1251
1252         print STDERR "Range checking statements...\n";
1253         for my $ip(0 .. (@{$p{statements}}-1))
1254         {
1255                 my $s = $p{statements}[$ip];
1256                 my $c = checkop $s->{op};
1257
1258                 for(qw(a b c))
1259                 {
1260                         my $type = $c->{$_};
1261                         next
1262                                 unless defined $type;
1263
1264                         if($type eq 'inglobal' || $type eq 'inglobalfunc')
1265                         {
1266                                 $s->{$_} &= 0xFFFF;
1267                                 die "Out of range global offset in statement $ip - cannot continue"
1268                                         if $s->{$_} >= @{$p{globals}};
1269                         }
1270                         elsif($type eq 'inglobalvec')
1271                         {
1272                                 $s->{$_} &= 0xFFFF;
1273                                 if($c->{isreturn})
1274                                 {
1275                                         die "Out of range global offset in statement $ip - cannot continue"
1276                                                 if $s->{$_} >= @{$p{globals}};
1277                                         print "Potentially out of range global offset in statement $ip - may crash engines"
1278                                                 if $s->{$_} >= @{$p{globals}}-2;
1279                                 }
1280                                 else
1281                                 {
1282                                         die "Out of range global offset in statement $ip - cannot continue"
1283                                                 if $s->{$_} >= @{$p{globals}}-2;
1284                                 }
1285                         }
1286                         elsif($type eq 'outglobal')
1287                         {
1288                                 $s->{$_} &= 0xFFFF;
1289                                 die "Out of range global offset in statement $ip - cannot continue"
1290                                         if $s->{$_} >= @{$p{globals}};
1291                         }
1292                         elsif($type eq 'outglobalvec')
1293                         {
1294                                 $s->{$_} &= 0xFFFF;
1295                                 die "Out of range global offset in statement $ip - cannot continue"
1296                                         if $s->{$_} >= @{$p{globals}}-2;
1297                         }
1298                         elsif($type eq 'ipoffset')
1299                         {
1300                                 die "Out of range GOTO/IF/IFNOT in statement $ip - cannot continue"
1301                                         if $ip + $s->{$_} < 0 || $ip + $s->{$_} >= @{$p{statements}};
1302                         }
1303                 }
1304         }
1305
1306         print STDERR "Looking for error()...\n";
1307         $p{error_func} = {};
1308         for(@{$p{globaldefs}})
1309         {
1310                 next
1311                         if $p{getstring}($_->{s_name}) ne 'error';
1312                 my $v = $p{globals}[$_->{ofs}]{v}{int};
1313                 next
1314                         if $v <= 0 || $v >= @{$p{functions}};
1315                 my $first = $p{functions}[$v]{first_statement};
1316                 next
1317                         if $first >= 0;
1318                 print STDERR "Detected error() at offset $_->{ofs} (builtin #@{[-$first]})\n";
1319                 $p{error_func}{$_->{ofs}} = 1;
1320         }
1321
1322         print STDERR "Scanning functions...\n";
1323         for(@{$p{functions}})
1324         {
1325                 my $file = $p{getstring}->($_->{s_file});
1326                 my $name = $p{getstring}->($_->{s_name});
1327                 $name = "$file:$name"
1328                         if length $file;
1329                 $_->{debugname} = $name;
1330
1331                 next
1332                         if $_->{first_statement} < 0;
1333
1334                 my %statements = ();
1335                 my %come_from = ();
1336                 my %go_to = ();
1337                 my %globals_read = ();
1338                 my %globals_written = ();
1339                 my %globals_used = ();
1340
1341                 if($_->{first_statement} >= 0)
1342                 {
1343                         run_nfa \%p, $_->{first_statement}, "", id, nfa_default_state_checker,
1344                                 sub
1345                                 {
1346                                         my ($ip, $state, $s, $c) = @_;
1347                                         ++$statements{$ip};
1348
1349                                         if(my $j = $c->{isjump})
1350                                         {
1351                                                 my $t = $ip + $s->{$j};
1352                                                 $come_from{$t}{$ip} = $c->{isconditional};
1353                                                 $go_to{$ip}{$t} = $c->{isconditional};
1354                                         }
1355
1356                                         for my $o(qw(a b c))
1357                                         {
1358                                                 my $type = $c->{$o}
1359                                                         or next;
1360                                                 my $ofs = $s->{$o};
1361
1362                                                 my $read = sub
1363                                                 {
1364                                                         my ($ofs) = @_;
1365                                                         $globals_read{$ofs}{$ip}{$o} = 1;
1366                                                         $globals_used{$ofs} = 1;
1367                                                 };
1368                                                 my $write = sub
1369                                                 {
1370                                                         my ($ofs) = @_;
1371                                                         $globals_written{$ofs}{$ip}{$o} = 1;
1372                                                         $globals_used{$ofs} = 1;
1373                                                 };
1374
1375                                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
1376                                                 {
1377                                                         $read->($ofs);
1378                                                 }
1379                                                 elsif($type eq 'inglobalvec')
1380                                                 {
1381                                                         $read->($ofs);
1382                                                         $read->($ofs+1);
1383                                                         $read->($ofs+2);
1384                                                 }
1385                                                 elsif($type eq 'outglobal')
1386                                                 {
1387                                                         $write->($ofs);
1388                                                 }
1389                                                 elsif($type eq 'outglobalvec')
1390                                                 {
1391                                                         $write->($ofs);
1392                                                         $write->($ofs+1);
1393                                                         $write->($ofs+2);
1394                                                 }
1395                                         }
1396
1397                                         return 0;
1398                                 };
1399                 }
1400
1401                 $_->{statements} = \%statements;
1402                 $_->{come_from} = \%come_from;
1403                 $_->{go_to} = \%go_to;
1404                 $_->{globals_read} = \%globals_read;
1405                 $_->{globals_written} = \%globals_written;
1406                 $_->{globals_used} = \%globals_used;
1407
1408                 # using this info, we could now identify basic blocks
1409         }
1410
1411         print STDERR "Detecting constants and temps, and naming...\n";
1412         detect_constants \%p;
1413
1414         if($ENV{DUMP})
1415         {
1416                 use Data::Dumper;
1417                 print Dumper \%p;
1418                 return;
1419         }
1420
1421         # what do we want to do?
1422         my $checkfunc = \&find_uninitialized_locals;
1423         if($ENV{DISASSEMBLE})
1424         {
1425                 $checkfunc = \&disassemble_function;
1426         }
1427         for(sort { $a->{debugname} cmp $b->{debugname} } @{$p{functions}})
1428         {
1429                 $checkfunc->(\%p, $_);
1430         }
1431 }
1432
1433 open my $fh, '<', $ARGV[0];
1434 parse_progs $fh;