src/vm/jit/verify/generate.pl

   1 #!/usr/bin/perl
   2 # src/vm/jit/verify/generate.pl - verifier generator
   3 #
   4 # Copyright (C) 1996-2005, 2006 R. Grafl, A. Krall, C. Kruegel,
   5 # C. Oates, R. Obermaisser, M. Platter, M. Probst, S. Ring,
   6 # E. Steiner, C. Thalinger, D. Thuernbeck, P. Tomsich, C. Ullrich,
   7 # J. Wenninger, Institut f. Computersprachen - TU Wien
   8 #
   9 # This file is part of CACAO.
  10 #
  11 # This program is free software; you can redistribute it and/or
  12 # modify it under the terms of the GNU General Public License as
  13 # published by the Free Software Foundation; either version 2, or (at
  14 # your option) any later version.
  15 #
  16 # This program is distributed in the hope that it will be useful, but
  17 # WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 # General Public License for more details.
  20 #
  21 # You should have received a copy of the GNU General Public License
  22 # along with this program; if not, write to the Free Software
  23 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  24 # 02110-1301, USA.
  25 #
  26 # Contact: cacao@cacaojvm.org
  27 #
  28 # Authors: Edwin Steiner
  29 #
  30 # Changes:
  31 #
  32 # $Id$
  33
  34
  35 use strict;
  36 use warnings;
  37 use Getopt::Long;
  38 use IO::File;
  39
  40 #################### options
  41
  42 my $opt_icmdtable;
  43 my $opt_table = 0;
  44 my $opt_stack = 0;
  45 my $opt_variables = 0;
  46 my $opt_typeinferer = 0;
  47 my $opt_debug = 0;
  48 my $opt_help = 0;
  49
  50 my $usage = <<"END_USAGE";
  51 Usage:
  52     $0 --icmdtable FILE  { --table | --stack | --variables | --typeinferer } [--debug]
  53
  54 Options:
  55     --icmdtable FILE         read ICMD table from FILE
  56     --table                  print ICMD table
  57     --stack                  generate stackbased verifier
  58     --variables              generate variablesbased verifier
  59         --typeinferer            generate the type inference pass
  60         --debug                  generate additional debugging code
  61
  62     Please specify exactly one of --table, --stack, --variables, or --typeinferer.
  63
  64 END_USAGE
  65
  66 my $result = GetOptions("icmdtable=s" => \$opt_icmdtable,
  67                                                 "table"       => \$opt_table,
  68                                                 "stack"       => \$opt_stack,
  69                                                 "variables"   => \$opt_variables,
  70                                                 "typeinferer" => \$opt_typeinferer,
  71                                                 "debug"       => \$opt_debug,
  72                                                 "help|h|?"    => \$opt_help,
  73                 );
  74
  75 $result or die "$0: invalid options\n";
  76
  77 if ($opt_help) {
  78         print $usage;
  79         exit 0;
  80 }
  81
  82 if (!defined($opt_icmdtable)
  83         || ($opt_table + $opt_stack + $opt_variables + $opt_typeinferer != 1))
  84 {
  85         print STDERR $usage;
  86         exit 1;
  87 }
  88
  89 #################### constants
  90
  91 my $VERIFY_C = 'src/vm/jit/verify/icmds.c';
  92 my $TYPECHECK_STACKBASED_INC = 'src/vm/jit/verify/typecheck-stackbased-gen.inc';
  93 my $TYPECHECK_VARIABLESBASED_INC = 'src/vm/jit/verify/typecheck-variablesbased-gen.inc';
  94 my $TYPECHECK_TYPEINFERER_INC = 'src/vm/jit/verify/typecheck-typeinferer-gen.inc';
  95
  96 my $TRACE = 1;
  97
  98 my @basictypes = qw(A I F L D R); # XXX remove R?
  99 my %basictypes = map { $_ => 1 } @basictypes;
 100
 101 my %slots = (
 102                 1 => 1,
 103                 2 => 2,
 104                 A => 1,
 105                 I => 1,
 106                 F => 1,
 107                 L => 2,
 108                 D => 2,
 109                 R => 1, # XXX remove?
 110 );
 111
 112 my %cacaotypes = (
 113                 A => 'TYPE_ADR',
 114                 I => 'TYPE_INT',
 115                 F => 'TYPE_FLT',
 116                 L => 'TYPE_LNG',
 117                 D => 'TYPE_DBL',
 118                 R => 'TYPE_RET', # XXX remove?
 119 );
 120
 121 my @superblockend = qw(END GOTO JSR RET TABLE LOOKUP);
 122 my %superblockend = map { $_ => 1 } @superblockend;
 123
 124 my @validstages = qw( -- -S S+ );
 125 my %validstages = map { $_ => 1 } @validstages;
 126
 127 my @valid_tags   = qw(STACKBASED VARIABLESBASED TYPEINFERER);
 128 my @default_tags = qw(STACKBASED VARIABLESBASED);
 129
 130 my %valid_tag    = map { $_ => 1 } @valid_tags;
 131
 132 #################### global variables
 133
 134 my @icmds;
 135 my %icmds;
 136 my %icmdtraits;
 137
 138 my $codeline;
 139 my $codefile;
 140
 141 #################### subs
 142
 143 sub parse_verify_code
 144 {
 145         my ($filename, $select) = @_;
 146
 147         my $file = IO::File->new($filename) or die "$0: could not open: $filename";
 148         my $icmd;
 149         my $codeprops;
 150         my $ignore = 0;
 151
 152         while (<$file>) {
 153                 last if /^\s*\/\*\s*{START_OF_CODE}\s*\*\/\s*$/;
 154         }
 155
 156         while (<$file>) {
 157                 last if /^\s*\/\*\s*{END_OF_CODE}\s*\*\/\s*$/;
 158
 159                 if (/^case/) {
 160                         unless (/^case \s+ (\w+) \s* :
 161                                          \s* ( \/\* \s* {\s* (\w+ (\s*,\s* \w+)*) \s*} \s* \*\/ )?
 162                                          \s* $/x)
 163                         {
 164                                 die "$0: invalid case line: $filename:$.: $_";
 165                         }
 166                         my ($n, $unused, $tags) = ($1, $2, $3 || '');
 167
 168                         my @tags = split /\s*,\s*/, $tags;
 169
 170                         if (@tags == 1 && $tags[0] eq 'ALL') {
 171                                 @tags = @valid_tags;
 172                         }
 173                         @tags = @default_tags unless @tags;
 174
 175                         defined($icmds{$n}) or die "$0: unknown ICMD: $filename:$.: $_";
 176
 177                         $ignore = 1;
 178
 179                         for my $tag (@tags) {
 180                                 $valid_tag{$tag} or die "$0: invalid tag: $filename:$.: $tag";
 181
 182                                 $ignore = 0 if $tag eq $select;
 183                         }
 184
 185                         unless ($ignore) {
 186                                 my $code = [];
 187                                 $codeprops = {};
 188
 189                                 if (defined($icmd)) {
 190                                         $code = $icmd->{VERIFYCODE};
 191                                         $codeprops = $icmd->{VERIFYCODEPROPS};
 192                                 }
 193
 194                                 $icmd = $icmds{$n};
 195                                 $icmd->{VERIFYCODE} = $code;
 196                                 $icmd->{VERIFYCODELINE} = $. + 1;
 197                                 $icmd->{VERIFYCODEFILE} = $filename;
 198                                 $icmd->{VERIFYCODEPROPS} = $codeprops;
 199                         }
 200                 }
 201                 elsif ($ignore) {
 202                         if (/^\s*break\s*;\s*$/
 203                                 || /^\s*goto\s+(\w+)\s*;\s*$/)
 204                         {
 205                                 $ignore = 0;
 206                         }
 207                 }
 208                 elsif (defined($icmd)) {
 209                         if (/^\s*break\s*;\s*$/) {
 210                                 undef $icmd;
 211                         }
 212                         elsif (/^\s*goto\s+(\w+)\s*;\s*$/) {
 213                                 $icmd->{GOTOLABEL} = $1;
 214                                 undef $icmd;
 215                         }
 216                         else {
 217                                 if (/\{RESULTNOW\}/) {
 218                                         $codeprops->{RESULTNOW} = 1;
 219                                 }
 220
 221                                 if (/\S/ || scalar @{$icmd->{VERIFYCODE}} != 0) {
 222                                         push @{$icmd->{VERIFYCODE}}, $_;
 223                                 }
 224                         }
 225                 }
 226                 else {
 227                         next if /^\s*$/;
 228                         next if /^\s*\/\*.*\*\/\s*$/;
 229
 230                         die "$0: cannot handle code line outside case: $filename:$.: $_";
 231                 }
 232         }
 233 }
 234
 235 sub fill
 236 {
 237         my ($str, $len) = @_;
 238
 239         return $str . (' ' x ($len - length($str)));
 240 }
 241
 242 sub add_flag
 243 {
 244         my ($flags, $name) = @_;
 245
 246         if ($$flags eq '0') {
 247                 $$flags = $name;
 248         }
 249         else {
 250                 $$flags .= '|'.$name;
 251         }
 252 }
 253
 254 sub trait
 255 {
 256         my ($icmd,$key,$default) = @_;
 257
 258         $default = "\0" unless defined($default);
 259
 260         return (defined($icmd->{$key})) ? ":$key:".($icmd->{$key})
 261                                                                         : ":$key:$default";
 262 }
 263
 264 sub set_icmd_traits
 265 {
 266         my ($icmd,$key,$traits) = @_;
 267
 268         $traits = $key . ':' . $traits;
 269
 270         $icmd->{$key} = $traits;
 271         push @{$icmdtraits{$traits}}, $icmd;
 272 }
 273
 274 sub post_process_icmds
 275 {
 276         my ($file) = @_;
 277
 278         my $maxnamelen = 0;
 279         my $maxfullnamelen = 0;
 280         my $maxactionlen = 0;
 281         my $maxflagslen = 0;
 282
 283         for my $icmdname (@icmds) {
 284                 my $icmd = $icmds{$icmdname};
 285
 286                 {
 287                         my $action = $icmd->{ACTION};
 288                         my @variants = split (/\s*\|\s*/, $action);
 289
 290                         $icmd->{VARIANTS} = [];
 291
 292                         for my $v (@variants) {
 293                                 $v =~ /^(.*?)\s*--\s*(.*)$/ or die "invalid action: $_";
 294                                 my ($in, $out) = ($1, $2);
 295
 296                                 my @in;
 297                                 my @out;
 298                                 if ($in =~ /\s/) {
 299                                         @in = split /\s*/, $in;
 300                                 }
 301                                 else {
 302                                         @in = split //, $in;
 303                                 }
 304                                 if ($out =~ /\s/) {
 305                                         @out = split /\s*/, $out;
 306                                 }
 307                                 else {
 308                                         @out = split //, $out;
 309                                 }
 310                                 my $invars = scalar @in;
 311                                 my $outvars = scalar @out;
 312
 313                                 my $var = {};
 314                                 push @{$icmd->{VARIANTS}}, $var;
 315
 316                                 $var->{IN} = \@in;
 317                                 $var->{OUT} = \@out;
 318
 319                                 $icmd->{INVARS} = $invars;
 320                                 $icmd->{OUTVARS} = $outvars;
 321
 322                                 my $inslots = 0;
 323                                 my $outslots = 0;
 324                                 for (@in) {
 325                                         my $slots = $slots{$_};
 326                                         defined($slots) or undef $inslots, last;
 327                                         $inslots += $slots;
 328                                 }
 329                                 for (@out) {
 330                                         my $slots = $slots{$_};
 331                                         defined($slots) or undef $outslots, last;
 332                                         $outslots += $slots;
 333                                 }
 334
 335                                 $var->{INSLOTS} = $inslots;
 336                                 $var->{OUTSLOTS} = $outslots;
 337
 338                                 if (defined($inslots)) {
 339                                         if (!defined($icmd->{MININSLOTS}) || $inslots < $icmd->{MININSLOTS}) {
 340                                                 $icmd->{MININSLOTS} = $inslots;
 341                                         }
 342
 343                                         if (exists $icmd->{INSLOTS}) {
 344                                                 if ($icmd->{INSLOTS} != $inslots) {
 345                                                         $icmd->{INSLOTS} = undef;
 346                                                 }
 347                                         }
 348                                         else {
 349                                                 $icmd->{INSLOTS} = $inslots;
 350                                         }
 351                                 }
 352                                 else {
 353                                         $icmd->{INSLOTS} = undef;
 354                                         $icmd->{MININSLOTS} = undef;
 355                                 }
 356
 357                                 if (defined($outslots)) {
 358                                         if (exists $icmd->{OUTSLOTS}) {
 359                                                 if (defined($icmd->{OUTSLOTS}) && $icmd->{OUTSLOTS} != $outslots) {
 360                                                         $icmd->{OUTSLOTS} = undef;
 361                                                 }
 362                                         }
 363                                         else {
 364                                                 $icmd->{OUTSLOTS} = $outslots;
 365                                         }
 366                                 }
 367                                 else {
 368                                         $icmd->{OUTSLOTS} = undef;
 369                                 }
 370
 371                                 if ($outvars == 0 || $outvars == 1) {
 372                                         my $df = $invars . '_TO_' . $outvars;
 373                                         if (defined($icmd->{DATAFLOW})) {
 374                                                 if ($icmd->{DATAFLOW} =~ /^\d_TO_\d$/) {
 375                                                         $icmd->{DATAFLOW} eq $df
 376                                                                 or die "$0: dataflow not consistent with action: "
 377                                                                                         .$icmd->{FULLNAME}."\n";
 378                                                 }
 379                                         }
 380                                         else {
 381                                                 $icmd->{DATAFLOW} = $df;
 382                                         }
 383                                 }
 384
 385                                 if (@out == 1) {
 386                                         if ($basictypes{$out[0]}) {
 387                                                 $icmd->{BASICOUTTYPE} = $out[0];
 388                                         }
 389                                 }
 390                         }
 391                         $icmd->{ACTION} =~ s/\s//g;
 392                 }
 393
 394                 $maxfullnamelen = length($icmdname) if length($icmdname) > $maxfullnamelen;
 395                 $maxnamelen = length($icmd->{NAME}) if length($icmd->{NAME}) > $maxnamelen;
 396                 $maxactionlen = length($icmd->{ACTION}) if length($icmd->{ACTION}) > $maxactionlen;
 397
 398                 my $parent;
 399
 400                 $icmd->{STAGE} = '  ' unless defined($icmd->{STAGE});
 401
 402                 if ($icmdname =~ /^(.*)CONST$/ && defined($icmds{$1})) {
 403                         $parent = $icmds{$1};
 404                 }
 405
 406                 if (!defined($icmd->{DATAFLOW}) && defined($parent)) {
 407                         if ($parent->{DATAFLOW} =~ /(\d)_TO_(\d)/) {
 408                                 $1 >= 0 or die "$0: cannot derive data-flow: $icmdname from ".$parent->{FULLNAME};
 409                                 $icmd->{DATAFLOW} = ($1-1).'_TO_'.$2;
 410                         }
 411                 }
 412
 413                 if (!defined($icmd->{BASICOUTTYPE}) && defined($parent)) {
 414                         $icmd->{BASICOUTTYPE} = $parent->{BASICOUTTYPE};
 415                 }
 416
 417                 if (defined($icmd->{INSLOTS}) && defined($icmd->{OUTSLOTS})) {
 418                         $icmd->{STACKCHANGE} = $icmd->{OUTSLOTS} - $icmd->{INSLOTS};
 419                 }
 420
 421                 my $flags = '0';
 422                 add_flag(\$flags, 'PEI') if $icmd->{MAYTHROW};
 423                 add_flag(\$flags, $icmd->{CALLS}) if $icmd->{CALLS};
 424
 425                 $icmd->{FLAGS} = $flags;
 426
 427                 $maxflagslen = length($flags) if length($flags) > $maxflagslen;
 428
 429                 ### calculate traits for building equivalence classes of ICMDs
 430
 431                 # traits used in all cases
 432                 my $commontraits = trait($icmd, 'CONTROLFLOW')
 433                                                  . trait($icmd, 'MAYTHROW', 0)
 434                                                  . trait($icmd, 'VERIFYCODE');
 435
 436                 # traits that completely define the kind of dataflow
 437                 my $datatraits = trait($icmd, 'DATAFLOW')
 438                                            . trait($icmd, 'ACTION');
 439
 440                 # traits defining the output type
 441                 my $outputtraits;
 442                 if ($icmd->{DATAFLOW} =~ /^\d_TO_\d$/) {
 443                         $outputtraits = trait($icmd, 'OUTVARS')
 444                                                   . trait($icmd, 'BASICOUTTYPE');
 445                 }
 446                 else {
 447                         $outputtraits = $datatraits;
 448                 }
 449
 450                 # traits used by the stack-based verifier
 451                 my $traits = $commontraits
 452                                    . $datatraits;
 453                 set_icmd_traits($icmd, 'STACKBASED', $traits);
 454
 455                 # traits used by the variables-based verifier
 456                 $traits = $commontraits
 457                             . ($opt_debug ? $datatraits : $outputtraits);
 458                 set_icmd_traits($icmd, 'VARIABLESBASED', $traits);
 459
 460                 # traits used by the type inference pass
 461                 $traits = $commontraits
 462                             . ($opt_debug ? $datatraits : $outputtraits);
 463                 set_icmd_traits($icmd, 'TYPEINFERER', $traits);
 464         }
 465
 466         my $maxmax = 18;
 467         $maxactionlen = $maxmax if $maxactionlen > $maxmax;
 468
 469         for my $icmdname (@icmds) {
 470                 my $icmd = $icmds{$icmdname};
 471
 472                 $icmd->{FULLNAME_FILLED} = fill($icmd->{FULLNAME}, $maxfullnamelen);
 473                 $icmd->{NAME_FILLED} = fill($icmd->{NAME}, $maxnamelen);
 474                 $icmd->{ACTION_FILLED} = fill("(".$icmd->{ACTION}.")", $maxactionlen+2);
 475                 $icmd->{FLAGS_FILLED} = fill($icmd->{FLAGS}, $maxflagslen);
 476         }
 477 }
 478
 479 sub code
 480 {
 481         my $text = join '', @_;
 482
 483         $text =~ s/\n/\n  GENERATED  /g;
 484         $text =~ s/^#/\n#            /g;
 485
 486         my $newlines = () = $text =~ /\n/g;
 487
 488         print $codefile $text;
 489         $codeline += $newlines;
 490 }
 491
 492 sub write_verify_stackbased_stackchange
 493 {
 494         my ($icmd) = @_;
 495
 496         my $outslots = $icmd->{OUTSLOTS};
 497         my $inslots = $icmd->{INSLOTS};
 498         my $outtype = $icmd->{BASICOUTTYPE};
 499         my $stackchange = $icmd->{STACKCHANGE};
 500
 501         my $modified = 0;
 502
 503         if (defined($inslots) && defined($outslots)) {
 504
 505                 ### modify stack pointer and write destination type
 506
 507                 if ($stackchange !=  0) {
 508                         code "\tstack += ", $stackchange, ";\n";
 509                 }
 510
 511                 if (defined($icmd->{VARIANTS}) && scalar @{$icmd->{VARIANTS}} == 1) {
 512                         my $var = $icmd->{VARIANTS}->[0];
 513
 514                         if (defined($outtype)) {
 515                                 if ($outslots && ($inslots < $outslots || $var->{IN}->[0] ne $outtype)) {
 516                                         if ($outslots == 1) {
 517                                                 code "\tstack[0].type = ", $cacaotypes{$outtype}, ";\n";
 518                                                 $modified = 1;
 519                                         }
 520                                         elsif ($outslots == 2) {
 521                                                 code "\tstack[0].type = TYPE_VOID;\n";
 522                                                 code "\tstack[-1].type = ", $cacaotypes{$outtype}, ";\n";
 523                                                 $modified = 1;
 524                                         }
 525                                 }
 526                         }
 527                 }
 528         }
 529
 530         return $modified;
 531 }
 532
 533 sub write_icmd_cases
 534 {
 535         my ($icmd, $traits, $condition, $done) = @_;
 536
 537         code "case ", $icmd->{FULLNAME}, ":\n";
 538
 539         my $eqgroup = $icmdtraits{$icmd->{$traits}};
 540         my @actions = ($icmd->{ACTION});
 541
 542         for my $ocmd (@$eqgroup) {
 543                 next unless $condition->($ocmd);
 544                 if ($ocmd->{FULLNAME} ne $icmd->{FULLNAME}) {
 545                         code "case ", $ocmd->{FULLNAME}, ":\n";
 546                         $done->{$ocmd->{FULLNAME}}++;
 547
 548                         unless (grep { $_ eq $ocmd->{ACTION} } @actions) {
 549                                 push @actions, $ocmd->{ACTION};
 550                         }
 551                 }
 552         }
 553
 554         code "\t/* ", join(", ", map { "($_)" } @actions), " */\n";
 555 }
 556
 557 sub write_icmd_set_props
 558 {
 559         my ($icmd) = @_;
 560
 561         if ($icmd->{MAYTHROW}) {
 562                 code "\tmaythrow = true;\n";
 563         }
 564         if ($superblockend{$icmd->{CONTROLFLOW}}) {
 565                 code "\tsuperblockend = true;\n";
 566         }
 567 }
 568
 569 sub write_trailer
 570 {
 571         my ($file) = @_;
 572
 573         print $file "\n#undef GENERATED\n";
 574         print $file "/* vim:filetype=c:\n";
 575         print $file " */\n";
 576 }
 577
 578 sub get_dst_slots_and_ctype
 579 {
 580         my ($icmd, $op1) = @_;
 581
 582         my $inslots;
 583         my $type;
 584         for my $v (@{$icmd->{VARIANTS}}) {
 585                 my $intype = $v->{IN}->[0];
 586                 if (defined($inslots) && $inslots != $slots{$intype}) {
 587                         die "$0: error: mixed slotsize for STORE is not supported: ".$icmd->{NAME};
 588                 }
 589                 else {
 590                         $inslots = $slots{$intype};
 591                 }
 592
 593                 if (defined($type) && $type ne $cacaotypes{$intype}) {
 594                         $type = "$op1->type";
 595                 }
 596                 else {
 597                         $type = $cacaotypes{$intype};
 598                 }
 599         }
 600
 601         return ($inslots, $type);
 602 }
 603
 604 sub write_verify_stackbased_code
 605 {
 606         my ($file) = @_;
 607
 608         my %done;
 609
 610         $codefile = $file;
 611         $codeline = 1;
 612         my $codefilename = $TYPECHECK_STACKBASED_INC;
 613
 614         print $file "#define GENERATED\n";
 615         $codeline++;
 616
 617         my $condition = sub { $_[0]->{STAGE} ne '--' and $_[0]->{STAGE} ne 'S+' };
 618
 619         for my $icmdname (@icmds) {
 620                 my $icmd = $icmds{$icmdname};
 621
 622                 next if $done{$icmdname};
 623                 next unless $condition->($icmd);
 624
 625                 $done{$icmdname}++;
 626
 627                 my $outslots = $icmd->{OUTSLOTS};
 628                 my $inslots = $icmd->{INSLOTS};
 629                 my $outtype = $icmd->{BASICOUTTYPE};
 630                 my $stackchange = $icmd->{STACKCHANGE};
 631
 632                 my @macros;
 633
 634                 ### start instruction case, group instructions with same code
 635
 636                 code "\n";
 637                 write_icmd_cases($icmd, 'STACKBASED', $condition, \%done);
 638
 639                 ### instruction properties
 640
 641                 write_icmd_set_props($icmd);
 642
 643                 ### check stackdepth and stack types
 644
 645                 if (defined($inslots) && $inslots > 0) {
 646                         code "\tCHECK_STACK_DEPTH($inslots);\n";
 647                 }
 648                 elsif (!defined($inslots)) {
 649                         code "\t/* variable number of inslots! */\n";
 650                 }
 651
 652                 if (defined($stackchange) && $stackchange > 0) {
 653                         code "\tCHECK_STACK_SPACE(", $stackchange, ");\n";
 654                 }
 655                 elsif (!defined($outslots)) {
 656                         code "\t/* variable number of outslots! */\n";
 657                 }
 658
 659                 if (defined($inslots) && defined($outslots) && defined($icmd->{VARIANTS})
 660                                 && scalar @{$icmd->{VARIANTS}} == 1)
 661                 {
 662                         my $var = $icmd->{VARIANTS}->[0];
 663
 664                         my $depth = 1 - $inslots;
 665                         my $opindex = 1;
 666                         for my $in (@{$var->{IN}}) {
 667                                 my $ctype = $cacaotypes{$in};
 668                                 my $slots = $slots{$in};
 669                                 if (defined($ctype)) {
 670                                         code "\tCHECK_STACK_TYPE(stack[$depth], $ctype);\n";
 671                                         $depth += $slots;
 672                                         $opindex++;
 673                                 }
 674                         }
 675                 }
 676
 677                 ###     check/store local types
 678
 679                 my $prohibit_stackchange = 0;
 680
 681                 if ($icmd->{DATAFLOW} eq 'LOAD') {
 682                         code "\tCHECK_LOCAL_TYPE(IPTR->s1.varindex, ".$cacaotypes{$outtype}.");\n";
 683                         if ($icmd->{VERIFYCODE}) {
 684                                 code "#\tdefine OP1 LOCAL_SLOT(IPTR->s1.varindex)\n";
 685                                 push @macros, 'OP1';
 686                         }
 687                 }
 688                 elsif ($icmd->{DATAFLOW} eq 'IINC') {
 689                         code "\tCHECK_LOCAL_TYPE(IPTR->s1.varindex, TYPE_INT);\n";
 690                 }
 691                 elsif ($icmd->{DATAFLOW} eq 'STORE') {
 692                         my ($inslots, $type) = get_dst_slots_and_ctype($icmd, 'OP1');
 693                         if ($type =~ /OP1/) {
 694                                 code "#\tdefine OP1 (&(stack[".(1-$inslots)."]))\n";
 695                                 push @macros, 'OP1';
 696                                 $prohibit_stackchange = 1;
 697                         }
 698                         if ($inslots == 2) {
 699                                 code "\tSTORE_LOCAL_2_WORD(".$type.", IPTR->dst.varindex);\n";
 700                         }
 701                         else {
 702                                 code "\tSTORE_LOCAL(".$type.", IPTR->dst.varindex);\n";
 703                         }
 704                         if ($icmd->{VERIFYCODE}) {
 705                                 code "#\tdefine DST LOCAL_SLOT(IPTR->dst.varindex)\n";
 706                                 push @macros, 'DST';
 707                         }
 708                 }
 709
 710                 ### custom verification code
 711
 712                 my $stackdone = 0;
 713
 714                 if ($icmd->{VERIFYCODE}) {
 715                         if ($icmd->{VERIFYCODEPROPS}->{RESULTNOW}) {
 716                                 if ($prohibit_stackchange) {
 717                                         die "$0: prohibited stack change before custom code: ".$icmd->{NAME};
 718                                 }
 719                                 if (write_verify_stackbased_stackchange($icmd)) {
 720                                         code "\t/* CAUTION: stack types changed before custom code! */\n";
 721                                 }
 722                                 if ($stackchange) {
 723                                         code "\t/* CAUTION: stack pointer changed before custom code! */\n";
 724                                 }
 725                                 $stackdone = 1;
 726                         }
 727
 728                         if (defined($inslots) && defined($outslots) && defined($icmd->{VARIANTS})
 729                                         && scalar @{$icmd->{VARIANTS}} == 1)
 730                         {
 731                                 my $var = $icmd->{VARIANTS}->[0];
 732
 733                                 my $depth = 1 - $inslots;
 734                                 $depth -= $stackchange if $stackdone;
 735                                 my $opindex = 1;
 736                                 for my $in (@{$var->{IN}}) {
 737                                         my $ctype = $cacaotypes{$in};
 738                                         my $slots = $slots{$in};
 739                                         if (defined($ctype)) {
 740                                                 code "#\tdefine OP$opindex (&(stack[$depth]))\n";
 741                                                 push @macros, "OP$opindex";
 742                                                 $depth += $slots;
 743                                                 $opindex++;
 744                                         }
 745                                 }
 746
 747                                 $depth = 1 - $inslots;
 748                                 $depth -= $stackchange if $stackdone;
 749                                 if ($outslots > 0) {
 750                                         code "#\tdefine DST  (&(stack[$depth]))\n";
 751                                         push @macros, "DST";
 752                                 }
 753                         }
 754
 755                         if (defined($inslots) && defined($outslots)) {
 756                                 my $min = 1 - $inslots;
 757                                 my $max = $outslots - $inslots;
 758                                 $max = 0 if ($max < 0);
 759                                 if ($stackdone) {
 760                                         $min -= $stackchange;
 761                                         $max -= $stackchange;
 762                                 }
 763                                 if ($min <= $max) {
 764                                         code "\t/* may use stack[$min] ... stack[$max] */\n";
 765                                 }
 766                         }
 767
 768                         code "\n";
 769                         code "#\tline ".$icmd->{VERIFYCODELINE}." \"".$icmd->{VERIFYCODEFILE}."\"\n";
 770                         code $_ for @{$icmd->{VERIFYCODE}};
 771                         code "#\tline ", $codeline+2, " \"", $codefilename, "\"\n";
 772                         code "\n";
 773                 }
 774
 775                 ### stack manipulation code
 776
 777                 if (!defined($icmd->{GOTOLABEL})) {
 778
 779                         unless ($stackdone) {
 780                                 write_verify_stackbased_stackchange($icmd);
 781                         }
 782
 783                         code "\tbreak;\n";
 784                 }
 785                 else {
 786                         code "\tgoto ", $icmd->{GOTOLABEL}, ";\n";
 787                 }
 788
 789                 ### undef macros that were defined above
 790
 791                 if (@macros) {
 792                         code "\n";
 793                         code "#\tundef $_\n" for @macros;
 794                 }
 795                 code "\n";
 796         }
 797
 798         write_trailer($file);
 799 }
 800
 801 sub write_verify_variablesbased_code
 802 {
 803         my ($file,$select,$codefilename) = @_;
 804
 805         my %done;
 806
 807         $codefile = $file;
 808         $codeline = 1;
 809
 810         print $file "#define GENERATED\n";
 811         $codeline++;
 812
 813         my $condition = sub { $_[0]->{STAGE} ne '--' and $_[0]->{STAGE} ne '-S' };
 814
 815         my $model_basic_types = 1;
 816         my $check_basic_types = $opt_debug;
 817         my $model_basic_local_types = $model_basic_types;
 818         my $check_basic_local_types = ($select ne 'TYPEINFERER') || $opt_debug;
 819
 820         for my $icmdname (@icmds) {
 821                 my $icmd = $icmds{$icmdname};
 822
 823                 next if $done{$icmdname};
 824                 next unless $condition->($icmd);
 825
 826                 $done{$icmdname}++;
 827
 828                 my $outvars = $icmd->{OUTVARS};
 829                 my $invars = $icmd->{INVARS};
 830                 my $outtype = $icmd->{BASICOUTTYPE};
 831
 832                 my @macros;
 833
 834                 ### start instruction case, group instructions with same code
 835
 836                 code "\n";
 837
 838                 write_icmd_cases($icmd, $select, $condition, \%done);
 839
 840                 ### instruction properties
 841
 842                 write_icmd_set_props($icmd);
 843
 844                 ### check basic types (only in --debug mode)
 845
 846                 if ($check_basic_types) {
 847                         if (scalar(@{$icmd->{VARIANTS}}) == 1 && defined($invars)) {
 848                            my $intypes = $icmd->{VARIANTS}->[0]->{IN};
 849                            if ($invars >= 1 && defined($cacaotypes{$intypes->[0]})) {
 850                                    code "\tif (VAROP(IPTR->s1)->type != ".$cacaotypes{$intypes->[0]}.")\n";
 851                                    code "\t\tVERIFY_ERROR(\"basic type mismatch\");\n";
 852                            }
 853                            if ($invars >= 2 && defined($cacaotypes{$intypes->[1]})) {
 854                                    code "\tif (VAROP(IPTR->sx.s23.s2)->type != ".$cacaotypes{$intypes->[1]}.")\n";
 855                                    code "\t\tVERIFY_ERROR(\"basic type mismatch\");\n";
 856                            }
 857                            if ($invars >= 3 && defined($cacaotypes{$intypes->[2]})) {
 858                                    code "\tif (VAROP(IPTR->sx.s23.s3)->type != ".$cacaotypes{$intypes->[2]}.")\n";
 859                                    code "\t\tVERIFY_ERROR(\"basic type mismatch\");\n";
 860                            }
 861                         }
 862                 }
 863
 864                 ###     check local types
 865
 866                 if ($check_basic_local_types) {
 867                         if ($icmd->{DATAFLOW} eq 'LOAD') {
 868                                 code "\tCHECK_LOCAL_TYPE(IPTR->s1.varindex, ".$cacaotypes{$outtype}.");\n";
 869                         }
 870                         elsif ($icmd->{DATAFLOW} eq 'IINC') {
 871                                 code "\tCHECK_LOCAL_TYPE(IPTR->s1.varindex, TYPE_INT);\n";
 872                         }
 873                 }
 874
 875                 ### store local types
 876
 877                 if ($model_basic_local_types) {
 878                         if ($icmd->{DATAFLOW} eq 'STORE') {
 879                                 my ($inslots, $type) = get_dst_slots_and_ctype($icmd, 'VAROP(iptr->s1)');
 880                                 if ($inslots == 2) {
 881                                         code "\tSTORE_LOCAL_2_WORD(".$type.", IPTR->dst.varindex);\n";
 882                                 }
 883                                 else {
 884                                         code "\tSTORE_LOCAL(".$type.", IPTR->dst.varindex);\n";
 885                                 }
 886                         }
 887                 }
 888
 889                 ### custom verification code
 890
 891                 my $resultdone = 0;
 892
 893                 if ($icmd->{VERIFYCODE}) {
 894                         # set OP1/DST for local variables
 895
 896                         if ($icmd->{DATAFLOW} eq 'LOAD') {
 897                                 code "#\tdefine OP1  VAROP(IPTR->s1)\n";
 898                                 push @macros, 'OP1';
 899                         }
 900                         elsif ($icmd->{DATAFLOW} eq 'STORE') {
 901                                 code "#\tdefine DST  VAROP(IPTR->dst)\n";
 902                                 push @macros, 'DST';
 903                         }
 904
 905                         # model stack-action, if RESULTNOW tag was used
 906
 907                         if ($icmd->{VERIFYCODEPROPS}->{RESULTNOW}) {
 908                                 if ($model_basic_types
 909                                         && defined($outtype) && defined($outvars) && $outvars == 1)
 910                                 {
 911                                         code "\tVAROP(iptr->dst)->type = ", $cacaotypes{$outtype}, ";\n";
 912                                 }
 913                                 $resultdone = 1;
 914                         }
 915
 916                         # define OP1/DST for stack variables
 917
 918                         if (defined($invars) && $invars >= 1) {
 919                                 code "#\tdefine OP1  VAROP(iptr->s1)\n";
 920                                 push @macros, 'OP1';
 921                         }
 922
 923                         if (defined($outvars) && $outvars == 1) {
 924                                 code "#\tdefine DST  VAROP(iptr->dst)\n";
 925                                 push @macros, 'DST';
 926                         }
 927
 928                         # insert the custom code
 929
 930                         code "\n";
 931                         code "#\tline ".$icmd->{VERIFYCODELINE}." \"".$icmd->{VERIFYCODEFILE}."\"\n";
 932                         code $_ for @{$icmd->{VERIFYCODE}};
 933                         code "#\tline ", $codeline+2, " \"", $codefilename, "\"\n";
 934                         code "\n";
 935                 }
 936
 937                 ### result code
 938
 939                 if (!defined($icmd->{GOTOLABEL})) {
 940
 941                         unless ($resultdone) {
 942                                 if ($model_basic_types
 943                                         && defined($outtype) && defined($outvars) && $outvars == 1)
 944                                 {
 945                                         code "\tVAROP(iptr->dst)->type = ", $cacaotypes{$outtype}, ";\n";
 946                                 }
 947                         }
 948
 949                         code "\tbreak;\n";
 950                 }
 951                 else {
 952                         code "\tgoto ", $icmd->{GOTOLABEL}, ";\n";
 953                 }
 954
 955                 ### undef macros that were defined above
 956
 957                 if (@macros) {
 958                         code "\n";
 959                         code "#\tundef $_\n" for @macros;
 960                 }
 961                 code "\n";
 962         }
 963
 964         write_trailer($file);
 965 }
 966
 967 sub write_icmd_table
 968 {
 969         my ($file) = @_;
 970
 971         for my $icmdname (@icmds) {
 972                 my $icmd = $icmds{$icmdname};
 973
 974                 printf $file "/*%3d*/ {", $icmd->{OPCODE};
 975                 print $file 'N("', $icmd->{NAME_FILLED}, '") ';
 976                 defined($icmd->{DATAFLOW}) or print STDERR "$0: warning: undefined data-flow: $icmdname\n";
 977                 printf $file "DF_%-7s", $icmd->{DATAFLOW} || '0_TO_0';
 978                 print $file ", ";
 979                 printf $file "CF_%-6s", $icmd->{CONTROLFLOW} || 'NORMAL';
 980                 print $file ", ";
 981
 982                 my $flags = $icmd->{FLAGS_FILLED};
 983                 print $file $flags;
 984
 985                 print $file " /* ";
 986
 987                 my $stage = $icmd->{STAGE} || '  ';
 988                 print $file $stage;
 989                 print $file ' ';
 990
 991                 print $file "", $icmd->{ACTION_FILLED}, "";
 992
 993                 print $file " */}";
 994                 print $file "," unless $icmdname eq $icmds[-1];
 995                 print $file "\n";
 996         }
 997
 998         print $file "\n";
 999 }
1000
1001 sub parse_icmd_table
1002 {
1003         my ($filename) = (@_);
1004         my $file;
1005
1006         $file = IO::File->new($filename) or die "$0: could not open file: $filename: $!\n";
1007
1008         while (<$file>) {
1009                 next if /^\s*$/;
1010
1011                 my $line = $_;
1012
1013                 # check if it looks like a table line
1014
1015                 next unless /^ \s* \/\* \s* (\d+) \s* \*\/ \s* (.*) $/x;
1016                 my ($opc) = ($1);
1017                 $_ = $2;
1018
1019                 # look at this monster! ;)
1020
1021                 if (/^      \{ \s* N\( \s* \" (\w+) \s* \" \)  # ICMD name --> $1
1022                            \s*  DF_(\w+) \s* ,                     # data-flow --> $2
1023                            \s*  CF_(\w+) \s* ,                     # control flow --> $3
1024                            \s*  ([^\/]*?)                          # the rest (flags) --> $4
1025                            \s*  \/\* \s* (\S+)?                    # stage --> $5
1026                          \s* \( ([^)]*) \)             # stack action --> $6
1027                                                  \s*
1028                                         \*\/
1029                            \s*  \} \s* ,?                          # closing brace and comma
1030                            \s*  (\/\* .* \*\/)?                    # optional comment
1031                            \s*  $/x)
1032                 {
1033                         my ($name, $df, $cf, $rest, $stage, $action) = ($1,$2,$3,$4,$5,$6);
1034
1035                         my $fn = 'ICMD_' . $name;
1036                         push @icmds, $fn;
1037
1038                         my $icmd = {
1039                                 FULLNAME => $fn,
1040                                 NAME => $name,
1041                                 OPCODE => $opc,
1042                                 DATAFLOW => $df,
1043                                 CONTROLFLOW => $cf,
1044                                 ACTION => $action,
1045                         };
1046
1047                         if ($stage) {
1048                                 $validstages{$stage} || die "$0: invalid stage: $filename:$.: $stage\n";
1049                                 $icmd->{STAGE} = $stage;
1050                         }
1051
1052                         my @flags = split /\s*\|\s*/, $rest;
1053
1054                         for my $f (@flags) {
1055                                 $icmd->{MAYTHROW} = 1 if $f eq 'PEI';
1056                                 $icmd->{CALLS} = $f if $f =~ /^(.*_)?CALLS$/;
1057                         }
1058
1059                         $icmds{$fn} = $icmd;
1060                 }
1061                 else {
1062                         die "$0: invalid ICMD table line: $filename:$.: $line";
1063                 }
1064         }
1065
1066         close $file;
1067 }
1068
1069 #################### main program
1070
1071 parse_icmd_table($opt_icmdtable);
1072
1073 if ($opt_stack) {
1074         parse_verify_code($VERIFY_C, 'STACKBASED');
1075         post_process_icmds();
1076
1077         my $outfile = IO::File->new(">$TYPECHECK_STACKBASED_INC")
1078                         or die "$0: could not create: $TYPECHECK_STACKBASED_INC";
1079         write_verify_stackbased_code($outfile);
1080         close $outfile;
1081 }
1082 elsif ($opt_variables) {
1083         parse_verify_code($VERIFY_C, 'VARIABLESBASED');
1084         post_process_icmds();
1085
1086         my $outfile = IO::File->new(">$TYPECHECK_VARIABLESBASED_INC")
1087                         or die "$0: could not create: $TYPECHECK_VARIABLESBASED_INC";
1088         write_verify_variablesbased_code($outfile, 'VARIABLESBASED',
1089                                                                          $TYPECHECK_VARIABLESBASED_INC);
1090         close $outfile;
1091 }
1092 elsif ($opt_typeinferer) {
1093         parse_verify_code($VERIFY_C, 'TYPEINFERER');
1094         post_process_icmds();
1095
1096         my $outfile = IO::File->new(">$TYPECHECK_TYPEINFERER_INC")
1097                         or die "$0: could not create: $TYPECHECK_TYPEINFERER_INC";
1098         write_verify_variablesbased_code($outfile, 'TYPEINFERER',
1099                                                                          $TYPECHECK_TYPEINFERER_INC);
1100         close $outfile;
1101 }
1102 elsif ($opt_table) {
1103         post_process_icmds();
1104         write_icmd_table(\*STDOUT);
1105 }
1106