Skip to content

Commit 0f63510

Browse files
t-kalinowskit-kalinowski
committed
Add OpenMP diagnostics and matrix inference tests
1 parent 6e95a68 commit 0f63510

6 files changed

Lines changed: 318 additions & 48 deletions

File tree

‎R/parallel.R‎

Lines changed: 23 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,15 @@ mark_openmp_used <- function(scope) {
3131
invisible(root)
3232
}
3333

34+
openmp_abort <- function(message, class = "quickr_openmp_error") {
35+
stop(
36+
structure(
37+
list(message = message, call = sys.call(-1)),
38+
class = c(class, "error", "condition")
39+
)
40+
)
41+
}
42+
3443
is_parallel_decl_call <- function(e) {
3544
is.call(e) &&
3645
is.symbol(e[[1L]]) &&
@@ -235,18 +244,24 @@ openmp_link_flags <- function(fflags = openmp_fflags()) {
235244
openmp_makevars_lines <- function() {
236245
fflags <- openmp_fflags()
237246
if (!nzchar(fflags)) {
238-
stop(
239-
"OpenMP was requested but no OpenMP flags were found for this toolchain.",
240-
"\nSet QUICKR_OPENMP_FFLAGS to your compiler's OpenMP flags.",
241-
call. = FALSE
247+
openmp_abort(
248+
paste(
249+
"OpenMP was requested but no OpenMP flags were found for this toolchain.",
250+
"Set QUICKR_OPENMP_FFLAGS to your compiler's OpenMP flags.",
251+
sep = "\n"
252+
),
253+
class = "quickr_openmp_unavailable"
242254
)
243255
}
244256
libs <- openmp_link_flags(fflags = fflags)
245257
if (!nzchar(libs)) {
246-
stop(
247-
"OpenMP was requested but no OpenMP linker flags were found.",
248-
"\nSet QUICKR_OPENMP_LIBS to your linker OpenMP flags.",
249-
call. = FALSE
258+
openmp_abort(
259+
paste(
260+
"OpenMP was requested but no OpenMP linker flags were found.",
261+
"Set QUICKR_OPENMP_LIBS to your linker OpenMP flags.",
262+
sep = "\n"
263+
),
264+
class = "quickr_openmp_unavailable"
250265
)
251266
}
252267
c(

‎R/quick.R‎

Lines changed: 52 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -262,41 +262,75 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
262262
env = env
263263
)
264264
if (!is.null(attr(result, "status")) && length(env)) {
265-
result2 <- system2(
266-
R.home("bin/R"),
267-
r_args_libs,
268-
stdout = TRUE,
269-
stderr = TRUE
270-
)
271-
if (is.null(attr(result2, "status"))) {
272-
result <- result2
265+
if (use_openmp) {
266+
attr(result, "quickr_openmp_failed") <- TRUE
273267
} else {
274-
# Prefer to show the flang attempt first, then the fallback attempt.
275-
result <- c(
276-
"--- flang attempt ---",
277-
result,
278-
"",
279-
"--- fallback attempt ---",
280-
result2
268+
result2 <- system2(
269+
R.home("bin/R"),
270+
r_args_libs,
271+
stdout = TRUE,
272+
stderr = TRUE
281273
)
282-
attr(result, "status") <- attr(result2, "status")
274+
if (is.null(attr(result2, "status"))) {
275+
result <- result2
276+
} else {
277+
# Prefer to show the flang attempt first, then the fallback attempt.
278+
result <- c(
279+
"--- flang attempt ---",
280+
result,
281+
"",
282+
"--- fallback attempt ---",
283+
result2
284+
)
285+
attr(result, "status") <- attr(result2, "status")
286+
}
283287
}
284288
}
285289
})
286290

287-
if (!is.null(status <- attr(result, "status"))) {
291+
status <- attr(result, "status")
292+
openmp_failed <- isTRUE(attr(result, "quickr_openmp_failed"))
293+
if (!is.null(status)) {
288294
# Adjust the compiler error so RStudio console formatter doesn't mangle
289295
# the actual error message https://github.com/rstudio/rstudio/issues/16365
290296
result <- gsub("Error: ", "Compiler Error: ", result, fixed = TRUE)
291297
writeLines(result, stderr())
292298
cat("---\nCompiler exit status:", status, "\n", file = stderr())
299+
if (openmp_failed) {
300+
openmp_abort(
301+
paste(
302+
"OpenMP was requested but compilation with OpenMP flags failed.",
303+
"quickr will not fall back to a non-OpenMP build.",
304+
"Resolve the OpenMP toolchain or remove the parallel declarations.",
305+
sep = "\n"
306+
),
307+
class = "quickr_openmp_ignored"
308+
)
309+
}
293310
stop("Compilation Error", call. = FALSE)
294311
}
295312

296313
quickr_windows_add_dll_paths(link_flags)
297314

298315
# tryCatch(dyn.unload(dll_path), error = identity)
299-
dll <- dyn.load(dll_path)
316+
dll <- tryCatch(
317+
dyn.load(dll_path),
318+
error = function(e) {
319+
if (use_openmp) {
320+
openmp_abort(
321+
paste(
322+
"OpenMP was requested but the compiled shared library failed to load.",
323+
"This usually means the OpenMP runtime (libgomp/libomp) was not found.",
324+
"Original error:",
325+
conditionMessage(e),
326+
sep = "\n"
327+
),
328+
class = "quickr_openmp_load_failed"
329+
)
330+
}
331+
stop(e)
332+
}
333+
)
300334
c_wrapper_name <- paste0(fsub@name, "_")
301335
ptr <- getNativeSymbolInfo(c_wrapper_name, dll)$address
302336

‎R/sub-r2f-matrix.R‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -190,7 +190,7 @@ r2f_handlers[["outer"]] <- function(
190190
dest = NULL
191191
) {
192192
x_arg <- args$X %||% args[[1L]]
193-
y_arg <- args$Y %||% args[[2L]]
193+
y_arg <- args$Y %||% if (length(args) >= 2L) args[[2L]] else NULL
194194
if (is.null(x_arg) || is.null(y_arg)) {
195195
stop("outer() expects X and Y")
196196
}
@@ -1022,7 +1022,7 @@ infer_dest_tcrossprod <- function(args, scope) {
10221022
# Infer destination dimensions for outer() and %o%().
10231023
infer_dest_outer <- function(args, scope) {
10241024
x_arg <- args$X %||% args[[1L]]
1025-
y_arg <- args$Y %||% args[[2L]]
1025+
y_arg <- args$Y %||% if (length(args) >= 2L) args[[2L]] else NULL
10261026
x <- infer_symbol_var(x_arg, scope)
10271027
y <- infer_symbol_var(y_arg, scope)
10281028
if (is.null(x) || is.null(y)) {

‎tests/testthat/helper.R‎

Lines changed: 10 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -75,27 +75,17 @@ openmp_supported_or_skip <- local({
7575
skip_on_cran()
7676
skip_if_not_installed("pkgload")
7777
if (is.null(supported)) {
78-
supported <<- tryCatch(
79-
{
80-
quick(function(x) {
81-
declare(type(x = double(1)))
82-
declare(parallel())
83-
for (i in seq_len(1L)) {
84-
x[i] <- x[i] + 1
85-
}
86-
x
87-
})
88-
TRUE
89-
},
90-
error = function(e) {
91-
msg <- conditionMessage(e)
92-
if (grepl("OpenMP", msg, fixed = TRUE)) {
93-
return(FALSE)
78+
supported <<- {
79+
quick(function(x) {
80+
declare(type(x = double(1)))
81+
declare(parallel())
82+
for (i in seq_len(1L)) {
83+
x[i] <- x[i] + 1
9484
}
95-
stop(e)
96-
}
97-
)
85+
x
86+
})
87+
TRUE
88+
}
9889
}
99-
skip_if(!isTRUE(supported), "OpenMP unavailable in this toolchain")
10090
}
10191
})

‎tests/testthat/test-matrix-inference.R‎

Lines changed: 168 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,168 @@
1+
test_that("matrix ops infer destination sizes for assignments", {
2+
matmul_infer <- function(A, B) {
3+
declare(type(A = double(2, 3)), type(B = double(3, 2)))
4+
out <- A %*% B
5+
out
6+
}
7+
8+
matvec_infer <- function(A, x) {
9+
declare(type(A = double(2, 3)), type(x = double(3)))
10+
out <- A %*% x
11+
out
12+
}
13+
14+
vecmat_infer <- function(x, A) {
15+
declare(type(x = double(2)), type(A = double(2, 3)))
16+
out <- x %*% A
17+
out
18+
}
19+
20+
cross_infer <- function(x) {
21+
declare(type(x = double(4, 3)))
22+
out <- crossprod(x)
23+
out
24+
}
25+
26+
cross_infer2 <- function(x, y) {
27+
declare(type(x = double(4, 3)), type(y = double(4, 2)))
28+
out <- crossprod(x, y)
29+
out
30+
}
31+
32+
tcross_infer <- function(x) {
33+
declare(type(x = double(4, 3)))
34+
out <- tcrossprod(x)
35+
out
36+
}
37+
38+
tcross_infer2 <- function(x, y) {
39+
declare(type(x = double(4, 3)), type(y = double(2, 3)))
40+
out <- tcrossprod(x, y)
41+
out
42+
}
43+
44+
outer_infer <- function(x, y) {
45+
declare(type(x = double(2)), type(y = double(3)))
46+
out <- outer(x, y)
47+
out
48+
}
49+
50+
outer_op_infer <- function(x, y) {
51+
declare(type(x = double(2)), type(y = double(3)))
52+
out <- x %o% y
53+
out
54+
}
55+
56+
forward_infer <- function(L, b) {
57+
declare(type(L = double(2, 2)), type(b = double(2, 2)))
58+
out <- forwardsolve(L, b)
59+
out
60+
}
61+
62+
back_infer <- function(U, b) {
63+
declare(type(U = double(2, 2)), type(b = double(2)))
64+
out <- backsolve(U, b)
65+
out
66+
}
67+
68+
set.seed(99)
69+
A <- matrix(rnorm(6), nrow = 2)
70+
B <- matrix(rnorm(6), nrow = 3)
71+
x2 <- rnorm(2)
72+
x3 <- rnorm(3)
73+
X <- matrix(rnorm(12), nrow = 4)
74+
Yc <- matrix(rnorm(8), nrow = 4)
75+
Yt <- matrix(rnorm(6), nrow = 2)
76+
v2 <- rnorm(2)
77+
v3 <- rnorm(3)
78+
79+
L <- matrix(c(2, 0, 1, 3), nrow = 2, byrow = TRUE)
80+
U <- matrix(c(2, 1, 0, 3), nrow = 2, byrow = TRUE)
81+
b_mat <- matrix(rnorm(4), nrow = 2)
82+
b_vec <- rnorm(2)
83+
84+
expect_quick_equal(matmul_infer, list(A = A, B = B))
85+
expect_quick_equal(matvec_infer, list(A = A, x = x3))
86+
expect_quick_equal(vecmat_infer, list(x = x2, A = A))
87+
expect_quick_equal(cross_infer, list(x = X))
88+
expect_quick_equal(cross_infer2, list(x = X, y = Yc))
89+
expect_quick_equal(tcross_infer, list(x = X))
90+
expect_quick_equal(tcross_infer2, list(x = X, y = Yt))
91+
expect_quick_equal(outer_infer, list(x = v2, y = v3))
92+
expect_quick_equal(outer_op_infer, list(x = v2, y = v3))
93+
expect_quick_equal(forward_infer, list(L = L, b = b_mat))
94+
expect_quick_equal(back_infer, list(U = U, b = b_vec))
95+
})
96+
97+
test_that("matrix helpers report unsupported inputs", {
98+
matmul_bad_rank <- function(a, b) {
99+
declare(type(a = double(2, 2, 2)), type(b = double(2, 2)))
100+
a %*% b
101+
}
102+
103+
transpose_bad_rank <- function(x) {
104+
declare(type(x = double(2, 2, 2)))
105+
t(x)
106+
}
107+
108+
outer_bad_rank <- function(x, y) {
109+
declare(type(x = double(2, 2)), type(y = double(2)))
110+
outer(x, y)
111+
}
112+
113+
outer_missing <- function(x) {
114+
declare(type(x = double(2)))
115+
outer(x)
116+
}
117+
118+
forward_k <- function(L, b) {
119+
declare(type(L = double(2, 2)), type(b = double(2)))
120+
forwardsolve(L, b, k = 1)
121+
}
122+
123+
back_bad_upper <- function(U, b, flag) {
124+
declare(
125+
type(U = double(2, 2)),
126+
type(b = double(2)),
127+
type(flag = logical(1))
128+
)
129+
backsolve(U, b, upper.tri = flag)
130+
}
131+
132+
back_bad_A <- function(A, b) {
133+
declare(type(A = double(2)), type(b = double(2)))
134+
backsolve(A, b)
135+
}
136+
137+
back_bad_B <- function(U, b) {
138+
declare(type(U = double(2, 2)), type(b = double(2, 2, 2)))
139+
backsolve(U, b)
140+
}
141+
142+
expect_error(quick(matmul_bad_rank), "%\\*% only supports vectors/matrices")
143+
expect_error(quick(transpose_bad_rank), "t\\(\\) only supports rank 0-2")
144+
expect_error(quick(outer_bad_rank), "outer\\(\\) only supports vectors")
145+
expect_error(quick(outer_missing), "outer\\(\\) expects X and Y")
146+
expect_error(quick(forward_k), "forwardsolve\\(\\) does not support k")
147+
expect_error(quick(back_bad_upper), "only supports literal upper\\.tri")
148+
expect_error(quick(back_bad_A), "triangular solve expects a matrix")
149+
expect_error(quick(back_bad_B), "triangular solve only supports vector")
150+
})
151+
152+
test_that("matrix conformability warnings are surfaced", {
153+
matmul_warn <- function(A, B, n, m, k) {
154+
declare(
155+
type(n = integer(1)),
156+
type(m = integer(1)),
157+
type(k = integer(1)),
158+
type(A = double(n, m)),
159+
type(B = double(k, n))
160+
)
161+
A %*% B
162+
}
163+
164+
expect_warning(
165+
quick(matmul_warn),
166+
"cannot verify conformability in %\\*%"
167+
)
168+
})

0 commit comments

Comments
 (0)