[flang][cuda] Allow list-directed PRINT and WRITE stmt in device code

[clementval]

The specification allow list-directed PRINT and WRITE statements to appear in device code. This patch relax the semantic check to allow them.

3.6.11.
List-directed PRINT and WRITE statements to the default unit may be used when compiling for compute capability 2.0 and higher; all other uses of PRINT and WRITE are disallowed.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

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

Changes

The specification allow list-directed PRINT and WRITE statements to appear in device code. This patch relax the semantic check to allow them.

3.6.11.
List-directed PRINT and WRITE statements to the default unit may be used when compiling for compute capability 2.0 and higher; all other uses of PRINT and WRITE are disallowed.

---

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

2 Files Affected:

• (modified) flang/lib/Semantics/check-cuda.cpp (+65)
• (modified) flang/test/Semantics/cuf09.cuf (+8)

diff --git a/flang/lib/Semantics/check-cuda.cpp b/flang/lib/Semantics/check-cuda.cpp
index c0c6ff4c1a2ba3..cb8ec7be4c05ef 100644
--- a/flang/lib/Semantics/check-cuda.cpp
+++ b/flang/lib/Semantics/check-cuda.cpp
@@ -275,9 +275,74 @@ template <bool IsCUFKernelDo> class DeviceContextChecker {
         },
         ec.u);
   }
+  template <typename SEEK, typename A>
+  static const auto *GetIOControl(const A &stmt) {
+    for (const auto &spec : stmt.controls) {
+      if (const auto *result = std::get_if<SEEK>(&spec.u)) {
+        return result;
+      }
+    }
+    return static_cast<const SEEK *>(nullptr);
+  }
+  template <typename A> static bool IsInternalIO(const A &stmt) {
+    if (stmt.iounit.has_value()) {
+      return std::holds_alternative<Fortran::parser::Variable>(stmt.iounit->u);
+    }
+    if (auto *unit = GetIOControl<Fortran::parser::IoUnit>(stmt)) {
+      return std::holds_alternative<Fortran::parser::Variable>(unit->u);
+    }
+    return false;
+  }
+  void WarnOnIoStmt(const parser::CharBlock &source) {
+    context_.Say(
+        source, "I/O statement might not be supported on device"_warn_en_US);
+  }
+  template <typename A>
+  void WarnIfNotInternal(const A &stmt, const parser::CharBlock &source) {
+    if (!IsInternalIO(stmt)) {
+      WarnOnIoStmt(source);
+    }
+  }
   void Check(const parser::ActionStmt &stmt, const parser::CharBlock &source) {
     common::visit(
         common::visitors{
+            [&](const common::Indirection<parser::PrintStmt> &) {},
+            [&](const common::Indirection<parser::WriteStmt> &x) {
+              if (x.value().format) { // Formatted write to '*' or '6'
+                if (std::holds_alternative<Fortran::parser::Star>(
+                        x.value().format->u)) {
+                  if (x.value().iounit) {
+                    if (std::holds_alternative<Fortran::parser::Star>(
+                            x.value().iounit->u)) {
+                      return;
+                    }
+                  }
+                  return;
+                }
+              }
+              WarnIfNotInternal(x.value(), source);
+            },
+            [&](const common::Indirection<parser::CloseStmt> &x) {
+              WarnOnIoStmt(source);
+            },
+            [&](const common::Indirection<parser::EndfileStmt> &x) {
+              WarnOnIoStmt(source);
+            },
+            [&](const common::Indirection<parser::OpenStmt> &x) {
+              WarnOnIoStmt(source);
+            },
+            [&](const common::Indirection<parser::ReadStmt> &x) {
+              WarnIfNotInternal(x.value(), source);
+            },
+            [&](const common::Indirection<parser::InquireStmt> &x) {
+              WarnOnIoStmt(source);
+            },
+            [&](const common::Indirection<parser::RewindStmt> &x) {
+              WarnOnIoStmt(source);
+            },
+            [&](const common::Indirection<parser::BackspaceStmt> &x) {
+              WarnOnIoStmt(source);
+            },
             [&](const auto &x) {
               if (auto msg{ActionStmtChecker<IsCUFKernelDo>::WhyNotOk(x)}) {
                 context_.Say(source, std::move(*msg));
diff --git a/flang/test/Semantics/cuf09.cuf b/flang/test/Semantics/cuf09.cuf
index 4bc93132044fdd..d2d4d239815e4b 100644
--- a/flang/test/Semantics/cuf09.cuf
+++ b/flang/test/Semantics/cuf09.cuf
@@ -7,6 +7,14 @@ module m
     do k=1,10
     end do
   end
+  attributes(device) subroutine devsub2
+    real, device :: x(10)
+    print*,'from device'
+    print '(f10.5)', (x(ivar), ivar = 1, 10)
+    write(*,*), "Hello world from device!"
+    !WARNING: I/O statement might not be supported on device
+    write(12,'(10F4.1)'), x
+  end
 end
 
 program main

[clementval]

ping