[flang] Warn about impure calls in concurrent headers (llvm#108436)

Emit a warning when an impure function is referenced from a DO
CONCURRENT or FORALL concurrent-header that is not nested within another
such construct. (That nested case is already an error.)

Author: klausler

flang/lib/Semantics/check-do-forall.cpp

@@ -122,6 +122,10 @@ class DoConcurrentBodyEnforce {
     }
     return true;
   }
+  bool Pre(const parser::ConcurrentHeader &) {
+    // handled in CheckConcurrentHeader
+    return false;
+  }
   template <typename T> void Post(const T &) {}
 
   // C1140 -- Can't deallocate a polymorphic entity in a DO CONCURRENT.
@@ -375,8 +379,13 @@ class DoConcurrentVariableEnforce {
 // Find a DO or FORALL and enforce semantics checks on its body
 class DoContext {
 public:
-  DoContext(SemanticsContext &context, IndexVarKind kind, bool isNested)
-      : context_{context}, kind_{kind}, isNested_{isNested} {}
+  DoContext(SemanticsContext &context, IndexVarKind kind,
+      const std::list<IndexVarKind> nesting)
+      : context_{context}, kind_{kind} {
+    if (!nesting.empty()) {
+      concurrentNesting_ = nesting.back();
+    }
+  }
 
   // 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
@@ -439,8 +448,8 @@ class DoContext {
             common::visitors{[&](const auto &x) { return GetAssignment(x); }},
             stmt.u)}) {
       CheckForallIndexesUsed(*assignment);
-      CheckForImpureCall(assignment->lhs);
-      CheckForImpureCall(assignment->rhs);
+      CheckForImpureCall(assignment->lhs, kind_);
+      CheckForImpureCall(assignment->rhs, kind_);
 
       if (IsVariable(assignment->lhs)) {
         if (const Symbol * symbol{GetLastSymbol(assignment->lhs)}) {
@@ -455,23 +464,23 @@ class DoContext {
 
       if (const auto *proc{
               std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
-        CheckForImpureCall(*proc);
+        CheckForImpureCall(*proc, kind_);
       }
       common::visit(
           common::visitors{
               [](const evaluate::Assignment::Intrinsic &) {},
               [&](const evaluate::ProcedureRef &proc) {
-                CheckForImpureCall(proc);
+                CheckForImpureCall(proc, kind_);
               },
               [&](const evaluate::Assignment::BoundsSpec &bounds) {
                 for (const auto &bound : bounds) {
-                  CheckForImpureCall(SomeExpr{bound});
+                  CheckForImpureCall(SomeExpr{bound}, kind_);
                 }
               },
               [&](const evaluate::Assignment::BoundsRemapping &bounds) {
                 for (const auto &bound : bounds) {
-                  CheckForImpureCall(SomeExpr{bound.first});
-                  CheckForImpureCall(SomeExpr{bound.second});
+                  CheckForImpureCall(SomeExpr{bound.first}, kind_);
+                  CheckForImpureCall(SomeExpr{bound.second}, kind_);
                 }
               },
           },
@@ -754,12 +763,10 @@ class DoContext {
       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);
-        }
+      CheckForImpureCall(std::get<1>(control.t), concurrentNesting_);
+      CheckForImpureCall(std::get<2>(control.t), concurrentNesting_);
+      if (const auto &stride{std::get<3>(control.t)}) {
+        CheckForImpureCall(*stride, concurrentNesting_);
       }
     }
     if (!indexNames.empty()) {
@@ -819,20 +826,29 @@ class DoContext {
     CheckConcurrentHeader(std::get<parser::ConcurrentHeader>(concurrent.t));
   }
 
-  template <typename T> void CheckForImpureCall(const T &x) const {
+  template <typename T>
+  void CheckForImpureCall(
+      const T &x, std::optional<IndexVarKind> nesting) 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());
+      if (nesting) {
+        context_.Say(
+            "Impure procedure '%s' may not be referenced in a %s"_err_en_US,
+            *bad, LoopKindName(*nesting));
+      } else {
+        context_.Say(
+            "Impure procedure '%s' should not be referenced in a %s header"_warn_en_US,
+            *bad, LoopKindName(kind_));
+      }
     }
   }
-  void CheckForImpureCall(const parser::ScalarIntExpr &x) const {
+  void CheckForImpureCall(const parser::ScalarIntExpr &x,
+      std::optional<IndexVarKind> nesting) 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);
+        CheckForImpureCall(*expr, nesting);
       }
     }
     context_.set_location(oldLocation);
@@ -885,54 +901,59 @@ class DoContext {
   }
 
   // For messages where the DO loop must be DO CONCURRENT, make that explicit.
-  const char *LoopKindName() const {
-    return kind_ == IndexVarKind::DO ? "DO CONCURRENT" : "FORALL";
+  const char *LoopKindName(IndexVarKind kind) const {
+    return kind == IndexVarKind::DO ? "DO CONCURRENT" : "FORALL";
   }
+  const char *LoopKindName() const { return LoopKindName(kind_); }
 
   SemanticsContext &context_;
   const IndexVarKind kind_;
   parser::CharBlock currentStatementSourcePosition_;
-  bool isNested_{false};
+  std::optional<IndexVarKind> concurrentNesting_;
 }; // class DoContext
 
 void DoForallChecker::Enter(const parser::DoConstruct &doConstruct) {
-  DoContext doContext{context_, IndexVarKind::DO, constructNesting_ > 0};
+  DoContext doContext{context_, IndexVarKind::DO, nestedWithinConcurrent_};
+  if (doConstruct.IsDoConcurrent()) {
+    nestedWithinConcurrent_.push_back(IndexVarKind::DO);
+  }
   doContext.DefineDoVariables(doConstruct);
+  doContext.Check(doConstruct);
 }
 
 void DoForallChecker::Leave(const parser::DoConstruct &doConstruct) {
-  DoContext doContext{context_, IndexVarKind::DO, constructNesting_ > 0};
-  ++constructNesting_;
-  doContext.Check(doConstruct);
+  DoContext doContext{context_, IndexVarKind::DO, nestedWithinConcurrent_};
   doContext.ResetDoVariables(doConstruct);
-  --constructNesting_;
+  if (doConstruct.IsDoConcurrent()) {
+    nestedWithinConcurrent_.pop_back();
+  }
 }
 
 void DoForallChecker::Enter(const parser::ForallConstruct &construct) {
-  DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
+  DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
   doContext.ActivateIndexVars(GetControls(construct));
-  ++constructNesting_;
+  nestedWithinConcurrent_.push_back(IndexVarKind::FORALL);
   doContext.Check(construct);
 }
 void DoForallChecker::Leave(const parser::ForallConstruct &construct) {
-  DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
+  DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
   doContext.DeactivateIndexVars(GetControls(construct));
-  --constructNesting_;
+  nestedWithinConcurrent_.pop_back();
 }
 
 void DoForallChecker::Enter(const parser::ForallStmt &stmt) {
-  DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
-  ++constructNesting_;
+  DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
+  nestedWithinConcurrent_.push_back(IndexVarKind::FORALL);
   doContext.Check(stmt);
   doContext.ActivateIndexVars(GetControls(stmt));
 }
 void DoForallChecker::Leave(const parser::ForallStmt &stmt) {
-  DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
+  DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
   doContext.DeactivateIndexVars(GetControls(stmt));
-  --constructNesting_;
+  nestedWithinConcurrent_.pop_back();
 }
 void DoForallChecker::Leave(const parser::ForallAssignmentStmt &stmt) {
-  DoContext doContext{context_, IndexVarKind::FORALL, constructNesting_ > 0};
+  DoContext doContext{context_, IndexVarKind::FORALL, nestedWithinConcurrent_};
   doContext.Check(stmt);
 }
 

flang/lib/Semantics/check-do-forall.h

@@ -60,7 +60,7 @@ class DoForallChecker : public virtual BaseChecker {
 private:
   SemanticsContext &context_;
   int exprDepth_{0};
-  int constructNesting_{0};
+  std::list<SemanticsContext::IndexVarKind> nestedWithinConcurrent_;
 
   void SayBadLeave(
       StmtType, const char *enclosingStmt, const ConstructNode &) const;

flang/test/Semantics/OpenMP/workshare02.f90

@@ -40,6 +40,7 @@ subroutine workshare(aa, bb, cc, dd, ee, ff, n)
     cc = ee + my_func()
   end where
 
+  !WARNING: Impure procedure 'my_func' should not be referenced in a FORALL header
   !ERROR: User defined non-ELEMENTAL function 'my_func' is not allowed in a WORKSHARE construct
   forall (j = 1:my_func()) aa(j) = aa(j) + bb(j)
 

flang/test/Semantics/call11.f90

@@ -42,30 +42,36 @@ 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
+    !WARNING: Impure procedure 'impure' should not be referenced in a DO CONCURRENT header
+    do concurrent (k=impure(1):1); end do
+    !WARNING: Impure procedure 'impure' should not be referenced in a DO CONCURRENT header
+    do concurrent (k=1:impure(1)); end do
+    !WARNING: Impure procedure 'impure' should not be referenced in a DO CONCURRENT header
+    do concurrent (k=1:1:impure(1)); end do
+    !WARNING: Impure procedure 'impure' should not be referenced in a FORALL header
+    forall (k=impure(1):1); end forall
+    !WARNING: Impure procedure 'impure' should not be referenced in a FORALL header
+    forall (k=1:impure(1)); end forall
+    !WARNING: Impure procedure 'impure' should not be referenced in a FORALL header
+    forall (k=1:1:impure(1)); end forall
     do concurrent (j=1:1)
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       do concurrent (k=impure(1):1); end do
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       do concurrent (k=1:impure(1)); end do
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       do concurrent (k=1:1:impure(1)); end do
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       forall (k=impure(1):1); end forall
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       forall (k=1:impure(1)); end forall
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       forall (k=1:1:impure(1)); end forall
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       forall (k=impure(1):1) a(k) = 0.
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       forall (k=1:impure(1)) a(k) = 0.
-      !ERROR: Impure procedure 'impure' may not be referenced in DO CONCURRENT
+      !ERROR: Impure procedure 'impure' may not be referenced in a DO CONCURRENT
       forall (k=1:1:impure(1)) a(k) = 0.
     end do
     forall (j=1:1)