[flang] Fix fir::isPolymorphic for TYPE(*) assumed-size arrays

[jeanPerier]

fir::isPolymorphic was returning false for TYPE() assumed-size arrays causing bad fir.rebox to be created when passing a polymorphic actual argument to such TYPE() dummy.

Fix fir::isAssumedSize to return true for fir.ref<fir.array> and fir.ref.

@cabreraam, I found this bug when testing your patch, although it is not caused by it, so you may hit it when passing TYPE() deferred shape of to assumed size TYPE() with a different rank.

[llvmbot]

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

Author: None (jeanPerier)

Changes

fir::isPolymorphic was returning false for TYPE() assumed-size arrays causing bad fir.rebox to be created when passing a polymorphic actual argument to such TYPE() dummy.

Fix fir::isAssumedSize to return true for fir.ref<fir.array<none>> and fir.ref<none>.

@cabreraam, I found this bug when testing your patch, although it is not caused by it, so you may hit it when passing TYPE() deferred shape of to assumed size TYPE() with a different rank.

---

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

4 Files Affected:

• (modified) flang/include/flang/Optimizer/Dialect/FIRType.h (+3-1)
• (modified) flang/lib/Optimizer/Dialect/FIRType.cpp (+13-14)
• (added) flang/test/Lower/HLFIR/calls-poly-to-assumed-type.f90 (+20)
• (modified) flang/test/Lower/polymorphic.f90 (+1-3)

diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h
index ecfa9839617dab..8672fcaf60f705 100644
--- a/flang/include/flang/Optimizer/Dialect/FIRType.h
+++ b/flang/include/flang/Optimizer/Dialect/FIRType.h
@@ -330,7 +330,9 @@ bool isPolymorphicType(mlir::Type ty);
 /// value.
 bool isUnlimitedPolymorphicType(mlir::Type ty);
 
-/// Return true iff `ty` is the type of an assumed type.
+/// Return true iff `ty` is the type of an assumed type. In FIR,
+/// assumed types are of the form `[fir.ref|ptr|heap]fir.box<[fir.array]none>`,
+/// or `fir.ref|ptr|heap<[fir.array]none>`.
 bool isAssumedType(mlir::Type ty);
 
 /// Return true iff `ty` is the type of an assumed shape array.
diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp
index d0c7bae674b6cf..110b3a5e0620e2 100644
--- a/flang/lib/Optimizer/Dialect/FIRType.cpp
+++ b/flang/lib/Optimizer/Dialect/FIRType.cpp
@@ -302,13 +302,16 @@ bool isScalarBoxedRecordType(mlir::Type ty) {
 }
 
 bool isAssumedType(mlir::Type ty) {
-  if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
-    if (boxTy.getEleTy().isa<mlir::NoneType>())
-      return true;
-    if (auto seqTy = boxTy.getEleTy().dyn_cast<fir::SequenceType>())
-      return seqTy.getEleTy().isa<mlir::NoneType>();
-  }
-  return false;
+  // Rule out CLASS(*) which are `fir.class<[fir.array] none>`.
+  if (mlir::isa<fir::ClassType>(ty))
+    return false;
+  mlir::Type valueType = fir::unwrapPassByRefType(fir::unwrapRefType(ty));
+  // Refuse raw `none` or `fir.array<none>` since assumed type
+  // should be in memory variables.
+  if (valueType == ty)
+    return false;
+  mlir::Type inner = fir::unwrapSequenceType(valueType);
+  return mlir::isa<mlir::NoneType>(inner);
 }
 
 bool isAssumedShape(mlir::Type ty) {
@@ -331,20 +334,16 @@ bool isAllocatableOrPointerArray(mlir::Type ty) {
 }
 
 bool isPolymorphicType(mlir::Type ty) {
-  if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
-    ty = refTy;
-  // CLASS(*)
-  if (ty.isa<fir::ClassType>())
+  // CLASS(T) or CLASS(*)
+  if (mlir::isa<fir::ClassType>(fir::unwrapRefType(ty)))
     return true;
   // assumed type are polymorphic.
   return isAssumedType(ty);
 }
 
 bool isUnlimitedPolymorphicType(mlir::Type ty) {
-  if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
-    ty = refTy;
   // CLASS(*)
-  if (auto clTy = ty.dyn_cast<fir::ClassType>()) {
+  if (auto clTy = mlir::dyn_cast<fir::ClassType>(fir::unwrapRefType(ty))) {
     if (clTy.getEleTy().isa<mlir::NoneType>())
       return true;
     mlir::Type innerType = clTy.unwrapInnerType();
diff --git a/flang/test/Lower/HLFIR/calls-poly-to-assumed-type.f90 b/flang/test/Lower/HLFIR/calls-poly-to-assumed-type.f90
new file mode 100644
index 00000000000000..ffd21e01ef98dd
--- /dev/null
+++ b/flang/test/Lower/HLFIR/calls-poly-to-assumed-type.f90
@@ -0,0 +1,20 @@
+! Test passing rank 2 CLASS(*) deferred shape to assumed size assumed type
+! This requires copy-in/copy-out logic.
+! RUN: bbc -emit-hlfir -polymorphic-type -o - %s | FileCheck %s
+
+subroutine pass_poly_to_assumed_type_assumed_size(x)
+  class(*), target :: x(:,:)
+  interface
+    subroutine assumed_type_assumed_size(x)
+       type(*), target :: x(*)
+    end subroutine
+  end interface
+  call assumed_type_assumed_size(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPpass_poly_to_assumed_type_assumed_size(
+! CHECK:           %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFpass_poly_to_assumed_type_assumed_sizeEx"} : (!fir.class<!fir.array<?x?xnone>>) -> (!fir.class<!fir.array<?x?xnone>>, !fir.class<!fir.array<?x?xnone>>)
+! CHECK:           %[[VAL_2:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.class<!fir.array<?x?xnone>>) -> (!fir.class<!fir.array<?x?xnone>>, i1)
+! CHECK:           %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]]#0 : (!fir.class<!fir.array<?x?xnone>>) -> !fir.ref<!fir.array<?x?xnone>>
+! CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref<!fir.array<?x?xnone>>) -> !fir.ref<!fir.array<?xnone>>
+! CHECK:           fir.call @_QPassumed_type_assumed_size(%[[VAL_4]]) fastmath<contract> : (!fir.ref<!fir.array<?xnone>>) -> ()
+! CHECK:           hlfir.copy_out %[[VAL_2]]#0, %[[VAL_2]]#1 to %[[VAL_1]]#0 : (!fir.class<!fir.array<?x?xnone>>, i1, !fir.class<!fir.array<?x?xnone>>) -> ()
diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90
index 1770b34d0fe1aa..a813eff690b77e 100644
--- a/flang/test/Lower/polymorphic.f90
+++ b/flang/test/Lower/polymorphic.f90
@@ -839,9 +839,7 @@ subroutine test_call_with_null()
 ! CHECK: %[[IS_ALLOCATED_OR_ASSOCIATED:.*]] = arith.cmpi ne, %[[BOX_ADDR_I64]], %[[C0]] : i64
 ! CHECK: %[[ABSENT:.*]] = fir.absent !fir.class<none>
 ! CHECK: %[[PTR_LOAD2:.*]] = fir.load %[[NULL_PTR]] : !fir.ref<!fir.box<!fir.ptr<none>>>
-! CHECK: %[[BOX_ADDR2:.*]] = fir.box_addr %[[PTR_LOAD2]] : (!fir.box<!fir.ptr<none>>) -> !fir.ptr<none>
-! CHECK: %[[BOX_NONE:.*]] = fir.embox %[[BOX_ADDR2]] : (!fir.ptr<none>) -> !fir.box<none>
-! CHECK: %[[CLASS_NONE:.*]] = fir.convert %[[BOX_NONE]] : (!fir.box<none>) -> !fir.class<none>
+! CHECK: %[[CLASS_NONE:.*]] = fir.rebox %[[PTR_LOAD2]] : (!fir.box<!fir.ptr<none>>) -> !fir.class<none>
 ! CHECK: %[[ARG:.*]] = arith.select %[[IS_ALLOCATED_OR_ASSOCIATED]], %[[CLASS_NONE]], %[[ABSENT]] : !fir.class<none>
 ! CHECK: fir.call @_QMpolymorphic_testPsub_with_poly_optional(%[[ARG]]) {{.*}} : (!fir.class<none>) -> ()
 

[clementval]

Thanks for catching this! LGTM