diff --git a/flang/include/flang/Lower/OpenACC.h b/flang/include/flang/Lower/OpenACC.h --- a/flang/include/flang/Lower/OpenACC.h +++ b/flang/include/flang/Lower/OpenACC.h @@ -12,6 +12,7 @@ namespace Fortran { namespace parser { struct OpenACCConstruct; +struct AccEndCombinedDirective; } // namespace parser namespace lower { @@ -25,6 +26,9 @@ void genOpenACCConstruct(AbstractConverter &, pft::Evaluation &, const parser::OpenACCConstruct &); +void genOpenACCEndCombined(AbstractConverter &, pft::Evaluation &, + const parser::AccEndCombinedDirective &); + } // namespace lower } // namespace Fortran diff --git a/flang/include/flang/Lower/PFTBuilder.h b/flang/include/flang/Lower/PFTBuilder.h --- a/flang/include/flang/Lower/PFTBuilder.h +++ b/flang/include/flang/Lower/PFTBuilder.h @@ -132,7 +132,8 @@ using Directives = std::tuple; + parser::AccEndCombinedDirective, parser::OpenMPConstruct, + parser::OmpEndLoopDirective>; template static constexpr bool isActionStmt{common::HasMember}; diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -258,6 +258,7 @@ struct AssignedGotoStmt; struct PauseStmt; struct OpenACCConstruct; +struct AccEndCombinedDirective; struct OpenACCDeclarativeConstruct; struct OpenMPConstruct; struct OpenMPDeclarativeConstruct; @@ -515,6 +516,7 @@ common::Indirection, common::Indirection, common::Indirection, common::Indirection, + common::Indirection, common::Indirection, common::Indirection> u; @@ -4037,6 +4039,7 @@ struct AccBeginCombinedDirective { TUPLE_CLASS_BOILERPLATE(AccBeginCombinedDirective); + CharBlock source; std::tuple t; }; @@ -4048,7 +4051,9 @@ struct OpenACCCombinedConstruct { TUPLE_CLASS_BOILERPLATE(OpenACCCombinedConstruct); CharBlock source; - std::tuple, std::optional> t; }; diff --git a/flang/lib/Lower/OpenACC.cpp b/flang/lib/Lower/OpenACC.cpp --- a/flang/lib/Lower/OpenACC.cpp +++ b/flang/lib/Lower/OpenACC.cpp @@ -46,3 +46,9 @@ }, accConstruct.u); } + +void Fortran::lower::genOpenACCEndCombined( + Fortran::lower::AbstractConverter &, Fortran::lower::pft::Evaluation &, + const Fortran::parser::AccEndCombinedDirective &) { + TODO(); +} diff --git a/flang/lib/Parser/executable-parsers.cpp b/flang/lib/Parser/executable-parsers.cpp --- a/flang/lib/Parser/executable-parsers.cpp +++ b/flang/lib/Parser/executable-parsers.cpp @@ -50,8 +50,9 @@ construct(indirect(whereConstruct)), construct(indirect(forallConstruct)), construct(indirect(ompEndLoopDirective)), - construct(indirect(openaccConstruct)), construct(indirect(openmpConstruct)), + construct(indirect(accEndCombinedDirective)), + construct(indirect(openaccConstruct)), construct(indirect(compilerDirective)))}; // R510 execution-part-construct -> diff --git a/flang/lib/Parser/openacc-parsers.cpp b/flang/lib/Parser/openacc-parsers.cpp --- a/flang/lib/Parser/openacc-parsers.cpp +++ b/flang/lib/Parser/openacc-parsers.cpp @@ -199,16 +199,9 @@ parenthesized(Parser{})))) // 2.11 Combined constructs -TYPE_PARSER(startAccLine >> construct(sourced( - "END"_tok >> Parser{}))) - TYPE_PARSER(construct( sourced(Parser{}), Parser{})) -TYPE_PARSER(construct( - Parser{} / endAccLine, block, - maybe(Parser{} / endAccLine))) - // 2.12 Atomic constructs TYPE_PARSER(construct(startAccLine >> "END ATOMIC"_tok)) @@ -281,4 +274,11 @@ construct(Parser{}), construct(Parser{}), construct(Parser{}))) + +TYPE_PARSER(startAccLine >> sourced(construct(sourced( + "END"_tok >> Parser{})))) + +TYPE_PARSER(construct( + sourced(Parser{} / endAccLine))) + } // namespace Fortran::parser diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp --- a/flang/lib/Parser/program-parsers.cpp +++ b/flang/lib/Parser/program-parsers.cpp @@ -77,9 +77,10 @@ // are allowed, and so we have a variant production for declaration-construct // that implements those constraints. constexpr auto execPartLookAhead{first(actionStmt >> ok, - ompEndLoopDirective >> ok, openaccConstruct >> ok, openmpConstruct >> ok, - "ASSOCIATE ("_tok, "BLOCK"_tok, "SELECT"_tok, "CHANGE TEAM"_sptok, - "CRITICAL"_tok, "DO"_tok, "IF ("_tok, "WHERE ("_tok, "FORALL ("_tok)}; + ompEndLoopDirective >> ok, accEndCombinedDirective >> ok, + openaccConstruct >> ok, openmpConstruct >> ok, "ASSOCIATE ("_tok, + "BLOCK"_tok, "SELECT"_tok, "CHANGE TEAM"_sptok, "CRITICAL"_tok, "DO"_tok, + "IF ("_tok, "WHERE ("_tok, "FORALL ("_tok)}; constexpr auto declErrorRecovery{ stmtErrorRecoveryStart >> !execPartLookAhead >> skipStmtErrorRecovery}; constexpr auto misplacedSpecificationStmt{Parser{} >> diff --git a/flang/lib/Parser/type-parsers.h b/flang/lib/Parser/type-parsers.h --- a/flang/lib/Parser/type-parsers.h +++ b/flang/lib/Parser/type-parsers.h @@ -131,6 +131,7 @@ constexpr Parser containsStmt; // R1543 constexpr Parser compilerDirective; constexpr Parser openaccConstruct; +constexpr Parser accEndCombinedDirective; constexpr Parser openaccDeclarativeConstruct; constexpr Parser openmpConstruct; constexpr Parser openmpDeclarativeConstruct; diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -2104,10 +2104,9 @@ Walk(std::get(x.t)); Put("\n"); EndOpenACC(); - Walk(std::get(x.t), ""); + Walk(std::get>(x.t)); BeginOpenACC(); - Word("!$ACC END "); - Walk(std::get>(x.t)); + Walk("!$ACC END ", std::get>(x.t)); Put("\n"); EndOpenACC(); } diff --git a/flang/lib/Semantics/canonicalize-acc.cpp b/flang/lib/Semantics/canonicalize-acc.cpp --- a/flang/lib/Semantics/canonicalize-acc.cpp +++ b/flang/lib/Semantics/canonicalize-acc.cpp @@ -16,6 +16,9 @@ // 1. move structured DoConstruct into // OpenACCLoopConstruct. Compilation will not proceed in case of errors // after this pass. +// 2. move structured DoConstruct into OpenACCCombinedConstruct. Move +// AccEndCombinedConstruct into OpenACCCombinedConstruct if present. +// Compilation will not proceed in case of errors after this pass. namespace Fortran::semantics { using namespace parser::literals; @@ -30,6 +33,16 @@ for (auto it{block.begin()}; it != block.end(); ++it) { if (auto *accLoop{parser::Unwrap(*it)}) { RewriteOpenACCLoopConstruct(*accLoop, block, it); + } else if (auto *accCombined{ + parser::Unwrap(*it)}) { + RewriteOpenACCCombinedConstruct(*accCombined, block, it); + } else if (auto *endDir{ + parser::Unwrap(*it)}) { + // Unmatched AccEndCombinedDirective + messages_.Say(endDir->v.source, + "The %s directive must follow the DO loop associated with the " + "loop construct"_err_en_US, + parser::ToUpperCaseLetters(endDir->v.source.ToString())); } } // Block list } @@ -73,6 +86,55 @@ parser::ToUpperCaseLetters(dir.source.ToString())); } + void RewriteOpenACCCombinedConstruct(parser::OpenACCCombinedConstruct &x, + parser::Block &block, parser::Block::iterator it) { + // Check the sequence of DoConstruct in the same iteration + // + // Original: + // ExecutableConstruct -> OpenACCConstruct -> OpenACCCombinedConstruct + // ACCBeginCombinedDirective + // ExecutableConstruct -> DoConstruct + // ExecutableConstruct -> AccEndCombinedDirective (if available) + // + // After rewriting: + // ExecutableConstruct -> OpenACCConstruct -> OpenACCCombinedConstruct + // ACCBeginCombinedDirective + // DoConstruct + // AccEndCombinedDirective (if available) + parser::Block::iterator nextIt; + auto &beginDir{std::get(x.t)}; + auto &dir{std::get(beginDir.t)}; + + nextIt = it; + if (++nextIt != block.end()) { + if (auto *doCons{parser::Unwrap(*nextIt)}) { + if (doCons->GetLoopControl()) { + // move DoConstruct + std::get>(x.t) = + std::move(*doCons); + nextIt = block.erase(nextIt); + // try to match AccEndCombinedDirective + if (nextIt != block.end()) { + if (auto *endDir{ + parser::Unwrap(*nextIt)}) { + std::get>(x.t) = + std::move(*endDir); + block.erase(nextIt); + } + } + } else { + messages_.Say(dir.source, + "DO loop after the %s directive must have loop control"_err_en_US, + parser::ToUpperCaseLetters(dir.source.ToString())); + } + return; // found do-loop + } + } + messages_.Say(dir.source, + "A DO loop must follow the %s directive"_err_en_US, + parser::ToUpperCaseLetters(dir.source.ToString())); + } + parser::Messages &messages_; }; diff --git a/flang/lib/Semantics/check-acc-structure.cpp b/flang/lib/Semantics/check-acc-structure.cpp --- a/flang/lib/Semantics/check-acc-structure.cpp +++ b/flang/lib/Semantics/check-acc-structure.cpp @@ -156,9 +156,17 @@ } void AccStructureChecker::Enter(const parser::OpenACCCombinedConstruct &x) { - const auto &beginBlockDir{std::get(x.t)}; + const auto &beginCombinedDir{ + std::get(x.t)}; const auto &combinedDir{ - std::get(beginBlockDir.t)}; + std::get(beginCombinedDir.t)}; + + // check matching, End directive is optional + if (const auto &endCombinedDir{ + std::get>(x.t)}) { + CheckMatching(combinedDir, endCombinedDir->v); + } + PushContextAndClauseSets(combinedDir.source, combinedDir.v); } diff --git a/flang/test/Lower/pre-fir-tree05.f90 b/flang/test/Lower/pre-fir-tree05.f90 --- a/flang/test/Lower/pre-fir-tree05.f90 +++ b/flang/test/Lower/pre-fir-tree05.f90 @@ -31,3 +31,20 @@ end subroutine ! CHECK-NEXT: EndSubroutine foo +! CHECK: Subroutine foo +subroutine foo2() + ! CHECK-NEXT: <> + !$acc parallel loop + ! CHECK-NEXT: <> + ! CHECK-NEXT: NonLabelDoStmt + do i=1,5 + ! CHECK-NEXT: EndDoStmt + ! CHECK-NEXT: <> + end do + !$acc end parallel loop + ! CHECK: <> + ! CHECK-NEXT: <> + ! CHECK-NEXT: ContinueStmt +end subroutine +! CHECK-NEXT: EndSubroutine foo2 + diff --git a/flang/test/Semantics/acc-canonicalization-validity.f90 b/flang/test/Semantics/acc-canonicalization-validity.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/acc-canonicalization-validity.f90 @@ -0,0 +1,95 @@ +! RUN: %S/test_errors.sh %s %t %f18 -fopenacc + +! Check OpenACC canonalization validity for the construct defined below: +! 2.9 Loop +! 2.11 Parallel Loop +! 2.11 Kernels Loop +! 2.11 Serial Loop + +program openacc_clause_validity + + implicit none + + integer :: i, j + integer :: N = 256 + real(8) :: a(256) + + !ERROR: A DO loop must follow the LOOP directive + !$acc loop + i = 1 + + !ERROR: DO loop after the LOOP directive must have loop control + !$acc loop + do + end do + + !ERROR: A DO loop must follow the PARALLEL LOOP directive + !$acc parallel loop + i = 1 + + !ERROR: A DO loop must follow the KERNELS LOOP directive + !$acc kernels loop + i = 1 + + !ERROR: A DO loop must follow the SERIAL LOOP directive + !$acc serial loop + i = 1 + + !ERROR: The END PARALLEL LOOP directive must follow the DO loop associated with the loop construct + !$acc end parallel loop + + !ERROR: The END KERNELS LOOP directive must follow the DO loop associated with the loop construct + !$acc end kernels loop + + !ERROR: The END SERIAL LOOP directive must follow the DO loop associated with the loop construct + !$acc end serial loop + + !$acc parallel loop + do i = 1, N + a(i) = 3.14 + end do + + !$acc kernels loop + do i = 1, N + a(i) = 3.14 + end do + + !$acc serial loop + do i = 1, N + a(i) = 3.14 + end do + + !$acc parallel loop + do i = 1, N + a(i) = 3.14 + end do + !$acc end parallel loop + + !$acc kernels loop + do i = 1, N + a(i) = 3.14 + end do + !$acc end kernels loop + + !$acc serial loop + do i = 1, N + a(i) = 3.14 + end do + !$acc end serial loop + + !ERROR: DO loop after the PARALLEL LOOP directive must have loop control + !$acc parallel loop + do + end do + + !ERROR: DO loop after the KERNELS LOOP directive must have loop control + !$acc kernels loop + do + end do + + !ERROR: DO loop after the SERIAL LOOP directive must have loop control + !$acc serial loop + do + end do + +end program openacc_clause_validity diff --git a/flang/test/Semantics/acc-clause-validity.f90 b/flang/test/Semantics/acc-clause-validity.f90 --- a/flang/test/Semantics/acc-clause-validity.f90 +++ b/flang/test/Semantics/acc-clause-validity.f90 @@ -5,6 +5,10 @@ ! 2.5.1 Parallel ! 2.5.2 Kernels ! 2.5.3 Serial +! 2.9 Loop +! 2.13 Declare +! 2.14.3 Set +! 2.14.4 Update ! 2.15.1 Routine ! 2.11 Parallel Loop ! 2.11 Kernels Loop @@ -162,6 +166,27 @@ end do !$acc end serial loop + !$acc parallel loop + do i = 1, N + a(i) = 3.14 + end do + !ERROR: Unmatched END KERNELS LOOP directive + !$acc end kernels loop + + !$acc kernels loop + do i = 1, N + a(i) = 3.14 + end do + !ERROR: Unmatched END SERIAL LOOP directive + !$acc end serial loop + + !$acc serial loop + do i = 1, N + a(i) = 3.14 + end do + !ERROR: Unmatched END PARALLEL LOOP directive + !$acc end parallel loop + contains subroutine sub1(a)