[flang] fix sequence association of polymorphic actual arguments (#99294)

When passing a polymorphic actual array argument to an non polymorphic
explicit or assumed shape argument, copy-in/copy-out may be required and
should be made according to the dummy dynamic type.

The code that was creating the descriptor to drive this copy-in/out was
not handling properly the case where the dummy and actual rank do not
match (possible according to sequence association rules), it tried to
make the copy-in/out according to the dummy argument shape (which we may
not even know if the dummy is assumed-size). Fix this by using the
actual shape when creating this new descriptor with the dummy argument
dynamic type.

2 files changed, 53 insertions, 27 deletions

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index ba65b64..fd873f5 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -1227,26 +1227,32 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     return hlfir::Entity{copyIn.getCopiedIn()};
   };
 
+  auto genSetDynamicTypeToDummyType = [&](hlfir::Entity var) -> hlfir::Entity {
+    fir::BaseBoxType boxType = fir::BoxType::get(
+        hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
+    if (actualIsAssumedRank)
+      return hlfir::Entity{builder.create<fir::ReboxAssumedRankOp>(
+          loc, boxType, var, fir::LowerBoundModifierAttribute::SetToOnes)};
+    // Use actual shape when creating descriptor with dummy type, the dummy
+    // shape may be unknown in case of sequence association.
+    mlir::Type actualTy =
+        hlfir::getFortranElementOrSequenceType(actual.getType());
+    boxType = boxType.getBoxTypeWithNewShape(actualTy);
+    return hlfir::Entity{builder.create<fir::ReboxOp>(loc, boxType, var,
+                                                      /*shape=*/mlir::Value{},
+                                                      /*slice=*/mlir::Value{})};
+  };
+
   // Step 2: prepare the storage for the dummy arguments, ensuring that it
   // matches the dummy requirements (e.g., must be contiguous or must be
   // a temporary).
   hlfir::Entity entity =
       hlfir::derefPointersAndAllocatables(loc, builder, actual);
   if (entity.isVariable()) {
-    if (mustSetDynamicTypeToDummyType) {
-      // Note: this is important to do this before any copy-in or copy so
-      // that the dummy is contiguous according to the dummy type.
-      mlir::Type boxType = fir::BoxType::get(
-          hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
-      if (actualIsAssumedRank) {
-        entity = hlfir::Entity{builder.create<fir::ReboxAssumedRankOp>(
-            loc, boxType, entity, fir::LowerBoundModifierAttribute::SetToOnes)};
-      } else {
-        entity = hlfir::Entity{builder.create<fir::ReboxOp>(
-            loc, boxType, entity, /*shape=*/mlir::Value{},
-            /*slice=*/mlir::Value{})};
-      }
-    }
+    // Set dynamic type if needed before any copy-in or copy so that the dummy
+    // is contiguous according to the dummy type.
+    if (mustSetDynamicTypeToDummyType)
+      entity = genSetDynamicTypeToDummyType(entity);
     if (arg.hasValueAttribute() ||
         // Constant expressions might be lowered as variables with
         // 'parameter' attribute. Even though the constant expressions
@@ -1285,20 +1291,14 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
         loc, builder, entity, storageType, "", byRefAttr);
     entity = hlfir::Entity{associate.getBase()};
     preparedDummy.pushExprAssociateCleanUp(associate);
+    // Rebox the actual argument to the dummy argument's type, and make sure
+    // that we pass a contiguous entity (i.e. make copy-in, if needed).
+    //
+    // TODO: this can probably be optimized by associating the expression with
+    // properly typed temporary, but this needs either a new operation or
+    // making the hlfir.associate more complex.
     if (mustSetDynamicTypeToDummyType) {
-      // Rebox the actual argument to the dummy argument's type, and make
-      // sure that we pass a contiguous entity (i.e. make copy-in,
-      // if needed).
-      //
-      // TODO: this can probably be optimized by associating the expression
-      // with properly typed temporary, but this needs either a new operation
-      // or making the hlfir.associate more complex.
-      assert(!actualIsAssumedRank && "only variables are assumed-rank");
-      mlir::Type boxType = fir::BoxType::get(
-          hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
-      entity = hlfir::Entity{builder.create<fir::ReboxOp>(
-          loc, boxType, entity, /*shape=*/mlir::Value{},
-          /*slice=*/mlir::Value{})};
+      entity = genSetDynamicTypeToDummyType(entity);
       entity = genCopyIn(entity, /*doCopyOut=*/false);
     }
   }
diff --git a/flang/test/Lower/HLFIR/calls-poly-to-nonpoly.f90 b/flang/test/Lower/HLFIR/calls-poly-to-nonpoly.f90
new file mode 100644
index 0000000..3c60a84
--- /dev/null
+++ b/flang/test/Lower/HLFIR/calls-poly-to-nonpoly.f90
@@ -0,0 +1,26 @@
+! Test passing polymorphic variable for non-polymorphic dummy arguments:
+! RUN: bbc -emit-hlfir -o - -I nowhere %s | FileCheck %s
+
+subroutine test_sequence_association(x)
+  type t
+    integer :: i
+  end type
+  interface
+    subroutine sequence_assoc(x, n)
+      import :: t
+      type(t) :: x(n)
+    end subroutine
+  end interface
+  class(t) :: x(:, :)
+  call sequence_assoc(x, 100)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_sequence_association(
+! CHECK-SAME:                                            %[[VAL_0:.*]]: !fir.class<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>
+! CHECK:           %[[VAL_1:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>>
+! CHECK:           %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]]
+! CHECK:           %[[REBOX:.*]] = fir.rebox %[[VAL_3]]#0 : (!fir.class<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>) -> !fir.box<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>
+! CHECK:           %[[VAL_5:.*]]:2 = hlfir.copy_in %[[REBOX]] to %[[VAL_1]] : (!fir.box<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>>>) -> (!fir.box<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>, i1)
+! CHECK:           %[[VAL_6:.*]] = fir.box_addr %[[VAL_5]]#0 : (!fir.box<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>) -> !fir.ref<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>
+! CHECK:           %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (!fir.ref<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>) -> !fir.ref<!fir.array<?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>
+! CHECK:           fir.call @_QPsequence_assoc(%[[VAL_7]], %{{.*}})
+! CHECK:           hlfir.copy_out %[[VAL_1]], %[[VAL_5]]#1 to %[[REBOX]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>>>, i1, !fir.box<!fir.array<?x?x!fir.type<_QFtest_sequence_associationTt{i:i32}>>>) -> ()