diff --git a/.Rbuildignore b/.Rbuildignore index 6f490cce..65f7b192 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -12,3 +12,4 @@ ^scripts$ ^AGENTS.md$ ^CRAN-SUBMISSION$ +^doc$ diff --git a/NEWS.md b/NEWS.md index 3b831d45..0a44a795 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,9 @@ The plan is to add more functions in the future (#77 @mns-nordicals) +- Added support for `cbind()` and `rbind()` for rank-0/1/2 inputs, with scalar + recycling only and strict length checks for non-scalar inputs. + - On macOS, quickr will use LLVM flang (`flang-new`) for compilation when available (e.g. `brew install flang`). This is optional and can be disabled with `options(quickr.prefer_flang = FALSE)`. diff --git a/R/classes.R b/R/classes.R index ddd91419..c046adc1 100644 --- a/R/classes.R +++ b/R/classes.R @@ -389,8 +389,6 @@ FortranSubroutine := new_class( ) ) -`%error%` <- function(x, y) tryCatch(x, error = function(e) y) - try_prop <- function(object, name) S7::prop(object, name) %error% NULL emit <- function(..., sep = "", end = "\n") cat(..., end, sep = sep) diff --git a/R/compiler.R b/R/compiler.R index d4464ee2..bac85633 100644 --- a/R/compiler.R +++ b/R/compiler.R @@ -10,6 +10,73 @@ quickr_flang_path <- function(which = Sys.which) { "" } +quickr_flang_available <- function( + which = Sys.which, + system2 = base::system2 +) { + flang <- quickr_flang_path(which = which) + if (!nzchar(flang)) { + return(list(path = "", available = FALSE)) + } + probe <- tryCatch( + system2(flang, "--version", stdout = TRUE, stderr = TRUE), + error = function(e) structure(character(), status = 1L) + ) + if (!is.null(attr(probe, "status"))) { + return(list(path = flang, available = FALSE)) + } + list(path = flang, available = TRUE) +} + +quickr_flang_state <- local({ + state <- new.env(parent = emptyenv()) + state$auto_disabled <- FALSE + state$fallback_warned <- FALSE + state +}) + +quickr_flang_auto_disabled <- function(state = quickr_flang_state) { + isTRUE(state$auto_disabled) +} + +quickr_disable_flang_auto <- function(state = quickr_flang_state) { + state$auto_disabled <- TRUE + invisible(state$auto_disabled) +} + +quickr_warn_flang_fallback_once <- function(state = quickr_flang_state) { + if (isTRUE(state$fallback_warned)) { + return(invisible(TRUE)) + } + warning( + paste( + "flang compilation failed; falling back to gfortran and disabling", + "automatic flang preference for this session." + ), + call. = FALSE + ) + state$fallback_warned <- TRUE + invisible(TRUE) +} + +quickr_compiler_warning_state <- local({ + state <- new.env(parent = emptyenv()) + state$warned <- FALSE + state +}) + +quickr_warn_compiler_failure_once <- function( + message, + state = quickr_compiler_warning_state +) { + if (isTRUE(state$warned)) { + return(invisible(TRUE)) + } + warning(message, call. = FALSE) + state$warned <- TRUE + invisible(TRUE) +} + quickr_flang_runtime_flags <- local({ cache <- NULL @@ -50,37 +117,55 @@ quickr_flang_runtime_flags <- local({ } }) -quickr_env_is_true <- function(name) { - val <- Sys.getenv(name, unset = "") - if (!nzchar(val)) { - return(FALSE) +quickr_fortran_compiler_option <- function( + opt = getOption("quickr.fortran_compiler") +) { + if (is.null(opt)) { + return(NULL) + } + if (!is_string(opt)) { + stop( + "`options(quickr.fortran_compiler)` must be a single string.", + call. = FALSE + ) + } + opt <- tolower(trimws(opt)) + if (!nzchar(opt) || opt %in% c("auto", "default", "system")) { + return(NULL) + } + if (opt %in% c("flang", "flang-new")) { + return("flang") } - tolower(val) %in% c("1", "true", "t", "yes", "y", "on") + if (opt %in% c("gfortran", "gnu")) { + return("gfortran") + } + stop( + "`options(quickr.fortran_compiler)` must be one of ", + "\"flang\", \"gfortran\", or \"auto\".", + call. = FALSE + ) } quickr_prefer_flang <- function( sysname = Sys.info()[["sysname"]], - which = Sys.which + which = Sys.which, + system2 = base::system2 ) { - opt <- getOption("quickr.prefer_flang") - if (isFALSE(opt)) { - return(FALSE) - } - if (quickr_env_is_true("QUICKR_PREFER_FLANG")) { + compiler_opt <- quickr_fortran_compiler_option() + if (identical(compiler_opt, "flang")) { return(TRUE) } - if (isTRUE(getOption("quickr.prefer_flang_force"))) { - return(TRUE) + if (identical(compiler_opt, "gfortran")) { + return(FALSE) } - if (interactive() && isTRUE(opt)) { - return(TRUE) + if (quickr_flang_auto_disabled()) { + return(FALSE) } # Best-effort: on macOS, prefer flang if it is available. - if ( - isTRUE(getOption("quickr.prefer_flang_auto", TRUE)) && sysname == "Darwin" - ) { - return(nzchar(quickr_flang_path(which = which))) + if (sysname == "Darwin") { + info <- quickr_flang_available(which = which, system2 = system2) + return(isTRUE(info$available)) } FALSE @@ -89,9 +174,7 @@ quickr_prefer_flang <- function( quickr_fcompiler_env <- function( build_dir, which = Sys.which, - prefer_flang = quickr_prefer_flang(which = which), - prefer_flang_force = isTRUE(getOption("quickr.prefer_flang_force")) || - quickr_env_is_true("QUICKR_PREFER_FLANG"), + system2 = base::system2, write_lines = writeLines, sysname = Sys.info()[["sysname"]], use_openmp = FALSE, @@ -101,17 +184,32 @@ quickr_fcompiler_env <- function( use_openmp <- isTRUE(use_openmp) link_flags <- link_flags[nzchar(link_flags)] + compiler_opt <- quickr_fortran_compiler_option() + explicit_request <- identical(compiler_opt, "flang") flang <- "" flang_runtime <- character() - use_flang <- isTRUE(prefer_flang) + use_flang <- isTRUE(quickr_prefer_flang( + sysname = sysname, + which = which, + system2 = system2 + )) if (use_flang) { - flang <- quickr_flang_path(which = which) - if (!nzchar(flang)) { + flang_info <- quickr_flang_available(which = which, system2 = system2) + flang <- flang_info$path + if (!isTRUE(flang_info$available)) { + if (isTRUE(explicit_request)) { + stop( + "quickr was configured to use flang, but flang was not available or could not be executed.\n", + "Ensure flang is on your PATH and that `flang --version` succeeds, or switch compilers with:\n", + " options(quickr.fortran_compiler = \"gfortran\")\n" + ) + } use_flang <- FALSE + flang <- "" } } - if (use_openmp && use_flang && !isTRUE(prefer_flang_force)) { + if (use_openmp && use_flang && !isTRUE(explicit_request)) { use_flang <- FALSE flang <- "" } @@ -122,15 +220,13 @@ quickr_fcompiler_env <- function( character() } if (sysname == "Darwin" && !length(flang_runtime)) { - if (isTRUE(prefer_flang_force)) { + if (isTRUE(explicit_request)) { stop( "quickr was configured to use flang (", flang, ") but could not locate the flang runtime library (libflang_rt.runtime.dylib) to link against.\n", - "Either reinstall flang so the runtime is available, or disable flang selection with:\n", - " options(quickr.prefer_flang = FALSE)\n", - "or:\n", - " Sys.setenv(QUICKR_PREFER_FLANG = 0)\n" + "Either reinstall flang so the runtime is available, or switch compilers with:\n", + " options(quickr.fortran_compiler = \"gfortran\")\n" ) } use_flang <- FALSE diff --git a/R/preprocess-lang.R b/R/preprocess-lang.R index 35eae931..5aa60959 100644 --- a/R/preprocess-lang.R +++ b/R/preprocess-lang.R @@ -75,13 +75,3 @@ whole_doubles_to_ints <- function(x) { } walker(x) } - -substitute_unique_case_insensitive_symbols <- function(x) { - # TODO: would be nice to fix case-insenstive name clashes - # with automatic substitutions. Would be a little involved since - # substitute will not replace tag names in a call, e.g., - # declare(type( = ...)), NAME would need to be manually replaced. - stopifnot(is.function(x)) - nms <- unique(c(all.names(body(x), names(formals(x))))) - stop("not yet implemented") -} diff --git a/R/quick.R b/R/quick.R index 0abc4af6..6474a096 100644 --- a/R/quick.R +++ b/R/quick.R @@ -108,18 +108,21 @@ #' quickr compiles via `R CMD SHLIB` and will normally use the same toolchain #' that R was built/configured with. #' -#' On macOS, quickr will speculatively prefer LLVM flang when it is available on -#' `PATH` (falling back to R's default toolchain if compilation fails). +#' quickr only uses LLVM flang when it is explicitly requested or, on macOS, +#' when flang is available on `PATH` (and `flang --version` succeeds). If flang +#' is requested but unavailable, compilation errors. If flang compilation +#' fails, quickr retries with the default toolchain; on success it emits a +#' one-time warning and disables automatic flang preference for the rest of the +#' session. #' #' In interactive use, you can explicitly control this with: #' #' ```r -#' options(quickr.prefer_flang = TRUE) +#' options(quickr.fortran_compiler = "flang") #' ``` #' -#' To disable the macOS auto-preference, set `options(quickr.prefer_flang_auto = FALSE)` -#' (or set `options(quickr.prefer_flang = FALSE)` to opt out entirely). -#' In non-interactive scripts, set `Sys.setenv(QUICKR_PREFER_FLANG = "1")`. +#' To disable the macOS auto-preference, set +#' `options(quickr.fortran_compiler = "gfortran")`. #' #' @returns A quicker R function. #' @export @@ -252,6 +255,8 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) { ) if (is.null(attr(result2, "status"))) { result <- result2 + quickr_disable_flang_auto() + quickr_warn_flang_fallback_once() } else { # Prefer to show the flang attempt first, then the fallback attempt. result <- c( @@ -271,8 +276,12 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) { # Adjust the compiler error so RStudio console formatter doesn't mangle # the actual error message https://github.com/rstudio/rstudio/issues/16365 result <- gsub("Error: ", "Compiler Error: ", result, fixed = TRUE) - writeLines(result, stderr()) - cat("---\nCompiler exit status:", status, "\n", file = stderr()) + quickr_warn_compiler_failure_once( + paste( + c(result, "---", sprintf("Compiler exit status: %s", status)), + collapse = "\n" + ) + ) if (use_openmp) { openmp_abort( paste( diff --git a/R/r2f-aaa-registry.R b/R/r2f-aaa-registry.R new file mode 100644 index 00000000..3a171d2d --- /dev/null +++ b/R/r2f-aaa-registry.R @@ -0,0 +1,26 @@ +# Handler registry and registration helpers. + +r2f_handlers <- new.env(parent = emptyenv()) + +## ??? export as S7::convert() methods? +register_r2f_handler <- function( + name, + fun, + dest_supported = NULL, + dest_infer = NULL, + match_fun = TRUE +) { + if (!is.null(dest_supported)) { + attr(fun, "dest_supported") <- dest_supported + } + if (!is.null(dest_infer)) { + attr(fun, "dest_infer") <- dest_infer + } + if (!is.null(match_fun) && !isTRUE(match_fun)) { + attr(fun, "match.fun") <- match_fun + } + for (nm in name) { + r2f_handlers[[nm]] <- fun + } + invisible(fun) +} diff --git a/R/r2f-assign.R b/R/r2f-assign.R new file mode 100644 index 00000000..bc320abb --- /dev/null +++ b/R/r2f-assign.R @@ -0,0 +1,332 @@ +# Assignment-related r2f handlers and helpers + +assignment_dispatch_call_target <- function( + target, + args, + scope, + ..., + hoist, + assign_op +) { + if (!is.call(target)) { + return(NULL) + } + target_callable <- target[[1L]] + stopifnot(is.symbol(target_callable)) + name <- as.symbol(paste0(as.character(target_callable), assign_op)) + handler <- get_r2f_handler(name) + handler(args, scope, ..., hoist = hoist) +} + +assignment_extract_fallthrough <- function(rhs) { + rhs_unwrapped <- rhs + while (is_call(rhs_unwrapped, "(") && length(rhs_unwrapped) == 2L) { + rhs_unwrapped <- rhs_unwrapped[[2L]] + } + if ( + (is_call(rhs_unwrapped, "<-") || is_call(rhs_unwrapped, "=")) && + length(rhs_unwrapped) == 3L && + is.symbol(rhs_unwrapped[[2L]]) + ) { + return(list( + target = rhs_unwrapped[[2L]], + rhs = rhs_unwrapped[[3L]] + )) + } + NULL +} + +assignment_fortran_name <- function(name, scope) { + stopifnot(is_string(name)) + if (scope_is_closure(scope) && inherits(get0(name, scope), Variable)) { + make_shadow_fortran_name(scope, name) + } else { + name + } +} + +assignment_is_local_closure_call <- function(rhs, scope) { + is.call(rhs) && + is.symbol(rhs[[1L]]) && + inherits(scope[[as.character(rhs[[1L]])]], LocalClosure) +} + +register_r2f_handler( + "<-", + function(args, scope, ..., hoist = NULL) { + target <- args[[1L]] + if ( + !is.null( + out <- assignment_dispatch_call_target( + target, + args, + scope, + ..., + hoist = hoist, + assign_op = "<-" + ) + ) + ) { + return(out) + } + + # It sure seems like it's be nice if the Fortran() constructor + # took mode and dims as args directly, + # without needing to go through Variable... + stopifnot(is.symbol(target)) + name <- as.character(target) + + rhs <- args[[2L]] + + # Fall-through assignment: `a <- b <- expr` (or `a <- (b <- expr)`). + # R evaluates this right-to-left and returns the assigned value, i.e. + # `a <- (b <- expr)` is equivalent to `b <- expr; a <- b`. + if (!is.null(fallthrough <- assignment_extract_fallthrough(rhs))) { + inner_stmt <- r2f( + call("<-", fallthrough$target, fallthrough$rhs), + scope, + ..., + hoist = hoist + ) + outer_stmt <- r2f( + call("<-", target, fallthrough$target), + scope, + ..., + hoist = hoist + ) + return(Fortran(str_flatten_lines(inner_stmt, outer_stmt))) + } + + # Local closure definition: `f <- function(i) ...` + if (is_function_call(rhs)) { + scope[[name]] <- as_local_closure( + rhs, + environment(scope@closure), + name = name + ) + return(Fortran("")) + } + + # Local closure call: `x <- f(...)` where `f <- function(...) ...` in scope. + if (assignment_is_local_closure_call(rhs, scope)) { + return(compile_closure_call_assignment( + name, + rhs, + scope, + ..., + hoist = hoist + )) + } + + # Targeted higher-order lowering: `out <- sapply(seq_along(x), f)` + if (is_sapply_call(rhs)) { + parallel <- take_pending_parallel(scope) + return( + compile_sapply_assignment( + name, + rhs, + scope, + ..., + hoist = hoist, + parallel = parallel + ) + ) + } + + dest_allowed <- dest_supported_for_call(rhs) + + # If target already exists (declared), thread destination hint to a single BLAS-capable child + var <- get0(name, scope, inherits = FALSE) + existing_binding <- !is.null(var) && inherits(var, Variable) + inferred_var <- NULL + fortran_name <- NULL + if (!existing_binding && dest_allowed) { + inferred_var <- dest_infer_for_call(rhs, scope) + fortran_name <- assignment_fortran_name(name, scope) + } + + if (existing_binding) { + value <- if (dest_allowed) { + r2f(rhs, scope, ..., hoist = hoist, dest = var) + } else { + r2f(rhs, scope, ..., hoist = hoist) + } + } else if (inherits(inferred_var, Variable)) { + var <- inferred_var + var@name <- fortran_name + value <- r2f(rhs, scope, ..., hoist = hoist, dest = var) + } else { + value <- r2f(rhs, scope, ..., hoist = hoist) + } + + # immutable / copy-on-modify usage of Variable() + if (!existing_binding) { + # The var does not exist -> this is a binding to a new symbol + # Create a fresh Variable carrying only mode/dims and a new name. + if (!inherits(var, Variable)) { + src <- value@value + var <- Variable(mode = src@mode, dims = src@dims) + } + if (is.null(fortran_name)) { + fortran_name <- assignment_fortran_name(name, scope) + } + var@name <- fortran_name + # keep a reference to the R expression assigned, if available + tryCatch( + var@r <- attr(value, "r", TRUE), + error = function(e) NULL + ) + scope[[name]] <- var + } else { + # The var already exists, this assignment is a modification / reassignment + check_assignment_compatible(var, value@value) + var@modified <- TRUE + # could probably drop this @modified property, and instead track + # if the var populated by declare is identical at the end (e.g., perhaps by + # address, or by attaching a unique id to each var, or ???) + assign(name, var, scope) + } + + # If child consumed destination (e.g., BLAS wrote directly into LHS), skip assignment + if (isTRUE(attr(value, "writes_to_dest", TRUE))) { + Fortran("") + } else { + Fortran(glue("{var@name} = {value}")) + } + } +) + +register_r2f_handler( + "[<-", + function(args, scope = NULL, ...) { + # TODO: handle logical subsetting here, which must become a where a construct like: + # x[lgl] <- val + # becomes + # where (lgl) + # x = val + # end where + # ! but if {va} references {x}, it will only see the subset x, not the full {x} + # e.g., + # sum(x) is not the same as `where lgl \n sum(x) \n end where` + # ditto for ifelse() ? + # e <- as.list(e) + + stopifnot(is_call(target_call <- args[[1L]], "[")) + + lhs <- compile_subscript_lhs(target_call, scope, ..., target = "local") + value <- r2f(args[[2L]], scope, ...) + + Fortran(str_flatten_lines(lhs$pre, glue("{lhs$lhs} = {value}"))) + } +) + +register_r2f_handler( + "<<-", + function(args, scope, ..., hoist = NULL) { + if (is.null(scope) || !identical(scope@kind, "closure")) { + stop("<<- is only supported inside local closures") + } + + target <- args[[1L]] + if ( + !is.null( + out <- assignment_dispatch_call_target( + target, + args, + scope, + ..., + hoist = hoist, + assign_op = "<<-" + ) + ) + ) { + return(out) + } + + stopifnot(is.symbol(target)) + name <- as.character(target) + + formal_names <- names(formals(scope@closure)) %||% character() + if (name %in% formal_names) { + stop("<<- targets must not shadow closure formals: ", name) + } + + forbidden <- attr(scope, "forbid_superassign", exact = TRUE) %||% + character() + if (name %in% forbidden) { + stop("closure must not superassign to its output variable: ", name) + } + + host_scope <- scope@host_scope %||% + stop("internal error: missing host scope") + host_var <- get0(name, host_scope) + if (!inherits(host_var, Variable)) { + stop( + "<<- targets must resolve to an existing variable in the enclosing quick() scope: ", + name + ) + } + + host_var@modified <- TRUE + host_scope[[name]] <- host_var + + value <- r2f(args[[2L]], scope, ..., hoist = hoist) + check_assignment_compatible(host_var, value@value) + + Fortran(glue("{host_var@name} = {value}")) + } +) + +register_r2f_handler( + "[<<-", + function(args, scope, ..., hoist = NULL) { + if (is.null(scope) || !identical(scope@kind, "closure")) { + stop("<<- is only supported inside local closures") + } + + stopifnot(is_call(target <- args[[1L]], "[")) + subset_call <- target + + base <- subset_call[[2L]] + if (!is.symbol(base)) { + stop("only superassignment to x[...] is supported") + } + name <- as.character(base) + + formal_names <- names(formals(scope@closure)) %||% character() + if (name %in% formal_names) { + stop("<<- targets must not shadow closure formals: ", name) + } + + forbidden <- attr(scope, "forbid_superassign", exact = TRUE) %||% + character() + if (name %in% forbidden) { + stop("closure must not superassign to its output variable: ", name) + } + + host_scope <- scope@host_scope %||% + stop("internal error: missing host scope") + host_var <- get0(name, host_scope) + if (!inherits(host_var, Variable)) { + stop( + "<<- targets must resolve to an existing variable in the enclosing quick() scope: ", + name + ) + } + + host_var@modified <- TRUE + host_scope[[name]] <- host_var + + lhs <- compile_subscript_lhs( + subset_call, + scope, + ..., + hoist = hoist, + target = "host" + ) + value <- r2f(args[[2L]], scope, ..., hoist = hoist) + Fortran(glue("{lhs$lhs} = {value}")) + } +) + +register_r2f_handler("=", r2f_handlers[["<-"]]) diff --git a/R/r2f-closures.R b/R/r2f-closures.R index 018383ed..4bc4b31e 100644 --- a/R/r2f-closures.R +++ b/R/r2f-closures.R @@ -372,6 +372,57 @@ closure_formal_vars <- function(args_f, formal_names) { formal_vars } +match_closure_call_args <- function( + call_expr, + closure_obj, + scope, + ..., + hoist = NULL +) { + stopifnot(is.call(call_expr), inherits(closure_obj, LocalClosure)) + fun <- closure_obj@fun + call_expr <- match.call(fun, call_expr) + args_expr <- as.list(call_expr)[-1L] + + formal_names <- names(formals(fun)) %||% character() + if (!identical((names(args_expr) %||% character()), formal_names)) { + stop("internal error: match.call did not align closure args") + } + + args_f <- lapply(args_expr, r2f, scope, ..., hoist = hoist) + formal_vars <- closure_formal_vars(args_f, formal_names) + + list( + call_expr = call_expr, + args_expr = args_expr, + args_f = args_f, + formal_names = formal_names, + formal_vars = formal_vars + ) +} + +compile_local_closure_proc <- function( + proc_name, + closure_obj, + scope, + formal_vars, + res_var, + allow_void_return = FALSE, + forbid_superassign = character() +) { + proc <- compile_internal_subroutine( + proc_name, + closure_obj, + scope, + formal_vars = formal_vars, + res_var = res_var, + allow_void_return = allow_void_return, + forbid_superassign = forbid_superassign + ) + scope_root(scope)@add_internal_proc(proc) + proc +} + compile_closure_call <- function( call_expr, closure_obj, @@ -390,32 +441,29 @@ compile_closure_call <- function( is_bool(needs_value) ) - fun <- closure_obj@fun - call_expr <- match.call(fun, call_expr) - args_expr <- as.list(call_expr)[-1L] - - formal_names <- names(formals(fun)) %||% character() - if (!identical((names(args_expr) %||% character()), formal_names)) { - stop("internal error: match.call did not align closure args") - } - - args_f <- lapply(args_expr, r2f, scope, ..., hoist = hoist) - formal_vars <- closure_formal_vars(args_f, formal_names) + call_info <- match_closure_call_args( + call_expr, + closure_obj, + scope, + ..., + hoist = hoist + ) + args_f <- call_info$args_f + formal_vars <- call_info$formal_vars - last_expr <- closure_last_expr(fun) + last_expr <- closure_last_expr(closure_obj@fun) if (is.null(last_expr)) { if (needs_value) { stop("local closure calls that return `NULL` cannot be used as values") } - proc <- compile_internal_subroutine( + proc <- compile_local_closure_proc( proc_name, closure_obj, scope, formal_vars = formal_vars, res_var = NULL ) - scope_root(scope)@add_internal_proc(proc) call_args <- unname(args_f) if (length(call_args)) { @@ -424,7 +472,7 @@ compile_closure_call <- function( return(Fortran(glue("call {proc$name}()"))) } - proc <- compile_internal_subroutine( + proc <- compile_local_closure_proc( proc_name, closure_obj, scope, @@ -432,7 +480,6 @@ compile_closure_call <- function( res_var = Variable(), allow_void_return = !needs_value ) - scope_root(scope)@add_internal_proc(proc) if (!needs_value && is.null(proc$res)) { call_args <- unname(args_f) @@ -484,19 +531,13 @@ compile_closure_call_assignment <- function( target_var <- get0(target_name, scope) target_exists <- inherits(target_var, Variable) - fun <- closure_obj@fun - if (is.null(closure_last_expr(fun))) { + if (is.null(closure_last_expr(closure_obj@fun))) { stop("local closure calls that return `NULL` cannot be assigned") } - call_expr <- match.call(fun, call_expr) - args_expr <- as.list(call_expr)[-1L] - formal_names <- names(formals(fun)) %||% character() - if (!identical((names(args_expr) %||% character()), formal_names)) { - stop("internal error: match.call did not align closure args") - } - - args_f <- lapply(args_expr, r2f, scope, ...) - formal_vars <- closure_formal_vars(args_f, formal_names) + call_info <- match_closure_call_args(call_expr, closure_obj, scope, ...) + args_expr <- call_info$args_expr + args_f <- call_info$args_f + formal_vars <- call_info$formal_vars return_names <- attr(scope, "return_names", exact = TRUE) %||% character() res_var <- if (target_exists) { @@ -513,7 +554,7 @@ compile_closure_call_assignment <- function( Variable() } - proc <- compile_internal_subroutine( + proc <- compile_local_closure_proc( closure_name, closure_obj, scope, @@ -539,7 +580,7 @@ compile_closure_call_assignment <- function( res_var <- Variable(mode = target_var@mode, dims = target_var@dims) res_var@name <- target_name res_var@logical_as_int <- TRUE - proc <- compile_internal_subroutine( + proc <- compile_local_closure_proc( closure_name, closure_obj, scope, diff --git a/R/r2f-matrix-blas.R b/R/r2f-matrix-blas.R new file mode 100644 index 00000000..b4dd732d --- /dev/null +++ b/R/r2f-matrix-blas.R @@ -0,0 +1,524 @@ +# Matrix BLAS/LAPACK emission helpers + +# ---- shared matrix helpers (loaded early for implicit collation) ---- + +# Return the R symbol name if operand is a bare symbol; otherwise NULL. +symbol_name_or_null <- function(x) { + stopifnot(inherits(x, Fortran)) + r_expr <- unwrap_parens(x@r) + if (is.symbol(r_expr)) { + return(as.character(r_expr)) + } + if (length(x) == 1L && grepl("^[A-Za-z][A-Za-z0-9_]*$", x)) { + return(as.character(x)) + } + NULL +} + +# Return a dimension value for an axis, defaulting missing dims to 1L. +dim_or_one_from <- function(dims, axis) { + stopifnot(is.numeric(axis), axis >= 1) + axis <- as.integer(axis) + if (is.null(dims)) { + return(1L) + } + if (axis <= length(dims) && !is.null(dims[[axis]])) { + dims[[axis]] + } else { + 1L + } +} + +# Return the requested axis length, defaulting scalars (or missing axes) to 1L. +dim_or_one <- function(x, axis) { + stopifnot(inherits(x, Fortran)) + dim_or_one_from(x@value@dims, axis) +} + +# Return the requested axis length for a Variable, defaulting to 1L. +var_dim_or_one <- function(var, axis) { + stopifnot(inherits(var, Variable)) + dim_or_one_from(var@dims, axis) +} + +# Compute matrix-style row/column dimensions from rank, dims, and orientation. +matrix_dims_from <- function( + rank, + dims, + orientation = c("matrix", "rowvec", "colvec") +) { + orientation <- match.arg(orientation) + rows <- dim_or_one_from(dims, 1L) + cols <- dim_or_one_from(dims, 2L) + + if (rank == 0L) { + rows <- 1L + cols <- 1L + } else if (rank == 1L) { + if (orientation == "rowvec") { + rows <- 1L + cols <- dim_or_one_from(dims, 1L) + } else { + rows <- dim_or_one_from(dims, 1L) + cols <- 1L + } + } + + list(rows = rows, cols = cols) +} + +# Interpret a Fortran value as a matrix for BLAS calls. Scalars become 1x1 +# matrices, and vectors can be viewed as either row or column vectors. +matrix_dims <- function(x, orientation = c("matrix", "rowvec", "colvec")) { + stopifnot(inherits(x, Fortran)) + matrix_dims_from(x@value@rank, x@value@dims, orientation = orientation) +} + +# Interpret a Variable value as a matrix for BLAS calls. +matrix_dims_var <- function( + var, + orientation = c("matrix", "rowvec", "colvec") +) { + stopifnot(inherits(var, Variable)) + matrix_dims_from(var@rank, var@dims, orientation = orientation) +} + +# Compute effective dimensions based on transpose flags. +effective_dims <- function(dims, trans) { + if (identical(trans, "T")) { + list(rows = dims$cols, cols = dims$rows) + } else { + dims + } +} + +# Return conformability status (ok/unknown) without side-effects. +check_conformable <- function(left, right) { + if (is_wholenumber(left) && is_wholenumber(right)) { + ok <- identical(as.integer(left), as.integer(right)) + return(list(ok = ok, unknown = FALSE)) + } + if (identical(left, right)) { + return(list(ok = TRUE, unknown = FALSE)) + } + list(ok = TRUE, unknown = TRUE) +} + +warn_conformability_unknown <- function(left, right, context) { + left_txt <- if (is.null(left)) "NULL" else deparse(left) + right_txt <- if (is.null(right)) "NULL" else deparse(right) + warning( + "cannot verify conformability in ", + context, + " at compile time: ", + left_txt, + " vs ", + right_txt, + call. = FALSE + ) + invisible(FALSE) +} + +# ---- BLAS emitters ---- + +# Check that destination dimensions match expected output dimensions. +assert_dest_dims_compatible <- function(dest, expected_dims, context) { + if (is.null(dest) || is.null(expected_dims)) { + return(invisible(TRUE)) + } + expected_rank <- length(expected_dims) + if (dest@rank != expected_rank) { + stop("assignment target has incompatible rank for ", context, call. = FALSE) + } + for (i in seq_len(expected_rank)) { + dest_dim <- dest@dims[[i]] + expected_dim <- expected_dims[[i]] + if (is_wholenumber(dest_dim) && is_wholenumber(expected_dim)) { + if (!identical(as.integer(dest_dim), as.integer(expected_dim))) { + stop( + "assignment target has incompatible dimensions for ", + context, + call. = FALSE + ) + } + } + } + invisible(TRUE) +} + +# Determine if output can safely write into dest without aliasing. +can_use_output <- function( + dest, + input_names = character(), + expected_dims = NULL, + context, + allow_alias = character() +) { + if (is.null(dest)) { + return(FALSE) + } + if (!identical(dest@mode, "double")) { + return(FALSE) + } + assert_dest_dims_compatible(dest, expected_dims, context) + output_name <- dest@name + if (is.null(output_name) || !nzchar(output_name)) { + return(FALSE) + } + + input_names <- unique(as.character(input_names)) + input_names <- input_names[nzchar(input_names)] + allow_alias <- unique(as.character(allow_alias)) + allow_alias <- allow_alias[nzchar(allow_alias)] + disallowed <- setdiff(input_names, allow_alias) + + !output_name %in% disallowed +} + +# Ensure a BLAS operand is named, hoisting into a temp if needed. +ensure_blas_operand_name <- function(x, hoist) { + name <- symbol_name_or_null(x) + if (!is.null(name)) { + return(name) + } + tmp <- hoist$declare_tmp( + mode = x@value@mode %||% "double", + dims = x@value@dims + ) + hoist$emit(glue("{tmp@name} = {x}")) + tmp@name +} + +# Wrap an expression as a BLAS int literal. +blas_int <- function(x) { + glue("int({x}, kind=c_int)") +} + +# Centralized GEMM emission with optional destination +# gemm: centralized BLAS GEMM emission. +# - 'hoist' is required and provided by r2f(); handlers thread it through so +# helpers can pre-emit temporary assignments and BLAS calls. +gemm <- function( + opA, + opB, + left, + right, + m, + n, + k, + lda, + ldb, + ldc_expr, + scope, + hoist, + dest = NULL, + context = "gemm" +) { + if (!inherits(hoist, "environment")) { + stop("internal: hoist must be a hoist environment") + } + A_name <- ensure_blas_operand_name(left, hoist) + B_name <- ensure_blas_operand_name(right, hoist) + + if ( + can_use_output( + dest, + input_names = c(A_name, B_name), + expected_dims = list(m, n), + context = context + ) + ) { + hoist$emit(glue( + "call dgemm('{opA}','{opB}', {blas_int(m)}, {blas_int(n)}, {blas_int(k)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {B_name}, {blas_int(ldb)}, 0.0_c_double, {dest@name}, {blas_int(ldc_expr)})" + )) + out <- Fortran(dest@name, dest) + attr(out, "writes_to_dest") <- TRUE + return(out) + } + + output_var <- hoist$declare_tmp(mode = "double", dims = list(m, n)) + hoist$emit(glue( + "call dgemm('{opA}','{opB}', {blas_int(m)}, {blas_int(n)}, {blas_int(k)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {B_name}, {blas_int(ldb)}, 0.0_c_double, {output_var@name}, {blas_int(ldc_expr)})" + )) + Fortran(output_var@name, output_var) +} + +# Centralized GEMV emission with optional destination +# gemv: centralized BLAS GEMV emission. +# - 'hoist' is required and provided by r2f(); handlers thread it through so +# helpers can pre-emit temporary assignments and BLAS calls. +gemv <- function( + transA, + A, + x, + m, + n, + lda, + out_dims, + scope, + hoist, + dest = NULL, + context = "gemv" +) { + if (!inherits(hoist, "environment")) { + stop("internal: hoist must be a hoist environment") + } + A_name <- ensure_blas_operand_name(A, hoist) + x_name <- ensure_blas_operand_name(x, hoist) + + if ( + can_use_output( + dest, + input_names = c(A_name, x_name), + expected_dims = out_dims, + context = context + ) + ) { + # Assign output to output destination + hoist$emit(glue( + "call dgemv('{transA}', {blas_int(m)}, {blas_int(n)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {x_name}, 1_c_int, 0.0_c_double, {dest@name}, 1_c_int)" + )) + out <- Fortran(dest@name, dest) + attr(out, "writes_to_dest") <- TRUE + return(out) + } + # Else assign to a temporary variable + output_var <- hoist$declare_tmp(mode = "double", dims = out_dims) + hoist$emit(glue( + "call dgemv('{transA}', {blas_int(m)}, {blas_int(n)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {x_name}, 1_c_int, 0.0_c_double, {output_var@name}, 1_c_int)" + )) + Fortran(output_var@name, output_var) +} + +symmetrize_upper_to_lower <- function(target, n, hoist) { + stopifnot(is_string(target), inherits(hoist, "environment")) + + idx_i <- hoist$declare_tmp(mode = "integer", dims = list(1L)) + idx_j <- hoist$declare_tmp(mode = "integer", dims = list(1L)) + n_int <- blas_int(n) + hoist$emit(glue( + " +do {idx_j@name} = 1_c_int, {n_int} - 1_c_int + do {idx_i@name} = {idx_j@name} + 1_c_int, {n_int} + {target}({idx_i@name}, {idx_j@name}) = {target}({idx_j@name}, {idx_i@name}) + end do +end do" + )) +} + +# Centralized SYRK emission for symmetric rank-k update +# Computes: C := alpha * op(A) * op(A)^T + beta * C +# For crossprod(X): C = t(X) %*% X → trans = "T" +# For tcrossprod(X): C = X %*% t(X) → trans = "N" +syrk <- function( + trans, + X, + scope, + hoist, + dest = NULL, + context = "syrk" +) { + if (!inherits(hoist, "environment")) { + stop("internal: hoist must be a hoist environment") + } + X_name <- ensure_blas_operand_name(X, hoist) + + x_dims <- matrix_dims(X) + + # For trans = "T": C = t(X) %*% X, so C is k x k where k = ncol(X) + # For trans = "N": C = X %*% t(X), so C is n x n where n = nrow(X) + if (trans == "T") { + n <- x_dims$cols + k <- x_dims$rows + } else { + n <- x_dims$rows + k <- x_dims$cols + } + lda <- x_dims$rows + + # Output is symmetric n x n matrix + writes_to_dest <- FALSE + out_var <- NULL + out_name <- NULL + + if ( + can_use_output( + dest, + input_names = X_name, + expected_dims = list(n, n), + context = context + ) + ) { + writes_to_dest <- TRUE + out_var <- dest + out_name <- dest@name + } else { + out_var <- hoist$declare_tmp(mode = "double", dims = list(n, n)) + out_name <- out_var@name + } + + hoist$emit(glue( + "call dsyrk('U', '{trans}', {blas_int(n)}, {blas_int(k)}, 1.0_c_double, {X_name}, {blas_int(lda)}, 0.0_c_double, {out_name}, {blas_int(n)})" + )) + symmetrize_upper_to_lower(out_name, n, hoist = hoist) + + out <- Fortran(out_name, out_var) + if (writes_to_dest) { + attr(out, "writes_to_dest") <- TRUE + } + out +} + +# Emit BLAS outer product for vectors or scalars with optional destination. +outer_mul <- function( + x, + y, + scope, + hoist, + dest = NULL, + context = "outer" +) { + if (!inherits(hoist, "environment")) { + stop("internal: hoist must be a hoist environment") + } + + x <- maybe_cast_double(x) + y <- maybe_cast_double(y) + + if (x@value@rank > 1L || y@value@rank > 1L) { + stop("outer() only supports vectors or scalars") + } + + m <- dim_or_one(x, 1L) + n <- dim_or_one(y, 1L) + + x_name <- ensure_blas_operand_name(x, hoist) + y_name <- ensure_blas_operand_name(y, hoist) + + if ( + can_use_output( + dest, + input_names = c(x_name, y_name), + expected_dims = list(m, n), + context = context + ) + ) { + hoist$emit(glue("{dest@name} = 0.0_c_double")) + hoist$emit(glue( + "call dger({blas_int(m)}, {blas_int(n)}, 1.0_c_double, {x_name}, 1_c_int, {y_name}, 1_c_int, {dest@name}, {blas_int(m)})" + )) + out <- Fortran(dest@name, dest) + attr(out, "writes_to_dest") <- TRUE + return(out) + } + + output_var <- hoist$declare_tmp(mode = "double", dims = list(m, n)) + hoist$emit(glue("{output_var@name} = 0.0_c_double")) + hoist$emit(glue( + "call dger({blas_int(m)}, {blas_int(n)}, 1.0_c_double, {x_name}, 1_c_int, {y_name}, 1_c_int, {output_var@name}, {blas_int(m)})" + )) + Fortran(output_var@name, output_var) +} + +# Emit triangular solve (vector or matrix RHS) with optional destination. +triangular_solve <- function( + A, + B, + uplo, + trans, + diag, + scope, + hoist, + dest = NULL, + context = "triangular solve" +) { + if (!inherits(hoist, "environment")) { + stop("internal: hoist must be a hoist environment") + } + + A <- maybe_cast_double(A) + B <- maybe_cast_double(B) + + if (A@value@rank != 2L) { + stop("triangular solve expects a matrix") + } + + a_dims <- matrix_dims(A) + conform <- check_conformable(a_dims$rows, a_dims$cols) + if (!conform$ok) { + stop("non-conformable arguments in triangular solve", call. = FALSE) + } + if (conform$unknown) { + warn_conformability_unknown(a_dims$rows, a_dims$cols, "triangular solve") + } + n <- a_dims$rows + + b_rank <- B@value@rank + if (b_rank > 2L) { + stop("triangular solve only supports vector or matrix right-hand sides") + } + if (b_rank == 0L) { + stop("triangular solve expects a vector or matrix right-hand side") + } else if (b_rank == 1L) { + b_len <- dim_or_one(B, 1L) + conform <- check_conformable(n, b_len) + if (!conform$ok) { + stop("non-conformable arguments in triangular solve", call. = FALSE) + } + if (conform$unknown) { + warn_conformability_unknown(n, b_len, "triangular solve") + } + } else { + b_rows <- dim_or_one(B, 1L) + conform <- check_conformable(n, b_rows) + if (!conform$ok) { + stop("non-conformable arguments in triangular solve", call. = FALSE) + } + if (conform$unknown) { + warn_conformability_unknown(n, b_rows, "triangular solve") + } + } + + A_name <- ensure_blas_operand_name(A, hoist) + B_input_name <- symbol_name_or_null(B) + + if ( + can_use_output( + dest, + input_names = c(A_name, B_input_name), + expected_dims = B@value@dims, + context = context, + allow_alias = B_input_name + ) + ) { + hoist$emit(glue("{dest@name} = {B}")) + B_name <- dest@name + out_var <- dest + writes_to_dest <- TRUE + } else { + out_var <- hoist$declare_tmp( + mode = B@value@mode %||% "double", + dims = B@value@dims + ) + hoist$emit(glue("{out_var@name} = {B}")) + B_name <- out_var@name + writes_to_dest <- FALSE + } + + if (b_rank <= 1L) { + hoist$emit(glue( + "call dtrsv('{uplo}', '{trans}', '{diag}', {blas_int(n)}, {A_name}, {blas_int(n)}, {B_name}, 1_c_int)" + )) + } else { + nrhs <- dim_or_one(B, 2L) + hoist$emit(glue( + "call dtrsm('L', '{uplo}', '{trans}', '{diag}', {blas_int(n)}, {blas_int(nrhs)}, 1.0_c_double, {A_name}, {blas_int(n)}, {B_name}, {blas_int(n)})" + )) + } + + out <- Fortran(B_name, out_var) + if (writes_to_dest) { + attr(out, "writes_to_dest") <- TRUE + } + out +} diff --git a/R/r2f-matrix-infer.R b/R/r2f-matrix-infer.R new file mode 100644 index 00000000..874c40d9 --- /dev/null +++ b/R/r2f-matrix-infer.R @@ -0,0 +1,163 @@ +# Matrix destination inference helpers + +# Infer a variable from a symbol in the current scope. +infer_symbol_var <- function(arg, scope) { + arg <- unwrap_parens(arg) + if (!is.symbol(arg)) { + return(NULL) + } + var <- get0(as.character(arg), scope, inherits = FALSE) + if (inherits(var, Variable)) var else NULL +} + +# Infer a matrix argument, handling t() and scalar/vector promotion. +infer_matrix_arg <- function(arg, scope) { + arg <- unwrap_parens(arg) + if (is_call(arg, quote(t)) && length(arg) == 2L) { + inner <- infer_symbol_var(arg[[2L]], scope) + if (is.null(inner)) { + return(NULL) + } + if (inner@rank == 2L) { + return(list(var = inner, trans = "T")) + } + if (inner@rank == 1L) { + len <- inner@dims[[1L]] + if (is.null(len)) { + return(NULL) + } + val <- Variable("double", list(1L, len)) + return(list(var = val, trans = "N")) + } + if (inner@rank == 0L) { + return(list(var = inner, trans = "N")) + } + return(NULL) + } + var <- infer_symbol_var(arg, scope) + if (is.null(var)) { + return(NULL) + } + list(var = var, trans = "N") +} + +# Infer destination dimensions for %*% based on inputs. +infer_dest_matmul <- function(args, scope) { + if (length(args) != 2L) { + return(NULL) + } + left_info <- infer_matrix_arg(args[[1L]], scope) + right_info <- infer_matrix_arg(args[[2L]], scope) + if (is.null(left_info) || is.null(right_info)) { + return(NULL) + } + + left <- left_info$var + right <- right_info$var + left_trans <- left_info$trans + right_trans <- right_info$trans + + left_rank <- left@rank + right_rank <- right@rank + if (left_rank > 2L || right_rank > 2L) { + return(NULL) + } + + left_dims <- matrix_dims_var( + left, + orientation = if (left_rank == 1L) "rowvec" else "matrix" + ) + right_dims <- matrix_dims_var( + right, + orientation = if (right_rank == 1L) "colvec" else "matrix" + ) + + left_eff <- if (left_rank == 2L) { + effective_dims(left_dims, left_trans) + } else { + left_dims + } + right_eff <- if (right_rank == 2L) { + effective_dims(right_dims, right_trans) + } else { + right_dims + } + + if (left_rank == 2L && right_rank == 1L) { + out_len <- if (left_trans == "N") left_dims$rows else left_dims$cols + return(Variable("double", list(out_len, 1L))) + } + if (left_rank == 1L && right_rank == 2L) { + transA <- if (right_trans == "N") "T" else "N" + out_len <- if (transA == "N") right_dims$rows else right_dims$cols + return(Variable("double", list(1L, out_len))) + } + + Variable("double", list(left_eff$rows, right_eff$cols)) +} + +# Shared inference for crossprod/tcrossprod destination sizes. +infer_dest_crossprod_like <- function(args, scope, trans) { + x <- infer_symbol_var(args[[1L]], scope) + if (is.null(x)) { + return(NULL) + } + y <- if (length(args) > 1L) infer_symbol_var(args[[2L]], scope) else NULL + x_dims <- matrix_dims_var(x) + if (is.null(y)) { + n <- if (identical(trans, "T")) x_dims$cols else x_dims$rows + return(Variable("double", list(n, n))) + } + y_dims <- matrix_dims_var(y) + if (identical(trans, "T")) { + Variable("double", list(x_dims$cols, y_dims$cols)) + } else { + Variable("double", list(x_dims$rows, y_dims$rows)) + } +} + +# Infer destination dimensions for crossprod(). +infer_dest_crossprod <- function(args, scope) { + infer_dest_crossprod_like(args, scope, trans = "T") +} + +# Infer destination dimensions for tcrossprod(). +infer_dest_tcrossprod <- function(args, scope) { + infer_dest_crossprod_like(args, scope, trans = "N") +} + +# Infer destination dimensions for outer() and %o%(). +infer_dest_outer <- function(args, scope) { + x_arg <- args$X %||% args[[1L]] + y_arg <- args$Y %||% if (length(args) >= 2L) args[[2L]] else NULL + x <- infer_symbol_var(x_arg, scope) + y <- infer_symbol_var(y_arg, scope) + if (is.null(x) || is.null(y)) { + return(NULL) + } + if (x@rank > 1L || y@rank > 1L) { + return(NULL) + } + m <- var_dim_or_one(x, 1L) + n <- var_dim_or_one(y, 1L) + Variable("double", list(m, n)) +} + +# Infer destination dimensions for forwardsolve() and backsolve(). +infer_dest_triangular <- function(args, scope) { + if (length(args) < 2L) { + return(NULL) + } + A <- infer_symbol_var(args[[1L]], scope) + B <- infer_symbol_var(args[[2L]], scope) + if (is.null(A) || is.null(B)) { + return(NULL) + } + if (A@rank != 2L || B@rank == 0L || B@rank > 2L) { + return(NULL) + } + if (is.null(B@dims)) { + return(NULL) + } + Variable("double", B@dims) +} diff --git a/R/r2f-matrix-parse.R b/R/r2f-matrix-parse.R new file mode 100644 index 00000000..8ac5a13b --- /dev/null +++ b/R/r2f-matrix-parse.R @@ -0,0 +1,40 @@ +# Matrix parsing helpers + +# Unwrap t() calls to infer transpose flags and normalize scalars/vectors. +unwrap_transpose_arg <- function(arg, scope, ..., hoist) { + arg_unwrapped <- unwrap_parens(arg) + if (is_call(arg_unwrapped, quote(t)) && length(arg_unwrapped) == 2L) { + inner_arg <- unwrap_parens(arg_unwrapped[[2L]]) + inner <- r2f(inner_arg, scope, ..., hoist = hoist) + inner <- maybe_cast_double(inner) + if (inner@value@rank == 2L) { + return(list(value = inner, trans = "T")) + } else if (inner@value@rank == 1L) { + len <- inner@value@dims[[1L]] + val <- Variable("double", list(1L, len)) + return(list( + value = Fortran(glue("reshape({inner}, [1, int({len})])"), val), + trans = "N" + )) + } else if (inner@value@rank == 0L) { + return(list(value = inner, trans = "N")) + } else { + stop("t() only supports rank 0-2 inputs") + } + } + value <- r2f(arg, scope, ..., hoist = hoist) + value <- maybe_cast_double(value) + list(value = value, trans = "N") +} + +# Extract a logical argument or use the provided default. +logical_arg_or_default <- function(args, name, default, context) { + val <- args[[name]] %||% default + if (is.null(val)) { + return(default) + } + if (!is.logical(val) || length(val) != 1L || is.na(val)) { + stop(context, " only supports literal ", name, " = TRUE/FALSE") + } + val +} diff --git a/R/r2f-matrix.R b/R/r2f-matrix.R new file mode 100644 index 00000000..d061e432 --- /dev/null +++ b/R/r2f-matrix.R @@ -0,0 +1,673 @@ +# Matrix-specific r2f handlers and wiring + +# %*% handler with optional destination hint +register_r2f_handler( + "%*%", + function(args, scope, ..., hoist = NULL, dest = NULL) { + stopifnot(length(args) == 2L) + left_info <- unwrap_transpose_arg(args[[1L]], scope, ..., hoist = hoist) + right_info <- unwrap_transpose_arg(args[[2L]], scope, ..., hoist = hoist) + left <- left_info$value + right <- right_info$value + left_trans <- left_info$trans + right_trans <- right_info$trans + + left_rank <- left@value@rank + right_rank <- right@value@rank + + if (left_rank > 2 || right_rank > 2) { + stop("%*% only supports vectors/matrices (rank <= 2)") + } + + left_dims <- matrix_dims( + left, + orientation = if (left_rank == 1) "rowvec" else "matrix" + ) + + right_dims <- matrix_dims( + right, + orientation = if (right_rank == 1) "colvec" else "matrix" + ) + + left_eff <- if (left_rank == 2) { + effective_dims(left_dims, left_trans) + } else { + left_dims + } + right_eff <- if (right_rank == 2) { + effective_dims(right_dims, right_trans) + } else { + right_dims + } + + # Compute effective shapes + m <- left_eff$rows + k <- left_eff$cols + n <- right_eff$cols + + # Leading dimensions + lda <- left_dims$rows + ldb <- right_dims$rows + ldc_expr <- m + + # Matrix-Vector: use GEMV + if (left_rank == 2 && right_rank == 1) { + expected_len <- if (left_trans == "N") left_dims$cols else left_dims$rows + conform <- check_conformable(expected_len, right_dims$rows) + if (!conform$ok) { + stop("non-conformable arguments in %*%", call. = FALSE) + } + if (conform$unknown) { + warn_conformability_unknown(expected_len, right_dims$rows, "%*%") + } + out_len <- if (left_trans == "N") left_dims$rows else left_dims$cols + return(gemv( + transA = left_trans, + A = left, + x = right, + m = left_dims$rows, + n = left_dims$cols, + lda = left_dims$rows, + out_dims = list(out_len, 1L), + scope = scope, + hoist = hoist, + dest = dest, + context = "%*%" + )) + } + # Vector-Matrix: use GEMV with transpose + if (left_rank == 1 && right_rank == 2) { + transA <- if (right_trans == "N") "T" else "N" + expected_len <- if (transA == "N") right_dims$cols else right_dims$rows + conform <- check_conformable(left_dims$cols, expected_len) + if (!conform$ok) { + stop("non-conformable arguments in %*%", call. = FALSE) + } + if (conform$unknown) { + warn_conformability_unknown(left_dims$cols, expected_len, "%*%") + } + out_len <- if (transA == "N") right_dims$rows else right_dims$cols + return(gemv( + transA = transA, + A = right, + x = left, + m = right_dims$rows, + n = right_dims$cols, + lda = right_dims$rows, + out_dims = list(1L, out_len), + scope = scope, + hoist = hoist, + dest = dest, + context = "%*%" + )) + } + + conform <- check_conformable(k, right_eff$rows) + if (!conform$ok) { + stop("non-conformable arguments in %*%", call. = FALSE) + } + if (conform$unknown) { + warn_conformability_unknown(k, right_eff$rows, "%*%") + } + + # Matrix-Matrix + gemm( + opA = left_trans, + opB = right_trans, + left = left, + right = right, + m = m, + n = n, + k = k, + lda = lda, + ldb = ldb, + ldc_expr = ldc_expr, + scope = scope, + hoist = hoist, + dest = dest, + context = "%*%" + ) + }, + dest_supported = TRUE, + dest_infer = infer_dest_matmul +) + + +# t(x) handler: transpose 2D; 1D becomes a 1 x n row matrix +r2f_handlers[["t"]] <- function(args, scope, ..., hoist = NULL) { + stopifnot(length(args) == 1L) + x <- r2f(args[[1L]], scope, ..., hoist = hoist) + x <- maybe_cast_double(x) + if (x@value@rank == 2) { + val <- Variable("double", list(x@value@dims[[2]], x@value@dims[[1]])) + return(Fortran(glue("transpose({x})"), val)) + } else if (x@value@rank == 1) { + len <- x@value@dims[[1]] + val <- Variable("double", list(1L, len)) + return(Fortran(glue("reshape({x}, [1, int({len})])"), val)) + } else if (x@value@rank == 0) { + return(x) + } else { + stop("t() only supports rank 0-2 inputs") + } +} + +bind_output_mode <- function(values, context) { + modes <- unique(vapply( + values, + function(val) val@value@mode %||% NA_character_, + character(1) + )) + if (anyNA(modes) || any(!nzchar(modes))) { + stop(context, " inputs must have a known type", call. = FALSE) + } + if ("complex" %in% modes) { + if (length(modes) > 1L) { + stop( + context, + " does not support mixing complex with other types", + call. = FALSE + ) + } + return("complex") + } + if ("double" %in% modes) { + return("double") + } + if ("integer" %in% modes) { + return("integer") + } + if ("logical" %in% modes) { + return("logical") + } + if ("raw" %in% modes) { + if (length(modes) > 1L) { + stop( + context, + " does not support mixing raw with other types", + call. = FALSE + ) + } + return("raw") + } + stop(context, " does not support input mode(s): ", str_flatten_commas(modes)) +} + +bind_cast_value <- function(value, mode, context) { + if (identical(value@value@mode, mode)) { + return(value) + } + if (identical(mode, "double")) { + return(maybe_cast_double(value)) + } + if (identical(mode, "integer") && identical(value@value@mode, "logical")) { + return(Fortran( + glue("merge(1_c_int, 0_c_int, {value})"), + Variable("integer", value@value@dims) + )) + } + stop( + context, + " does not support coercion from ", + value@value@mode, + " to ", + mode, + call. = FALSE + ) +} + +bind_dim_sum <- function(values, context, label) { + if (!length(values)) { + return(0L) + } + if (any(map_lgl(values, is_scalar_na))) { + stop( + context, + " requires inputs with known ", + label, + " sizes", + call. = FALSE + ) + } + if (all(map_lgl(values, is_wholenumber))) { + return(sum(as.integer(values))) + } + reduce(values, \(a, b) call("+", a, b)) +} + +bind_common_dim <- function(dim_list, scalar_flags, context, label) { + non_scalar <- which(!scalar_flags) + if (!length(non_scalar)) { + return(1L) + } + target <- dim_list[[non_scalar[[1L]]]] + if (is_scalar_na(target)) { + stop( + context, + " requires inputs with known ", + label, + " counts", + call. = FALSE + ) + } + if (length(non_scalar) > 1L) { + for (idx in non_scalar[-1L]) { + conform <- check_conformable(target, dim_list[[idx]]) + if (!conform$ok) { + stop( + context, + " requires inputs with a common ", + label, + " count", + call. = FALSE + ) + } + if (conform$unknown) { + warn_conformability_unknown(target, dim_list[[idx]], context) + } + } + } + target +} + +bind_dim_string <- function(dim) { + if (is.character(dim)) { + dim + } else if (is_wholenumber(dim)) { + as.character(as.integer(dim)) + } else if (is.numeric(dim)) { + as.character(dim) + } else { + gsub("([0-9]+)L\\b", "\\1", deparse1(dim)) + } +} + +bind_dim_int <- function(dim) { + paste0("int(", bind_dim_string(dim), ")") +} + +bind_col_matrix_expr <- function(value, rows, is_scalar, context) { + rows_int <- bind_dim_int(rows) + if (is_scalar) { + vec <- glue("spread({value}, 1, {rows_int})") + return(glue("reshape({vec}, [{rows_int}, 1])")) + } + if (value@value@rank == 1L) { + return(glue("reshape({value}, [{rows_int}, 1])")) + } + if (value@value@rank == 2L) { + return(as.character(value)) + } + stop(context, " only supports rank 0-2 inputs", call. = FALSE) +} + +bind_row_matrix_expr <- function(value, cols, is_scalar, context) { + cols_int <- bind_dim_int(cols) + if (is_scalar) { + vec <- glue("spread({value}, 1, {cols_int})") + return(glue("reshape({vec}, [1, {cols_int}])")) + } + if (value@value@rank == 1L) { + return(glue("reshape({value}, [1, {cols_int}])")) + } + if (value@value@rank == 2L) { + return(as.character(value)) + } + stop(context, " only supports rank 0-2 inputs", call. = FALSE) +} + +register_r2f_handler( + "cbind", + function(args, scope, ..., hoist = NULL) { + context <- "cbind()" + if (!is.null(args$deparse.level) && !is_missing(args$deparse.level)) { + args$deparse.level <- NULL + } + args <- args[!vapply(args, is_missing, logical(1))] + args <- args[ + !vapply( + args, + \(x) is.null(x) || identical(x, quote(NULL)), + logical(1) + ) + ] + if (!length(args)) { + stop("cbind() requires at least one argument", call. = FALSE) + } + + values <- lapply(args, r2f, scope, ..., hoist = hoist) + for (val in values) { + if (is.null(val@value) || is.null(val@value@mode)) { + stop(context, " inputs must have a value", call. = FALSE) + } + if (val@value@rank > 2L) { + stop(context, " only supports rank 0-2 inputs", call. = FALSE) + } + } + + mode <- bind_output_mode(values, context) + values <- lapply(values, bind_cast_value, mode = mode, context = context) + + dims <- lapply(values, matrix_dims, orientation = "colvec") + scalar_flags <- map_lgl(values, \(val) passes_as_scalar(val@value)) + row_sizes <- lapply(dims, `[[`, "rows") + col_sizes <- lapply(dims, `[[`, "cols") + + rows <- bind_common_dim(row_sizes, scalar_flags, context, "row") + cols <- bind_dim_sum(col_sizes, context, "column") + + col_exprs <- vector("list", length(values)) + for (i in seq_along(values)) { + col_exprs[[i]] <- bind_col_matrix_expr( + value = values[[i]], + rows = rows, + is_scalar = scalar_flags[[i]], + context = context + ) + } + + data_expr <- glue("[{str_flatten_commas(col_exprs)}]") + out_expr <- glue( + "reshape({data_expr}, [{bind_dim_int(rows)}, {bind_dim_int(cols)}])" + ) + Fortran(out_expr, Variable(mode, list(rows, cols))) + } +) + +register_r2f_handler( + "rbind", + function(args, scope, ..., hoist = NULL) { + context <- "rbind()" + if (!is.null(args$deparse.level) && !is_missing(args$deparse.level)) { + args$deparse.level <- NULL + } + args <- args[!vapply(args, is_missing, logical(1))] + args <- args[ + !vapply( + args, + \(x) is.null(x) || identical(x, quote(NULL)), + logical(1) + ) + ] + if (!length(args)) { + stop("rbind() requires at least one argument", call. = FALSE) + } + + values <- lapply(args, r2f, scope, ..., hoist = hoist) + for (val in values) { + if (is.null(val@value) || is.null(val@value@mode)) { + stop(context, " inputs must have a value", call. = FALSE) + } + if (val@value@rank > 2L) { + stop(context, " only supports rank 0-2 inputs", call. = FALSE) + } + } + + mode <- bind_output_mode(values, context) + values <- lapply(values, bind_cast_value, mode = mode, context = context) + + dims <- lapply(values, matrix_dims, orientation = "rowvec") + scalar_flags <- map_lgl(values, \(val) passes_as_scalar(val@value)) + row_sizes <- lapply(dims, `[[`, "rows") + col_sizes <- lapply(dims, `[[`, "cols") + + cols <- bind_common_dim(col_sizes, scalar_flags, context, "column") + rows <- bind_dim_sum(row_sizes, context, "row") + + row_exprs <- vector("list", length(values)) + for (i in seq_along(values)) { + row_exprs[[i]] <- bind_row_matrix_expr( + value = values[[i]], + cols = cols, + is_scalar = scalar_flags[[i]], + context = context + ) + } + transposed <- lapply(row_exprs, \(expr) glue("transpose({expr})")) + + data_expr <- glue("[{str_flatten_commas(transposed)}]") + combined <- glue( + "reshape({data_expr}, [{bind_dim_int(cols)}, {bind_dim_int(rows)}])" + ) + out_expr <- glue("transpose({combined})") + + Fortran(out_expr, Variable(mode, list(rows, cols))) + } +) + + +# Handle crossprod(), using SYRK for single-arg and GEMM for two-arg forms. +register_r2f_handler( + "crossprod", + function(args, scope, ..., hoist = NULL, dest = NULL) { + x_arg <- args[[1L]] + y_arg <- if (length(args) > 1L) args[[2L]] else NULL + crossprod_like( + x_arg = x_arg, + y_arg = y_arg, + scope = scope, + ..., + hoist = hoist, + dest = dest, + trans_single = "T", + opA = "T", + opB = "N", + context = "crossprod" + ) + }, + dest_supported = TRUE, + dest_infer = infer_dest_crossprod +) + + +# Handle tcrossprod(), using SYRK for single-arg and GEMM for two-arg forms. +register_r2f_handler( + "tcrossprod", + function(args, scope, ..., hoist = NULL, dest = NULL) { + x_arg <- args[[1L]] + y_arg <- if (length(args) > 1L) args[[2L]] else NULL + crossprod_like( + x_arg = x_arg, + y_arg = y_arg, + scope = scope, + ..., + hoist = hoist, + dest = dest, + trans_single = "N", + opA = "N", + opB = "T", + context = "tcrossprod" + ) + }, + dest_supported = TRUE, + dest_infer = infer_dest_tcrossprod +) + +# Handle outer() for FUN = "*" as BLAS outer product. +register_r2f_handler( + "outer", + function(args, scope, ..., hoist = NULL, dest = NULL) { + x_arg <- args$X %||% args[[1L]] + y_arg <- args$Y %||% if (length(args) >= 2L) args[[2L]] else NULL + if (is.null(x_arg) || is.null(y_arg)) { + stop("outer() expects X and Y") + } + + fun <- args$FUN %||% "*" + if (!identical(fun, "*")) { + stop("outer() only supports FUN = \"*\"") + } + x <- r2f(x_arg, scope, ..., hoist = hoist) + y <- r2f(y_arg, scope, ..., hoist = hoist) + outer_mul( + x, + y, + scope = scope, + hoist = hoist, + dest = dest, + context = "outer" + ) + }, + dest_supported = TRUE, + dest_infer = infer_dest_outer +) + +# Handle %o% for outer products via BLAS GER. +register_r2f_handler( + "%o%", + function(args, scope, ..., hoist = NULL, dest = NULL) { + stopifnot(length(args) == 2L) + x <- r2f(args[[1L]], scope, ..., hoist = hoist) + y <- r2f(args[[2L]], scope, ..., hoist = hoist) + outer_mul( + x, + y, + scope = scope, + hoist = hoist, + dest = dest, + context = "%o%" + ) + }, + dest_supported = TRUE, + dest_infer = infer_dest_outer +) + +# Handle forwardsolve() via triangular BLAS routines. +register_r2f_handler( + "forwardsolve", + function(args, scope, ..., hoist = NULL, dest = NULL) { + stopifnot(length(args) >= 2L) + if (!is.null(args$k)) { + stop("forwardsolve() does not support k yet") + } + upper_tri <- logical_arg_or_default( + args, + "upper.tri", + FALSE, + "forwardsolve()" + ) + transpose <- logical_arg_or_default( + args, + "transpose", + FALSE, + "forwardsolve()" + ) + diag_unit <- logical_arg_or_default(args, "diag", FALSE, "forwardsolve()") + + A <- r2f(args[[1L]], scope, ..., hoist = hoist) + B <- r2f(args[[2L]], scope, ..., hoist = hoist) + + triangular_solve( + A = A, + B = B, + uplo = if (upper_tri) "U" else "L", + trans = if (transpose) "T" else "N", + diag = if (diag_unit) "U" else "N", + scope = scope, + hoist = hoist, + dest = dest, + context = "forwardsolve" + ) + }, + dest_supported = TRUE, + dest_infer = infer_dest_triangular +) + +# Handle backsolve() via triangular BLAS routines. +register_r2f_handler( + "backsolve", + function(args, scope, ..., hoist = NULL, dest = NULL) { + stopifnot(length(args) >= 2L) + if (!is.null(args$k)) { + stop("backsolve() does not support k yet") + } + upper_tri <- logical_arg_or_default(args, "upper.tri", TRUE, "backsolve()") + transpose <- logical_arg_or_default(args, "transpose", FALSE, "backsolve()") + diag_unit <- logical_arg_or_default(args, "diag", FALSE, "backsolve()") + + A <- r2f(args[[1L]], scope, ..., hoist = hoist) + B <- r2f(args[[2L]], scope, ..., hoist = hoist) + + triangular_solve( + A = A, + B = B, + uplo = if (upper_tri) "U" else "L", + trans = if (transpose) "T" else "N", + diag = if (diag_unit) "U" else "N", + scope = scope, + hoist = hoist, + dest = dest, + context = "backsolve" + ) + }, + dest_supported = TRUE, + dest_infer = infer_dest_triangular +) + +# Shared crossprod/tcrossprod logic for one- and two-argument forms. +crossprod_like <- function( + x_arg, + y_arg, + scope, + ..., + hoist, + dest, + trans_single, + opA, + opB, + context +) { + x <- r2f(x_arg, scope, ..., hoist = hoist) + x <- maybe_cast_double(x) + + if (is.null(y_arg)) { + return(syrk( + trans = trans_single, + X = x, + scope = scope, + hoist = hoist, + dest = dest, + context = context + )) + } + + y <- maybe_cast_double(r2f(y_arg, scope, ..., hoist = hoist)) + + x_dims <- matrix_dims(x) + y_dims <- matrix_dims(y) + x_eff <- effective_dims(x_dims, opA) + y_eff <- effective_dims(y_dims, opB) + + conform <- check_conformable(x_eff$cols, y_eff$rows) + if (!conform$ok) { + stop("non-conformable arguments in ", context, call. = FALSE) + } + if (conform$unknown) { + warn_conformability_unknown(x_eff$cols, y_eff$rows, context) + } + + m <- x_eff$rows + n <- y_eff$cols + k <- x_eff$cols + + lda <- x_dims$rows + ldb <- y_dims$rows + ldc_expr <- m + + gemm( + opA = opA, + opB = opB, + left = x, + right = y, + m = m, + n = n, + k = k, + lda = lda, + ldb = ldb, + ldc_expr = ldc_expr, + scope = scope, + hoist = hoist, + dest = dest, + context = context + ) +} diff --git a/R/r2f.R b/R/r2f.R index 34a64875..2f74aeb9 100644 --- a/R/r2f.R +++ b/R/r2f.R @@ -304,9 +304,6 @@ num2fortran <- function(x) { } -r2f_handlers := new.env(parent = emptyenv()) - - get_r2f_handler <- function(name) { stopifnot("All functions called must be named as symbols" = is.symbol(name)) get0(name, r2f_handlers) %||% @@ -355,14 +352,6 @@ r2f_default_handler <- function(args, scope = NULL, ..., calls) { Fortran(s) } -## ??? export as S7::convert() methods? -register_r2f_handler <- function(name, fun) { - for (nm in name) { - r2f_handlers[[nm]] <- fun - } - invisible(fun) -} - .r2f_handler_not_implemented_yet <- function(e, scope, ...) { stop( gettextf("'%s' is not implemented yet", as.character(e[[1L]])), @@ -1071,8 +1060,23 @@ r2f_handlers[["ifelse"]] <- function(args, scope, ...) { # ---- pure elemental unary math intrinsics ---- +register_unary_intrinsic <- function( + name, + mode_fun, + expr_fun +) { + handler <- function(args, scope, ...) { + stopifnot(length(args) == 1L) + arg <- r2f(args[[1L]], scope, ...) + val <- Variable(mode = mode_fun(arg), dims = arg@value@dims) + Fortran(expr_fun(arg, last(list(...)$calls)), val) + } + register_r2f_handler(name, handler) + invisible(handler) +} + ## real and complex intrinsics -register_r2f_handler( +register_unary_intrinsic( c( "sin", "cos", @@ -1086,15 +1090,8 @@ register_r2f_handler( "floor", "ceiling" ), - function(args, scope, ...) { - stopifnot(length(args) == 1L) - arg <- r2f(args[[1]], scope, ...) - intrinsic <- last(list(...)$calls) - Fortran( - glue("{intrinsic}({arg})"), - Variable(mode = arg@value@mode, dims = arg@value@dims) - ) - } + mode_fun = function(arg) arg@value@mode, + expr_fun = function(arg, intrinsic) glue("{intrinsic}({arg})") ) r2f_handlers[["log10"]] <- function(args, scope, ...) { @@ -1115,54 +1112,42 @@ r2f_handlers[["log10"]] <- function(args, scope, ...) { r2f_handlers[["abs"]] <- function(args, scope, ...) { stopifnot(length(args) == 1L) arg <- r2f(args[[1]], scope, ...) - val <- if (arg@value@mode == "complex") { - Variable(mode = "double", dims = arg@value@dims) - } else { - Variable(mode = arg@value@mode, dims = arg@value@dims) - } - Fortran(glue("abs({arg})"), val) + out_mode <- if (arg@value@mode == "complex") "double" else arg@value@mode + Fortran(glue("abs({arg})"), Variable(mode = out_mode, dims = arg@value@dims)) } # ---- complex elemental unary intrinsics ---- -r2f_handlers[["Re"]] <- function(args, scope, ...) { - stopifnot(length(args) == 1L) - arg <- r2f(args[[1]], scope, ...) - val <- Variable(mode = "double", dims = arg@value@dims) - Fortran(glue("real({arg})"), val) -} +register_unary_intrinsic( + "Re", + mode_fun = function(arg) "double", + expr_fun = function(arg, intrinsic) glue("real({arg})") +) -r2f_handlers[["Im"]] <- function(args, scope, ...) { - stopifnot(length(args) == 1L) - arg <- r2f(args[[1]], scope, ...) - val <- Variable(mode = "double", dims = arg@value@dims) - Fortran(glue("aimag({arg})"), val) -} +register_unary_intrinsic( + "Im", + mode_fun = function(arg) "double", + expr_fun = function(arg, intrinsic) glue("aimag({arg})") +) -# Modulus (magnitude) -r2f_handlers[["Mod"]] <- function(args, scope, ...) { - stopifnot(length(args) == 1L) - arg <- r2f(args[[1]], scope, ...) - val <- Variable(mode = "double", dims = arg@value@dims) - Fortran(glue("abs({arg})"), val) -} +register_unary_intrinsic( + "Mod", + mode_fun = function(arg) "double", + expr_fun = function(arg, intrinsic) glue("abs({arg})") +) -# Argument (phase angle, radians) -r2f_handlers[["Arg"]] <- function(args, scope, ...) { - stopifnot(length(args) == 1L) - arg <- r2f(args[[1]], scope, ...) - val <- Variable(mode = "double", dims = arg@value@dims) - Fortran(glue("atan2(aimag({arg}), real({arg}))"), val) -} +register_unary_intrinsic( + "Arg", + mode_fun = function(arg) "double", + expr_fun = function(arg, intrinsic) glue("atan2(aimag({arg}), real({arg}))") +) -# conjg() returns a complex value; R uses Conj() -r2f_handlers[["Conj"]] <- function(args, scope, ...) { - stopifnot(length(args) == 1L) - arg <- r2f(args[[1]], scope, ...) - val <- Variable(mode = "complex", dims = arg@value@dims) - Fortran(glue("conjg({arg})"), val) -} +register_unary_intrinsic( + "Conj", + mode_fun = function(arg) "complex", + expr_fun = function(arg, intrinsic) glue("conjg({arg})") +) # ---- elemental binary infix operators ---- @@ -1374,298 +1359,6 @@ r2f_handlers[["c"]] <- function(args, scope = NULL, ...) { Fortran(s, Variable(mode, list(len))) } - -r2f_handlers[["cbind"]] <- function(e, scope) { - .NotYetImplemented() - ee <- lapply(e[-1], r2f, scope) - ncols <- lapply(ee, function(f) { - if (f@value@rank %in% c(0, 1)) { - 1 - } else if (f@value@rank == 2) { - f@value@dims[[2]] - } - }) - ncols <- Reduce(\(a, b) call("+", a, b), ncols) - ncols <- eval(ncols, scope@sizes) -} - -r2f_handlers[["<-"]] <- function(args, scope, ..., hoist = NULL) { - target <- args[[1]] - if (is.call(target)) { - # given a call like `foo(x) <- y`, dispatch to `foo<-` - target_callable <- target[[1]] - stopifnot(is.symbol(target_callable)) - name <- as.symbol(paste0(as.character(target_callable), "<-")) - handler <- get_r2f_handler(name) - return(handler(args, scope, ..., hoist = hoist)) # new hoist target - } - - # It sure seems like it's be nice if the Fortran() constructor - # took mode and dims as args directly, - # without needing to go through Variable... - stopifnot(is.symbol(target)) - name <- as.character(target) - - rhs <- args[[2]] - - # Fall-through assignment: `a <- b <- expr` (or `a <- (b <- expr)`). - # R evaluates this right-to-left and returns the assigned value, i.e. - # `a <- (b <- expr)` is equivalent to `b <- expr; a <- b`. - rhs_unwrapped <- rhs - while (is_call(rhs_unwrapped, "(") && length(rhs_unwrapped) == 2L) { - rhs_unwrapped <- rhs_unwrapped[[2L]] - } - if ( - (is_call(rhs_unwrapped, "<-") || is_call(rhs_unwrapped, "=")) && - length(rhs_unwrapped) == 3L && - is.symbol(rhs_unwrapped[[2L]]) - ) { - inner_target <- rhs_unwrapped[[2L]] - inner_rhs <- rhs_unwrapped[[3L]] - - inner_stmt <- r2f( - call("<-", inner_target, inner_rhs), - scope, - ..., - hoist = hoist - ) - outer_stmt <- r2f( - call("<-", target, inner_target), - scope, - ..., - hoist = hoist - ) - - return(Fortran(str_flatten_lines(inner_stmt, outer_stmt))) - } - - # Local closure definition: `f <- function(i) ...` - if (is_function_call(rhs)) { - scope[[name]] <- as_local_closure( - rhs, - environment(scope@closure), - name = name - ) - return(Fortran("")) - } - - # Local closure call: `x <- f(...)` where `f <- function(...) ...` in scope. - if ( - is.call(rhs) && - is.symbol(rhs[[1L]]) && - inherits(scope[[as.character(rhs[[1L]])]], LocalClosure) - ) { - return(compile_closure_call_assignment( - name, - rhs, - scope, - ..., - hoist = hoist - )) - } - - # Targeted higher-order lowering: `out <- sapply(seq_along(x), f)` - if (is_sapply_call(rhs)) { - parallel <- take_pending_parallel(scope) - return( - compile_sapply_assignment( - name, - rhs, - scope, - ..., - hoist = hoist, - parallel = parallel - ) - ) - } - - dest_allowed <- dest_supported_for_call(rhs) - - # If target already exists (declared), thread destination hint to a single BLAS-capable child - var <- get0(name, scope, inherits = FALSE) - existing_binding <- !is.null(var) && inherits(var, Variable) - inferred_var <- NULL - fortran_name <- NULL - if (!existing_binding && dest_allowed) { - inferred_var <- dest_infer_for_call(rhs, scope) - fortran_name <- if ( - scope_is_closure(scope) && inherits(get0(name, scope), Variable) - ) { - make_shadow_fortran_name(scope, name) - } else { - name - } - } - - if (existing_binding) { - value <- if (dest_allowed) { - r2f(rhs, scope, ..., hoist = hoist, dest = var) - } else { - r2f(rhs, scope, ..., hoist = hoist) - } - } else if (inherits(inferred_var, Variable)) { - var <- inferred_var - var@name <- fortran_name - value <- r2f(rhs, scope, ..., hoist = hoist, dest = var) - } else { - value <- r2f(rhs, scope, ..., hoist = hoist) - } - - # immutable / copy-on-modify usage of Variable() - if (!existing_binding) { - # The var does not exist -> this is a binding to a new symbol - # Create a fresh Variable carrying only mode/dims and a new name. - if (!inherits(var, Variable)) { - src <- value@value - var <- Variable(mode = src@mode, dims = src@dims) - } - if (is.null(fortran_name)) { - fortran_name <- if ( - scope_is_closure(scope) && inherits(get0(name, scope), Variable) - ) { - make_shadow_fortran_name(scope, name) - } else { - name - } - } - var@name <- fortran_name - # keep a reference to the R expression assigned, if available - tryCatch( - var@r <- attr(value, "r", TRUE), - error = function(e) NULL - ) - scope[[name]] <- var - } else { - # The var already exists, this assignment is a modification / reassignment - check_assignment_compatible(var, value@value) - var@modified <- TRUE - # could probably drop this @modified property, and instead track - # if the var populated by declare is identical at the end (e.g., perhaps by - # address, or by attaching a unique id to each var, or ???) - assign(name, var, scope) - } - - # If child consumed destination (e.g., BLAS wrote directly into LHS), skip assignment - if (isTRUE(attr(value, "writes_to_dest", TRUE))) { - Fortran("") - } else { - Fortran(glue("{var@name} = {value}")) - } -} - -r2f_handlers[["[<-"]] <- function(args, scope = NULL, ...) { - # TODO: handle logical subsetting here, which must become a where a construct like: - # x[lgl] <- val - # becomes - # where (lgl) - # x = val - # end where - # ! but if {va} references {x}, it will only see the subset x, not the full {x} - # e.g., - # sum(x) is not the same as `where lgl \n sum(x) \n end where` - # ditto for ifelse() ? - # e <- as.list(e) - - stopifnot(is_call(target_call <- args[[1L]], "[")) - - lhs <- compile_subscript_lhs(target_call, scope, ..., target = "local") - value <- r2f(args[[2L]], scope, ...) - - Fortran(str_flatten_lines(lhs$pre, glue("{lhs$lhs} = {value}"))) -} - -r2f_handlers[["<<-"]] <- function(args, scope, ..., hoist = NULL) { - if (is.null(scope) || !identical(scope@kind, "closure")) { - stop("<<- is only supported inside local closures") - } - - target <- args[[1L]] - if (is.call(target)) { - target_callable <- target[[1L]] - stopifnot(is.symbol(target_callable)) - name <- as.symbol(paste0(as.character(target_callable), "<<-")) - handler <- get_r2f_handler(name) - return(handler(args, scope, ..., hoist = hoist)) - } - - stopifnot(is.symbol(target)) - name <- as.character(target) - - formal_names <- names(formals(scope@closure)) %||% character() - if (name %in% formal_names) { - stop("<<- targets must not shadow closure formals: ", name) - } - - forbidden <- attr(scope, "forbid_superassign", exact = TRUE) %||% character() - if (name %in% forbidden) { - stop("closure must not superassign to its output variable: ", name) - } - - host_scope <- scope@host_scope %||% stop("internal error: missing host scope") - host_var <- get0(name, host_scope) - if (!inherits(host_var, Variable)) { - stop( - "<<- targets must resolve to an existing variable in the enclosing quick() scope: ", - name - ) - } - - host_var@modified <- TRUE - host_scope[[name]] <- host_var - - value <- r2f(args[[2L]], scope, ..., hoist = hoist) - check_assignment_compatible(host_var, value@value) - - Fortran(glue("{host_var@name} = {value}")) -} - -r2f_handlers[["[<<-"]] <- function(args, scope, ..., hoist = NULL) { - if (is.null(scope) || !identical(scope@kind, "closure")) { - stop("<<- is only supported inside local closures") - } - - stopifnot(is_call(target <- args[[1L]], "[")) - subset_call <- target - - base <- subset_call[[2L]] - if (!is.symbol(base)) { - stop("only superassignment to x[...] is supported") - } - name <- as.character(base) - - formal_names <- names(formals(scope@closure)) %||% character() - if (name %in% formal_names) { - stop("<<- targets must not shadow closure formals: ", name) - } - - forbidden <- attr(scope, "forbid_superassign", exact = TRUE) %||% character() - if (name %in% forbidden) { - stop("closure must not superassign to its output variable: ", name) - } - - host_scope <- scope@host_scope %||% stop("internal error: missing host scope") - host_var <- get0(name, host_scope) - if (!inherits(host_var, Variable)) { - stop( - "<<- targets must resolve to an existing variable in the enclosing quick() scope: ", - name - ) - } - - host_var@modified <- TRUE - host_scope[[name]] <- host_var - - lhs <- compile_subscript_lhs( - subset_call, - scope, - ..., - hoist = hoist, - target = "host" - ) - value <- r2f(args[[2L]], scope, ..., hoist = hoist) - Fortran(glue("{lhs$lhs} = {value}")) -} - reduce_promoted_mode <- function(...) { getmode <- function(d) { if (inherits(d, Fortran)) { @@ -1692,25 +1385,29 @@ reduce_promoted_mode <- function(...) { } -r2f_handlers[["="]] <- r2f_handlers[["<-"]] - -r2f_handlers[["logical"]] <- function(args, scope, ...) { - Fortran(".false.", Variable(mode = "logical", dims = r2dims(args, scope))) -} -attr(r2f_handlers[["logical"]], "match.fun") <- FALSE - -r2f_handlers[["integer"]] <- function(args, scope, ...) { - Fortran("0", Variable(mode = "integer", dims = r2dims(args, scope))) -} -attr(r2f_handlers[["integer"]], "match.fun") <- FALSE +register_r2f_handler( + "logical", + function(args, scope, ...) { + Fortran(".false.", Variable(mode = "logical", dims = r2dims(args, scope))) + }, + match_fun = FALSE +) -r2f_handlers[["double"]] <- function(args, scope, ...) { - Fortran("0", Variable(mode = "double", dims = r2dims(args, scope))) -} -attr(r2f_handlers[["double"]], "match.fun") <- FALSE +register_r2f_handler( + "integer", + function(args, scope, ...) { + Fortran("0", Variable(mode = "integer", dims = r2dims(args, scope))) + }, + match_fun = FALSE +) -r2f_handlers[["numeric"]] <- r2f_handlers[["double"]] -attr(r2f_handlers[["numeric"]], "match.fun") <- FALSE +register_r2f_handler( + c("double", "numeric"), + function(args, scope, ...) { + Fortran("0", Variable(mode = "double", dims = r2dims(args, scope))) + }, + match_fun = FALSE +) r2f_handlers[["runif"]] <- function(args, scope, ..., hoist = NULL) { attr(scope, "uses_rng") <- TRUE @@ -1895,9 +1592,6 @@ r2f_handlers[["dim"]] <- function(args, scope, ...) { # this is just `[` handler -r2f_slice <- function(args, scope, ...) {} - - # ---- control flow ---- r2f_handlers[["if"]] <- function(args, scope, ..., hoist = NULL) { diff --git a/R/sub-r2f-matrix.R b/R/sub-r2f-matrix.R deleted file mode 100644 index 25d3ce4e..00000000 --- a/R/sub-r2f-matrix.R +++ /dev/null @@ -1,1072 +0,0 @@ -# Matrix-specific r2f handlers and helpers - -# ---- matrix operation handlers ---- - -# %*% handler with optional destination hint -r2f_handlers[["%*%"]] <- function(args, scope, ..., hoist = NULL, dest = NULL) { - stopifnot(length(args) == 2L) - left_info <- unwrap_transpose_arg(args[[1L]], scope, ..., hoist = hoist) - right_info <- unwrap_transpose_arg(args[[2L]], scope, ..., hoist = hoist) - left <- left_info$value - right <- right_info$value - left_trans <- left_info$trans - right_trans <- right_info$trans - - left_rank <- left@value@rank - right_rank <- right@value@rank - - if (left_rank > 2 || right_rank > 2) { - stop("%*% only supports vectors/matrices (rank <= 2)") - } - - left_dims <- matrix_dims( - left, - orientation = if (left_rank == 1) "rowvec" else "matrix" - ) - - right_dims <- matrix_dims( - right, - orientation = if (right_rank == 1) "colvec" else "matrix" - ) - - left_eff <- if (left_rank == 2) { - effective_dims(left_dims, left_trans) - } else { - left_dims - } - right_eff <- if (right_rank == 2) { - effective_dims(right_dims, right_trans) - } else { - right_dims - } - - # Compute effective shapes - m <- left_eff$rows - k <- left_eff$cols - n <- right_eff$cols - - # Leading dimensions - lda <- left_dims$rows - ldb <- right_dims$rows - ldc_expr <- m - - # Matrix-Vector: use GEMV - if (left_rank == 2 && right_rank == 1) { - expected_len <- if (left_trans == "N") left_dims$cols else left_dims$rows - assert_conformable(expected_len, right_dims$rows, "%*%") - out_len <- if (left_trans == "N") left_dims$rows else left_dims$cols - return(gemv( - transA = left_trans, - A = left, - x = right, - m = left_dims$rows, - n = left_dims$cols, - lda = left_dims$rows, - out_dims = list(out_len, 1L), - scope = scope, - hoist = hoist, - dest = dest, - context = "%*%" - )) - } - # Vector-Matrix: use GEMV with transpose - if (left_rank == 1 && right_rank == 2) { - transA <- if (right_trans == "N") "T" else "N" - expected_len <- if (transA == "N") right_dims$cols else right_dims$rows - assert_conformable(left_dims$cols, expected_len, "%*%") - out_len <- if (transA == "N") right_dims$rows else right_dims$cols - return(gemv( - transA = transA, - A = right, - x = left, - m = right_dims$rows, - n = right_dims$cols, - lda = right_dims$rows, - out_dims = list(1L, out_len), - scope = scope, - hoist = hoist, - dest = dest, - context = "%*%" - )) - } - - assert_conformable(k, right_eff$rows, "%*%") - - # Matrix-Matrix - gemm( - opA = left_trans, - opB = right_trans, - left = left, - right = right, - m = m, - n = n, - k = k, - lda = lda, - ldb = ldb, - ldc_expr = ldc_expr, - scope = scope, - hoist = hoist, - dest = dest, - context = "%*%" - ) -} - - -# t(x) handler: transpose 2D; 1D becomes a 1 x n row matrix -r2f_handlers[["t"]] <- function(args, scope, ..., hoist = NULL) { - stopifnot(length(args) == 1L) - x <- r2f(args[[1L]], scope, ..., hoist = hoist) - x <- maybe_cast_double(x) - if (x@value@rank == 2) { - val <- Variable("double", list(x@value@dims[[2]], x@value@dims[[1]])) - return(Fortran(glue("transpose({x})"), val)) - } else if (x@value@rank == 1) { - len <- x@value@dims[[1]] - val <- Variable("double", list(1L, len)) - return(Fortran(glue("reshape({x}, [1, int({len})])"), val)) - } else if (x@value@rank == 0) { - return(x) - } else { - stop("t() only supports rank 0-2 inputs") - } -} - - -# Handle crossprod(), using SYRK for single-arg and GEMM for two-arg forms. -r2f_handlers[["crossprod"]] <- function( - args, - scope, - ..., - hoist = NULL, - dest = NULL -) { - x_arg <- args[[1L]] - y_arg <- if (length(args) > 1L) args[[2L]] else NULL - crossprod_like( - x_arg = x_arg, - y_arg = y_arg, - scope = scope, - ..., - hoist = hoist, - dest = dest, - trans_single = "T", - opA = "T", - opB = "N", - context = "crossprod" - ) -} - - -# Handle tcrossprod(), using SYRK for single-arg and GEMM for two-arg forms. -r2f_handlers[["tcrossprod"]] <- function( - args, - scope, - ..., - hoist = NULL, - dest = NULL -) { - x_arg <- args[[1L]] - y_arg <- if (length(args) > 1L) args[[2L]] else NULL - crossprod_like( - x_arg = x_arg, - y_arg = y_arg, - scope = scope, - ..., - hoist = hoist, - dest = dest, - trans_single = "N", - opA = "N", - opB = "T", - context = "tcrossprod" - ) -} - -# Handle outer() for FUN = "*" as BLAS outer product. -r2f_handlers[["outer"]] <- function( - args, - scope, - ..., - hoist = NULL, - dest = NULL -) { - x_arg <- args$X %||% args[[1L]] - y_arg <- args$Y %||% if (length(args) >= 2L) args[[2L]] else NULL - if (is.null(x_arg) || is.null(y_arg)) { - stop("outer() expects X and Y") - } - - fun <- args$FUN %||% "*" - if (!identical(fun, "*")) { - stop("outer() only supports FUN = \"*\"") - } - x <- r2f(x_arg, scope, ..., hoist = hoist) - y <- r2f(y_arg, scope, ..., hoist = hoist) - outer_mul( - x, - y, - scope = scope, - hoist = hoist, - dest = dest, - context = "outer" - ) -} - -# Handle %o% for outer products via BLAS GER. -r2f_handlers[["%o%"]] <- function( - args, - scope, - ..., - hoist = NULL, - dest = NULL -) { - stopifnot(length(args) == 2L) - x <- r2f(args[[1L]], scope, ..., hoist = hoist) - y <- r2f(args[[2L]], scope, ..., hoist = hoist) - outer_mul( - x, - y, - scope = scope, - hoist = hoist, - dest = dest, - context = "%o%" - ) -} - -# Handle forwardsolve() via triangular BLAS routines. -r2f_handlers[["forwardsolve"]] <- function( - args, - scope, - ..., - hoist = NULL, - dest = NULL -) { - stopifnot(length(args) >= 2L) - if (!is.null(args$k)) { - stop("forwardsolve() does not support k yet") - } - upper_tri <- logical_arg_or_default( - args, - "upper.tri", - FALSE, - "forwardsolve()" - ) - transpose <- logical_arg_or_default( - args, - "transpose", - FALSE, - "forwardsolve()" - ) - diag_unit <- logical_arg_or_default(args, "diag", FALSE, "forwardsolve()") - - A <- r2f(args[[1L]], scope, ..., hoist = hoist) - B <- r2f(args[[2L]], scope, ..., hoist = hoist) - - triangular_solve( - A = A, - B = B, - uplo = if (upper_tri) "U" else "L", - trans = if (transpose) "T" else "N", - diag = if (diag_unit) "U" else "N", - scope = scope, - hoist = hoist, - dest = dest, - context = "forwardsolve" - ) -} - -# Handle backsolve() via triangular BLAS routines. -r2f_handlers[["backsolve"]] <- function( - args, - scope, - ..., - hoist = NULL, - dest = NULL -) { - stopifnot(length(args) >= 2L) - if (!is.null(args$k)) { - stop("backsolve() does not support k yet") - } - upper_tri <- logical_arg_or_default(args, "upper.tri", TRUE, "backsolve()") - transpose <- logical_arg_or_default(args, "transpose", FALSE, "backsolve()") - diag_unit <- logical_arg_or_default(args, "diag", FALSE, "backsolve()") - - A <- r2f(args[[1L]], scope, ..., hoist = hoist) - B <- r2f(args[[2L]], scope, ..., hoist = hoist) - - triangular_solve( - A = A, - B = B, - uplo = if (upper_tri) "U" else "L", - trans = if (transpose) "T" else "N", - diag = if (diag_unit) "U" else "N", - scope = scope, - hoist = hoist, - dest = dest, - context = "backsolve" - ) -} - -# ---- matrix helpers ---- - -# Return the R symbol name if operand is a bare symbol; otherwise NULL. -symbol_name_or_null <- function(x) { - stopifnot(inherits(x, Fortran)) - r_expr <- x@r - if (is.symbol(r_expr)) { - return(as.character(r_expr)) - } - if (length(x) == 1L && grepl("^[A-Za-z][A-Za-z0-9_]*$", x)) { - return(as.character(x)) - } - NULL -} - -# Return a dimension value for an axis, defaulting missing dims to 1L. -dim_or_one_from <- function(dims, axis) { - stopifnot(is.numeric(axis), axis >= 1) - axis <- as.integer(axis) - if (is.null(dims)) { - return(1L) - } - if (axis <= length(dims) && !is.null(dims[[axis]])) { - dims[[axis]] - } else { - 1L - } -} - -# Return the requested axis length, defaulting scalars (or missing axes) to 1L. -dim_or_one <- function(x, axis) { - stopifnot(inherits(x, Fortran)) - dim_or_one_from(x@value@dims, axis) -} - -# Return the requested axis length for a Variable, defaulting to 1L. -var_dim_or_one <- function(var, axis) { - stopifnot(inherits(var, Variable)) - dim_or_one_from(var@dims, axis) -} - -# Compute matrix-style row/column dimensions from rank, dims, and orientation. -matrix_dims_from <- function( - rank, - dims, - orientation = c("matrix", "rowvec", "colvec") -) { - orientation <- match.arg(orientation) - rows <- dim_or_one_from(dims, 1L) - cols <- dim_or_one_from(dims, 2L) - - if (rank == 0L) { - rows <- 1L - cols <- 1L - } else if (rank == 1L) { - if (orientation == "rowvec") { - rows <- 1L - cols <- dim_or_one_from(dims, 1L) - } else { - rows <- dim_or_one_from(dims, 1L) - cols <- 1L - } - } - - list(rows = rows, cols = cols) -} - -# Interpret a Fortran value as a matrix for BLAS calls. Scalars become 1x1 -# matrices, and vectors can be viewed as either row or column vectors. -matrix_dims <- function(x, orientation = c("matrix", "rowvec", "colvec")) { - stopifnot(inherits(x, Fortran)) - matrix_dims_from(x@value@rank, x@value@dims, orientation = orientation) -} - -# Interpret a Variable value as a matrix for BLAS calls. -matrix_dims_var <- function( - var, - orientation = c("matrix", "rowvec", "colvec") -) { - stopifnot(inherits(var, Variable)) - matrix_dims_from(var@rank, var@dims, orientation = orientation) -} - -# Compute effective dimensions based on transpose flags. -effective_dims <- function(dims, trans) { - if (identical(trans, "T")) { - list(rows = dims$cols, cols = dims$rows) - } else { - dims - } -} - -# Validate conformability, warning when static checks are inconclusive. -assert_conformable <- function(left, right, context) { - if (is_wholenumber(left) && is_wholenumber(right)) { - if (!identical(as.integer(left), as.integer(right))) { - stop("non-conformable arguments in ", context, call. = FALSE) - } - return(invisible(TRUE)) - } - if (identical(left, right)) { - return(invisible(TRUE)) - } - - left_txt <- if (is.null(left)) "NULL" else deparse(left) - right_txt <- if (is.null(right)) "NULL" else deparse(right) - warning( - "cannot verify conformability in ", - context, - " at compile time: ", - left_txt, - " vs ", - right_txt, - call. = FALSE - ) - invisible(FALSE) -} - -# Unwrap t() calls to infer transpose flags and normalize scalars/vectors. -unwrap_transpose_arg <- function(arg, scope, ..., hoist) { - if (is_call(arg, quote(t)) && length(arg) == 2L) { - inner <- r2f(arg[[2L]], scope, ..., hoist = hoist) - inner <- maybe_cast_double(inner) - if (inner@value@rank == 2L) { - return(list(value = inner, trans = "T")) - } else if (inner@value@rank == 1L) { - len <- inner@value@dims[[1L]] - val <- Variable("double", list(1L, len)) - return(list( - value = Fortran(glue("reshape({inner}, [1, int({len})])"), val), - trans = "N" - )) - } else if (inner@value@rank == 0L) { - return(list(value = inner, trans = "N")) - } else { - stop("t() only supports rank 0-2 inputs") - } - } - value <- r2f(arg, scope, ..., hoist = hoist) - value <- maybe_cast_double(value) - list(value = value, trans = "N") -} - -# Check that destination dimensions match expected output dimensions. -assert_dest_dims_compatible <- function(dest, expected_dims, context) { - if (is.null(dest) || is.null(expected_dims)) { - return(invisible(TRUE)) - } - expected_rank <- length(expected_dims) - if (dest@rank != expected_rank) { - stop("assignment target has incompatible rank for ", context, call. = FALSE) - } - for (i in seq_len(expected_rank)) { - dest_dim <- dest@dims[[i]] - expected_dim <- expected_dims[[i]] - if (is_wholenumber(dest_dim) && is_wholenumber(expected_dim)) { - if (!identical(as.integer(dest_dim), as.integer(expected_dim))) { - stop( - "assignment target has incompatible dimensions for ", - context, - call. = FALSE - ) - } - } - } - invisible(TRUE) -} - -# Determine if output can safely write into dest without aliasing. -can_use_output <- function(dest, left, right, expected_dims = NULL, context) { - if (is.null(dest)) { - return(FALSE) - } - if (!identical(dest@mode, "double")) { - return(FALSE) - } - assert_dest_dims_compatible(dest, expected_dims, context) - output_name <- dest@name - # check output name is not the same as left or right - !identical(output_name, as.character(left)) && - !identical(output_name, as.character(right)) -} - -# Ensure a BLAS operand is named, hoisting into a temp if needed. -ensure_blas_operand_name <- function(x, hoist) { - name <- symbol_name_or_null(x) - if (!is.null(name)) { - return(name) - } - tmp <- hoist$declare_tmp( - mode = x@value@mode %||% "double", - dims = x@value@dims - ) - hoist$emit(glue("{tmp@name} = {x}")) - tmp@name -} - -# Extract a logical argument or use the provided default. -logical_arg_or_default <- function(args, name, default, context) { - val <- args[[name]] %||% default - if (is.null(val)) { - return(default) - } - if (!is.logical(val) || length(val) != 1L || is.na(val)) { - stop(context, " only supports literal ", name, " = TRUE/FALSE") - } - val -} - -# Wrap an expression as a BLAS int literal. -blas_int <- function(x) { - glue("int({x}, kind=c_int)") -} - -# Centralized GEMM emission with optional destination -# gemm: centralized BLAS GEMM emission. -# - 'hoist' is required and provided by r2f(); handlers thread it through so -# helpers can pre-emit temporary assignments and BLAS calls. -gemm <- function( - opA, - opB, - left, - right, - m, - n, - k, - lda, - ldb, - ldc_expr, - scope, - hoist, - dest = NULL, - context = "gemm" -) { - if (!inherits(hoist, "environment")) { - stop("internal: hoist must be a hoist environment") - } - A_name <- ensure_blas_operand_name(left, hoist) - B_name <- ensure_blas_operand_name(right, hoist) - - if ( - can_use_output( - dest, - left, - right, - expected_dims = list(m, n), - context = context - ) - ) { - hoist$emit(glue( - "call dgemm('{opA}','{opB}', {blas_int(m)}, {blas_int(n)}, {blas_int(k)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {B_name}, {blas_int(ldb)}, 0.0_c_double, {dest@name}, {blas_int(ldc_expr)})" - )) - out <- Fortran(dest@name, dest) - attr(out, "writes_to_dest") <- TRUE - return(out) - } - - output_var <- hoist$declare_tmp(mode = "double", dims = list(m, n)) - hoist$emit(glue( - "call dgemm('{opA}','{opB}', {blas_int(m)}, {blas_int(n)}, {blas_int(k)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {B_name}, {blas_int(ldb)}, 0.0_c_double, {output_var@name}, {blas_int(ldc_expr)})" - )) - Fortran(output_var@name, output_var) -} - -# Centralized GEMV emission with optional destination -# gemv: centralized BLAS GEMV emission. -# - 'hoist' is required and provided by r2f(); handlers thread it through so -# helpers can pre-emit temporary assignments and BLAS calls. -gemv <- function( - transA, - A, - x, - m, - n, - lda, - out_dims, - scope, - hoist, - dest = NULL, - context = "gemv" -) { - if (!inherits(hoist, "environment")) { - stop("internal: hoist must be a hoist environment") - } - A_name <- ensure_blas_operand_name(A, hoist) - x_name <- ensure_blas_operand_name(x, hoist) - - if ( - can_use_output( - dest, - A, - x, - expected_dims = out_dims, - context = context - ) - ) { - # Assign output to output destination - hoist$emit(glue( - "call dgemv('{transA}', {blas_int(m)}, {blas_int(n)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {x_name}, 1, 0.0_c_double, {dest@name}, 1)" - )) - out <- Fortran(dest@name, dest) - attr(out, "writes_to_dest") <- TRUE - return(out) - } - # Else assign to a temporary variable - output_var <- hoist$declare_tmp(mode = "double", dims = out_dims) - hoist$emit(glue( - "call dgemv('{transA}', {blas_int(m)}, {blas_int(n)}, 1.0_c_double, {A_name}, {blas_int(lda)}, {x_name}, 1, 0.0_c_double, {output_var@name}, 1)" - )) - Fortran(output_var@name, output_var) -} - -# Centralized SYRK emission for symmetric rank-k update -# Computes: C := alpha * op(A) * op(A)^T + beta * C -# For crossprod(X): C = t(X) %*% X → trans = "T" -# For tcrossprod(X): C = X %*% t(X) → trans = "N" -syrk <- function( - trans, - X, - scope, - hoist, - dest = NULL, - context = "syrk" -) { - if (!inherits(hoist, "environment")) { - stop("internal: hoist must be a hoist environment") - } - X_name <- ensure_blas_operand_name(X, hoist) - - x_dims <- matrix_dims(X) - - # For trans = "T": C = t(X) %*% X, so C is k x k where k = ncol(X) - # For trans = "N": C = X %*% t(X), so C is n x n where n = nrow(X) - if (trans == "T") { - n <- x_dims$cols - k <- x_dims$rows - } else { - n <- x_dims$rows - k <- x_dims$cols - } - lda <- x_dims$rows - - # Output is symmetric n x n matrix - if ( - can_use_output( - dest, - X, - X, - expected_dims = list(n, n), - context = context - ) - ) { - hoist$emit(glue( - "call dsyrk('U', '{trans}', {blas_int(n)}, {blas_int(k)}, 1.0_c_double, {X_name}, {blas_int(lda)}, 0.0_c_double, {dest@name}, {blas_int(n)})" - )) - # Fill lower triangle from upper - idx_i <- hoist$declare_tmp(mode = "integer", dims = list(1L)) - idx_j <- hoist$declare_tmp(mode = "integer", dims = list(1L)) - hoist$emit(glue( - " -do {idx_j@name} = 1_c_int, {n} - 1_c_int - do {idx_i@name} = {idx_j@name} + 1_c_int, {n} - {dest@name}({idx_i@name}, {idx_j@name}) = {dest@name}({idx_j@name}, {idx_i@name}) - end do -end do" - )) - out <- Fortran(dest@name, dest) - attr(out, "writes_to_dest") <- TRUE - return(out) - } - - output_var <- hoist$declare_tmp(mode = "double", dims = list(n, n)) - hoist$emit(glue( - "call dsyrk('U', '{trans}', {blas_int(n)}, {blas_int(k)}, 1.0_c_double, {X_name}, {blas_int(lda)}, 0.0_c_double, {output_var@name}, {blas_int(n)})" - )) - # Fill lower triangle from upper - idx_i <- hoist$declare_tmp(mode = "integer", dims = list(1L)) - idx_j <- hoist$declare_tmp(mode = "integer", dims = list(1L)) - hoist$emit(glue( - " -do {idx_j@name} = 1_c_int, {n} - 1_c_int - do {idx_i@name} = {idx_j@name} + 1_c_int, {n} - {output_var@name}({idx_i@name}, {idx_j@name}) = {output_var@name}({idx_j@name}, {idx_i@name}) - end do -end do" - )) - Fortran(output_var@name, output_var) -} - -# Emit BLAS outer product for vectors or scalars with optional destination. -outer_mul <- function( - x, - y, - scope, - hoist, - dest = NULL, - context = "outer" -) { - if (!inherits(hoist, "environment")) { - stop("internal: hoist must be a hoist environment") - } - - x <- maybe_cast_double(x) - y <- maybe_cast_double(y) - - if (x@value@rank > 1L || y@value@rank > 1L) { - stop("outer() only supports vectors or scalars") - } - - m <- dim_or_one(x, 1L) - n <- dim_or_one(y, 1L) - - x_name <- ensure_blas_operand_name(x, hoist) - y_name <- ensure_blas_operand_name(y, hoist) - - if ( - can_use_output( - dest, - x, - y, - expected_dims = list(m, n), - context = context - ) - ) { - hoist$emit(glue("{dest@name} = 0.0_c_double")) - hoist$emit(glue( - "call dger({blas_int(m)}, {blas_int(n)}, 1.0_c_double, {x_name}, 1, {y_name}, 1, {dest@name}, {blas_int(m)})" - )) - out <- Fortran(dest@name, dest) - attr(out, "writes_to_dest") <- TRUE - return(out) - } - - output_var <- hoist$declare_tmp(mode = "double", dims = list(m, n)) - hoist$emit(glue("{output_var@name} = 0.0_c_double")) - hoist$emit(glue( - "call dger({blas_int(m)}, {blas_int(n)}, 1.0_c_double, {x_name}, 1, {y_name}, 1, {output_var@name}, {blas_int(m)})" - )) - Fortran(output_var@name, output_var) -} - -# Emit triangular solve (vector or matrix RHS) with optional destination. -triangular_solve <- function( - A, - B, - uplo, - trans, - diag, - scope, - hoist, - dest = NULL, - context = "triangular solve" -) { - if (!inherits(hoist, "environment")) { - stop("internal: hoist must be a hoist environment") - } - - A <- maybe_cast_double(A) - B <- maybe_cast_double(B) - - if (A@value@rank != 2L) { - stop("triangular solve expects a matrix") - } - - a_dims <- matrix_dims(A) - assert_conformable(a_dims$rows, a_dims$cols, "triangular solve") - n <- a_dims$rows - - b_rank <- B@value@rank - if (b_rank > 2L) { - stop("triangular solve only supports vector or matrix right-hand sides") - } - if (b_rank == 0L) { - stop("triangular solve expects a vector or matrix right-hand side") - } else if (b_rank == 1L) { - b_len <- dim_or_one(B, 1L) - assert_conformable(n, b_len, "triangular solve") - } else { - b_rows <- dim_or_one(B, 1L) - assert_conformable(n, b_rows, "triangular solve") - } - - A_name <- ensure_blas_operand_name(A, hoist) - - if ( - can_use_output( - dest, - A, - B, - expected_dims = B@value@dims, - context = context - ) - ) { - hoist$emit(glue("{dest@name} = {B}")) - B_name <- dest@name - out_var <- dest - writes_to_dest <- TRUE - } else { - out_var <- hoist$declare_tmp( - mode = B@value@mode %||% "double", - dims = B@value@dims - ) - hoist$emit(glue("{out_var@name} = {B}")) - B_name <- out_var@name - writes_to_dest <- FALSE - } - - if (b_rank <= 1L) { - hoist$emit(glue( - "call dtrsv('{uplo}', '{trans}', '{diag}', {blas_int(n)}, {A_name}, {blas_int(n)}, {B_name}, 1)" - )) - } else { - nrhs <- dim_or_one(B, 2L) - hoist$emit(glue( - "call dtrsm('L', '{uplo}', '{trans}', '{diag}', {blas_int(n)}, {blas_int(nrhs)}, 1.0_c_double, {A_name}, {blas_int(n)}, {B_name}, {blas_int(n)})" - )) - } - - out <- Fortran(B_name, out_var) - if (writes_to_dest) { - attr(out, "writes_to_dest") <- TRUE - } - out -} - -# Shared crossprod/tcrossprod logic for one- and two-argument forms. -crossprod_like <- function( - x_arg, - y_arg, - scope, - ..., - hoist, - dest, - trans_single, - opA, - opB, - context -) { - x <- r2f(x_arg, scope, ..., hoist = hoist) - x <- maybe_cast_double(x) - - if (is.null(y_arg)) { - return(syrk( - trans = trans_single, - X = x, - scope = scope, - hoist = hoist, - dest = dest, - context = context - )) - } - - y <- maybe_cast_double(r2f(y_arg, scope, ..., hoist = hoist)) - - x_dims <- matrix_dims(x) - y_dims <- matrix_dims(y) - x_eff <- effective_dims(x_dims, opA) - y_eff <- effective_dims(y_dims, opB) - - assert_conformable(x_eff$cols, y_eff$rows, context) - - m <- x_eff$rows - n <- y_eff$cols - k <- x_eff$cols - - lda <- x_dims$rows - ldb <- y_dims$rows - ldc_expr <- m - - gemm( - opA = opA, - opB = opB, - left = x, - right = y, - m = m, - n = n, - k = k, - lda = lda, - ldb = ldb, - ldc_expr = ldc_expr, - scope = scope, - hoist = hoist, - dest = dest, - context = context - ) -} - -# ---- matrix inference helpers ---- - -# Infer a variable from a symbol in the current scope. -infer_symbol_var <- function(arg, scope) { - if (!is.symbol(arg)) { - return(NULL) - } - var <- get0(as.character(arg), scope, inherits = FALSE) - if (inherits(var, Variable)) var else NULL -} - -# Infer a matrix argument, handling t() and scalar/vector promotion. -infer_matrix_arg <- function(arg, scope) { - if (is_call(arg, quote(t)) && length(arg) == 2L) { - inner <- infer_symbol_var(arg[[2L]], scope) - if (is.null(inner)) { - return(NULL) - } - if (inner@rank == 2L) { - return(list(var = inner, trans = "T")) - } - if (inner@rank == 1L) { - len <- inner@dims[[1L]] - if (is.null(len)) { - return(NULL) - } - val <- Variable("double", list(1L, len)) - return(list(var = val, trans = "N")) - } - if (inner@rank == 0L) { - return(list(var = inner, trans = "N")) - } - return(NULL) - } - var <- infer_symbol_var(arg, scope) - if (is.null(var)) { - return(NULL) - } - list(var = var, trans = "N") -} - -# Infer destination dimensions for %*% based on inputs. -infer_dest_matmul <- function(args, scope) { - if (length(args) != 2L) { - return(NULL) - } - left_info <- infer_matrix_arg(args[[1L]], scope) - right_info <- infer_matrix_arg(args[[2L]], scope) - if (is.null(left_info) || is.null(right_info)) { - return(NULL) - } - - left <- left_info$var - right <- right_info$var - left_trans <- left_info$trans - right_trans <- right_info$trans - - left_rank <- left@rank - right_rank <- right@rank - if (left_rank > 2L || right_rank > 2L) { - return(NULL) - } - - left_dims <- matrix_dims_var( - left, - orientation = if (left_rank == 1L) "rowvec" else "matrix" - ) - right_dims <- matrix_dims_var( - right, - orientation = if (right_rank == 1L) "colvec" else "matrix" - ) - - left_eff <- if (left_rank == 2L) { - effective_dims(left_dims, left_trans) - } else { - left_dims - } - right_eff <- if (right_rank == 2L) { - effective_dims(right_dims, right_trans) - } else { - right_dims - } - - if (left_rank == 2L && right_rank == 1L) { - out_len <- if (left_trans == "N") left_dims$rows else left_dims$cols - return(Variable("double", list(out_len, 1L))) - } - if (left_rank == 1L && right_rank == 2L) { - transA <- if (right_trans == "N") "T" else "N" - out_len <- if (transA == "N") right_dims$rows else right_dims$cols - return(Variable("double", list(1L, out_len))) - } - - Variable("double", list(left_eff$rows, right_eff$cols)) -} - -# Shared inference for crossprod/tcrossprod destination sizes. -infer_dest_crossprod_like <- function(args, scope, trans) { - x <- infer_symbol_var(args[[1L]], scope) - if (is.null(x)) { - return(NULL) - } - y <- if (length(args) > 1L) infer_symbol_var(args[[2L]], scope) else NULL - x_dims <- matrix_dims_var(x) - if (is.null(y)) { - n <- if (identical(trans, "T")) x_dims$cols else x_dims$rows - return(Variable("double", list(n, n))) - } - y_dims <- matrix_dims_var(y) - if (identical(trans, "T")) { - Variable("double", list(x_dims$cols, y_dims$cols)) - } else { - Variable("double", list(x_dims$rows, y_dims$rows)) - } -} - -# Infer destination dimensions for crossprod(). -infer_dest_crossprod <- function(args, scope) { - infer_dest_crossprod_like(args, scope, trans = "T") -} - -# Infer destination dimensions for tcrossprod(). -infer_dest_tcrossprod <- function(args, scope) { - infer_dest_crossprod_like(args, scope, trans = "N") -} - -# Infer destination dimensions for outer() and %o%(). -infer_dest_outer <- function(args, scope) { - x_arg <- args$X %||% args[[1L]] - y_arg <- args$Y %||% if (length(args) >= 2L) args[[2L]] else NULL - x <- infer_symbol_var(x_arg, scope) - y <- infer_symbol_var(y_arg, scope) - if (is.null(x) || is.null(y)) { - return(NULL) - } - if (x@rank > 1L || y@rank > 1L) { - return(NULL) - } - m <- var_dim_or_one(x, 1L) - n <- var_dim_or_one(y, 1L) - Variable("double", list(m, n)) -} - -# Infer destination dimensions for forwardsolve() and backsolve(). -infer_dest_triangular <- function(args, scope) { - if (length(args) < 2L) { - return(NULL) - } - A <- infer_symbol_var(args[[1L]], scope) - B <- infer_symbol_var(args[[2L]], scope) - if (is.null(A) || is.null(B)) { - return(NULL) - } - if (A@rank != 2L || B@rank == 0L || B@rank > 2L) { - return(NULL) - } - if (is.null(B@dims)) { - return(NULL) - } - Variable("double", B@dims) -} - -attr(r2f_handlers[["%*%"]], "dest_supported") <- TRUE -attr(r2f_handlers[["crossprod"]], "dest_supported") <- TRUE -attr(r2f_handlers[["tcrossprod"]], "dest_supported") <- TRUE -attr(r2f_handlers[["outer"]], "dest_supported") <- TRUE -attr(r2f_handlers[["%o%"]], "dest_supported") <- TRUE -attr(r2f_handlers[["forwardsolve"]], "dest_supported") <- TRUE -attr(r2f_handlers[["backsolve"]], "dest_supported") <- TRUE - -attr(r2f_handlers[["%*%"]], "dest_infer") <- infer_dest_matmul -attr(r2f_handlers[["crossprod"]], "dest_infer") <- infer_dest_crossprod -attr(r2f_handlers[["tcrossprod"]], "dest_infer") <- infer_dest_tcrossprod -attr(r2f_handlers[["outer"]], "dest_infer") <- infer_dest_outer -attr(r2f_handlers[["%o%"]], "dest_infer") <- infer_dest_outer -attr(r2f_handlers[["forwardsolve"]], "dest_infer") <- infer_dest_triangular -attr(r2f_handlers[["backsolve"]], "dest_infer") <- infer_dest_triangular diff --git a/man/quick.Rd b/man/quick.Rd index 493006c4..83218709 100644 --- a/man/quick.Rd +++ b/man/quick.Rd @@ -118,17 +118,20 @@ quick_seq(1L, 5L) quickr compiles via \verb{R CMD SHLIB} and will normally use the same toolchain that R was built/configured with. -On macOS, quickr will speculatively prefer LLVM flang when it is available on -\code{PATH} (falling back to R's default toolchain if compilation fails). +quickr only uses LLVM flang when it is explicitly requested or, on macOS, +when flang is available on \code{PATH} (and \code{flang --version} succeeds). If flang +is requested but unavailable, compilation errors. If flang compilation +fails, quickr retries with the default toolchain; on success it emits a +one-time warning and disables automatic flang preference for the rest of the +session. In interactive use, you can explicitly control this with: -\if{html}{\out{
}}\preformatted{options(quickr.prefer_flang = TRUE) +\if{html}{\out{
}}\preformatted{options(quickr.fortran_compiler = "flang") }\if{html}{\out{
}} -To disable the macOS auto-preference, set \code{options(quickr.prefer_flang_auto = FALSE)} -(or set \code{options(quickr.prefer_flang = FALSE)} to opt out entirely). -In non-interactive scripts, set \code{Sys.setenv(QUICKR_PREFER_FLANG = "1")}. +To disable the macOS auto-preference, set +\code{options(quickr.fortran_compiler = "gfortran")}. } } \examples{ diff --git a/tests/testthat/_snaps/bind.md b/tests/testthat/_snaps/bind.md new file mode 100644 index 00000000..d6458b0e --- /dev/null +++ b/tests/testthat/_snaps/bind.md @@ -0,0 +1,11 @@ +# cbind/rbind reject rank > 2 inputs with clear errors + + Code + capture_bind_error(r2f(bad_cbind)) + Output + cbind() only supports rank 0-2 inputs + Code + capture_bind_error(r2f(bad_rbind)) + Output + rbind() only supports rank 0-2 inputs + diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index ed7b23f3..4b4a7f42 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -69,7 +69,7 @@ set_seed_and_call <- function(fun, ...) { fun(...) } -openmp_supported_or_skip <- local({ +skip_if_no_openmp <- local({ supported <- NULL function() { skip_on_cran() diff --git a/tests/testthat/test-assignment-writes-to-dest.R b/tests/testthat/test-assignment-writes-to-dest.R new file mode 100644 index 00000000..047a4e15 --- /dev/null +++ b/tests/testthat/test-assignment-writes-to-dest.R @@ -0,0 +1,11 @@ +test_that("assignment is not skipped when RHS does not write to dest", { + fn <- function(x) { + declare(type(x = double(1))) + x <- 1 + x + } + qfn <- quick(fn) + + args <- list(x = 2) + expect_equal(do.call(fn, args), do.call(qfn, args)) +}) diff --git a/tests/testthat/test-bind.R b/tests/testthat/test-bind.R new file mode 100644 index 00000000..f9b57f2e --- /dev/null +++ b/tests/testthat/test-bind.R @@ -0,0 +1,187 @@ +# Unit tests for cbind() and rbind() + +expect_bind_equal <- function(fn, ...) { + qfn := quick(fn) + args_list <- rlang::list2(...) + args_list <- lapply(args_list, function(x) if (!is.list(x)) list(x) else x) + + for (args in args_list) { + fn_res <- do.call(fn, args) + qfn_res <- do.call(qfn, args) + expect_identical(dim(fn_res), dim(qfn_res)) + expect_equal(unname(fn_res), unname(qfn_res)) + expect_identical(typeof(fn_res), typeof(qfn_res)) + } +} + +test_that("cbind binds vectors and matrices with scalar recycling", { + cbind_vec <- function(x, y, s) { + declare(type(x = double(n)), type(y = double(n)), type(s = double(1))) + cbind(x, y, s) + } + + set.seed(1) + x <- runif(4) + y <- runif(4) + s <- 2.5 + expect_bind_equal(cbind_vec, list(x, y, s)) + + cbind_mat <- function(A, v) { + declare(type(A = double(n, m)), type(v = double(n))) + cbind(A, v) + } + + A <- matrix(runif(6), nrow = 3) + v <- runif(3) + expect_bind_equal(cbind_mat, list(A, v)) + + cbind_int <- function(x, y) { + declare(type(x = integer(n)), type(y = integer(n))) + cbind(x, y) + } + + x_int <- 1:3 + y_int <- 4:6 + expect_bind_equal(cbind_int, list(x_int, y_int)) +}) + +test_that("rbind binds vectors and matrices with scalar recycling", { + rbind_vec <- function(x, y, s) { + declare(type(x = double(n)), type(y = double(n)), type(s = double(1))) + rbind(x, y, s) + } + + set.seed(2) + x <- runif(5) + y <- runif(5) + s <- -1.25 + expect_bind_equal(rbind_vec, list(x, y, s)) + + rbind_mat <- function(A, v) { + declare(type(A = double(n, m)), type(v = double(m))) + rbind(A, v) + } + + A <- matrix(runif(6), nrow = 2) + v <- runif(3) + expect_bind_equal(rbind_mat, list(A, v)) + + rbind_int <- function(x, y) { + declare(type(x = integer(n)), type(y = integer(n))) + rbind(x, y) + } + + x_int <- 1:4 + y_int <- 5:8 + expect_bind_equal(rbind_int, list(x_int, y_int)) +}) + +test_that("cbind/rbind enforce common lengths", { + bad_cbind <- function(x, y) { + declare(type(x = double(2)), type(y = double(3))) + cbind(x, y) + } + + expect_error( + quick(bad_cbind), + "common row count", + fixed = TRUE + ) + + bad_rbind <- function(A, B) { + declare(type(A = double(2, 3)), type(B = double(2, 4))) + rbind(A, B) + } + + expect_error( + quick(bad_rbind), + "common column count", + fixed = TRUE + ) +}) + +test_that("cbind/rbind reject rank > 2 inputs with clear errors", { + capture_bind_error <- function(expr) { + tryCatch(expr, error = function(e) cat(conditionMessage(e), "\n")) + } + + bad_cbind <- function(x) { + declare(type(x = double(2, 2, 2))) + cbind(x) + } + + bad_rbind <- function(x) { + declare(type(x = double(2, 2, 2))) + rbind(x) + } + + expect_snapshot({ + capture_bind_error(r2f(bad_cbind)) + capture_bind_error(r2f(bad_rbind)) + }) +}) + +test_that("cbind/rbind handle mixed rank-2, rank-1, and rank-0 inputs", { + cbind_mixed <- function(A, v1, s1, B, s2, v2, C, v3, s3) { + declare( + type(A = double(n, 2)), + type(B = double(n, 1)), + type(C = double(n, 3)), + type(v1 = double(n)), + type(v2 = double(n)), + type(v3 = double(n)), + type(s1 = double(1)), + type(s2 = double(1)), + type(s3 = double(1)) + ) + cbind(A, v1, s1, B, s2, v2, C, v3, s3) + } + + rbind_mixed <- function(A, v1, s1, B, s2, v2, C, v3, s3) { + declare( + type(A = double(2, m)), + type(B = double(1, m)), + type(C = double(3, m)), + type(v1 = double(m)), + type(v2 = double(m)), + type(v3 = double(m)), + type(s1 = double(1)), + type(s2 = double(1)), + type(s3 = double(1)) + ) + rbind(A, v1, s1, B, s2, v2, C, v3, s3) + } + + set.seed(42) + n <- 2L + A <- matrix(runif(n * 2L), nrow = n) + B <- matrix(runif(n * 1L), nrow = n) + C <- matrix(runif(n * 3L), nrow = n) + v1 <- runif(n) + v2 <- runif(n) + v3 <- runif(n) + s1 <- -0.5 + s2 <- 1.25 + s3 <- 0.0 + + expect_bind_equal( + cbind_mixed, + list(A, v1, s1, B, s2, v2, C, v3, s3) + ) + + m <- 3L + A2 <- matrix(runif(2L * m), nrow = 2L) + B2 <- matrix(runif(1L * m), nrow = 1L) + C2 <- matrix(runif(3L * m), nrow = 3L) + w1 <- runif(m) + w2 <- runif(m) + w3 <- runif(m) + t1 <- 2.0 + t2 <- -1.0 + t3 <- 0.5 + + expect_bind_equal( + rbind_mixed, + list(A2, w1, t1, B2, t2, w2, C2, w3, t3) + ) +}) diff --git a/tests/testthat/test-compiler.R b/tests/testthat/test-compiler.R index 030eb834..fb72ca94 100644 --- a/tests/testthat/test-compiler.R +++ b/tests/testthat/test-compiler.R @@ -1,16 +1,5 @@ # Unit tests for compiler selection helpers -test_that("quickr_env_is_true recognizes common truthy values", { - withr::local_envvar(c(QUICKR_PREFER_FLANG = "")) - expect_false(quickr:::quickr_env_is_true("QUICKR_PREFER_FLANG")) - - withr::local_envvar(c(QUICKR_PREFER_FLANG = "1")) - expect_true(quickr:::quickr_env_is_true("QUICKR_PREFER_FLANG")) - - withr::local_envvar(c(QUICKR_PREFER_FLANG = "YeS")) - expect_true(quickr:::quickr_env_is_true("QUICKR_PREFER_FLANG")) -}) - test_that("quickr_r_cmd_config_value captures only stdout", { expect_identical( deparse(formals(quickr:::quickr_r_cmd_config_value)$system2), @@ -68,27 +57,46 @@ test_that("quickr_flang_path and quickr_prefer_flang are deterministic with stub "" } } + system2_stub <- function(command, args, stdout = TRUE, stderr = TRUE, ...) { + "flang version" + } expect_identical(quickr:::quickr_flang_path(which = which), "/tmp/flang-new") - withr::local_options( - quickr.prefer_flang = NULL, - quickr.prefer_flang_force = NULL, - quickr.prefer_flang_auto = TRUE - ) - withr::local_envvar(c(QUICKR_PREFER_FLANG = "")) + withr::local_options(quickr.fortran_compiler = "auto") - expect_true(quickr:::quickr_prefer_flang(sysname = "Darwin", which = which)) + expect_true(quickr:::quickr_prefer_flang( + sysname = "Darwin", + which = which, + system2 = system2_stub + )) expect_false(quickr:::quickr_prefer_flang(sysname = "Linux", which = which)) +}) + +test_that("quickr_prefer_flang respects quickr.fortran_compiler", { + withr::local_options(quickr.fortran_compiler = "flang") + expect_true(quickr:::quickr_prefer_flang(sysname = "Linux")) + + withr::local_options(quickr.fortran_compiler = "gfortran") + expect_false(quickr:::quickr_prefer_flang(sysname = "Darwin")) +}) + +test_that("quickr_fortran_compiler_option validates values", { + withr::local_options(quickr.fortran_compiler = "auto") + expect_null(quickr:::quickr_fortran_compiler_option()) - withr::local_options(quickr.prefer_flang = FALSE) - expect_false(quickr:::quickr_prefer_flang(sysname = "Darwin", which = which)) + withr::local_options(quickr.fortran_compiler = "flang") + expect_identical(quickr:::quickr_fortran_compiler_option(), "flang") - withr::local_options( - quickr.prefer_flang = NULL, - quickr.prefer_flang_force = TRUE + withr::local_options(quickr.fortran_compiler = "gfortran") + expect_identical(quickr:::quickr_fortran_compiler_option(), "gfortran") + + withr::local_options(quickr.fortran_compiler = "nope") + expect_error( + quickr:::quickr_fortran_compiler_option(), + "options(quickr.fortran_compiler)", + fixed = TRUE ) - expect_true(quickr:::quickr_prefer_flang(sysname = "Linux", which = which)) }) test_that("quickr_fcompiler_env writes Makevars when flang is usable", { @@ -111,17 +119,32 @@ test_that("quickr_fcompiler_env writes Makevars when flang is usable", { build_dir <- file.path(temp, "build") dir.create(build_dir) + withr::local_options(quickr.fortran_compiler = "flang") env <- quickr:::quickr_fcompiler_env( build_dir = build_dir, which = which, - prefer_flang = TRUE, - prefer_flang_force = TRUE, + system2 = function(...) "", sysname = "Darwin" ) expect_true(startsWith(env, "R_MAKEVARS_USER=")) expect_true(file.exists(sub("R_MAKEVARS_USER=", "", env, fixed = TRUE))) }) +test_that("quickr_fcompiler_env errors when flang is explicitly requested but unavailable", { + build_dir <- withr::local_tempdir() + + withr::local_options(quickr.fortran_compiler = "flang") + expect_error( + quickr:::quickr_fcompiler_env( + build_dir = build_dir, + which = function(cmd) "", + system2 = function(...) structure("", status = 1L) + ), + "configured to use flang", + fixed = TRUE + ) +}) + test_that("compile cleans existing build directories and reports failures", { fsub <- r2f(function(x) { declare(type(x = double(1))) @@ -164,7 +187,7 @@ test_that("compile cleans existing build directories and reports failures", { ) expect_error( - quickr:::compile(fsub, build_dir = build_dir), + suppressWarnings(quickr:::compile(fsub, build_dir = build_dir)), "Compilation Error", fixed = TRUE ) diff --git a/tests/testthat/test-flang-preference.R b/tests/testthat/test-flang-preference.R index 798b607f..c5b857b0 100644 --- a/tests/testthat/test-flang-preference.R +++ b/tests/testthat/test-flang-preference.R @@ -6,18 +6,13 @@ test_that("quickr_fcompiler_env prefers flang-new when requested", { "" } - old_opts <- options( - quickr.prefer_flang_force = NULL, - quickr.prefer_flang_auto = FALSE, - quickr.prefer_flang = NULL - ) - on.exit(options(old_opts), add = TRUE) + withr::local_options(quickr.fortran_compiler = "flang") build_dir <- tempfile("quickr-build-") dir.create(build_dir) env <- quickr:::quickr_fcompiler_env( build_dir, - prefer_flang = TRUE, + system2 = function(...) "", which = which, sysname = "Linux" ) @@ -39,18 +34,13 @@ test_that("quickr_fcompiler_env falls back to flang when flang-new missing", { "" } - old_opts <- options( - quickr.prefer_flang_force = NULL, - quickr.prefer_flang_auto = FALSE, - quickr.prefer_flang = NULL - ) - on.exit(options(old_opts), add = TRUE) + withr::local_options(quickr.fortran_compiler = "flang") build_dir <- tempfile("quickr-build-") dir.create(build_dir) env <- quickr:::quickr_fcompiler_env( build_dir, - prefer_flang = TRUE, + system2 = function(...) "", which = which, sysname = "Linux" ) @@ -68,18 +58,20 @@ test_that("quickr_fcompiler_env returns empty when disabled or unavailable", { which <- function(cmd) "" build_dir <- tempfile("quickr-build-") dir.create(build_dir) + + withr::local_options(quickr.fortran_compiler = "gfortran") expect_equal( quickr:::quickr_fcompiler_env( build_dir, - prefer_flang = FALSE, which = which ), character() ) + + withr::local_options(quickr.fortran_compiler = "auto") expect_equal( quickr:::quickr_fcompiler_env( build_dir, - prefer_flang = TRUE, which = which ), character() @@ -94,31 +86,17 @@ test_that("quickr_prefer_flang defaults to TRUE on macOS when flang exists", { "" } - old_opts <- options( - quickr.prefer_flang_force = NULL, - quickr.prefer_flang_auto = TRUE, - quickr.prefer_flang = NULL - ) - on.exit(options(old_opts), add = TRUE) - - old_env <- Sys.getenv("QUICKR_PREFER_FLANG", unset = NA_character_) - on.exit( - { - if (is.na(old_env)) { - Sys.unsetenv("QUICKR_PREFER_FLANG") - } else { - Sys.setenv(QUICKR_PREFER_FLANG = old_env) - } - }, - add = TRUE - ) - Sys.unsetenv("QUICKR_PREFER_FLANG") + withr::local_options(quickr.fortran_compiler = "auto") - expect_true(quickr:::quickr_prefer_flang(sysname = "Darwin", which = which)) + expect_true(quickr:::quickr_prefer_flang( + sysname = "Darwin", + which = which, + system2 = function(...) "" + )) expect_false(quickr:::quickr_prefer_flang(sysname = "Linux", which = which)) }) -test_that("quickr.prefer_flang = FALSE disables auto preference", { +test_that("quickr.fortran_compiler = \"gfortran\" disables auto preference", { which <- function(cmd) { if (identical(cmd, "flang-new")) { return("/opt/bin/flang-new") @@ -126,25 +104,7 @@ test_that("quickr.prefer_flang = FALSE disables auto preference", { "" } - old_opts <- options( - quickr.prefer_flang_force = NULL, - quickr.prefer_flang_auto = TRUE, - quickr.prefer_flang = FALSE - ) - on.exit(options(old_opts), add = TRUE) - - old_env <- Sys.getenv("QUICKR_PREFER_FLANG", unset = NA_character_) - on.exit( - { - if (is.na(old_env)) { - Sys.unsetenv("QUICKR_PREFER_FLANG") - } else { - Sys.setenv(QUICKR_PREFER_FLANG = old_env) - } - }, - add = TRUE - ) - Sys.unsetenv("QUICKR_PREFER_FLANG") + withr::local_options(quickr.fortran_compiler = "gfortran") expect_false(quickr:::quickr_prefer_flang(sysname = "Darwin", which = which)) }) diff --git a/tests/testthat/test-matrix-internals.R b/tests/testthat/test-matrix-internals.R index fec5191c..e52c51c0 100644 --- a/tests/testthat/test-matrix-internals.R +++ b/tests/testthat/test-matrix-internals.R @@ -27,6 +27,12 @@ test_that("symbol_name_or_null recognizes identifiers", { f_str <- quickr:::Fortran("x", var) expect_identical(quickr:::symbol_name_or_null(f_str), "x") + f_paren <- quickr:::Fortran("(x)", var, r = quote((x))) + expect_identical(quickr:::symbol_name_or_null(f_paren), "x") + + f_nested <- quickr:::Fortran("(((x)))", var, r = quote((((x))))) + expect_identical(quickr:::symbol_name_or_null(f_nested), "x") + f_expr <- quickr:::Fortran("x + 1", var, r = quote(x + 1)) expect_null(quickr:::symbol_name_or_null(f_expr)) }) @@ -41,28 +47,178 @@ test_that("destination helpers handle NULL and mode mismatches", { ) dest <- quickr:::Variable("integer", list(1L), name = "out") - left <- quickr:::Fortran( - "x", - quickr:::Variable("double", list(1L), name = "x"), - r = quote(x) - ) - right <- quickr:::Fortran( - "y", - quickr:::Variable("double", list(1L), name = "y"), - r = quote(y) - ) expect_false( quickr:::can_use_output( dest, - left, - right, + input_names = c("x", "y"), expected_dims = list(1L), context = "ctx" ) ) }) +test_that("bind output helpers handle type coercion edge cases", { + make_value <- function(mode, dims = list(1L), name = "x") { + Fortran( + name, + Variable(mode, dims, name = name), + r = as.symbol(name) + ) + } + + val_logical <- make_value("logical", name = "l") + val_integer <- make_value("integer", name = "i") + val_double <- make_value("double", name = "d") + val_complex <- make_value("complex", name = "z") + val_raw <- make_value("raw", name = "r") + val_character <- make_value("character", name = "c") + val_unknown <- make_value(NULL, name = "u") + + expect_identical( + bind_output_mode(list(val_integer, val_logical), "bind"), + "integer" + ) + expect_identical( + bind_output_mode(list(val_double, val_integer), "bind"), + "double" + ) + + expect_error( + bind_output_mode(list(val_unknown), "bind"), + "inputs must have a known type" + ) + expect_error( + bind_output_mode(list(val_complex, val_double), "bind"), + "does not support mixing complex" + ) + expect_error( + bind_output_mode(list(val_raw, val_character), "bind"), + "does not support mixing raw with other types" + ) + + cast_double <- bind_cast_value(val_integer, "double", "bind") + expect_identical(cast_double@value@mode, "double") + expect_identical(cast_double@value@dims, val_integer@value@dims) + + cast_int <- bind_cast_value(val_logical, "integer", "bind") + expect_identical(cast_int@value@mode, "integer") + expect_identical( + as.character(cast_int), + paste0("merge(1_c_int, 0_c_int, ", as.character(val_logical), ")") + ) + + expect_error( + bind_cast_value(val_double, "integer", "bind"), + "does not support coercion from" + ) +}) + +test_that("bind dimension helpers cover scalar, symbolic, and unknown sizes", { + expect_error( + bind_dim_sum(list(NA_integer_), "ctx", "row"), + "requires inputs with known row sizes" + ) + + expr <- bind_dim_sum(list(quote(n), 2L), "ctx", "column") + expect_true(is.language(expr)) + expect_identical(expr[[1L]], quote(`+`)) + + expect_identical( + bind_common_dim(list(1L, 1L), c(TRUE, TRUE), "ctx", "row"), + 1L + ) + expect_warning( + common <- bind_common_dim( + list(quote(n), quote(m)), + c(FALSE, FALSE), + "ctx", + "row" + ), + "cannot verify conformability in ctx" + ) + expect_identical(common, quote(n)) + + expect_identical(bind_dim_string(3L), "3") + expect_identical( + bind_dim_string(quote(n + 1L)), + "n + 1" + ) + expect_identical(bind_dim_int(quote(n + 1L)), "int(n + 1)") +}) + +test_that("bind matrix expression helpers protect against unsupported ranks", { + scalar <- Fortran( + "s", + Variable("double", name = "s"), + r = quote(s) + ) + mat <- Fortran( + "A", + Variable("double", list(2L, 2L), name = "A"), + r = quote(A) + ) + rank3 <- Fortran( + "arr", + Variable("double", list(2L, 2L, 2L), name = "arr"), + r = quote(arr) + ) + + expect_identical( + bind_col_matrix_expr( + mat, + rows = 2L, + is_scalar = FALSE, + context = "ctx" + ), + "A" + ) + expect_identical( + bind_row_matrix_expr( + mat, + cols = 2L, + is_scalar = FALSE, + context = "ctx" + ), + "A" + ) + + expect_error( + bind_col_matrix_expr( + rank3, + rows = 2L, + is_scalar = FALSE, + context = "ctx" + ), + "only supports rank 0-2 inputs" + ) + expect_error( + bind_row_matrix_expr( + rank3, + cols = 2L, + is_scalar = FALSE, + context = "ctx" + ), + "only supports rank 0-2 inputs" + ) + + spread_col <- bind_col_matrix_expr( + scalar, + rows = quote(n), + is_scalar = TRUE, + context = "ctx" + ) + expect_match(spread_col, "spread", fixed = FALSE) + + spread_row <- bind_row_matrix_expr( + scalar, + cols = quote(m), + is_scalar = TRUE, + context = "ctx" + ) + expect_match(spread_row, "spread", fixed = FALSE) +}) + test_that("unwrap_transpose_arg handles scalar inputs and rank errors", { scope <- quickr:::new_scope(NULL) scope@assign("a", quickr:::Variable("double", name = "a")) diff --git a/tests/testthat/test-matrix-mul.R b/tests/testthat/test-matrix-mul.R index f2242a86..9f116dae 100644 --- a/tests/testthat/test-matrix-mul.R +++ b/tests/testthat/test-matrix-mul.R @@ -228,6 +228,135 @@ test_that("matrix multiplication rejects incompatible destinations", { expect_error(quick(dest_mismatch), "incompatible rank for %\\*%") }) +test_that("BLAS matrix ops coerce integer and logical inputs to double", { + matmul_int <- function(A, B) { + declare(type(A = integer(2, 2)), type(B = integer(2, 2))) + A %*% B + } + + crossprod_int <- function(x) { + declare(type(x = integer(3, 2))) + crossprod(x) + } + + outer_int <- function(x, y) { + declare(type(x = integer(2)), type(y = integer(3))) + outer(x, y) + } + + matmul_lgl <- function(A, B) { + declare(type(A = logical(2, 2)), type(B = logical(2, 2))) + A %*% B + } + + A <- matrix(as.integer(c(1, 2, 3, 4)), nrow = 2) + B <- matrix(as.integer(c(2, 0, 1, -1)), nrow = 2) + x <- matrix(as.integer(1:6), nrow = 3) + v2 <- as.integer(c(1, -2)) + v3 <- as.integer(c(3, 0, 4)) + + set.seed(123) + A_lgl <- matrix(sample(c(TRUE, FALSE), 4, TRUE), nrow = 2) + B_lgl <- matrix(sample(c(TRUE, FALSE), 4, TRUE), nrow = 2) + + expect_quick_equal(matmul_int, list(A = A, B = B)) + expect_quick_equal(crossprod_int, list(x = x)) + expect_quick_equal(outer_int, list(x = v2, y = v3)) + expect_quick_equal(matmul_lgl, list(A = A_lgl, B = B_lgl)) +}) + +test_that("matrix multiplication avoids unsafe in-place aliasing", { + fn <- function(A, B) { + declare(type(A = double(2, 2)), type(B = double(2, 2))) + A <- (A) %*% B + A + } + + set.seed(42) + A0 <- matrix(rnorm(4), nrow = 2) + B <- matrix(rnorm(4), nrow = 2) + + qfn <- quick(fn) + A_orig <- A0 + 0 + out <- qfn(A0, B) + + expect_identical(A0, A_orig) + expect_equal(out, fn(A_orig, B)) +}) + +test_that("matrix multiplication handles expression inputs without mutating sources", { + fn <- function(A, B) { + declare(type(A = double(2, 2)), type(B = double(2, 2))) + A <- (A + 1) %*% B + A + } + + set.seed(101) + A0 <- matrix(rnorm(4), nrow = 2) + B <- matrix(rnorm(4), nrow = 2) + + qfn <- quick(fn) + A_orig <- A0 + 0 + out <- qfn(A0, B) + + expect_identical(A0, A_orig) + expect_equal(out, fn(A_orig, B)) +}) + +test_that("crossprod handles parenthesized inputs without aliasing", { + fn <- function(A) { + declare(type(A = double(2, 2))) + A <- crossprod(((A))) + A + } + + set.seed(202) + A0 <- matrix(rnorm(4), nrow = 2) + + qfn <- quick(fn) + A_orig <- A0 + 0 + out <- qfn(A0) + + expect_identical(A0, A_orig) + expect_equal(out, fn(A_orig)) +}) + +test_that("triangular solves can write into the RHS variable safely", { + fn <- function(U, b) { + declare(type(U = double(2, 2)), type(b = double(2))) + b <- backsolve(U, b) + b + } + + U <- matrix(c(2, 1, 0, 3), nrow = 2, byrow = TRUE) + b0 <- c(1.25, -0.5) + + qfn <- quick(fn) + b_orig <- b0 + 0 + out <- qfn(U, b0) + + expect_identical(b0, b_orig) + expect_equal(out, fn(U, b_orig)) +}) + +test_that("triangular solves accept parenthesized RHS safely", { + fn <- function(U, b) { + declare(type(U = double(2, 2)), type(b = double(2))) + b <- backsolve(U, (b)) + b + } + + U <- matrix(c(2, 1, 0, 3), nrow = 2, byrow = TRUE) + b0 <- c(1.25, -0.5) + + qfn <- quick(fn) + b_orig <- b0 + 0 + out <- qfn(U, b0) + + expect_identical(b0, b_orig) + expect_equal(out, fn(U, b_orig)) +}) + test_that("crossprod and tcrossprod match R", { cross_fun <- function(x, y) { declare( diff --git a/tests/testthat/test-openmp-parallelization.R b/tests/testthat/test-openmp-parallelization.R index 12283bf6..baef60d8 100644 --- a/tests/testthat/test-openmp-parallelization.R +++ b/tests/testthat/test-openmp-parallelization.R @@ -73,22 +73,25 @@ check_thread_scaling_subprocess <- function(label, n, iters) { "}; out })", collapse = " " ) - code <- paste( - load_snippet, - iter_parallel_line, - sprintf("n <- %dL", as.integer(n)), - sprintf("iters <- %dL", as.integer(iters)), - "set.seed(1)", - "x <- runif(n)", - "invisible(iter_parallel(x, n, iters))", - "timing <- system.time(iter_parallel(x, n, iters))", - "cpu_fields <- intersect(names(timing), c('user.self', 'sys.self', 'user.child', 'sys.child', 'user', 'system'))", - "cpu <- sum(timing[cpu_fields])", - "cat(sprintf('elapsed=%.6f cpu=%.6f\\n', timing[['elapsed']], cpu))", - sep = "; " - ) + make_code <- function(iters) { + paste( + load_snippet, + iter_parallel_line, + sprintf("n <- %dL", as.integer(n)), + sprintf("iters <- %dL", as.integer(iters)), + "set.seed(1)", + "x <- runif(n)", + "invisible(iter_parallel(x, n, iters))", + "timing <- system.time(iter_parallel(x, n, iters))", + "cpu_fields <- intersect(names(timing), c('user.self', 'sys.self', 'user.child', 'sys.child', 'user', 'system'))", + "cpu <- sum(timing[cpu_fields])", + "cat(sprintf('elapsed=%.6f cpu=%.6f\\n', timing[['elapsed']], cpu))", + sep = "; " + ) + } - run_one <- function(threads) { + run_one <- function(threads, iters) { + code <- make_code(iters) out <- system2( R.home("bin/R"), c("--vanilla", "--slave", "-e", shQuote(code)), @@ -112,20 +115,25 @@ check_thread_scaling_subprocess <- function(label, n, iters) { list(elapsed = parsed$elapsed, cpu = parsed$cpu) } - two_threads <- run_one(2) - four_threads <- run_one(4) - eight_threads <- run_one(8) - - if ( - two_threads$elapsed < 0.1 || - four_threads$elapsed < 0.1 || - eight_threads$elapsed < 0.1 - ) { - skip("Workload too small to assess OpenMP thread controls") + scale_iters <- as.integer(iters) + for (attempt in seq_len(5L)) { + two_threads <- run_one(2, scale_iters) + four_threads <- run_one(4, scale_iters) + eight_threads <- run_one(8, scale_iters) + min_elapsed <- min( + c(two_threads$elapsed, four_threads$elapsed, eight_threads$elapsed) + ) + if (min_elapsed >= 0.1) { + break + } + scale_iters <- as.integer(scale_iters * 4L) } thread_info <- paste0( label, + " (iters=", + scale_iters, + ")", ": threads=2 elapsed=", signif(two_threads$elapsed, 3), " cpu=", @@ -156,12 +164,16 @@ check_thread_scaling_subprocess <- function(label, n, iters) { } test_that("parallel loops show parallelism without large slowdowns", { - openmp_supported_or_skip() + skip_if_no_openmp() - serial <- function(x, n) { - declare(type(x = double(n)), type(n = integer(1)), type(out = double(n))) + serial <- function(x, n, iters) { + declare( + type(x = double(n)), + type(n = integer(1)), + type(iters = integer(1)), + type(out = double(n)) + ) out <- double(n) - iters <- 12L for (i in seq_len(n)) { v <- x[i] for (k in seq_len(iters)) { @@ -173,10 +185,14 @@ test_that("parallel loops show parallelism without large slowdowns", { out } - parallel <- function(x, n) { - declare(type(x = double(n)), type(n = integer(1)), type(out = double(n))) + parallel <- function(x, n, iters) { + declare( + type(x = double(n)), + type(n = integer(1)), + type(iters = integer(1)), + type(out = double(n)) + ) out <- double(n) - iters <- 12L declare(parallel()) for (i in seq_len(n)) { v <- x[i] @@ -195,11 +211,18 @@ test_that("parallel loops show parallelism without large slowdowns", { serial_q <- quick(serial) parallel_q <- quick(parallel) - serial_q(x, n) + iters <- 12L + serial_q(x, n, iters) gc() reps <- 1L - serial_time <- timed_run(serial_q, x, n, reps = reps) + for (attempt in seq_len(5L)) { + serial_time <- timed_run(serial_q, x, n, iters, reps = reps) + if (serial_time$elapsed >= 0.1) { + break + } + iters <- as.integer(iters * 4L) + } parallel_time <- withr::with_envvar( c( OMP_NUM_THREADS = "2", @@ -207,17 +230,16 @@ test_that("parallel loops show parallelism without large slowdowns", { OMP_DYNAMIC = "false" ), { - parallel_q(x, n) + parallel_q(x, n, iters) gc() - timed_run(parallel_q, x, n, reps = reps) + timed_run(parallel_q, x, n, iters, reps = reps) } ) - if (serial_time$elapsed < 0.1) { - skip("Workload too small to assess OpenMP parallelism") - } - info <- paste0( + "iters=", + iters, + "; ", "serial elapsed=", signif(serial_time$elapsed, 3), " (sys=", @@ -259,7 +281,7 @@ test_that("parallel loops show parallelism without large slowdowns", { }) test_that("openmp responds to OMP_NUM_THREADS across sessions", { - openmp_supported_or_skip() + skip_if_no_openmp() check_thread_scaling_subprocess( label = "iter-map", diff --git a/tests/testthat/test-parallel-declare.R b/tests/testthat/test-parallel-declare.R index 767c1aab..00bdfbe0 100644 --- a/tests/testthat/test-parallel-declare.R +++ b/tests/testthat/test-parallel-declare.R @@ -1,5 +1,5 @@ test_that("declare(parallel()) and declare(omp()) parallelize loops", { - openmp_supported_or_skip() + skip_if_no_openmp() parallel_for <- function(x, n) { declare(type(x = double(n)), type(n = integer(1)), type(out = double(n))) @@ -26,7 +26,7 @@ test_that("declare(parallel()) and declare(omp()) parallelize loops", { }) test_that("parallel sapply supports axpy patterns", { - openmp_supported_or_skip() + skip_if_no_openmp() axpy <- function(x, y, a) { declare( @@ -65,7 +65,7 @@ test_that("parallel sapply supports axpy patterns", { }) test_that("parallel sapply supports seq_len(nrow(x))", { - openmp_supported_or_skip() + skip_if_no_openmp() row_sums <- function(x) { declare(type(x = double(NA, NA))) @@ -79,7 +79,7 @@ test_that("parallel sapply supports seq_len(nrow(x))", { }) test_that("parallel for-loops support value iteration", { - openmp_supported_or_skip() + skip_if_no_openmp() value_iter <- function(x) { declare( @@ -102,7 +102,7 @@ test_that("parallel for-loops support value iteration", { }) test_that("parallel declarations require supported targets", { - openmp_supported_or_skip() + skip_if_no_openmp() wrong_target <- function(x) { declare(type(x = double(1))) @@ -128,7 +128,7 @@ test_that("parallel declarations require supported targets", { }) test_that("parallel declarations do not cross control flow boundaries", { - openmp_supported_or_skip() + skip_if_no_openmp() if_decl <- function(x) { declare(type(x = double(1))) @@ -163,7 +163,7 @@ test_that("parallel declarations do not cross control flow boundaries", { }) test_that("openmp functions that use BLAS load and run", { - openmp_supported_or_skip() + skip_if_no_openmp() blas_parallel <- function(x, n) { declare(