[flang-commits] [flang] [flang][cuda] Allow SHARED actual to DEVICE dummy (PR #115215)

[Valentin Clement バレンタイン クレメン via flang-commits]

https://github.com/clementval created https://github.com/llvm/llvm-project/pull/115215

Update the compatibility rules to allow SHARED actual argument passed to DEVICE dummy argument. Emit a warning in that case.

>From 4e4e5d84cd732dea713d447449721f4e9a2144a4 Mon Sep 17 00:00:00 2001
From: Valentin Clement <clementval at gmail.com>
Date: Wed, 6 Nov 2024 13:22:15 -0800
Subject: [PATCH] [flang][cuda] Allow SHARED actual to DEVICE dummy

---
 flang/include/flang/Common/Fortran.h   |  3 ++-
 flang/lib/Common/Fortran.cpp           |  9 +++++++--
 flang/lib/Evaluate/characteristics.cpp |  5 +++--
 flang/lib/Semantics/check-call.cpp     |  7 ++++++-
 flang/test/Semantics/cuf17.cuf         | 18 ++++++++++++++++++
 5 files changed, 36 insertions(+), 6 deletions(-)
 create mode 100644 flang/test/Semantics/cuf17.cuf

diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h
index 5b2ed43a8f99c0..cb109ad574cf6e 100644
--- a/flang/include/flang/Common/Fortran.h
+++ b/flang/include/flang/Common/Fortran.h
@@ -118,7 +118,8 @@ static constexpr IgnoreTKRSet ignoreTKRAll{IgnoreTKR::Type, IgnoreTKR::Kind,
 std::string AsFortran(IgnoreTKRSet);
 
 bool AreCompatibleCUDADataAttrs(std::optional<CUDADataAttr>,
-    std::optional<CUDADataAttr>, IgnoreTKRSet, bool allowUnifiedMatchingRule,
+    std::optional<CUDADataAttr>, IgnoreTKRSet, std::optional<std::string> *,
+    bool allowUnifiedMatchingRule,
     const LanguageFeatureControl *features = nullptr);
 
 static constexpr char blankCommonObjectName[] = "__BLNK__";
diff --git a/flang/lib/Common/Fortran.cpp b/flang/lib/Common/Fortran.cpp
index c014b1263a67f0..dc0c9d6406474d 100644
--- a/flang/lib/Common/Fortran.cpp
+++ b/flang/lib/Common/Fortran.cpp
@@ -103,7 +103,8 @@ std::string AsFortran(IgnoreTKRSet tkr) {
 /// dummy argument attribute while `y` represents the actual argument attribute.
 bool AreCompatibleCUDADataAttrs(std::optional<CUDADataAttr> x,
     std::optional<CUDADataAttr> y, IgnoreTKRSet ignoreTKR,
-    bool allowUnifiedMatchingRule, const LanguageFeatureControl *features) {
+    std::optional<std::string> *warning, bool allowUnifiedMatchingRule,
+    const LanguageFeatureControl *features) {
   bool isCudaManaged{features
           ? features->IsEnabled(common::LanguageFeature::CudaManaged)
           : false};
@@ -134,8 +135,12 @@ bool AreCompatibleCUDADataAttrs(std::optional<CUDADataAttr> x,
     } else {
       if (*x == CUDADataAttr::Device) {
         if ((y &&
-                (*y == CUDADataAttr::Managed || *y == CUDADataAttr::Unified)) ||
+                (*y == CUDADataAttr::Managed || *y == CUDADataAttr::Unified ||
+                    *y == CUDADataAttr::Shared)) ||
             (!y && (isCudaUnified || isCudaManaged))) {
+          if (y && *y == CUDADataAttr::Shared) {
+            *warning = "SHARED attribute ignored"s;
+          }
           return true;
         }
       } else if (*x == CUDADataAttr::Managed) {
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 2496e4427fe7ae..a835aecfaf5ece 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -371,7 +371,7 @@ bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
   }
   if (!attrs.test(Attr::Value) &&
       !common::AreCompatibleCUDADataAttrs(cudaDataAttr, actual.cudaDataAttr,
-          ignoreTKR,
+          ignoreTKR, warning,
           /*allowUnifiedMatchingRule=*/false)) {
     if (whyNot) {
       *whyNot = "incompatible CUDA data attributes";
@@ -1762,6 +1762,7 @@ bool DistinguishUtils::Distinguishable(
 bool DistinguishUtils::Distinguishable(
     const DummyDataObject &x, const DummyDataObject &y) const {
   using Attr = DummyDataObject::Attr;
+  std::optional<std::string> warning;
   if (Distinguishable(x.type, y.type, x.ignoreTKR | y.ignoreTKR)) {
     return true;
   } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
@@ -1771,7 +1772,7 @@ bool DistinguishUtils::Distinguishable(
       x.intent != common::Intent::In) {
     return true;
   } else if (!common::AreCompatibleCUDADataAttrs(x.cudaDataAttr, y.cudaDataAttr,
-                 x.ignoreTKR | y.ignoreTKR,
+                 x.ignoreTKR | y.ignoreTKR, &warning,
                  /*allowUnifiedMatchingRule=*/false)) {
     return true;
   } else if (features_.IsEnabled(
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index fa2d59da10f827..a161d2bdf9dbb8 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -976,8 +976,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
         actualDataAttr = common::CUDADataAttr::Device;
       }
     }
+    std::optional<std::string> warning;
     if (!common::AreCompatibleCUDADataAttrs(dummyDataAttr, actualDataAttr,
-            dummy.ignoreTKR,
+            dummy.ignoreTKR, &warning,
             /*allowUnifiedMatchingRule=*/true, &context.languageFeatures())) {
       auto toStr{[](std::optional<common::CUDADataAttr> x) {
         return x ? "ATTRIBUTES("s +
@@ -988,6 +989,10 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           "%s has %s but its associated actual argument has %s"_err_en_US,
           dummyName, toStr(dummyDataAttr), toStr(actualDataAttr));
     }
+    if (warning && context.ShouldWarn(common::UsageWarning::CUDAUsage)) {
+      messages.Say(common::UsageWarning::CUDAUsage, "%s"_warn_en_US,
+          std::move(*warning));
+    }
   }
 
   // Warning for breaking F'2023 change with character allocatables
diff --git a/flang/test/Semantics/cuf17.cuf b/flang/test/Semantics/cuf17.cuf
new file mode 100644
index 00000000000000..daeb59033561cf
--- /dev/null
+++ b/flang/test/Semantics/cuf17.cuf
@@ -0,0 +1,18 @@
+! RUN: bbc -emit-hlfir -fcuda %s 2>&1 | FileCheck %s
+
+module mod1
+contains
+
+attributes(device) subroutine sub1(adev)
+  real, device :: adev(10)
+end
+
+attributes(global) subroutine sub2()
+  real, shared :: adev(10)
+  !WARNING: SHARED attribute ignored
+  call sub1(adev)
+end subroutine
+
+end module
+
+! CHECK: warning: SHARED attribute ignored