1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6use File::Basename;
7use File::Spec;
8use File::Temp;
9use POSIX;
10
11sub makeJob(\@$);
12sub forkAndCompileFiles(\@$);
13sub Exec($);
14sub waitForChild(\@);
15sub cleanup(\@);
16
17my $debug = 0;
18
19chomp(my $clexe = `cygpath -u '$ENV{'VS80COMNTOOLS'}/../../VC/bin/cl.exe'`);
20
21if ($debug) {
22    print STDERR "Received " . @ARGV . " arguments:\n";
23    foreach my $arg (@ARGV) {
24        print STDERR "$arg\n";
25    }
26}
27
28my $commandFile;
29foreach 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
38die "No command file specified!" unless $commandFile;
39die "Couldn't find $commandFile!" unless -f $commandFile;
40
41my @sources;
42
43open(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
46my $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.
51my $firstFileIndex;
52print STDERR "Last character of first line = '" . substr($firstLine, -1, 1) . "'\n" if $debug;
53if (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
61my $options = substr($firstLine, 0, $firstFileIndex) . join(' ', @ARGV[1 .. $#ARGV]);
62my $possibleFirstFile = substr($firstLine, $firstFileIndex);
63if ($possibleFirstFile =~ /\.(cpp|c)/) {
64    push(@sources, $possibleFirstFile);
65} else {
66    $options .= " $possibleFirstFile";
67}
68
69print STDERR "######## Found options $options ##########\n" if $debug;
70print 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
73while (my $source = <COMMAND>) {
74    chomp($source);
75    $source =~ s/^\s+//;
76    $source =~ s/\s+$//;
77    push(@sources, $source) if length($source);
78}
79close(COMMAND);
80
81my $numSources = @sources;
82exit unless $numSources > 0;
83
84my $numJobs;
85if ($options =~ s/-j\s*([0-9]+)//) {
86    $numJobs = $1;
87} else {
88    chomp($numJobs = `num-cpus`);
89}
90
91print STDERR "\n\n####### COMPILING $numSources FILES USING 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.
98my $jobSize = POSIX::ceil($numSources / (2 * $numJobs));
99$jobSize = $jobSize < 5 ? 5 : $jobSize;
100
101print 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)
104sub 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
114fisher_yates_shuffle(@sources);    # permutes @array in place
115
116my @children;
117my @tmpFiles;
118my $status = 0;
119while (@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
134while (@children) {
135    $status |= waitForChild(@children);
136}
137cleanup(@tmpFiles);
138
139exit WEXITSTATUS($status);
140
141
142sub 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
157sub 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
189sub Exec($)
190{
191    my ($command) = @_;
192
193    print STDERR "Exec($command)\n" if $debug;
194
195    exec($command);
196}
197
198sub 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
217sub cleanup(\@)
218{
219    my ($tmpFiles) = @_;
220
221    foreach my $file (@{$tmpFiles}) {
222        unlink $file;
223    }
224}
225