struct node *mock_deffun(struct module *mod, const char *name) {
GSTART();
G0(foo, mod->body, DEFFUN,
G_IDENT(_name, name);
G(genargs, GENARGS);
G(funargs, FUNARGS,
G_IDENT(retval, "void"));
G(body, BLOCK));
return foo;
}
struct node *mock_deftype(struct module *mod, const char *name) {
GSTART();
G0(test, mod->body, DEFTYPE,
G_IDENT(_name, name);
G(genargs, GENARGS);
G(isalist, ISALIST));
return test;
}
static void process_reduction(expr_t* redexpr) {
statement_t* stmt;
int lineno;
char* filename;
statement_t* nextstmt;
expr_t* assignexpr;
expr_t* rhs;
expr_t* lhs;
int numdims = 0;
datatype_t* pdt;
char tempvarname[64];
symboltable_t* tempvar;
expr_t* tempexpr;
statement_t* assignstmt;
int complete;
expr_t* rhsreg;
expr_t* tempreg=NULL;
datatype_t* temparrdt;
expr_t* dstreg;
expr_t* srcreg;
expr_t* dstmask;
int dstmaskbit;
expr_t* srcmask;
int srcmaskbit;
int staticreg;
int try_using_dest_as_temp=1;
int using_dest_as_temp=0;
char* id;
expr_t* tmp;
statement_t* newstmt;
statement_t* laststmt;
int free=0;
stmt = T_STMT(redexpr);
lineno = T_LINENO(stmt);
filename = T_FILENAME(stmt);
nextstmt = T_NEXT(stmt);
assignexpr = T_EXPR(stmt);
if (!T_IS_ASSIGNOP(T_TYPE(assignexpr))) {
return;
}
/* if the assignment is +=, etc. we can't use the dest as the temp storage */
if (T_TYPE(assignexpr) != BIASSIGNMENT) {
try_using_dest_as_temp=0;
}
lhs = T_OPLS(assignexpr);
rhs = T_NEXT(lhs);
if (rhs != redexpr) {
INT_FATAL(stmt,"Unexpected placement of reduction within statement");
}
rhs = T_OPLS(rhs);
rhsreg = T_TYPEINFO_REG(rhs);
if (rhsreg == NULL) {
/* if rhsreg is NULL, either the expression is a scalar (which is
illegal and will be handled by typechecking), or it's an
indexed array of arrays which has not yet had its indices
inserted by a2nloops, and therefore evaluates as a scalar
array. In this latter case, we search deeply to try and find
something that tells the rank. */
numdims = expr_rank(rhs);
if (numdims == 0) {
free = expr_is_free(rhs);
if (!free) {
USR_FATAL_CONT(stmt,"Reduce of scalar expression");
return;
}
}
} else {
numdims = D_REG_NUM(T_TYPEINFO(rhsreg));
}
dstreg = RMSCurrentRegion();
dstmask = RMSCurrentMask(&dstmaskbit);
if (T_IDENT(dstreg) == pst_qreg[0]) { /* unresolved quote region */
if (free) {
T_IDENT(dstreg) = pst_free;
} else {
T_IDENT(dstreg) = pst_qreg[numdims];
}
}
/* save destination region away for later use at codegen time since we
will be playing games with scopes */
T_REGMASK2(redexpr) = T_REGION(build_reg_mask_scope(dstreg,NULL,0,NULL,
lineno,filename));
complete = (T_REGMASK(redexpr) == NULL);
if (complete) {
srcreg = dstreg;
srcmask = dstmask;
srcmaskbit = dstmaskbit;
dstreg = NULL;
tempreg = NULL;
} else {
RMSPushScope(T_REGMASK(redexpr));
if (!RMSLegalReduce(stmt,numdims)) {
RMSPopScope(T_REGMASK(redexpr));
return;
}
srcreg = RMSCurrentRegion();
srcmask = RMSCurrentMask(&srcmaskbit);
if (T_IDENT(srcreg) == pst_qreg[0]) { /* unresolved quote region */
T_IDENT(srcreg) = pst_qreg[numdims];
}
/* build temp region */
tempreg = create_red_reg(numdims,dstreg,srcreg,lineno,filename,&staticreg);
RMSPopScope(T_REGMASK(redexpr));
}
pdt = T_TYPEINFO(lhs);
if (T_SUBTYPE(redexpr) != USER) {
pdt = ensure_good_scanred_type(pdt);
}
if ((try_using_dest_as_temp) && (tempreg == dstreg)) {
symboltable_t* lhsroot;
datatype_t* lhsensdt;
lhsroot = expr_find_root_pst(lhs);
lhsensdt = datatype_find_ensemble(S_DTYPE(lhsroot));
if ((tempreg == NULL && lhsensdt == NULL) ||
(tempreg != NULL && lhsensdt != NULL &&
expr_equal(D_ENS_REG(lhsensdt), tempreg) && /* must be size of tempreg */
expr_find_ensemble_root(lhs) == lhs)) { /* must be whole array access */
using_dest_as_temp = 1;
tempexpr = copy_expr(lhs);
}
}
if (!using_dest_as_temp) {
if (complete) {
/* build scalar (grid) temp */
sprintf(tempvarname,"_red_data%d",full_red_buff_num++);
tempvar = create_named_local_var(pdt,T_PARFCN(stmt),tempvarname);
} else {
/* build temp array */
sprintf(tempvarname, "_Red_data%d", part_red_buff_num++);
temparrdt = build_ensemble_type(pdt,tempreg,0,1,lineno,filename);
if (staticreg) { /* make global if we can */
tempvar = LU_INS(tempvarname);
S_DTYPE(tempvar) = temparrdt;
} else { /* otherwise, make it local */
tempvar = create_named_local_var(temparrdt,T_PARFCN(stmt),tempvarname);
S_SETUP(tempvar) = 0;
}
}
/* build expression for the reduction temp */
tempexpr = build_typed_0ary_op(VARIABLE,tempvar);
}
/* switch reduction argument, tag reduction's rank */
T_OPLS(redexpr) = tempexpr;
T_RED_RANK(redexpr) = numdims;
tempexpr = copy_expr(tempexpr);
if (!using_dest_as_temp) {
/* add on blank array references */
while (D_CLASS(pdt) == DT_ARRAY) {
tempexpr = build_typed_Nary_op(ARRAY_REF, tempexpr, NULL);
T_TYPEINFO_REG(tempexpr) = build_0ary_op(CONSTANT, pstGRID_SCALAR[numdims]);
pdt = D_ARR_TYPE(pdt);
}
}
/* build assignment to the reduction temp */
assignstmt = build_ident_expr(redexpr,pdt,tempexpr);
/* wrap a scope around it for partial reduction */
if (!complete) {
if (using_dest_as_temp) {
/* use dest region */
assignstmt = build_reg_mask_scope(dstreg,NULL,MASK_NONE,assignstmt,
lineno,filename);
/* assignstmt = build_mloop_statement(dstreg, assignstmt,
D_REG_NUM(T_TYPEINFO(dstreg)),
NULL, MASK_NONE, lineno, filename);*/
} else {
/* use temporary region that we created to describe internal temp */
genlist_t* newgls;
/* open region scope */
assignstmt = build_reg_mask_scope(tempreg,NULL,MASK_NONE,assignstmt,
lineno,filename);
/* assignstmt = build_mloop_statement(tempreg, assignstmt,
D_REG_NUM(T_TYPEINFO(tempreg)),
NULL, MASK_NONE, lineno, filename);*/
if (!staticreg) {
newgls = alloc_gen();
G_IDENT(newgls) = tempvar;
T_PRE(assignstmt) = newgls;
}
}
}
newstmt = assignstmt;
/*
dbg_gen_stmtls(stdout, newstmt);
printf("-------\n");
*/
/* setup temp reduction region */
if (!complete && !staticreg && !using_dest_as_temp) {
expr_t* fncall;
expr_t* argexpr;
expr_t* newarg;
argexpr = copy_expr(srcreg);
newarg = copy_expr(dstreg);
T_NEXT(newarg) = argexpr;
argexpr = newarg;
newarg = copy_expr(tempreg);
T_NEXT(newarg) = argexpr;
argexpr = newarg;
fncall = build_typed_Nary_op(FUNCTION,build_0ary_op(VARIABLE,
pstCalcRedReg),argexpr);
assignstmt = build_expr_statement(fncall,lineno,filename);
insertafter_stmt(newstmt,assignstmt);
newstmt = assignstmt;
/*
dbg_gen_stmtls(stdout, newstmt);
printf("-------\n");
*/
}
/* build local part of reduction */
tempexpr = copy_expr(tempexpr);
{
expr_t* tmp;
tmp = tempexpr;
while (tmp) {
T_FREE(tmp) = TRUE;
tmp = T_OPLS(tmp);
}
}
rhs = copy_exprls(rhs, T_PARENT(rhs));
if (T_SUBTYPE(redexpr) != USER) {
assignexpr = build_typed_binary_op(BIOP_GETS, rhs, tempexpr);
T_SUBTYPE(assignexpr) = T_SUBTYPE(redexpr);
}
else {
symboltable_t* pst;
tmp = rhs;
while (T_NEXT(tmp) != NULL) {
tmp = T_NEXT(tmp);
}
T_NEXT(tmp) = copy_expr(tempexpr);
id = get_function_name(T_IDENT(redexpr), rhs, 1);
if (id == NULL) {
USR_FATALX(lineno, filename, "Missing local function for user defined reduction");
}
assignexpr = build_typed_Nary_op(FUNCTION, build_0ary_op(VARIABLE, check_var(id)), rhs);
pst = lu(id);
if (pst != NULL) {
subclass sc;
symboltable_t* decls;
decls = T_DECL(S_FUN_BODY(pst));
while (decls != NULL && S_CLASS(decls) != S_PARAMETER) {
decls = S_SIBLING(decls);
}
while (decls != NULL) {
sc = S_PAR_CLASS(decls);
decls = S_SIBLING(decls);
while (decls != NULL && S_CLASS(decls) != S_PARAMETER) {
decls = S_SIBLING(decls);
}
}
if (sc == SC_IN || sc == SC_CONST) {
assignexpr = build_typed_binary_op(BIASSIGNMENT, assignexpr, tempexpr);
if (!(equiv_datatypes(S_FUN_TYPE(pst), T_TYPEINFO(tempexpr)))) {
USR_FATALX(lineno, filename, "local function for user defined reduction returns wrong type");
}
}
else {
if (S_CLASS(S_FUN_TYPE(pst)) != DT_VOID) {
USR_FATALX(lineno, filename, "by reference local function for user defined reduction must not return a value");
}
}
}
}
assignstmt = build_expr_statement(assignexpr,lineno,filename);
if (numdims != 0) { /* don't put mloop around free reduce */
/* assignstmt = build_mloop_statement(srcreg, assignstmt,
D_REG_NUM(T_TYPEINFO(srcreg)),
srcmask, srcmaskbit, lineno, filename);*/
}
insertbefore_stmt(newstmt, assignstmt);
/*
dbg_gen_stmtls(stdout, newstmt);
printf("-------\n");
*/
/* create actual reduction statement */
assignstmt = build_expr_statement(redexpr,lineno,filename);
insertbefore_stmt(newstmt, assignstmt);
/*
dbg_gen_stmtls(stdout, newstmt);
printf("-------\n");
*/
/* wrap a scope around it for partial reduction */
if (!complete) {
newstmt = build_reg_mask_scope(srcreg,srcmask,srcmaskbit,newstmt,
lineno,filename);
}
insertbefore_stmt(newstmt,stmt);
laststmt = stmt;
/*
dbg_gen_stmtls(stdout, newstmt);
printf("-------\n");
*/
if (!using_dest_as_temp) {
/* build assignment of reduction result */
tempexpr = copy_expr(tempexpr);
lhs = copy_expr(lhs);
assignexpr = build_typed_binary_op(BIASSIGNMENT, tempexpr, lhs);
assignstmt = build_expr_statement(assignexpr,lineno,filename);
if (!complete) {
/* assignstmt = build_mloop_statement(dstreg, assignstmt,
D_REG_NUM(T_TYPEINFO(dstreg)),
dstmask, dstmaskbit, lineno, filename);*/
}
if (nextstmt == NULL) {
T_NEXT(stmt) = assignstmt;
T_PREV(assignstmt) = stmt;
T_PARFCN(assignstmt) = T_PARFCN(stmt);
} else {
insertbefore_stmt(assignstmt,nextstmt);
laststmt = nextstmt;
}
}
/* deallocate local array if there was one */
if (!complete && !staticreg && !using_dest_as_temp) {
genlist_t* newgls;
newgls = alloc_gen();
G_IDENT(newgls) = tempvar;
T_POST(assignstmt) = newgls;
}
/* convert original statement into a simple reduction expression */
/* T_EXPR(stmt) = redexpr;*/
T_PRE(newstmt) = cat_genlist_ls(T_PRE(newstmt), T_PRE(stmt));
T_POST(laststmt) = cat_genlist_ls(T_POST(laststmt), T_POST(stmt));
remove_stmt(stmt);
/* for user defined reductions, find or create a global reduction function */
if (T_SUBTYPE(redexpr) == USER) {
expr_t* copyexpr;
char gfn[256];
statement_t* body;
statement_t* comp_stmt;
symboltable_t* pst;
expr_t* oldarg1;
expr_t* newarg1;
expr_t* oldarg2;
expr_t* newarg2;
sprintf(gfn, "_ZPLGLOBALREDUCE_%s", S_IDENT(T_IDENT(redexpr)));
pst = lu(gfn);
if (pst != NULL) {
T_IDENT(redexpr) = pst;
}
else {
symboltable_t* locals;
tempexpr = copy_expr(tempexpr);
copyexpr = copy_expr(tempexpr);
T_NEXT(tempexpr) = copyexpr;
id = get_function_name(T_IDENT(redexpr), tempexpr, 1);
if (id == NULL) {
USR_FATALX(lineno, filename, "Missing global function for user defined reduction");
}
pst = lu(id);
if (pst == NULL) {
USR_FATALX(lineno, filename, "Missing global function for user defined reduction");
}
locals = T_DECL(S_FUN_BODY(pst));
oldarg1 = build_typed_0ary_op(VARIABLE, T_DECL(S_FUN_BODY(pst)));
oldarg2 = build_typed_0ary_op(VARIABLE, S_SIBLING(T_DECL(S_FUN_BODY(pst))));
body = copy_stmtls(T_STLS(S_FUN_BODY(pst)));
pst = insert_function(gfn,pdtVOID,2,T_TYPEINFO(tempexpr),SC_INOUT,
T_TYPEINFO(tempexpr),SC_INOUT);
S_STD_CONTEXT(pst) = FALSE;
if (T_TYPE(body) != S_COMPOUND) {
comp_stmt = build_compound_statement( NULL, body, lineno, filename);
} else {
comp_stmt = body;
}
S_SIBLING(S_SIBLING(T_DECL(S_FUN_BODY(pst)))) = locals;
T_DECL(T_CMPD(comp_stmt)) = T_DECL(S_FUN_BODY(pst));
T_STLS(S_FUN_BODY(pst)) = comp_stmt;
fix_stmtls(comp_stmt, NULL, S_FUN_BODY(pst));
newarg1 = build_typed_0ary_op(VARIABLE, T_DECL(S_FUN_BODY(pst)));
newarg2 = build_typed_0ary_op(VARIABLE, S_SIBLING(T_DECL(S_FUN_BODY(pst))));
replaceall_stmtls(body, oldarg1, newarg1);
replaceall_stmtls(body, oldarg2, newarg2);
/* we can do this because we know it is not recursive! */
body = returns2assigns(body, newarg2);
T_IDENT(redexpr) = pst;
}
}
}
