[flang] implement assumed-rank in ENTRY

[jeanPerier]

Note: first commit is a createUnallocatedBox utility change part of #96106 that is also needed here.

With this utility change, the TODO for assumed-rank in entry can simply be lifted and test is added.

The key is that a unallocated assumed-rank descriptor is created with rank zero in the entry where an assumed-rank dummy from some other entry do not appear as a dummy (the symbol must still be mapped to some valid value because the symbol could be used in code that would be unreachable at runtime, but that the compiler must still generate).

[llvmbot]

@llvm/pr-subscribers-flang-fir-hlfir

Author: None (jeanPerier)

Changes

Note: first commit is a createUnallocatedBox utility change part of #96106 that is also needed here.

With this utility change, the TODO for assumed-rank in entry can simply be lifted and test is added.

The key is that a unallocated assumed-rank descriptor is created with rank zero in the entry where an assumed-rank dummy from some other entry do not appear as a dummy (the symbol must still be mapped to some valid value because the symbol could be used in code that would be unreachable at runtime, but that the compiler must still generate).

---

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

4 Files Affected:

• (modified) flang/lib/Lower/ConvertType.cpp (+4-3)
• (modified) flang/lib/Lower/ConvertVariable.cpp (-5)
• (modified) flang/lib/Optimizer/Builder/MutableBox.cpp (+17-3)
• (added) flang/test/Lower/HLFIR/assumed-rank-entry.f90 (+28)

diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index f64f6c93541a3..a47fc99ea9f45 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -280,10 +280,11 @@ struct TypeBuilderImpl {
     if (ultimate.IsObjectArray()) {
       auto shapeExpr =
           Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate);
-      if (!shapeExpr)
-        TODO(loc, "assumed rank symbol type");
       fir::SequenceType::Shape shape;
-      translateShape(shape, std::move(*shapeExpr));
+      // If there is no shapExpr, this is an assumed-rank, and the empty shape
+      // will build the desired fir.array<*:T> type.
+      if (shapeExpr)
+        translateShape(shape, std::move(*shapeExpr));
       ty = fir::SequenceType::get(shape, ty);
     }
     if (Fortran::semantics::IsPointer(symbol))
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 8c96123b14976..e5a71c5ec5b4a 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -2036,11 +2036,6 @@ void Fortran::lower::mapSymbolAttributes(
     if (isUnusedEntryDummy) {
       assert(!Fortran::semantics::IsAllocatableOrPointer(sym) &&
              "handled above");
-      // Need to add support for allocatable assumed-rank to use
-      // logic below, or to simplify it and add codegen for fir.zero
-      // !fir.box<> instead.
-      if (isAssumedRank)
-        TODO(loc, "assumed rank in ENTRY");
       // The box is read right away because lowering code does not expect
       // a non pointer/allocatable symbol to be mapped to a MutableBox.
       mlir::Type ty = converter.genType(var);
diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp
index 16e543fe86a79..fb76928137020 100644
--- a/flang/lib/Optimizer/Builder/MutableBox.cpp
+++ b/flang/lib/Optimizer/Builder/MutableBox.cpp
@@ -329,7 +329,18 @@ class MutablePropertyWriter {
 mlir::Value fir::factory::createUnallocatedBox(
     fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type boxType,
     mlir::ValueRange nonDeferredParams, mlir::Value typeSourceBox) {
-  auto baseAddrType = mlir::dyn_cast<fir::BaseBoxType>(boxType).getEleTy();
+  auto baseBoxType = mlir::cast<fir::BaseBoxType>(boxType);
+  // Giving unallocated/disassociated status to assumed-rank POINTER/
+  // ALLOCATABLE is not directly possible to a Fortran user. But the
+  // compiler may need to create such temporary descriptor to deal with
+  // cases like ENTRY or host association. In such case, all that mater
+  // is that the base address is set to zero and the rank is set to
+  // some defined value. Hence, a scalar descriptor is created and
+  // cast to assumed-rank.
+  const bool isAssumedRank = baseBoxType.isAssumedRank();
+  if (isAssumedRank)
+    baseBoxType = baseBoxType.getBoxTypeWithNewShape(/*rank=*/0);
+  auto baseAddrType = baseBoxType.getEleTy();
   if (!fir::isa_ref_type(baseAddrType))
     baseAddrType = builder.getRefType(baseAddrType);
   auto type = fir::unwrapRefType(baseAddrType);
@@ -361,8 +372,11 @@ mlir::Value fir::factory::createUnallocatedBox(
     }
   }
   mlir::Value emptySlice;
-  return builder.create<fir::EmboxOp>(loc, boxType, nullAddr, shape, emptySlice,
-                                      lenParams, typeSourceBox);
+  auto embox = builder.create<fir::EmboxOp>(
+      loc, baseBoxType, nullAddr, shape, emptySlice, lenParams, typeSourceBox);
+  if (isAssumedRank)
+    return builder.createConvert(loc, boxType, embox);
+  return embox;
 }
 
 fir::MutableBoxValue fir::factory::createTempMutableBox(
diff --git a/flang/test/Lower/HLFIR/assumed-rank-entry.f90 b/flang/test/Lower/HLFIR/assumed-rank-entry.f90
new file mode 100644
index 0000000000000..9928f5459f71f
--- /dev/null
+++ b/flang/test/Lower/HLFIR/assumed-rank-entry.f90
@@ -0,0 +1,28 @@
+! Test assumed-rank dummy argument that is not present in
+! all ENTRY statements.
+! RUN: bbc -emit-hlfir -allow-assumed-rank -o - %s | FileCheck %s
+
+subroutine test_main_entry(x)
+  real :: x(..)
+  interface
+  subroutine some_proc(x)
+    real :: x(..)
+  end subroutine
+  end interface
+  call some_proc(x)
+entry test_alternate_entry()
+  call the_end()
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_main_entry(
+! CHECK-SAME:                                  %[[VAL_0:.*]]: !fir.box<!fir.array<*:f32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! CHECK:           %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {uniq_name = "_QFtest_main_entryEx"} : (!fir.box<!fir.array<*:f32>>, !fir.dscope) -> (!fir.box<!fir.array<*:f32>>, !fir.box<!fir.array<*:f32>>)
+
+! CHECK-LABEL:   func.func @_QPtest_alternate_entry() {
+! CHECK:           %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<*:f32>>>
+! CHECK:           %[[VAL_1:.*]] = fir.zero_bits !fir.heap<f32>
+! CHECK:           %[[VAL_2:.*]] = fir.embox %[[VAL_1]] : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
+! CHECK:           %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.box<!fir.heap<f32>>) -> !fir.box<!fir.heap<!fir.array<*:f32>>>
+! CHECK:           fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK:           %[[VAL_4:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK:           %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]] {uniq_name = "_QFtest_main_entryEx"} : (!fir.box<!fir.heap<!fir.array<*:f32>>>) -> (!fir.box<!fir.heap<!fir.array<*:f32>>>, !fir.box<!fir.heap<!fir.array<*:f32>>>)

[clementval]

LGTM