misc/tools/progs-analyzer.pl

   1 use strict;
   2 use warnings;
   3
   4 sub id()
   5 {
   6         return sub { $_[0]; };
   7 }
   8
   9 sub signed($)
  10 {
  11         my ($bits) = @_;
  12         return sub { $_[0] >= (2**($bits-1)) ? $_[0]-(2**$bits) : $_[0]; };
  13 }
  14
  15 use constant OPCODE_E => [qw[
  16         DONE
  17         MUL_F MUL_V MUL_FV MUL_VF
  18         DIV_F
  19         ADD_F ADD_V
  20         SUB_F SUB_V
  21         EQ_F EQ_V EQ_S EQ_E EQ_FNC
  22         NE_F NE_V NE_S NE_E NE_FNC
  23         LE GE LT GT
  24         LOAD_F LOAD_V LOAD_S LOAD_ENT LOAD_FLD LOAD_FNC
  25         ADDRESS
  26         STORE_F STORE_V STORE_S STORE_ENT STORE_FLD STORE_FNC
  27         STOREP_F STOREP_V STOREP_S STOREP_ENT STOREP_FLD STOREP_FNC
  28         RETURN
  29         NOT_F NOT_V NOT_S NOT_ENT NOT_FNC
  30         IF IFNOT
  31         CALL0 CALL1 CALL2 CALL3 CALL4 CALL5 CALL6 CALL7 CALL8
  32         STATE
  33         GOTO
  34         AND OR
  35         BITAND BITOR
  36 ]];
  37 use constant ETYPE_E => [qw[
  38         void
  39         string
  40         float
  41         vector
  42         entity
  43         field
  44         function
  45         pointer
  46 ]];
  47 use constant DEF_SAVEGLOBAL => 32768;
  48 sub typesize($)
  49 {
  50         my ($type) = @_;
  51         return 3 if $type eq 'vector';
  52         return 1;
  53 }
  54
  55 sub checkop($)
  56 {
  57         my ($op) = @_;
  58         if($op =~ /^IF.*_V$/)
  59         {
  60                 return { a => 'inglobalvec', b => 'ipoffset', isjump => 'b', isconditional => 1 };
  61         }
  62         if($op =~ /^IF/)
  63         {
  64                 return { a => 'inglobal', b => 'ipoffset', isjump => 'b', isconditional => 1 };
  65         }
  66         if($op eq 'GOTO')
  67         {
  68                 return { a => 'ipoffset', isjump => 'a', isconditional => 0 };
  69         }
  70         if($op =~ /^ADD_V$|^SUB_V$/)
  71         {
  72                 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobalvec' };
  73         }
  74         if($op =~ /^MUL_V$|^EQ_V$|^NE_V$/)
  75         {
  76                 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobal' };
  77         }
  78         if($op eq 'MUL_FV')
  79         {
  80                 return { a => 'inglobal', b => 'inglobalvec', c => 'outglobalvec' };
  81         }
  82         if($op eq 'MUL_VF')
  83         {
  84                 return { a => 'inglobalvec', b => 'inglobal', c => 'outglobalvec' };
  85         }
  86         if($op eq 'LOAD_V')
  87         {
  88                 return { a => 'inglobal', b => 'inglobal', c => 'outglobalvec' };
  89         }
  90         if($op =~ /^NOT_V/)
  91         {
  92                 return { a => 'inglobalvec', c => 'outglobal' };
  93         }
  94         if($op =~ /^NOT_/)
  95         {
  96                 return { a => 'inglobal', c => 'outglobal' };
  97         }
  98         if($op eq 'STOREP_V')
  99         {
 100                 return { a => 'inglobalvec', b => 'inglobal' };
 101         }
 102         if($op eq 'STORE_V')
 103         {
 104                 return { a => 'inglobalvec', b => 'outglobalvec' };
 105         }
 106         if($op =~ /^STOREP_/)
 107         {
 108                 return { a => 'inglobal', b => 'inglobal' };
 109         }
 110         if($op =~ /^STORE_/)
 111         {
 112                 return { a => 'inglobal', b => 'outglobal' };
 113         }
 114         if($op =~ /^CALL/)
 115         {
 116                 return { a => 'inglobalfunc', iscall => 1 };
 117         }
 118         if($op =~ /^DONE$|^RETURN$/)
 119         {
 120                 return { a => 'inglobal', isreturn => 1 };
 121         }
 122         return { a => 'inglobal', b => 'inglobal', c => 'outglobal' };
 123 }
 124
 125 use constant TYPES => {
 126         int => ['V', 4, signed 32],
 127         ushort => ['v', 2, id],
 128         short => ['v', 2, signed 16],
 129         opcode => ['v', 2, sub { OPCODE_E->[$_[0]] or die "Invalid opcode: $_[0]"; }],
 130         float => ['f', 4, id],
 131         uchar8 => ['a8', 8, sub { [unpack 'C8', $_[0]] }],
 132         global => ['i', 4, sub { { int => $_[0], float => unpack "f", pack "L", $_[0] }; }],
 133         deftype => ['v', 2, sub { { type => ETYPE_E->[$_[0] & ~DEF_SAVEGLOBAL], save => !!($_[0] & DEF_SAVEGLOBAL) }; }],
 134 };
 135
 136 use constant DPROGRAMS_T => [
 137         [int => 'version'],
 138         [int => 'crc'],
 139         [int => 'ofs_statements'],
 140         [int => 'numstatements'],
 141         [int => 'ofs_globaldefs'],
 142         [int => 'numglobaldefs'],
 143         [int => 'ofs_fielddefs'],
 144         [int => 'numfielddefs'],
 145         [int => 'ofs_functions'],
 146         [int => 'numfunctions'],
 147         [int => 'ofs_strings'],
 148         [int => 'numstrings'],
 149         [int => 'ofs_globals'],
 150         [int => 'numglobals'],
 151         [int => 'entityfields']
 152 ];
 153
 154 use constant DSTATEMENT_T => [
 155         [opcode => 'op'],
 156         [short => 'a'],
 157         [short => 'b'],
 158         [short => 'c']
 159 ];
 160
 161 use constant DDEF_T => [
 162         [deftype => 'type'],
 163         [ushort => 'ofs'],
 164         [int => 's_name']
 165 ];
 166
 167 use constant DGLOBAL_T => [
 168         [global => 'v'],
 169 ];
 170
 171 use constant DFUNCTION_T => [
 172         [int => 'first_statement'],
 173         [int => 'parm_start'],
 174         [int => 'locals'],
 175         [int => 'profile'],
 176         [int => 's_name'],
 177         [int => 's_file'],
 178         [int => 'numparms'],
 179         [uchar8 => 'parm_size'],
 180 ];
 181
 182 sub get_section($$$)
 183 {
 184         my ($fh, $start, $len) = @_;
 185         seek $fh, $start, 0
 186                 or die "seek: $!";
 187         $len == read $fh, my $buf, $len
 188                 or die "short read";
 189         return $buf;
 190 }
 191
 192 sub parse_section($$$$$)
 193 {
 194         my ($fh, $struct, $start, $len, $cnt) = @_;
 195
 196         my $itemlen = 0;
 197         $itemlen += TYPES->{$_->[0]}->[1]
 198                 for @$struct;
 199         my $packspec = join '', map { TYPES->{$_->[0]}->[0]; } @$struct;
 200         my @packnames = map { $_->[1]; } @$struct;
 201
 202         $len = $cnt * $itemlen
 203                 if not defined $len and defined $cnt;
 204         $cnt = int($len / $itemlen)
 205                 if not defined $cnt and defined $len;
 206         die "Invalid length specification"
 207                 unless defined $len and defined $cnt and $len == $cnt * $itemlen;
 208         die "Invalid length specification in scalar context"
 209                 unless wantarray or $cnt == 1;
 210
 211         seek $fh, $start, 0
 212                 or die "seek: $!";
 213         my @out = map
 214         {
 215                 $itemlen == read $fh, my $buf, $itemlen
 216                         or die "short read";
 217                 my %h = ();
 218                 @h{@packnames} = unpack $packspec, $buf;
 219                 $h{$_->[1]} = TYPES->{$_->[0]}->[2]->($h{$_->[1]})
 220                         for @$struct;
 221                 \%h;
 222         }
 223         0..($cnt-1);
 224         return @out
 225                 if wantarray;
 226         return $out[0];
 227 }
 228
 229 sub run_nfa($$$$$$)
 230 {
 231         my ($progs, $ip, $state, $copy_handler, $state_hasher, $instruction_handler) = @_;
 232         my %seen = ();
 233
 234         my $statements = $progs->{statements};
 235
 236         my $nfa;
 237         $nfa = sub
 238         {
 239                 no warnings 'recursion';
 240
 241                 my ($ip, $state) = @_;
 242
 243                 for(;;)
 244                 {
 245                         my $statestr = $state_hasher->($state);
 246                         return
 247                                 if $seen{"$ip:$statestr"}++;
 248
 249                         my $s = $statements->[$ip];
 250                         my $c = checkop $s->{op};
 251
 252                         if($instruction_handler->($ip, $state, $s, $c))
 253                         {
 254                                 # abort execution
 255                                 last;
 256                         }
 257
 258                         if($c->{isreturn})
 259                         {
 260                                 last;
 261                         }
 262                         elsif($c->{isjump})
 263                         {
 264                                 if($c->{isconditional})
 265                                 {
 266                                         $nfa->($ip+1, $copy_handler->($state));
 267                                         $ip += $s->{$c->{isjump}};
 268                                 }
 269                                 else
 270                                 {
 271                                         $ip += $s->{$c->{isjump}};
 272                                 }
 273                         }
 274                         else
 275                         {
 276                                 $ip += 1;
 277                         }
 278                 }
 279         };
 280
 281         $nfa->($ip, $copy_handler->($state));
 282 }
 283
 284 sub get_constant($$)
 285 {
 286         my ($progs, $g) = @_;
 287         if($g->{int} == 0)
 288         {
 289                 return undef;
 290         }
 291         elsif($g->{int} > 0 && $g->{int} < 16777216)
 292         {
 293                 if($g->{int} < length $progs->{strings} && $g->{int} > 0)
 294                 {
 295                         return str($progs->{getstring}->($g->{int}));
 296                 }
 297                 else
 298                 {
 299                         return $g->{int} . "i";
 300                 }
 301         }
 302         else
 303         {
 304                 return $g->{float};
 305         }
 306 }
 307
 308 use constant PRE_MARK_STATEMENT => "\e[1m";
 309 use constant POST_MARK_STATEMENT => "\e[m";
 310 use constant PRE_MARK_OPERAND => "\e[41m";
 311 use constant POST_MARK_OPERAND => "\e[49m";
 312
 313 use constant INSTRUCTION_FORMAT => "%8s %3s | %-12s ";
 314 use constant OPERAND_FORMAT => "%s";
 315 use constant OPERAND_SEPARATOR => ", ";
 316 use constant INSTRUCTION_SEPARATOR => "\n";
 317
 318 sub str($)
 319 {
 320         my ($str) = @_;
 321         $str =~ s/[\000-\037\\\"\177-\377]/sprintf "\\%03o", ord $&/ge;
 322         return "\"$str\"";
 323 }
 324
 325 sub disassemble_function($$;$)
 326 {
 327         my ($progs, $func, $highlight) = @_;
 328
 329         print "$func->{debugname}:\n";
 330
 331         my $initializer = sub
 332         {
 333                 my ($ofs) = @_;
 334                 my $g = get_constant($progs, $progs->{globals}[$ofs]{v});
 335                 print " = $g"
 336                         if defined $g;
 337         };
 338
 339         printf INSTRUCTION_FORMAT, '', '', '.PARM_START';
 340         printf OPERAND_FORMAT, "$func->{parm_start}";
 341         print INSTRUCTION_SEPARATOR;
 342
 343         printf INSTRUCTION_FORMAT, '', '', '.LOCALS';
 344         printf OPERAND_FORMAT, "$func->{locals}";
 345         print INSTRUCTION_SEPARATOR;
 346
 347         my %override_locals = ();
 348         my $p = $func->{parm_start};
 349         for(0..($func->{numparms}-1))
 350         {
 351                 $override_locals{$p} //= "argv[$_]";
 352                 for my $comp(0..($func->{parm_size}[$_]-1))
 353                 {
 354                         $override_locals{$p} //= "argv[$_][$comp]";
 355                         ++$p;
 356                 }
 357                 printf INSTRUCTION_FORMAT, '', '', '.ARG';
 358                 printf OPERAND_FORMAT, "argv[$_]";
 359                 print OPERAND_SEPARATOR;
 360                 printf OPERAND_FORMAT, $func->{parm_size}[$_];
 361                 print INSTRUCTION_SEPARATOR;
 362         }
 363         for($func->{parm_start}..($func->{parm_start} + $func->{locals} - 1))
 364         {
 365                 next
 366                         if exists $override_locals{$_};
 367                 $override_locals{$_} = "<local>\@$_";
 368
 369                 printf INSTRUCTION_FORMAT, '', '', '.LOCAL';
 370                 printf OPERAND_FORMAT, "<local>\@$_";
 371                 $initializer->($_);
 372                 print INSTRUCTION_SEPARATOR;
 373         }
 374
 375         my $getname = sub
 376         {
 377                 my ($ofs) = @_;
 378                 $ofs &= 0xFFFF;
 379                 return $override_locals{$ofs}
 380                         if exists $override_locals{$ofs};
 381                 my $def = $progs->{globaldef_byoffset}->($ofs);
 382                 return $def->{debugname};
 383         };
 384
 385         my $operand = sub
 386         {
 387                 my ($ip, $type, $operand) = @_;
 388                 if($type eq 'inglobal')
 389                 {
 390                         my $name = $getname->($operand);
 391                         printf OPERAND_FORMAT, "$name";
 392                 }
 393                 elsif($type eq 'outglobal')
 394                 {
 395                         my $name = $getname->($operand);
 396                         printf OPERAND_FORMAT, "&$name";
 397                 }
 398                 elsif($type eq 'inglobalvec')
 399                 {
 400                         my $name = $getname->($operand);
 401                         printf OPERAND_FORMAT, "$name\[\]";
 402                 }
 403                 elsif($type eq 'outglobalvec')
 404                 {
 405                         my $name = $getname->($operand);
 406                         printf OPERAND_FORMAT, "&$name\[\]";
 407                 }
 408                 elsif($type eq 'inglobalfunc')
 409                 {
 410                         my $name = $getname->($operand);
 411                         printf OPERAND_FORMAT, "$name()";
 412                 }
 413                 elsif($type eq 'ipoffset')
 414                 {
 415                         printf OPERAND_FORMAT, "@{[$ip + $operand]}" . sprintf ' ($%+d)', $operand;
 416                 }
 417                 else
 418                 {
 419                         die "unknown type: $type";
 420                 }
 421         };
 422
 423         my %statements = ();
 424         my %come_from = ();
 425         run_nfa $progs, $func->{first_statement}, "", id, id,
 426                 sub
 427                 {
 428                         my ($ip, $state, $s, $c) = @_;
 429                         ++$statements{$ip};
 430
 431                         if(my $j = $c->{isjump})
 432                         {
 433                                 my $t = $ip + $s->{$j};
 434                                 $come_from{$t}{$ip} = $c->{isconditional};
 435                         }
 436
 437                         return 0;
 438                 };
 439
 440         my $ipprev = undef;
 441         for my $ip(sort { $a <=> $b } keys %statements)
 442         {
 443                 if($ip == $func->{first_statement})
 444                 {
 445                         printf INSTRUCTION_FORMAT, $ip, '', '.ENTRY';
 446                         print INSTRUCTION_SEPARATOR;
 447                 }
 448                 if(defined $ipprev && $ip != $ipprev + 1)
 449                 {
 450                         printf INSTRUCTION_FORMAT, $ip, '', '.SKIP';
 451                         printf OPERAND_FORMAT, $ip - $ipprev - 1;
 452                         print INSTRUCTION_SEPARATOR;
 453                 }
 454                 if(my $cf = $come_from{$ip})
 455                 {
 456                         printf INSTRUCTION_FORMAT, $ip, '', '.XREF';
 457                         my $cnt = 0;
 458                         for(sort { $a <=> $b } keys %$cf)
 459                         {
 460                                 print OPERAND_SEPARATOR
 461                                         if $cnt++;
 462                                 printf OPERAND_FORMAT, ($cf->{$_} ? 'c' : 'j') . $_ . sprintf ' ($%+d)', $_ - $ip;
 463                         }
 464                         print INSTRUCTION_SEPARATOR;
 465                 }
 466
 467                 my $op = $progs->{statements}[$ip]{op};
 468                 my $ipt = $progs->{statements}[$ip];
 469                 my $opprop = checkop $op;
 470
 471                 print PRE_MARK_STATEMENT
 472                         if $highlight and $highlight->{$ip};
 473
 474                 my $showip = $opprop->{isjump};
 475                 printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? "<!>" : "", $op;
 476
 477                 my $cnt = 0;
 478                 for my $o(qw(a b c))
 479                 {
 480                         next
 481                                 if not defined $opprop->{$o};
 482                         print OPERAND_SEPARATOR
 483                                 if $cnt++;
 484                         print PRE_MARK_OPERAND
 485                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 486                         $operand->($ip, $opprop->{$o}, $ipt->{$o});
 487                         print POST_MARK_OPERAND
 488                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 489                 }
 490
 491                 print POST_MARK_STATEMENT
 492                         if $highlight and $highlight->{$ip};
 493
 494                 print INSTRUCTION_SEPARATOR;
 495         }
 496 }
 497
 498 sub find_uninitialized_locals($$)
 499 {
 500         my ($progs, $func) = @_;
 501
 502         return
 503                 if $func->{first_statement} < 0; # builtin
 504
 505         print STDERR "Checking $func->{debugname}...\n";
 506
 507         my $p = $func->{parm_start};
 508         for(0..($func->{numparms}-1))
 509         {
 510                 $p += $func->{parm_size}[$_];
 511         }
 512
 513         use constant WATCHME_R => 1;
 514         use constant WATCHME_W => 2;
 515         use constant WATCHME_X => 4;
 516         use constant WATCHME_T => 8;
 517         my %watchme = map { $_ => WATCHME_X } ($func->{parm_start} .. ($func->{parm_start} + $func->{locals} - 1));
 518
 519         for(keys %{$progs->{temps}})
 520         {
 521                 $watchme{$_} = WATCHME_T | WATCHME_X
 522                         if not exists $watchme{$_};
 523         }
 524
 525         run_nfa $progs, $func->{first_statement}, "", id, id,
 526                 sub
 527                 {
 528                         my ($ip, $state, $s, $c) = @_;
 529                         for(qw(a b c))
 530                         {
 531                                 my $type = $c->{$_};
 532                                 next
 533                                         unless defined $type;
 534
 535                                 my $ofs = $s->{$_};
 536                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 537                                 {
 538                                         $watchme{$ofs} |= WATCHME_R;
 539                                 }
 540                                 elsif($type eq 'inglobalvec')
 541                                 {
 542                                         $watchme{$ofs} |= WATCHME_R;
 543                                         $watchme{$ofs+1} |= WATCHME_R;
 544                                         $watchme{$ofs+2} |= WATCHME_R;
 545                                 }
 546                                 elsif($type eq 'outglobal')
 547                                 {
 548                                         $watchme{$ofs} |= WATCHME_W;
 549                                 }
 550                                 elsif($type eq 'outglobalvec')
 551                                 {
 552                                         $watchme{$ofs} |= WATCHME_W;
 553                                         $watchme{$ofs+1} |= WATCHME_W;
 554                                         $watchme{$ofs+2} |= WATCHME_W;
 555                                 }
 556                         }
 557
 558                         return 0;
 559                 };
 560
 561         for(keys %watchme)
 562         {
 563                 delete $watchme{$_}
 564                         if ($watchme{$_} & (WATCHME_R | WATCHME_W | WATCHME_X)) != (WATCHME_R | WATCHME_W | WATCHME_X);
 565         }
 566
 567         return
 568                 if not keys %watchme;
 569
 570         for(keys %watchme)
 571         {
 572                 $watchme{$_} = {
 573                         flags => $watchme{$_},
 574                         valid => 0
 575                 };
 576         }
 577
 578         # mark parameters as initialized
 579         for($func->{parm_start} .. ($p-1))
 580         {
 581                 $watchme{$_}{valid} = 1
 582                         if defined $watchme{$_};
 583         }
 584         # an initial run of STORE instruction is for receiving extra parameters
 585         # (beyond 8). Only possible if the function is declared as having 8 params.
 586         # Extra parameters behave otherwise like temps, but are initialized at
 587         # startup.
 588         for($func->{first_statement} .. (@{$progs->{statements}}-1))
 589         {
 590                 my $s = $progs->{statements}[$_];
 591                 if($s->{op} eq 'STORE_V')
 592                 {
 593                         $watchme{$s->{a}}{valid} = 1
 594                                 if defined $watchme{$s->{a}};
 595                         $watchme{$s->{a}+1}{valid} = 1
 596                                 if defined $watchme{$s->{a}+1};
 597                         $watchme{$s->{a}+2}{valid} = 1
 598                                 if defined $watchme{$s->{a}+2};
 599                 }
 600                 elsif($s->{op} =~ /^STORE_/)
 601                 {
 602                         $watchme{$s->{a}}{valid} = 1
 603                                 if defined $watchme{$s->{a}};
 604                 }
 605                 else
 606                 {
 607                         last;
 608                 }
 609         }
 610
 611         my %warned = ();
 612         run_nfa $progs, $func->{first_statement}, \%watchme,
 613                 sub {
 614                         my ($h) = @_;
 615                         return { map { $_ => { %{$h->{$_}} } } keys %$h };
 616                 },
 617                 sub {
 618                         my ($h) = @_;
 619                         return join ' ', map { $h->{$_}->{valid}; } sort keys %$h;
 620                 },
 621                 sub {
 622                         my ($ip, $state, $s, $c) = @_;
 623                         my $op = $s->{op};
 624                         for(qw(a b c))
 625                         {
 626                                 my $type = $c->{$_};
 627                                 next
 628                                         unless defined $type;
 629
 630                                 my $ofs = $s->{$_};
 631
 632                                 my $read = sub
 633                                 {
 634                                         my ($ofs) = @_;
 635                                         return
 636                                                 if not exists $state->{$ofs};
 637                                         my $valid = $state->{$ofs}{valid};
 638                                         if($valid == 0)
 639                                         {
 640                                                 print "; Use of uninitialized value $ofs in $func->{debugname} at $ip.$_\n";
 641                                                 ++$warned{$ip}{$_};
 642                                         }
 643                                         elsif($valid < 0)
 644                                         {
 645                                                 print "; Use of temporary $ofs across CALL in $func->{debugname} at $ip.$_\n";
 646                                                 ++$warned{$ip}{$_};
 647                                         }
 648                                 };
 649                                 my $write = sub
 650                                 {
 651                                         my ($ofs) = @_;
 652                                         $state->{$ofs}{valid} = 1
 653                                                 if exists $state->{$ofs};
 654                                 };
 655
 656                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 657                                 {
 658                                         if($op ne 'OR' && $op ne 'AND') # fteqcc logicops cause this
 659                                         {
 660                                                 $read->($ofs);
 661                                         }
 662                                 }
 663                                 elsif($type eq 'inglobalvec')
 664                                 {
 665                                         if($op ne 'OR' && $op ne 'AND') # fteqcc logicops cause this
 666                                         {
 667                                                 $read->($ofs);
 668                                                 $read->($ofs+1);
 669                                                 $read->($ofs+2);
 670                                         }
 671                                 }
 672                                 elsif($type eq 'outglobal')
 673                                 {
 674                                         $write->($ofs);
 675                                 }
 676                                 elsif($type eq 'outglobalvec')
 677                                 {
 678                                         $write->($ofs);
 679                                         $write->($ofs+1);
 680                                         $write->($ofs+2);
 681                                 }
 682                         }
 683                         if($c->{iscall})
 684                         {
 685                                 # builtin calls may clobber stuff
 686                                 my $func = $s->{a};
 687                                 my $funcid = $progs->{globals}[$func]{v}{int};
 688                                 my $funcobj = $progs->{functions}[$funcid];
 689                                 if($funcobj->{first_statement} >= 0)
 690                                 {
 691                                         # invalidate temps
 692                                         for(values %$state)
 693                                         {
 694                                                 if($_->{flags} & WATCHME_T)
 695                                                 {
 696                                                         $_->{valid} = -1;
 697                                                 }
 698                                         }
 699                                 }
 700                                 elsif($funcobj->{debugname} =~ /(^|:)error$/)
 701                                 {
 702                                         return 1;
 703                                 }
 704                         }
 705
 706                         return 0;
 707                 };
 708
 709         disassemble_function($progs, $func, \%warned)
 710                 if keys %warned;
 711 }
 712
 713 use constant DEFAULTGLOBALS => [
 714         "<OFS_NULL>",
 715         "<OFS_RETURN>",
 716         "<OFS_RETURN>[1]",
 717         "<OFS_RETURN>[2]",
 718         "<OFS_PARM0>",
 719         "<OFS_PARM0>[1]",
 720         "<OFS_PARM0>[2]",
 721         "<OFS_PARM1>",
 722         "<OFS_PARM1>[1]",
 723         "<OFS_PARM1>[2]",
 724         "<OFS_PARM2>",
 725         "<OFS_PARM2>[1]",
 726         "<OFS_PARM2>[2]",
 727         "<OFS_PARM3>",
 728         "<OFS_PARM3>[1]",
 729         "<OFS_PARM3>[2]",
 730         "<OFS_PARM4>",
 731         "<OFS_PARM4>[1]",
 732         "<OFS_PARM4>[2]",
 733         "<OFS_PARM5>",
 734         "<OFS_PARM5>[1]",
 735         "<OFS_PARM5>[2]",
 736         "<OFS_PARM6>",
 737         "<OFS_PARM6>[1]",
 738         "<OFS_PARM6>[2]",
 739         "<OFS_PARM7>",
 740         "<OFS_PARM7>[1]",
 741         "<OFS_PARM7>[2]"
 742 ];
 743
 744 sub defaultglobal($)
 745 {
 746         my ($ofs) = @_;
 747         if($ofs < @{(DEFAULTGLOBALS)})
 748         {
 749                 return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
 750         }
 751         return { ofs => $ofs, s_name => undef, debugname => "<undefined>\@$ofs", type => undef };
 752 }
 753
 754 sub parse_progs($)
 755 {
 756         my ($fh) = @_;
 757
 758         my %p = ();
 759
 760         print STDERR "Parsing header...\n";
 761         $p{header} = parse_section $fh, DPROGRAMS_T, 0, undef, 1;
 762
 763         print STDERR "Parsing strings...\n";
 764         $p{strings} = get_section $fh, $p{header}{ofs_strings}, $p{header}{numstrings};
 765         $p{getstring} = sub
 766         {
 767                 my ($startpos) = @_;
 768                 my $endpos = index $p{strings}, "\0", $startpos;
 769                 return substr $p{strings}, $startpos, $endpos - $startpos;
 770         };
 771
 772         print STDERR "Parsing statements...\n";
 773         $p{statements} = [parse_section $fh, DSTATEMENT_T, $p{header}{ofs_statements}, undef, $p{header}{numstatements}];
 774
 775         print STDERR "Parsing globaldefs...\n";
 776         $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}];
 777
 778         print STDERR "Parsing fielddefs...\n";
 779         $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}];
 780
 781         print STDERR "Parsing globals...\n";
 782         $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}];
 783
 784         print STDERR "Parsing functions...\n";
 785         $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}];
 786
 787         print STDERR "Detecting temps...\n";
 788         my %offsets_saved = ();
 789         for(@{$p{globaldefs}})
 790         {
 791                 my $type = $_->{type};
 792                 my $name = $p{getstring}->($_->{s_name});
 793                 next
 794                         unless $type->{save} or $name ne "";
 795                 for my $i(0..(typesize($_->{type}{type})-1))
 796                 {
 797                         ++$offsets_saved{$_->{ofs}+$i};
 798                 }
 799         }
 800         my %offsets_initialized = ();
 801         for(0..(@{$p{globals}}-1))
 802         {
 803                 if($p{globals}[$_]{v}{int})
 804                 {
 805                         ++$offsets_initialized{$_};
 806                 }
 807         }
 808         my %istemp = ();
 809         my %isconst = ();
 810         for(0..(@{$p{globals}}-1))
 811         {
 812                 next
 813                         if $_ < @{(DEFAULTGLOBALS)};
 814                 ++$isconst{$_}
 815                         if !$offsets_saved{$_} and $offsets_initialized{$_};
 816                 ++$istemp{$_}
 817                         if !$offsets_saved{$_} and !$offsets_initialized{$_};
 818         }
 819         $p{temps} = \%istemp;
 820         $p{consts} = \%isconst;
 821
 822         print STDERR "Naming...\n";
 823
 824         # globaldefs
 825         my @globaldefs = ();
 826         for(@{$p{globaldefs}})
 827         {
 828                 $_->{debugname} = $p{getstring}->($_->{s_name});
 829         }
 830         for(@{$p{globaldefs}})
 831         {
 832                 $globaldefs[$_->{ofs}] //= $_
 833                         if $_->{debugname} ne "";
 834         }
 835         for(@{$p{globaldefs}})
 836         {
 837                 $globaldefs[$_->{ofs}] //= $_;
 838         }
 839         for(0..(@{$p{globals}}-1))
 840         {
 841                 $globaldefs[$_] //= {
 842                         ofs => $_,
 843                         s_name => undef,
 844                         debugname => ""
 845                 };
 846         }
 847         my %globaldefs = ();
 848         for(@globaldefs)
 849         {
 850                 if($_->{debugname} eq "")
 851                 {
 852                         if($istemp{$_->{ofs}})
 853                         {
 854                                 $_->{debugname} = "<temp>\@$_->{ofs}";
 855                         }
 856                         elsif($isconst{$_->{ofs}})
 857                         {
 858                                 $_->{debugname} = "<" . get_constant(\%p, $p{globals}[$_->{ofs}]{v}) . ">\@$_->{ofs}";
 859                         }
 860                         else
 861                         {
 862                                 $_->{debugname} = "<nodef>\@$_->{ofs}";
 863                         }
 864                 }
 865                 ++$globaldefs{$_->{debugname}};
 866         }
 867         for(@globaldefs)
 868         {
 869                 next
 870                         if $globaldefs{$_->{debugname}} <= 1;
 871                 $_->{debugname} .= "\@$_->{ofs}";
 872         }
 873         $p{globaldef_byoffset} = sub
 874         {
 875                 my ($ofs) = @_;
 876                 $ofs &= 0xFFFF;
 877                 if($ofs >= 0 && $ofs < @{(DEFAULTGLOBALS)})
 878                 {
 879                         return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
 880                 }
 881                 my $def = $globaldefs[$ofs];
 882                 return $def;
 883         };
 884
 885         # functions
 886         my %functions = ();
 887         for(@{$p{functions}})
 888         {
 889                 my $file = $p{getstring}->($_->{s_file});
 890                 my $name = $p{getstring}->($_->{s_name});
 891                 $name = "$file:$name"
 892                         if length $file;
 893                 $_->{debugname} = $name;
 894                 $functions{$_->{first_statement}} = $_;
 895         }
 896         $p{function_byoffset} = sub
 897         {
 898                 my ($ofs) = @_;
 899                 return $functions{$ofs};
 900         };
 901
 902         # what do we want to do?
 903         my $checkfunc = \&find_uninitialized_locals;
 904         #my $checkfunc = \&disassemble_function;
 905         for(sort { $a->{debugname} cmp $b->{debugname} } @{$p{functions}})
 906         {
 907                 $checkfunc->(\%p, $_);
 908         }
 909 }
 910
 911 open my $fh, '<', $ARGV[0];
 912 parse_progs $fh;