[flang][hlfir] Lower parent component references

[jeanPerier]

Summary

Skip the parent components when they are not at the end of
designators.
Generate an hlfir.parent_comp for parent component at the end
of designators.

Depends on D144946

[clementval]

LGTM

flang/lib/Lower/ConvertExprToHLFIR.cpp

private:
   gen(const Fortran::evaluate::SymbolRef &symbolRef) {
     if (std::optional<fir::FortranVariableOpInterface> varDef =
             getSymMap().lookupVariableDefinition(symbolRef))
       return *varDef;
     TODO(getLoc(), "lowering symbol to HLFIR");
   }
 
   fir::FortranVariableOpInterface
-  gen(const Fortran::evaluate::Component &component) {
+  gen(const Fortran::evaluate::Component &component,
+      bool skipParentComponent = false) {
     if (Fortran::semantics::IsAllocatableOrPointer(component.GetLastSymbol()))
       return genWholeAllocatableOrPointerComponent(component);
+    if (component.GetLastSymbol().test(
+            Fortran::semantics::Symbol::Flag::ParentComp)) {
+      if (skipParentComponent)
+        // Inner parent components can be skipped: x%parent_comp%i is equivalent
+        // to "x%i" in FIR (all the parent components are part of the FIR type
+        // of "x").
+        return genDataRefAndSkipParentComponents(component.base());
+      // This is a leaf "x%parent_comp" or "x(subscripts)%parent_comp" and
+      // cannot be skipped: the designator must be lowered to the parent type.
+      // This cannot be represented with an hlfir.designate since "parent_comp"
+      // name is meaningless in the fir.record type of "x". Instead, an
+      // hlfir.parent_comp is generated.
+      fir::FirOpBuilder &builder = getBuilder();
+      hlfir::Entity base = genDataRefAndSkipParentComponents(component.base());
+      base = derefPointersAndAllocatables(loc, builder, base);
+      mlir::Value shape;
+      if (base.isArray())
+        shape = hlfir::genShape(loc, builder, base);
+      const Fortran::semantics::DeclTypeSpec *declTypeSpec =
+          component.GetLastSymbol().GetType();
+      assert(declTypeSpec && declTypeSpec->AsDerived() &&
+             "parent component symbols must have a derived type");
+      mlir::Type componentType = Fortran::lower::translateDerivedTypeToFIRType(
+          getConverter(), *declTypeSpec->AsDerived());
+      mlir::Type resultType =
+          changeElementType(base.getElementOrSequenceType(), componentType);
+      // Note that the result is monomorphic even if the base is polymorphic:
+      // the dynamic type of the parent component reference is the parent type.
+      // If the base is an array, it is however most likely not contiguous.
+      if (base.isArray() || fir::isRecordWithTypeParameters(componentType))
+        resultType = fir::BoxType::get(resultType);
+      else
+        resultType = fir::ReferenceType::get(resultType);
+      if (fir::isRecordWithTypeParameters(componentType))
+        TODO(loc, "parent component reference with a parametrized parent type");
+      auto parentComp = builder.create<hlfir::ParentComponentOp>(
+          loc, resultType, base, shape, /*typeParams=*/mlir::ValueRange{});
+      return mlir::cast<fir::FortranVariableOpInterface>(
+          parentComp.getOperation());
+    }
     PartInfo partInfo;
     mlir::Type resultType = visit(component, partInfo);
     return genDesignate(resultType, partInfo, component);
   }
 
   fir::FortranVariableOpInterface
+  genDataRefAndSkipParentComponents(const Fortran::evaluate::DataRef &dataRef) {
+    return std::visit(Fortran::common::visitors{
+                          [&](const Fortran::evaluate::Component &component) {
+                            return gen(component, /*skipParentComponent=*/true);
+                          },
+                          [&](const auto &x) { return gen(x); }},
+                      dataRef.u);
+  }
+
+  fir::FortranVariableOpInterface
   gen(const Fortran::evaluate::ArrayRef &arrayRef) {
     PartInfo partInfo;
     mlir::Type resultType = visit(arrayRef, partInfo);
     return genDesignate(resultType, partInfo, arrayRef);
   }
 
   fir::FortranVariableOpInterface
   gen(const Fortran::evaluate::CoarrayRef &coarrayRef) {
private:
   std::pair<mlir::Type, mlir::Type>
   visitComponentImpl(const Fortran::evaluate::Component &component,
                      PartInfo &partInfo) {
     fir::FirOpBuilder &builder = getBuilder();
     // Break the Designator visit here: if the base is an array-ref, a
     // coarray-ref, or another component, this creates another hlfir.designate
     // for it.  hlfir.designate is not meant to represent more than one
     // part-ref.
-    partInfo.base =
-        std::visit([&](const auto &x) { return gen(x); }, component.base().u);
+    partInfo.base = genDataRefAndSkipParentComponents(component.base());
     // If the base is an allocatable/pointer, dereference it here since the
     // component ref designates its target.
     partInfo.base =
         hlfir::derefPointersAndAllocatables(loc, builder, *partInfo.base);
     assert(partInfo.typeParams.empty() && "should not have been computed yet");
 
     hlfir::genLengthParameters(getLoc(), getBuilder(), *partInfo.base,
                                partInfo.typeParams);
     mlir::Type baseType = partInfo.base->getElementOrSequenceType();
 
     // Lower the information about the component (type, length parameters and
     // shape).
     const Fortran::semantics::Symbol &componentSym = component.GetLastSymbol();
-    if (componentSym.test(Fortran::semantics::Symbol::Flag::ParentComp))
-      TODO(getLoc(), "Parent component reference in HLFIR");
+    assert(
+        !componentSym.test(Fortran::semantics::Symbol::Flag::ParentComp) &&
+        "parent components are skipped and must not reach visitComponentImpl");
     partInfo.componentName = componentSym.name().ToString();
     auto recordType =
         hlfir::getFortranElementType(baseType).cast<fir::RecordType>();
     if (recordType.isDependentType())
       TODO(getLoc(), "Designate derived type with length parameters in HLFIR");
     mlir::Type fieldType = recordType.getType(partInfo.componentName);
     mlir::Type fieldBaseType =
         hlfir::getFortranElementOrSequenceType(fieldType);

flang/test/Lower/HLFIR/parent-component-ref.f90

+! Test lowering of parent component references to HLFIR.
+! RUN: bbc -emit-fir -hlfir -polymorphic-type -o - %s -I nw | FileCheck %s
+
+module pc_types
+  type t
+    integer :: i
+  end type
+  type, extends(t) :: t2
+    integer :: j
+  end type
+interface
+subroutine takes_t_type_array(x)
+  import :: t
+  type(t) :: x(:)
+end subroutine
+subroutine takes_t_class_array(x)
+  import :: t
+  class(t) :: x(:)
+end subroutine
+subroutine takes_int_array(x)
+  integer :: x(:)
+end subroutine
+end interface
+end module
+
+subroutine test_ignored_inner_parent_comp(x)
+ use pc_types
+ type(t2) :: x
+ call takes_int(x%t%i)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_ignored_inner_parent_comp(
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex"
+! CHECK:  %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#0{"i"}   : (!fir.ref<!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>) -> !fir.ref<i32>
+! CHECK:  fir.call @_QPtakes_int(%[[VAL_2]])
+
+subroutine test_ignored_inner_parent_comp_2(x)
+ use pc_types
+ type(t2) :: x(:)
+ call takes_int_array(x%t%i)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_ignored_inner_parent_comp_2(
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex"
+! CHECK:  %[[VAL_2:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_3:.*]]:3 = fir.box_dims %[[VAL_1]]#0, %[[VAL_2]] : (!fir.box<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_4:.*]] = fir.shape %[[VAL_3]]#1 : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_5:.*]] = hlfir.designate %[[VAL_1]]#0{"i"}   shape %[[VAL_4]] : (!fir.box<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<?xi32>>
+! CHECK:  fir.call @_QPtakes_int_array(%[[VAL_5]])
+
+subroutine test_leaf_parent_ref(x)
+ use pc_types
+ type(t2) :: x
+ call takes_parent(x%t)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_leaf_parent_ref(
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex"
+! CHECK:  %[[VAL_2:.*]] = hlfir.parent_comp %[[VAL_1]]#0 : (!fir.ref<!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>) -> !fir.ref<!fir.type<_QMpc_typesTt{i:i32}>>
+! CHECK:  fir.call @_QPtakes_parent(%[[VAL_2]])
+
+subroutine test_leaf_parent_ref_array(x)
+ use pc_types
+ class(t2) :: x(42:)
+! CHECK-LABEL: func.func @_QPtest_leaf_parent_ref_array(
+! CHECK:  %[[VAL_4:.*]]:2 = hlfir.declare {{.*}}Ex"
+ call takes_t_type_array(x%t)
+! CHECK:  %[[VAL_5:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_6:.*]]:3 = fir.box_dims %[[VAL_4]]#0, %[[VAL_5]] : (!fir.class<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_7:.*]] = fir.shape %[[VAL_6]]#1 : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_8:.*]] = hlfir.parent_comp %[[VAL_4]]#0 shape %[[VAL_7]] : (!fir.class<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<?x!fir.type<_QMpc_typesTt{i:i32}>>>
+! CHECK:  fir.call @_QPtakes_t_type_array(%[[VAL_8]])
+ call takes_t_class_array(x%t)
+! CHECK:  %[[VAL_12:.*]] = hlfir.parent_comp %[[VAL_4]]#0 shape %{{.*}} : (!fir.class<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<?x!fir.type<_QMpc_typesTt{i:i32}>>>
+! CHECK:  %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (!fir.box<!fir.array<?x!fir.type<_QMpc_typesTt{i:i32}>>>) -> !fir.class<!fir.array<?x!fir.type<_QMpc_typesTt{i:i32}>>>
+! CHECK:  fir.call @_QPtakes_t_class_array(%[[VAL_13]])
+end subroutine
+
+subroutine test_parent_section_leaf_array(x)
+ use pc_types
+ class(t2) :: x(:)
+ call takes_t_type_array(x(2:11)%t)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_parent_section_leaf_array(
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex"
+! CHECK:  %[[VAL_7:.*]] = hlfir.designate %[[VAL_1]]#0 ({{.*}})  shape %[[VAL_6:.*]] : (!fir.class<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>, index, index, index, !fir.shape<1>) -> !fir.class<!fir.array<10x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>
+! CHECK:  %[[VAL_8:.*]] = hlfir.parent_comp %[[VAL_7]] shape %[[VAL_6]] : (!fir.class<!fir.array<10x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.type<_QMpc_typesTt{i:i32}>>>
+! CHECK:  %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.box<!fir.array<10x!fir.type<_QMpc_typesTt{i:i32}>>>) -> !fir.box<!fir.array<?x!fir.type<_QMpc_typesTt{i:i32}>>>
+! CHECK:  fir.call @_QPtakes_t_type_array(%[[VAL_9]])
+
+subroutine test_pointer_leaf_parent_ref_array(x)
+ use pc_types
+ class(t2), pointer :: x(:)
+ call takes_t_type_array(x%t)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_pointer_leaf_parent_ref_array(
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex"
+! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>>>
+! CHECK:  %[[VAL_3:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_4:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_3]] : (!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_5:.*]] = fir.shape %[[VAL_4]]#1 : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_6:.*]] = hlfir.parent_comp %[[VAL_2]] shape %[[VAL_5]] : (!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpc_typesTt2{i:i32,j:i32}>>>>, !fir.shape<1>) -> !fir.box<!fir.array<?x!fir.type<_QMpc_typesTt{i:i32}>>>