12 return sub { $_[0] >= (2**($bits-1)) ? $_[0]-(2**$bits) : $_[0]; };
15 use constant OPCODE_E => [qw[
17 MUL_F MUL_V MUL_FV MUL_VF
21 EQ_F EQ_V EQ_S EQ_E EQ_FNC
22 NE_F NE_V NE_S NE_E NE_FNC
24 LOAD_F LOAD_V LOAD_S LOAD_ENT LOAD_FLD LOAD_FNC
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
29 NOT_F NOT_V NOT_S NOT_ENT NOT_FNC
31 CALL0 CALL1 CALL2 CALL3 CALL4 CALL5 CALL6 CALL7 CALL8
37 use constant ETYPE_E => [qw[
47 use constant DEF_SAVEGLOBAL => 32768;
51 return 3 if $type eq 'vector';
60 return { a => 'inglobalvec', b => 'ipoffset', isjump => 'b', isconditional => 1 };
64 return { a => 'inglobal', b => 'ipoffset', isjump => 'b', isconditional => 1 };
68 return { a => 'ipoffset', isjump => 'a', isconditional => 0 };
70 if($op =~ /^ADD_V$|^SUB_V$/)
72 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobalvec' };
74 if($op =~ /^MUL_V$|^EQ_V$|^NE_V$/)
76 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobal' };
80 return { a => 'inglobal', b => 'inglobalvec', c => 'outglobalvec' };
84 return { a => 'inglobalvec', b => 'inglobal', c => 'outglobalvec' };
88 return { a => 'inglobal', b => 'inglobal', c => 'outglobalvec' };
92 return { a => 'inglobalvec', c => 'outglobal' };
96 return { a => 'inglobal', c => 'outglobal' };
100 return { a => 'inglobalvec', b => 'inglobal' };
104 return { a => 'inglobalvec', b => 'outglobalvec' };
106 if($op =~ /^STOREP_/)
108 return { a => 'inglobal', b => 'inglobal' };
112 return { a => 'inglobal', b => 'outglobal' };
116 return { a => 'inglobalfunc', iscall => 1 };
118 if($op =~ /^DONE$|^RETURN$/)
120 return { a => 'inglobal', isreturn => 1 };
122 return { a => 'inglobal', b => 'inglobal', c => 'outglobal' };
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) }; }],
136 use constant DPROGRAMS_T => [
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']
154 use constant DSTATEMENT_T => [
161 use constant DDEF_T => [
167 use constant DGLOBAL_T => [
171 use constant DFUNCTION_T => [
172 [int => 'first_statement'],
173 [int => 'parm_start'],
179 [uchar8 => 'parm_size'],
184 my ($fh, $start, $len) = @_;
187 $len == read $fh, my $buf, $len
192 sub parse_section($$$$$)
194 my ($fh, $struct, $start, $len, $cnt) = @_;
197 $itemlen += TYPES->{$_->[0]}->[1]
199 my $packspec = join '', map { TYPES->{$_->[0]}->[0]; } @$struct;
200 my @packnames = map { $_->[1]; } @$struct;
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;
215 $itemlen == read $fh, my $buf, $itemlen
218 @h{@packnames} = unpack $packspec, $buf;
219 $h{$_->[1]} = TYPES->{$_->[0]}->[2]->($h{$_->[1]})
231 my ($progs, $ip, $state, $copy_handler, $state_hasher, $instruction_handler) = @_;
234 my $statements = $progs->{statements};
239 no warnings 'recursion';
241 my ($ip, $state) = @_;
245 my $statestr = $state_hasher->($state);
247 if $seen{"$ip:$statestr"}++;
249 my $s = $statements->[$ip];
250 my $c = checkop $s->{op};
252 if($instruction_handler->($ip, $state, $s, $c))
264 if($c->{isconditional})
266 $nfa->($ip+1, $copy_handler->($state));
267 $ip += $s->{$c->{isjump}};
271 $ip += $s->{$c->{isjump}};
281 $nfa->($ip, $copy_handler->($state));
286 my ($progs, $g) = @_;
291 elsif($g->{int} > 0 && $g->{int} < 16777216)
293 if($g->{int} < length $progs->{strings} && $g->{int} > 0)
295 return str($progs->{getstring}->($g->{int}));
299 return $g->{int} . "i";
308 use constant PRE_MARK_STATEMENT => "\e[1m";
309 use constant POST_MARK_STATEMENT => "\e[m";
310 use constant PRE_MARK_OPERAND => "\e[41m";
311 use constant POST_MARK_OPERAND => "\e[49m";
313 use constant INSTRUCTION_FORMAT => "%8s %3s | %-12s ";
314 use constant OPERAND_FORMAT => "%s";
315 use constant OPERAND_SEPARATOR => ", ";
316 use constant INSTRUCTION_SEPARATOR => "\n";
321 $str =~ s/[\000-\037\\\"\177-\377]/sprintf "\\%03o", ord $&/ge;
325 sub disassemble_function($$;$)
327 my ($progs, $func, $highlight) = @_;
329 print "$func->{debugname}:\n";
331 my $initializer = sub
334 my $g = get_constant($progs, $progs->{globals}[$ofs]{v});
339 printf INSTRUCTION_FORMAT, '', '', '.PARM_START';
340 printf OPERAND_FORMAT, "$func->{parm_start}";
341 print INSTRUCTION_SEPARATOR;
343 printf INSTRUCTION_FORMAT, '', '', '.LOCALS';
344 printf OPERAND_FORMAT, "$func->{locals}";
345 print INSTRUCTION_SEPARATOR;
347 my %override_locals = ();
348 my $p = $func->{parm_start};
349 for(0..($func->{numparms}-1))
351 $override_locals{$p} //= "argv[$_]";
352 for my $comp(0..($func->{parm_size}[$_]-1))
354 $override_locals{$p} //= "argv[$_][$comp]";
357 printf INSTRUCTION_FORMAT, '', '', '.ARG';
358 printf OPERAND_FORMAT, "argv[$_]";
359 print OPERAND_SEPARATOR;
360 printf OPERAND_FORMAT, $func->{parm_size}[$_];
361 print INSTRUCTION_SEPARATOR;
363 for($func->{parm_start}..($func->{parm_start} + $func->{locals} - 1))
366 if exists $override_locals{$_};
367 $override_locals{$_} = "<local>\@$_";
369 printf INSTRUCTION_FORMAT, '', '', '.LOCAL';
370 printf OPERAND_FORMAT, "<local>\@$_";
372 print INSTRUCTION_SEPARATOR;
379 return $override_locals{$ofs}
380 if exists $override_locals{$ofs};
381 my $def = $progs->{globaldef_byoffset}->($ofs);
382 return $def->{debugname};
387 my ($ip, $type, $operand) = @_;
388 if($type eq 'inglobal')
390 my $name = $getname->($operand);
391 printf OPERAND_FORMAT, "$name";
393 elsif($type eq 'outglobal')
395 my $name = $getname->($operand);
396 printf OPERAND_FORMAT, "&$name";
398 elsif($type eq 'inglobalvec')
400 my $name = $getname->($operand);
401 printf OPERAND_FORMAT, "$name\[\]";
403 elsif($type eq 'outglobalvec')
405 my $name = $getname->($operand);
406 printf OPERAND_FORMAT, "&$name\[\]";
408 elsif($type eq 'inglobalfunc')
410 my $name = $getname->($operand);
411 printf OPERAND_FORMAT, "$name()";
413 elsif($type eq 'ipoffset')
415 printf OPERAND_FORMAT, "@{[$ip + $operand]}" . sprintf ' ($%+d)', $operand;
419 die "unknown type: $type";
425 run_nfa $progs, $func->{first_statement}, "", id, id,
428 my ($ip, $state, $s, $c) = @_;
431 if(my $j = $c->{isjump})
433 my $t = $ip + $s->{$j};
434 $come_from{$t}{$ip} = $c->{isconditional};
441 for my $ip(sort { $a <=> $b } keys %statements)
443 if($ip == $func->{first_statement})
445 printf INSTRUCTION_FORMAT, $ip, '', '.ENTRY';
446 print INSTRUCTION_SEPARATOR;
448 if(defined $ipprev && $ip != $ipprev + 1)
450 printf INSTRUCTION_FORMAT, $ip, '', '.SKIP';
451 printf OPERAND_FORMAT, $ip - $ipprev - 1;
452 print INSTRUCTION_SEPARATOR;
454 if(my $cf = $come_from{$ip})
456 printf INSTRUCTION_FORMAT, $ip, '', '.XREF';
458 for(sort { $a <=> $b } keys %$cf)
460 print OPERAND_SEPARATOR
462 printf OPERAND_FORMAT, ($cf->{$_} ? 'c' : 'j') . $_ . sprintf ' ($%+d)', $_ - $ip;
464 print INSTRUCTION_SEPARATOR;
467 my $op = $progs->{statements}[$ip]{op};
468 my $ipt = $progs->{statements}[$ip];
469 my $opprop = checkop $op;
471 print PRE_MARK_STATEMENT
472 if $highlight and $highlight->{$ip};
474 my $showip = $opprop->{isjump};
475 printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? "<!>" : "", $op;
481 if not defined $opprop->{$o};
482 print OPERAND_SEPARATOR
484 print PRE_MARK_OPERAND
485 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
486 $operand->($ip, $opprop->{$o}, $ipt->{$o});
487 print POST_MARK_OPERAND
488 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
491 print POST_MARK_STATEMENT
492 if $highlight and $highlight->{$ip};
494 print INSTRUCTION_SEPARATOR;
498 sub find_uninitialized_locals($$)
500 my ($progs, $func) = @_;
503 if $func->{first_statement} < 0; # builtin
505 print STDERR "Checking $func->{debugname}...\n";
507 my $p = $func->{parm_start};
508 for(0..($func->{numparms}-1))
510 $p += $func->{parm_size}[$_];
513 use constant WATCHME_R => 1;
514 use constant WATCHME_W => 2;
515 use constant WATCHME_X => 4;
516 use constant WATCHME_T => 8;
517 my %watchme = map { $_ => WATCHME_X } ($func->{parm_start} .. ($func->{parm_start} + $func->{locals} - 1));
519 for(keys %{$progs->{temps}})
521 $watchme{$_} = WATCHME_T | WATCHME_X
522 if not exists $watchme{$_};
525 run_nfa $progs, $func->{first_statement}, "", id, id,
528 my ($ip, $state, $s, $c) = @_;
533 unless defined $type;
536 if($type eq 'inglobal' || $type eq 'inglobalfunc')
538 $watchme{$ofs} |= WATCHME_R;
540 elsif($type eq 'inglobalvec')
542 $watchme{$ofs} |= WATCHME_R;
543 $watchme{$ofs+1} |= WATCHME_R;
544 $watchme{$ofs+2} |= WATCHME_R;
546 elsif($type eq 'outglobal')
548 $watchme{$ofs} |= WATCHME_W;
550 elsif($type eq 'outglobalvec')
552 $watchme{$ofs} |= WATCHME_W;
553 $watchme{$ofs+1} |= WATCHME_W;
554 $watchme{$ofs+2} |= WATCHME_W;
564 if ($watchme{$_} & (WATCHME_R | WATCHME_W | WATCHME_X)) != (WATCHME_R | WATCHME_W | WATCHME_X);
568 if not keys %watchme;
573 flags => $watchme{$_},
578 # mark parameters as initialized
579 for($func->{parm_start} .. ($p-1))
581 $watchme{$_}{valid} = 1
582 if defined $watchme{$_};
584 # an initial run of STORE instruction is for receiving extra parameters
585 # (beyond 8). Only possible if the function is declared as having 8 params.
586 # Extra parameters behave otherwise like temps, but are initialized at
588 for($func->{first_statement} .. (@{$progs->{statements}}-1))
590 my $s = $progs->{statements}[$_];
591 if($s->{op} eq 'STORE_V')
593 $watchme{$s->{a}}{valid} = 1
594 if defined $watchme{$s->{a}};
595 $watchme{$s->{a}+1}{valid} = 1
596 if defined $watchme{$s->{a}+1};
597 $watchme{$s->{a}+2}{valid} = 1
598 if defined $watchme{$s->{a}+2};
600 elsif($s->{op} =~ /^STORE_/)
602 $watchme{$s->{a}}{valid} = 1
603 if defined $watchme{$s->{a}};
612 run_nfa $progs, $func->{first_statement}, \%watchme,
615 return { map { $_ => { %{$h->{$_}} } } keys %$h };
619 return join ' ', map { $h->{$_}->{valid}; } sort keys %$h;
622 my ($ip, $state, $s, $c) = @_;
628 unless defined $type;
636 if not exists $state->{$ofs};
637 my $valid = $state->{$ofs}{valid};
640 print "; Use of uninitialized value $ofs in $func->{debugname} at $ip.$_\n";
645 print "; Use of temporary $ofs across CALL in $func->{debugname} at $ip.$_\n";
652 $state->{$ofs}{valid} = 1
653 if exists $state->{$ofs};
656 if($type eq 'inglobal' || $type eq 'inglobalfunc')
658 if($op ne 'OR' && $op ne 'AND') # fteqcc logicops cause this
663 elsif($type eq 'inglobalvec')
665 if($op ne 'OR' && $op ne 'AND') # fteqcc logicops cause this
672 elsif($type eq 'outglobal')
676 elsif($type eq 'outglobalvec')
685 # builtin calls may clobber stuff
687 my $funcid = $progs->{globals}[$func]{v}{int};
688 my $funcobj = $progs->{functions}[$funcid];
689 if($funcobj->{first_statement} >= 0)
694 if($_->{flags} & WATCHME_T)
700 elsif($funcobj->{debugname} =~ /(^|:)error$/)
709 disassemble_function($progs, $func, \%warned)
713 use constant DEFAULTGLOBALS => [
747 if($ofs < @{(DEFAULTGLOBALS)})
749 return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
751 return { ofs => $ofs, s_name => undef, debugname => "<undefined>\@$ofs", type => undef };
760 print STDERR "Parsing header...\n";
761 $p{header} = parse_section $fh, DPROGRAMS_T, 0, undef, 1;
763 print STDERR "Parsing strings...\n";
764 $p{strings} = get_section $fh, $p{header}{ofs_strings}, $p{header}{numstrings};
768 my $endpos = index $p{strings}, "\0", $startpos;
769 return substr $p{strings}, $startpos, $endpos - $startpos;
772 print STDERR "Parsing statements...\n";
773 $p{statements} = [parse_section $fh, DSTATEMENT_T, $p{header}{ofs_statements}, undef, $p{header}{numstatements}];
775 print STDERR "Parsing globaldefs...\n";
776 $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}];
778 print STDERR "Parsing fielddefs...\n";
779 $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}];
781 print STDERR "Parsing globals...\n";
782 $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}];
784 print STDERR "Parsing functions...\n";
785 $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}];
787 print STDERR "Detecting temps...\n";
788 my %offsets_saved = ();
789 for(@{$p{globaldefs}})
791 my $type = $_->{type};
792 my $name = $p{getstring}->($_->{s_name});
794 unless $type->{save} or $name ne "";
795 for my $i(0..(typesize($_->{type}{type})-1))
797 ++$offsets_saved{$_->{ofs}+$i};
800 my %offsets_initialized = ();
801 for(0..(@{$p{globals}}-1))
803 if($p{globals}[$_]{v}{int})
805 ++$offsets_initialized{$_};
810 for(0..(@{$p{globals}}-1))
813 if $_ < @{(DEFAULTGLOBALS)};
815 if !$offsets_saved{$_} and $offsets_initialized{$_};
817 if !$offsets_saved{$_} and !$offsets_initialized{$_};
819 $p{temps} = \%istemp;
820 $p{consts} = \%isconst;
822 print STDERR "Naming...\n";
826 for(@{$p{globaldefs}})
828 $_->{debugname} = $p{getstring}->($_->{s_name});
830 for(@{$p{globaldefs}})
832 $globaldefs[$_->{ofs}] //= $_
833 if $_->{debugname} ne "";
835 for(@{$p{globaldefs}})
837 $globaldefs[$_->{ofs}] //= $_;
839 for(0..(@{$p{globals}}-1))
841 $globaldefs[$_] //= {
850 if($_->{debugname} eq "")
852 if($istemp{$_->{ofs}})
854 $_->{debugname} = "<temp>\@$_->{ofs}";
856 elsif($isconst{$_->{ofs}})
858 $_->{debugname} = "<" . get_constant(\%p, $p{globals}[$_->{ofs}]{v}) . ">\@$_->{ofs}";
862 $_->{debugname} = "<nodef>\@$_->{ofs}";
865 ++$globaldefs{$_->{debugname}};
870 if $globaldefs{$_->{debugname}} <= 1;
871 $_->{debugname} .= "\@$_->{ofs}";
873 $p{globaldef_byoffset} = sub
877 if($ofs >= 0 && $ofs < @{(DEFAULTGLOBALS)})
879 return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
881 my $def = $globaldefs[$ofs];
887 for(@{$p{functions}})
889 my $file = $p{getstring}->($_->{s_file});
890 my $name = $p{getstring}->($_->{s_name});
891 $name = "$file:$name"
893 $_->{debugname} = $name;
894 $functions{$_->{first_statement}} = $_;
896 $p{function_byoffset} = sub
899 return $functions{$ofs};
902 # what do we want to do?
903 my $checkfunc = \&find_uninitialized_locals;
904 #my $checkfunc = \&disassemble_function;
905 for(sort { $a->{debugname} cmp $b->{debugname} } @{$p{functions}})
907 $checkfunc->(\%p, $_);
911 open my $fh, '<', $ARGV[0];