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                         $instruction_handler->($ip, $state, $s, $c);
 253
 254                         if($c->{isreturn})
 255                         {
 256                                 last;
 257                         }
 258                         elsif($c->{isjump})
 259                         {
 260                                 if($c->{isconditional})
 261                                 {
 262                                         $nfa->($ip+1, $copy_handler->($state));
 263                                         $ip += $s->{$c->{isjump}};
 264                                 }
 265                                 else
 266                                 {
 267                                         $ip += $s->{$c->{isjump}};
 268                                 }
 269                         }
 270                         else
 271                         {
 272                                 $ip += 1;
 273                         }
 274                 }
 275         };
 276
 277         $nfa->($ip, $copy_handler->($state));
 278 }
 279
 280 use constant PRE_MARK_STATEMENT => "\e[1m";
 281 use constant POST_MARK_STATEMENT => "\e[m";
 282 use constant PRE_MARK_OPERAND => "\e[41m";
 283 use constant POST_MARK_OPERAND => "\e[49m";
 284
 285 use constant INSTRUCTION_FORMAT => "%8s %3s | %-12s ";
 286 use constant OPERAND_FORMAT => "%s";
 287 use constant OPERAND_SEPARATOR => ", ";
 288 use constant INSTRUCTION_SEPARATOR => "\n";
 289
 290 sub str($)
 291 {
 292         my ($str) = @_;
 293         $str =~ s/[\000-\037\\\"\177-\377]/sprintf "\\%03o", ord $&/ge;
 294         return "\"$str\"";
 295 }
 296
 297 sub disassemble_function($$;$)
 298 {
 299         my ($progs, $func, $highlight) = @_;
 300
 301         print "$func->{debugname}:\n";
 302
 303         my $initializer = sub
 304         {
 305                 my ($ofs) = @_;
 306                 my $g = $progs->{globals}[$ofs]{v};
 307                 if($g->{int} == 0)
 308                 {
 309                 }
 310                 elsif($g->{int} < 16777216)
 311                 {
 312                         print " = $g->{int}%";
 313                         if($g->{int} < length $progs->{strings} && $g->{int} > 0)
 314                         {
 315                                 print " " . str($progs->{getstring}->($g->{int}));
 316                         }
 317                 }
 318                 else
 319                 {
 320                         print " = $g->{float}!";
 321                 }
 322         };
 323
 324         printf INSTRUCTION_FORMAT, '', '', '.PARM_START';
 325         printf OPERAND_FORMAT, "$func->{parm_start}";
 326         print INSTRUCTION_SEPARATOR;
 327
 328         printf INSTRUCTION_FORMAT, '', '', '.LOCALS';
 329         printf OPERAND_FORMAT, "$func->{locals}";
 330         print INSTRUCTION_SEPARATOR;
 331
 332         my %override_locals = ();
 333         my $p = $func->{parm_start};
 334         for(0..($func->{numparms}-1))
 335         {
 336                 if($func->{parm_size}[$_] <= 1)
 337                 {
 338                         $override_locals{$p} //= "argv[$_]";
 339                 }
 340                 for my $comp(0..($func->{parm_size}[$_]-1))
 341                 {
 342                         $override_locals{$p} //= "argv[$_][$comp]";
 343                         ++$p;
 344                 }
 345                 printf INSTRUCTION_FORMAT, '', '', '.ARG';
 346                 printf OPERAND_FORMAT, "argv[$_]";
 347                 print OPERAND_SEPARATOR;
 348                 printf OPERAND_FORMAT, $func->{parm_size}[$_];
 349                 print INSTRUCTION_SEPARATOR;
 350         }
 351         for($func->{parm_start}..($func->{parm_start} + $func->{locals} - 1))
 352         {
 353                 next
 354                         if exists $override_locals{$_};
 355                 $override_locals{$_} = "<local>\@$_";
 356
 357                 printf INSTRUCTION_FORMAT, '', '', '.LOCAL';
 358                 printf OPERAND_FORMAT, "<local>\@$_";
 359                 $initializer->($_);
 360                 print INSTRUCTION_SEPARATOR;
 361         }
 362
 363         my $getname = sub
 364         {
 365                 my ($ofs) = @_;
 366                 return $override_locals{$ofs}
 367                         if exists $override_locals{$ofs};
 368                 return $progs->{globaldef_byoffset}->($ofs)->{debugname};
 369         };
 370
 371         my $operand = sub
 372         {
 373                 my ($ip, $type, $operand) = @_;
 374                 if($type eq 'inglobal')
 375                 {
 376                         my $name = $getname->($operand);
 377                         printf OPERAND_FORMAT, "$name";
 378                 }
 379                 elsif($type eq 'outglobal')
 380                 {
 381                         my $name = $getname->($operand);
 382                         printf OPERAND_FORMAT, "&$name";
 383                 }
 384                 elsif($type eq 'inglobalvec')
 385                 {
 386                         my $name = $getname->($operand);
 387                         printf OPERAND_FORMAT, "$name\[\]";
 388                 }
 389                 elsif($type eq 'outglobalvec')
 390                 {
 391                         my $name = $getname->($operand);
 392                         printf OPERAND_FORMAT, "&$name\[\]";
 393                 }
 394                 elsif($type eq 'inglobalfunc')
 395                 {
 396                         my $name = $getname->($operand);
 397                         printf OPERAND_FORMAT, "$name()";
 398                 }
 399                 elsif($type eq 'ipoffset')
 400                 {
 401                         printf OPERAND_FORMAT, "@{[$ip + $operand]}" . sprintf ' ($%+d)', $operand;
 402                 }
 403                 else
 404                 {
 405                         die "unknown type: $type";
 406                 }
 407         };
 408
 409         my %statements = ();
 410         my %come_from = ();
 411         run_nfa $progs, $func->{first_statement}, "", id, id,
 412                 sub
 413                 {
 414                         my ($ip, $state, $s, $c) = @_;
 415                         ++$statements{$ip};
 416
 417                         if(my $j = $c->{isjump})
 418                         {
 419                                 my $t = $ip + $s->{$j};
 420                                 $come_from{$t}{$ip} = $c->{isconditional};
 421                         }
 422                 };
 423
 424         my $ipprev = undef;
 425         for my $ip(sort { $a <=> $b } keys %statements)
 426         {
 427                 if($ip == $func->{first_statement})
 428                 {
 429                         printf INSTRUCTION_FORMAT, $ip, '', '.ENTRY';
 430                         print INSTRUCTION_SEPARATOR;
 431                 }
 432                 if(defined $ipprev && $ip != $ipprev + 1)
 433                 {
 434                         printf INSTRUCTION_FORMAT, $ip, '', '.SKIP';
 435                         printf OPERAND_FORMAT, $ip - $ipprev - 1;
 436                         print INSTRUCTION_SEPARATOR;
 437                 }
 438                 if(my $cf = $come_from{$ip})
 439                 {
 440                         printf INSTRUCTION_FORMAT, $ip, '', '.XREF';
 441                         my $cnt = 0;
 442                         for(sort { $a <=> $b } keys %$cf)
 443                         {
 444                                 print OPERAND_SEPARATOR
 445                                         if $cnt++;
 446                                 printf OPERAND_FORMAT, ($cf->{$_} ? 'c' : 'j') . $_ . sprintf ' ($%+d)', $_ - $ip;
 447                         }
 448                         print INSTRUCTION_SEPARATOR;
 449                 }
 450
 451                 my $op = $progs->{statements}[$ip]{op};
 452                 my $ipt = $progs->{statements}[$ip];
 453                 my $opprop = checkop $op;
 454
 455                 print PRE_MARK_STATEMENT
 456                         if $highlight and $highlight->{$ip};
 457
 458                 my $showip = $opprop->{isjump};
 459                 printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? "<!>" : "", $op;
 460
 461                 my $cnt = 0;
 462                 for my $o(qw(a b c))
 463                 {
 464                         next
 465                                 if not defined $opprop->{$o};
 466                         print OPERAND_SEPARATOR
 467                                 if $cnt++;
 468                         print PRE_MARK_OPERAND
 469                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 470                         $operand->($ip, $opprop->{$o}, $ipt->{$o});
 471                         print POST_MARK_OPERAND
 472                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
 473                 }
 474
 475                 print POST_MARK_STATEMENT
 476                         if $highlight and $highlight->{$ip};
 477
 478                 print INSTRUCTION_SEPARATOR;
 479         }
 480 }
 481
 482 sub find_uninitialized_locals($$)
 483 {
 484         my ($progs, $func) = @_;
 485
 486         return
 487                 if $func->{first_statement} < 0; # builtin
 488
 489         print STDERR "Checking $func->{debugname}...\n";
 490
 491         my $p = $func->{parm_start};
 492         for(0..($func->{numparms}-1))
 493         {
 494                 $p += $func->{parm_size}[$_];
 495         }
 496
 497         use constant WATCHME_R => 1;
 498         use constant WATCHME_W => 2;
 499         use constant WATCHME_X => 4;
 500         use constant WATCHME_T => 8;
 501         my %watchme = map { $_ => WATCHME_X } ($p .. ($func->{parm_start} + $func->{locals} - 1));
 502
 503         for($progs->{temps})
 504         {
 505                 $watchme{$_} = WATCHME_T | WATCHME_X
 506                         if not exists $watchme{$_};
 507         }
 508
 509         run_nfa $progs, $func->{first_statement}, "", id, id,
 510                 sub
 511                 {
 512                         my ($ip, $state, $s, $c) = @_;
 513                         for(qw(a b c))
 514                         {
 515                                 my $type = $c->{$_};
 516                                 next
 517                                         unless defined $type;
 518
 519                                 my $ofs = $s->{$_};
 520                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 521                                 {
 522                                         $watchme{$ofs} |= WATCHME_R;
 523                                 }
 524                                 elsif($type eq 'inglobalvec')
 525                                 {
 526                                         $watchme{$ofs} |= WATCHME_R;
 527                                         $watchme{$ofs+1} |= WATCHME_R;
 528                                         $watchme{$ofs+2} |= WATCHME_R;
 529                                 }
 530                                 elsif($type eq 'outglobal')
 531                                 {
 532                                         $watchme{$ofs} |= WATCHME_W;
 533                                 }
 534                                 elsif($type eq 'outglobalvec')
 535                                 {
 536                                         $watchme{$ofs} |= WATCHME_W;
 537                                         $watchme{$ofs+1} |= WATCHME_W;
 538                                         $watchme{$ofs+2} |= WATCHME_W;
 539                                 }
 540                         }
 541                 };
 542
 543         for(keys %watchme)
 544         {
 545                 delete $watchme{$_}
 546                         if ($watchme{$_} & (WATCHME_R | WATCHME_W | WATCHME_X)) != (WATCHME_R | WATCHME_W | WATCHME_X);
 547         }
 548
 549         return
 550                 if not keys %watchme;
 551
 552         for(keys %watchme)
 553         {
 554                 $watchme{$_} = { flags => $watchme{$_}, valid => 0 };
 555         }
 556
 557         my %warned = ();
 558         run_nfa $progs, $func->{first_statement}, \%watchme,
 559                 sub {
 560                         my ($h) = @_;
 561                         return { map { $_ => { %{$h->{$_}} } } keys %$h };
 562                 },
 563                 sub {
 564                         my ($h) = @_;
 565                         return join ' ', map { $h->{$_}->{valid}; } sort keys %$h;
 566                 },
 567                 sub {
 568                         my ($ip, $state, $s, $c) = @_;
 569                         my $op = $s->{op};
 570                         for(qw(a b c))
 571                         {
 572                                 my $type = $c->{$_};
 573                                 next
 574                                         unless defined $type;
 575
 576                                 my $ofs = $s->{$_};
 577
 578                                 my $read = sub
 579                                 {
 580                                         my ($ofs) = @_;
 581                                         return
 582                                                 if not exists $state->{$ofs};
 583                                         my $valid = $state->{$ofs}{valid};
 584                                         if($valid == 0)
 585                                         {
 586                                                 print "; Use of uninitialized value $ofs in $func->{debugname} at $ip.$_\n";
 587                                                 ++$warned{$ip}{$_};
 588                                         }
 589                                         elsif($valid < 0)
 590                                         {
 591                                                 print "; Use of temporary $ofs across CALL in $func->{debugname} at $ip.$_\n";
 592                                                 ++$warned{$ip}{$_};
 593                                         }
 594                                 };
 595                                 my $write = sub
 596                                 {
 597                                         my ($ofs) = @_;
 598                                         $state->{$ofs}{valid} = 1
 599                                                 if exists $state->{$ofs};
 600                                 };
 601
 602                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
 603                                 {
 604                                         if($op ne 'OR' && $op ne 'AND') # fteqcc logicops cause this
 605                                         {
 606                                                 $read->($ofs);
 607                                         }
 608                                 }
 609                                 elsif($type eq 'inglobalvec')
 610                                 {
 611                                         if($op ne 'OR' && $op ne 'AND') # fteqcc logicops cause this
 612                                         {
 613                                                 $read->($ofs);
 614                                                 $read->($ofs+1);
 615                                                 $read->($ofs+2);
 616                                         }
 617                                 }
 618                                 elsif($type eq 'outglobal')
 619                                 {
 620                                         $write->($ofs);
 621                                 }
 622                                 elsif($type eq 'outglobalvec')
 623                                 {
 624                                         $write->($ofs);
 625                                         $write->($ofs+1);
 626                                         $write->($ofs+2);
 627                                 }
 628                         }
 629                         if($c->{iscall})
 630                         {
 631                                 # invalidate temps
 632                                 for(values %$state)
 633                                 {
 634                                         if($_->{flags} & WATCHME_T)
 635                                         {
 636                                                 $_->{valid} = -1;
 637                                         }
 638                                 }
 639                         }
 640                 };
 641
 642         disassemble_function($progs, $func, \%warned)
 643                 if keys %warned;
 644 }
 645
 646 use constant DEFAULTGLOBALS => [
 647         "<OFS_NULL>",
 648         "<OFS_RETURN>",
 649         "<OFS_RETURN>[1]",
 650         "<OFS_RETURN>[2]",
 651         "<OFS_PARM0>",
 652         "<OFS_PARM0>[1]",
 653         "<OFS_PARM0>[2]",
 654         "<OFS_PARM1>",
 655         "<OFS_PARM1>[1]",
 656         "<OFS_PARM1>[2]",
 657         "<OFS_PARM2>",
 658         "<OFS_PARM2>[1]",
 659         "<OFS_PARM2>[2]",
 660         "<OFS_PARM3>",
 661         "<OFS_PARM3>[1]",
 662         "<OFS_PARM3>[2]",
 663         "<OFS_PARM4>",
 664         "<OFS_PARM4>[1]",
 665         "<OFS_PARM4>[2]",
 666         "<OFS_PARM5>",
 667         "<OFS_PARM5>[1]",
 668         "<OFS_PARM5>[2]",
 669         "<OFS_PARM6>",
 670         "<OFS_PARM6>[1]",
 671         "<OFS_PARM6>[2]",
 672         "<OFS_PARM7>",
 673         "<OFS_PARM7>[1]",
 674         "<OFS_PARM7>[2]"
 675 ];
 676
 677 sub defaultglobal($)
 678 {
 679         my ($ofs) = @_;
 680         if($ofs < @{(DEFAULTGLOBALS)})
 681         {
 682                 return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
 683         }
 684         return { ofs => $ofs, s_name => undef, debugname => "<undefined>\@$ofs", type => undef };
 685 }
 686
 687 sub parse_progs($)
 688 {
 689         my ($fh) = @_;
 690
 691         my %p = ();
 692
 693         print STDERR "Parsing header...\n";
 694         $p{header} = parse_section $fh, DPROGRAMS_T, 0, undef, 1;
 695
 696         print STDERR "Parsing strings...\n";
 697         $p{strings} = get_section $fh, $p{header}{ofs_strings}, $p{header}{numstrings};
 698         $p{getstring} = sub
 699         {
 700                 my ($startpos) = @_;
 701                 my $endpos = index $p{strings}, "\0", $startpos;
 702                 return substr $p{strings}, $startpos, $endpos - $startpos;
 703         };
 704
 705         print STDERR "Parsing statements...\n";
 706         $p{statements} = [parse_section $fh, DSTATEMENT_T, $p{header}{ofs_statements}, undef, $p{header}{numstatements}];
 707
 708         print STDERR "Parsing globaldefs...\n";
 709         $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}];
 710
 711         print STDERR "Parsing fielddefs...\n";
 712         $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}];
 713
 714         print STDERR "Parsing globals...\n";
 715         $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}];
 716
 717         print STDERR "Parsing functions...\n";
 718         $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}];
 719
 720         print STDERR "Detecting temps...\n";
 721         my %offsets_saved = ();
 722         for(@{$p{globaldefs}})
 723         {
 724                 next
 725                         unless $_->{type}{save};
 726                 next
 727                         unless $p{getstring}->($_->{s_name}) eq "";
 728                 for my $i(0..(typesize($_->{type}{type})-1))
 729                 {
 730                         ++$offsets_saved{$_->{ofs}+$i};
 731                 }
 732         }
 733         my %istemp = ();
 734         for(0..(@{$p{globals}}-1))
 735         {
 736                 next
 737                         if $offsets_saved{$_};
 738                 $istemp{$_} = 1;
 739         }
 740         $p{temps} = [keys %istemp];
 741
 742         print STDERR "Naming...\n";
 743
 744         # globaldefs
 745         my @globaldefs = ();
 746         for(@{$p{globaldefs}})
 747         {
 748                 $_->{debugname} = $p{getstring}->($_->{s_name});
 749         }
 750         for(@{$p{globaldefs}})
 751         {
 752                 $globaldefs[$_->{ofs}] //= $_
 753                         if $_->{debugname} ne "";
 754         }
 755         for(@{$p{globaldefs}})
 756         {
 757                 $globaldefs[$_->{ofs}] //= $_;
 758         }
 759         for(0..(@{$p{globals}}-1))
 760         {
 761                 $globaldefs[$_] //= { ofs => $_, s_name => undef, debugname => ($istemp{$_} ? "<temp>" : "<nodef>") . "\@$_" },
 762         }
 763         my %globaldefs = ();
 764         for(@{$p{globaldefs}})
 765         {
 766                 $_->{debugname} = "<anon>\@$_->{ofs}"
 767                         if $_->{debugname} eq "";
 768                 ++$globaldefs{$_->{debugname}};
 769         }
 770         for(@{$p{globaldefs}})
 771         {
 772                 next
 773                         if $globaldefs{$_->{debugname}} <= 1;
 774                 $_->{debugname} .= "\@$_->{ofs}";
 775         }
 776         $p{globaldef_byoffset} = sub
 777         {
 778                 my ($ofs) = @_;
 779                 if($ofs < @{(DEFAULTGLOBALS)})
 780                 {
 781                         return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
 782                 }
 783                 my $def = $globaldefs[$ofs];
 784         };
 785
 786         # functions
 787         my %functions = ();
 788         for(@{$p{functions}})
 789         {
 790                 my $file = $p{getstring}->($_->{s_file});
 791                 my $name = $p{getstring}->($_->{s_name});
 792                 $name = "$file:$name"
 793                         if length $file;
 794                 $_->{debugname} = $name;
 795                 $functions{$_->{first_statement}} = $_;
 796         }
 797         $p{function_byoffset} = sub
 798         {
 799                 my ($ofs) = @_;
 800                 return $functions{$ofs};
 801         };
 802
 803         # what do we want to do?
 804         my $checkfunc = \&find_uninitialized_locals;
 805         for(sort { $a->{debugname} cmp $b->{debugname} } @{$p{functions}})
 806         {
 807                 $checkfunc->(\%p, $_);
 808         }
 809 }
 810
 811 open my $fh, '<', $ARGV[0];
 812 parse_progs $fh;