[flang-commits] [flang] 9390eb9 - [flang] Catch impure calls in nested concurrent-headers (#102075)
via flang-commits
flang-commits at lists.llvm.org
Thu Aug 8 11:06:56 PDT 2024
Author: Peter Klausler
Date: 2024-08-08T11:06:52-07:00
New Revision: 9390eb92212a584db75101d7e0ecd3f8819cd201
URL: https://github.com/llvm/llvm-project/commit/9390eb92212a584db75101d7e0ecd3f8819cd201
DIFF: https://github.com/llvm/llvm-project/commit/9390eb92212a584db75101d7e0ecd3f8819cd201.diff
LOG: [flang] Catch impure calls in nested concurrent-headers (#102075)
The start, end, and stride expressions of a concurrent-header in a DO
CONCURRENT or FORALL statement can contain calls to impure functions...
unless they appear in a statement that's nested in an enclosing DO
CONCURRENT or FORALL construct. Ensure that we catch this nested case.
Added:
Modified:
flang/lib/Semantics/check-do-forall.cpp
flang/lib/Semantics/check-do-forall.h
flang/test/Semantics/call11.f90
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 34225cd406192..e55a01d80acfb 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -269,8 +269,7 @@ class DoConcurrentBodyEnforce {
const parser::CharBlock statementLocation{
GetImageControlStmtLocation(construct)};
auto &msg{context_.Say(statementLocation,
- "An image control statement is not allowed in DO"
- " CONCURRENT"_err_en_US)};
+ "An image control statement is not allowed in DO CONCURRENT"_err_en_US)};
if (auto coarrayMsg{GetImageControlStmtCoarrayMsg(construct)}) {
msg.Attach(statementLocation, *coarrayMsg);
}
@@ -372,8 +371,8 @@ class DoConcurrentVariableEnforce {
// Find a DO or FORALL and enforce semantics checks on its body
class DoContext {
public:
- DoContext(SemanticsContext &context, IndexVarKind kind)
- : context_{context}, kind_{kind} {}
+ DoContext(SemanticsContext &context, IndexVarKind kind, bool isNested)
+ : context_{context}, kind_{kind}, isNested_{isNested} {}
// Mark this DO construct as a point of definition for the DO variables
// or index-names it contains. If they're already defined, emit an error
@@ -743,13 +742,21 @@ class DoContext {
std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {
CheckMaskIsPure(*mask);
}
- auto &controls{std::get<std::list<parser::ConcurrentControl>>(header.t)};
+ const auto &controls{
+ std::get<std::list<parser::ConcurrentControl>>(header.t)};
UnorderedSymbolSet indexNames;
for (const parser::ConcurrentControl &control : controls) {
const auto &indexName{std::get<parser::Name>(control.t)};
if (indexName.symbol) {
indexNames.insert(*indexName.symbol);
}
+ if (isNested_) {
+ CheckForImpureCall(std::get<1>(control.t));
+ CheckForImpureCall(std::get<2>(control.t));
+ if (const auto &stride{std::get<3>(control.t)}) {
+ CheckForImpureCall(*stride);
+ }
+ }
}
if (!indexNames.empty()) {
for (const parser::ConcurrentControl &control : controls) {
@@ -808,13 +815,24 @@ class DoContext {
CheckConcurrentHeader(std::get<parser::ConcurrentHeader>(concurrent.t));
}
- template <typename T> void CheckForImpureCall(const T &x) {
+ template <typename T> void CheckForImpureCall(const T &x) const {
if (auto bad{FindImpureCall(context_.foldingContext(), x)}) {
context_.Say(
"Impure procedure '%s' may not be referenced in a %s"_err_en_US, *bad,
LoopKindName());
}
}
+ void CheckForImpureCall(const parser::ScalarIntExpr &x) const {
+ const auto &parsedExpr{x.thing.thing.value()};
+ auto oldLocation{context_.location()};
+ context_.set_location(parsedExpr.source);
+ if (const auto &typedExpr{parsedExpr.typedExpr}) {
+ if (const auto &expr{typedExpr->v}) {
+ CheckForImpureCall(*expr);
+ }
+ }
+ context_.set_location(oldLocation);
+ }
// Each index should be used on the LHS of each assignment in a FORALL
void CheckForallIndexesUsed(const evaluate::Assignment &assignment) {
@@ -870,40 +888,47 @@ class DoContext {
SemanticsContext &context_;
const IndexVarKind kind_;
parser::CharBlock currentStatementSourcePosition_;
+ bool isNested_{false};
}; // class DoContext
void DoForallChecker::Enter(const parser::DoConstruct &doConstruct) {
- DoContext doContext{context_, IndexVarKind::DO};
+ DoContext doContext{context_, IndexVarKind::DO, constructNesting_ > 0};
doContext.DefineDoVariables(doConstruct);
}
void DoForallChecker::Leave(const parser::DoConstruct &doConstruct) {
- DoContext doContext{context_, IndexVarKind::DO};
+ DoContext doContext{context_, IndexVarKind::DO, constructNesting_ > 0};
+ ++constructNesting_;
doContext.Check(doConstruct);
doContext.ResetDoVariables(doConstruct);
+ --constructNesting_;
}
void DoForallChecker::Enter(const parser::ForallConstruct &construct) {
- DoContext doContext{context_, IndexVarKind::FORALL};
+ DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
doContext.ActivateIndexVars(GetControls(construct));
+ ++constructNesting_;
+ doContext.Check(construct);
}
void DoForallChecker::Leave(const parser::ForallConstruct &construct) {
- DoContext doContext{context_, IndexVarKind::FORALL};
- doContext.Check(construct);
+ DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
doContext.DeactivateIndexVars(GetControls(construct));
+ --constructNesting_;
}
void DoForallChecker::Enter(const parser::ForallStmt &stmt) {
- DoContext doContext{context_, IndexVarKind::FORALL};
+ DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
+ ++constructNesting_;
+ doContext.Check(stmt);
doContext.ActivateIndexVars(GetControls(stmt));
}
void DoForallChecker::Leave(const parser::ForallStmt &stmt) {
- DoContext doContext{context_, IndexVarKind::FORALL};
- doContext.Check(stmt);
+ DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
doContext.DeactivateIndexVars(GetControls(stmt));
+ --constructNesting_;
}
void DoForallChecker::Leave(const parser::ForallAssignmentStmt &stmt) {
- DoContext doContext{context_, IndexVarKind::FORALL};
+ DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
doContext.Check(stmt);
}
diff --git a/flang/lib/Semantics/check-do-forall.h b/flang/lib/Semantics/check-do-forall.h
index 3b2ae59f5f3ff..f08ff3467d4cc 100644
--- a/flang/lib/Semantics/check-do-forall.h
+++ b/flang/lib/Semantics/check-do-forall.h
@@ -60,6 +60,7 @@ class DoForallChecker : public virtual BaseChecker {
private:
SemanticsContext &context_;
int exprDepth_{0};
+ int constructNesting_{0};
void SayBadLeave(
StmtType, const char *enclosingStmt, const ConstructNode &) const;
diff --git a/flang/test/Semantics/call11.f90 b/flang/test/Semantics/call11.f90
index f4f4740795562..7bc4931890dee 100644
--- a/flang/test/Semantics/call11.f90
+++ b/flang/test/Semantics/call11.f90
@@ -42,6 +42,46 @@ subroutine test
!ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
a(j) = impure(j) ! C1139
end do
+ do concurrent (k=impure(1):1); end do ! ok
+ do concurrent (k=1:impure(1)); end do ! ok
+ do concurrent (k=1:1:impure(1)); end do ! ok
+ forall (k=impure(1):1); end forall ! ok
+ forall (k=1:impure(1)); end forall ! ok
+ forall (k=1:1:impure(1)); end forall ! ok
+ do concurrent (j=1:1)
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ do concurrent (k=impure(1):1); end do
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ do concurrent (k=1:impure(1)); end do
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ do concurrent (k=1:1:impure(1)); end do
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ forall (k=impure(1):1); end forall
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ forall (k=1:impure(1)); end forall
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ forall (k=1:1:impure(1)); end forall
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ forall (k=impure(1):1) a(k) = 0.
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ forall (k=1:impure(1)) a(k) = 0.
+ !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+ forall (k=1:1:impure(1)) a(k) = 0.
+ end do
+ forall (j=1:1)
+ !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
+ forall (k=impure(1):1); end forall
+ !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
+ forall (k=1:impure(1)); end forall
+ !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
+ forall (k=1:1:impure(1)); end forall
+ !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
+ forall (k=impure(1):1) a(j*k) = 0.
+ !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
+ forall (k=1:impure(1)) a(j*k) = 0.
+ !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
+ forall (k=1:1:impure(1)) a(j*k) = 0.
+ end forall
end subroutine
subroutine test2
More information about the flang-commits
mailing list