[flang][OpenMP] Fix copyprivate semantic checks

[luporl]

There are some cases in which variables used in OpenMP constructs
are predetermined as private. The semantic checks for copyprivate
were not handling those cases.

Besides that, shared symbols were not being properly represented
in some cases. When there was no previously declared private
(implicit) symbol, no new association symbols, representing
shared ones, were being created.

These symbols must always be inserted in constructs that may
privatize the original symbol: parallel, teams and task
generating constructs.

Fixes #87214 and #86907

[llvmbot]

@llvm/pr-subscribers-flang-openmp

@llvm/pr-subscribers-flang-semantics

Author: Leandro Lupori (luporl)

Changes

There are some cases in which variables used in OpenMP constructs
are predetermined as private. The semantic checks for copyprivate
were not handling those cases.

Fixes #87214 and #86907

---

Full diff: https://github.com/llvm/llvm-project/pull/95799.diff

3 Files Affected:

• (modified) flang/include/flang/Semantics/tools.h (+1)
• (modified) flang/lib/Semantics/resolve-directives.cpp (+38-5)
• (added) flang/test/Semantics/OpenMP/copyprivate04.f90 (+84)

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 0b5308d9242de..5afbacbbbeea7 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -87,6 +87,7 @@ bool IsIntrinsicConcat(
 bool IsGenericDefinedOp(const Symbol &);
 bool IsDefinedOperator(SourceName);
 std::string MakeOpName(SourceName);
+bool IsCommonBlockContaining(const Symbol &, const Symbol &);
 
 // Returns true if maybeAncestor exists and is a proper ancestor of a
 // descendent scope (or symbol owner).  Will be false, unlike Scope::Contains(),
diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp
index dbc531372c3f4..e13a3c076abed 100644
--- a/flang/lib/Semantics/resolve-directives.cpp
+++ b/flang/lib/Semantics/resolve-directives.cpp
@@ -19,6 +19,7 @@
 #include "flang/Parser/parse-tree.h"
 #include "flang/Parser/tools.h"
 #include "flang/Semantics/expression.h"
+#include "flang/Semantics/tools.h"
 #include <list>
 #include <map>
 #include <sstream>
@@ -2540,6 +2541,32 @@ void ResolveOmpTopLevelParts(
   });
 }
 
+static bool IsSymbolInCommonBlock(const Symbol &symbol) {
+  // If there are many symbols in common blocks, going through them all can be
+  // slow. A possible optimization is to add an OmpInCommonBlock flag to
+  // Symbol, to make it possible to quickly test if a given symbol is in a
+  // common block.
+  for (const auto &cb : symbol.owner().commonBlocks()) {
+    if (IsCommonBlockContaining(cb.second.get(), symbol)) {
+      return true;
+    }
+  }
+  return false;
+}
+
+static bool IsSymbolPredeterminedAsPrivate(const Symbol &symbol) {
+  switch (symbol.owner().kind()) {
+  case Scope::Kind::MainProgram:
+  case Scope::Kind::Subprogram:
+  case Scope::Kind::BlockConstruct:
+    return !symbol.attrs().test(Attr::SAVE) &&
+        !symbol.attrs().test(Attr::PARAMETER) && !IsAssumedShape(symbol) &&
+        !IsSymbolInCommonBlock(symbol);
+  default:
+    return false;
+  }
+}
+
 void OmpAttributeVisitor::CheckDataCopyingClause(
     const parser::Name &name, const Symbol &symbol, Symbol::Flag ompFlag) {
   const auto *checkSymbol{&symbol};
@@ -2566,13 +2593,19 @@ void OmpAttributeVisitor::CheckDataCopyingClause(
           "COPYPRIVATE variable '%s' may not appear on a PRIVATE or "
           "FIRSTPRIVATE clause on a SINGLE construct"_err_en_US,
           symbol.name());
-    } else {
+    } else if (!checkSymbol->test(Symbol::Flag::OmpThreadprivate) &&
+        !(HasSymbolInEnclosingScope(symbol, currScope()) &&
+            (symbol.test(Symbol::Flag::OmpPrivate) ||
+                symbol.test(Symbol::Flag::OmpFirstPrivate)))) {
       // List of items/objects that can appear in a 'copyprivate' clause must be
       // either 'private' or 'threadprivate' in enclosing context.
-      if (!checkSymbol->test(Symbol::Flag::OmpThreadprivate) &&
-          !(HasSymbolInEnclosingScope(symbol, currScope()) &&
-              (symbol.test(Symbol::Flag::OmpPrivate) ||
-                  symbol.test(Symbol::Flag::OmpFirstPrivate)))) {
+      // If the symbol used in 'copyprivate' has not gone through constructs
+      // that may privatize the original symbol, then it may be predetermined
+      // as private in some cases.
+      // (OMP 5.2 5.1.1 - Variables Referenced in a Construct)
+      if (!HasSymbolInEnclosingScope(symbol, currScope()) ||
+          symbol != symbol.GetUltimate() ||
+          !IsSymbolPredeterminedAsPrivate(symbol)) {
         context_.Say(name.source,
             "COPYPRIVATE variable '%s' is not PRIVATE or THREADPRIVATE in "
             "outer context"_err_en_US,
diff --git a/flang/test/Semantics/OpenMP/copyprivate04.f90 b/flang/test/Semantics/OpenMP/copyprivate04.f90
new file mode 100644
index 0000000000000..5db3caf9b6964
--- /dev/null
+++ b/flang/test/Semantics/OpenMP/copyprivate04.f90
@@ -0,0 +1,84 @@
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp
+! OpenMP Version 5.2
+! 5.1.1 - Variables Referenced in a Construct
+! Copyprivate must accept variables that are predetermined as private.
+
+module m1
+  integer :: m
+end module
+
+program omp_copyprivate
+  use m1
+  implicit none
+  integer :: i
+  integer, save :: j
+  integer :: k
+  common /c/ k
+  real, parameter :: pi = 3.14
+  integer :: a1(10)
+
+  ! Local variables are private.
+  !$omp single
+    i = 123
+  !$omp end single copyprivate(i)
+  !$omp single
+  !$omp end single copyprivate(a1)
+
+  ! Variables with the SAVE attribute are not private.
+  !$omp single
+  !ERROR: COPYPRIVATE variable 'j' is not PRIVATE or THREADPRIVATE in outer context
+  !$omp end single copyprivate(j)
+
+  ! Common block variables are not private.
+  !$omp single
+  !ERROR: COPYPRIVATE variable 'k' is not PRIVATE or THREADPRIVATE in outer context
+  !$omp end single copyprivate(/c/)
+  !$omp single
+  !ERROR: COPYPRIVATE variable 'k' is not PRIVATE or THREADPRIVATE in outer context
+  !$omp end single copyprivate(k)
+
+  ! Module variables are not private.
+  !$omp single
+  !ERROR: COPYPRIVATE variable 'm' is not PRIVATE or THREADPRIVATE in outer context
+  !$omp end single copyprivate(m)
+
+  ! Parallel can make a variable shared.
+  !$omp parallel
+    !$omp single
+    !ERROR: COPYPRIVATE variable 'i' is not PRIVATE or THREADPRIVATE in outer context
+    !$omp end single copyprivate(i)
+    call sub(j, a1)
+  !$omp end parallel
+
+  ! Named constants are shared.
+  !$omp single
+  !ERROR: COPYPRIVATE variable 'pi' is not PRIVATE or THREADPRIVATE in outer context
+  !$omp end single copyprivate(pi)
+
+contains
+  subroutine sub(s1, a)
+    integer :: s1
+    integer :: a(:)
+
+    ! Dummy argument.
+    !$omp single
+    !$omp end single copyprivate(s1)
+
+    ! Assumed shape arrays are shared.
+    !$omp single
+    !ERROR: COPYPRIVATE variable 'a' is not PRIVATE or THREADPRIVATE in outer context
+    !$omp end single copyprivate(a)
+  end subroutine
+
+  integer function fun(f1)
+    integer :: f1
+
+    ! Dummy argument.
+    !$omp single
+    !$omp end single copyprivate(f1)
+
+    ! Function result is private.
+    !$omp single
+    !$omp end single copyprivate(fun)
+  end function
+end program

[luporl]

The copyprivate checks should behave correctly now, in all cases that I'm aware of.
Some symbols that represent variables with shared DSA were missing too. These were added, which required the update of some tests. I also did a slight code refactoring.

[tblah]

LGTM, but please wait for review from somebody else.

[luporl]

Thanks for the review @tblah.

Ping for other reviews.

[NimishMishra]

Ping for other reviews.

Sorry for the delay. I'll a look and revert, latest by tomorrow.

[NimishMishra]

Thanks for the patch. LGTM overall

[psteinfeld]

@luporl, after this change, I'm seeing errors in our internal test suites. Here's a program that produces similar errors:

[pete@rome3 install]$cat bug.f90
program bug
  use omp_lib
  implicit none
  integer i1,i2,i3,m
  type derived
    integer field(2,3)
  end type
  type(derived) y(5)
  integer,parameter :: nt = 2
  integer field(nt)
  field = 0
  m = 1
  !$OMP PARALLEL DO NUM_THREADS(nt) PRIVATE(m) DEFAULT(NONE) SHARED(y,field) &
  !$OMP COLLAPSE(2) SCHEDULE(STATIC)
  do i1=1,size(y,1)
    do i3=1,3
      do i2=1,2
        y(i1)%field(i2,i3) = 1
        !$omp atomic
        field(m) = field(m) + 1 !error here
      end do
    end do
  end do
  !$OMP END PARALLEL DO
end program

flang-new -fopenmp -fopenmp-version=31 bug.f90 
error: Semantic errors in bug.f90
./bug.f90:20:9: error: Reference to rank-2 object 'field' has 1 subscripts
          field(m) = field(m) + 1 !error here
          ^^^^^^^^
./bug.f90:20:20: error: Reference to rank-2 object 'field' has 1 subscripts
          field(m) = field(m) + 1 !error here
                     ^^^^^^^^

Before you merged this change, this program compiled cleanly. Can you please either revert or fix this?

[luporl]

@psteinfeld Reverted. I'll need some time to investigate this error.

[tblah]

A minimised test of ours which failed too (posting in addition in case it helps the investigation):

program omp_associate_min
  integer, parameter :: l = 42
  integer :: a(l)
  integer :: i
  a = 1

  !$omp parallel do
  do i = 1,l
    associate (b=>a)
      b(i) = b(i) * 2
    end associate
  enddo
  !$omp end parallel do
end program

Thanks for the quick revert and cherry-pick to the release branch.

[luporl]

Thanks for the feedback @psteinfeld and @tblah.
The regressions should be fixed in #101009.
Please check if it fixes your tests.