[flang][cuda] Set implicit CUDA device attribute in block construct

[clementval]

Arrays in specification part inside a device procedure are implicitly flagged as device if they have no attribute. This was not done for arrays in block construct and leads to false semantic error about usage of host arrays in device context.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Valentin Clement (バレンタイン クレメン) (clementval)

Changes

Arrays in specification part inside a device procedure are implicitly flagged as device if they have no attribute. This was not done for arrays in block construct and leads to false semantic error about usage of host arrays in device context.

---

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

2 Files Affected:

• (modified) flang/lib/Semantics/resolve-names.cpp (+35-8)
• (modified) flang/test/Semantics/cuf09.cuf (+11)

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index bdafc03ad2c05..92a3277191ae0 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -9372,11 +9372,40 @@ void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) {
   info.Resolve(&MakeSymbol(symbolName, Attrs{}, std::move(genericDetails)));
 }
 
+static void SetImplicitCUDADevice(bool inDeviceSubprogram, Symbol &symbol) {
+  if (inDeviceSubprogram && symbol.has<ObjectEntityDetails>()) {
+    auto *object{symbol.detailsIf<ObjectEntityDetails>()};
+    if (!object->cudaDataAttr() && !IsValue(symbol) &&
+        (IsDummy(symbol) || object->IsArray())) {
+      // Implicitly set device attribute if none is set in device context.
+      object->set_cudaDataAttr(common::CUDADataAttr::Device);
+    }
+  }
+}
+
 void ResolveNamesVisitor::FinishSpecificationPart(
     const std::list<parser::DeclarationConstruct> &decls) {
   misparsedStmtFuncFound_ = false;
   funcResultStack().CompleteFunctionResultType();
   CheckImports();
+  bool inDeviceSubprogram{false};
+  Symbol *scopeSym{currScope().symbol()};
+  if (currScope().kind() == Scope::Kind::BlockConstruct) {
+    scopeSym = currScope().parent().symbol();
+  }
+  if (scopeSym) {
+    if (auto *details{scopeSym->detailsIf<SubprogramDetails>()}) {
+      // Check the current procedure is a device procedure to apply implicit
+      // attribute at the end.
+      if (auto attrs{details->cudaSubprogramAttrs()}) {
+        if (*attrs == common::CUDASubprogramAttrs::Device ||
+            *attrs == common::CUDASubprogramAttrs::Global ||
+            *attrs == common::CUDASubprogramAttrs::Grid_Global) {
+          inDeviceSubprogram = true;
+        }
+      }
+    }
+  }
   for (auto &pair : currScope()) {
     auto &symbol{*pair.second};
     if (inInterfaceBlock()) {
@@ -9411,6 +9440,11 @@ void ResolveNamesVisitor::FinishSpecificationPart(
         SetBindNameOn(symbol);
       }
     }
+    if (currScope().kind() == Scope::Kind::BlockConstruct) {
+      // Only look for specification in BlockConstruct. Other cases are done in
+      // ResolveSpecificationParts.
+      SetImplicitCUDADevice(inDeviceSubprogram, symbol);
+    }
   }
   currScope().InstantiateDerivedTypes();
   for (const auto &decl : decls) {
@@ -9970,14 +10004,7 @@ void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) {
     }
     ApplyImplicitRules(symbol);
     // Apply CUDA implicit attributes if needed.
-    if (inDeviceSubprogram && symbol.has<ObjectEntityDetails>()) {
-      auto *object{symbol.detailsIf<ObjectEntityDetails>()};
-      if (!object->cudaDataAttr() && !IsValue(symbol) &&
-          (IsDummy(symbol) || object->IsArray())) {
-        // Implicitly set device attribute if none is set in device context.
-        object->set_cudaDataAttr(common::CUDADataAttr::Device);
-      }
-    }
+    SetImplicitCUDADevice(inDeviceSubprogram, symbol);
     // Main program local objects usually don't have an implied SAVE attribute,
     // as one might think, but in the exceptional case of a derived type
     // local object that contains a coarray, we have to mark it as an
diff --git a/flang/test/Semantics/cuf09.cuf b/flang/test/Semantics/cuf09.cuf
index 193b22213da61..4a6d9ab09387d 100644
--- a/flang/test/Semantics/cuf09.cuf
+++ b/flang/test/Semantics/cuf09.cuf
@@ -228,3 +228,14 @@ attributes(host,device) subroutine do2(a,b,c,i)
   c(i) = a(i) - b(i) ! ok. Should not error with Host array 
                      ! cannot be present in device context
 end
+
+attributes(global) subroutine blockTest
+block
+  integer(8) :: xloc
+  integer(8) :: s(7)
+  integer(4) :: i
+  do i = 1, 7
+    s = xloc ! ok.
+  end do
+end block
+end subroutine