kcc

#!/usr/bin/env perl
use strict;
use warnings;

use File::Basename;
use File::Temp;
use File::Spec::Functions qw(rel2abs catfile);
use File::Copy;
use Getopt::Declare;
use MIME::Base64;
use IO::Compress::Gzip qw(gzip $GzipError) ;

# Here we trap control-c (and others) so we can clean up when that happens.
$SIG{'ABRT'} = 'interruptHandler';
$SIG{'TERM'} = 'interruptHandler';
$SIG{'QUIT'} = 'interruptHandler';
$SIG{'SEGV'} = 'interruptHandler';
$SIG{'HUP' } = 'interruptHandler';
$SIG{'TRAP'} = 'interruptHandler';
$SIG{'STOP'} = 'interruptHandler';
$SIG{'INT'} = 'interruptHandler'; # Handle control-c.

# Set heap size of krun
$ENV{K_OPTS} = '-Xmx2048m';

$::VERSION="0.1";

my $KRUN = "krun";

my @objFiles = ();
my @srcFiles = ();
my @tempFiles = ();

my $myDirectory = dirname(rel2abs($0));
my $xmlToK = catfile($myDirectory, 'xml-to-k');
my $cparser = catfile($myDirectory, 'cparser');

my $TRANS_DEF =
      catfile($myDirectory, "c11-translation-kompiled");

our @cppDefines = ();
our @cppIncludeDirs = ();

my $spec = q(#
      -c			Compile and assemble, but do not link.
      -clib			Compile and assemble into a single object file (for
				faster loading).
      #-i				Include support for runtime file io.
      -d			Keep intermediate files.
      -D <name>[=<definition>]	Predefine <name> as a macro, with definition <definition>.
{ push(@main::cppDefines, " -D$name=\"" . ((defined $definition) ? "$definition" : "1") . "\" "); }
      -I <dir>			Look for headers in <dir>.
{ push(@main::cppIncludeDirs, " -I$dir "); }
      -s			Do not link against the standard library.
      -o <file>			Place the output into <file>.
      #-verbose			Do not delete intermediate files.
      -w			Do not print warning messages.
      <files>...		C files to be compiled. [required]
      #-funsigned-char			Let the type "char" be unsigned, like "unsigned char."
      #-fsigned-char			Let the type "char" be signed, like "signed char."
      #-fbits-per-byte <num>		Sets the number of bits in a byte.
      #[mutex: -funsigned-char -fsigned-char]
      -lm			Ignored
      -O[<level:/0|1|2|3|s/>]	Ignored
      -std <standard>		Ignored
      -x <language>		Ignored
      -pedantic			Ignored
      -Wall			Ignored
                  
      There are additional options available at runtime. Try running your compiled
      program with HELP set (e.g., HELP=1 ./a.out) to see these.
      );

my $args = Getopt::Declare->new($spec, ['-BUILD']);

exit main();

sub main {
     my @stdlib = ();
     push(@stdlib, catfile($myDirectory, 'lib', 'libc.o'));

     $args->parse() or die "Failed to parse the command line.\n";

     if ($args->{'-c'}) {
          for (@{$args->{'<files>'}}) {
               compile($_);
          }

          if ($args->{'-o'}) {
               move($objFiles[0], $args->{'-o'}) 
                    or die "Failed to move the generated program to its destination $args->{'-o'}: $!\n";
          }

          return 0;
     }

     if ($args->{'-clib'}) {
          for (@{$args->{'<files>'}}) {
               compile($_);
          }

          # Reduce our objFiles all the way down to a single one.
          mergeObjs(1);
          move($objFiles[0], $args->{'-o'} || 'a.o');
          return 0;
     }

     # Otherwise, we're compiling an executable.

     # Classify file arguments as either obj files or src files based on
     # extension.
     classify(@{$args->{'<files>'}});

     # Pull off the first source file to leave as source and compile the rest.
     my $unppSourceFile = shift @srcFiles;
     my $sourceFile;

     if (defined $unppSourceFile) {
          $sourceFile = preprocess($args->{'-w'}, $unppSourceFile);
          (-e $sourceFile)
               or die "Parsing failed for $unppSourceFile.\n";
     }

     for (@srcFiles) {
          compile($_);
     }

     if (! $args->{'-s'}) {
          push(@objFiles, @stdlib);
     }

     # Reduce our objFiles down to at most two.
     mergeObjs(2);

     my $oval = $args->{'-o'} || 'a.out';

     my $programRunnerTmp = File::Temp->new( 
               TEMPLATE => 'tmp-kcc-runner-XXXX', 
               SUFFIX => '.pl', 
               UNLINK => 0 );
     push(@tempFiles, $programRunnerTmp);

     my $confOutTmp = File::Temp->new( 
               TEMPLATE => 'tmp-kcc-conf-XXXX', 
               SUFFIX => '.bin', 
               UNLINK => 0 );
     push(@tempFiles, $confOutTmp);

     my $confOutPrettyTmp = File::Temp->new( 
               TEMPLATE => 'tmp-kcc-conf-pretty-XXXX', 
               SUFFIX => '.txt', 
               UNLINK => 0 );
     push(@tempFiles, $confOutPrettyTmp) if (!$args->{'-d'});

     my $linkStdout = File::Temp->new( 
               TEMPLATE => 'tmp-kcc-link-stdout-XXXX', 
               SUFFIX => '.txt', 
               UNLINK => 0 );
     push(@tempFiles, $linkStdout);

     # At this point, we have 0-1 source files and 0-2 object files left for
     # the final call(s) to kcc. Setting up the arguments is kinda difficult
     # because we need to use different parsers if one of the config vars
     # should be empty.

     my @krun_args = (
          '--output="binary"', 
          "--output-file=\"$confOutTmp\"",
          "-d $TRANS_DEF",
          '-cOPTIONS="(.Set)"', 
     );

     my @krun_args_pretty = (
          '--output="pretty"', 
          "--output-file=\"$confOutPrettyTmp\"",
          "-d $TRANS_DEF",
          '-cOPTIONS="(SetItem(DEBUG) .Set)"', 
     );

     my @file_args = ();

     if (scalar @objFiles == 0) {
          push(@file_args, '-cOBJ1=".Bag"');
          push(@file_args, '-cOBJ2=".Bag"');
     } elsif (scalar @objFiles == 1) {
          push(@file_args, '-cOBJ1=".Bag"');
          push(@file_args, '--config-var-parser="kast --parser binary"');
          push(@file_args, "-cOBJ2=\"$objFiles[0]\"");
     } elsif (scalar @objFiles == 2) {
          push(@file_args, '--config-var-parser="kast --parser binary"');
          push(@file_args, "-cOBJ1=\"$objFiles[0]\"");
          push(@file_args, "-cOBJ2=\"$objFiles[1]\"");
     }

     if (defined $sourceFile) {
          push(@file_args, '--parser="cat"');
          push(@file_args, $sourceFile);
     } else {
          push(@file_args, '--config-var-parser="kast --parser ground -e"');
          push(@file_args, '-cPGM=".K"');
     }

     push (@krun_args, @file_args);
     push (@krun_args_pretty, @file_args);

     my $cmd = "$KRUN " . (join ' ', (@krun_args)) . " > $linkStdout 2>&1";
     my $cmd_pretty = "$KRUN " . (join ' ', (@krun_args_pretty)) . " > /dev/null 2>&1";

     print $cmd . "\n" if ($args->{'-d'});
     system($cmd);

     print $cmd_pretty . "\n" if ($args->{'-d'});
     system($cmd_pretty) if ($args->{'-d'});

     open(FILE, catfile($myDirectory, 'program-runner')) or die "Couldn't open file: $!\n";
     my $programRunner = join("", <FILE>);
     close(FILE);

     open(FILE, $confOutTmp) or die "Couldn't open file: $!\n";
     binmode(FILE, ':raw');
     my $programConf = join("", <FILE>);
     close(FILE);

     my $gzippedConf;

     gzip \$programConf => \$gzippedConf
          or die "gzip failed: $GzipError\n";

     $programConf = encode_base64($gzippedConf);

     if ($args->{'-d'}) {
          print "Final configuration saved to $confOutPrettyTmp.\n";
     }
     if (!checkTransSuccess($linkStdout)) {
          print "Error during translation.\n";
          if (!$args->{'-d'}) {
               die "Use \"kcc -d\" to get the final configuration.\n";
          } else {
               die "See the final configuration for details.\n";
          }
     }

     $programRunner = performSpecializations($programRunner);

     print $programRunnerTmp "$programRunner\n";

     print $programRunnerTmp "sub linkedProgram {\nreturn <<'PROGRAMCONF';\n$programConf\nPROGRAMCONF\n}\n";

     close($programRunnerTmp);

     copy("$programRunnerTmp", $oval)
          or die "Failed to move the generated program to its destination $oval: $!\n";

     my $numFilesChanged = chmod(0755, $oval);

     ($numFilesChanged == 1)
          or die "Call to chmod $oval failed\n";

     return 0;
}

sub checkTransSuccess {
     my ($file) = (@_);

     open(OUT, "<$file");

     my $success = 0;
     my $output = "";

     { 
          local $/ = undef;
          $output = <OUT>;
     }

     if ($output =~ /Translation successful!/) {
          return 1;
     } else {
          print $output;
          return 0;
     }
}

sub performSpecializations {
     my ($file) = (@_);

     my $mainFileName = $args->{'<files>'}[0];

     $file =~ s?EXTERN_SCRIPTS_DIR?$myDirectory?g;
     $file =~ s?EXTERN_IDENTIFIER?$mainFileName?g;
     return $file;
}

sub mergeObjs {
     my ($n) = (@_);

     return if (scalar @objFiles < $n);

     my $accum = File::Temp->new( 
          TEMPLATE => 'tmp-kcc-accum-XXXX', 
          SUFFIX => '.o', 
          UNLINK => 0 );
     push(@tempFiles, $accum);

     my $mergeStdout = File::Temp->new( 
          TEMPLATE => 'tmp-kcc-merge-stdout-XXXX', 
          SUFFIX => '.o', 
          UNLINK => 0 );
     push(@tempFiles, $mergeStdout);

     my $objFile = shift @objFiles;

     copy($objFile, $accum);

     unshift(@objFiles, $accum);

     while (scalar @objFiles > $n) {

          my $obj1 = shift @objFiles;
          my $obj2 = shift @objFiles;

          my @krun_args = (
               '--output="binary"',
               "--output-file=\"$obj1\"",
               '-cOPTIONS="(SetItem(NOLINK) .Set)"', 
               '-cPGM=".K"',
               '--config-var-parser="kast --parser binary"',
               "-cOBJ1=\"$obj1\"",
               "-cOBJ2=\"$obj2\"",
               "-d $TRANS_DEF",
               );

          my $cmd = "$KRUN " . (join ' ', (@krun_args)) . " > $mergeStdout 2>&1";

          print $cmd . "\n" if ($args->{'-d'});
          system($cmd);

          if (!checkTransSuccess($mergeStdout)) {
               print "Command line: $cmd\n";
               die "Error merging object files: $obj1, $obj2\n";
          }

          unshift(@objFiles, $obj1);
     }
}

sub classify {
     my @files = @_;

     for (@files) {
          my ($base, $dir, $suffix) = fileparse($_, ('\.c', '\.o', '\.a'));

          if (($suffix eq '.o') or ($suffix eq '.a')) {
               push(@objFiles, $_);
          } else {
               push(@srcFiles, $_);
          }

     }
}

sub compile {
     my ($file) = (@_);
     my $inputFile = rel2abs($file);

     (-e $inputFile)
          or die "kcc: $file: No such file or directory.\n";

     my ($baseName, $inputDirectory, $suffix) = 
          fileparse($inputFile, ('\.c', '\.o', '\.a'));

# Assume it's a normal input file, so compile it.
     my $localOval = "$baseName.o";
     my $localOvalPretty = "$baseName.pretty.o";
     my $ppResult = preprocess($args->{'-w'}, $inputFile);

     (-e $ppResult)
          or die "Parsing failed: expected to find $baseName.c11-translation, but did not.\n";

     my $compileStdout = File::Temp->new( 
          TEMPLATE => 'tmp-kcc-compile-stdout-XXXX', 
          SUFFIX => '.o', 
          UNLINK => 0 );
     push(@tempFiles, $compileStdout);

     my @krun_args = (
          '--output="binary"', 
          "--output-file=\"$localOval\"",
          '-cOPTIONS="(SetItem(NOLINK) .Set)"', 
          '-cOBJ1=".Bag"',
          '-cOBJ2=".Bag"',
          '--parser="cat"', 
          "-d $TRANS_DEF",
          $ppResult
          );

     my @krun_args_pretty = (
          '--output="pretty"', 
          "--output-file=\"$localOvalPretty\"",
          '-cOPTIONS="(SetItem(NOLINK) .Set)"', 
          '-cOBJ1=".Bag"',
          '-cOBJ2=".Bag"',
          '--parser="cat"', 
          "-d $TRANS_DEF",
          $ppResult
          );

     my $cmd = "$KRUN " . (join ' ', (@krun_args)) . " > $compileStdout 2>&1";
     my $cmd_pretty = "$KRUN " . (join ' ', (@krun_args_pretty)) . " > /dev/null 2>&1";

     print $cmd . "\n" if ($args->{'-d'});
     system($cmd);

     print $cmd_pretty . "\n" if ($args->{'-d'});
     system($cmd_pretty) if ($args->{'-d'});

     push(@objFiles, $localOval);
     if (!$args->{'-c'}) {
          push(@tempFiles, $localOval);
     }
     if (!$args->{'-d'}) {
          push(@tempFiles, $localOvalPretty);
     }

     if ($args->{'-d'}) {
          print "Final configuration saved to $localOvalPretty.\n";
     }
     if (!checkTransSuccess($compileStdout)) {
          print "Error during translation: $localOval\n";
          if (!$args->{'-d'}) {
               die "Use \"kcc -d\" to get the final configuration.\n";
          } else {
               die "See the final configuration for details.\n";
          }
     }
}

sub preprocess {
     my ($nowarn, $inputFile) = (@_);

     my $PEDANTRY_OPTIONS = 
          "-Wall -Wextra -Werror -Wmissing-prototypes -pedantic -x c -std=c99";
     my $CPP_OPTIONS = "-CC -std=c99 -nostdlib -nodefaultlibs -U __GNUC__";

     my $compilationLog = File::Temp->new( 
          TEMPLATE => 'tmp-kcc-parsing-XXXX', 
          SUFFIX => '.log', 
          UNLINK => 0 );
     push(@tempFiles, $compilationLog);

     my $trueFilename = $inputFile;
     my ($filename, $directoryname, $suffix) = fileparse($inputFile, '.c');
     my $fullfilename = catfile($directoryname, "$filename.c");
     my $ppResult = "$filename.c11-translation";

     (-e $fullfilename)
          or die "$filename.c not found.";

     my $cppCommand = 
          "gcc $PEDANTRY_OPTIONS $CPP_OPTIONS @main::cppDefines @main::cppIncludeDirs -E -iquote . -iquote $directoryname -I $myDirectory/includes $fullfilename 1> $filename.pre.gen 2> $filename.warnings.log";

     push(@tempFiles, "$filename.warnings.log");
     push(@tempFiles, "$filename.pre.gen");

     my $retval = system($cppCommand);
     open FILE, "$filename.warnings.log";
     my @lines = <FILE>;
     close FILE;

     if ($retval) {
          print STDERR "Error running preprocessor:\n";
          print STDERR join("\n", @lines);
          die "Translation failed.\n"
     }
     if (! $nowarn) {
          print join("\n", @lines);
     }
     $retval = system(
          "$cparser $filename.pre.gen --trueName $trueFilename 2> $filename.warnings.log 1> $filename.gen.parse.tmp");

     open FILE, "$filename.warnings.log";
     @lines = <FILE>;
     close FILE;

     if ($retval) {
          unlink("$filename.gen.parse.tmp");
          print STDERR "Error running C parser:\n";
          print STDERR join("\n", @lines);
          die "Translation failed.\n"
     }
     if (! $nowarn) {
          print join("\n", @lines);
     }
     move("$filename.gen.parse.tmp", "$filename.gen.parse") 
          or die "Failed to move $filename.gen.parse.tmp to $filename.gen.parse: $!\n";

     push(@tempFiles, "$filename.gen.parse");

     $retval = 
          system("cat $filename.gen.parse | $xmlToK 2> $compilationLog 1> $ppResult");

     push(@tempFiles, $ppResult);

     open FILE, "$compilationLog" 
          or die "Could not open $compilationLog.\n";
     @lines = <FILE>;
     close FILE;

     if ($retval) {
          print STDERR "Error compiling program:\n";
          print STDERR join("\n", @lines);
          die "Translation failed.\n"
     }

     return $ppResult;
}

sub printNested {
     my ($name, @rest) = (@_);

     if (defined($name)) {
          return "_`,`,_(($name), " . printNested(@rest) .")";
     } else {
          return '.KList';
     }
}

sub interruptHandler {
# Call single cleanup point.
     finalCleanup();
# Since we were interrupted, we should exit with a non-zero code.
     exit 1;
}

# This subroutine can be used as a way to ensure we clean up all resources
# whenever we exit. This is going to be mostly temp files. If the program
# terminates for almost any reason, this code will be executed.
sub finalCleanup {
     for (@tempFiles) {
          unlink;
     }
}

# This block gets run at the end of a normally terminating program, whether it
# simply exits, or dies. We use this to clean up.
END {
# $? contains the value the program would normally have exited with.
     my $retval = $?;
# Call single cleanup point.
     finalCleanup();
     exit $retval;
}