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