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