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