[5/15] Validate subscripts and make in-loop errors cancel OpenMP loops

R/c-wrapper.R

@@ -459,6 +459,26 @@ c_bridge_hoist_take_pending <- function(hoist) {
   pending
 }
 
+c_bridge_hoist_seq_checks <- function(hoist, from, to, by) {
+  stopifnot(
+    is.environment(hoist),
+    is_string(from),
+    is_string(to),
+    is_string(by)
+  )
+  hoist$pending <- c(
+    hoist$pending,
+    glue(
+      '
+      if (({from} != {to}) && ({by} == 0))
+        Rf_error("invalid \'(to - from)/by\'");
+      if ((({from} < {to}) && ({by} < 0)) ||
+          (({from} > {to}) && ({by} > 0)))
+        Rf_error("wrong sign in \'by\' argument");'
+    )
+  )
+}
+
 
 as_c_name <- function(var, c_hoist = NULL) {
   stopifnot(inherits(var, Variable))
@@ -582,6 +602,23 @@ dims2c_expr <- function(e, scope, c_hoist = NULL) {
     return(dims2c_dim_index_expr(call("[", call("dim", args[[1L]]), 2L), scope))
   }
 
+  if (identical(op, "quickr_seq_length")) {
+    if (length(args) != 3L || is.null(c_hoist)) {
+      stop("quickr_seq_length() requires three arguments and a C bridge hoist")
+    }
+    from <- dims2c_expr(args[[1L]], scope, c_hoist = c_hoist)
+    to <- dims2c_expr(args[[2L]], scope, c_hoist = c_hoist)
+    by <- dims2c_expr(args[[3L]], scope, c_hoist = c_hoist)
+    c_bridge_hoist_seq_checks(c_hoist, from, to, by)
+
+    safe_by <- glue("(({by}) == 0 ? 1 : ({by}))")
+    delta <- glue("((R_xlen_t)({to}) - (R_xlen_t)({from}))")
+    quotient <- glue("({delta} / (R_xlen_t)({safe_by}))")
+    return(glue(
+      "((({quotient}) < 0 ? -({quotient}) : ({quotient})) + 1)"
+    ))
+  }
+
   if (identical(op, "abs")) {
     if (length(args) != 1L) {
       stop("abs() expects one argument")

R/declare.R

@@ -18,6 +18,15 @@
 #' and `OMP_DYNAMIC` (disable/enable runtime adjustment). Set them before
 #' calling a compiled function, e.g. `Sys.setenv(OMP_NUM_THREADS = "4")`.
 #'
+#' When an error is raised inside a parallel loop, quickr cancels the
+#' remaining iterations via OpenMP cancellation, which the OpenMP runtime
+#' only honors when `OMP_CANCELLATION=true` is set before the runtime first
+#' initializes in the process. quickr sets it when the package loads (unless
+#' already set), but this has no effect if another package initialized the
+#' OpenMP runtime first. Early exit is best-effort either way: the error
+#' message is always recorded correctly; without cancellation the remaining
+#' iterations simply run to completion before the error is raised.
+#'
 #' @param ... Declarations, typically calls like `type(x = double(n))`.
 #' @returns `NULL`, invisibly.
 #' @rawNamespace if (getRversion() < "4.4.0") export(declare)

R/error-handling.R

@@ -112,6 +112,32 @@ quickr_error_fortran_lines <- function(message = NULL, scope = NULL) {
   lines
 }
 
+# Emit a runtime guard: if `condition` holds, record a quickr error and
+# bail out of the subroutine (or cancel the OpenMP loop). Statement-level
+# machinery shared by any handler that needs a runtime check.
+emit_quickr_error_if <- function(
+  condition,
+  message,
+  hoist,
+  scope
+) {
+  stopifnot(
+    is_string(condition),
+    is_string(message),
+    inherits(hoist, "environment"),
+    inherits(scope, "quickr_scope")
+  )
+  mark_scope_uses_errors(scope)
+  err_lines <- quickr_error_fortran_lines(message, scope = scope)
+  hoist$emit(glue(
+    "
+    if ({condition}) then
+    {indent(str_flatten_lines(err_lines))}
+    end if
+    "
+  ))
+}
+
 quickr_error_return_if_set <- function(
   scope,
   openmp_depth = scope_openmp_depth(scope)

R/manifest.R

@@ -522,6 +522,10 @@ dims2f_eval_base_env[["%%"]] <- function(e1, e2) {
 }
 dims2f_eval_base_env[["^"]] <- function(e1, e2) glue("({e1})**({e2})")
 dims2f_eval_base_env[["abs"]] <- function(x) glue("abs({x})")
+dims2f_eval_base_env[["quickr_seq_length"]] <- function(from, to, by) {
+  safe_by <- glue("merge(int({by}), 1, int({by}) /= 0)")
+  glue("(abs((int({to}) - int({from})) / {safe_by}) + 1)")
+}
 dims2f_eval_base_env[["length"]] <- function(x) {
   if (is.symbol(x)) {
     glue("size({as.character(x)})")

R/r2f-closures.R

@@ -1389,6 +1389,11 @@ compile_subset_designator <- function(
     is_bool(allow_logical_vector_subscripts)
   )
 
+  # Same validation as the read-side `[` handler: assignment subscripts
+  # would otherwise lower R's exclusion/zero/out-of-range subscripts into
+  # silent out-of-bounds Fortran writes.
+  check_subscript_exprs(base_var, idx_args)
+
   idxs <- whole_doubles_to_ints(idx_args)
   idxs <- imap(idxs, function(idx, i) {
     if (is_missing(idx)) {

R/r2f-control-flow.R

@@ -77,7 +77,7 @@ r2f_handlers[["while"]] <- function(args, scope, ...) {
 }
 
 # ---- for ----
-r2f_handlers[["for"]] <- function(args, scope, ...) {
+r2f_handlers[["for"]] <- function(args, scope, ..., hoist = NULL) {
   .[var, iterable, body] <- args
   stopifnot(is.symbol(var))
   var <- as.character(var)
@@ -174,7 +174,10 @@ r2f_handlers[["for"]] <- function(args, scope, ...) {
       previous_openmp <- enter_openmp_scope(scope)
       on.exit(exit_openmp_scope(scope, previous_openmp), add = TRUE)
     }
-    body <- r2f(body, scope, ...)
+    # The body is a distinct execution region and needs its own hoist target.
+    # Otherwise a single-expression body reuses the enclosing statement's
+    # target and emits loop-dependent setup before the loop.
+    body <- r2f(body, scope, ..., hoist = NULL)
     check_pending_parallel_consumed(scope)
     loop_stmts <- str_flatten_lines(glue("{var_name} = {element_expr}"), body)
 
@@ -214,12 +217,14 @@ r2f_handlers[["for"]] <- function(args, scope, ...) {
   }
   scope[[var]] <- loop_var
 
-  iterable <- r2f_for_iterable(iterable, scope, ...)
+  iterable <- r2f_for_iterable(iterable, scope, ..., hoist = hoist)
   if (!is.null(parallel)) {
     previous_openmp <- enter_openmp_scope(scope)
     on.exit(exit_openmp_scope(scope, previous_openmp), add = TRUE)
   }
-  body <- r2f(body, scope, ...)
+  # See the value-iteration path above: body-local setup must run inside the
+  # loop even when the R body is not wrapped in braces.
+  body <- r2f(body, scope, ..., hoist = NULL)
   check_pending_parallel_consumed(scope)
 
   directives <- openmp_directives(parallel)

R/r2f-iterables-helpers.R

@@ -46,7 +46,11 @@ seq_like_length_expr <- function(from, to, by = NULL) {
     return(1L)
   }
 
-  if (is_scalar_integerish(from) && is_scalar_integerish(to)) {
+  if (
+    is_scalar_integerish(from) &&
+      is_scalar_integerish(to) &&
+      (is.null(by) || is_scalar_integerish(by)) # symbolic by: length needs it
+  ) {
     from_val <- as.integer(from)
     to_val <- as.integer(to)
     delta <- to_val - from_val
@@ -72,7 +76,39 @@ seq_like_length_expr <- function(from, to, by = NULL) {
   if (is.null(by)) {
     return(call("+", call("abs", call("-", to, from)), 1L))
   }
-  call("+", call("abs", call("%/%", call("-", to, from), by)), 1L)
+  call("quickr_seq_length", from, to, by)
+}
+
+seq_like_step_needs_runtime_check <- function(info) {
+  !is.null(info$by) &&
+    !(is_scalar_integerish(info$from) &&
+      is_scalar_integerish(info$to) &&
+      is_scalar_integerish(info$by))
+}
+
+emit_seq_step_runtime_checks <- function(from, to, by, hoist, scope) {
+  stopifnot(
+    inherits(from, Fortran),
+    inherits(to, Fortran),
+    inherits(by, Fortran),
+    inherits(hoist, "environment"),
+    inherits(scope, "quickr_scope")
+  )
+  emit_quickr_error_if(
+    glue("({from} /= {to}) .and. ({by} == 0_c_int)"),
+    "invalid '(to - from)/by'",
+    hoist,
+    scope
+  )
+  emit_quickr_error_if(
+    glue(
+      "(({to} > {from}) .and. ({by} < 0_c_int)) .or. ",
+      "(({to} < {from}) .and. ({by} > 0_c_int))"
+    ),
+    "wrong sign in 'by' argument",
+    hoist,
+    scope
+  )
 }
 
 # Parse a seq-like call into its components.
@@ -249,6 +285,24 @@ seq_like_r2f <- function(
     context <- "value"
   }
 
+  check_step_at_runtime <- kind == "seq" &&
+    seq_like_step_needs_runtime_check(info)
+  if (check_step_at_runtime && context != "[") {
+    emit_seq_step_runtime_checks(
+      from,
+      to,
+      by,
+      hoist = list(...)$hoist,
+      scope = scope
+    )
+  }
+  if (check_step_at_runtime) {
+    by <- Fortran(
+      glue("merge(int({by}, kind=c_int), 1_c_int, {from} /= {to})"),
+      Variable("integer")
+    )
+  }
+
   if (is.null(len_expr) || is_scalar_na(len_expr)) {
     len_expr <- NA_integer_
   }
@@ -280,6 +334,18 @@ seq_like_r2f <- function(
       glue("{start}, {end}, {step}")
     }
   } else if (context == "[") {
+    # Validate statically-known unsupported bounds and seq() step semantics.
+    # Dynamically computed array bounds remain the caller's responsibility.
+    if (kind %in% c(":", "seq")) {
+      check_subscript_range_bounds(
+        info,
+        from,
+        to,
+        by_f = by,
+        hoist = list(...)$hoist,
+        scope = scope
+      )
+    }
     fr <- if (omit_step) {
       glue("{start}:{end}")
     } else {
@@ -297,6 +363,77 @@ seq_like_r2f <- function(
   Fortran(fr, val)
 }
 
+# Validate an x[a:b] / x[seq(a, b, by)] index range where doing so has no
+# general bounds-checking cost. Statically bad literal bounds are compile
+# errors. Dynamic bounds are trusted, consistently with symbolic scalar and
+# vector subscripts. An explicit seq() step is handled below (literal-only,
+# plus a runtime wrong-sign check required by seq() semantics).
+# Used by: seq_like_r2f() (subscript context)
+check_subscript_range_bounds <- function(info, from, to, by_f, hoist, scope) {
+  lit <- function(e) {
+    e <- unwrap_parens(e)
+    if (is_scalar_integerish(e)) as.integer(e) else NA_integer_
+  }
+  from_lit <- lit(info$from)
+  to_lit <- lit(info$to)
+  by_lit <- if (is.null(info$by)) 1L else lit(info$by)
+  same_endpoint <- identical(
+    unwrap_parens(info$from),
+    unwrap_parens(info$to)
+  )
+
+  bounds_msg <- "index ranges in x[a:b] must have bounds >= 1"
+  if (isTRUE(from_lit < 1L) || isTRUE(to_lit < 1L)) {
+    stop(
+      bounds_msg,
+      ": ",
+      deparse1(info$from),
+      ", ",
+      deparse1(info$to),
+      call. = FALSE
+    )
+  }
+
+  emit <- function(condition, message) {
+    if (is.null(hoist)) {
+      stop(
+        "cannot emit a runtime subscript-range guard here; ",
+        "use literal bounds >= 1 in x[a:b]",
+        call. = FALSE
+      )
+    }
+    emit_quickr_error_if(condition, message, hoist, scope)
+  }
+
+  # Explicit seq() step. When the endpoints differ, the result length divides
+  # by the step, and that length is evaluated in the C bridge *before* any
+  # Fortran guard can run (a zero step would be a division-by-zero crash
+  # there), so a non-literal step is a compile error, not a guard. With a
+  # literal step and symbolic bounds, R errors when the step's sign opposes
+  # the direction -- the emitted section would be zero-length while the
+  # claimed length is not; that case is checkable at runtime. All-literal
+  # ranges were already validated by seq_like_length_expr() at compile time.
+  if (!is.null(info$by) && !same_endpoint) {
+    if (is.na(by_lit)) {
+      stop(
+        "seq() in x[...] requires a literal `by` step ",
+        "(the result length depends on it): by = ",
+        deparse1(info$by),
+        call. = FALSE
+      )
+    }
+    if (is.na(from_lit) || is.na(to_lit)) {
+      emit(
+        glue(
+          "(({to} /= {from}) .and. (sign(1_c_int, {by_f}) /= sign(1_c_int, {to} - {from})))"
+        ),
+        "wrong sign in 'by' argument in x[seq(a, b, by)]"
+      )
+    }
+  }
+  invisible(NULL)
+}
+
 # Unwrap a for-loop iterable, handling rev() calls.
 # Used by: r2f-control-flow.R
 r2f_unwrap_for_iterable <- function(iterable) {

R/r2f-matrix-blas.R

@@ -74,29 +74,6 @@ assert_conformable_dims <- function(left, right, context, err_msg) {
   invisible(TRUE)
 }
 
-emit_quickr_error_if <- function(
-  condition,
-  message,
-  hoist,
-  scope
-) {
-  stopifnot(
-    is_string(condition),
-    is_string(message),
-    inherits(hoist, "environment"),
-    inherits(scope, "quickr_scope")
-  )
-  mark_scope_uses_errors(scope)
-  err_lines <- quickr_error_fortran_lines(message, scope = scope)
-  hoist$emit(glue(
-    "
-    if ({condition}) then
-    {indent(str_flatten_lines(err_lines))}
-    end if
-    "
-  ))
-}
-
 # Return the R symbol name if operand is a bare symbol; otherwise NULL.
 symbol_name_or_null <- function(x) {
   stopifnot(inherits(x, Fortran))