misc/tools/progs-analyzer.pl

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