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.

$::VERSION="0.1 GNU-compatible";

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");

my @originalArgv;

our @cppDefines = ();
our @cppIncludeDirs = ();
our @cppIncludes = ();
our @cppUndefines = ();
our @stdlib = ();

my $spec = q(#
      [strict]
      -c			Compile and assemble, but do not link.
      -shared			Compile and assemble into a single object file (for
				faster loading).
      -d			Print debugging information.
      -D <name>[=<definition>]	Predefine <name> as a macro, with definition <definition>.
{ push(@main::cppDefines, defined $definition ? "-D$name=$definition" : "-D$name"); }
      -U <name>			Undefine <name> as a macro.
{ push(@main::cppUndefines, "-U$name"); }
      -E			Preprocess only.
      -I <dir>			Look for headers in <dir>.
{ push(@main::cppIncludeDirs, '-I', $dir); }
      -include <file>		Add header to file during preprocessing.
{ push(@main::cppIncludes, '-include', $file); }
      -L <dir>			Look for shared libraries in <dir>.
      -s			Do not link against the standard library.
      -o <file>			Place the output into <file>.
      -l<lib>			Link semantics against native-compiled so file
{ push (@main::stdlib, $lib) }
      <files>...		C files to be compiled. [required] [repeatable]
      -fnative-libc			Link semantics against native C library.
      --help				Show usage information [undocumented]
                        { $self->usage(0); }
      -v				Show version information [undocumented]
                                { $self->version(0); }

      -O[<level:/0|1|2|3|s/>]	Ignored
      -std <standard>		Ignored
      -x <language>		Ignored
      -pedantic			Ignored
      -Wall			Ignored
      -rpath <file>		Ignored
      -soname <file>		Ignored

      -Xmx<size>		Passed to underlying JVM
                  
      The following lines of output are added to this message for compatibility
      with GNU ld and libtool:

      : supported targets: elf
      );

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

exit main();

sub main {
     @originalArgv = @ARGV;
     $args->parse() or die "Failed to parse the command line.\n";

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

     my $heapSize = "2G";
     if ($args->{'-Xmx'}) {
          $heapSize = $args->{'-Xmx'};
     }
     # Set heap and stack size of krun
     $ENV{K_OPTS} = "-Xms64m -Xmx$heapSize -Xss32m -XX:+TieredCompilation";

     if ($args->{'-E'}) {
          my $oval = $args->{'-o'};
          if ($oval) {
            if (scalar @{$args->{'<files>'}} > 1) {
              die "cannot specify -o with -c or -E with multiple files";
            }
          } else {
            $oval = '-';
          }
          return preprocess($oval, @{$args->{'<files>'}});
     }

     if ($args->{'-c'}) {
          my $oval = $args->{'-o'};
          if ($oval) {
            if (scalar @{$args->{'<files>'}} > 1) {
              die "cannot specify -o with -c or -E with multiple files";
            }
          } else {
            $oval = basename($args->{'<files>'}[0], ".c") . ".o";
          }
          compile($oval, @{$args->{'<files>'}});
          return 0;
     }

     if ($args->{'-shared'}) {
          classify(@{$args->{'<files>'}});
          mergeObjs(1, 0);
          move($objFiles[0], $args->{'-o'} || 'a.out');
          return 0;
     }

     if ($args->{'-s'}) {
          classify(@{$args->{'<files>'}});
     } else {
          classify(@{$args->{'<files>'}}, catfile($myDirectory, 'lib', 'libc.so'));
     }

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

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

     my $programConfFile = tempFile(); 

     # 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 $retval = execute('krun', getKRunCommand($programConfFile, $objFiles[0], $objFiles[1], $srcFiles[0], 1));
     checkError($retval);

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

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

     $template =~ s?EXTERN_SCRIPTS_DIR?$myDirectory?g;

     open(my $programRunner, '>', $oval) or die "Couldn't open file: $!\n";
     print $programRunner "$template\n";
     print $programRunner "sub linkedProgram {\nreturn <<'PROGRAMCONF';\n$programConf\nPROGRAMCONF\n}\n";
     if (@stdlib && $args->{'-fnative-libc'}) {
           print $programRunner "sub nativeLibraries {\n return '@stdlib';\n}\n";
     } else {
           print $programRunner "sub nativeLibraries {\n return undef;\n}\n";
     }
     close($programRunner);

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

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

     return 0;
}

sub mergeObjs {
     my ($numObj, $numSrc) = (@_);

     my @pids = ();

     while (scalar @srcFiles > $numSrc) {
          my $oval = tempFile();
          compile($oval, shift @srcFiles);
          push(@objFiles, $oval);
     }

     while (scalar @objFiles + scalar @pids > $numObj) {
          my $obj1 = shift @objFiles;
          my $obj2 = shift @objFiles;

          my $accum = tempFile();
          my $pid = fork();
          if (!defined $pid) {
            die "Error running process";
          }
          if (!$pid) {
            my @cmd = getKRunCommand($accum, $obj1, $obj2, undef, 0);
            if ($args->{'-d'}) {
              print("krun '" . join("' '", @cmd) . "'\n");
            }
            exec('krun', @cmd);
          }
          my %data = (
            'pid' => $pid,
            'out' => $accum,
          );
          push(@pids, \%data);

          if (scalar @pids >= 4 || scalar @objFiles == 0) {
            # finished a round, wait for results
            while (scalar @pids > 0) {
              my %data = %{shift @pids};
              push(@objFiles, $data{'out'});
              waitpid $data{'pid'}, 0;

              checkError($? >> 8);
            }
          }
     }
}

sub classify {
     my @files = @_;

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

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

     }
}

sub extractStatic {
  my ($file, $basename, $suffix) = (@_);
  -e $file or die "$file does not exist";
  my $tempDir = File::Temp->newdir(
      TEMPLATE => 'tmp-kcc-ar-XXXX',
      CLEANUP => 0);
  push (@tempFiles, $tempDir);
  copy ($file, $tempDir);
  system("cd $tempDir && ar -x $basename$suffix");
  if ($? >> 8) {
    die "failed to run ar -x";
  }
  opendir my $dir, $tempDir or die "Cannot open directory: $tempDir";
  my @files = readdir $dir;
  closedir $dir;
  for (@files) {
    if ($_ ne "$basename$suffix") {
      push(@objFiles, "$tempDir/$_");
    }
  }
}

sub compile {
     my ($oval, $inputFile) = (@_);
     my $retval = execute('krun', getKRunCommand($oval, undef, undef, $inputFile, 0));
     checkError($retval);
}

sub getKRunCommand {
     my ($output, $obj1, $obj2, $src, $link) = (@_);

     my @krun_args = (
          '--output', 'binary', 
          '--output-file', $output,
          '-d', $TRANS_DEF,
          '-w', 'none',
          '--pattern-matching',
          '--exit-code',
          '<result-value> _:Int </result-value>'
     );

     if ($args->{'-d'}) {
          push(@krun_args, '--debug');
     }

     if ($link) {
          push(@krun_args, '-cOPTIONS=.Set');
     } else {
          push(@krun_args, '-cOPTIONS=SetItem(NOLINK)');
     }

     if (defined $obj1) {
          push(@krun_args, '-pOBJ1=kast --parser binary');
          push(@krun_args, "-cOBJ1=$obj1");
     } else {
          push(@krun_args, '-cOBJ1=.Bag');
     }
     if (defined $obj2) {
          push(@krun_args, '-pOBJ2=kast --parser binary');
          push(@krun_args, "-cOBJ2=$obj2");
     } else {
          push(@krun_args, '-cOBJ2=.Bag');
     }
     if (defined $src) {
          my $kast = parse($src);
          push(@krun_args, '--parser', 'cat');
          push(@krun_args, $kast);
     } else {
          push(@krun_args, '-cPGM=.K');
     }

     if ($args->{'-fnative-libc'} && scalar @stdlib) {
          push(@krun_args, '--native-libraries');
          push(@krun_args, "@stdlib");
     }

     return @krun_args;
}

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

     my $directoryname = dirname($inputFile);
     system("which gcc-4.9 > /dev/null 2>&1");
     my $pp;
     if ($? >> 8 == 0) {
          $pp = "gcc-4.9";
     } else {
          # no gcc, try clang
          $pp = "clang";
     }
     my @ppArgs = ($pp, "-Wall", "-Wextra", "-Werror", "-Wmissing-prototypes",
                   "-pedantic", "-x", "c", "-std=c11", "-nostdlib",
                   "-U", "__GNUC__", "-include", "$myDirectory/includes/kcc_settings.h",
                   @main::cppDefines, @main::cppUndefines, @main::cppIncludeDirs,
                   @main::cppIncludes, '-E', '-iquote', '.', '-iquote', $directoryname,
                   '-I', "$myDirectory/includes", $inputFile, '-o', $output);

     my $retval = execute(@ppArgs);
     return $retval;
}

sub execute {
    my @cmd = @_;
    if ($args->{'-d'}) {
      print("'" . join("' '", @cmd) . "'\n");
    }
    my $pgm = shift @cmd;
    system($pgm, @cmd);
    return $? >> 8;
}

sub tempFile {
     my $file = File::Temp->new( 
                TEMPLATE => 'tmp-kcc-XXXXXXX', 
                UNLINK => 0 );
     push(@tempFiles, $file);
     return $file;
}

sub parse {
     my ($inputFile) = (@_);

     my $ppResult = tempFile();
     my $kast = tempFile();
     checkError(preprocess($ppResult, $inputFile));

     my $cmd = ("$cparser $ppResult --trueName '$inputFile' | $xmlToK > $kast");
     if ($args->{'-d'}) {
       print("$cmd\n");
     }
     system($cmd);
     checkError($? >> 8);

     return $kast;
}

sub checkError {
  my ($retval) = (@_);
  if ($retval) {
    if ($args->{'-d'}) {
      print STDERR "Translation failed. Refer to last command run for details.\n";
      exit $retval;
    } else {
      print STDERR "Translation failed. Run kcc -d @originalArgv to see commands run.\n";
      exit $retval;
    }
  }
}

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 {
     if (!$args->{'-d'}) {
          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;
}