From 13294b9fbbc176b70b653f8eb50117b269b60185 Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 22 May 2026 09:32:34 -0700 Subject: [PATCH 1/4] Implement much of "as" with nC_as on the C++ side --- nCompiler/R/compile_aaa_operatorLists.R | 15 + nCompiler/R/compile_eigenization.R | 11 + nCompiler/R/compile_generateCpp.R | 25 ++ nCompiler/R/compile_labelAbstractTypes.R | 15 + .../ET_Rcpp_ext/ET_Rcpp_ext_post_Rcpp.h | 1 + .../post_Rcpp/ETaccessor_post_Rcpp.h | 99 +++++++ .../nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h | 164 +++++++++++ .../nCompiler/ET_ext/StridedTensorMap.h | 33 +++ .../tests/testthat/specificOp_tests/test-as.R | 272 ++++++++++++++++++ 9 files changed, 635 insertions(+) create mode 100644 nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h create mode 100644 nCompiler/tests/testthat/specificOp_tests/test-as.R diff --git a/nCompiler/R/compile_aaa_operatorLists.R b/nCompiler/R/compile_aaa_operatorLists.R index fb9bd1e3..3a12217c 100644 --- a/nCompiler/R/compile_aaa_operatorLists.R +++ b/nCompiler/R/compile_aaa_operatorLists.R @@ -236,6 +236,21 @@ assignOperatorDef( ) ) +assignOperatorDef( + 'as', + list( + matchDef = function(object, type) {}, + compileArgs = c("type"), + help = 'as(object, type) uses "object" as if it is of type "type", where the type is limited to basic types.', + labelAbstractTypes = list( + handler = 'As'), + eigenImpl = list( + handler = 'As'), + cppOutput = list( + handler = 'As') + ) +) + assignOperatorDef( c('if', 'while'), list( diff --git a/nCompiler/R/compile_eigenization.R b/nCompiler/R/compile_eigenization.R index 8be6ce2f..2a619c8d 100644 --- a/nCompiler/R/compile_eigenization.R +++ b/nCompiler/R/compile_eigenization.R @@ -445,6 +445,17 @@ inEigenizeEnv( } ) +inEigenizeEnv( + As <- function(code, symTab, auxEnv, workEnv, handlingInfo) { + ## STM is needed when as() is immediately indexed: as(X, type)[...] + ## LHS detection is handled centrally via code$aux$onLHS (set in labelAbstractTypes). + caller <- code$caller + use_stm <- !is.null(caller) && caller$name == "[" && isTRUE(code$callerArgID == 1) + code$aux$useSTM <- use_stm + invisible(NULL) + } +) + inEigenizeEnv( RandomGeneration <- function(code, symTab, auxEnv, workEnv, handlingInfo) { # determine arguments that parameterize the dist'n. diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index e8932ba9..6ab78cbd 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -602,6 +602,31 @@ inGenCppEnv( } ) +inGenCppEnv( + as_op_scalarToCpp <- function(type) { + switch(type, + double = 'double', + integer = 'int', + logical = 'bool', + stop(paste0("as_op: unknown scalar type '", type, "'"), call. = FALSE) + ) + } +) + +inGenCppEnv( + As <- function(code, symTab) { + obj_cpp <- compile_generateCpp(code$args[[1]], symTab) + tgt_type <- code$type$type + tgt_nDim <- code$type$nDim + use_stm <- isTRUE(code$aux$useSTM) + is_lhs <- isTRUE(code$aux$onLHS) + + tgt_cpp <- as_op_scalarToCpp(tgt_type) + mode_arg <- if(is_lhs) ', AsMode::LHS' else if(use_stm) ', AsMode::STM' else '' + paste0('as_nC<', tgt_cpp, ', ', tgt_nDim, mode_arg, '>(', obj_cpp, ')') + } +) + inGenCppEnv( ## StaticCast(A) -> static_cast(A) StaticCast <- function(code, symTab) { diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 0fcab72f..cf750227 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -11,6 +11,8 @@ compile_labelAbstractTypes <- function(code, logging <- get_nOption('compilerOptions')[['logging']] if (logging) appendToLog(paste('###', nErrorEnv$stateInfo, '###')) + if(isTRUE(auxEnv$onLHS)) code$aux$onLHS <- TRUE + if(code$isLiteral) { if(is.numeric(code$name)) { if(is.integer(code$name)) { @@ -205,6 +207,17 @@ inLabelAbstractTypesEnv( } ) +inLabelAbstractTypesEnv( + As <- function(code, symTab, auxEnv, handlingInfo) { + inner_type <- nType(expr = code$aux$compileArgs$type, env = auxEnv$where) + sym <- type2symbol({{inner_type}}, where = auxEnv$where) + sym <- resolveOneTBDsymbol(sym, env = auxEnv$where, project_env = auxEnv$project_env) + inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) + code$type <- sym + if(length(inserts) == 0) NULL else inserts + } +) + ## chainedCall ## nParse converts something like foo(a)(b) to chainedCall(foo(a), b), ## (although there is no support for a function returning a function.) @@ -728,9 +741,11 @@ inLabelAbstractTypesEnv( compile_labelAbstractTypes(code, symTab, auxEnv)) } else{ + auxEnv$onLHS <- TRUE inserts <- c(inserts, recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo, useArgs = c(TRUE, FALSE))) + auxEnv$onLHS <- FALSE # auxEnv[['.ensureNimbleBlocks']] <- FALSE ## may have been true from RHS of rmnorm etc. inserts <- c(inserts, AssignAfterRecursing(code, symTab, auxEnv, diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/ET_Rcpp_ext_post_Rcpp.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/ET_Rcpp_ext_post_Rcpp.h index 53401835..38bc3de9 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/ET_Rcpp_ext_post_Rcpp.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/ET_Rcpp_ext_post_Rcpp.h @@ -6,5 +6,6 @@ #include #include #include +#include //#endif // EIGEN_RCPP_EXTENSIONS_H_ diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h index 873c2af7..2c30855b 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h @@ -2,10 +2,21 @@ #define NCOMPILER_ETACCESSOR_POST_RCPP_H_ #include +#include template class ETaccessorTyped; +using Eigen::StridedTensorMap; + +enum class AsMode { TM, STM, LHS }; + +// Forward declaration: CastingProxy is defined in nC_as.h (included after +// this file). ETaccessorTyped::asTyped() returns it; because asTyped() is a +// template, instantiation is deferred to the call site where CastingProxy is +// fully defined. +template class CastingProxy; + // Virtual nDim-general methods (e.g. resize, conversions to and from SEXP). class ETaccessorBase { public: @@ -17,9 +28,33 @@ class ETaccessorBase { virtual std::vector &intDims()=0; + // Virtual element-wise cast/writeback for cross-scalar RuntimeCastingProxy. + // Only 3 scalar types are supported so virtual templates are avoided. + virtual void castCopyToDouble(double* dest, size_t n) { + Rcpp::stop("castCopyToDouble not supported for this ETaccessor type."); + } + virtual void castCopyToInt(int* dest, size_t n) { + Rcpp::stop("castCopyToInt not supported for this ETaccessor type."); + } + virtual void castCopyToBool(bool* dest, size_t n) { + Rcpp::stop("castCopyToBool not supported for this ETaccessor type."); + } + virtual void writeBackFromDouble(const double* src, size_t n) { + Rcpp::stop("writeBackFromDouble not supported for this ETaccessor type."); + } + virtual void writeBackFromInt(const int* src, size_t n) { + Rcpp::stop("writeBackFromInt not supported for this ETaccessor type."); + } + virtual void writeBackFromBool(const bool* src, size_t n) { + Rcpp::stop("writeBackFromBool not supported for this ETaccessor type."); + } + template using ETM = Eigen::TensorMap >; + template + using ESTM = StridedTensorMap >; + template ETaccessorTyped &S() { auto castptr = dynamic_cast* >(this); @@ -30,6 +65,9 @@ class ETaccessorBase { template ETM map(); + template + ESTM STmap(); + template Eigen::Tensor &ref(); @@ -57,6 +95,60 @@ class ETaccessorTyped : public ETaccessorBase { return *data(); } + // Cast/writeback implementations (element-wise, supports all 3 scalar types). + void castCopyToDouble(double* dest, size_t n) override { + Scalar* src = data(); + for(size_t i = 0; i < n; ++i) dest[i] = static_cast(src[i]); + } + void castCopyToInt(int* dest, size_t n) override { + Scalar* src = data(); + for(size_t i = 0; i < n; ++i) dest[i] = static_cast(src[i]); + } + void castCopyToBool(bool* dest, size_t n) override { + Scalar* src = data(); + for(size_t i = 0; i < n; ++i) dest[i] = static_cast(src[i]); + } + void writeBackFromDouble(const double* src, size_t n) override { + Scalar* dest = data(); + for(size_t i = 0; i < n; ++i) dest[i] = static_cast(src[i]); + } + void writeBackFromInt(const int* src, size_t n) override { + Scalar* dest = data(); + for(size_t i = 0; i < n; ++i) dest[i] = static_cast(src[i]); + } + void writeBackFromBool(const bool* src, size_t n) override { + Scalar* dest = data(); + for(size_t i = 0; i < n; ++i) dest[i] = static_cast(src[i]); + } + + template + using ESTM = StridedTensorMap >; + + // StridedTensorMap variant of mapTyped — same singleton-drop/pad logic. + template + ESTM STmapTyped() { + return Eigen::MakeStridedTensorMap::make(mapTyped()); + } + + // Central dispatch for as() operations. Selects view type and write-back + // behaviour at compile time based on scalar match and AsMode. + template + auto asTyped() { + if constexpr (std::is_same_v) { + if constexpr (mode == AsMode::TM) + return mapTyped(); + else + return STmapTyped(); // mode == STM or LHS: STM for full element access + } else { + if constexpr (mode == AsMode::LHS) { + auto view = STmapTyped(); // STM for write-back correctness (handles non-contiguous sources) + return CastingProxy(view, /*is_lhs=*/true); + } else { + return mapTyped().template cast(); // lazy Eigen expression, RHS only + } + } + } + template ETM mapTyped() { //innate_nDim is the nDim of the object. @@ -105,6 +197,13 @@ Eigen::TensorMap > ETaccessorBase::map() { return castptr->template mapTyped(); } +template +StridedTensorMap > ETaccessorBase::STmap() { + auto castptr = dynamic_cast* >(this); + if(castptr == nullptr) Rcpp::stop("Problem creating an STmap() from some form of access().\n"); + return castptr->template STmapTyped(); +} + template Scalar& ETaccessorBase::scalar() { auto castptr = dynamic_cast* >(this); diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h new file mode 100644 index 00000000..371dec2a --- /dev/null +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h @@ -0,0 +1,164 @@ +#ifndef NCOMPILER_NC_AS_H_ +#define NCOMPILER_NC_AS_H_ + +#include +#include + +// CastingProxy +// +// RAII wrapper for cross-scalar-type as() on the LHS. Holds a copy of the +// source view cast to TargetScalar. On destruction, casts the (possibly +// modified) copy back into the original view via ViewType::operator=. +// ViewType should be a StridedTensorMap so that non-contiguous sources +// (e.g. blockRef) are handled correctly. For RHS use, is_lhs = false +// makes the destructor a no-op. +// +// ViewType must expose ::Scalar, ::NumDimensions, and operator= from Eigen. +template +class CastingProxy { + static constexpr int nDim = ViewType::NumDimensions; + using SourceScalar = typename ViewType::Scalar; + using CopyTensor = Eigen::Tensor; + using TM = Eigen::TensorMap; + + ViewType view_; // TensorMap into original source data + CopyTensor copy_; // TargetScalar copy + bool is_lhs_; + +public: + explicit CastingProxy(ViewType view, bool is_lhs = false) + : view_(view), copy_(view.template cast()), is_lhs_(is_lhs) {} + + ~CastingProxy() { + if(is_lhs_) view_ = copy_.template cast(); + } + + CastingProxy(const CastingProxy&) = delete; + CastingProxy& operator=(const CastingProxy&) = delete; + + TM map() { return TM(copy_.data(), copy_.dimensions()); } +}; + +// RuntimeCastingProxy +// +// Used when the source type is only known at runtime (ETaccessorBase). +// At construction, dynamic_cast tests whether the source scalar matches +// TargetScalar: +// - Same type: map_ points directly into source data (no copy). +// - Different type: allocates copy_, cast-copies from source; map_ points +// into copy_->data(). +// On destruction, if a copy was made and is_lhs is true, writes copy_ back +// into the source via virtual writeBackFrom* methods. +template +class RuntimeCastingProxy { + using TM = Eigen::TensorMap>; + using CopyTensor = Eigen::Tensor; + + ETaccessorBase& source_; + std::unique_ptr copy_; // null when same scalar type + TargetScalar* data_ptr_; + Eigen::array dims_; + bool is_lhs_; + + // Mirrors mapTyped singleton-drop/pad logic from ETaccessorTyped. + Eigen::array computeDims(const std::vector& intDims) { + Eigen::array outDim; + int innate_nDim = static_cast(intDims.size()); + if(nDim >= innate_nDim) { + for(int i = 0; i < innate_nDim; ++i) outDim[i] = intDims[i]; + for(int i = innate_nDim; i < nDim; ++i) outDim[i] = 1; + } else { + int i_out = 0; + for(int i_in = 0; i_in < innate_nDim; ++i_in) { + if(intDims[i_in] > 1) { + if(i_out >= nDim) + Rcpp::stop("RuntimeCastingProxy: too many non-singleton dimensions for requested nDim."); + outDim[i_out++] = intDims[i_in]; + } + } + for(; i_out < nDim; ++i_out) outDim[i_out] = 1; + } + return outDim; + } + + size_t totalElems() const { + size_t n = 1; + for(int i = 0; i < nDim; ++i) n *= static_cast(dims_[i]); + return n; + } + + void castCopyFrom() { + size_t n = totalElems(); + copy_ = std::make_unique(dims_); + if constexpr (std::is_same_v) + source_.castCopyToDouble(copy_->data(), n); + else if constexpr (std::is_same_v) + source_.castCopyToInt(copy_->data(), n); + else if constexpr (std::is_same_v) + source_.castCopyToBool(copy_->data(), n); + else + Rcpp::stop("RuntimeCastingProxy: unsupported TargetScalar type."); + data_ptr_ = copy_->data(); + } + + void writeBack() { + size_t n = totalElems(); + if constexpr (std::is_same_v) + source_.writeBackFromDouble(copy_->data(), n); + else if constexpr (std::is_same_v) + source_.writeBackFromInt(copy_->data(), n); + else if constexpr (std::is_same_v) + source_.writeBackFromBool(copy_->data(), n); + else + Rcpp::stop("RuntimeCastingProxy: unsupported TargetScalar type."); + } + +public: + explicit RuntimeCastingProxy(ETaccessorBase& acc, bool is_lhs = false) + : source_(acc), is_lhs_(is_lhs) + { + dims_ = computeDims(acc.intDims()); + auto* typed = dynamic_cast*>(&acc); + if(typed) { + // Same scalar type: view directly, no copy. + auto tm = typed->template mapTyped(); + data_ptr_ = tm.data(); + } else { + castCopyFrom(); + } + } + + ~RuntimeCastingProxy() { + if(copy_ && is_lhs_) writeBack(); + } + + RuntimeCastingProxy(const RuntimeCastingProxy&) = delete; + RuntimeCastingProxy& operator=(const RuntimeCastingProxy&) = delete; + + TM map() { return TM(data_ptr_, dims_); } +}; + +// --------------------------------------------------------------------------- +// as_nC — the single public API emitted by the nCompiler code generator. +// Two overloads: compile-time source (any concrete T) and runtime source +// (ETaccessorBase&, scalar type unknown at C++ compile time). +// --------------------------------------------------------------------------- + +// Compile-time source: delegates to ETaccessorTyped::asTyped<>(). +// Returns: TM (TM mode), STM (STM/LHS same-scalar), CastingProxy (LHS cross- +// scalar), or a lazy Eigen cast expression (RHS cross-scalar). +template +auto as_nC(T& x) { + return ETaccess(x).template asTyped(); +} + +// Runtime source: scalar type of acc is unknown at compile time. +// Returns a RuntimeCastingProxy that uses dynamic_cast to avoid copies when +// source scalar already matches TargetScalar, and virtual cast/writeback +// methods otherwise. Write-back occurs on destruction iff mode == LHS. +template +RuntimeCastingProxy as_nC(ETaccessorBase& acc) { + return RuntimeCastingProxy(acc, mode == AsMode::LHS); +} + +#endif // NCOMPILER_NC_AS_H_ diff --git a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h index 13816eb7..a58da51f 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h @@ -141,6 +141,30 @@ namespace Eigen { #endif } + // const-ref and rvalue-ref overloads so temporary tensors/maps can be used as input. + // Only data() and dimensions() are needed, so this is safe: m_data outlives the temp. + template + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(const InputType &inputTensor) + : m_data(const_cast(inputTensor.data())) + { + createSubTensorInfo(inputTensor.dimensions(), + m_dimensions, + m_strides, + m_startIndices, + m_stopIndices); + } + + template + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(InputType &&inputTensor) + : m_data(inputTensor.data()) + { + createSubTensorInfo(inputTensor.dimensions(), + m_dimensions, + m_strides, + m_startIndices, + m_stopIndices); + } + template EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(InputType &inputTensor, const Eigen::array &ss) @@ -645,6 +669,15 @@ struct MakeStridedTensorMap { static typename MakeOutputType::type make(EigenInputType &x) { return typename MakeOutputType::type(x); } + // rvalue overloads so temporaries (e.g. TensorMap returned by nC_as) can be used as input. + template + static typename MakeOutputType::type make(EigenInputType &&x, const IndexBlocksType &indexBlockArray) { + return typename MakeOutputType::type(std::forward(x), indexBlockArray); + } + template + static typename MakeOutputType::type make(EigenInputType &&x) { + return typename MakeOutputType::type(std::forward(x)); + } }; // Eval as lvalue diff --git a/nCompiler/tests/testthat/specificOp_tests/test-as.R b/nCompiler/tests/testthat/specificOp_tests/test-as.R new file mode 100644 index 00000000..e149aa7d --- /dev/null +++ b/nCompiler/tests/testthat/specificOp_tests/test-as.R @@ -0,0 +1,272 @@ +# Tests for the as() keyword. +# +# as(object, type) reinterprets the shape or scalar type of an object at +# compile time using Eigen TensorMap / StridedTensorMap views to minimise +# copies. Cross-scalar LHS uses a CastingProxy that writes element values +# back to the source on destruction. +# +# Shape semantics (same as mapTyped): when the target nDim is less than the +# source nDim, singleton dimensions are dropped; when more, 1s are appended. +# A runtime error is thrown if too many non-singleton dimensions would be lost. +# +# Items not yet implemented (marked with skip()): +# - Uncompiled (R-side) execution of as(). +# - Cross-scalar LHS: requires CastingProxy::operator=. +# - Immediate indexing of an as() expression: as(x, type)[i] (complex Eigen +# interaction between STM and the indexing subsystem). +# - Runtime-source path: ETaccessorBase input from genericInterfaceC. + +# --------------------------------------------------------------------------- +# Same scalar, dimension change — RHS +# --------------------------------------------------------------------------- + +test_that("as(): same scalar 2D→1D singleton-drop, RHS", { + nc <- nClass( + Cpublic = list( + col_to_vec = nFunction( + function(x = numericMatrix) { + ans <- as(x, "numericVector") + return(ans) + returnType(numericVector) + } + ), + row_to_vec = nFunction( + function(x = numericMatrix) { + ans <- as(x, "numericVector") + return(ans) + returnType(numericVector) + } + ) + ) + ) + for(package in c(FALSE, TRUE)) { + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + + # Single-column (n×1) matrix: singleton column dim is dropped. + x_col <- matrix(as.numeric(1:6), nrow = 6, ncol = 1) + expect_equal(nco$col_to_vec(x_col), as.numeric(1:6)) + + # Single-row (1×n) matrix: singleton row dim is dropped. + x_row <- matrix(as.numeric(1:6), nrow = 1, ncol = 6) + expect_equal(nco$row_to_vec(x_row), as.numeric(1:6)) + } + rm(nco); gc() +}) + +test_that("as(): same scalar 1D→2D dimension padding, RHS", { + nc <- nClass( + Cpublic = list( + vec_to_mat = nFunction( + function(x = numericVector) { + ans <- as(x, "numericMatrix") + return(ans) + returnType(numericMatrix) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + # A length-n vector is viewed as an (n×1) matrix (second dim padded with 1). + x <- as.numeric(1:5) + expect_equal(nco$vec_to_mat(x), matrix(x, ncol = 1)) + rm(nco); gc() +}) + +test_that("as(): same scalar, result used in arithmetic", { + nc <- nClass( + Cpublic = list( + sum_col = nFunction( + function(x = numericMatrix) { + ans <- sum(as(x, "numericVector")) + ans <- ans + sum(as(x, "numericVector") + (1:length(x))) + # ans <- sum(v) + return(ans) + returnType(numericScalar) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + x <- matrix(as.numeric(1:4), nrow = 4, ncol = 1) + expect_equal(nco$sum_col(x), sum(x) + sum(x + 1:length(x))) + rm(nco); gc() +}) + +# --------------------------------------------------------------------------- +# Cross scalar — RHS (lazy Eigen cast, no copy until evaluation) +# --------------------------------------------------------------------------- + +test_that("as(): cross scalar double→integer, RHS", { + nc <- nClass( + Cpublic = list( + to_int = nFunction( + function(x = numericVector) { + ans <- as(x, "integerVector") + return(ans) + returnType(integerVector) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + x <- c(1.9, 2.1, 3.7, -0.5) + expect_equal(nco$to_int(x), as.integer(x)) +}) + +test_that("as(): cross scalar integer→double, RHS", { + nc <- nClass( + Cpublic = list( + to_double = nFunction( + function(x = integerVector) { + ans <- as(x, "numericVector") + return(ans) + returnType(numericVector) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + x <- 1:5L + expect_equal(nco$to_double(x), as.numeric(x)) + rm(nco); gc() +}) + +test_that("as(): cross scalar logical→double, RHS", { + nc <- nClass( + Cpublic = list( + to_double = nFunction( + function(x = logicalVector) { + ans <- as(x, "numericVector") + return(ans) + returnType(numericVector) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + x <- c(TRUE, FALSE, TRUE, FALSE) + expect_equal(nco$to_double(x), as.numeric(x)) + rm(nco); gc() +}) + +test_that("as(): cross scalar integer→double 2D, RHS", { + nc <- nClass( + Cpublic = list( + mat_to_double = nFunction( + function(x = integerMatrix) { + ans <- as(x, "numericMatrix") + return(ans) + returnType(numericMatrix) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + x <- matrix(1:6L, nrow = 2, ncol = 3) + expect_equal(nco$mat_to_double(x), matrix(as.numeric(1:6), nrow = 2, ncol = 3)) + rm(nco); gc() +}) + +# --------------------------------------------------------------------------- +# Same scalar — LHS (assign through StridedTensorMap view) +# --------------------------------------------------------------------------- + +test_that("as(): same scalar 1D viewed as 2D on LHS writes through STM", { + nc <- nClass( + Cpublic = list( + assign_via_view = nFunction( + function(x = numericVector, y = numericMatrix) { + as(x, "numericMatrix") <- y + return(x) + returnType(numericVector) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + # x has 5 elements; y is (5×1), matching the (n,1) view of x. + # After assignment, x should contain y's values. + x <- as.numeric(1:5) + y <- matrix(as.numeric(6:10), nrow = 5, ncol = 1) + expect_equal(nco$assign_via_view(x, y), as.numeric(6:10)) + rm(nco); gc() +}) + +test_that("as(): same scalar 2D viewed as 1D on LHS writes through STM", { + nc <- nClass( + Cpublic = list( + assign_via_view = nFunction( + function(x = numericMatrix, y = numericVector) { + as(x, "numericVector") <- y + return(x) + returnType(numericMatrix) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + # x is a (5×1) matrix; y is a length-5 vector. + # After assignment, x should contain y's values in its single column. + x <- matrix(as.numeric(1:5), nrow = 5, ncol = 1) + y <- as.numeric(6:10) + expect_equal(nco$assign_via_view(x, y), matrix(y, nrow = 5, ncol = 1)) + rm(nco); gc() +}) + +# --------------------------------------------------------------------------- +# Runtime error for incompatible shapes +# --------------------------------------------------------------------------- + +test_that("as(): runtime error when non-singleton dims cannot be dropped", { + nc <- nClass( + Cpublic = list( + bad_reshape = nFunction( + function(x = numericMatrix) { + ans <- as(x, "numericVector") + return(ans) + returnType(numericVector) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + # A (3×4) matrix has two non-singleton dims — cannot map to 1D. + x <- matrix(as.numeric(1:12), nrow = 3, ncol = 4) + expect_error(nco$bad_reshape(x)) + rm(nco); gc() +}) + +# --------------------------------------------------------------------------- +# Pending / not yet implemented +# --------------------------------------------------------------------------- + +test_that("as(): cross-scalar LHS (CastingProxy write-back)", { + skip("Cross-scalar LHS requires CastingProxy::operator= — not yet implemented.") +}) + +test_that("as(): immediate indexing of as() result — as(x, type)[i]", { + skip("Indexing directly on an as() expression (STM path) — not yet implemented.") +}) + +test_that("as(): runtime-source path via ETaccessorBase", { + skip("Runtime-source path (ETaccessorBase from genericInterfaceC) — not yet integrated.") +}) From 91f6144ed9c72f63a69322f927719b87488cc45e Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 22 May 2026 10:18:59 -0700 Subject: [PATCH 2/4] add operator=() to CastingProxy and remove lhs flag --- .../post_Rcpp/ETaccessor_post_Rcpp.h | 2 +- .../nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h | 18 +++++-- .../tests/testthat/specificOp_tests/test-as.R | 49 +++++++++++++++++-- 3 files changed, 60 insertions(+), 9 deletions(-) diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h index 2c30855b..c1c53947 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h @@ -142,7 +142,7 @@ class ETaccessorTyped : public ETaccessorBase { } else { if constexpr (mode == AsMode::LHS) { auto view = STmapTyped(); // STM for write-back correctness (handles non-contiguous sources) - return CastingProxy(view, /*is_lhs=*/true); + return CastingProxy(view); } else { return mapTyped().template cast(); // lazy Eigen expression, RHS only } diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h index 371dec2a..069a127f 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h @@ -21,21 +21,29 @@ class CastingProxy { using CopyTensor = Eigen::Tensor; using TM = Eigen::TensorMap; - ViewType view_; // TensorMap into original source data + ViewType view_; // view into original source data CopyTensor copy_; // TargetScalar copy - bool is_lhs_; public: - explicit CastingProxy(ViewType view, bool is_lhs = false) - : view_(view), copy_(view.template cast()), is_lhs_(is_lhs) {} + explicit CastingProxy(ViewType view) + : view_(view), copy_(view.template cast()) {} + // Always writes copy_ back to the source on destruction. ~CastingProxy() { - if(is_lhs_) view_ = copy_.template cast(); + view_ = copy_.template cast(); } CastingProxy(const CastingProxy&) = delete; CastingProxy& operator=(const CastingProxy&) = delete; + // Assign an Eigen expression into copy_. cast() is a no-op + // when Rhs already has scalar type TargetScalar. + template + CastingProxy& operator=(const Rhs& rhs) { + copy_ = rhs.template cast(); + return *this; + } + TM map() { return TM(copy_.data(), copy_.dimensions()); } }; diff --git a/nCompiler/tests/testthat/specificOp_tests/test-as.R b/nCompiler/tests/testthat/specificOp_tests/test-as.R index e149aa7d..2d278f70 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-as.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-as.R @@ -256,13 +256,56 @@ test_that("as(): runtime error when non-singleton dims cannot be dropped", { }) # --------------------------------------------------------------------------- -# Pending / not yet implemented +# Cross-scalar LHS (CastingProxy write-back) # --------------------------------------------------------------------------- -test_that("as(): cross-scalar LHS (CastingProxy write-back)", { - skip("Cross-scalar LHS requires CastingProxy::operator= — not yet implemented.") +test_that("as(): cross-scalar LHS — double source viewed as integer, integer assigned, writes back double", { + nc <- nClass( + Cpublic = list( + assign_int_to_double = nFunction( + function(x = numericVector, y = integerVector) { + as(x, "integerVector") <- y + return(x) + returnType(numericVector) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + x <- c(1.5, 2.5, 3.5) + y <- c(10L, 20L, 30L) + expect_equal(nco$assign_int_to_double(x, y), as.numeric(y)) + rm(nco); gc() +}) + +test_that("as(): cross-scalar LHS — integer source viewed as double, double assigned, writes back integer", { + nc <- nClass( + Cpublic = list( + assign_double_to_int = nFunction( + function(x = integerVector, y = numericVector) { + as(x, "numericVector") <- y + return(x) + returnType(integerVector) + } + ) + ) + ) + ncc <- nCompile(nc) + nco <- ncc$new() + + x <- 1:3L + y <- c(10.9, 20.1, 30.7) + # double values are truncated to integer on write-back + expect_equal(nco$assign_double_to_int(x, y), as.integer(y)) + rm(nco); gc() }) +# --------------------------------------------------------------------------- +# Pending / not yet implemented +# --------------------------------------------------------------------------- + test_that("as(): immediate indexing of as() result — as(x, type)[i]", { skip("Indexing directly on an as() expression (STM path) — not yet implemented.") }) From 811a54c01597f6c37384e443081fd4b40dd06983 Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 29 May 2026 11:19:46 -0700 Subject: [PATCH 3/4] work on nC_as with proxy returns from ETaccessor asTyped --- nCompiler/NAMESPACE | 2 + nCompiler/R/Rexecution.R | 200 +++--- nCompiler/R/changeKeywords.R | 3 +- nCompiler/R/compile_aaa_operatorLists.R | 4 +- nCompiler/R/compile_eigenization.R | 22 +- nCompiler/R/compile_exprClass.R | 14 +- nCompiler/R/compile_generateCpp.R | 3 +- .../post_Rcpp/ETaccessor_post_Rcpp.h | 37 +- .../nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h | 105 ++- .../nClass_tests/test-nClass_inherit.R | 37 ++ .../tests/testthat/specificOp_tests/test-as.R | 620 +++++++++++++++--- 11 files changed, 820 insertions(+), 227 deletions(-) diff --git a/nCompiler/NAMESPACE b/nCompiler/NAMESPACE index 60960ad5..73d7475a 100644 --- a/nCompiler/NAMESPACE +++ b/nCompiler/NAMESPACE @@ -84,6 +84,8 @@ export(logit) export(method) export(modelBase_nClass) export(nArray) +export(nAs) +export(`nAs<-`) export(nBacksolve) export(nC) export(nChol) diff --git a/nCompiler/R/Rexecution.R b/nCompiler/R/Rexecution.R index 51080743..8210affa 100644 --- a/nCompiler/R/Rexecution.R +++ b/nCompiler/R/Rexecution.R @@ -17,6 +17,60 @@ parallel_reduce <- function(f, x, init, ...) { Reduce(f, x, init) } +make_nAs_output_dims <- function(input_dims, output_nDim) { + input_nDim <- length(input_dims) + if(output_nDim >= input_nDim) + c(input_dims, rep(1, output_nDim - input_nDim)) + else { + output_dims <- input_dims[input_dims > 1] + if(length(output_dims) < output_nDim) output_dims <- c(output_dims, rep(1, output_nDim - length(output_dims))) + if(length(output_dims) > output_nDim) stop("input_dims don't have enough singleton dimensions for output_nDim = ", output_nDim) + output_dims + } +} + +#' @export +nAs <- function(object, type) { + ttype <- nCaptureType(type) + sym <- type2symbol(!!ttype) + output_nDim <- sym$nDim + scalar_type <- sym$type + if(storage.mode(object) != scalar_type) + storage.mode(object) <- scalar_type + input_dims <- dim(object) %||% length(object) + output_dims <- make_nAs_output_dims(input_dims, output_nDim) + if(output_nDim > 1) { + dim(object) <- output_dims + object + } else + as.vector(object) +} + +#' @export +`nAs<-` <- function(object, type, value) { + # Here "input" is object + # and "output" is how object is viewed. + # "output" is only needed to see if it conforms with value. + # If so, the copying can be done with [] on both sides. + obj_expr <- substitute(object) + value_expr <- substitute(value) + ttype <- nCaptureType(type) + sym <- type2symbol(!!ttype) + output_nDim <- sym$nDim + scalar_type <- storage.mode(object) + input_dims <- dim(object) %||% length(object) + output_dims <- make_nAs_output_dims(input_dims, output_nDim) + value_dims <- dim(value) %||% length(value) + if(!all.equal(output_dims, value_dims)) + stop("value doesn't conform to type in nAs<- assignment") + object[] <- value[] + if(storage.mode(object) != scalar_type) + storage.mode(object) <- scalar_type + expr <- substitute(LHS <- OBJ, list(LHS = obj_expr, OBJ = object)) + res <- eval(expr, envir = parent.frame()) + res +} + #' @export square <- function(x) x*x #' @export @@ -60,9 +114,9 @@ nC <- c #' #' @details #' These functions are similar to R's \code{\link{numeric}}, \code{\link{integer}}, \code{\link{logical}} functions, but they can be used in a nFunction and then compiled using \code{nCompile}. Largely for compilation purposes, finer control is provided over initialization behavior. If \code{init = FALSE}, no initialization will be done, and \code{value}, \code{fillZeros} and \code{recycle} will be ignored. If \code{init=TRUE} and \code{recycle=TRUE}, then \code{fillZeros} will be ignored, and \code{value} will be repeated (according to R's recycling rule) as much as necessary to fill a vector of length \code{length}. If \code{init=TRUE} and \code{recycle=FALSE}, then if \code{fillZeros=TRUE}, values of 0 (or FALSE for \code{nLogical}) will be filled in after \code{value} up to length \code{length}. Compiled code will be more efficient if unnecessary initialization is not done, but this may or may not be noticeable depending on the situation. -#' -#' When used in a \code{nFunction} (in \code{run} or other member function), \code{numeric}, \code{integer} and \code{logical} are immediately converted to \code{nNumeric}, \code{nInteger} and \code{nLogical}, respectively. -#' +#' +#' When used in a \code{nFunction} (in \code{run} or other member function), \code{numeric}, \code{integer} and \code{logical} are immediately converted to \code{nNumeric}, \code{nInteger} and \code{nLogical}, respectively. +#' #' @author Daniel Turek, Chris Paciorek, Perry de Valpine #' @aliases numeric #' @seealso \code{\link{nMatrix}}, \code{\link{nArray}} @@ -87,7 +141,7 @@ nLogical <- function(length = 0, value = 0, init = TRUE, fillZeros = TRUE, recyc } #' Creates matrix or array objects for use in nFunctions -#' +#' #' In a \code{nFunction}, \code{matrix} and \code{array} are identical to \code{nMatrix} and \code{nArray}, respectively #' #' @aliases nArray matrix array @@ -108,7 +162,7 @@ nLogical <- function(length = 0, value = 0, init = TRUE, fillZeros = TRUE, recyc #' When used in a \code{nFunction} (in \code{run} or other member function), \code{matrix} and \code{array} are immediately converted to \code{nMatrix} and \code{nArray}, respectively. #' #' The \code{nDim} argument is only necessary for a use like \code{dim <- c(2, 3, 4); A <- nArray(0, dim = dim, nDim = 3)}. It is necessary because the compiler must determine during compilation that \code{A} will be a 3-dimensional numeric array. However, the compiler doesn't know for sure what the length of \code{dim} will be at run time, only that it is a vector. On the other hand, \code{A <- nArray(0, dim = c(2, 3, 4))} is allowed because the compiler can directly determine that a vector of length three is constructed inline for the \code{dim} argument. -#' +#' #' @author Daniel Turek and Perry de Valpine #' @seealso \code{\link{nNumeric}} \code{\link{nInteger}} \code{\link{nLogical}} #' @export @@ -168,13 +222,13 @@ makeReturnVector <- function(fillValue, length, recycle) { else { if(length(fillValue) != length) { if(length(fillValue) < length) { - ##warning(paste0("Not enough values provided for vector of length ",length, ".")) + ##warning(paste0("Not enough values provided for vector of length ",length, ".")) if(recycle) rep(fillValue, length.out = length) else c(fillValue, as(rep(0, length-length(fillValue)), class(fillValue))) } else { - ##warning(paste0("Too many values provided for vector of length ",length, ".")) + ##warning(paste0("Too many values provided for vector of length ",length, ".")) fillValue[1:length] } } else { @@ -184,17 +238,17 @@ makeReturnVector <- function(fillValue, length, recycle) { } #' Spectral Decomposition of a Matrix -#' +#' #' In a \code{nFunction}, \code{nEigen} is identical to \code{eigen} #' -#' @details This function is similar to R's \code{\link{eigen}} function, but -#' can be used in a nFunction and compiled using \code{nCompile}. -#' -#' @param x a numeric or complex matrix whose spectral decomposition is to be +#' @details This function is similar to R's \code{\link{eigen}} function, but +#' can be used in a nFunction and compiled using \code{nCompile}. +#' +#' @param x a numeric or complex matrix whose spectral decomposition is to be #' computed. Logical matrices are coerced to numeric. #' #' @export -#' +#' nEigen <- function(x, symmetric, valuesOnly = FALSE) { res <- eigen(x = x, symmetric = symmetric, only.values = valuesOnly) ans <- EigenDecomp$new() @@ -208,10 +262,10 @@ nEigen <- function(x, symmetric, valuesOnly = FALSE) { return(ans) } -#' Singular Value Decomposition of a Matrix +#' Singular Value Decomposition of a Matrix #' #' Computes singular values and, optionally, left and right singular vectors of a numeric matrix. -#' +#' #' @param x a symmetric numeric matrix (double or integer) whose spectral decomposition is to be computed. #' @param vectors character that determines whether to calculate left and right singular vectors. Can take values \code{'none'}, \code{'thin'} or \code{'full'}. Defaults to \code{'full'}. See details. #' @@ -222,22 +276,22 @@ nEigen <- function(x, symmetric, valuesOnly = FALSE) { #' @export #' #' @details -#' Computes the singular value decomposition of a numeric matrix using the Eigen C++ template library. -#' +#' Computes the singular value decomposition of a numeric matrix using the Eigen C++ template library. +#' #' The \code{vectors} character argument determines whether to compute no left and right singular vectors (\code{0} or (for uncompiled operation) \code{'none'}), thinned left and right singular vectors (\code{1} or (for uncompiled) \code{'thin'}) (the default), or full left and right singular vectors (\code{2} or (for uncompiled) \code{'full'}). For a -#' matrix \code{x} with dimensions \code{n} and \code{p}, setting \code{vectors = 'thin'} will does the following (quoted from eigen website): -#' In case of a rectangular n-by-p matrix, letting m be the smaller value among n and p, there are only m singular vectors; -#' the remaining columns of U and V do not correspond to actual singular vectors. -#' Asking for thin U or V means asking for only their m first columns to be formed. -#' So U is then a n-by-m matrix, and V is then a p-by-m matrix. +#' matrix \code{x} with dimensions \code{n} and \code{p}, setting \code{vectors = 'thin'} will does the following (quoted from eigen website): +#' In case of a rectangular n-by-p matrix, letting m be the smaller value among n and p, there are only m singular vectors; +#' the remaining columns of U and V do not correspond to actual singular vectors. +#' Asking for thin U or V means asking for only their m first columns to be formed. +#' So U is then a n-by-m matrix, and V is then a p-by-m matrix. #' Notice that thin U and V are all you need for (least squares) solving. -#' +#' #' Setting \code{vectors = 'full'} will compute full matrices for U and V, so that U will be of size n-by-n, and V will be of size p-by-p. -#' -#' In a \code{nFunction}, \code{svd} is identical to \code{nSvd}. -#' -#' \code{returnType(svdNimbleList())} can be used within a \link{nFunction} to specify that the function will return a \code{nCompilerList} generated by the \code{nSvd} function. \code{svdNimbleList()} can also be used to define a nested \code{nimbleList} element. See the User Manual for usage examples. -#' +#' +#' In a \code{nFunction}, \code{svd} is identical to \code{nSvd}. +#' +#' \code{returnType(svdNimbleList())} can be used within a \link{nFunction} to specify that the function will return a \code{nCompilerList} generated by the \code{nSvd} function. \code{svdNimbleList()} can also be used to define a nested \code{nimbleList} element. See the User Manual for usage examples. +#' #' @return #' The singular value decomposition of \code{x} is returned as a \code{nCompilerList} with elements: #' \itemize{ @@ -245,8 +299,8 @@ nEigen <- function(x, symmetric, valuesOnly = FALSE) { #' \item v matrix with columns containing the left singular vectors of \code{x}, or an empty matrix if \code{vectors = 'none'}. #' \item u matrix with columns containing the right singular vectors of \code{x}, or an empty matrix if \code{vectors = 'none'}. #' } -#' -#' @examples +#' +#' @examples #' singularValuesDemoFunction <- nFunction( #' setup = function(){ #' demoMatrix <- diag(4) + 2 @@ -259,13 +313,13 @@ nEigen <- function(x, symmetric, valuesOnly = FALSE) { nSvd <- function(x, vectors = 'thin') { n <- nrow(x) p <- ncol(x) - if(vectors %in% c(2, 'full')) { + if(vectors %in% c(2, 'full')) { nu <- n nv <- p - } else if(vectors %in% c(1, 'thin')) { + } else if(vectors %in% c(1, 'thin')) { nu <- min(n, p) nv <- nu - } else if(vectors %in% c(0, 'none')) { + } else if(vectors %in% c(0, 'none')) { nu <- 0 nv <- 0 } @@ -276,83 +330,83 @@ nSvd <- function(x, vectors = 'thin') { } #' Extract or replace the diagonal of matrix -#' +#' #' In a \code{nFunction}, \code{nDiag} is identical to \code{diag} #' -#' @details This function is similar to R's \code{\link{diag}} function, but -#' can be used in a nFunction and compiled using \code{nCompile}. -#' +#' @details This function is similar to R's \code{\link{diag}} function, but +#' can be used in a nFunction and compiled using \code{nCompile}. +#' #' @param x a numeric or complex matrix #' #' @export -#' +#' nDiag <- function(x, ...) { diag(x, ...) } #' Compute the cholesky decomposition of a matrix -#' +#' #' In a \code{nFunction}, \code{nChol} is identical to \code{chol} #' -#' @details This function is similar to R's \code{\link{diag}} function, but -#' can be used in a nFunction and compiled using \code{nCompile}. -#' +#' @details This function is similar to R's \code{\link{diag}} function, but +#' can be used in a nFunction and compiled using \code{nCompile}. +#' #' @param x a symmetric matrix #' #' @export -#' +#' nChol <- function(x) { chol(x) } #' Compute the log-determinant of a matrix -#' +#' #' In a \code{nFunction}, \code{nLogdet} is identical to \code{logdet} #' -#' @details This function is similar to R's \code{\link{diag}} function, but -#' can be used in a nFunction and compiled using \code{nCompile}. -#' +#' @details This function is similar to R's \code{\link{diag}} function, but +#' can be used in a nFunction and compiled using \code{nCompile}. +#' #' @param x a square matrix #' #' @export -#' +#' nLogdet <- function(x) { ldet <- determinant(x, logarithm = TRUE) ifelse(ldet$sign >= 0, ldet$modulus, NaN) } #' Replicate Elements of Vectors and Lists -#' +#' #' In a \code{nFunction}, \code{nRep} is identical to \code{base::rep} #' -#' @details This function is similar to R's \code{\link{rep}} function, but -#' can be used in a nFunction and compiled using \code{nCompile}. -#' -#' @param x a vector (of any mode including a list) or a factor or -#' (for rep only) a POSIXct or POSIXlt or Date object; or an S4 object +#' @details This function is similar to R's \code{\link{rep}} function, but +#' can be used in a nFunction and compiled using \code{nCompile}. +#' +#' @param x a vector (of any mode including a list) or a factor or +#' (for rep only) a POSIXct or POSIXlt or Date object; or an S4 object #' containing such an object. #' #' @param ... further arguments to be passed to or from other methods. #' #' @export -#' +#' nRep <- function(x, ...) { base::rep(x, ...) } #' Sequence Generation -#' +#' #' In a \code{nFunction}, \code{nSeq} is (mostly) equivalent to \code{base::seq} #' -#' @details This function is similar to R's \code{\link{seq}} function, but -#' can be used in a nFunction and compiled using \code{nCompile}. -#' +#' @details This function is similar to R's \code{\link{seq}} function, but +#' can be used in a nFunction and compiled using \code{nCompile}. +#' #' @param from the starting value of the sequence. -#' +#' #' @param to the ending value of the sequence. -#' +#' #' @param by increment of the sequence -#' +#' #' @param length.out desired length of the sequence #' #' @details @@ -363,7 +417,7 @@ nRep <- function(x, ...) { #' There are no nCompiler versions of \code{seq.int}, \code{seq_along} or \code{seq_len}. #' @export -#' +#' nSeq <- function(...) { base::seq(...) } @@ -375,11 +429,11 @@ nSeq <- function(...) { #' @importFrom Matrix Matrix drop0 #' @importFrom methods as #' @param x object to convert to sparse representation -#' @param prune TRUE to remove 0's from an object if it is already stored in a +#' @param prune TRUE to remove 0's from an object if it is already stored in a #' sparse format #' @export asSparse <- function(x, prune = TRUE) { - if(inherits(x, c('dgCMatrix', 'dgTMatrix', 'dsparseVector', 'isparseVector', + if(inherits(x, c('dgCMatrix', 'dgTMatrix', 'dsparseVector', 'isparseVector', 'lsparseVector', 'zsparseVector'))) { if(prune) { return(drop0(x)) @@ -396,7 +450,7 @@ asSparse <- function(x, prune = TRUE) { } #' Converts a sparse matrix or vector to a dense sparse matrix or vector -#' +#' #' @export asDense <- function(x) { if(inherits(x, c('matrix', 'numeric', 'integer', 'logical', 'complex'))) { @@ -411,7 +465,7 @@ asDense <- function(x) { } #' Wrapper for matrix multiplication -#' +#' #' @export nMul <- function(x, y) { x %*% y @@ -439,15 +493,15 @@ nBacksolve <- function(r, x) { } #' Wrapper for var -#' +#' #' @export -nVar <- function(x) { - var(x) +nVar <- function(x) { + var(x) } #' Wrapper for sd -#' +#' #' @export -nSd <- function(x) { - sd(x) +nSd <- function(x) { + sd(x) } diff --git a/nCompiler/R/changeKeywords.R b/nCompiler/R/changeKeywords.R index 8e0a564d..a461bd3c 100644 --- a/nCompiler/R/changeKeywords.R +++ b/nCompiler/R/changeKeywords.R @@ -1,4 +1,5 @@ -nKeyWords <- list(copy = 'nCopy', +nKeyWords <- list(as = 'nAs', + copy = 'nCopy', print = 'nPrint', cat = 'nCat', step = 'nStep', diff --git a/nCompiler/R/compile_aaa_operatorLists.R b/nCompiler/R/compile_aaa_operatorLists.R index 3a12217c..48a7677b 100644 --- a/nCompiler/R/compile_aaa_operatorLists.R +++ b/nCompiler/R/compile_aaa_operatorLists.R @@ -237,11 +237,11 @@ assignOperatorDef( ) assignOperatorDef( - 'as', + 'nAs', list( matchDef = function(object, type) {}, compileArgs = c("type"), - help = 'as(object, type) uses "object" as if it is of type "type", where the type is limited to basic types.', + help = 'as(object, type) (or nAs(object, type)) uses "object" as if it is of type "type", where the type is limited to basic types.', labelAbstractTypes = list( handler = 'As'), eigenImpl = list( diff --git a/nCompiler/R/compile_eigenization.R b/nCompiler/R/compile_eigenization.R index 2a619c8d..f9c07e0c 100644 --- a/nCompiler/R/compile_eigenization.R +++ b/nCompiler/R/compile_eigenization.R @@ -447,11 +447,21 @@ inEigenizeEnv( inEigenizeEnv( As <- function(code, symTab, auxEnv, workEnv, handlingInfo) { - ## STM is needed when as() is immediately indexed: as(X, type)[...] - ## LHS detection is handled centrally via code$aux$onLHS (set in labelAbstractTypes). caller <- code$caller - use_stm <- !is.null(caller) && caller$name == "[" && isTRUE(code$callerArgID == 1) - code$aux$useSTM <- use_stm + # labelAbstractTypes does not propagate onLHS through [<-, so we detect + # indexed LHS/RHS by looking up at the caller rather than reading onLHS. + caller_is_bracket_rhs <- !is.null(caller) && caller$name == "[" && + isTRUE(code$callerArgID == 1) + caller_is_bracket_lhs <- !is.null(caller) && caller$name == "[<-" && + isTRUE(code$callerArgID == 1) + + # AsMode::STM is needed for indexed RHS so slicing strides are correct. + code$aux$useSTM <- caller_is_bracket_rhs + + # labelAbstractTypes sets onLHS for the plain <- case; we handle [<- here. + if(caller_is_bracket_lhs) + code$aux$onLHS <- TRUE + invisible(NULL) } ) @@ -926,8 +936,8 @@ nCompiler:::inEigenizeEnv( # Either we're indexing a vector and we keep '[' in the AST, or we're # indexing a non-vector object and we use 'index(' instead. # TODO: if (code$args[[1]]$type$nDim == 0) - if (code$args[[1]]$type$nDim == 1) code$name <- 'index[' - else if (code$args[[1]]$type$nDim > 1) code$name <- 'index(' + if (code$args[[1]]$type$nDim == 1 && isTRUE(code$args[[1]]$isName)) code$name <- 'index[' + else code$name <- 'index(' ## Enforce C++ type long for all indices using static_cast(index_expr) ## We see inconsistent C++ compiler behavior around casting a double index ## to a long index, so we do it explicitly. diff --git a/nCompiler/R/compile_exprClass.R b/nCompiler/R/compile_exprClass.R index 7341366d..a9fff29b 100644 --- a/nCompiler/R/compile_exprClass.R +++ b/nCompiler/R/compile_exprClass.R @@ -588,19 +588,21 @@ exprClass_put_args_in_order <- function(def, expr, # separate compile-time arguments. # This is done AFTER inserting defaults, so that compile-time args can have defaults. # The nParse-ing of compileTime args was superfluous, so we throw it out in this step. - expr$aux[["compileArgs"]] <- list() + # Seed from any already-extracted compileArgs so repeated normalization calls + # are safe: if an arg was already removed from expr$args in a prior call, its + # value is preserved in aux_compileArgs rather than silently dropped. if(length(compileArgs)>0) { - aux_compileArgs <- list() - iRes <- 1 + aux_compileArgs <- if(!is.null(expr$aux[["compileArgs"]])) expr$aux[["compileArgs"]] else list() for(CA_name in compileArgs) { if(CA_name %in% names(expr$args)) { - aux_compileArgs[[iRes]] <- expr$args[[CA_name]]$Rexpr - names(aux_compileArgs)[iRes] <- CA_name - iRes <- iRes + 1 + aux_compileArgs[[CA_name]] <- expr$args[[CA_name]]$Rexpr removeArg(expr, CA_name) } + # else: already extracted in a prior normalization call — keep existing value } expr$aux[["compileArgs"]] <- aux_compileArgs + } else { + if(is.null(expr$aux[["compileArgs"]])) expr$aux[["compileArgs"]] <- list() } expr } diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index 6ab78cbd..d891b43d 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -623,7 +623,8 @@ inGenCppEnv( tgt_cpp <- as_op_scalarToCpp(tgt_type) mode_arg <- if(is_lhs) ', AsMode::LHS' else if(use_stm) ', AsMode::STM' else '' - paste0('as_nC<', tgt_cpp, ', ', tgt_nDim, mode_arg, '>(', obj_cpp, ')') + # All proxy types expose operator()() — always append (). + paste0('as_nC<', tgt_cpp, ', ', tgt_nDim, mode_arg, '>(', obj_cpp, ')()') } ) diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h index c1c53947..a069ce00 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h @@ -3,18 +3,19 @@ #include #include +#include template class ETaccessorTyped; -using Eigen::StridedTensorMap; - enum class AsMode { TM, STM, LHS }; -// Forward declaration: CastingProxy is defined in nC_as.h (included after -// this file). ETaccessorTyped::asTyped() returns it; because asTyped() is a -// template, instantiation is deferred to the call site where CastingProxy is -// fully defined. +// Forward declarations: proxy classes are defined in nC_as.h (included after +// this file). ETaccessorTyped::asTyped() returns them; because asTyped() is a +// template, instantiation is deferred to the call site where they are fully +// defined. +template class EmptyProxy; +template class RHSCastProxy; template class CastingProxy; // Virtual nDim-general methods (e.g. resize, conversions to and from SEXP). @@ -53,7 +54,7 @@ class ETaccessorBase { using ETM = Eigen::TensorMap >; template - using ESTM = StridedTensorMap >; + using ESTM = Eigen::StridedTensorMap >; template ETaccessorTyped &S() { @@ -122,7 +123,7 @@ class ETaccessorTyped : public ETaccessorBase { } template - using ESTM = StridedTensorMap >; + using ESTM = Eigen::StridedTensorMap >; // StridedTensorMap variant of mapTyped — same singleton-drop/pad logic. template @@ -130,21 +131,27 @@ class ETaccessorTyped : public ETaccessorBase { return Eigen::MakeStridedTensorMap::make(mapTyped()); } - // Central dispatch for as() operations. Selects view type and write-back - // behaviour at compile time based on scalar match and AsMode. + // Central dispatch for as() operations. Returns a proxy wrapping the + // appropriate view. All proxy types expose operator()() uniformly. template auto asTyped() { if constexpr (std::is_same_v) { if constexpr (mode == AsMode::TM) - return mapTyped(); + return EmptyProxy>(mapTyped()); else - return STmapTyped(); // mode == STM or LHS: STM for full element access + return EmptyProxy>(STmapTyped()); } else { if constexpr (mode == AsMode::LHS) { - auto view = STmapTyped(); // STM for write-back correctness (handles non-contiguous sources) + auto view = STmapTyped(); return CastingProxy(view); + } else if constexpr (mode == AsMode::STM) { + // Indexed RHS: use STM so that non-contiguous sources (e.g. blockRef) + // have correct strides in the lazy cast expression. + auto view = STmapTyped(); + return RHSCastProxy(view); } else { - return mapTyped().template cast(); // lazy Eigen expression, RHS only + auto view = mapTyped(); + return RHSCastProxy(view); } } } @@ -198,7 +205,7 @@ Eigen::TensorMap > ETaccessorBase::map() { } template -StridedTensorMap > ETaccessorBase::STmap() { +Eigen::StridedTensorMap > ETaccessorBase::STmap() { auto castptr = dynamic_cast* >(this); if(castptr == nullptr) Rcpp::stop("Problem creating an STmap() from some form of access().\n"); return castptr->template STmapTyped(); diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h index 069a127f..0222d849 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h @@ -4,31 +4,79 @@ #include #include +// --------------------------------------------------------------------------- +// All as_nC<>() calls return a proxy. Every proxy exposes operator()() to +// obtain the underlying tensor expression or reference. This uniform interface +// means callers always write as_nC(x)() regardless of mode or +// scalar match. +// +// Four proxy types, selected at compile time by asTyped() / as_nC(): +// +// EmptyProxy — same-scalar; wraps TM or STM view +// RHSCastProxy — cross-scalar RHS; lazy, no allocation +// CastingProxy — cross-scalar LHS; eager copy + write-back +// RuntimeCastingProxy — runtime-source (ETaccessorBase) +// --------------------------------------------------------------------------- + +// EmptyProxy +// +// Same-scalar proxy. Stores a TensorMap or StridedTensorMap by value (cheap: +// just a pointer + dims). operator()() returns a reference to the stored view +// for all Eigen tensor operations. +template +class EmptyProxy { + ViewType view_; +public: + explicit EmptyProxy(ViewType view) : view_(std::move(view)) {} + EmptyProxy(const EmptyProxy&) = delete; + EmptyProxy& operator=(const EmptyProxy&) = delete; + ViewType& operator()() { return view_; } +}; + +// RHSCastProxy +// +// Cross-scalar RHS proxy. ViewType is TM (AsMode::TM, non-indexed) or STM +// (AsMode::STM, indexed). Stores the view by value; operator()() returns a +// fresh lazy view.cast() expression each time. The const ViewType& +// inside the TensorConversionOp refers to the stable view_ member, not a stack +// temporary, so there is no dangling reference. No copy of source data is made. +// +// STM must be used for indexed RHS (AsMode::STM) so that non-contiguous sources +// (e.g. blockRef) produce correct strides in the lazy cast expression. +template +class RHSCastProxy { + ViewType view_; +public: + explicit RHSCastProxy(ViewType view) : view_(std::move(view)) {} + RHSCastProxy(const RHSCastProxy&) = delete; + RHSCastProxy& operator=(const RHSCastProxy&) = delete; + auto operator()() { return view_.template cast(); } +}; + // CastingProxy // -// RAII wrapper for cross-scalar-type as() on the LHS. Holds a copy of the -// source view cast to TargetScalar. On destruction, casts the (possibly -// modified) copy back into the original view via ViewType::operator=. +// Cross-scalar LHS proxy. Holds an eager copy of the source view cast to +// TargetScalar. On destruction, casts the copy back into the original view. // ViewType should be a StridedTensorMap so that non-contiguous sources -// (e.g. blockRef) are handled correctly. For RHS use, is_lhs = false -// makes the destructor a no-op. +// (e.g. blockRef) are handled correctly. // -// ViewType must expose ::Scalar, ::NumDimensions, and operator= from Eigen. +// operator()() returns CopyTensor& for all Eigen write operations: +// as_nC(x)()(i, j) = val; // element write +// ISEQS_(2, si, as_nC(x)()) = y; // range write +// as_nC(x)() = rhs; // whole-object write template class CastingProxy { static constexpr int nDim = ViewType::NumDimensions; using SourceScalar = typename ViewType::Scalar; using CopyTensor = Eigen::Tensor; - using TM = Eigen::TensorMap; - ViewType view_; // view into original source data - CopyTensor copy_; // TargetScalar copy + ViewType view_; + CopyTensor copy_; public: explicit CastingProxy(ViewType view) : view_(view), copy_(view.template cast()) {} - // Always writes copy_ back to the source on destruction. ~CastingProxy() { view_ = copy_.template cast(); } @@ -36,27 +84,23 @@ class CastingProxy { CastingProxy(const CastingProxy&) = delete; CastingProxy& operator=(const CastingProxy&) = delete; - // Assign an Eigen expression into copy_. cast() is a no-op - // when Rhs already has scalar type TargetScalar. - template - CastingProxy& operator=(const Rhs& rhs) { - copy_ = rhs.template cast(); - return *this; - } - - TM map() { return TM(copy_.data(), copy_.dimensions()); } + CopyTensor& operator()() { return copy_; } }; // RuntimeCastingProxy // -// Used when the source type is only known at runtime (ETaccessorBase). -// At construction, dynamic_cast tests whether the source scalar matches -// TargetScalar: -// - Same type: map_ points directly into source data (no copy). -// - Different type: allocates copy_, cast-copies from source; map_ points -// into copy_->data(). +// Runtime-source proxy (ETaccessorBase). At construction, dynamic_cast tests +// whether the source scalar matches TargetScalar: +// - Same type: data_ptr_ points directly into source data (no copy). +// - Different type: allocates copy_, cast-copies from source; +// data_ptr_ points into copy_->data(). // On destruction, if a copy was made and is_lhs is true, writes copy_ back // into the source via virtual writeBackFrom* methods. +// +// operator()() returns TM for all Eigen ops (element access, ISEQS_, ...): +// as_nC(*acc)()(i) // element read +// as_nC(*acc)()(i) = val; // element write +// as_nC(*acc)() = rhs; // whole-object write template class RuntimeCastingProxy { using TM = Eigen::TensorMap>; @@ -143,27 +187,26 @@ class RuntimeCastingProxy { RuntimeCastingProxy(const RuntimeCastingProxy&) = delete; RuntimeCastingProxy& operator=(const RuntimeCastingProxy&) = delete; - TM map() { return TM(data_ptr_, dims_); } + TM operator()() { return TM(data_ptr_, dims_); } }; // --------------------------------------------------------------------------- // as_nC — the single public API emitted by the nCompiler code generator. // Two overloads: compile-time source (any concrete T) and runtime source // (ETaccessorBase&, scalar type unknown at C++ compile time). +// +// All overloads return a proxy; caller always writes as_nC(x)(). // --------------------------------------------------------------------------- // Compile-time source: delegates to ETaccessorTyped::asTyped<>(). -// Returns: TM (TM mode), STM (STM/LHS same-scalar), CastingProxy (LHS cross- -// scalar), or a lazy Eigen cast expression (RHS cross-scalar). +// Returns EmptyProxy, EmptyProxy, RHSCastProxy, or CastingProxy. template auto as_nC(T& x) { return ETaccess(x).template asTyped(); } // Runtime source: scalar type of acc is unknown at compile time. -// Returns a RuntimeCastingProxy that uses dynamic_cast to avoid copies when -// source scalar already matches TargetScalar, and virtual cast/writeback -// methods otherwise. Write-back occurs on destruction iff mode == LHS. +// Returns RuntimeCastingProxy. Write-back occurs on destruction iff mode == LHS. template RuntimeCastingProxy as_nC(ETaccessorBase& acc) { return RuntimeCastingProxy(acc, mode == AsMode::LHS); diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R index 2f33de9d..5c8cbe1e 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R @@ -698,3 +698,40 @@ test_that("inheritance with interfaces at multiple levels", { rm(Cder, Cmid, Cbase); gc() }) + +test_that("manual access to derived interfaced members works", { + ncBase <- nClass( + classname = "ncBase", + Cpublic = list(v = 'numericScalar') + ) + ncDer <- nClass( + classname = "ncDer", + inherit = ncBase, + Cpublic = list(x = "numericVector") + ) + foo <- nFunction( + function(obj = ncDer()) { + cppLiteral("auto ETacc = obj->access(\"x\");") + cppLiteral("ans = ETacc->map<1, double>();", types=list(ans="numericVector")) + # Cppliteral("ans = Rcpp::as >(obj->get_value(\"x\"));", types=list(ans = "numericVector")) + return(ans) + returnType(numericVector()) + } + ) + foo2 <- nFunction( + function(obj = ncBase()) { + cppLiteral("auto ETacc = obj->access(\"x\");") + cppLiteral("ans = ETacc->map<1, double>();", types=list(ans="numericVector")) +# cppLiteral("ans = Rcpp::as >(obj->get_value(\"x\"));", types=list(ans = "numericVector")) + return(ans) + returnType(numericVector()) + } + ) + + comp <- nCompile(ncBase, ncDer, foo, foo2) + obj <- comp$ncDer$new() + obj$x <- 1:3 + comp$foo(obj) + comp$foo2(obj) + rm(obj); gc() +}) diff --git a/nCompiler/tests/testthat/specificOp_tests/test-as.R b/nCompiler/tests/testthat/specificOp_tests/test-as.R index 2d278f70..5bdeafbf 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-as.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-as.R @@ -9,12 +9,10 @@ # source nDim, singleton dimensions are dropped; when more, 1s are appended. # A runtime error is thrown if too many non-singleton dimensions would be lost. # -# Items not yet implemented (marked with skip()): -# - Uncompiled (R-side) execution of as(). -# - Cross-scalar LHS: requires CastingProxy::operator=. -# - Immediate indexing of an as() expression: as(x, type)[i] (complex Eigen -# interaction between STM and the indexing subsystem). -# - Runtime-source path: ETaccessorBase input from genericInterfaceC. +# Each test runs in three modes: uncompiled R ("R"), compiled non-package +# ("non_pkg"), and compiled package ("pkg"). +# +# All planned cases are implemented. # --------------------------------------------------------------------------- # Same scalar, dimension change — RHS @@ -39,9 +37,14 @@ test_that("as(): same scalar 2D→1D singleton-drop, RHS", { ) ) ) - for(package in c(FALSE, TRUE)) { - ncc <- nCompile(nc, package = package) - nco <- ncc$new() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } # Single-column (n×1) matrix: singleton column dim is dropped. x_col <- matrix(as.numeric(1:6), nrow = 6, ncol = 1) @@ -50,8 +53,8 @@ test_that("as(): same scalar 2D→1D singleton-drop, RHS", { # Single-row (1×n) matrix: singleton row dim is dropped. x_row <- matrix(as.numeric(1:6), nrow = 1, ncol = 6) expect_equal(nco$row_to_vec(x_row), as.numeric(1:6)) + rm(nco); gc() } - rm(nco); gc() }) test_that("as(): same scalar 1D→2D dimension padding, RHS", { @@ -66,13 +69,20 @@ test_that("as(): same scalar 1D→2D dimension padding, RHS", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - # A length-n vector is viewed as an (n×1) matrix (second dim padded with 1). - x <- as.numeric(1:5) - expect_equal(nco$vec_to_mat(x), matrix(x, ncol = 1)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + # A length-n vector is viewed as an (n×1) matrix (second dim padded with 1). + x <- as.numeric(1:5) + expect_equal(nco$vec_to_mat(x), matrix(x, ncol = 1)) + rm(nco); gc() + } }) test_that("as(): same scalar, result used in arithmetic", { @@ -82,19 +92,25 @@ test_that("as(): same scalar, result used in arithmetic", { function(x = numericMatrix) { ans <- sum(as(x, "numericVector")) ans <- ans + sum(as(x, "numericVector") + (1:length(x))) - # ans <- sum(v) return(ans) returnType(numericScalar) } ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - x <- matrix(as.numeric(1:4), nrow = 4, ncol = 1) - expect_equal(nco$sum_col(x), sum(x) + sum(x + 1:length(x))) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- matrix(as.numeric(1:4), nrow = 4, ncol = 1) + expect_equal(nco$sum_col(x), sum(x) + sum(x + 1:length(x))) + rm(nco); gc() + } }) # --------------------------------------------------------------------------- @@ -113,11 +129,19 @@ test_that("as(): cross scalar double→integer, RHS", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - x <- c(1.9, 2.1, 3.7, -0.5) - expect_equal(nco$to_int(x), as.integer(x)) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- c(1.9, 2.1, 3.7, -0.5) + expect_equal(nco$to_int(x), as.integer(x)) + rm(nco); gc() + } }) test_that("as(): cross scalar integer→double, RHS", { @@ -132,12 +156,19 @@ test_that("as(): cross scalar integer→double, RHS", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - x <- 1:5L - expect_equal(nco$to_double(x), as.numeric(x)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- 1:5L + expect_equal(nco$to_double(x), as.numeric(x)) + rm(nco); gc() + } }) test_that("as(): cross scalar logical→double, RHS", { @@ -152,12 +183,19 @@ test_that("as(): cross scalar logical→double, RHS", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - x <- c(TRUE, FALSE, TRUE, FALSE) - expect_equal(nco$to_double(x), as.numeric(x)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- c(TRUE, FALSE, TRUE, FALSE) + expect_equal(nco$to_double(x), as.numeric(x)) + rm(nco); gc() + } }) test_that("as(): cross scalar integer→double 2D, RHS", { @@ -172,12 +210,19 @@ test_that("as(): cross scalar integer→double 2D, RHS", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - x <- matrix(1:6L, nrow = 2, ncol = 3) - expect_equal(nco$mat_to_double(x), matrix(as.numeric(1:6), nrow = 2, ncol = 3)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- matrix(1:6L, nrow = 2, ncol = 3) + expect_equal(nco$mat_to_double(x), matrix(as.numeric(1:6), nrow = 2, ncol = 3)) + rm(nco); gc() + } }) # --------------------------------------------------------------------------- @@ -196,15 +241,22 @@ test_that("as(): same scalar 1D viewed as 2D on LHS writes through STM", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - # x has 5 elements; y is (5×1), matching the (n,1) view of x. - # After assignment, x should contain y's values. - x <- as.numeric(1:5) - y <- matrix(as.numeric(6:10), nrow = 5, ncol = 1) - expect_equal(nco$assign_via_view(x, y), as.numeric(6:10)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + # x has 5 elements; y is (5×1), matching the (n,1) view of x. + # After assignment, x should contain y's values. + x <- as.numeric(1:5) + y <- matrix(as.numeric(6:10), nrow = 5, ncol = 1) + expect_equal(nco$assign_via_view(x, y), as.numeric(6:10)) + rm(nco); gc() + } }) test_that("as(): same scalar 2D viewed as 1D on LHS writes through STM", { @@ -219,15 +271,22 @@ test_that("as(): same scalar 2D viewed as 1D on LHS writes through STM", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - # x is a (5×1) matrix; y is a length-5 vector. - # After assignment, x should contain y's values in its single column. - x <- matrix(as.numeric(1:5), nrow = 5, ncol = 1) - y <- as.numeric(6:10) - expect_equal(nco$assign_via_view(x, y), matrix(y, nrow = 5, ncol = 1)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + # x is a (5×1) matrix; y is a length-5 vector. + # After assignment, x should contain y's values in its single column. + x <- matrix(as.numeric(1:5), nrow = 5, ncol = 1) + y <- as.numeric(6:10) + expect_equal(nco$assign_via_view(x, y), matrix(y, nrow = 5, ncol = 1)) + rm(nco); gc() + } }) # --------------------------------------------------------------------------- @@ -246,13 +305,20 @@ test_that("as(): runtime error when non-singleton dims cannot be dropped", { ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - # A (3×4) matrix has two non-singleton dims — cannot map to 1D. - x <- matrix(as.numeric(1:12), nrow = 3, ncol = 4) - expect_error(nco$bad_reshape(x)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + # A (3×4) matrix has two non-singleton dims — cannot map to 1D. + x <- matrix(as.numeric(1:12), nrow = 3, ncol = 4) + expect_error(nco$bad_reshape(x)) + rm(nco); gc() + } }) # --------------------------------------------------------------------------- @@ -271,13 +337,20 @@ test_that("as(): cross-scalar LHS — double source viewed as integer, integer a ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - x <- c(1.5, 2.5, 3.5) - y <- c(10L, 20L, 30L) - expect_equal(nco$assign_int_to_double(x, y), as.numeric(y)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- c(1.5, 2.5, 3.5) + y <- c(10L, 20L, 30L) + expect_equal(nco$assign_int_to_double(x, y), as.numeric(y)) + rm(nco); gc() + } }) test_that("as(): cross-scalar LHS — integer source viewed as double, double assigned, writes back integer", { @@ -292,24 +365,387 @@ test_that("as(): cross-scalar LHS — integer source viewed as double, double as ) ) ) - ncc <- nCompile(nc) - nco <- ncc$new() - - x <- 1:3L - y <- c(10.9, 20.1, 30.7) - # double values are truncated to integer on write-back - expect_equal(nco$assign_double_to_int(x, y), as.integer(y)) - rm(nco); gc() + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- 1:3L + y <- c(10.9, 20.1, 30.7) + # double values are truncated to integer on write-back + expect_equal(nco$assign_double_to_int(x, y), as.integer(y)) + rm(nco); gc() + } }) # --------------------------------------------------------------------------- -# Pending / not yet implemented +# Indexing of as() results # --------------------------------------------------------------------------- -test_that("as(): immediate indexing of as() result — as(x, type)[i]", { - skip("Indexing directly on an as() expression (STM path) — not yet implemented.") +# RHS scalar result — same scalar ----------------------------------------------- + +test_that("as(): RHS scalar indexing same-scalar (all-singleton)", { + nc <- nClass( + Cpublic = list( + get_elem = nFunction( + function(x = numericVector) { + ans <- as(x, "numericMatrix")[2, 1] + return(ans) + returnType(numericScalar) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- c(10.0, 20.0, 30.0) # viewed as 3×1 matrix; [2,1] == x[2] + expect_equal(nco$get_elem(x), 20.0) + rm(nco); gc() + } }) -test_that("as(): runtime-source path via ETaccessorBase", { - skip("Runtime-source path (ETaccessorBase from genericInterfaceC) — not yet integrated.") +foo <- nFunction( + fun=function(x = 'numericVector') {y <- integer(length = 5); y <- x; return(y); returnType('integerVector')} +) +cfoo <- nCompile(foo) +cfoo(c(1.2, 2.3)) + +# RHS scalar result — cross scalar ----------------------------------------------- + +test_that("as(): RHS scalar indexing cross-scalar (double→integer)", { + nc <- nClass( + Cpublic = list( + get_int = nFunction( + function(x = numericVector) { + ans <- as(x, "integerVector")[2] + return(ans) + returnType(integerScalar) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- c(1.9, 2.7, 3.1) + expect_equal(nco$get_int(x), 2L) # truncation toward zero + rm(nco); gc() + } +}) + +# RHS range result — same scalar ------------------------------------------------- + +test_that("as(): RHS range indexing same-scalar (pure range)", { + nc <- nClass( + Cpublic = list( + sub_mat = nFunction( + function(x = numericVector) { + ans <- as(x, "numericMatrix")[1:3, 1:1, drop=FALSE] + return(ans) + returnType(numericMatrix) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- as.numeric(1:5) # viewed as 5×1; rows 1:3, col 1:1 → 3×1 + expect_equal(nco$sub_mat(x), matrix(1:3, ncol = 1)) + rm(nco); gc() + } +}) + +# RHS range result — cross scalar ------------------------------------------------ + +test_that("as(): RHS range indexing cross-scalar (integer→double)", { + nc <- nClass( + Cpublic = list( + sub_dbl = nFunction( + function(x = integerVector) { + ans <- as(x, "numericMatrix")[1:3, 1:1, drop=FALSE] + return(ans) + returnType(numericMatrix) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- 1:5L # viewed as 5×1; rows 1:3 → 3×1 double matrix + expect_equal(nco$sub_dbl(x), matrix(as.numeric(1:3), ncol = 1)) + rm(nco); gc() + } +}) + +# LHS scalar write-back — same scalar ------------------------------------------- + +test_that("as(): LHS scalar assignment same-scalar (all-singleton)", { + nc <- nClass( + Cpublic = list( + set_elem = nFunction( + function(x = numericVector, val = numericScalar) { + as(x, "numericMatrix")[2, 1] <- val + return(x) + returnType(numericVector) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- c(10.0, 20.0, 30.0) + result <- nco$set_elem(x, 99.0) + expect_equal(result, c(10.0, 99.0, 30.0)) + rm(nco); gc() + } +}) + +# LHS range write-back — same scalar -------------------------------------------- + +test_that("as(): LHS range assignment same-scalar (pure range)", { + nc <- nClass( + Cpublic = list( + set_range = nFunction( + function(x = numericVector, y = numericMatrix) { + as(x, "numericMatrix")[1:3, 1:1] <- y + return(x) + returnType(numericVector) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- as.numeric(1:5) + y <- matrix(c(10.0, 20.0, 30.0), nrow = 3, ncol = 1) + result <- nco$set_range(x, y) + expect_equal(result, c(10.0, 20.0, 30.0, 4.0, 5.0)) + rm(nco); gc() + } +}) + +# LHS scalar write-back — cross scalar ------------------------------------------ + +test_that("as(): LHS scalar assignment cross-scalar (double source, integer view)", { + nc <- nClass( + Cpublic = list( + set_int_elem = nFunction( + function(x = numericVector, val = integerScalar) { + as(x, "integerMatrix")[2, 1] <- val + return(x) + returnType(numericVector) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- c(10.0, 20.0, 30.0) # double; view as int matrix, assign int to [2,1] + result <- nco$set_int_elem(x, 99L) + expect_equal(result, c(10.0, 99.0, 30.0)) + rm(nco); gc() + } +}) + +# LHS range write-back — cross scalar ------------------------------------------- + +test_that("as(): LHS range assignment cross-scalar (double source, integer view)", { + nc <- nClass( + Cpublic = list( + set_int_range = nFunction( + function(x = numericVector, y = integerMatrix) { + as(x, "integerMatrix")[1:3, 1:1] <- y + return(x) + returnType(numericVector) + } + ) + ) + ) + for(mode in c("R", "non_pkg", "pkg")) { + if(mode == "R") { + nco <- nc$new() + } else { + package <- mode == "pkg" + ncc <- nCompile(nc, package = package) + nco <- ncc$new() + } + + x <- as.numeric(1:5) + y <- matrix(c(10L, 20L, 30L), nrow = 3, ncol = 1) + result <- nco$set_int_range(x, y) + expect_equal(result, c(10.0, 20.0, 30.0, 4.0, 5.0)) + rm(nco); gc() + } +}) + +# --------------------------------------------------------------------------- +# Runtime-source path via ETaccessorBase (RuntimeCastingProxy) +# +# obj->access("varname") returns unique_ptr. +# as_nC(*acc) constructs a RuntimeCastingProxy that views source data +# directly when scalars match, or makes a cast copy otherwise (writing back +# on destruction when LHS mode). +# +# Tests use cppLiteral with a two-nClass pattern: ncAcc holds the data member +# x, and ncOps creates a local ncAcc object inside each method so that +# data->access("x") is valid C++ (avoids the self->access() path that requires +# the self-keyword PR not yet merged). Compiled modes only. +# --------------------------------------------------------------------------- + +test_that("as(): ETaccessorBase RHS paths (same-scalar, cross-scalar sum and element)", { + ncAcc <- nClass( + Cpublic = list(x = 'numericVector') + ) + ncOps <- nClass( + Cpublic = list( + # same scalar: no copy, direct pointer into x + rhs_same_sum = nFunction( + function(v = numericVector) { + data <- ncAcc$new() + data$x <- v + ans <- 0.0 + cppLiteral('{ auto _acc = data->access("x"); ans = as_nC(*_acc)().sum(); }') + return(ans) + returnType(numericScalar) + } + ), + # cross scalar sum: cast-copy double→int, sum truncated values + rhs_xscalar_sum = nFunction( + function(v = numericVector) { + data <- ncAcc$new() + data$x <- v + ans <- 0L + cppLiteral('{ auto _acc = data->access("x"); ans = as_nC(*_acc)().sum(); }') + return(ans) + returnType(integerScalar) + } + ), + # cross scalar element: operator()() then (i) on the proxy + rhs_xscalar_elem = nFunction( + function(v = numericVector, i = integerScalar) { + data <- ncAcc$new() + data$x <- v + ans <- 0L + cppLiteral('{ auto _acc = data->access("x"); ans = as_nC(*_acc)()(i - 1); }') + return(ans) + returnType(integerScalar) + } + ) + ) + ) + for(mode in c("non_pkg", "pkg")) { + package <- mode == "pkg" + comp <- nCompile(ncAcc, ncOps, package = package) + nco <- comp$ncOps$new() + + # same scalar: 1+2+3+4 = 10 + expect_equal(nco$rhs_same_sum(c(1.0, 2.0, 3.0, 4.0)), 10.0) + + # cross scalar sum: 1.9→1, 2.1→2, 3.7→3 → sum = 6 + expect_equal(nco$rhs_xscalar_sum(c(1.9, 2.1, 3.7)), 6L) + + # cross scalar element: x[2] = 20.1 → truncates to 20 + expect_equal(nco$rhs_xscalar_elem(c(10.9, 20.1, 30.7), 2L), 20L) + + rm(nco); gc() + } +}) + +test_that("as(): ETaccessorBase LHS paths (same-scalar write-through, cross-scalar write-back)", { + ncAcc <- nClass( + Cpublic = list(x = 'numericVector') + ) + ncOps <- nClass( + Cpublic = list( + # same scalar LHS: direct pointer write, no destructor copy, verify via second accessor + lhs_same = nFunction( + function(v = numericVector) { + data <- ncAcc$new() + data$x <- numeric(length = length(v), value = 0) + cppLiteral('{ auto _acc = data->access("x"); as_nC(*_acc) = v; }') + ans <- 0.0 + cppLiteral('{ auto _acc2 = data->access("x"); ans = as_nC(*_acc2)().sum(); }') + return(ans) + returnType(numericScalar) + } + ), + # cross scalar LHS: int proxy writes int values into double storage on destruction + lhs_xscalar = nFunction( + function(v = integerVector) { + data <- ncAcc$new() + data$x <- numeric(length = length(v), value = 0) + cppLiteral('{ auto _acc = data->access("x"); as_nC(*_acc) = v; }') + ans <- 0.0 + cppLiteral('{ auto _acc2 = data->access("x"); ans = as_nC(*_acc2)().sum(); }') + return(ans) + returnType(numericScalar) + } + ) + ) + ) + for(mode in c("non_pkg", "pkg")) { + package <- mode == "pkg" + comp <- nCompile(ncAcc, ncOps, package = package) + nco <- comp$ncOps$new() + + # same scalar: write [10,20,30], read sum = 60 + expect_equal(nco$lhs_same(c(10.0, 20.0, 30.0)), 60.0) + + # cross scalar: write int [10,20,30] into double x, read sum = 60 + expect_equal(nco$lhs_xscalar(c(10L, 20L, 30L)), 60.0) + + rm(nco); gc() + } }) From b7948289c3f748e64c59b2ec1c282542d53779f9 Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 2 Jun 2026 09:48:32 -0700 Subject: [PATCH 4/4] Add CastSTM class in StridedTensorMap.h for RHS cross-scalar `as` followed by indexing or ops --- nCompiler/R/compile_aaa_operatorLists.R | 3 + nCompiler/R/compile_eigenization.R | 2 +- nCompiler/R/compile_generateCpp.R | 2 +- .../nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h | 5 +- .../nCompiler/ET_ext/StridedTensorMap.h | 157 ++++++++++++++++-- .../tests/testthat/specificOp_tests/test-as.R | 20 +-- 6 files changed, 159 insertions(+), 30 deletions(-) diff --git a/nCompiler/R/compile_aaa_operatorLists.R b/nCompiler/R/compile_aaa_operatorLists.R index 48a7677b..eccfdf3f 100644 --- a/nCompiler/R/compile_aaa_operatorLists.R +++ b/nCompiler/R/compile_aaa_operatorLists.R @@ -237,6 +237,9 @@ assignOperatorDef( ) assignOperatorDef( + # Note that nAs<- is supported but does not need + # separate assignment op handlers. Hence + # we do not have useAssignOp = TRUE. 'nAs', list( matchDef = function(object, type) {}, diff --git a/nCompiler/R/compile_eigenization.R b/nCompiler/R/compile_eigenization.R index f9c07e0c..85853a36 100644 --- a/nCompiler/R/compile_eigenization.R +++ b/nCompiler/R/compile_eigenization.R @@ -936,7 +936,7 @@ nCompiler:::inEigenizeEnv( # Either we're indexing a vector and we keep '[' in the AST, or we're # indexing a non-vector object and we use 'index(' instead. # TODO: if (code$args[[1]]$type$nDim == 0) - if (code$args[[1]]$type$nDim == 1 && isTRUE(code$args[[1]]$isName)) code$name <- 'index[' + if (code$args[[1]]$type$nDim == 1 && isTRUE(code$args[[1]]$isName) && !isTRUE(code$args[[1]]$type$isBlockRef)) code$name <- 'index[' else code$name <- 'index(' ## Enforce C++ type long for all indices using static_cast(index_expr) ## We see inconsistent C++ compiler behavior around casting a double index diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index d891b43d..da5a253e 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -174,7 +174,7 @@ inGenCppEnv( inGenCppEnv( Assign <- function(code, symTab) { orig_name <- code$name - code$name <- ' = ' + code$name <- '=' res <- MidOperator(code, symTab) code$name <- orig_name res diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h index 0222d849..58d7407b 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h @@ -3,6 +3,7 @@ #include #include +#include "../../ET_ext/StridedTensorMap.h" // --------------------------------------------------------------------------- // All as_nC<>() calls return a proxy. Every proxy exposes operator()() to @@ -50,7 +51,9 @@ class RHSCastProxy { explicit RHSCastProxy(ViewType view) : view_(std::move(view)) {} RHSCastProxy(const RHSCastProxy&) = delete; RHSCastProxy& operator=(const RHSCastProxy&) = delete; - auto operator()() { return view_.template cast(); } + // Returns a CastSTM — a proper Eigen expression that casts elements on read. + // Directly supports operator()(index), assignment to Tensor<>, and all Eigen ops. + Eigen::CastSTM operator()() { return Eigen::CastSTM(view_); } }; // CastingProxy diff --git a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h index a58da51f..cee0601a 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h @@ -141,8 +141,8 @@ namespace Eigen { #endif } - // const-ref and rvalue-ref overloads so temporary tensors/maps can be used as input. - // Only data() and dimensions() are needed, so this is safe: m_data outlives the temp. + // const-ref overload so temporaries and const tensors/maps can be used as input. + // Only data() and dimensions() are needed; m_data points to the source data, which outlives the temp. template EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(const InputType &inputTensor) : m_data(const_cast(inputTensor.data())) @@ -154,17 +154,6 @@ namespace Eigen { m_stopIndices); } - template - EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(InputType &&inputTensor) - : m_data(inputTensor.data()) - { - createSubTensorInfo(inputTensor.dimensions(), - m_dimensions, - m_strides, - m_startIndices, - m_stopIndices); - } - template EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(InputType &inputTensor, const Eigen::array &ss) @@ -657,7 +646,8 @@ template struct MakeStridedTensorMap { template struct MakeOutputType { - typedef typename EigenInputType::Scalar Scalar; + typedef typename std::remove_reference::type EigenBaseType; + typedef typename EigenBaseType::Scalar Scalar; typedef Tensor EigenOutputType; typedef StridedTensorMap< EigenOutputType > type; }; @@ -720,6 +710,145 @@ struct TensorEvaluator< StridedTensorMap +// +// A read-only Eigen tensor expression that wraps a SourceSTM and casts its +// elements to TargetScalar at read time. No allocation; coeff(i) evaluates +// to static_cast(source_evaluator.coeff(i)). +// +// Returned by RHSCastProxy::operator()() for cross-scalar as_nC<> calls, +// making the result directly usable in Eigen ops and scalar indexing with +// the same uniform as_nC(x)() interface. +// +// SourceSTM is stored by value (cheap: pointer + small index arrays) to +// avoid lifetime issues when wrapping a proxy member. +// --------------------------------------------------------------------------- + +// Forward declaration required before the traits specialisation. +template class CastSTM; + +namespace internal { + template + struct traits> { + typedef TargetScalar Scalar; + typedef typename traits::StorageKind StorageKind; + typedef typename traits::Index Index; + static const int NumDimensions = traits::NumDimensions; + static const int Layout = traits::Layout; + enum { Flags = 0 }; + // PointerType: TypeConversion converts the source pointer's element type to + // TargetScalar*, matching the pattern used by TensorConversionOp. + typedef typename TypeConversion::PointerType>::type PointerType; + }; + + // eval: keep as a const reference (the expression is cheap to hold by reference). + template + struct eval, Eigen::Dense> { + typedef const CastSTM& type; + }; + + // nested: store by value when nested inside another expression (avoids dangling + // reference when the CastSTM is a temporary returned from RHSCastProxy::operator()()). + template + struct nested, 1, + typename eval>::type> { + typedef CastSTM type; + }; +} // namespace internal + +template +class CastSTM : public TensorBase, ReadOnlyAccessors> +{ +public: + typedef typename internal::traits::Scalar Scalar; + typedef typename internal::traits::StorageKind StorageKind; + typedef typename internal::traits::Index Index; + typedef typename internal::nested::type Nested; + typedef Scalar CoeffReturnType; + typedef typename NumTraits::Real RealScalar; + typedef typename SourceSTM::Dimensions Dimensions; + static const int NumDimensions = SourceSTM::NumDimensions; + + EIGEN_DEVICE_FUNC explicit CastSTM(const SourceSTM& src) : src_(src) {} + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + const Dimensions& dimensions() const { return src_.dimensions(); } + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + const SourceSTM& source() const { return src_; } + + // Element access — delegates cast to SourceSTM's operator(), which handles strides. + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + TargetScalar operator()(Index i) const { + return static_cast(src_(i)); + } + + template + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + TargetScalar operator()(Index firstIndex, Index secondIndex, IndexTypes... otherIndices) const { + return static_cast(src_(firstIndex, secondIndex, otherIndices...)); + } + +private: + SourceSTM src_; // stored by value — cheap and avoids proxy-member lifetime issues +}; + +template +struct TensorEvaluator, Device> +{ + typedef CastSTM XprType; + typedef typename XprType::Dimensions Dimensions; + typedef TargetScalar Scalar; + typedef TargetScalar CoeffReturnType; + typedef typename PacketType::type PacketReturnType; + typedef typename XprType::Index Index; + + enum { + IsAligned = false, + PacketAccess = false, + BlockAccess = false, + PreferBlockAccess = false, + Layout = TensorEvaluator::Layout, + RawAccess = false + }; + + typedef internal::TensorBlockNotImplemented TensorBlock; + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + TensorEvaluator(const XprType& op, const Device& device) + : src_eval_(op.source(), device) {} + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + const Dimensions& dimensions() const { return src_eval_.dimensions(); } + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + bool evalSubExprsIfNeeded(CoeffReturnType*) { + src_eval_.evalSubExprsIfNeeded(nullptr); + return true; + } + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + void cleanup() { src_eval_.cleanup(); } + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + CoeffReturnType coeff(Index index) const { + return static_cast(src_eval_.coeff(index)); + } + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + TensorOpCost costPerCoeff(bool vectorized) const { + return src_eval_.costPerCoeff(vectorized); + } + + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE + Scalar* data() const { return nullptr; } + +private: + TensorEvaluator src_eval_; +}; + } // end namespace Eigen #endif // EIGEN_CXX11_TENSOR_TENSOR_MAP_H diff --git a/nCompiler/tests/testthat/specificOp_tests/test-as.R b/nCompiler/tests/testthat/specificOp_tests/test-as.R index 5bdeafbf..abff91de 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-as.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-as.R @@ -415,12 +415,6 @@ test_that("as(): RHS scalar indexing same-scalar (all-singleton)", { } }) -foo <- nFunction( - fun=function(x = 'numericVector') {y <- integer(length = 5); y <- x; return(y); returnType('integerVector')} -) -cfoo <- nCompile(foo) -cfoo(c(1.2, 2.3)) - # RHS scalar result — cross scalar ----------------------------------------------- test_that("as(): RHS scalar indexing cross-scalar (double→integer)", { @@ -656,7 +650,7 @@ test_that("as(): ETaccessorBase RHS paths (same-scalar, cross-scalar sum and ele data <- ncAcc$new() data$x <- v ans <- 0.0 - cppLiteral('{ auto _acc = data->access("x"); ans = as_nC(*_acc)().sum(); }') + cppLiteral('{ auto _acc = data->access("x"); flex_(ans) = as_nC(*_acc)().sum(); }') return(ans) returnType(numericScalar) } @@ -667,7 +661,7 @@ test_that("as(): ETaccessorBase RHS paths (same-scalar, cross-scalar sum and ele data <- ncAcc$new() data$x <- v ans <- 0L - cppLiteral('{ auto _acc = data->access("x"); ans = as_nC(*_acc)().sum(); }') + cppLiteral('{ auto _acc = data->access("x"); flex_(ans) = as_nC(*_acc)().sum(); }') return(ans) returnType(integerScalar) } @@ -678,7 +672,7 @@ test_that("as(): ETaccessorBase RHS paths (same-scalar, cross-scalar sum and ele data <- ncAcc$new() data$x <- v ans <- 0L - cppLiteral('{ auto _acc = data->access("x"); ans = as_nC(*_acc)()(i - 1); }') + cppLiteral('{ auto _acc = data->access("x"); flex_(ans) = as_nC(*_acc)()(i - 1); }') return(ans) returnType(integerScalar) } @@ -714,9 +708,9 @@ test_that("as(): ETaccessorBase LHS paths (same-scalar write-through, cross-scal function(v = numericVector) { data <- ncAcc$new() data$x <- numeric(length = length(v), value = 0) - cppLiteral('{ auto _acc = data->access("x"); as_nC(*_acc) = v; }') + cppLiteral('{ auto _acc = data->access("x"); as_nC(*_acc)() = v; }') ans <- 0.0 - cppLiteral('{ auto _acc2 = data->access("x"); ans = as_nC(*_acc2)().sum(); }') + cppLiteral('{ auto _acc2 = data->access("x"); flex_(ans) = as_nC(*_acc2)().sum(); }') return(ans) returnType(numericScalar) } @@ -726,9 +720,9 @@ test_that("as(): ETaccessorBase LHS paths (same-scalar write-through, cross-scal function(v = integerVector) { data <- ncAcc$new() data$x <- numeric(length = length(v), value = 0) - cppLiteral('{ auto _acc = data->access("x"); as_nC(*_acc) = v; }') + cppLiteral('{ auto _acc = data->access("x"); as_nC(*_acc)() = v; }') ans <- 0.0 - cppLiteral('{ auto _acc2 = data->access("x"); ans = as_nC(*_acc2)().sum(); }') + cppLiteral('{ auto _acc2 = data->access("x"); flex_(ans) = as_nC(*_acc2)().sum(); }') return(ans) returnType(numericScalar) }