has already been processed)
> (i.e. CHARACTER FOO*1); and a length of -1 implies that no length
> was specified.
>
> So, when sptr is nonzero and len is -1, we do not attempt to adjust
> the data type; if so, we will incorrectly adjust
>
> REAL*4 rv
> when the "r8" option has been selected (-x 124 8).
*/
int
mod_type(int dtype, int ty, int kind, int len, int propagated, int sptr)
{
/*
* The dtype could be any static or dynamic dtype therefore use the
* TY_type field for comparisons. For example, there is the static
* entry for CHARACTER*1 and the dynamic entries for CHARACTER*number.
*/
if (sptr && len == -1)
return dtype;
/*
* the possible values of 'ty' are those which can be base types.
*/
switch (ty) {
case TY_BINT:
if (kind != 0)
error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "byte", CNULL);
break;
case TY_INT:
case TY_INT8:
if (kind == 0) {
if (!flg.i4 && dtype == DT_INT)
return (DT_SINT);
return dtype;
}
if (kind == 1) {
if (len == 1)
return (DT_BINT);
if (len == 2)
return (DT_SINT);
if (len == 4)
return (DT_INT4);
if (len == 8 && !XBIT(57, 0x2))
return (DT_INT8);
}
error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "integer", CNULL);
break;
case TY_LOG:
case TY_LOG8:
if (kind == 0) {
if (!flg.i4 && dtype == DT_LOG)
return (DT_SLOG);
return dtype;
}
if (kind == 1) {
if (len == 1)
return (DT_BLOG);
if (len == 2)
return (DT_SLOG);
if (len == 4)
return (DT_LOG4);
if (len == 8 && !XBIT(57, 0x2))
return (DT_LOG8);
}
error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "logical", CNULL);
break;
case TY_DBLE:
if (sem.ogdtype == DT_REAL8 && kind != 0) {
error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "doubleprecision",
CNULL);
break;
}
/* NB: no break here. */
case TY_REAL:
if (kind == 0)
return dtype;
if (kind == 1) {
if (len == 16 && !XBIT(57, 0x4)) {
if (XBIT(57, 0x10)) {
if (!propagated)
error(437, 2, gbl.lineno, "REAL*16", "REAL*8");
return DT_REAL8;
} else {
return DT_QUAD;
}
}
if (len == 8)
return DT_REAL8;
if (len == 4)
return (DT_REAL4);
}
error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) :
(ty == TY_HALF ? "real2" : "real"), CNULL);
break;
case TY_DCMPLX:
if (sem.ogdtype == DT_CMPLX16 && kind != 0) {
error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "doublecomplex", CNULL);
break;
}
/* NB: no break here. */
case TY_CMPLX:
if (kind == 0)
return dtype;
if (kind == 1) {
if (len == 32 && !XBIT(57, 0x8)) {
if (XBIT(57, 0x10)) {
if (!propagated)
error(437, 2, gbl.lineno, "COMPLEX*32", "COMPLEX*16");
return DT_CMPLX16;
} else {
return DT_QCMPLX;
}
}
if (len == 16)
return DT_CMPLX16;
if (len == 8)
return (DT_CMPLX8);
}
error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "complex", CNULL);
break;
case TY_CHAR:
case TY_NCHAR:
switch (kind) {
case 3: /* zero-size character */
return get_type(2, DTY(dtype), astb.i0);
case 5: /* '*(:)' */
if (DTY(dtype) == TY_CHAR)
return DT_DEFERCHAR;
else
return DT_DEFERNCHAR;
case 2: /* '*(*)' */
if (DTY(dtype) == TY_CHAR)
return DT_ASSCHAR;
else
return DT_ASSNCHAR;
case 1: /* constant length */
return get_type(2, DTY(dtype), mk_cval(len, DT_INT4));
case 4: /* adjustable length */
return get_type(2, DTY(dtype), len);
case 0: /* no length */
return get_type(2, DTY(dtype), astb.i1);
}
break;
default:
interr("mod_type/data type: bad data type:", dtype, 0);
break;
}
return dtype;
}
/** \brief Return the printable representation of a semantic stack entry
*/
char *
prtsst(SST *stkptr)
{
static char symbuf[132];
int val, dtype;
val = SST_SYMG(stkptr);
dtype = SST_DTYPEG(stkptr);
if (SST_IDG(stkptr) == S_CONST) {
if (dtype == DT_QUAD || dtype == DT_REAL8 || DT_ISCMPLX(dtype)) {
return (getprint(val));
} else {
if (DT_ISREAL(dtype)) {
sprintf(symbuf, "%f", *(float *)&val);
} else if (DT_ISLOG(dtype)) {
if (val == SCFTN_TRUE)
sprintf(symbuf, ".TRUE.");
else
sprintf(symbuf, ".FALSE.");
} else if (DTYG(dtype) == TY_CHAR)
sprintf(symbuf, "\"%s\"", stb.n_base + CONVAL1G(val));
else
sprintf(symbuf, "%d", val);
}
}
return (symbuf);
}
/** \brief Dereference an ast to determine the base, i.e. its symbol pointer.
*/
int
getbase(int ast)
{
switch (A_TYPEG(ast)) {
case A_SUBSTR:
case A_SUBSCR:
return (getbase((int)A_LOPG(ast)));
case A_ID:
return A_SPTRG(ast);
case A_MEM:
return (getbase((int)A_PARENTG(ast)));
case A_FUNC:
case A_CALL:
return (getbase((int)A_LOPG(ast)));
default:
return 0;
}
}
/*---------------------------------------------------------------------*
* Handle DO statements *
*---------------------------------------------------------------------*/
/** \brief Generate ILMs which computes the address of the index variable.
Need to do it this way since the ILMs which were originally
computed during the parse are not saved across the blocks
*/
int
do_index_addr(int sptr)
{
return ref_object(sptr);
}
/** \brief Write out block DO AST from doinfo record. This function assumes
that they init, limit, and step expressions have already been cast to
the type of the do index variable.
*/
int
do_begin(DOINFO *doinfo)
{
int iv;
int ast, dovar;
iv = doinfo->index_var;
doinfo->prev_dovar = DOVARG(iv);
DOCHK(iv);
DOVARP(iv, 1);
ast = mk_stmt(A_DO, 0 /* SST_ASTG(RHS(1)) BLOCKDO */);
dovar = mk_id(iv);
A_DOVARP(ast, dovar);
A_M1P(ast, doinfo->init_expr);
A_M2P(ast, doinfo->limit_expr);
A_M3P(ast, doinfo->step_expr);
A_LASTVALP(ast, 0);
return ast;
}
/*
* Compute the last value of a DO index variable.
*/
static int tempify_ast(int);
void
do_lastval(DOINFO *doinfo)
{
int dtype, sptr;
int e1, e2, e3;
int ast, dest_ast;
/* for a simd loop, lastval_var is not used.
* we need to calculate the last iteration in the
* compiler.
*/
doinfo->lastval_var = 0;
if (!sem.expect_simd_do) {
sptr = get_itemp(DT_INT);
ast = astb.i0;
ADDRTKNP(sptr, 1);
doinfo->lastval_var = sptr;
dest_ast = mk_id(sptr);
ast = mk_assn_stmt(dest_ast, ast, A_DTYPEG(ast));
(void)add_stmt(ast);
return;
}
dtype = DTYPEG(doinfo->index_var);
/*
* A do expression containing a function needs to be assigned to a temp
* since we're creating multiple uses (here in and in the DO itself),
* of a do expression.
*/
e1 = doinfo->init_expr;
if (A_CALLFGG(e1)) {
e1 = tempify_ast(e1);
e1 = doinfo->init_expr = A_DESTG(e1);
}
e2 = doinfo->limit_expr;
if (A_CALLFGG(e2)) {
e2 = tempify_ast(e2);
e2 = doinfo->limit_expr = A_DESTG(e2);
}
e3 = doinfo->step_expr;
if (A_CALLFGG(e3)) {
e3 = tempify_ast(e3);
e3 = doinfo->step_expr = A_DESTG(e3);
}
/* lp_cnt = (e2 - e1 + e3) / e3 */
ast = mk_binop(OP_SUB, e2, e1, dtype);
ast = mk_binop(OP_ADD, ast, e3, dtype);
ast = mk_binop(OP_DIV, ast, e3, dtype);
/* lastval = lp_cnt*e3 + e1 */
ast = mk_binop(OP_MUL, ast, e3, dtype);
ast = mk_binop(OP_ADD, ast, e1, dtype);
doinfo->lastval_var = get_itemp(dtype);
dest_ast = mk_id(doinfo->lastval_var);
ast = mk_assn_stmt(dest_ast, ast, dtype);
(void)add_stmt(ast);
}
/*
* allocate a temporary, assign it the value, and return the assignment
* ast
*/
static int
tempify_ast(int src)
{
int argtyp;
int tmpsym;
int assn;
int ast;
argtyp = A_DTYPEG(src);
tmpsym = get_temp(argtyp);
ast = mk_id(tmpsym);
ast = mk_assn_stmt(ast, src, argtyp);
(void)add_stmt(ast);
return ast;
}
static void
add_taskloopreg(DOINFO *doinfo)
{
int ast, savesc;
int lb, ub, st;
ast = mk_stmt(A_MP_TASKLOOPREG, 0);
A_M1P(ast, doinfo->init_expr);
A_M2P(ast, doinfo->limit_expr);
A_M3P(ast, doinfo->step_expr);
(void)add_stmt(ast);
}
int
do_parbegin(DOINFO *doinfo)
{
int iv, di_id;
int ast, dovar;
iv = doinfo->index_var;
if (!DT_ISINT(DTYPEG(iv))) {
error(155, 3, gbl.lineno,
"The index variable of a parallel DO must be integer -", SYMNAME(iv));
return do_begin(doinfo);
}
if (DI_ID(sem.doif_depth) == DI_TASKLOOP) {
add_taskloopreg(doinfo);
}
doinfo->prev_dovar = DOVARG(iv);
DOCHK(iv);
DOVARP(iv, 1);
ast = mk_stmt(A_MP_PDO, 0 /* SST_ASTG(RHS(1)) BLOCKDO */);
dovar = mk_id(iv);
A_DOVARP(ast, dovar);
A_M1P(ast, doinfo->init_expr);
A_M2P(ast, doinfo->limit_expr);
A_M3P(ast, doinfo->step_expr);
#ifdef OMP_OFFLOAD_LLVM
if(DI_ID(sem.doif_depth) == DI_PARDO &&
DI_ID(sem.doif_depth-1) == DI_TARGET) {
int targetast = DI_BTARGET(1);
int ast_looptc = mk_stmt(A_MP_TARGETLOOPTRIPCOUNT, 0);
A_LOOPTRIPCOUNTP(targetast, ast_looptc);
A_DOVARP(ast_looptc, dovar);
A_M1P(ast_looptc, doinfo->init_expr);
A_M2P(ast_looptc, doinfo->limit_expr);
A_M3P(ast_looptc, doinfo->step_expr);
}
#endif
if (DI_ID(sem.doif_depth) != DI_TASKLOOP) {
A_CHUNKP(ast, DI_CHUNK(sem.doif_depth));
A_DISTCHUNKP(ast, DI_DISTCHUNK(sem.doif_depth)); /* currently unused */
A_SCHED_TYPEP(ast, DI_SCHED_TYPE(sem.doif_depth));
A_ORDEREDP(ast, DI_IS_ORDERED(sem.doif_depth));
} else {
A_CHUNKP(ast, 0);
A_DISTCHUNKP(ast, 0);
A_SCHED_TYPEP(ast, 0);
A_ORDEREDP(ast, 0);
}
if (doinfo->lastval_var) {
int lv_ast = mk_id(doinfo->lastval_var);
A_LASTVALP(ast, lv_ast);
} else {
A_LASTVALP(ast, 0);
}
A_ENDLABP(ast, 0);
/* set distribute loop flag */
A_DISTRIBUTEP(ast, 0);
A_DISTPARDOP(ast, 0);
if (DI_ID(sem.doif_depth) == DI_TASKLOOP) {
A_TASKLOOPP(ast, 1);
} else {
A_TASKLOOPP(ast, 0);
}
return ast;
}
static struct {
int upper;
int lower;
int tmplower; /* different if lower is lastprivate */
int stride;
// struct mp_for_init_info MPF;
} distlp_info;
void
save_distloop_info(int lower, int upper, int stride)
{
}
void
restore_distloop_info()
{
}
int
do_simdbegin(DOINFO *doinfo)
{
int iv, di_id;
int ast, dovar;
iv = doinfo->index_var;
if (!DT_ISINT(DTYPEG(iv))) {
error(155, 3, gbl.lineno,
"The index variable of a simd DO must be integer -", SYMNAME(iv));
return do_begin(doinfo);
}
doinfo->prev_dovar = DOVARG(iv);
DOCHK(iv);
DOVARP(iv, 1);
ast = mk_stmt(A_DO, 0 /* SST_ASTG(RHS(1)) BLOCKDO */);
dovar = mk_id(iv);
A_DOVARP(ast, dovar);
A_M1P(ast, doinfo->init_expr);
A_M2P(ast, doinfo->limit_expr);
A_M3P(ast, doinfo->step_expr);
if (doinfo->lastval_var) {
A_LASTVALP(ast, mk_id(doinfo->lastval_var));
} else {
A_LASTVALP(ast, 0);
}
A_ENDLABP(ast, 0);
A_DISTRIBUTEP(ast, 0);
A_CHUNKP(ast, 0);
A_DISTCHUNKP(ast, 0); /* currently unused */
A_SCHED_TYPEP(ast, 0);
A_ORDEREDP(ast, 0);
A_DISTPARDOP(ast, 0);
A_TASKLOOPP(ast, 0);
return ast;
}
/*
* collapse structure where various information is collected when the
* omp collapse clause is present.
*/
static struct {
int itemp;
int doif_depth; /* doif of the PARDO/PDO specifying COLLAPSE */
int dtype; /* dtype of the new index, loop cnt & other temps */
int index_var;
int lp_cnt;
int quo_var;
int rem_var;
int tmp_var;
} coll_st;
static int get_collapse_temp(int, char *);
static int collapse_expr(int, int, char *);
static void collapse_index(DOINFO *);
/** \brief Begin processing loop collapse.
Example: the use of the collapse is for 3 loops.
!$omp ... collapse(3)
do i1 = in1, l1, s1
do i2 = in2, l2, s2
do i3 = in3, l3, s3
... SS ...
The 3 loops are collapsed into a single loop with a new index variable and
loop count. The new loop defines the iteration space for which the other
omp clauses are applied; the new loop will appear as:
n1 = (l1 - in1 + s1)/s1
n2 = (l2 - in2 + s2)/s2
n3 = (l3 - in3 + s3)/s3
nn = n1*n2*n3 !! the product of the loop counts
!$omp ...
do ii = 1, nn
t = ii-1
q = t / n3
r = t - q*n3
i3 = in3 + r*s3
t = q
q = t / n2
r = t - q*n2
i2 = in2 + r*s2
t = q
q = t / n1
r = t - q*n1
i2 = in1 + r*s1
... SS ...
Basically, the original index variables are no longer iterated; their
values are computed as a function of the new index variable and the
corresponding loops' init, stride, and loop count.
Prefix of temps created for each loop:
.Xa - lower bound
.Xb - stride
.Xc - loop count
Collapsed loop:
.Xd - loop count
.id - index variable
.Xe - quotient of id/loopcnt
.Xf - remainder of id/loopcnt
.Xg = temp var
*/
int
collapse_begin(DOINFO *doinfo)
{
int dtype;
SST tsst;
int ast;
int count_var;
dtype = DTYPEG(doinfo->index_var);
if (!DT_ISINT(dtype)) {
error(155, 3, gbl.lineno,
"The index variable of a parallel DO must be integer -",
SYMNAME(doinfo->index_var));
doinfo->collapse = sem.collapse = sem.collapse_depth = 0;
ast = do_begin(doinfo);
DI_DOINFO(sem.doif_depth) = 0; /* remove any chunk info */
return ast;
}
coll_st.doif_depth = sem.doif_depth;
if (dtype != DT_INT8) /* change type if LOG, SINT, etc.*/
dtype = DT_INT; /* see ensuing getccsym() call */
/*
* if the step expression is not a constant, a temporary variable
* must be allocated to hold the value for the do-end.
*/
doinfo->step_expr = collapse_expr(doinfo->step_expr, dtype, "Xb");
/*
* Same with the init expr.
*/
doinfo->init_expr = collapse_expr(doinfo->init_expr, dtype, "Xa");
/*
* lp_cnt <-- (e2 - e1 + e3) / e3
*/
ast = mk_binop(OP_SUB, doinfo->limit_expr, doinfo->init_expr, dtype);
ast = mk_binop(OP_ADD, ast, doinfo->step_expr, dtype);
ast = mk_binop(OP_DIV, ast, doinfo->step_expr, dtype);
SST_IDP(&tsst, S_EXPR);
SST_ASTP(&tsst, ast);
SST_DTYPEP(&tsst, dtype);
chktyp(&tsst, DT_INT8, FALSE);
count_var = get_collapse_temp(DT_INT8, "Xc");
doinfo->count = mk_id(count_var);
/* add store of loop count */
ast = SST_ASTG(&tsst);
ast = mk_assn_stmt(doinfo->count, ast, DT_INT8);
(void)add_stmt(ast);
coll_st.dtype = DT_INT8;
coll_st.lp_cnt = get_collapse_temp(coll_st.dtype, "Xd");
coll_st.index_var = get_collapse_temp(coll_st.dtype, "id");
coll_st.quo_var = get_collapse_temp(coll_st.dtype, "Xe");
coll_st.rem_var = get_collapse_temp(coll_st.dtype, "Xf");
coll_st.tmp_var = get_collapse_temp(coll_st.dtype, "Xg");
ENCLFUNCP(count_var, BLK_SYM(sem.scope_level));
ENCLFUNCP(coll_st.lp_cnt, BLK_SYM(sem.scope_level));
ENCLFUNCP(coll_st.index_var, BLK_SYM(sem.scope_level));
ENCLFUNCP(coll_st.quo_var, BLK_SYM(sem.scope_level));
ENCLFUNCP(coll_st.rem_var, BLK_SYM(sem.scope_level));
ENCLFUNCP(coll_st.tmp_var, BLK_SYM(sem.scope_level));
/*
* initialize the new loop count as the loop count of the first loop.
*/
SST_IDP(&tsst, S_IDENT);
SST_SYMP(&tsst, count_var);
SST_DTYPEP(&tsst, DT_INT8);
chktyp(&tsst, coll_st.dtype, FALSE);
mkexpr1(&tsst);
ast = SST_ASTG(&tsst);
ast = mk_assn_stmt(mk_id(coll_st.lp_cnt), ast, coll_st.dtype);
(void)add_stmt(ast);
coll_st.itemp++;
sem.collapse_depth--;
return 0;
}
/** \brief Process an ensuing loop which is being collapsed.
*/
int
collapse_add(DOINFO *doinfo)
{
int dtype;
SST tsst;
int ast, dest_ast, std;
int count_var;
dtype = DTYPEG(doinfo->index_var);
if (DT_ISINT(dtype) && dtype != DT_INT8) /* change type if LOG, SINT, etc.*/
dtype = DT_INT; /* see ensuing getccsym() call */
/*
* if the step expression is not a constant, a temporary variable
* must be allocated to hold the value for the do-end.
*/
doinfo->step_expr = collapse_expr(doinfo->step_expr, dtype, "Xb");
/*
* Same with the init expr.
*/
doinfo->init_expr = collapse_expr(doinfo->init_expr, dtype, "Xa");
/*
* lp_cnt <-- (e2 - e1 + e3) / e3
*/
ast = mk_binop(OP_SUB, doinfo->limit_expr, doinfo->init_expr, dtype);
ast = mk_binop(OP_ADD, ast, doinfo->step_expr, dtype);
ast = mk_binop(OP_DIV, ast, doinfo->step_expr, dtype);
SST_IDP(&tsst, S_EXPR);
SST_ASTP(&tsst, ast);
SST_DTYPEP(&tsst, dtype);
chktyp(&tsst, DT_INT8, FALSE);
ast = SST_ASTG(&tsst);
count_var = get_collapse_temp(DT_INT8, "Xc");
ENCLFUNCP(count_var, BLK_SYM(sem.scope_level));
doinfo->count = mk_id(count_var);
coll_st.itemp++;
/* add store of loop count */
ast = SST_ASTG(&tsst);
ast = mk_assn_stmt(doinfo->count, ast, DT_INT8);
(void)add_stmt(ast);
/*
* update the new loop count by multiplying the loop count of the
* current loop.
*/
SST_IDP(&tsst, S_IDENT);
SST_SYMP(&tsst, count_var);
SST_DTYPEP(&tsst, DT_INT8);
chktyp(&tsst, coll_st.dtype, FALSE);
mkexpr1(&tsst);
ast = SST_ASTG(&tsst);
dest_ast = mk_id(coll_st.lp_cnt);
ast = mk_binop(OP_MUL, dest_ast, ast, coll_st.dtype);
ast = mk_assn_stmt(dest_ast, ast, coll_st.dtype);
(void)add_stmt(ast);
if (doinfo->collapse == 1) {
DOINFO *dinf;
int t1, t2;
int sv;
int i;
/*
* The last loop to be collapsed is now processed. Create the new
* new loop and pass to do_parbegin() which will apply the remaining
* omp clauses.
*/
dinf = get_doinfo(1);
dinf->index_var = coll_st.index_var;
dinf->prev_dovar = 0;
if (coll_st.dtype != DT_INT8)
dinf->init_expr = dinf->step_expr = astb.i1;
else
dinf->init_expr = dinf->step_expr = astb.k1;
dinf->limit_expr = mk_id(coll_st.lp_cnt);
do_lastval(dinf);
sv = sem.doif_depth;
/*
* DI_DOINFO(coll_st.doif_depth) locates the DOINFO record for
* the PARDO/PDO; DI_DOINFO(coll_st.doif_depth+1) is the DOINFO
* for its corresponding DO.
*/
sem.doif_depth = coll_st.doif_depth;
if (DI_ID(sem.doif_depth) == DI_SIMD)
ast = do_simdbegin(dinf);
else
ast = do_parbegin(dinf);
std = add_stmt(ast);
sem.doif_depth = sv;
if (DI_ID(sv) == DI_DOCONCURRENT)
STD_BLKSYM(std) = DI_CONC_BLOCK_SYM(sv);
/*
* Compute the values for index variables in the collapsed do loops in
* the order from inner to outer.
* DI_DOINFO(sem.doif_depth) locates the DOINFO record for loop
* immediately enclosing the current loop.
*/
collapse_index(doinfo); /* innermost first */
for (i = sem.doif_depth; TRUE; i--) {
DOINFO *dd;
dd = DI_DOINFO(i);
collapse_index(dd);
if (dd->collapse == sem.collapse)
break;
}
DI_DOINFO(coll_st.doif_depth + 1) = dinf;
}
sem.collapse_depth--;
return 0;
}
static int
get_collapse_temp(int dtype, char *pfx)
{
int sptr;
sptr = getccssym_sc(pfx, coll_st.itemp, ST_VAR, sem.sc);
DTYPEP(sptr, dtype);
return sptr;
}
static int
collapse_expr(int ast, int dtype, char *pfx)
{
int sptr, dest_ast;
if (A_ALIASG(ast))
return ast;
sptr = getccssym_sc(pfx, coll_st.itemp, ST_VAR, sem.sc);
DTYPEP(sptr, dtype);
dest_ast = mk_id(sptr);
ast = mk_assn_stmt(dest_ast, ast, dtype);
(void)add_stmt(ast);
return dest_ast;
}
/*
* Compute the values of the index variables of the collapsed DO loops.
* The index variables will be computed in the order of inner to
* outer.
*/
static void
collapse_index(DOINFO *dd)
{
int dt_index;
int q, r, cnt;
int qpr, tmp;
SST tsst;
dt_index = DTYPEG(dd->index_var);
if (dd->collapse == 1) {
/*
* initialize for a new set of collapsed loops; compute
* qpr <-- (id-1) / cnt
*/
qpr = mk_id(coll_st.index_var);
if (coll_st.dtype != DT_INT8)
qpr = mk_binop(OP_SUB, qpr, astb.i1, coll_st.dtype);
else
qpr = mk_binop(OP_SUB, qpr, astb.k1, coll_st.dtype);
qpr = mk_assn_stmt(mk_id(coll_st.tmp_var), qpr, coll_st.dtype);
(void)add_stmt(qpr);
}
/*
* Compute
* q <-- qpr / cnt
*/
qpr = mk_id(coll_st.tmp_var);
SST_IDP(&tsst, S_IDENT);
SST_SYMP(&tsst, A_SPTRG(dd->count));
SST_DTYPEP(&tsst, dt_index);
chktyp(&tsst, coll_st.dtype, FALSE);
mkexpr1(&tsst);
cnt = SST_ASTG(&tsst);
tmp = mk_binop(OP_DIV, qpr, cnt, coll_st.dtype);
q = mk_id(coll_st.quo_var);
tmp = mk_assn_stmt(q, tmp, coll_st.dtype);
(void)add_stmt(tmp);
/*
* Compute
* r <-- qpr - q * cnt
*/
tmp = mk_binop(OP_MUL, q, cnt, coll_st.dtype);
tmp = mk_binop(OP_SUB, qpr, tmp, coll_st.dtype);
r = mk_id(coll_st.rem_var);
tmp = mk_assn_stmt(r, tmp, coll_st.dtype);
(void)add_stmt(tmp);
/*
* Compute
* i <-- init + r*step
*/
SST_IDP(&tsst, S_IDENT);
SST_SYMP(&tsst, coll_st.rem_var);
SST_DTYPEP(&tsst, coll_st.dtype);
chktyp(&tsst, dt_index, FALSE);
mkexpr1(&tsst);
r = SST_ASTG(&tsst);
tmp = mk_binop(OP_MUL, r, dd->step_expr, dt_index);
tmp = mk_binop(OP_ADD, tmp, dd->init_expr, dt_index);
tmp = mk_assn_stmt(mk_id(dd->index_var), tmp, dt_index);
(void)add_stmt(tmp);
/*
* Compute, iff not the last index variable
* qpr <-- q
*/
if (dd->collapse != sem.collapse) {
tmp = mk_assn_stmt(qpr, q, coll_st.dtype);
(void)add_stmt(tmp);
}
}
void
do_end(DOINFO *doinfo)
{
int ast, i, orig_doif, par_doif, std, symi, astlab;
SPTR block_sptr, lab, sptr;
orig_doif = sem.doif_depth; // original loop index
// Close do concurrent mask.
// Don't emit scn.currlab here. (Don't use add_stmt.)
if (DI_ID(orig_doif) == DI_DOCONCURRENT && DI_CONC_MASK_STD(orig_doif))
(void)add_stmt_after(mk_stmt(A_ENDIF, 0), STD_LAST);
// Loop body is done; emit loop cycle label.
// Don't emit scn.currlab here. (Don't use add_stmt.)
if (DI_CYCLE_LABEL(orig_doif)) {
std = add_stmt_after(mk_stmt(A_CONTINUE, 0), STD_LAST);
STD_LABEL(std) = DI_CYCLE_LABEL(orig_doif);
DEFDP(DI_CYCLE_LABEL(orig_doif), 1);
}
// Finish do concurrent inner loop processing and move to the outermost loop.
if (DI_ID(orig_doif) == DI_DOCONCURRENT) {
check_doconcurrent(orig_doif); // innermost loop has constraint check info
std = add_stmt_after(mk_stmt(A_CONTINUE, 0), STD_LAST);
STD_LINENO(std) = gbl.lineno;
STD_LABEL(std) = lab = getlab();
RFCNTI(lab);
VOLP(lab, true);
block_sptr = DI_CONC_BLOCK_SYM(orig_doif);
ENDLINEP(block_sptr, gbl.lineno);
ENDLABP(block_sptr, lab);
for (i = DI_CONC_COUNT(orig_doif), symi = DI_CONC_SYMS(orig_doif); i;
--i, symi = SYMI_NEXT(symi)) {
sptr = SYMI_SPTR(symi);
HIDDENP(sptr, 1); // do concurrent index construct var
}
for (++sptr; sptr < stb.stg_avail; ++sptr)
switch (STYPEG(sptr)) {
case ST_UNKNOWN:
case ST_IDENT:
case ST_VAR:
case ST_ARRAY:
if (SAVEG(sptr))
break;
if (!CCSYMG(sptr) && !HCCSYMG(sptr))
DCLCHK(sptr);
HIDDENP(sptr, 1); // do concurrent non-index construct var
if (ENCLFUNCG(sptr) == 0)
ENCLFUNCP(sptr, block_sptr);
}
for (; DI_CONC_COUNT(orig_doif) > 1; --orig_doif)
if (!DI_DOINFO(orig_doif)->collapse) {
std = add_stmt(mk_stmt(A_ENDDO, 0));
STD_BLKSYM(std) = block_sptr;
}
doinfo = DI_DOINFO(orig_doif);
sem.doif_depth = orig_doif;
}
if (doinfo->index_var)
/*
* If there is an index variable, set its DOVAR flag to its 'state'
* before entering the DO which is about to be popped.
*/
DOVARP(doinfo->index_var, doinfo->prev_dovar);
par_doif = orig_doif - 1; // parallel loop index (if it exists)
switch (DI_ID(par_doif)) {
case DI_PDO:
(void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
if (scn.currlab && scn.stmtyp != TK_ENDDO)
(void)add_stmt(mk_stmt(A_MP_BARRIER, 0));
end_parallel_clause(par_doif);
sem.close_pdo = TRUE;
par_pop_scope();
sem.collapse = 0;
break;
case DI_TASKLOOP:
ast = mk_stmt(A_MP_ENDPDO, 0);
A_TASKLOOPP(ast, 1);
(void)add_stmt(ast);
end_parallel_clause(par_doif);
sem.close_pdo = TRUE;
--sem.task;
par_pop_scope();
add_stmt(mk_stmt(A_MP_ETASKLOOPREG, 0));
ast = mk_stmt(A_MP_ETASKLOOP, 0);
A_LOPP(DI_BEGINP(par_doif), ast);
A_LOPP(ast, DI_BEGINP(par_doif));
add_stmt(ast);
if (sem.task < 0)
sem.task = 0;
mp_create_escope();
sem.collapse = 0;
break;
case DI_DOACROSS:
case DI_PARDO:
/* For DOACROSS & PARALLEL DO, need to end the parallel section. */
(void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
end_parallel_clause(par_doif);
sem.close_pdo = TRUE;
--sem.parallel;
par_pop_scope();
ast = emit_epar();
A_LOPP(DI_BPAR(par_doif), ast);
A_LOPP(ast, DI_BPAR(par_doif));
mp_create_escope();
sem.collapse = 0;
break;
case DI_TEAMSDIST:
case DI_TARGTEAMSDIST:
case DI_DISTRIBUTE:
(void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
end_parallel_clause(par_doif);
sem.close_pdo = TRUE;
par_pop_scope();
ast = mk_stmt(A_MP_ENDDISTRIBUTE, 0);
A_LOPP(DI_BDISTRIBUTE(par_doif), ast);
A_LOPP(ast, DI_BDISTRIBUTE(par_doif));
(void)add_stmt(ast);
sem.collapse = 0;
break;
case DI_TEAMSDISTPARDO:
case DI_TARGTEAMSDISTPARDO:
case DI_DISTPARDO:
(void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
end_parallel_clause(par_doif);
sem.close_pdo = TRUE;
/* We create 2 scopes for distributed loop so that
* lastprivate(dovar) is not the same as dovar for
* distributed loop, therefore we need to double pop
* one for do scope and another is for lastprivate
* which is DISTPARDO scope.
*/
par_pop_scope();
par_pop_scope();
ast = mk_stmt(A_MP_ENDDISTRIBUTE, 0);
A_LOPP(DI_BDISTRIBUTE(par_doif), ast);
A_LOPP(ast, DI_BDISTRIBUTE(par_doif));
(void)add_stmt(ast);
sem.collapse = 0;
break;
case DI_TARGPARDO:
(void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
end_parallel_clause(par_doif);
sem.close_pdo = TRUE;
--sem.parallel;
par_pop_scope();
ast = emit_epar();
A_LOPP(DI_BPAR(par_doif), ast);
A_LOPP(ast, DI_BPAR(par_doif));
mp_create_escope();
sem.collapse = 0;
end_parallel_clause(orig_doif);
sem.doif_depth--; /* leave_dir(DI_TARGPARDO, .. */
par_doif--;
sem.target--;
par_pop_scope();
ast = emit_etarget();
mp_create_escope();
A_LOPP(DI_BTARGET(par_doif), ast);
A_LOPP(ast, DI_BTARGET(par_doif));
sem.collapse = 0;
break;
case DI_SIMD:
/* Standalone simd construct and target simd too? */
(void)add_stmt(mk_stmt(A_ENDDO, 0));
end_parallel_clause(par_doif);
sem.close_pdo = TRUE;
par_pop_scope();
sem.collapse = 0;
break;
case DI_ACCDO:
case DI_ACCLOOP:
case DI_ACCREGDO:
case DI_ACCREGLOOP:
case DI_ACCKERNELSDO:
case DI_ACCKERNELSLOOP:
case DI_ACCPARALLELDO:
case DI_ACCPARALLELLOOP:
case DI_ACCSERIALLOOP:
case DI_CUFKERNEL:
(void)add_stmt(mk_stmt(A_ENDDO, 0));
sem.close_pdo = TRUE;
/* Pop the inserted new symbol for the induction var*/
if (flg.smp && (SCG(doinfo->index_var) != SC_PRIVATE)) {
if (DI_DO_POPINDEX(sem.doif_depth) > SPTR_NULL)
pop_sym(DI_DO_POPINDEX(sem.doif_depth));
}
break;
default:
// No parallel loop; process the original loop.
if (doinfo->collapse > 0)
// This is an intermediate loop in a collapsed loop nest.
break;
switch (DI_ID(orig_doif)) {
case DI_DO:
(void)add_stmt(mk_stmt(A_ENDDO, 0));
break;
case DI_DOCONCURRENT:
std = add_stmt(mk_stmt(A_ENDDO, 0));
STD_BLKSYM(std) = block_sptr;
break;
case DI_DOWHILE:
ast = mk_stmt(A_GOTO, 0);
// Do not place mk_label inside A_L1P(ast, mk_label(...))
// due to undefined behavior of C compiler for evaluation order
// between the calculation of the address of the target of an
// assignment and the computation of the value being assigned.
astlab = mk_label(DI_TOP_LABEL(orig_doif));
A_L1P(ast, astlab);
RFCNTI(DI_TOP_LABEL(orig_doif));
(void)add_stmt(ast);
(void)add_stmt(mk_stmt(A_ENDIF, 0));
break;
}
}
// Loop code is done; emit loop exit label.
if (DI_EXIT_LABEL(orig_doif)) {
std = add_stmt(mk_stmt(A_CONTINUE, 0));
STD_LABEL(std) = DI_EXIT_LABEL(orig_doif);
DEFDP(DI_EXIT_LABEL(orig_doif), 1);
}
--sem.doif_depth;
}
DOINFO *
get_doinfo(int area)
{
DOINFO *doinfo;
doinfo = (DOINFO *)getitem(area, sizeof(DOINFO));
doinfo->collapse = 0;
doinfo->distloop = 0;
return doinfo;
}
/**
\param structd dtype record of parent structure
\param base ast ptr of parent structure
\param nmx index into "names" area of member
\return ast or 0 if not found
*/
int
mkmember(int structd, int base, int nmx)
{
int sptr; /* next member of structure to search */
int dtype;
int tmp;
for (sptr = DTY(structd + 1); sptr > NOSYM; sptr = SYMLKG(sptr)) {
dtype = DTYPEG(sptr);
/*
* special case: if member is a union, then we must look at
* all maps which belong to the union; recall that each map is
* just a struct.
*/
if (DTY(dtype) == TY_UNION) {
int ast;
ast = mkunion(dtype, base, nmx);
if (ast)
return (ast);
} else if (NMPTRG(sptr) == nmx) {
int ast, member;
if (flg.xref)
xrefput(sptr, 'r');
member = mk_id(sptr);
ast = mk_member(base, mk_id(sptr), dtype);
return ast;
} else if (PARENTG(sptr)) { /* type extension */
int ast = mkmember(DTYPEG(sptr), base, nmx);
if (ast)
return ast;
}
}
return 0; /* not found */
}
/**
\param uniond dtype record of parent structure
\param base ast ptr of parent structure
\param nmx index into "names" area of member
\return ast or 0 if not found
*/
static int
mkunion(int uniond, int base, int nmx)
{
int sptr; /* next member of structure to search */
int dtype;
int ast;
/*
* scan the MAPs (each "member" is a struct and represents
* one map)
*/
for (sptr = DTY(uniond + 1); sptr != NOSYM; sptr = SYMLKG(sptr)) {
dtype = DTYPEG(sptr);
#if DEBUG
assert(DTY(dtype) == TY_STRUCT, "mkunion, dt not struct", sptr, 3);
#endif
/* look at all members of the map (a struct) */
ast = mkmember(dtype, base, nmx);
if (ast)
return ast;
}
return 0; /* not found */
}
/** \brief Given an ast which computes the address of the label variable or
loads the label variable, create the variable of indicated dtype.
*/
int
mklabelvar(SST *stkptr)
{
int ast;
int sptr;
int dtype;
mkexpr(stkptr);
ast = SST_ASTG(stkptr);
#if DEBUG
if (A_TYPEG(ast) != A_ID) {
interr("mklabelvar: ast not id", ast, 3);
return 0;
}
#endif
sptr = A_SPTRG(ast);
/*
* When targeting llvm, always create a temp variable of ptr-size
* integer type.
*/
if (XBIT(49, 0x100))
dtype = DT_INT8;
else
dtype = DT_INT4;
sptr = getcctmp_sc('l', sptr, ST_VAR, dtype, sem.sc);
SST_DTYPEP(stkptr, DTYPEG(sptr));
SST_ASTP(stkptr, mk_id(sptr));
return sptr;
}
LOGICAL
legal_labelvar(int dtype)
{
if (dtype == stb.user.dt_int)
return TRUE;
if (dtype == DT_INT4 || dtype == DT_INT8)
return TRUE;
return FALSE;
}
static INT
_xtok(INT conval1, BIGINT64 count, int dtype)
{
INT conval;
INT one;
int isneg;
IEEE128 qtemp, qresult, qnum1;
IEEE128 qreal1, qrealrs, qimag1, qimagrs;
IEEE128 qrealpv, qtemp1;
DBLE dtemp, dresult, num1;
DBLE dreal1, drealrs, dimag1, dimagrs;
DBLE drealpv, dtemp1;
SNGL temp, result;
SNGL real1, realrs, imag1, imagrs;
SNGL realpv, temp1;
DBLINT64 inum1, ires;
int overr;
UINT uval, uoldval;
overr = 0;
isneg = 0;
if (count < 0) {
isneg = 1;
count = -count;
}
one = 1;
if (dtype != DT_INT4)
one = cngcon(one, DT_INT4, dtype);
switch (DTY(dtype)) {
case TY_WORD:
case TY_DWORD:
error(33, 3, gbl.lineno, " ", CNULL);
return (0);
case TY_BINT:
case TY_SINT:
case TY_INT:
uval = 1;
{
int do_neg;
int sg;
sg = 0;
do_neg = 0;
if (conval1 < 0) {
do_neg = 1;
conval1 = -conval1;
}
uoldval = conval1;
while (count--) {
sg ^= 1;
uval = uval * conval1;
if (!sem.which_pass && !overr && uval < uoldval) {
/*
* generally, warnings are inhibited during the 2nd parse
*/
overr = 1;
}
uoldval = uval;
}
conval = *((INT *)&uval);
if (do_neg) {
conval1 = -conval1;
if (sg)
conval = -conval;
} else if (conval & 0x80000000)
overr = 1;
if (overr) {
error(155, 2, gbl.lineno, "Integer overflow occurred when evaluating",
"**");
}
}
break;
case TY_INT8:
inum1[0] = CONVAL1G(conval1);
inum1[1] = CONVAL2G(conval1);
ires[0] = CONVAL1G(stb.k1);
ires[1] = CONVAL2G(stb.k1);
while (count--)
mul64(inum1, ires, ires);
conval = getcon(ires, DT_INT8);
break;
case TY_REAL:
conval = CONVAL2G(stb.flt1);
while (count--)
xfmul(conval1, conval, &conval);
break;
case TY_DBLE:
num1[0] = CONVAL1G(conval1);
num1[1] = CONVAL2G(conval1);
dresult[0] = CONVAL1G(stb.dbl1);
dresult[1] = CONVAL2G(stb.dbl1);
while (count--)
xdmul(num1, dresult, dresult);
conval = getcon(dresult, DT_REAL8);
break;
case TY_CMPLX:
real1 = CONVAL1G(conval1);
imag1 = CONVAL2G(conval1);
realrs = CONVAL1G(one);
imagrs = CONVAL2G(one);
while (count--) {
/* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */
realpv = realrs;
xfmul(real1, realrs, &temp1);
xfmul(imag1, imagrs, &temp);
xfsub(temp1, temp, &realrs);
xfmul(real1, imagrs, &temp1);
xfmul(realpv, imag1, &temp);
xfadd(temp1, temp, &imagrs);
}
num1[0] = realrs;
num1[1] = imagrs;
conval = getcon(num1, DT_CMPLX8);
break;
case TY_DCMPLX:
dreal1[0] = CONVAL1G(CONVAL1G(conval1));
dreal1[1] = CONVAL2G(CONVAL1G(conval1));
dimag1[0] = CONVAL1G(CONVAL2G(conval1));
dimag1[1] = CONVAL2G(CONVAL2G(conval1));
drealrs[0] = CONVAL1G(CONVAL1G(one));
drealrs[1] = CONVAL2G(CONVAL1G(one));
dimagrs[0] = CONVAL1G(CONVAL2G(one));
dimagrs[1] = CONVAL2G(CONVAL2G(one));
while (count--) {
/* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */
drealpv[0] = drealrs[0];
drealpv[1] = drealrs[1];
xdmul(dreal1, drealrs, dtemp1);
xdmul(dimag1, dimagrs, dtemp);
xdsub(dtemp1, dtemp, drealrs);
xdmul(dreal1, dimagrs, dtemp1);
xdmul(drealpv, dimag1, dtemp);
xdadd(dtemp1, dtemp, dimagrs);
}
num1[0] = getcon(drealrs, DT_REAL8);
num1[1] = getcon(dimagrs, DT_REAL8);
conval = getcon(num1, DT_CMPLX16);
break;
case TY_BLOG:
case TY_SLOG:
case TY_LOG:
case TY_LOG8:
case TY_NCHAR:
case TY_CHAR:
errsev(91);
return 0;
}
if (isneg) {
/* exponentiation to a negative power */
conval = const_fold(OP_DIV, one, conval, dtype);
}
return conval;
}
static void
error83(int ty)
{
if (ty == TY_CHAR)
UFCHAR;
else
errsev(83);
}