1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
#!/usr/bin/perl
use strict;
use warnings;
use File::Basename;
use File::Spec;
use File::Temp;
use POSIX;
sub makeJob(\@$);
sub forkAndCompileFiles(\@$);
sub Exec($);
sub waitForChild(\@);
sub cleanup(\@);
my $debug = 0;
chomp(my $clexe = `cygpath -u '$ENV{'VS80COMNTOOLS'}/../../VC/bin/cl.exe'`);
if ($debug) {
print STDERR "Received " . @ARGV . " arguments:\n";
foreach my $arg (@ARGV) {
print STDERR "$arg\n";
}
}
my $commandFile;
foreach my $arg (@ARGV) {
if ($arg =~ /^[\/-](E|EP|P)$/) {
print STDERR "The invoking process wants preprocessed source, so let's hand off this whole command to the real cl.exe\n" if $debug;
Exec("\"$clexe\" \"" . join('" "', @ARGV) . "\"");
} elsif ($arg =~ /^@(.*)$/) {
chomp($commandFile = `cygpath -u '$1'`);
}
}
die "No command file specified!" unless $commandFile;
die "Couldn't find $commandFile!" unless -f $commandFile;
my @sources;
open(COMMAND, '<:raw:encoding(UTF16-LE):crlf:utf8', $commandFile) or die "Couldn't open $commandFile!";
# The first line of the command file contains all the options to cl.exe plus the first (possibly quoted) filename
my $firstLine = <COMMAND>;
$firstLine =~ s/\r?\n$//;
# To find the start of the first filename, look for either the last space on the line.
# If the filename is quoted, the last character on the line will be a quote, so look for the quote before that.
my $firstFileIndex;
print STDERR "Last character of first line = '" . substr($firstLine, -1, 1) . "'\n" if $debug;
if (substr($firstLine, -1, 1) eq '"') {
print STDERR "First file is quoted\n" if $debug;
$firstFileIndex = rindex($firstLine, '"', length($firstLine) - 2);
} else {
print STDERR "First file is NOT quoted\n" if $debug;
$firstFileIndex = rindex($firstLine, ' ') + 1;
}
my $options = substr($firstLine, 0, $firstFileIndex) . join(' ', @ARGV[1 .. $#ARGV]);
my $possibleFirstFile = substr($firstLine, $firstFileIndex);
if ($possibleFirstFile =~ /\.(cpp|c)/) {
push(@sources, $possibleFirstFile);
} else {
$options .= " $possibleFirstFile";
}
print STDERR "######## Found options $options ##########\n" if $debug;
print STDERR "####### Found first source file $sources[0] ########\n" if @sources && $debug;
# The rest of the lines of the command file just contain source files, one per line
while (my $source = <COMMAND>) {
chomp($source);
$source =~ s/^\s+//;
$source =~ s/\s+$//;
push(@sources, $source) if length($source);
}
close(COMMAND);
my $numSources = @sources;
exit unless $numSources > 0;
my $numJobs;
if ($options =~ s/-j\s*([0-9]+)//) {
$numJobs = $1;
} else {
chomp($numJobs = `num-cpus`);
}
print STDERR "\n\n####### COMPILING $numSources FILES USING AT MOST $numJobs PARALLEL INSTANCES OF cl.exe ###########\n\n";# if $debug;
# Magic determination of job size
# The hope is that by splitting the source files up into 2*$numJobs pieces, we
# won't suffer too much if one job finishes much more quickly than another.
# However, we don't want to split it up too much due to cl.exe overhead, so set
# the minimum job size to 5.
my $jobSize = POSIX::ceil($numSources / (2 * $numJobs));
$jobSize = $jobSize < 5 ? 5 : $jobSize;
print STDERR "######## jobSize = $jobSize ##########\n" if $debug;
# Sort the source files randomly so that we don't end up with big clumps of large files (aka SVG)
sub fisher_yates_shuffle(\@)
{
my ($array) = @_;
for (my $i = @{$array}; --$i; ) {
my $j = int(rand($i+1));
next if $i == $j;
@{$array}[$i,$j] = @{$array}[$j,$i];
}
}
fisher_yates_shuffle(@sources); # permutes @array in place
my @children;
my @tmpFiles;
my $status = 0;
while (@sources) {
while (@sources && @children < $numJobs) {
my $pid;
my $tmpFile;
my $job = makeJob(@sources, $jobSize);
($pid, $tmpFile) = forkAndCompileFiles(@{$job}, $options);
print STDERR "####### Spawned child with PID $pid and tmpFile $tmpFile ##########\n" if $debug;
push(@children, $pid);
push(@tmpFiles, $tmpFile);
}
$status |= waitForChild(@children);
}
while (@children) {
$status |= waitForChild(@children);
}
cleanup(@tmpFiles);
exit WEXITSTATUS($status);
sub makeJob(\@$)
{
my ($files, $jobSize) = @_;
my @job;
if (@{$files} > ($jobSize * 1.5)) {
@job = splice(@{$files}, -$jobSize);
} else {
# Compile all the remaining files in this job to avoid having a small job later
@job = splice(@{$files});
}
return \@job;
}
sub forkAndCompileFiles(\@$)
{
print STDERR "######## forkAndCompileFiles()\n" if $debug;
my ($files, $options) = @_;
if ($debug) {
foreach my $file (@{$files}) {
print STDERR "######## $file\n";
}
}
my (undef, $tmpFile) = File::Temp::tempfile('clcommandXXXXX', DIR => File::Spec->tmpdir, OPEN => 0);
my $pid = fork();
die "Fork failed" unless defined($pid);
unless ($pid) {
# Child process
open(TMP, '>:raw:encoding(UTF16-LE):crlf:utf8', $tmpFile) or die "Couldn't open $tmpFile";
print TMP "$options\n";
foreach my $file (@{$files}) {
print TMP "$file\n";
}
close(TMP);
chomp(my $winTmpFile = `cygpath -m $tmpFile`);
Exec "\"$clexe\" \@\"$winTmpFile\"";
} else {
return ($pid, $tmpFile);
}
}
sub Exec($)
{
my ($command) = @_;
print STDERR "Exec($command)\n" if $debug;
exec($command);
}
sub waitForChild(\@)
{
my ($children) = @_;
return unless @{$children};
my $deceased = wait();
my $status = $?;
print STDERR "######## Child with PID $deceased finished ###########\n" if $debug;
for (my $i = 0; $i < @{$children}; $i++) {
if ($children->[$i] == $deceased) {
splice(@{$children}, $i, 1);
last;
}
}
return $status;
}
sub cleanup(\@)
{
my ($tmpFiles) = @_;
foreach my $file (@{$tmpFiles}) {
unlink $file;
}
}
|
