Skip to content

Commit da4444a

Browse files
perrydvperrydv
authored
Support for user-defined operator definitions (opDefs) (#87)
* Establish cachedOpInfo in code$auxEnv so that user-defined opDefs can occur at various levels. * move recurse_normalizeCalls after arg ordering and extracting compile-time args * tests and cleanup for user-defined opDefs
1 parent 3f640cc commit da4444a

11 files changed

Lines changed: 600 additions & 271 deletions

‎nCompiler/R/NF_InternalsClass.R‎

Lines changed: 3 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,8 @@ NF_InternalsClass <- R6::R6Class(
1515
isMethod = FALSE,
1616
uniqueName = character(),
1717
cpp_code_name = character(),
18-
## template = NULL, replaced with compileInfo$matchDef
18+
## template = NULL, replaced with default_matchDef
19+
default_matchDef = NULL,
1920
code = NULL,
2021
RcppPacket = NULL,
2122
Rwrapper = NULL,
@@ -96,13 +97,7 @@ NF_InternalsClass <- R6::R6Class(
9697
## in the "decoration" system. They could be put in "value" argument.
9798
## Either a named "value" or a ... is in all types.
9899

99-
## not used until much later
100-
if(is.null(self$compileInfo$opDef))
101-
self$compileInfo$opDef <- list()
102-
if(is.null(self$compileInfo$opDef$matchDef)) {
103-
self$compileInfo$opDef$matchDef <- Rarguments_2_function(arguments, body = quote({}))
104-
}
105-
# self$template <- Rarguments_2_function(arguments, body = quote({})) ## generateTemplate()
100+
self$default_matchDef <- Rarguments_2_function(arguments, body = quote({})) ## generateTemplate()
106101
returnTypeInfo <- nf_extractReturnType(code)
107102
returnTypeDecl <- returnTypeInfo$returnType
108103
if(is.null(returnTypeDecl)) {

‎nCompiler/R/NF_Utils.R‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -50,8 +50,9 @@ nGet <- function(name, where) {
5050
## switch where to be the generator's parent_env
5151
where <- where$parent_env
5252
}
53-
if(exists(name, envir = where, inherits = TRUE))
54-
get(name, envir = where, inherits = TRUE)
55-
else
56-
NULL
53+
get0(name, envir = where)
54+
# if(exists(name, envir = where, inherits = TRUE))
55+
# get(name, envir = where, inherits = TRUE)
56+
# else
57+
# NULL
5758
}

‎nCompiler/R/compile_aaa_operatorLists.R‎

Lines changed: 24 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -94,12 +94,19 @@ updateOperatorDef <- function(ops, field, subfield = NULL, val) {
9494
}
9595
}
9696

97+
getOperatorField <- function(opDef, field = NULL, subfield = NULL) {
98+
if (is.null(opDef)) return(NULL)
99+
if (is.null(field)) return(opDef)
100+
if (is.null(opDef[[field]])) return(NULL)
101+
if (is.null(subfield)) return(opDef[[field]])
102+
opDef[[field]][[subfield]]
103+
}
104+
97105
getOperatorDef <- function(op, field = NULL, subfield = NULL) {
98-
opInfo <- get0(op, envir=operatorDefUserEnv)
99-
# opInfo <- operatorDefEnv[[op]]
100-
if (is.null(opInfo) || is.null(field)) return(opInfo)
101-
if (is.null(opInfo[[field]]) || is.null(subfield)) return(opInfo[[field]])
102-
return(opInfo[[field]][[subfield]])
106+
opDef <- get0(op, envir=operatorDefUserEnv)
107+
# opDef <- operatorDefEnv[[op]]
108+
if(is.null(opDef)) return(NULL)
109+
getOperatorField(opDef, field, subfield)
103110
}
104111

105112
assignOperatorDef(
@@ -122,7 +129,7 @@ assignOperatorDef(
122129
)
123130

124131
assignOperatorDef(
125-
'NFCALL_', # This is used for non-method nFunctions in normalizeCalls and for any (including method) nFunctions after normalizeCalls
132+
'nFunction_default', # This is used for non-method nFunctions in normalizeCalls and for any (including method) nFunctions after normalizeCalls
126133
list(
127134
labelAbstractTypes = list(
128135
handler = 'nFunction_or_method_call'),
@@ -133,17 +140,17 @@ assignOperatorDef(
133140
)
134141
)
135142

136-
assignOperatorDef(
137-
'NCMETHOD_', # This is a transient label that only exists within normalizeCalls
138-
list(
139-
## labelAbstractTypes = list(
140-
## handler = 'nFunction_or_method_call'),
141-
normalizeCalls = list(
142-
handler = 'nFunction_or_method_call')#, # becomes NFCALL_
143-
## cppOutput = list(
144-
## handler = 'Generic_nFunction')
145-
)
146-
)
143+
# assignOperatorDef(
144+
# 'NCMETHOD_', # This is a transient label that only exists within normalizeCalls
145+
# list(
146+
# ## labelAbstractTypes = list(
147+
# ## handler = 'nFunction_or_method_call'),
148+
# normalizeCalls = list(
149+
# handler = 'nFunction_or_method_call')#, # becomes NFCALL_
150+
# ## cppOutput = list(
151+
# ## handler = 'Generic_nFunction')
152+
# )
153+
# )
147154

148155
assignOperatorDef(
149156
c('dim'),

‎nCompiler/R/compile_eigenization.R‎

Lines changed: 27 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -73,21 +73,27 @@ compile_eigenize <- function(code,
7373
return(invisible(NULL))
7474
}
7575

76-
handlingInfo <- getOperatorDef(code$name, "eigenImpl")
76+
opInfo <- check_cachedOpInfo(code, where=auxEnv$where, update=TRUE)
77+
handlingInfo <- getOperatorField(opInfo$opDef, "eigenImpl")
78+
# handlingInfo <- getOperatorDef(code$name, "eigenImpl")
7779
# operatorDefEnv[[code$name]]
7880
# if(!is.null(opInfo)) {
7981
# handlingInfo <- opInfo[["eigenImpl"]]
8082
if(!is.null(handlingInfo)) {
8183
beforeHandler <- handlingInfo[['beforeHandler']]
8284
if(!is.null(beforeHandler)) {
83-
setupExprs <- c(setupExprs,
84-
eval(call(beforeHandler,
85-
code,
86-
symTab,
87-
auxEnv,
88-
workEnv,
89-
handlingInfo),
90-
envir = eigenizeEnv))
85+
if(is.function(beforeHandler))
86+
setupExprs <- c(setupExprs,
87+
beforeHandler(code, symTab, auxEnv, workEnv, handlingInfo))
88+
else
89+
setupExprs <- c(setupExprs,
90+
eval(call(beforeHandler,
91+
code,
92+
symTab,
93+
auxEnv,
94+
workEnv,
95+
handlingInfo),
96+
envir = eigenizeEnv))
9197
# return(if(length(setupExprs) == 0) NULL else setupExprs)
9298
}
9399
}
@@ -110,14 +116,18 @@ compile_eigenize <- function(code,
110116
if(!is.null(handlingInfo)) {
111117
handler <- handlingInfo[['handler']]
112118
if(!is.null(handler)) {
113-
setupExprs <- c(setupExprs,
114-
eval(call(handler,
115-
code,
116-
symTab,
117-
auxEnv,
118-
workEnv,
119-
handlingInfo),
120-
envir = eigenizeEnv))
119+
if(is.function(handler))
120+
setupExprs <- c(setupExprs,
121+
handler(code, symTab, auxEnv, workEnv, handlingInfo))
122+
else
123+
setupExprs <- c(setupExprs,
124+
eval(call(handler,
125+
code,
126+
symTab,
127+
auxEnv,
128+
workEnv,
129+
handlingInfo),
130+
envir = eigenizeEnv))
121131
}
122132
}
123133
# }

‎nCompiler/R/compile_generateCpp.R‎

Lines changed: 21 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -85,7 +85,18 @@ compile_generateCpp <- function(code,
8585
ans[[length(code$args) + 2]] <- paste0(indent, '}')
8686
return(ans)
8787
}
88-
handler <- getOperatorDef(code$name, "cppOutput", "handler")
88+
# All calls must have valid opInfo or be a core DSL operator
89+
# This compiler stage is called from cppDefs' generate() methods,
90+
# so where$auxEnv is not available.
91+
# This means that any penultimate compiler stages that changed the
92+
# call name to something non-core (and hence potentially the handler)
93+
# must update the cachedOpInfo.
94+
# or we must add a final pass to do so.
95+
# An example is changes made in eigenization, such as inserting `index[`.
96+
# This is a core operator so it will be found in the check_cachedOpInfo with update=TRUE.
97+
opInfo <- check_cachedOpInfo(code, where=baseenv(), update=TRUE, allowFail = TRUE)
98+
handler <- getOperatorField(opInfo$opDef, "cppOutput", "handler")
99+
# handler <- getOperatorDef(code$name, "cppOutput", "handler")
89100
# opInfo <- operatorDefEnv[[code$name]]
90101
# if(!is.null(opInfo)) {
91102
# handlingInfo <- opInfo[["cppOutput"]]
@@ -94,10 +105,13 @@ compile_generateCpp <- function(code,
94105
if(!is.null(handler)) {
95106
if (logging)
96107
appendToLog(paste('Calling handler', handler, 'for', code$name))
97-
res <- eval(call(handler,
98-
code,
99-
symTab),
100-
envir = genCppEnv)
108+
if(is.function(handler))
109+
res <- handler(code, symTab)
110+
else
111+
res <- eval(call(handler,
112+
code,
113+
symTab),
114+
envir = genCppEnv)
101115
if (logging) {
102116
appendToLog(paste('Finished handling', handler, 'for',
103117
code$name, 'with result:'))
@@ -165,10 +179,9 @@ inGenCppEnv(
165179

166180
inGenCppEnv(
167181
Generic_nFunction <- function(code, symTab) {
168-
innerCode <- code$args[['call']]
169-
cpp_code_name <- code$aux$cpp_code_name
182+
cpp_code_name <- code$aux$cachedOpInfo$obj_internals$cpp_code_name
170183
paste0(cpp_code_name,
171-
'(', paste0(unlist(lapply(innerCode$args,
184+
'(', paste0(unlist(lapply(code$args,
172185
compile_generateCpp,
173186
symTab,
174187
asArg = TRUE) ),

‎nCompiler/R/compile_labelAbstractTypes.R‎

Lines changed: 13 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -100,7 +100,10 @@ compile_labelAbstractTypes <- function(code,
100100
return(invisible(NULL))
101101
}
102102

103-
handlingInfo <- getOperatorDef(code$name, "labelAbstractTypes")
103+
opInfo <- check_cachedOpInfo(code, where=auxEnv$where, update=TRUE)
104+
handlingInfo <- getOperatorField(opInfo$opDef, "labelAbstractTypes")
105+
106+
# handlingInfo <- getOperatorDef(code$name, "labelAbstractTypes")
104107
# opInfo <- operatorDefEnv[[code$name]]
105108
# if(!is.null(opInfo)) {
106109
# handlingInfo <- opInfo[["labelAbstractTypes"]]
@@ -109,8 +112,11 @@ compile_labelAbstractTypes <- function(code,
109112
if(!is.null(handler)) {
110113
if (logging)
111114
appendToLog(paste('Calling handler', handler, 'for', code$name))
112-
ans <- eval(call(handler, code, symTab, auxEnv, handlingInfo),
113-
envir = labelAbstractTypesEnv)
115+
if(is.function(handler))
116+
ans <- handler(code, symTab, auxEnv, handlingInfo)
117+
else
118+
ans <- eval(call(handler, code, symTab, auxEnv, handlingInfo),
119+
envir = labelAbstractTypesEnv)
114120
nErrorEnv$stateInfo <- character()
115121
if (logging) {
116122
appendToLog(paste('Finished handling', handler, 'for', code$name))
@@ -406,24 +412,11 @@ inLabelAbstractTypesEnv(
406412
inLabelAbstractTypesEnv(
407413
nFunction_or_method_call <-
408414
function(code, symTab, auxEnv, handlingInfo) {
409-
# We have code = NFCALL_(foo(x, y))
410-
# innerCall if foo(x,y)
411-
# We'll set innerCall$type to symbolNF
412-
# and we'll set code$type to the returnType of foo(x, y)
413-
innerCall <- code$args[['call']]
414-
if(is.null(innerCall))
415-
stop(
416-
exprClassProcessingErrorMsg(
417-
code, paste('In nFunction_or_method_call: the nFunction (or method) ',
418-
code$name,
419-
' has NULL content.')
420-
), call. = FALSE
421-
)
422-
inserts <- recurse_labelAbstractTypes(innerCall, symTab, auxEnv,
415+
inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv,
423416
handlingInfo)
424-
obj_internals <- code$aux$obj_internals
425-
nFunctionName <- code$aux$nFunctionName
426-
innerCall$type <- symbolNF$new(name = nFunctionName)
417+
obj_internals <- code$aux$cachedOpInfo$obj_internals
418+
# nFunctionName <- obj_internals$nFunctionName
419+
# code$aux$symbolNF <- symbolNF$new(name = nFunctionName)
427420
returnSym <- obj_internals$returnSym
428421
if(is.null(returnSym))
429422
stop(
@@ -435,24 +428,6 @@ inLabelAbstractTypesEnv(
435428
)
436429
code$type <- returnSym$clone() ## Not sure if a clone is needed, but it seems safer to make one.
437430
inserts
438-
439-
# useArgs <- c(FALSE, rep(TRUE, length(code$args)-1))
440-
# inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv,
441-
# handlingInfo, useArgs)
442-
# obj_internals <- code$args[[1]]$aux$obj_internals
443-
# nFunctionName <- code$args[[1]]$aux$nFunctionName
444-
# code$args[[1]]$type <- symbolNF$new(name = nFunctionName)
445-
# returnSym <- obj_internals$returnSym
446-
# if(is.null(returnSym))
447-
# stop(
448-
# exprClassProcessingErrorMsg(
449-
# code, paste('In nFunction_or_method_call: the nFunction (or method) ',
450-
# code$name,
451-
# ' does not have a valid returnType.')
452-
# ), call. = FALSE
453-
# )
454-
# code$type <- returnSym$clone() ## Not sure if a clone is needed, but it seems safer to make one.
455-
# invisible(NULL)
456431
}
457432
)
458433

0 commit comments

Comments
 (0)