1//===-- lib/Semantics/rewrite-directives.cpp ------------------------------===//
2//
3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4// See https://llvm.org/LICENSE.txt for license information.
5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6//
7//===----------------------------------------------------------------------===//
8
9#include "rewrite-directives.h"
10#include "flang/Parser/parse-tree-visitor.h"
11#include "flang/Parser/parse-tree.h"
12#include "flang/Semantics/semantics.h"
13#include "flang/Semantics/symbol.h"
14#include "llvm/Frontend/OpenMP/OMP.h"
15#include <list>
16
17namespace Fortran::semantics {
18
19using namespace parser::literals;
20
21class DirectiveRewriteMutator {
22public:
23 explicit DirectiveRewriteMutator(SemanticsContext &context)
24 : context_{context} {}
25
26 // Default action for a parse tree node is to visit children.
27 template <typename T> bool Pre(T &) { return true; }
28 template <typename T> void Post(T &) {}
29
30protected:
31 SemanticsContext &context_;
32};
33
34// Rewrite atomic constructs to add an explicit memory ordering to all that do
35// not specify it, honoring in this way the `atomic_default_mem_order` clause of
36// the REQUIRES directive.
37class OmpRewriteMutator : public DirectiveRewriteMutator {
38public:
39 explicit OmpRewriteMutator(SemanticsContext &context)
40 : DirectiveRewriteMutator(context) {}
41
42 template <typename T> bool Pre(T &) { return true; }
43 template <typename T> void Post(T &) {}
44
45 bool Pre(parser::OpenMPAtomicConstruct &);
46 bool Pre(parser::OpenMPRequiresConstruct &);
47
48private:
49 bool atomicDirectiveDefaultOrderFound_{false};
50};
51
52bool OmpRewriteMutator::Pre(parser::OpenMPAtomicConstruct &x) {
53 // Find top-level parent of the operation.
54 Symbol *topLevelParent{[&]() {
55 Symbol *symbol{nullptr};
56 Scope *scope{&context_.FindScope(
57 std::get<parser::OmpDirectiveSpecification>(x.t).source)};
58 do {
59 if (Symbol * parent{scope->symbol()}) {
60 symbol = parent;
61 }
62 scope = &scope->parent();
63 } while (!scope->IsGlobal());
64
65 assert(symbol &&
66 "Atomic construct must be within a scope associated with a symbol");
67 return symbol;
68 }()};
69
70 // Get the `atomic_default_mem_order` clause from the top-level parent.
71 std::optional<common::OmpMemoryOrderType> defaultMemOrder;
72 common::visit(
73 [&](auto &details) {
74 if constexpr (std::is_convertible_v<decltype(&details),
75 WithOmpDeclarative *>) {
76 if (details.has_ompAtomicDefaultMemOrder()) {
77 defaultMemOrder = *details.ompAtomicDefaultMemOrder();
78 }
79 }
80 },
81 topLevelParent->details());
82
83 if (!defaultMemOrder) {
84 return false;
85 }
86
87 auto findMemOrderClause{[](const parser::OmpClauseList &clauses) {
88 return llvm::any_of(
89 clauses.v, [](auto &clause) -> const parser::OmpClause * {
90 switch (clause.Id()) {
91 case llvm::omp::Clause::OMPC_acq_rel:
92 case llvm::omp::Clause::OMPC_acquire:
93 case llvm::omp::Clause::OMPC_relaxed:
94 case llvm::omp::Clause::OMPC_release:
95 case llvm::omp::Clause::OMPC_seq_cst:
96 return &clause;
97 default:
98 return nullptr;
99 }
100 });
101 }};
102
103 auto &dirSpec{std::get<parser::OmpDirectiveSpecification>(x.t)};
104 auto &clauseList{std::get<std::optional<parser::OmpClauseList>>(dirSpec.t)};
105 if (clauseList) {
106 if (findMemOrderClause(*clauseList)) {
107 return false;
108 }
109 } else {
110 clauseList = parser::OmpClauseList(decltype(parser::OmpClauseList::v){});
111 }
112
113 // Add a memory order clause to the atomic directive.
114 atomicDirectiveDefaultOrderFound_ = true;
115 switch (*defaultMemOrder) {
116 case common::OmpMemoryOrderType::Acq_Rel:
117 clauseList->v.emplace_back(parser::OmpClause{parser::OmpClause::AcqRel{}});
118 break;
119 case common::OmpMemoryOrderType::Relaxed:
120 clauseList->v.emplace_back(parser::OmpClause{parser::OmpClause::Relaxed{}});
121 break;
122 case common::OmpMemoryOrderType::Seq_Cst:
123 clauseList->v.emplace_back(parser::OmpClause{parser::OmpClause::SeqCst{}});
124 break;
125 default:
126 // FIXME: Don't process other values at the moment since their validity
127 // depends on the OpenMP version (which is unavailable here).
128 break;
129 }
130
131 return false;
132}
133
134bool OmpRewriteMutator::Pre(parser::OpenMPRequiresConstruct &x) {
135 for (parser::OmpClause &clause : std::get<parser::OmpClauseList>(x.t).v) {
136 if (std::holds_alternative<parser::OmpClause::AtomicDefaultMemOrder>(
137 clause.u) &&
138 atomicDirectiveDefaultOrderFound_) {
139 context_.Say(clause.source,
140 "REQUIRES directive with '%s' clause found lexically after atomic "
141 "operation without a memory order clause"_err_en_US,
142 parser::ToUpperCaseLetters(llvm::omp::getOpenMPClauseName(
143 llvm::omp::OMPC_atomic_default_mem_order)
144 .str()));
145 }
146 }
147 return false;
148}
149
150bool RewriteOmpParts(SemanticsContext &context, parser::Program &program) {
151 if (!context.IsEnabled(common::LanguageFeature::OpenMP)) {
152 return true;
153 }
154 OmpRewriteMutator ompMutator{context};
155 parser::Walk(program, ompMutator);
156 return !context.AnyFatalError();
157}
158
159} // namespace Fortran::semantics
160

source code of flang/lib/Semantics/rewrite-directives.cpp