misc/tools/progs-analyzer.pl

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