1 #!/usr/bin/perl

     2 

     3 use strict;

     4 use warnings;

     5 

     6 use File::Basename;

     7 use File::Spec;

     8 use File::Temp;

     9 use POSIX;

    10 

    11 sub makeJob(\@$);

    12 sub forkAndCompileFiles(\@$);

    13 sub Exec($);

    14 sub waitForChild(\@);

    15 sub cleanup(\@);

    16 

    17 my $debug = 0;

    18 

    19 chomp(my $clexe = `cygpath -u '$ENV{'VS80COMNTOOLS'}/../../VC/bin/cl.exe'`);

    20 

    21 if ($debug) {

    22     print STDERR "Received " . @ARGV . " arguments:\n";

    23     foreach my $arg (@ARGV) {

    24         print STDERR "$arg\n";

    25     }

    26 }

    27 

    28 my $commandFile;

    29 foreach my $arg (@ARGV) {

    30     if ($arg =~ /^[\/-](E|EP|P)$/) {

    31         print STDERR "The invoking process wants preprocessed source, so let's hand off this whole command to the real cl.exe\n" if $debug;

    32         Exec("\"$clexe\" \"" . join('" "', @ARGV) . "\"");

    33     } elsif ($arg =~ /^@(.*)$/) {

    34         chomp($commandFile = `cygpath -u '$1'`);

    35     }

    36 }

    37 

    38 die "No command file specified!" unless $commandFile;

    39 die "Couldn't find $commandFile!" unless -f $commandFile;

    40 

    41 my @sources;

    42 

    43 open(COMMAND, '<:raw:encoding(UTF16-LE):crlf:utf8', $commandFile) or die "Couldn't open $commandFile!";

    44 

    45 # The first line of the command file contains all the options to cl.exe plus the first (possibly quoted) filename

    46 my $firstLine = <COMMAND>;

    47 $firstLine =~ s/\r?\n$//;

    48 

    49 # To find the start of the first filename, look for either the last space on the line.

    50 # If the filename is quoted, the last character on the line will be a quote, so look for the quote before that.

    51 my $firstFileIndex;

    52 print STDERR "Last character of first line = '" . substr($firstLine, -1, 1) . "'\n" if $debug;

    53 if (substr($firstLine, -1, 1) eq '"') {

    54     print STDERR "First file is quoted\n" if $debug;

    55     $firstFileIndex = rindex($firstLine, '"', length($firstLine) - 2);

    56 } else {

    57     print STDERR "First file is NOT quoted\n" if $debug;

    58     $firstFileIndex = rindex($firstLine, ' ') + 1;

    59 }

    60 

    61 my $options = substr($firstLine, 0, $firstFileIndex) . join(' ', @ARGV[1 .. $#ARGV]);

    62 my $possibleFirstFile = substr($firstLine, $firstFileIndex);

    63 if ($possibleFirstFile =~ /\.(cpp|c)/) {

    64     push(@sources, $possibleFirstFile);

    65 } else {

    66     $options .= " $possibleFirstFile";

    67 }

    68 

    69 print STDERR "######## Found options $options ##########\n" if $debug;

    70 print STDERR "####### Found first source file $sources[0] ########\n" if @sources && $debug;

    71 

    72 # The rest of the lines of the command file just contain source files, one per line

    73 while (my $source = <COMMAND>) {

    74     chomp($source);

    75     $source =~ s/^\s+//;

    76     $source =~ s/\s+$//;

    77     push(@sources, $source) if length($source);

    78 }

    79 close(COMMAND);

    80 

    81 my $numSources = @sources;

    82 exit unless $numSources > 0;

    83 

    84 my $numJobs;

    85 if ($options =~ s/-j\s*([0-9]+)//) {

    86     $numJobs = $1;

    87 } else {

    88     chomp($numJobs = `num-cpus`);

    89 }

    90 

    91 print STDERR "\n\n####### RUNNING AT MOST $numJobs PARALLEL INSTANCES OF cl.exe ###########\n\n";# if $debug;

    92 

    93 # Magic determination of job size

    94 # The hope is that by splitting the source files up into 2*$numJobs pieces, we

    95 # won't suffer too much if one job finishes much more quickly than another.

    96 # However, we don't want to split it up too much due to cl.exe overhead, so set

    97 # the minimum job size to 5.

    98 my $jobSize = POSIX::ceil($numSources / (2 * $numJobs));

    99 $jobSize = $jobSize < 5 ? 5 : $jobSize;

   100 

   101 print STDERR "######## jobSize = $jobSize ##########\n" if $debug;

   102 

   103 # Sort the source files randomly so that we don't end up with big clumps of large files (aka SVG)

   104 sub fisher_yates_shuffle(\@)

   105 {

   106     my ($array) = @_;

   107     for (my $i = @{$array}; --$i; ) {

   108         my $j = int(rand($i+1));

   109         next if $i == $j;

   110         @{$array}[$i,$j] = @{$array}[$j,$i];

   111     }

   112 }

   113 

   114 fisher_yates_shuffle(@sources);    # permutes @array in place

   115 

   116 my @children;

   117 my @tmpFiles;

   118 my $status = 0;

   119 while (@sources) {

   120     while (@sources && @children < $numJobs) {

   121         my $pid;

   122         my $tmpFile;

   123         my $job = makeJob(@sources, $jobSize);

   124         ($pid, $tmpFile) = forkAndCompileFiles(@{$job}, $options);

   125 

   126         print STDERR "####### Spawned child with PID $pid and tmpFile $tmpFile ##########\n" if $debug;

   127         push(@children, $pid);

   128         push(@tmpFiles, $tmpFile);

   129     }

   130 

   131     $status |= waitForChild(@children);

   132 }

   133 

   134 while (@children) {

   135     $status |= waitForChild(@children);

   136 }

   137 cleanup(@tmpFiles);

   138 

   139 exit WEXITSTATUS($status);

   140 

   141 

   142 sub makeJob(\@$)

   143 {

   144     my ($files, $jobSize) = @_;

   145 

   146     my @job;

   147     if (@{$files} > ($jobSize * 1.5)) {

   148         @job = splice(@{$files}, -$jobSize);

   149     } else {

   150         # Compile all the remaining files in this job to avoid having a small job later

   151         @job = splice(@{$files});

   152     }

   153 

   154     return \@job;

   155 }

   156 

   157 sub forkAndCompileFiles(\@$)

   158 {

   159     print STDERR "######## forkAndCompileFiles()\n" if $debug;

   160     my ($files, $options) = @_;

   161 

   162     if ($debug) {

   163         foreach my $file (@{$files}) {

   164             print STDERR "######## $file\n";

   165         }

   166     }

   167 

   168     my (undef, $tmpFile) = File::Temp::tempfile('clcommandXXXXX', DIR => File::Spec->tmpdir, OPEN => 0);

   169 

   170     my $pid = fork();

   171     die "Fork failed" unless defined($pid);

   172 

   173     unless ($pid) {

   174         # Child process

   175         open(TMP, '>:raw:encoding(UTF16-LE):crlf:utf8', $tmpFile) or die "Couldn't open $tmpFile";

   176         print TMP "$options\n";

   177         foreach my $file (@{$files}) {

   178             print TMP "$file\n";

   179         }

   180         close(TMP);

   181         

   182         chomp(my $winTmpFile = `cygpath -m $tmpFile`);

   183         Exec "\"$clexe\" \@\"$winTmpFile\"";

   184     } else {

   185         return ($pid, $tmpFile);

   186     }

   187 }

   188 

   189 sub Exec($)

   190 {

   191     my ($command) = @_;

   192 

   193     print STDERR "Exec($command)\n" if $debug;

   194 

   195     exec($command);

   196 }

   197 

   198 sub waitForChild(\@)

   199 {

   200     my ($children) = @_;

   201 

   202     return unless @{$children};

   203 

   204     my $deceased = wait();

   205     my $status = $?;

   206     print STDERR "######## Child with PID $deceased finished ###########\n" if $debug;

   207     for (my $i = 0; $i < @{$children}; $i++) {

   208         if ($children->[$i] == $deceased) {

   209             splice(@{$children}, $i, 1);

   210             last;

   211         }

   212     }

   213 

   214     return $status;

   215 }

   216 

   217 sub cleanup(\@)

   218 {

   219     my ($tmpFiles) = @_;

   220 

   221     foreach my $file (@{$tmpFiles}) {

   222         unlink $file;

   223     }

   224 }