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                                 my $funcobj = $progs->{functions}[$funcid];
 277                                 if($funcobj && $funcobj->{first_statement} < 0) # builtin
 278                                 {
 279                                         my $def = $progs->{globaldef_byoffset}->($func);
 280                                         last
 281                                                 if $def->{debugname} eq '$error';
 282                                 }
 283                                 $ip += 1;
 284                         }
 285                         elsif($c->{isjump})
 286                         {
 287                                 if($c->{isconditional})
 288                                 {
 289                                         if(rand 2)
 290                                         {
 291                                                 if(($ret = $nfa->($ip+$s->{$c->{isjump}}, $copy_handler->($state))) < 0)
 292                                                 {
 293                                                         last;
 294                                                 }
 295                                                 $ip += 1;
 296                                         }
 297                                         else
 298                                         {
 299                                                 $nfa->($ip+1, $copy_handler->($state));
 300                                                 $ip += $s->{$c->{isjump}};
 301                                         }
 302                                 }
 303                                 else
 304                                 {
 305                                         $ip += $s->{$c->{isjump}};
 306                                 }
 307                         }
 308                         else
 309                         {
 310                                 $ip += 1;
 311                         }
 312                 }
 313
 314                 return $ret;
 315         };
 316
 317         $nfa->($ip, $copy_handler->($state));
 318 }
 319
 320 sub get_constant($$)
 321 {
 322         my ($progs, $g) = @_;
 323         if($g->{int} == 0)
 324         {
 325                 return 0;
 326         }
 327         elsif($g->{int} > 0 && $g->{int} < 8388608)
 328         {
 329                 if($g->{int} < length $progs->{strings} && $g->{int} > 0)
 330                 {
 331                         return str($progs->{getstring}->($g->{int}));
 332                 }
 333                 else
 334                 {
 335                         return $g->{int} . "i";
 336                 }
 337         }
 338         else
 339         {
 340                 return $g->{float};
 341         }
 342 }
 343
 344 use constant PRE_MARK_STATEMENT => "";
 345 use constant POST_MARK_STATEMENT => "";
 346 use constant PRE_MARK_OPERAND => "*** ";
 347 use constant POST_MARK_OPERAND => " ***";
 348
 349 use constant INSTRUCTION_FORMAT => "%8s %3s | %-12s ";
 350 use constant OPERAND_FORMAT => "%s";
 351 use constant OPERAND_SEPARATOR => ", ";
 352 use constant INSTRUCTION_SEPARATOR => "\n";
 353
 354 sub str($)
 355 {
 356         my ($str) = @_;
 357         $str =~ s/[\000-\037\\\"\177-\377]/sprintf "\\%03o", ord $&/ge;
 358         return "\"$str\"";
 359 }
 360
 361 sub disassemble_function($$;$)
 362 {
 363         my ($progs, $func, $highlight) = @_;
 364
 365         print "$func->{debugname}:\n";
 366
 367         my $initializer = sub
 368         {
 369                 my ($ofs) = @_;
 370                 my $g = get_constant($progs, $progs->{globals}[$ofs]{v});
 371                 print " = $g"
 372                         if defined $g;
 373         };
 374
 375         printf INSTRUCTION_FORMAT, '', '', '.PARM_START';
 376         printf OPERAND_FORMAT, "$func->{parm_start}";
 377         print INSTRUCTION_SEPARATOR;
 378
 379         printf INSTRUCTION_FORMAT, '', '', '.LOCALS';
 380         printf OPERAND_FORMAT, "$func->{locals}";
 381         print INSTRUCTION_SEPARATOR;
 382
 383         my %override_locals = ();
 384         my $p = $func->{parm_start};
 385         for(0..($func->{numparms}-1))
 386         {
 387                 $override_locals{$p} //= "argv_$_";
 388                 for my $comp(0..($func->{parm_size}[$_]-1))
 389                 {
 390                         $override_locals{$p} //= "argv_$_\[$comp]";
 391                         ++$p;
 392                 }
 393                 printf INSTRUCTION_FORMAT, '', '', '.ARG';
 394                 printf OPERAND_FORMAT, "argv_$_";
 395                 print OPERAND_SEPARATOR;
 396                 printf OPERAND_FORMAT, $func->{parm_size}[$_];
 397                 print INSTRUCTION_SEPARATOR;
 398         }
 399         for($func->{parm_start}..($func->{parm_start} + $func->{locals} - 1))
 400         {
 401                 next
 402                         if exists $override_locals{$_};
 403                 $override_locals{$_} = "local_$_";
 404
 405                 printf INSTRUCTION_FORMAT, '', '', '.LOCAL';
 406                 printf OPERAND_FORMAT, "local_$_";
 407                 $initializer->($_);
 408                 print INSTRUCTION_SEPARATOR;
 409         }
 410
 411         my $getname = sub
 412         {
 413                 my ($ofs) = @_;
 414                 return $override_locals{$ofs}
 415                         if exists $override_locals{$ofs};
 416                 my $def = $progs->{globaldef_byoffset}->($ofs);
 417                 return $def->{debugname};
 418         };
 419
 420         my $operand = sub
 421         {
 422                 my ($ip, $type, $operand) = @_;
 423                 if($type eq 'inglobal')
 424                 {
 425                         my $name = $getname->($operand);
 426                         printf OPERAND_FORMAT, "$name";
 427                 }
 428                 elsif($type eq 'outglobal')
 429                 {
 430                         my $name = $getname->($operand);
 431                         printf OPERAND_FORMAT, "&$name";
 432                 }
 433                 elsif($type eq 'inglobalvec')
 434                 {
 435                         my $name = $getname->($operand);
 436                         printf OPERAND_FORMAT, "$name\[\]";
 437                 }
 438                 elsif($type eq 'outglobalvec')
 439                 {
 440                         my $name = $getname->($operand);
 441                         printf OPERAND_FORMAT, "&$name\[\]";
 442                 }
 443                 elsif($type eq 'inglobalfunc')
 444                 {
 445                         my $name = $getname->($operand);
 446                         printf OPERAND_FORMAT, "$name()";
 447                 }
 448                 elsif($type eq 'ipoffset')
 449                 {
 450                         printf OPERAND_FORMAT, "@{[$ip + $operand]}" . sprintf ' ($%+d)', $operand;
 451                 }
 452                 else
 453                 {
 454                         die "unknown type: $type";
 455                 }
 456         };
 457
 458         my %statements = ();
 459         my %come_from = ();
 460         run_nfa $progs, $func->{first_statement}, "", id, nfa_default_state_checker,
 461                 sub
 462                 {
 463                         my ($ip, $state, $s, $c) = @_;
 464                         ++$statements{$ip};
 465
 466                         if(my $j = $c->{isjump})
 467                         {
 468                                 my $t = $ip + $s->{$j};
 469                                 $come_from{$t}{$ip} = $c->{isconditional};
 470                         }
 471
 472                         return 0;
 473                 };
 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                 print PRE_MARK_STATEMENT
 507                         if $highlight and $highlight->{$ip};
 508
 509                 my $showip = $opprop->{isjump};
 510                 printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? "<!>" : "", $op;
 511
 512                 my $cnt = 0;
 513                 for my $o(qw(a b c))
 514                 {
 515                         next
 516                                 if not defined $opprop->{$o};
 517                         print OPERAND_SEPARATOR
 518                                 if $cnt++;
 519                         print PRE_MARK_OPERAND
 520                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 521                         $operand->($ip, $opprop->{$o}, $ipt->{$o});
 522                         print POST_MARK_OPERAND
 523                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 524                 }
 525
 526                 print POST_MARK_STATEMENT
 527                         if $highlight and $highlight->{$ip};
 528
 529                 print INSTRUCTION_SEPARATOR;
 530         }
 531 }
 532
 533 sub find_uninitialized_locals($$)
 534 {
 535         my ($progs, $func) = @_;
 536
 537
 538         return
 539                 if $func->{first_statement} < 0; # builtin
 540
 541         print STDERR "Checking $func->{debugname}...\n";
 542
 543         my $p = $func->{parm_start};
 544         for(0..($func->{numparms}-1))
 545         {
 546                 $p += $func->{parm_size}[$_];
 547         }
 548
 549         use constant WATCHME_R => 1;
 550         use constant WATCHME_W => 2;
 551         use constant WATCHME_X => 4;
 552         use constant WATCHME_T => 8;
 553         my %watchme = map { $_ => WATCHME_X } ($func->{parm_start} .. ($func->{parm_start} + $func->{locals} - 1));
 554
 555         for(keys %{$progs->{temps}})
 556         {
 557                 $watchme{$_} = WATCHME_T | WATCHME_X
 558                         if not exists $watchme{$_};
 559         }
 560
 561         my %write_places = ();
 562         run_nfa $progs, $func->{first_statement}, "", id, nfa_default_state_checker,
 563                 sub
 564                 {
 565                         my ($ip, $state, $s, $c) = @_;
 566                         for(qw(a b c))
 567                         {
 568                                 my $type = $c->{$_};
 569                                 next
 570                                         unless defined $type;
 571
 572                                 my $ofs = $s->{$_};
 573                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 574                                 {
 575                                         $watchme{$ofs} |= WATCHME_R;
 576                                 }
 577                                 elsif($type eq 'inglobalvec')
 578                                 {
 579                                         $watchme{$ofs} |= WATCHME_R;
 580                                         $watchme{$ofs+1} |= WATCHME_R;
 581                                         $watchme{$ofs+2} |= WATCHME_R;
 582                                 }
 583                                 elsif($type eq 'outglobal')
 584                                 {
 585                                         $watchme{$ofs} |= WATCHME_W;
 586                                         $write_places{$ip}{$_} = [$ofs]
 587                                                 if $watchme{$ofs} & WATCHME_X;
 588                                 }
 589                                 elsif($type eq 'outglobalvec')
 590                                 {
 591                                         $watchme{$ofs} |= WATCHME_W;
 592                                         $watchme{$ofs+1} |= WATCHME_W;
 593                                         $watchme{$ofs+2} |= WATCHME_W;
 594                                         my @l = grep { $watchme{$_} & WATCHME_X } $ofs .. ($ofs+2);
 595                                         $write_places{$ip}{$_} = \@l
 596                                                 if @l;
 597                                 }
 598                         }
 599
 600                         return 0;
 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         # an initial run of STORE instruction is for receiving extra parameters
 627         # (beyond 8). Only possible if the function is declared as having 8 params.
 628         # Extra parameters behave otherwise like temps, but are initialized at
 629         # startup.
 630         for($func->{first_statement} .. (@{$progs->{statements}}-1))
 631         {
 632                 my $s = $progs->{statements}[$_];
 633                 if($s->{op} eq 'STORE_V')
 634                 {
 635                         $watchme{$s->{a}}{valid} = [1, undef, undef]
 636                                 if defined $watchme{$s->{a}};
 637                         $watchme{$s->{a}+1}{valid} = [1, undef, undef]
 638                                 if defined $watchme{$s->{a}+1};
 639                         $watchme{$s->{a}+2}{valid} = [1, undef, undef]
 640                                 if defined $watchme{$s->{a}+2};
 641                 }
 642                 elsif($s->{op} =~ /^STORE_/)
 643                 {
 644                         $watchme{$s->{a}}{valid} = [1, undef, undef]
 645                                 if defined $watchme{$s->{a}};
 646                 }
 647                 else
 648                 {
 649                         last;
 650                 }
 651         }
 652
 653         my %warned = ();
 654         my %ip_seen = ();
 655         run_nfa $progs, $func->{first_statement}, \%watchme,
 656                 sub {
 657                         my ($h) = @_;
 658                         return { map { $_ => { %{$h->{$_}} } } keys %$h };
 659                 },
 660                 sub {
 661                         my ($ip, $state) = @_;
 662
 663                         my $s = $ip_seen{$ip};
 664                         if($s)
 665                         {
 666                                 # if $state is stronger or equal to $s, return 1
 667
 668                                 for(keys %$state)
 669                                 {
 670                                         if($state->{$_}{valid}[0] < $s->{$_})
 671                                         {
 672                                                 # The current state is LESS valid than the previously run one. We NEED to run this.
 673                                                 # The saved state can safely become the intersection [citation needed].
 674                                                 for(keys %$state)
 675                                                 {
 676                                                         $s->{$_} = $state->{$_}{valid}[0]
 677                                                                 if $state->{$_}{valid}[0] < $s->{$_};
 678                                                 }
 679                                                 return 0;
 680                                         }
 681                                 }
 682                                 # if we get here, $state is stronger or equal. No need to try it.
 683                                 return 1;
 684                         }
 685                         else
 686                         {
 687                                 # Never seen this IP yet.
 688                                 $ip_seen{$ip} = { map { ($_ => $state->{$_}{valid}[0]); } keys %$state };
 689                                 return 0;
 690                         }
 691                 },
 692                 sub {
 693                         my ($ip, $state, $s, $c) = @_;
 694                         my $op = $s->{op};
 695
 696                         my $return_hack = $c->{isreturn} // 0;
 697
 698                         for(qw(a b c))
 699                         {
 700                                 my $type = $c->{$_};
 701                                 next
 702                                         unless defined $type;
 703
 704                                 my $ofs = $s->{$_};
 705
 706                                 my $read = sub
 707                                 {
 708                                         my ($ofs) = @_;
 709                                         ++$return_hack
 710                                                 if $return_hack;
 711                                         return
 712                                                 if not exists $state->{$ofs};
 713                                         my $valid = $state->{$ofs}{valid};
 714                                         if($valid->[0] == 0)
 715                                         {
 716                                                 if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b')) # fteqcc logicops cause this
 717                                                 {
 718                                                         print "; Use of uninitialized value $ofs in $func->{debugname} at $ip.$_\n";
 719                                                         ++$warned{$ip}{$_};
 720                                                 }
 721                                         }
 722                                         elsif($valid->[0] < 0)
 723                                         {
 724                                                 if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b')) # fteqcc logicops cause this
 725                                                 {
 726                                                         print "; Use of temporary $ofs across CALL in $func->{debugname} at $ip.$_\n";
 727                                                         ++$warned{$ip}{$_};
 728                                                 }
 729                                         }
 730                                         else
 731                                         {
 732                                                 # it's VALID
 733                                                 if(defined $valid->[1])
 734                                                 {
 735                                                         delete $write_places{$valid->[1]}{$valid->[2]};
 736                                                 }
 737                                         }
 738                                 };
 739                                 my $write = sub
 740                                 {
 741                                         my ($ofs) = @_;
 742                                         $state->{$ofs}{valid} = [1, $ip, $_]
 743                                                 if exists $state->{$ofs};
 744                                 };
 745
 746                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 747                                 {
 748                                         $read->($ofs);
 749                                 }
 750                                 elsif($type eq 'inglobalvec')
 751                                 {
 752                                         $read->($ofs);
 753                                         $read->($ofs+1);
 754                                         $read->($ofs+2);
 755                                 }
 756                                 elsif($type eq 'outglobal')
 757                                 {
 758                                         $write->($ofs);
 759                                 }
 760                                 elsif($type eq 'outglobalvec')
 761                                 {
 762                                         $write->($ofs);
 763                                         $write->($ofs+1);
 764                                         $write->($ofs+2);
 765                                 }
 766                         }
 767                         if($c->{iscall})
 768                         {
 769                                 # builtin calls may clobber stuff
 770                                 my $func = $s->{a};
 771                                 my $funcid = $progs->{globals}[$func]{v}{int};
 772                                 my $funcobj = $progs->{functions}[$funcid];
 773                                 if(!$funcobj || $funcobj->{first_statement} >= 0)
 774                                 {
 775                                         # invalidate temps
 776                                         for(values %$state)
 777                                         {
 778                                                 if($_->{flags} & WATCHME_T)
 779                                                 {
 780                                                         $_->{valid} = [-1, undef, undef];
 781                                                 }
 782                                         }
 783                                 }
 784                         }
 785
 786                         return 0;
 787                 };
 788
 789         for my $ip(keys %write_places)
 790         {
 791                 for my $operand(keys %{$write_places{$ip}})
 792                 {
 793                         # TODO verify it
 794                         my %left = map { $_ => 1 } @{$write_places{$ip}{$operand}};
 795                         my $isread = 0;
 796
 797                         my %writeplace_seen = ();
 798                         run_nfa $progs, $ip+1, \%left,
 799                                 sub
 800                                 {
 801                                         return { %{$_[0]} };
 802                                 },
 803                                 sub
 804                                 {
 805                                         my ($ip, $state) = @_;
 806                                         return $writeplace_seen{"$ip " . join " ", sort keys %$state}++;
 807                                 },
 808                                 sub
 809                                 {
 810                                         my ($ip, $state, $s, $c) = @_;
 811                                         for(qw(a b c))
 812                                         {
 813                                                 my $type = $c->{$_};
 814                                                 next
 815                                                         unless defined $type;
 816
 817                                                 my $ofs = $s->{$_};
 818                                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 819                                                 {
 820                                                         if($state->{$ofs})
 821                                                         {
 822                                                                 $isread = 1;
 823                                                                 return -1; # exit TOTALLY
 824                                                         }
 825                                                 }
 826                                                 elsif($type eq 'inglobalvec')
 827                                                 {
 828                                                         if($state->{$ofs} || $state->{$ofs+1} || $state->{$ofs+2})
 829                                                         {
 830                                                                 $isread = 1;
 831                                                                 return -1; # exit TOTALLY
 832                                                         }
 833                                                 }
 834                                                 elsif($type eq 'outglobal')
 835                                                 {
 836                                                         delete $state->{$ofs};
 837                                                         return 1
 838                                                                 if !%$state;
 839                                                 }
 840                                                 elsif($type eq 'outglobalvec')
 841                                                 {
 842                                                         delete $state->{$ofs};
 843                                                         delete $state->{$ofs+1};
 844                                                         delete $state->{$ofs+2};
 845                                                         return 1
 846                                                                 if !%$state;
 847                                                 }
 848                                         }
 849                                         return 0;
 850                                 };
 851
 852                         if(!$isread)
 853                         {
 854                                 print "; Value is never used in $func->{debugname} at $ip.$operand\n";
 855                                 ++$warned{$ip}{$operand};
 856                         }
 857                 }
 858         }
 859
 860         disassemble_function($progs, $func, \%warned)
 861                 if keys %warned;
 862 }
 863
 864 use constant DEFAULTGLOBALS => [
 865         "OFS_NULL",
 866         "OFS_RETURN",
 867         "OFS_RETURN[1]",
 868         "OFS_RETURN[2]",
 869         "OFS_PARM0",
 870         "OFS_PARM0[1]",
 871         "OFS_PARM0[2]",
 872         "OFS_PARM1",
 873         "OFS_PARM1[1]",
 874         "OFS_PARM1[2]",
 875         "OFS_PARM2",
 876         "OFS_PARM2[1]",
 877         "OFS_PARM2[2]",
 878         "OFS_PARM3",
 879         "OFS_PARM3[1]",
 880         "OFS_PARM3[2]",
 881         "OFS_PARM4",
 882         "OFS_PARM4[1]",
 883         "OFS_PARM4[2]",
 884         "OFS_PARM5",
 885         "OFS_PARM5[1]",
 886         "OFS_PARM5[2]",
 887         "OFS_PARM6",
 888         "OFS_PARM6[1]",
 889         "OFS_PARM6[2]",
 890         "OFS_PARM7",
 891         "OFS_PARM7[1]",
 892         "OFS_PARM7[2]"
 893 ];
 894
 895 sub defaultglobal($)
 896 {
 897         my ($ofs) = @_;
 898         if($ofs < @{(DEFAULTGLOBALS)})
 899         {
 900                 return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
 901         }
 902         return { ofs => $ofs, s_name => undef, debugname => "<undefined>\@$ofs", type => undef };
 903 }
 904
 905 sub parse_progs($)
 906 {
 907         my ($fh) = @_;
 908
 909         my %p = ();
 910
 911         print STDERR "Parsing header...\n";
 912         $p{header} = parse_section $fh, DPROGRAMS_T, 0, undef, 1;
 913
 914         print STDERR "Parsing strings...\n";
 915         $p{strings} = get_section $fh, $p{header}{ofs_strings}, $p{header}{numstrings};
 916         $p{getstring} = sub
 917         {
 918                 my ($startpos) = @_;
 919                 my $endpos = index $p{strings}, "\0", $startpos;
 920                 return substr $p{strings}, $startpos, $endpos - $startpos;
 921         };
 922
 923         print STDERR "Parsing statements...\n";
 924         $p{statements} = [parse_section $fh, DSTATEMENT_T, $p{header}{ofs_statements}, undef, $p{header}{numstatements}];
 925
 926         print STDERR "Parsing globaldefs...\n";
 927         $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}];
 928
 929         print STDERR "Parsing fielddefs...\n";
 930         $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}];
 931
 932         print STDERR "Parsing globals...\n";
 933         $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}];
 934
 935         print STDERR "Parsing functions...\n";
 936         $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}];
 937
 938         print STDERR "Detecting constants and temps...\n";
 939         use constant GLOBALFLAG_R => 1;
 940         use constant GLOBALFLAG_W => 2;
 941         use constant GLOBALFLAG_S => 4;
 942         use constant GLOBALFLAG_I => 8;
 943         use constant GLOBALFLAG_N => 16;
 944         my @globalflags = (0) x @{$p{globals}};
 945         for my $s(@{$p{statements}})
 946         {
 947                 my $c = checkop $s->{op};
 948
 949                 for(qw(a b c))
 950                 {
 951                         my $type = $c->{$_};
 952                         next
 953                                 unless defined $type;
 954
 955                         my $ofs = $s->{$_};
 956
 957                         my $read = sub
 958                         {
 959                                 my ($ofs) = @_;
 960                                 $globalflags[$ofs] |= GLOBALFLAG_R;
 961                         };
 962                         my $write = sub
 963                         {
 964                                 my ($ofs) = @_;
 965                                 $globalflags[$ofs] |= GLOBALFLAG_W;
 966                         };
 967
 968                         if($type eq 'inglobal' || $type eq 'inglobalfunc')
 969                         {
 970                                 $s->{$_} = $ofs = ($ofs & 0xFFFF);
 971                                 $read->($ofs);
 972                         }
 973                         elsif($type eq 'inglobalvec')
 974                         {
 975                                 $s->{$_} = $ofs = ($ofs & 0xFFFF);
 976                                 $read->($ofs);
 977                                 $read->($ofs+1);
 978                                 $read->($ofs+2);
 979                         }
 980                         elsif($type eq 'outglobal')
 981                         {
 982                                 $s->{$_} = $ofs = ($ofs & 0xFFFF);
 983                                 $write->($ofs);
 984                         }
 985                         elsif($type eq 'outglobalvec')
 986                         {
 987                                 $s->{$_} = $ofs = ($ofs & 0xFFFF);
 988                                 $write->($ofs);
 989                                 $write->($ofs+1);
 990                                 $write->($ofs+2);
 991                         }
 992                 }
 993
 994         }
 995
 996         my %offsets_saved = ();
 997         for(@{$p{globaldefs}})
 998         {
 999                 my $type = $_->{type};
1000                 my $name = $p{getstring}->($_->{s_name});
1001                 if($type->{save})
1002                 {
1003                         for my $i(0..(typesize($_->{type}{type})-1))
1004                         {
1005                                 $globalflags[$_->{ofs}] |= GLOBALFLAG_S;
1006                         }
1007                 }
1008                 if($name ne "")
1009                 {
1010                         for my $i(0..(typesize($_->{type}{type})-1))
1011                         {
1012                                 $globalflags[$_->{ofs}] |= GLOBALFLAG_N;
1013                         }
1014                 }
1015         }
1016         my %offsets_initialized = ();
1017         for(0..(@{$p{globals}}-1))
1018         {
1019                 if($p{globals}[$_]{v}{int})
1020                 {
1021                         $globalflags[$_] |= GLOBALFLAG_I;
1022                 }
1023         }
1024
1025         my @globaltypes = (undef) x @{$p{globals}};
1026
1027         my %istemp = ();
1028         for(0..(@{$p{globals}}-1))
1029         {
1030                 next
1031                         if $_ < @{(DEFAULTGLOBALS)};
1032                 if(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == 0)
1033                 {
1034                         $globaltypes[$_] = "unused";
1035                 }
1036                 elsif(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == GLOBALFLAG_R)
1037                 {
1038                         # so it is ro
1039                         if(($globalflags[$_] & GLOBALFLAG_N) == GLOBALFLAG_N)
1040                         {
1041                                 $globaltypes[$_] = "read_only";
1042                         }
1043                         elsif(($globalflags[$_] & GLOBALFLAG_S) == 0)
1044                         {
1045                                 $globaltypes[$_] = "const";
1046                         }
1047                         else
1048                         {
1049                                 $globaltypes[$_] = "read_only";
1050                         }
1051                 }
1052                 elsif(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == GLOBALFLAG_W)
1053                 {
1054                         $globaltypes[$_] = "write_only";
1055                 }
1056                 else
1057                 {
1058                         # now we know it is rw
1059                         if(($globalflags[$_] & GLOBALFLAG_N) == GLOBALFLAG_N)
1060                         {
1061                                 $globaltypes[$_] = "global";
1062                         }
1063                         elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == 0)
1064                         {
1065                                 $globaltypes[$_] = "temp";
1066                                 ++$istemp{$_};
1067                         }
1068                         elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == GLOBALFLAG_I)
1069                         {
1070                                 $globaltypes[$_] = "not_saved";
1071                         }
1072                         else
1073                         {
1074                                 $globaltypes[$_] = "global";
1075                         }
1076                 }
1077         }
1078         $p{temps} = \%istemp;
1079
1080         print STDERR "Naming...\n";
1081         # globaldefs
1082         my @globaldefs = (undef) x @{$p{globaldefs}};
1083         for(@{$p{globaldefs}})
1084         {
1085                 my $s = $p{getstring}->($_->{s_name});
1086                 $_->{debugname} //= "\$" . "$s"
1087                         if length $s;
1088         }
1089         for(@{$p{globaldefs}})
1090         {
1091                 $globaldefs[$_->{ofs}] //= $_
1092                         if defined $_->{debugname};
1093         }
1094         for(@{$p{globaldefs}})
1095         {
1096                 $globaldefs[$_->{ofs}] //= $_;
1097         }
1098         for(0..(@{$p{globals}}-1))
1099         {
1100                 $globaldefs[$_] //= {
1101                         ofs => $_,
1102                         s_name => undef,
1103                         debugname => undef
1104                 };
1105         }
1106         my %globaldefs = ();
1107         for(0..(@{(DEFAULTGLOBALS)}-1))
1108         {
1109                 $globaldefs[$_] = { ofs => $_, s_name => undef, debugname => DEFAULTGLOBALS->[$_], type => undef };
1110                 $globaltypes[$_] = 'defglobal';
1111         }
1112         for(@globaldefs)
1113         {
1114                 if(defined $_->{debugname})
1115                 {
1116                         # already has debugname
1117                 }
1118                 elsif($globaltypes[$_->{ofs}] eq 'const')
1119                 {
1120                         $_->{debugname} = get_constant(\%p, $p{globals}[$_->{ofs}]{v});
1121                 }
1122                 else
1123                 {
1124                         $_->{debugname} = "$globaltypes[$_->{ofs}]_$_->{ofs}";
1125                 }
1126                 ++$globaldefs{$_->{debugname}};
1127         }
1128         for(@globaldefs)
1129         {
1130                 next
1131                         if $globaldefs{$_->{debugname}} <= 1;
1132                 #print "Not unique: $_->{debugname} at $_->{ofs}\n";
1133                 $_->{debugname} .= "\@$_->{ofs}";
1134         }
1135         $p{globaldef_byoffset} = sub
1136         {
1137                 my ($ofs) = @_;
1138                 my $def = $globaldefs[$ofs];
1139                 return $def;
1140         };
1141
1142         # functions
1143         my %functions = ();
1144         for(@{$p{functions}})
1145         {
1146                 my $file = $p{getstring}->($_->{s_file});
1147                 my $name = $p{getstring}->($_->{s_name});
1148                 $name = "$file:$name"
1149                         if length $file;
1150                 $_->{debugname} = $name;
1151                 $functions{$_->{first_statement}} = $_;
1152         }
1153         $p{function_byoffset} = sub
1154         {
1155                 my ($ofs) = @_;
1156                 return $functions{$ofs};
1157         };
1158
1159         # what do we want to do?
1160         my $checkfunc = \&find_uninitialized_locals;
1161         #my $checkfunc = \&disassemble_function;
1162         for(sort { $a->{debugname} cmp $b->{debugname} } @{$p{functions}})
1163         {
1164                 $checkfunc->(\%p, $_);
1165         }
1166 }
1167
1168 open my $fh, '<', $ARGV[0];
1169 parse_progs $fh;