Fix and extend parallel_reduce functionality

nCompiler/R/Rexecution.R

@@ -14,6 +14,18 @@ parallel_for <- function(index, range, body, ...) {
 
 #' @export
 parallel_reduce <- function(f, x, init, ...) {
+  if(is.character(f)) {  # Not clear how to convert to char ...
+    operatorDef <- operatorDefEnv[[f]]
+    if(!is.null(operatorDef) && is.null(operatorDef$reduction))
+        stop("`", f, "` is not a valid reduction function/operator")
+  }
+  if(missing(init)) {
+    if(!is.character(f) || is.null(operatorDef) || is.null(operatorDef$reduction))
+      stop("`init` argument is missing and no default value provided for reduction function/operator")
+    init <- operatorDef$reduction
+  }
+  if(identical(f, "pairmin")) f <- "pmin"
+  if(identical(f, "pairmax")) f <- "pmax"
   Reduce(f, x, init)
 }
 
@@ -416,4 +428,4 @@ nVar <- function(x) {
 #' @export
 nSd <- function(x) { 
   sd(x) 
-}
+}

nCompiler/R/compile_aaa_operatorLists.R

@@ -473,9 +473,11 @@ assignOperatorDef(
           )
         ),
         cppOutput = list(
-          handler = 'BinaryOrUnary')
+          handler = 'BinaryOrUnary'),
+        reduction = 0
     )
 )
+updateOperatorDef('-', 'reduction', val = NULL)
 
 assignOperatorDef(
   c('inprod'),
@@ -522,11 +524,13 @@ assignOperatorDef(
     labelAbstractTypes = list(
         handler = 'BinaryCwise',
         returnTypeCode = returnTypeCodes$promoteNoLogical),
-    cppOutput = list()
+    cppOutput = list(),
+    reduction = Inf
   )
 )
 updateOperatorDef('pairmax', 'cppOutput', 'cppString', 'std::max')
 updateOperatorDef('pairmin', 'cppOutput', 'cppString', 'std::min')
+updateOperatorDef('pairmax', 'reduction', val = -Inf)
 
 assignOperatorDef(
   c('pmin', 'pmax'),
@@ -902,7 +906,8 @@ assignOperatorDef(
       )
     ),
     cppOutput = list(
-      handler = 'MidOperator')
+      handler = 'MidOperator'),
+    reduction = 1
   )
 )
 

nCompiler/R/compile_eigenization.R

@@ -5,7 +5,8 @@
 eigenizeUseArgs <- c(
     list(
         setWhich = c(FALSE, TRUE),
-        setRepVectorTimes = c(FALSE, TRUE, TRUE)
+        setRepVectorTimes = c(FALSE, TRUE, TRUE),
+        parallel_reduce = c(FALSE, TRUE, TRUE)
         ))
 
 eigenizeEnv <- new.env()

nCompiler/R/compile_finalTransformations.R

@@ -128,7 +128,7 @@ inFinalTransformationsEnv(
     setArg(colon, 1, exprClass$new(name = 1, isLiteral = TRUE, isCall = FALSE,
                                    isName = FALSE, isAssign = FALSE))
     size_expr <- setArg(
-      colon, 2, nParse(paste0('cppLiteral("', vector_arg$name, '.size();")')))
+      colon, 2, nParse(paste0('cppLiteral("', vector_arg$name, '.size()")')))
     ## make the vector an argument of the reduce op and index it
     reduce_op <- code$args[[3]]
     setArg(reduce_op, 1, copyExprClass(vector_arg))

nCompiler/R/compile_generateCpp.R

@@ -209,7 +209,7 @@ inGenCppEnv(
 )
 
 inGenCppEnv(
-  MidOperator <- function(code, symTab) {
+    MidOperator <- function(code, symTab) {
     if(length(code$args) != 2) stop('Error: expecting 2 arguments for operator ',code$name)
     if(is.null(code$caller)) useParens <- FALSE
     else {

nCompiler/R/compile_labelAbstractTypes.R

@@ -763,12 +763,33 @@ inLabelAbstractTypesEnv(
 
 inLabelAbstractTypesEnv(
   ParallelReduce <- function(code, symTab, auxEnv, handlingInfo) {
-    if (length(code$args) != 3)
+    if(is.null(symTab$parentST))   #  TODO: this seems kludgey and perhaps should be done at a different processing stage.
+      stop(exprClassProcessingErrorMsg(
+        code,
+        paste0('In labelAbstractTypes handler ParallelReduce: ',
+               'parallel_reduce must be used in a method of an nClass, not in a stand-alone nFunction.')),
+        call. = FALSE)          
+    operatorDef <- operatorDefEnv[[code$args[[1]]$name]]
+    if (!is.null(operatorDef) && is.null(operatorDef$reduction))   # Check for validity only for our operators.
+    # TODO: perhaps this should just be a warning.        
+      stop(exprClassProcessingErrorMsg(
+        code,
+        paste0('In labelAbstractTypes handler ParallelReduce: ',
+               'function/operator `', code$args[[1]]$name, '` is not a valid reduction function/operator.')),
+        call. = FALSE)
+    if(length(code$args) == 2 && !is.null(operatorDef$reduction))
+      setArg(code, 3, nParse(operatorDef$reduction))
+    if (length(code$args) != 3) 
       stop(exprClassProcessingErrorMsg(
         code,
         paste('In labelAbstractTypes handler ParallelReduce:',
               'expected 3 arguments but got', length(code$args))),
         call. = FALSE)
+    if(code$args[[1]]$isName) {  ## Handle reduction function as function not char.        
+      code$args[[1]]$isName <- FALSE
+      code$args[[1]]$isLiteral <- TRUE
+      code$args[[1]]$Rexpr <- deparse(code$args[[1]]$Rexpr)
+    }
     ## process the initial value
     inserts <- compile_labelAbstractTypes(code$args[[3]], symTab, auxEnv)
     if (code$args[[3]]$type$nDim != 0)
@@ -778,12 +799,14 @@ inLabelAbstractTypesEnv(
               'initial value for parallel_reduce should be scalar but got',
               ' nDim = ', code$args[[3]]$type$nDim)),
         call. = FALSE)
-    if (isFALSE(code$args[[3]]$isLiteral))
-      stop(exprClassProcessingErrorMsg(
-        code,
-        paste('In labelAbstractTypes handler ParallelReduce:',
-              'initial value for parallel_reduce must be a literal')),
-        call. = FALSE)
+    if (isFALSE(code$args[[3]]$isLiteral)) {
+      if(!(code$args[[3]]$name == "-" && isTRUE(code$args[[3]]$args[[1]]$isLiteral)))  # Handle negative init.
+        stop(exprClassProcessingErrorMsg(
+          code,
+          paste('In labelAbstractTypes handler ParallelReduce:',
+                'initial value for parallel_reduce must be a literal value, not a variable or expression')),
+          call. = FALSE)
+    }
     ## process the reduce operator
     if (isTRUE(code$args[[1]]$isLiteral)) {
       if (!is.character(code$args[[1]]$name))
@@ -796,11 +819,11 @@ inLabelAbstractTypesEnv(
       code$args[[1]]$isLiteral <- FALSE
       code$args[[1]]$isCall <- TRUE
     }
-    ## give reduce operator the same return type as the initial value
+    ## give reduce operator the same return type as the input vector.
     ## TODO: Maybe symbolNF is the right type for the reduction op.
     code$args[[1]]$type <-
       symbolBasic$new(name = code$args[[1]]$name,
-                      nDim = 0, type = code$args[[3]]$type$type)
+                      nDim = 0, type = code$args[[2]]$type$type)
     ## finish by processing the vector arg
     inserts <- c(inserts, compile_labelAbstractTypes(code$args[[2]], symTab, auxEnv))
     if (code$args[[2]]$type$nDim != 1)
@@ -811,7 +834,7 @@ inLabelAbstractTypesEnv(
               code$args[[2]]$type$nDim)),
         call. = FALSE)
     code$type <- symbolBasic$new(name = code$name, nDim = 0,
-                                 type = code$args[[3]]$type$type)
+                                 type = code$args[[2]]$type$type)
     return(if (length(inserts) == 0) invisible(NULL) else inserts)
   }
 )

nCompiler/R/compile_normalizeCalls.R

@@ -1,3 +1,9 @@
+## Special cases placed here by analogy with `eigenizeUseArgs`,
+## but perhaps should be in handler list.
+normalizeCallsFunctionArgs <- list(
+    parallel_reduce = 1
+)
+
 normalizeCallsEnv <- new.env()
 normalizeCallsEnv$.debug <- FALSE
 
@@ -50,7 +56,10 @@ compile_normalizeCalls <- function(code,
     # What gets cached in the aux of the exprClass for the call:
     #   cachedOpInfo = list(opDef, name, obj_internals, case)
     #   We defer: uniqueName, cpp_code_name
-    cachedOpInfo <- update_cachedOpInfo(code, auxEnv$where)
+    fxnArg <- normalizeCallsFunctionArgs[[code$name]]
+    if(!is.null(fxnArg)) {  # Handle arguments that are functions (`parallel_reduce`).
+      cachedOpInfo <- update_cachedOpInfo(code$args[[fxnArg]], auxEnv$where)
+    } else cachedOpInfo <- update_cachedOpInfo(code, auxEnv$where)
     if(cachedOpInfo$case == "nFunction") {
       uniqueName <- cachedOpInfo$obj_internals$uniqueName2
       if(length(uniqueName)==0)
@@ -65,17 +74,19 @@ compile_normalizeCalls <- function(code,
         ## but we do not as a way to avoid having many references to R6 objects
         ## in a blind attempt to facilitate garbage collection based on past experience.
         ## Instead, we provide what is needed to look up the nFunction again later.
-        auxEnv$needed_nFunctions[[uniqueName]] <- list(code$name, auxEnv$where)
+        auxEnv$needed_nFunctions[[uniqueName]] <- list(code$args[[fxnArg]]$name, auxEnv$where)
       }
     }
 
-    opDef <- cachedOpInfo$opDef
-    matchDef <- opDef[["matchDef"]]
-    if(is.null(matchDef))
-      matchDef <- cachedOpInfo$obj_internals$default_matchDef
-    if(!is.null(matchDef)) {
-      exprClass_put_args_in_order(matchDef, code, opDef$compileArgs)
-      # code <- replaceArgInCaller(code, matched_code)
+    if(is.null(fxnArg)) {
+      opDef <- cachedOpInfo$opDef
+      matchDef <- opDef[["matchDef"]]
+      if(is.null(matchDef))
+        matchDef <- cachedOpInfo$obj_internals$default_matchDef
+      if(!is.null(matchDef)) {
+        exprClass_put_args_in_order(matchDef, code, opDef$compileArgs)
+        # code <- replaceArgInCaller(code, matched_code)
+      }
     }
     normalizeCallsEnv$recurse_normalizeCalls(code, symTab, auxEnv, handlingInfo)
   }

nCompiler/R/cppDefs_TBB.R

@@ -1,4 +1,3 @@
-# not working
 ## cppDefs for parallel loop bodies for TBB
 
 cppParallelBodyClass <- R6::R6Class(
@@ -256,8 +255,9 @@ cppParallelReduceBodyClass_init_impl <- function(cppDef,
   vector_name <- orig_caller$args[[4]] ## should be a string
   initializerList <- list()
   initializerList[[1]] <- nParse(
-    substitute(X(X_), list(X = as.name(value_name),
-                           X_ = as.name(init_arg$name))))
+    substitute(X(X_), list(X = as.name(value_name))))
+  ## Need to directly parse the init value to handle various numeric cases, e.g., `Inf`.
+  setArg(initializerList[[1]], 1, init_arg) 
   initializerList[[2]] <- nParse(
     substitute(X(X_), list(X = as.name(vector_name),
                            X_ = as.name(paste0('parent.', vector_name)))))
@@ -278,14 +278,17 @@ cppParallelReduceBodyClass_init_impl <- function(cppDef,
                                             ref = TRUE,
                                             const = TRUE))
   ## make the reduce code
-  reduce_op <- exprClass$new(name = loop_body$args[[2]]$name, isCall = TRUE,
-                             isName = FALSE, isAssign = FALSE,
+  ## `aux` needed so that user-defined reduction functions will be replaced with `cpp_code_name`. 
+  reduce_op <- exprClass$new(name = loop_body$args[[2]]$name, aux = loop_body$args[[2]]$aux,
+                             isCall = TRUE, isName = FALSE, isAssign = FALSE,
                              isLiteral = FALSE)
   setArg(reduce_op, 1, copyExprClass(value_expr))
-  setArg(reduce_op, 2, nParse(paste0('cppLiteral("target.', value_name, ';")')))
+  setArg(reduce_op, 2, nParse(paste0('cppLiteral("target.', value_name, '")')))
   join_code <- newAssignmentExpression()
   setArg(join_code, 1, copyExprClass(value_expr))
   setArg(join_code, 2, reduce_op)
+  ## Put code in {} so handled by full processing later, in particular adding ending `;`.  
+  join_code <- newBracketExpr(list(join_code))  
   ## create the join cppFunctionClass definition
   join_body <- cppCodeBlockClass$new(code = join_code,
                                      ## TODO: any symbols ever needed?

nCompiler/R/cppDefs_nClass.R

@@ -11,13 +11,13 @@ nClassBaseClass_init_impl <- function(cppDef) {
   cppDef$Hpreamble <- pluginIncludes
   cppDef$Hpreamble <- c(cppDef$Hpreamble,
                         "#define NCOMPILER_USES_EIGEN",
-                        "// #define NCOMPILER_USES_TBB",
+                        "#define NCOMPILER_USES_TBB",
                         "#define NCOMPILER_USES_NLIST",
                         "#define USES_NCOMPILER")
   cppDef$CPPpreamble <- pluginIncludes
   cppDef$CPPpreamble <- c(cppDef$CPPpreamble,
                         "#define NCOMPILER_USES_EIGEN",
-                        "// #define NCOMPILER_USES_TBB",
+                        "#define NCOMPILER_USES_TBB",
                         "#define NCOMPILER_USES_NLIST",
                         "#define USES_NCOMPILER")
 

nCompiler/R/cppDefs_nFunction.R

@@ -8,7 +8,7 @@ cpp_nFunctionClass_init_impl <- function(cppDef) {
   cppDef$Hpreamble <- pluginIncludes
   cppDef$Hpreamble <- c(cppDef$Hpreamble,
                         "#define NCOMPILER_USES_EIGEN",
-                        "// #define NCOMPILER_USES_TBB",
+                        "#define NCOMPILER_USES_TBB",
                         "#define NCOMPILER_USES_NLIST",
                         "#define USES_NCOMPILER")
   ## handler nList in labelAbstractTypes does record in auxEnv if an
@@ -19,7 +19,7 @@ cpp_nFunctionClass_init_impl <- function(cppDef) {
   cppDef$CPPpreamble <- pluginIncludes
   cppDef$CPPpreamble <- c(cppDef$CPPpreamble,
                           "#define NCOMPILER_USES_EIGEN",
-                          "// #define NCOMPILER_USES_TBB",
+                          "#define NCOMPILER_USES_TBB",
                           "#define NCOMPILER_USES_NLIST",
                           "#define USES_NCOMPILER")
   cppDef$Hincludes <- c(cppDef$Hincludes)#,