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