Permalink
Browse files

F18 DO CONCURRENT construct implementation (and a little more)

This is a full serial implementation of the F18 DO CONCURRENT
construct, including locality specifications and associated
constraints C1121-30, C1136-41, and C1166. There are also collateral
feature implementations to upgrade FORALL statements and constructs
and the EXIT statement to F08/F18 status.

With this implementation, a loop such as:

   do concurrent (i=1:m, j=1:n, i.ne.j) local(a) local_init(b) shared(c)
     <body>
   enddo

generates code that looks like:

   do i=1,m
     do j=1,n
       if (i.ne.j)
         b = b ! <construct b> = <host b>
         <body>
       endif
     enddo
   enddo

In this code, variables a and b are local to each iteration of the loop
nest.  Variable c is shared across iterations and host routine code.

F08/F18 DO CONCURRENT constructs and FORALL statements and constructs
may specify an explicit index type:

   do concurrent (integer(8) :: i=1:m, j=1:n, i.ne.j) ! type of i, j
   forall (integer(2) :: i=1:6) a(i) = 1 ! type of i

Although FORALL code generation is very different from DO CONCURRENT
code generation, the two share this syntax, so FORALL code is also
updated with this capability to full F08/F18 status.  F08 syntax
specified DO CONCURRENT loop control in terms of FORALL loop control.
F18 syntax does the reverse (and puts FORALL on the path to deletion).
Grammar productions here use DO CONCURRENT centric names.

F18 constraint C1166 prohibits an EXIT statement from leaving a
DO CONCURRENT construct. This constraint is implemented in code that
is also upgraded to allow EXITs from non-loop constructs, as allowed
in F08/F18.
  • Loading branch information...
gklimowicz committed Sep 13, 2018
1 parent fecdbb9 commit c7ab041531ab04db413b02ea91cfa0a221c04013
@@ -1168,9 +1168,8 @@ An actual argument that is an array element cannot be passed to a REFLECTED dumm
.MS E 487 "Index variable $ does not appear in a subscript on the left hand side of the FORALL assignment"
In a FORALL statement, each index variable in the FORALL must appear in some subscript of the left hand side of the FORALL assignment.
Otherwise, the FORALL will assign the same left hand side elements for different values of that index.
.MS E 488 "The function call in the FORALL does not have the PURE attribute - $"
In a FORALL statement, all functions used must be PURE or ELEMENTAL.
Otherwise, they cannot be called in parallel.
.MS S 488 "$ is not PURE - $"
DO CONCURRENT and FORALL subprogram calls must be PURE or ELEMENTAL.
.MS I 489 "An ALLOCATE of a POINTER with transcriptive or inherited distribution causes replication - $"
When an array with the POINTER attribute and with a distributed that is transcriptive or inherited is allocated,
the alignment and distribution are ignored and the array pointer is treated as replicated,
@@ -3584,10 +3584,11 @@ is_pcalls(int std, int fstd)
ast = STD_AST(std);
if (A_TYPEG(ast) == A_CALL) {
sptr = A_SPTRG(A_LOPG(ast));
if (PUREG(sptr) || (ELEMENTALG(sptr) && !IMPUREG(sptr)))
return TRUE;
if (is_impure(sptr))
error(488, 4, STD_LINENO(fstd), "subprogram call in FORALL",
SYMNAME(sptr));
else
error(488, 4, STD_LINENO(fstd), SYMNAME(sptr), CNULL);
return TRUE;
}
if (A_TYPEG(ast) == A_ICALL)
return TRUE;
@@ -1781,6 +1781,21 @@ has_finalized_component(SPTR sptr)
return test_sym_components_only(sptr, is_finalized);
}
static LOGICAL
is_impure_finalizer(int sptr, struct visit_list **visited)
{
return sptr > NOSYM &&
((STYPEG(sptr) == ST_MEMBER &&
FINALG(sptr) && is_impure(VTABLEG(sptr))) ||
search_type_members(DTYPEG(sptr), is_impure_finalizer, visited));
}
LOGICAL
has_impure_finalizer(SPTR sptr)
{
return test_sym_and_components(sptr, is_impure_finalizer);
}
static LOGICAL
is_layout_desc(SPTR sptr, struct visit_list **visited)
{
@@ -75,21 +75,21 @@ typedef struct {
* table and let alpha() do the rest. (NOTE that 0 is returned by
* keyword() if a name is not found in a keyword table).
*/
#define TKF_BLOCK -1
#define TKF_DOUBLE -2
#define TKF_GO -3
#define TKF_SELECT -4
#define TKF_NO -5
#define TKF_ARRAY -6
#define TKF_ENDBLOCK -7
#define TKF_ATOMIC -8
#define TKF_DOWHILE -9
#define TKF_DOCONCURRENT -10
#define TKF_TARGETENTER -11
#define TKF_TARGETEXIT -12
#define TKF_CANCELLATION -13
#define TKF_DISTPAR -14
#define TKF_ENDDISTPAR -15
#define TKF_ARRAY -1
#define TKF_ATOMIC -2
#define TKF_CANCELLATION -3
#define TKF_DISTPAR -4
#define TKF_DOCONCURRENT -5
#define TKF_DOUBLE -6
#define TKF_DOWHILE -7
#define TKF_ENDDISTPAR -8
#define TKF_GO -9
#define TKF_NO -10
#define TKF_SELECT -11
#define TKF_TARGETENTER -12
#define TKF_TARGETEXIT -13
#define TKF_BLOCK -14
#define TKF_ENDBLOCK -15
static KWORD t1[] = { /* normal keyword table */
{"", 0}, /* a keyword index must be nonzero */
@@ -115,15 +115,18 @@ static KWORD t1[] = { /* normal keyword table */
{"close", TK_CLOSE},
{"common", TK_COMMON},
{"complex", TK_COMPLEX},
{"concurrent", TK_CONCURRENT},
{"contains", TK_CONTAINS},
{"contiguous", TK_CONTIGUOUS},
{"continue", TK_CONTINUE},
{"cycle", TK_CYCLE},
{"data", TK_DATA},
{"deallocate", TK_DEALLOCATE},
{"decode", TK_DECODE},
{"default", TK_DEFAULT},
{"dimension", TK_DIMENSION},
{"do", TK_DO},
{"doconcurrent", TKF_DOCONCURRENT},
{"double", TKF_DOUBLE},
{"doublecomplex", TK_DBLECMPLX},
{"doubleprecision", TK_DBLEPREC},
@@ -182,13 +185,16 @@ static KWORD t1[] = { /* normal keyword table */
{"intent", TK_INTENT},
{"interface", TK_INTERFACE},
{"intrinsic", TK_INTRINSIC},
{"local", TK_LOCAL},
{"local_init", TK_LOCAL_INIT},
{"logical", TK_LOGICAL},
{"map", TK_MAP},
{"module", TK_MODULE},
{"namelist", TK_NAMELIST},
{"ncharacter", TK_NCHARACTER},
{"no", TKF_NO},
{"non_intrinsic", TK_NON_INTRINSIC},
{"none", TK_NONE},
{"nopass", TK_NOPASS},
{"nosequence", TK_NOSEQUENCE},
{"nullify", TK_NULLIFY},
@@ -217,6 +223,7 @@ static KWORD t1[] = { /* normal keyword table */
{"selectcase", TK_SELECTCASE},
{"selecttype", TK_SELECTTYPE},
{"sequence", TK_SEQUENCE},
{"shared", TK_SHARED},
{"stop", TK_STOP},
{"structure", TK_STRUCTURE},
{"submodule", TK_SUBMODULE},
@@ -2407,9 +2407,7 @@ pure_procedure(int ast)
static void
check_pure_interface(int entry, int std, int ast)
{
if ((PUREG(gbl.currsub) ||
(ELEMENTALG(gbl.currsub) && !IMPUREG(gbl.currsub))) &&
!HCCSYMG(entry) && !pure_procedure(ast)) {
if (!is_impure(gbl.currsub) && !HCCSYMG(entry) && !pure_procedure(ast)) {
switch (STYPEG(entry)) {
case ST_INTRIN:
case ST_GENERIC:
@@ -263,6 +263,7 @@ static LOGICAL is_sgi; /* current statement is an sgi SMP directive
static LOGICAL is_dec; /* current statement is a DEC directive */
static LOGICAL is_mem; /* current statement is a mem directive */
static LOGICAL is_ppragma; /* current statement is a parsed pragma/directive */
static bool is_doconcurrent; /* current statement is a do concurrent stmt */
static LOGICAL is_kernel; /* current statement is a parsed kernel directive */
static LOGICAL long_pragma_candidate; /* current statement may be a
* long directive/pragma */
@@ -279,33 +280,23 @@ static int scmode; /* scan mode - used to interpret alpha tokens
#define SCM_DOLAB 9
#define SCM_GOTO 10
#define SCM_DONEXT 11
#define SCM_ALLOC 12
/* 13 available */
/* 14 available */
#define SCM_ID_ATTR 15
/* 16 available */
/* 17 available */
#define SCM_NEXTIDENT 18 /* next exposed id is as if it begins a statement */
#define SCM_INTERFACE 19
/* 20 available */
/* 21 avaialble */
/* 22 available */
/* 23 available */
/* 24 available */
#define SCM_OPERATOR \
25 /* next id (presumably enclosed in '.'s) is a user- \
* efined operator or a named intrinsic operator */
#define SCM_LOOKFOR_OPERATOR 26 /* next id may be word 'operator' */
#define SCM_PAR 27
/* 28 available */
#define SCM_ACCEL 29
#define SCM_BIND 30 /* next id is keyword bind */
#define SCM_PROCEDURE 31
#define SCM_KERNEL 32
#define SCM_GENERIC 33
#define SCM_TYPEIS 34
#define SCM_DEFINED_IO 35
#define SCM_CHEVRON 36
#define SCM_LOCALITY 12
#define SCM_ALLOC 13
#define SCM_ID_ATTR 14
#define SCM_NEXTIDENT 15 /* next exposed id is as if it begins a statement */
#define SCM_INTERFACE 16
#define SCM_OPERATOR 17 /* next id (presumably enclosed in '.'s) is a
* user-defined or named intrinsic operator */
#define SCM_LOOKFOR_OPERATOR 18 /* next id may be word 'operator' */
#define SCM_PAR 19
#define SCM_ACCEL 20
#define SCM_BIND 21 /* next id is keyword bind */
#define SCM_PROCEDURE 22
#define SCM_KERNEL 23
#define SCM_GENERIC 24
#define SCM_TYPEIS 25
#define SCM_DEFINED_IO 26
#define SCM_CHEVRON 27
static int par_depth; /* current parentheses nesting depth */
static LOGICAL past_equal; /* set if past the equal sign */
@@ -793,6 +784,8 @@ _get_token(INT *tknv)
scmode = SCM_FIRST;
else if (follow_attr)
scmode = SCM_LOOKFOR_OPERATOR;
else if (is_doconcurrent)
scmode = SCM_LOCALITY;
}
tkntyp = TK_RPAREN;
if (bind_state == B_FUNC_FOUND) {
@@ -869,31 +862,37 @@ _get_token(INT *tknv)
goto ret_token;
case ':': /* return colon or coloncolon token: */
if (acb_depth > 0 && *currc == ':' && exp_ac && !lparen) {
currc++;
tkntyp = TK_COLONCOLON;
ionly = FALSE;
exp_ac = 0;
} else if (par_depth == 0 && exp_attr && *currc == ':') {
currc++;
exp_attr = FALSE;
if (scmode != SCM_GENERIC)
scmode = SCM_LOOKFOR_OPERATOR;
tkntyp = TK_COLONCOLON;
follow_attr = TRUE;
} else if (par1_attr && par_depth == 1 && scmode == SCM_ALLOC &&
*currc == ':') {
currc++;
par1_attr = FALSE;
tkntyp = TK_COLONCOLON;
ionly = FALSE;
} else {
tkntyp = TK_COLON;
if (scn.stmtyp == TK_USE) {
scmode = SCM_LOOKFOR_OPERATOR;
follow_attr = TRUE;
if (*currc == ':') {
if (acb_depth > 0 && exp_ac && !lparen) {
currc++;
tkntyp = TK_COLONCOLON;
exp_ac = 0;
ionly = false;
goto ret_token;
}
if (par_depth == 0 && exp_attr) {
currc++;
tkntyp = TK_COLONCOLON;
exp_attr = false;
follow_attr = true;
if (scmode != SCM_GENERIC)
scmode = SCM_LOOKFOR_OPERATOR;
goto ret_token;
}
if (par1_attr && par_depth == 1 &&
(scmode == SCM_ALLOC || is_doconcurrent || scn.stmtyp == TK_FORALL)) {
currc++;
tkntyp = TK_COLONCOLON;
ionly = false;
par1_attr = false;
goto ret_token;
}
}
tkntyp = TK_COLON;
if (scn.stmtyp == TK_USE) {
scmode = SCM_LOOKFOR_OPERATOR;
follow_attr = true;
}
goto ret_token;
case '=': /* return equals sign or eq compar. token */
@@ -1081,6 +1080,7 @@ get_stmt(void)
is_mem = FALSE;
is_ppragma = FALSE;
is_kernel = FALSE;
is_doconcurrent = false;
do {
again:
@@ -4329,7 +4329,9 @@ alpha(void)
--cp; /* point to first char after identifier
* string */
o_idlen = idlen = cp - currc;
/* step 2 - check scan mode to determine further processing */
switch (scmode) {
case SCM_FIRST: /* first token of a statement is to be
* processed */
@@ -4621,15 +4623,31 @@ alpha(void)
*/
tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
if (tkntyp == TK_WHILE || tkntyp == TK_CONCURRENT) {
is_doconcurrent = tkntyp == TK_CONCURRENT;
scmode = SCM_IDENT;
goto alpha_exit;
}
/*
* Could give an error message indicating that the WHILE/ONCURRENT keyword
* is expected.
* Could give an error message indicating that the WHILE/CONCURRENT
* keyword is expected.
*/
goto return_identifier;
case SCM_LOCALITY:
tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
switch (tkntyp) {
case TK_LOCAL:
case TK_LOCAL_INIT:
case TK_SHARED:
case TK_NONE:
scmode = SCM_IDENT;
goto alpha_exit;
case TK_DEFAULT:
// Remain in SCM_LOCALITY mode to look for NONE.
goto alpha_exit;
}
break;
case SCM_TYPEIS:
/* FS#19094 - in the context of "type is", check to see if these
* are a part of an identifier, or if they really are intrinsic
@@ -5663,6 +5681,12 @@ alpha(void)
/* step 4 - enter identifier into symtab and return it: */
return_identifier:
if (par1_attr == 1 && par_depth == 1 &&
(is_doconcurrent || scn.stmtyp == TK_FORALL)) {
tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
if (tkntyp == TK_INTEGER && o_idlen == idlen)
goto alpha_exit;
}
if (exp_ac) {
if (*cp == ' ')
cp++;
@@ -7600,6 +7624,7 @@ ff_get_stmt(void)
is_mem = FALSE;
is_ppragma = FALSE;
is_kernel = FALSE;
is_doconcurrent = false;
for (p = printbuff + 8; *p != '\0' && (isblank(*p));) {
++p;
Oops, something went wrong.

0 comments on commit c7ab041

Please sign in to comment.