Skip to content
Merged
Show file tree
Hide file tree
Changes from 3 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
27 changes: 26 additions & 1 deletion R/c-wrapper.R
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
closure <- fsub@closure
scope <- fsub@scope
uses_rng <- isTRUE(attr(scope, "uses_rng", TRUE))
uses_errors <- isTRUE(attr(scope, "uses_errors", TRUE))

fsub_arg_names <- fsub@signature # arg names
closure_arg_names <- names(formals(closure)) %||% character()
Expand Down Expand Up @@ -52,8 +53,22 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
}
}

if (uses_errors) {
append(c_body) <- c(
"",
glue("char {quickr_error_msg_name()}[{quickr_error_msg_len()}];"),
glue("{quickr_error_msg_name()}[0] = '\\0';"),
""
)
}

fsub_call_args <- fsub_arg_names |>
lapply(\(nm) paste0(nm, if (!is_size_name(nm)) "__")) |>
lapply(\(nm) {
if (is_quickr_error_msg(nm)) {
return(nm)
}
paste0(nm, if (!is_size_name(nm)) "__")
}) |>
unlist()

if (length(fsub_call_args) > 3) {
Expand All @@ -65,6 +80,13 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
if (uses_rng) "GetRNGstate();",
glue("{fsub@name}({str_flatten_commas(fsub_call_args)});"),
if (uses_rng) "PutRNGstate();",
if (uses_errors) glue("if ({quickr_error_msg_name()}[0] != '\\0') {{"),
if (uses_errors) {
indent(glue(
"Rf_error(\"%s\", {quickr_error_msg_name()});"
))
},
if (uses_errors) "}",
""
)
# Determine if the closure returns a list call or a single symbol
Expand Down Expand Up @@ -552,6 +574,9 @@ fsub_extern_decl <- function(fsub) {
scope <- fsub@scope

fsub_c_sig <- map_chr(fsub_arg_names, function(name) {
if (is_quickr_error_msg(name)) {
return(glue("char* {name}"))
}
if (is_size_name(name)) {
type <- if (name |> endsWith("__len_")) {
"R_xlen_t"
Expand Down
131 changes: 131 additions & 0 deletions R/error-handling.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,131 @@
quickr_error_msg_name <- function() "quickr_err_msg"

quickr_error_msg_len <- function() 256L

quickr_error_setter_name <- function() "quickr_set_error_msg"

quickr_error_arg_names <- function() {
c(quickr_error_msg_name())
}

is_quickr_error_msg <- function(name) {
identical(name, quickr_error_msg_name())
}

scope_root_for_errors <- function(scope) {
if (!inherits(scope, "quickr_scope")) {
return(scope)
}
while (
!identical(attr(scope, "kind", exact = TRUE), "subroutine") &&
inherits(parent.env(scope), "quickr_scope")
) {
scope <- parent.env(scope)
}
scope
}

mark_scope_uses_errors <- function(scope) {
root <- scope_root_for_errors(scope)
if (inherits(root, "quickr_scope")) {
attr(root, "uses_errors") <- TRUE
}
invisible(TRUE)
}

scope_uses_errors <- function(scope) {
root <- scope_root_for_errors(scope)
isTRUE(attr(root, "uses_errors", TRUE))
}

fortran_string_literal <- function(x) {
stopifnot(is_string(x))
escaped <- gsub("\r\n|\r|\n", "\\\\n", x)
escaped <- gsub("\"", "\"\"", escaped, fixed = TRUE)
paste0("\"", escaped, "\"")
}

check_quickr_error_message_continuable <- function(msg) {
stopifnot(is_string(msg))
if (grepl("[ \t]", msg)) {
return(invisible(TRUE))
}
msg_literal <- fortran_string_literal(msg)
line_len <- nchar(glue(
"&{quickr_error_setter_name()}( {msg_literal} )"
))
if (line_len > 132L) {
stop(
"Error message is too long to fit in a single Fortran line without spaces.",
" Add spaces to allow line continuations.",
call. = FALSE
)
}
invisible(TRUE)
}

quickr_error_manifest_lines <- function() {
msg_name <- quickr_error_msg_name()
len_val <- quickr_error_msg_len()

glue("character(kind=c_char), intent(inout) :: {msg_name}({len_val})")
}

quickr_error_helper_fortran <- function(openmp = FALSE) {
msg_name <- quickr_error_msg_name()
setter <- quickr_error_setter_name()
len_val <- quickr_error_msg_len()

glue::trim(str_flatten_lines(
glue("subroutine {setter}(msg)"),
" character(len=*), intent(in) :: msg",
" integer :: i",
" integer :: n",
if (isTRUE(openmp)) " !$omp critical (quickr_error)",
glue(" if ({msg_name}(1) == c_null_char) then"),
glue(" n = min(len(msg), {len_val} - 1)"),
glue(" {msg_name}(1:n) = [(msg(i:i), i = 1, n)]"),
glue(" {msg_name}(n + 1) = c_null_char"),
" end if",
if (isTRUE(openmp)) " !$omp end critical (quickr_error)",
glue("end subroutine {setter}")
))
}

quickr_error_fortran_lines <- function(message = NULL, scope = NULL) {
msg <- message %||% "quickr error"
stopifnot(is_string(msg))
if (!nzchar(msg)) {
msg <- "quickr error"
}
check_quickr_error_message_continuable(msg)
msg_literal <- fortran_string_literal(msg)
lines <- glue("call {quickr_error_setter_name()}({msg_literal})")
if (isTRUE(scope_in_openmp(scope))) {
lines <- c(lines, "!$omp cancel do")
} else {
lines <- c(lines, "return")
}
lines
}

quickr_error_return_if_set <- function(
scope,
openmp_depth = scope_openmp_depth(scope)
) {
if (!isTRUE(scope_uses_errors(scope))) {
return("")
}
if (is.null(openmp_depth)) {
openmp_depth <- 0L
}
openmp_depth <- max(as.integer(openmp_depth), 0L)
if (openmp_depth > 0L) {
return(str_flatten_lines(
glue("if ({quickr_error_msg_name()}(1) /= c_null_char) then"),
" !$omp cancel do",
"end if"
))
}
glue("if ({quickr_error_msg_name()}(1) /= c_null_char) return")
}
16 changes: 13 additions & 3 deletions R/manifest.R
Original file line number Diff line number Diff line change
Expand Up @@ -105,7 +105,8 @@ iso_c_binding_symbols <- function(
vars,
body_code = "",
logical_is_c_int = logical_as_int,
uses_rng = FALSE
uses_rng = FALSE,
include_errors = FALSE
) {
stopifnot(is.list(vars), is_string(body_code), is.function(logical_is_c_int))

Expand Down Expand Up @@ -152,6 +153,13 @@ iso_c_binding_symbols <- function(
used_iso_bindings <- union(used_iso_bindings, "c_double")
}

if (isTRUE(include_errors)) {
used_iso_bindings <- union(
used_iso_bindings,
c("c_char", "c_null_char")
)
}

used_iso_bindings |>
compact() |>
unique() |>
Expand Down Expand Up @@ -256,7 +264,7 @@ emit_block <- function(decls, stmts) {
))
}

r2f.scope <- function(scope) {
r2f.scope <- function(scope, include_errors = FALSE) {
vars <- scope_vars(scope)
vars <- lapply(vars, function(var) {
intent_in <- var@name %in% names(formals(scope@closure))
Expand Down Expand Up @@ -331,6 +339,7 @@ r2f.scope <- function(scope) {

manifest <- compact(list(
sizes = sizes,
error = if (isTRUE(include_errors)) quickr_error_manifest_lines(),
args = vars[non_local_var_names],
locals = vars[setdiff(names(vars), non_local_var_names)]
))
Expand All @@ -346,7 +355,8 @@ r2f.scope <- function(scope) {
# # method="radix" for locale-independent stable order.
signature <- unique(c(
non_local_var_names,
sort(size_names, method = "radix")
sort(size_names, method = "radix"),
if (isTRUE(include_errors)) quickr_error_arg_names()
))
attr(manifest, "signature") <- signature

Expand Down
38 changes: 38 additions & 0 deletions R/parallel.R
Original file line number Diff line number Diff line change
Expand Up @@ -31,6 +31,44 @@ mark_openmp_used <- function(scope) {
invisible(root)
}

scope_openmp_depth <- function(scope) {
if (!inherits(scope, "quickr_scope")) {
return(0L)
}
depth <- attr(scope, "openmp_depth", exact = TRUE)
if (is.null(depth)) {
0L
} else {
as.integer(depth)
}
}

scope_in_openmp <- function(scope) {
scope_openmp_depth(scope) > 0L
}

enter_openmp_scope <- function(scope) {
if (!inherits(scope, "quickr_scope")) {
return(NULL)
}
previous_depth <- attr(scope, "openmp_depth", exact = TRUE)
depth <- scope_openmp_depth(scope)
attr(scope, "openmp_depth") <- depth + 1L
previous_depth
}

exit_openmp_scope <- function(scope, previous_depth) {
if (!inherits(scope, "quickr_scope")) {
return(invisible(NULL))
}
if (is.null(previous_depth)) {
attr(scope, "openmp_depth") <- NULL
} else {
attr(scope, "openmp_depth") <- as.integer(previous_depth)
}
invisible(TRUE)
}

openmp_abort <- function(message, class = "quickr_openmp_error") {
stop(
structure(
Expand Down
4 changes: 3 additions & 1 deletion R/quick.R
Original file line number Diff line number Diff line change
Expand Up @@ -447,7 +447,9 @@ check_all_var_names_valid <- function(fun) {
"c_ptrdiff_t",

# clashes with C bridge symbols
"int" #, "double",
"int", #, "double",
quickr_error_msg_name(),
quickr_error_setter_name()

# ??? (clashes with R symbols?)
# "double", "integer"
Expand Down
39 changes: 35 additions & 4 deletions R/r2f-closures.R
Original file line number Diff line number Diff line change
Expand Up @@ -467,9 +467,16 @@ compile_closure_call <- function(

call_args <- unname(args_f)
if (length(call_args)) {
return(Fortran(glue("call {proc$name}({str_flatten_commas(call_args)})")))
call_stmt <- glue("call {proc$name}({str_flatten_commas(call_args)})")
return(Fortran(str_flatten_lines(
call_stmt,
quickr_error_return_if_set(scope)
)))
}
return(Fortran(glue("call {proc$name}()")))
return(Fortran(str_flatten_lines(
glue("call {proc$name}()"),
quickr_error_return_if_set(scope)
)))
}

proc <- compile_local_closure_proc(
Expand All @@ -484,9 +491,16 @@ compile_closure_call <- function(
if (!needs_value && is.null(proc$res)) {
call_args <- unname(args_f)
if (length(call_args)) {
return(Fortran(glue("call {proc$name}({str_flatten_commas(call_args)})")))
call_stmt <- glue("call {proc$name}({str_flatten_commas(call_args)})")
return(Fortran(str_flatten_lines(
call_stmt,
quickr_error_return_if_set(scope)
)))
}
return(Fortran(glue("call {proc$name}()")))
return(Fortran(str_flatten_lines(
glue("call {proc$name}()"),
quickr_error_return_if_set(scope)
)))
}

res_var <- proc$res_var
Expand All @@ -497,6 +511,7 @@ compile_closure_call <- function(
tmp <- hoist$declare_tmp(mode = res_var@mode, dims = res_var@dims)
call_args <- c(unname(args_f), tmp@name)
call_stmt <- glue("call {proc$name}({str_flatten_commas(call_args)})")
call_stmt <- str_flatten_lines(call_stmt, quickr_error_return_if_set(scope))

if (needs_value) {
hoist$emit(call_stmt)
Expand Down Expand Up @@ -621,6 +636,7 @@ compile_closure_call_assignment <- function(
Fortran(glue(
"
call {proc$name}({str_flatten_commas(call_args)})
{quickr_error_return_if_set(scope)}
{str_flatten_lines(post)}
"
))
Expand Down Expand Up @@ -863,6 +879,19 @@ compile_sapply_assignment <- function(
if (!is.null(parallel)) {
mark_openmp_used(scope)
}
error_check_inner <- if (is.null(parallel)) {
quickr_error_return_if_set(scope)
} else {
""

Copy link
Copy Markdown

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

P2 Badge Cancel OpenMP sapply loops on error

When parallel is set, error_check_inner is deliberately empty, so the OpenMP sapply loop never checks quickr_err_msg inside the do region. Because compile_sapply_assignment() never calls enter_openmp_scope(), a stop() in the closure only calls quickr_set_error_msg and returns, and the parallel loop continues to run until completion; the error is only surfaced after the loop. This means OpenMP sapply() can keep executing with known-invalid inputs or side effects long after an error is raised, unlike parallel for loops where !$omp cancel do is triggered promptly. Consider inserting a cancellation check inside the loop for the parallel case or marking the OpenMP scope so stop() emits !$omp cancel do.

Useful? React with 👍 / 👎.

}
error_check_after <- if (!is.null(parallel)) {
quickr_error_return_if_set(
scope,
openmp_depth = scope_openmp_depth(scope) - 1L
)
} else {
""
}
loop_header <- glue("do {idx@name} = 1_c_int, {last_i}")
prefix <- str_flatten_lines(
if (!index_iterable) iterable_tmp_assign else NULL,
Expand All @@ -872,8 +901,10 @@ compile_sapply_assignment <- function(
"
{prefix}
call {proc_name}({call_args})
{error_check_inner}
end do
{str_flatten_lines(directives$suffix)}
{error_check_after}
{str_flatten_lines(post_stmts)}
"
))
Expand Down
Loading