[flang] handle assume-rank descriptor updates in calls

[jeanPerier]

Deal with the cases where lower bounds, or attribute, or dynamic type must be updated when passing an assumed-rank actual argument to an assumed-rank dummy argument.

copy-in/copy-out and passing target assumed-rank to intent(in) pointers will be handled in separate patch.

[llvmbot]

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

Author: None (jeanPerier)

Changes

Deal with the cases where lower bounds, or attribute, or dynamic type must be updated when passing an assumed-rank actual argument to an assumed-rank dummy argument.

copy-in/copy-out and passing target assumed-rank to intent(in) pointers will be handled in separate patch.

---

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

2 Files Affected:

• (modified) flang/lib/Lower/ConvertCall.cpp (+20-18)
• (added) flang/test/Lower/HLFIR/assumed-rank-calls.f90 (+63)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 3bd1993249575..39bef5c03754a 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -1216,14 +1216,16 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     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.
-      if (actualIsAssumedRank)
-        TODO(loc, "passing polymorphic assumed-rank to non polymorphic dummy "
-                  "argument");
       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{})};
+      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{})};
+      }
     }
     if (arg.hasValueAttribute() ||
         // Constant expressions might be lowered as variables with
@@ -1330,19 +1332,19 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag ||
         needsZeroLowerBounds) {
       if (actualIsAssumedRank) {
-        if (needToAddAddendum)
-          TODO(loc, "passing intrinsic assumed-rank to unlimited polymorphic "
-                    "assumed-rank");
-        else
-          TODO(loc, "passing pointer or allocatable assumed-rank to non "
-                    "pointer non allocatable assumed-rank");
+        auto lbModifier = needsZeroLowerBounds
+                              ? fir::LowerBoundModifierAttribute::SetToZeroes
+                              : fir::LowerBoundModifierAttribute::SetToOnes;
+        entity = hlfir::Entity{builder.create<fir::ReboxAssumedRankOp>(
+            loc, dummyTypeWithActualRank, entity, lbModifier)};
+      } else {
+        mlir::Value shift{};
+        if (needsZeroLowerBounds)
+          shift = getZeroLowerBounds(loc, builder, entity);
+        entity = hlfir::Entity{builder.create<fir::ReboxOp>(
+            loc, dummyTypeWithActualRank, entity, /*shape=*/shift,
+            /*slice=*/mlir::Value{})};
       }
-      mlir::Value shift{};
-      if (needsZeroLowerBounds)
-        shift = getZeroLowerBounds(loc, builder, entity);
-      entity = hlfir::Entity{builder.create<fir::ReboxOp>(
-          loc, dummyTypeWithActualRank, entity, /*shape=*/shift,
-          /*slice=*/mlir::Value{})};
     }
     addr = entity;
   } else {
diff --git a/flang/test/Lower/HLFIR/assumed-rank-calls.f90 b/flang/test/Lower/HLFIR/assumed-rank-calls.f90
new file mode 100644
index 0000000000000..f5fb343977474
--- /dev/null
+++ b/flang/test/Lower/HLFIR/assumed-rank-calls.f90
@@ -0,0 +1,63 @@
+! Test passing of assumed-ranks that require creating a
+! a new descriptor for the dummy argument (different lower bounds,
+! attribute, or dynamic type)
+! RUN: bbc -emit-hlfir -allow-assumed-rank -o - %s | FileCheck %s
+
+subroutine test_alloc_to_nonalloc(x)
+  real, allocatable ::  x(..)
+  interface
+    subroutine takes_assumed_rank(x)
+      real :: x(..)
+    end subroutine
+  end interface
+  call takes_assumed_rank(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_alloc_to_nonalloc(
+! CHECK-SAME:                                         %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!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]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFtest_alloc_to_nonallocEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>, !fir.dscope) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>)
+! CHECK:           %[[VAL_3:.*]] = fir.load %[[VAL_2]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK:           %[[VAL_4:.*]] = fir.rebox_assumed_rank %[[VAL_3]] lbs ones : (!fir.box<!fir.heap<!fir.array<*:f32>>>) -> !fir.box<!fir.array<*:f32>>
+! CHECK:           fir.call @_QPtakes_assumed_rank(%[[VAL_4]]) fastmath<contract> : (!fir.box<!fir.array<*:f32>>) -> ()
+! CHECK:           return
+! CHECK:         }
+
+subroutine test_to_bindc(x)
+  real ::  x(..)
+  interface
+    subroutine bindc_func(x) bind(c)
+      real :: x(..)
+    end subroutine
+  end interface
+  call bindc_func(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_to_bindc(
+! 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_to_bindcEx"} : (!fir.box<!fir.array<*:f32>>, !fir.dscope) -> (!fir.box<!fir.array<*:f32>>, !fir.box<!fir.array<*:f32>>)
+! CHECK:           %[[VAL_3:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs zeroes : (!fir.box<!fir.array<*:f32>>) -> !fir.box<!fir.array<*:f32>>
+! CHECK:           fir.call @bindc_func(%[[VAL_3]]) fastmath<contract> {is_bind_c} : (!fir.box<!fir.array<*:f32>>) -> ()
+! CHECK:           return
+! CHECK:         }
+
+subroutine test_poly_to_nonepoly(x)
+  type t
+    integer :: i
+  end type
+  class(t) ::  x(..)
+  interface
+    subroutine takes_assumed_rank_t(x)
+      import :: t
+      type(t) :: x(..)
+    end subroutine
+  end interface
+  call takes_assumed_rank_t(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_poly_to_nonepoly(
+! CHECK-SAME:                                        %[[VAL_0:.*]]: !fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>> {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_poly_to_nonepolyEx"} : (!fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>, !fir.dscope) -> (!fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>, !fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>)
+! CHECK:           %[[VAL_3:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs ones : (!fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>) -> !fir.box<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>
+! CHECK:           fir.call @_QPtakes_assumed_rank_t(%[[VAL_3]]) fastmath<contract> : (!fir.box<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>) -> ()
+! CHECK:           return
+! CHECK:         }

[clementval]

LGTM