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