-
Notifications
You must be signed in to change notification settings - Fork 59
Expand file tree
/
Copy pathtbb-downstream-check.R
More file actions
242 lines (189 loc) · 8.92 KB
/
Copy pathtbb-downstream-check.R
File metadata and controls
242 lines (189 loc) · 8.92 KB
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
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
# Build and load a translation unit exercising the parts of the TBB API that
# downstream packages depend on, using only the flags RcppParallel advertises.
#
# StanHeaders -- and so rstan -- needs both of the pieces used here:
# tbb::this_task_arena::isolate, to keep its thread-local AD tape from being
# modified by a task from another arena, and tbb::task_scheduler_observer, to
# install that tape on each worker. Rtools42's TBB 2017 provides neither in a
# usable form, which is what broke rstan on R 4.2 (isolate is gated behind
# TBB_PREVIEW_TASK_ISOLATION, and isolate_within_arena isn't in the library at
# all), so this stands in for a full rstan build.
code <- '
#include <tbb/blocked_range.h>
#include <tbb/parallel_for.h>
#include <tbb/task_arena.h>
#include <tbb/task_scheduler_observer.h>
#include <atomic>
#include <cstddef>
// R.h remaps names like \'length\' onto Rf_ equivalents by default, which
// collides with the standard library; keep it last, and unremapped
#define R_NO_REMAP
#include <R.h>
#include <Rinternals.h>
namespace {
// mirrors StanHeaders\' ad_tape_observer, which is what pulls the
// task_scheduler_observer entry points into the link
struct observer : public tbb::task_scheduler_observer {
observer() : tbb::task_scheduler_observer() { observe(true); }
void on_scheduler_entry(bool) override {}
void on_scheduler_exit(bool) override {}
};
} // end anonymous namespace
extern "C" SEXP tbb_downstream_check(void) {
observer obs;
std::atomic<int> total(0);
// mirrors StanHeaders\' use of task isolation in reduce_sum / map_rect
tbb::this_task_arena::isolate([&] {
tbb::parallel_for(
tbb::blocked_range<std::size_t>(0, 1024),
[&](const tbb::blocked_range<std::size_t>& range) {
total += static_cast<int>(range.end() - range.begin());
}
);
});
return Rf_ScalarInteger(total.load());
}
'
# report how RcppParallel is configured, so a failure here can be read
# against the provenance logged during installation
writeLines(c(
sprintf("TBB_ENABLED : %s", RcppParallel:::TBB_ENABLED),
sprintf("TBB_LIB : '%s'", RcppParallel:::TBB_LIB),
sprintf("TBB_INC : '%s'", RcppParallel:::TBB_INC),
sprintf("CxxFlags() : %s", RcppParallel:::tbbCxxFlags()),
sprintf("LdFlags() : %s", RcppParallel:::tbbLdFlags())
))
if (!RcppParallel:::TBB_ENABLED)
stop("RcppParallel was installed without a tbb backend")
# mirror rstan's src/Makevars.win, which takes all of its TBB configuration
# from RcppParallel: its compiler flags via CxxFlags(), its linker flags via
# RcppParallelLibs(), and the include path itself via 'LinkingTo'
makevars <- c(
"CXX_STD = CXX17",
sprintf("PKG_CPPFLAGS = -I\"%s\"", system.file("include", package = "RcppParallel")),
"PKG_CPPFLAGS += $(shell \"${R_HOME}/bin${R_ARCH_BIN}/Rscript\" -e \"RcppParallel::CxxFlags()\" | tail -n 1)",
"PKG_LIBS += $(shell \"${R_HOME}/bin${R_ARCH_BIN}/Rscript\" -e \"RcppParallel::RcppParallelLibs()\" | tail -n 1)"
)
dir <- tempfile("tbb-downstream-")
dir.create(dir, recursive = TRUE)
owd <- setwd(dir)
on.exit(setwd(owd), add = TRUE)
writeLines(code, "check.cpp")
# deliberately not named 'Makevars': R CMD SHLIB reads a Makevars in the
# working directory as well as R_MAKEVARS_USER, and would apply both. going
# through R_MAKEVARS_USER also keeps any personal ~/.R/Makevars out of the way
writeLines(makevars, "makevars-downstream")
Sys.setenv(R_MAKEVARS_USER = file.path(dir, "makevars-downstream"))
status <- system(paste(shQuote(file.path(R.home("bin"), "R")), "CMD SHLIB check.cpp"))
if (status != 0L)
stop("downstream translation unit failed to build")
dllName <- paste0("check", .Platform$dynlib.ext)
# On Windows, check where the TBB symbols came from. RcppParallel builds oneTBB
# as a shared library and links against it, exactly as on other platforms, so
# there should be a single TBB runtime in the process: this library's TBB
# symbols must all come from 'tbb.dll', and RcppParallel.dll must import from it
# too rather than carrying a copy of its own. Two runtimes would be a silent
# failure -- an observer registered with one would never fire for arenas owned
# by the other -- so it is worth asserting rather than assuming.
# objdump has to match the target architecture, and the first one on the PATH
# may well not: the aarch64 runner leads with an x86_64 objdump from C:/mingw64,
# which exits non-zero having read nothing. Ask R which compiler it builds with
# -- that is the one that produced the PE, so its objdump can always read it --
# and only then fall back to whatever the PATH offers
objdumpCandidates <- function() {
cc <- suppressWarnings(
system2(
file.path(R.home("bin"), "R"),
c("CMD", "config", "CC"),
stdout = TRUE,
stderr = FALSE
)
)
# CC may carry arguments (e.g. 'gcc -std=gnu2x'), and may name the compiler
# rather than spell out its path, in which case the PATH has to resolve it
cc <- strsplit(trimws(paste(cc, collapse = " ")), "[[:space:]]+")[[1L]][[1L]]
cc <- if (file.exists(cc)) cc else Sys.which(cc)
compilers <- c(cc, Sys.which(c("gcc", "clang", "cc")))
beside <- file.path(dirname(compilers[nzchar(compilers)]), "objdump.exe")
candidates <- c(beside, Sys.which("objdump"))
candidates <- candidates[nzchar(candidates) & file.exists(candidates)]
# '/' and '\\' spellings of one path are the same objdump; don't try twice
unique(normalizePath(candidates, winslash = "/", mustWork = FALSE))
}
tbbImports <- function(dll) {
# each imported library opens a 'DLL Name:' block listing the symbols taken
# from it; finding at least one is how we know objdump really read the file,
# rather than failing in a way that would look like 'imports nothing'
starts <- integer()
output <- character()
for (objdump in objdumpCandidates()) {
output <- suppressWarnings(
system2(objdump, c("-p", shQuote(dll)), stdout = TRUE, stderr = TRUE)
)
status <- attr(output, "status")
# keep only the import tables. the export table follows them, and lists
# the library's own inlined TBB instantiations -- left in, it would be
# absorbed into the last 'DLL Name:' block and credit that library with
# TBB symbols it never imported
exports <- grep("export table|The Export Tables", output)
if (length(exports))
output <- output[seq_len(exports[[1L]] - 1L)]
starts <- grep("DLL Name:", output, fixed = TRUE)
if (length(starts) && !(is.numeric(status) && status != 0L))
break
fmt <- "** '%s' could not read the import table of '%s'"
writeLines(sprintf(fmt, objdump, basename(dll)))
writeLines(output)
starts <- integer()
}
if (!length(starts)) {
fmt <- "** no usable objdump for '%s'; skipping the import table check"
writeLines(sprintf(fmt, basename(dll)))
return(NULL)
}
imported <- sub(".*DLL Name:[[:space:]]*", "", output[starts])
ends <- c(starts[-1L], length(output) + 1L)
# attribute the TBB symbols to the module each was taken from
providers <- character()
for (i in seq_along(starts)) {
block <- output[seq(starts[[i]], ends[[i]] - 1L)]
if (any(grepl("_ZN3tbb", block, fixed = TRUE)))
providers <- c(providers, imported[[i]])
}
fmt <- "%s imports: %s [tbb symbols from: %s]"
writeLines(sprintf(
fmt, basename(dll),
paste(imported, collapse = ", "),
if (length(providers)) paste(providers, collapse = ", ") else "none"
))
tolower(providers)
}
if (.Platform$OS.type == "windows") {
providers <- tbbImports(dllName)
if (!is.null(providers)) {
if (length(providers) != 1L)
stop("expected this library's tbb symbols to come from exactly one ",
"module, but found ", length(providers), " (",
paste(providers, collapse = ", "), "); more than one means more ",
"than one copy of the oneTBB runtime")
if (!identical(providers, "tbb.dll"))
stop("this library's tbb symbols came from '", providers,
"' rather than the shared 'tbb.dll' runtime")
}
# and RcppParallel itself must be a client of that same runtime
rcppParallelDll <- RcppParallel:::archSystemFile("libs", "RcppParallel.dll")
if (!file.exists(rcppParallelDll))
stop("could not locate RcppParallel.dll within the installed package")
providers <- tbbImports(rcppParallelDll)
if (!is.null(providers) && !identical(providers, "tbb.dll"))
stop("RcppParallel.dll does not take its tbb symbols from 'tbb.dll' ",
"(got: ", paste(providers, collapse = ", "),
"); it appears to carry its own copy of the runtime")
}
# loading also proves the load-time dependency on the tbb runtime resolves
dll <- dyn.load(dllName)
on.exit(dyn.unload(dll[["path"]]), add = TRUE)
result <- .Call("tbb_downstream_check")
if (!identical(result, 1024L))
stop("downstream check returned ", result, "; expected 1024")
writeLines("** downstream TBB check passed")