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 String::Escape qw(quote backslash); 
use Getopt::Declare;

# 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 @objFiles = ();
my @srcFiles = ();
my @tempFiles = ();

my $distDirectory = dirname(rel2abs($0));
our $profile;
my $profileDirectory;
{
  local $/=undef;
  open FILE, "$distDirectory/current-profile" or die "Couldn't find current profile: please fix $distDirectory/current-profile";
  $profile = <FILE>;
  $profileDirectory = "$distDirectory/$profile";
  close FILE;
}

our $defaultProfile;
{
  local $/=undef;
  open FILE, "$distDirectory/default-profile" or die "Couldn't find default profile: please fix $distDirectory/default-profile";
  $defaultProfile = <FILE>;
  close FILE;
}

opendir (my $DIR, $distDirectory);
our @profiles = ();
while ( my $entry = readdir $DIR) {
  next unless -d $distDirectory . '/' . $entry;
  next if $entry eq '.' or $entry eq '..' or $entry eq 'licenses';
  push(@profiles, $entry);
}

my $cygwin = $^O eq "cygwin" || $^O eq "msys";
my $quoteString = "\"String\"";
my $quoteInt = "\"Int\"";
if ($cygwin) {
  $distDirectory = `cygpath -w $distDirectory`;
  $profileDirectory = `cygpath -w $profileDirectory`;
  chop($distDirectory);
  chop($profileDirectory);
  $quoteString = backslash($quoteString);
  $quoteInt = backslash($quoteInt);
}

my $krun;
my $printf;
if ($cygwin) {
  $krun = 'krun.bat';
  $printf = 'printf %%s';
} else {
  $krun = 'krun';
  $printf = 'printf %s';
}

my $preprocessor;
{
  local $/=undef;
  open FILE, "$profileDirectory/pp" or die "Couldn't find current profile: please fix $distDirectory/current-profile";
  $preprocessor = <FILE>;
  close FILE;
  chop($preprocessor);
}

our $ourDist = $distDirectory;

my $xmlToK = catfile($distDirectory, 'xml-to-k');
my $cparser = catfile($distDirectory, 'cparser');

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

my @originalArgv;

our @cppArgs = ();
our @stdlib = ();
our @ld_lib = ();

our $oflag;

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::cppArgs, defined $definition ? "-D$name=$definition" : "-D$name"); }
      -U <name>			Undefine <name> as a macro.
{ push(@main::cppArgs, "-U$name"); }
      -E			Preprocess only.
      -I <dir>			Look for headers in <dir>.
{ push(@main::cppArgs, '-I', $dir); }
      -include <file>		Add header to file during preprocessing.
{ push(@main::cppArgs, '-include', $file); }
      -L <dir>			Look for shared libraries in <dir>.
{ push(@main::ld_lib, $dir) }
      -s			Do not link against the standard library.
      -o <file>			Place the output into <file>.
{ $main::oflag = $file; }
      -l <lib>			Link semantics against native-compiled so file
{ push (@main::stdlib, $lib) }
      <files>...		C files to be compiled. [required] [repeatable]
      --help				Show usage information [undocumented]
                        { $self->usage(0); }
      -version				Show version information [undocumented]
{ 
  $self->version(); 
  my $profiles = join("\n	                    ", @main::profiles);
  print("	Current profile: $main::profile\n	Installed profiles: $profiles\n	Default profile: $main::defaultProfile\n\n");
  exit 0;
}
      -Version			[ditto]
      -VERSION			[ditto]
      --version			[ditto]
      --Version			[ditto]
      --VERSION			[ditto]
      -v			[ditto]
      -V			[ditto]

      -MD			Dependency generation. See documentation for GCC preprocessor
{ push(@main::cppArgs, '-MD'); }
      -MP			Dependency generation. See documentation for GCC preprocessor
{ push(@main::cppArgs, '-MP'); }
      -MF <file>		Dependency generation. See documentation for GCC preprocessor
{ push(@main::cppArgs, '-MF', $file); }
      -frunner-script		Compile program to perl script with analysis tool options
      -fissue-report=<file>	Write issues to the specified file in CSV format
      -flint			Generate lint errors for potentially undesirable behaviors.*
      -Wlint			[ditto]
      -fheap-size=<size>	Used with -flint to detect dynamic memory overflow.*
      -frecover-all-errors	Recover from fatal errors that would normally cause an application to crash.

      -O [<level:/0|1|2|3|s/>]	Ignored
      -std=<standard>		Ignored
      -x <language>		Ignored
      -pedantic			Ignored
      -Wall			Ignored
      -rpath=<file>		Ignored
      -soname <file>		Ignored
      -pthread			Enables pthread library (highly experimental, likely broken)
{ push(@main::cppArgs, '-pthread');  push(@main::stdlib, 'pthread'); }

      -Xmx<size>		Passed to underlying JVM
      -profile <name>		Set KCC profile.
{
      if ( grep( /^$name$/, @main::profiles ) ) {
           open(my $file, '>', "$main::ourDist/current-profile") or die "Could not open profile file. Check OS permissions.";
           print $file $name;
           close $file;
           exit 0;
      } else {
           print "Profile '$name' is not installed. See kcc -v for list of installed profiles.\n";
           exit 1;
      }
}
      * Indicates flags that require RV-Match from http://www.runtimeverification.com/match
        to run.
                  
      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";

     my $clib;
     if ($cygwin) {
       $clib = 'msvcrt';
     } else {
       $clib = 'c';
     }

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

     my $heapSize = "1G";
     if ($args->{'-Xmx'}) {
          $heapSize = $args->{'-Xmx'};
     }
     # Set heap and stack size of krun
     $ENV{K_OPTS} = "-Xmx$heapSize";

     if ($args->{'-E'}) {
          my $oval = $main::oflag;
          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 = $main::oflag;
          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";
          }
          my $result = tempFile();
          compile($result, @{$args->{'<files>'}});
          move($result, $oval);
          return 0;
     }

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

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

     # Reduce our source files down to at most one
     mergeObjs(0, 1);

     my $oval = $main::oflag || '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, $srcFiles[0], 1));
     checkError($retval);

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

     if ($args->{'-frunner-script'}) {

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

          $template =~ s?EXTERN_SCRIPTS_DIR?$profileDirectory?g;
          $template =~ s?EXTERN_HEAP_SIZE?$heapSize?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) {
                print $programRunner "sub nativeLibraries {\n return '@stdlib';\n}\n";
          } else {
                print $programRunner "sub nativeLibraries {\n return undef;\n}\n";
          }
          if (@ld_lib) {
                print $programRunner "sub nativeLibraryPath {\n return '@ld_lib';\n}\n";
          } else {
                print $programRunner "sub nativeLibraryPath {\n return undef;\n}\n";
          }
          close($programRunner);

     } else {
          # add space to end of args with () so that batch scripts work on windows
          my @options;
          if ($args->{'-fissue-report='}) {
               my $file = quote(backslash(quote(backslash($args->{'-fissue-report='}))));
               if ($cygwin) {
                    $file = backslash($file);
               }
               push(@options, "`CSV`(#token($file, $quoteString))");
          }
          if ($args->{'-frecover-all-errors'}) {
               push(@options, "`RECOVER_ALL`(.KList)");
          }
          if ($args->{'-flint'}) {
               push(@options, "`LINT`(.KList)");
               my $size;
               if ($args->{'-fheap-size='}) {
                    $size = `echo $args->{'-fheap-size='} | sed -e 's/[Tt]/kg/i;s/[Gg]/km/i;s/[Mm]/kk/i;s/k/*1024/ig' | bc`;
                    chop($size);
               } else {
                    $size = 1024 * 1024 * 1024;
               }
               $size = quote(backslash($size));
               if ($cygwin) {
                    $size = backslash($size);
               }
               push(@options, "`HEAP`(#token($size, $quoteInt))");
          }
          my $opts = makeSet(@options);

          my @cmd = ('-d', catfile($profileDirectory, "c11-kompiled"), 
                  '-cARGV=`#argv`(.KList) ', "-pARGV=$printf",
                  '-w', 'none', '--parser', 'cat', $programConfFile,
                  '--exit-code', "<result-value> _:Int </result-value>",
                  "-cOPTIONS=$opts ", "-pOPTIONS=$printf",
                  '--output-file', $oval, '--ocaml-compile', '--ocaml-dump-exit-code', '139',
                  '--ocaml-serialize-config', '$PGM'
                  );

          if ($args->{'-d'}) {
               push(@cmd, '--debug');
          }
          if (@stdlib) {
            push @cmd, '--native-libraries';
            push @cmd, "@stdlib";
          }
          if (@ld_lib) {
            push @cmd, '--native-library-path';
            push @cmd, "@ld_lib";
          }
          my $retval = execute($krun, @cmd);
          checkError($retval);
     }

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

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

     return 0;
}

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

     my @pids = ();

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

     if ($mergeObjs) {
         my $accum = tempFile();
         my @cmd = getKRunCommand($accum, \@objFiles, undef, 0);
         my $retval = execute($krun, @cmd);
         checkError($retval);
         @objFiles = ($accum);
     }
}

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);
          } elsif ($suffix eq '.c' or $_ eq '-') {
               push(@srcFiles, $_);
          } else {
               die "Unsupported option $_";
          }
     }
}

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 @arr = ();
     my $retval = execute($krun, getKRunCommand($oval, \@arr, $inputFile, 0));
     checkError($retval);
}

sub pushObj {
     my ($arr, $obj, $i) = (@_);

     if (defined $obj) {
          push(@{$_[0]}, "-pOBJ$i=cat");
          push(@{$_[0]}, "-cOBJ$i=$obj");
     } else {
          push(@{$_[0]}, "-pOBJ$i=$printf");
          push(@{$_[0]}, "-cOBJ$i=.K");
     }
}
   

sub getKRunCommand {
     my ($output, $objsRef, $src, $link) = (@_);
     my @objs = @$objsRef;

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

     if ($args->{'-d'}) {
          push(@krun_args, '--debug');
     }
     my @options;
     if (!$link) {
          push(@options, "`NOLINK`(.KList)");
     }
     if ($args->{'-fissue-report='}) {
          my $file = quote(backslash(quote(backslash($args->{'-fissue-report='}))));
          if ($cygwin) {
               $file = backslash($file);
          }
          push(@options, "`CSV`(#token($file, $quoteString))");
     }
     if ($args->{'-flint'}) {
          push(@options, "`LINT`(.KList)");
     }
     if ($args->{'-frecover-all-errors'}) {
          push(@options, "`RECOVER_ALL`(.KList)");
     }

     my $opts = makeSet(@options);
     push(@krun_args, "-cOPTIONS=$opts ");
     push(@krun_args, "-pOPTIONS=$printf");

     if (scalar @objs) {
          my $allObjsFile = tempFile();
          my @catArgs = ();
          my @objTexts = ();
          for (my $i = 0; $i < scalar @objFiles; $i++) {
               my $thisObj = `cat $objFiles[$i]`;
               push(@objTexts, "`unwrapObj`($thisObj)");
          }
          my $objText = join('~>', @objTexts);
          open(my $file, '>', "$allObjsFile");
          print $file $objText;
          close $file;

          push(@krun_args, "-pOBJS=cat");
          push(@krun_args, "-cOBJS=$allObjsFile");
     } else {
          push(@krun_args, "-pOBJS=$printf");
          push(@krun_args, "-cOBJS=.K");
     }
     if (defined $src) {
          my $kast = parse($src);
          push(@krun_args, '--parser', 'cat');
          push(@krun_args, $kast);
     } else {
          push(@krun_args, "-pPGM=$printf");
          push(@krun_args, '-cPGM=.K');
     }

     if (scalar @stdlib) {
          push(@krun_args, '--native-libraries');
          push(@krun_args, "@stdlib");
     }
     if (scalar @ld_lib) {
          push(@krun_args, '--native-library-path');
          push(@krun_args, "@ld_lib");
     }

     return @krun_args;
}

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

     my $directoryname = dirname($inputFile);
     my @ppArgs = ($preprocessor, "-Wall", "-Wextra", "-Werror", '-Wno-error=comment', "-Wmissing-prototypes",
                   "-pedantic", "-x", "c", "-std=c11", "-nostdlib",
                   "-U", "__GNUC__", "-D", "__KCC__", "-include", "$profileDirectory/include/kcc_settings.h",
                   @main::cppArgs, '-E', '-iquote', '.', '-iquote', $directoryname,
                   '-I', "$profileDirectory/include", $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 makeSet {
  my $set = '`.Set`(.KList)';
  foreach my $el (@_) {
    $set = "`_Set_`(`SetItem`($el), $set)";
  }
  return $set;
} 

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;
}