[flang][hlfir] Implemented addressing an element of a polymorphic array.

[vzakhari]

Summary

The changes convert hlfir.designate to fir.array_coor/fir.embox
to represent a subscripted element of a polymorphic array.
The type information is conveyed via the fir.embox's source_box.

[tblah]

flang/test/HLFIR/designate-codegen.fir

204

This value is unused. Are there cases when it is used?

[vzakhari]

flang/test/HLFIR/designate-codegen.fir

204

This rebox is part of hlfir.declare HLFIR-to-FIR conversion pattern. The local box is used, for example, here:

subroutine test(x)
  real x(:)
  call callee(x)
end subroutine test

%2 = fir.declare %arg0 {uniq_name = "_QFtestEx"} : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xf32>>
%3 = fir.rebox %2 : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xf32>>
%4 = fir.convert %3 : (!fir.box<!fir.array<?xf32>>) -> !fir.box<none>
%5 = fir.call @_FortranAIsContiguous(%4) : (!fir.box<none>) -> i1
%6 = fir.if %5 -> (!fir.box<!fir.array<?xf32>>) {

[tblah]

Thanks for explaining. This looks good to me.

flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp

matchAndRewrite(hlfir::DeclareOp declareOp,
     }
     rewriter.replaceOp(declareOp, {hlfirBase, firBase});
     return mlir::success();
   }
 };
 
 class DesignateOpConversion
     : public mlir::OpRewritePattern<hlfir::DesignateOp> {
+  // Helper method to generate the coordinate of the first element
+  // of an array section. It is also called for cases of non-section
+  // array element addressing.
+  static mlir::Value genSubscriptBeginAddr(
+      fir::FirOpBuilder &builder, mlir::Location loc,
+      hlfir::DesignateOp designate, mlir::Type baseEleTy, mlir::Value base,
+      mlir::Value shape,
+      const llvm::SmallVector<mlir::Value> &firBaseTypeParameters) {
+    assert(!designate.getIndices().empty());
+    llvm::SmallVector<mlir::Value> firstElementIndices;
+    auto indices = designate.getIndices();
+    int i = 0;
+    for (auto isTriplet : designate.getIsTripletAttr().asArrayRef()) {
+      // Coordinate of the first element are the index and triplets lower
+      // bounds
+      firstElementIndices.push_back(indices[i]);
+      i = i + (isTriplet ? 3 : 1);
+    }
+    mlir::Type arrayCoorType = fir::ReferenceType::get(baseEleTy);
+    base = builder.create<fir::ArrayCoorOp>(
+        loc, arrayCoorType, base, shape,
+        /*slice=*/mlir::Value{}, firstElementIndices, firBaseTypeParameters);
+    return base;
+  }
+
 public:
   explicit DesignateOpConversion(mlir::MLIRContext *ctx)
       : OpRewritePattern{ctx} {}
 
   mlir::LogicalResult
   matchAndRewrite(hlfir::DesignateOp designate,
                   mlir::PatternRewriter &rewriter) const override {
     mlir::Location loc = designate.getLoc();
if (designate.getComponent()) {
         // array%component[(indices) substring|complex part] cases.
         // Component ref of array bases are dealt with below in embox/rebox.
         assert(designateResultType.isa<fir::BaseBoxType>());
       }
     }
 
     if (designateResultType.isa<fir::BaseBoxType>()) {
       // Generate embox or rebox.
-      if (!fir::unwrapPassByRefType(designateResultType)
-               .isa<fir::SequenceType>())
-        TODO(loc, "addressing polymorphic arrays");
+      mlir::Type eleTy = fir::unwrapPassByRefType(designateResultType);
+      bool isScalarDesignator = !eleTy.isa<fir::SequenceType>();
+      mlir::Value sourceBox;
+      if (isScalarDesignator) {
+        // The base box will be used for emboxing the scalar element.
+        sourceBox = base;
+        // Generate the coordinate of the element.
+        base = genSubscriptBeginAddr(builder, loc, designate, baseEleTy, base,
+                                     shape, firBaseTypeParameters);
+        shape = nullptr;
+        // Type information will be taken from the source box,
+        // so the type parameters are not needed.
+        firBaseTypeParameters.clear();
+      }
       llvm::SmallVector<mlir::Value> triples;
       llvm::SmallVector<mlir::Value> sliceFields;
       mlir::Type idxTy = builder.getIndexType();
       auto subscripts = designate.getIndices();
       if (fieldIndex && baseEntity.isArray()) {
         // array%scalar_comp or array%array_comp(indices)
         // Generate triples for array(:, :, ...).
         triples = genFullSliceTriples(builder, loc, baseEntity);
         sliceFields.push_back(fieldIndex);
         // Add indices in the field path for "array%array_comp(indices)"
         // case. The indices of components provided to the sliceOp must
         // be zero based (fir.slice has no knowledge of the component
         // lower bounds). The component lower bounds are applied here.
         if (!subscripts.empty()) {
           llvm::SmallVector<mlir::Value> lbounds = hlfir::genLowerbounds(
               loc, builder, designate.getComponentShape(), subscripts.size());
           for (auto [i, lb] : llvm::zip(subscripts, lbounds)) {
             mlir::Value iIdx = builder.createConvert(loc, idxTy, i);
             mlir::Value lbIdx = builder.createConvert(loc, idxTy, lb);
             sliceFields.emplace_back(
                 builder.create<mlir::arith::SubIOp>(loc, iIdx, lbIdx));
           }
         }
-      } else {
+      } else if (!isScalarDesignator) {
         // Otherwise, this is an array section with triplets.
         auto undef = builder.create<fir::UndefOp>(loc, idxTy);
         unsigned i = 0;
         for (auto isTriplet : designate.getIsTriplet()) {
           triples.push_back(subscripts[i++]);
           if (isTriplet) {
             triples.push_back(subscripts[i++]);
             triples.push_back(subscripts[i++]);
if (designateResultType.isa<fir::BaseBoxType>()) {
       else
         assert(sliceFields.empty() && substring.empty());
       llvm::SmallVector<mlir::Type> resultType{designateResultType};
       mlir::Value resultBox;
       if (base.getType().isa<fir::BaseBoxType>())
         resultBox =
             builder.create<fir::ReboxOp>(loc, resultType, base, shape, slice);
       else
-        resultBox = builder.create<fir::EmboxOp>(loc, resultType, base, shape,
-                                                 slice, firBaseTypeParameters);
+        resultBox =
+            builder.create<fir::EmboxOp>(loc, resultType, base, shape, slice,
+                                         firBaseTypeParameters, sourceBox);
       rewriter.replaceOp(designate, resultBox);
       return mlir::success();
     }
 
     // Otherwise, the result is the address of a scalar, or the address of the
     // first element of a contiguous array section with compile time constant
     // shape. The base may be an array, or a scalar.
     mlir::Type resultAddressType = designateResultType;
     if (auto boxCharType = designateResultType.dyn_cast<fir::BoxCharType>())
       resultAddressType = fir::ReferenceType::get(boxCharType.getEleTy());
 
     // Array element indexing.
     if (!designate.getIndices().empty()) {
       // - array(indices) [substring|complex_part] or
       // - scalar%array_comp(indices) [substring|complex_part]
       // This may be a ranked contiguous array section in which case
       // The first element address is being computed.
-      llvm::SmallVector<mlir::Value> firstElementIndices;
-      auto indices = designate.getIndices();
-      int i = 0;
-      for (auto isTriplet : designate.getIsTripletAttr().asArrayRef()) {
-        // Coordinate of the first element are the index and triplets lower
-        // bounds
-        firstElementIndices.push_back(indices[i]);
-        i = i + (isTriplet ? 3 : 1);
-      }
-      mlir::Type arrayCoorType = fir::ReferenceType::get(baseEleTy);
-      base = builder.create<fir::ArrayCoorOp>(
-          loc, arrayCoorType, base, shape,
-          /*slice=*/mlir::Value{}, firstElementIndices, firBaseTypeParameters);
+      base = genSubscriptBeginAddr(builder, loc, designate, baseEleTy, base,
+                                   shape, firBaseTypeParameters);
     }
 
     // Scalar substring (potentially on the previously built array element or
     // component reference).
     if (!designate.getSubstring().empty())
       base = fir::factory::CharacterExprHelper{builder, loc}.genSubstringBase(
           base, designate.getSubstring()[0], resultAddressType);
 

flang/test/HLFIR/designate-codegen.fir

 // CHECK:  %[[VAL_7:.*]] = arith.constant 0 : index
 // CHECK:  %[[VAL_8:.*]]:3 = fir.box_dims %[[VAL_4]], %[[VAL_7]] : (!fir.box<!fir.array<?x!fir.char<1,5>>>, index) -> (index, index, index)
 // CHECK:  %[[VAL_9:.*]] = arith.constant 3 : index
 // CHECK:  %[[VAL_10:.*]] = arith.constant 42 : index
 // CHECK:  %[[VAL_11:.*]] = fir.shape %[[VAL_10]] : (index) -> !fir.shape<1>
 // CHECK:  %[[VAL_12:.*]] = fir.undefined index
 // CHECK:  %[[VAL_13:.*]] = fir.slice %[[VAL_6]], %[[VAL_8]]#1, %[[VAL_9]] : (index, index, index) -> !fir.slice<1>
 // CHECK:  %[[VAL_14:.*]] = fir.rebox %[[VAL_4]] {{\[}}%[[VAL_13]]] : (!fir.box<!fir.array<?x!fir.char<1,5>>>, !fir.slice<1>) -> !fir.box<!fir.array<?x!fir.char<1,5>>>
+
+func.func @test_polymorphic_array_elt(%arg0: !fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>> {fir.bindc_name = "x"}) {
+  %0:2 = hlfir.declare %arg0 {uniq_name = "_QFtest1Ex"} : (!fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>) -> (!fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>, !fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>)
+  %c7 = arith.constant 7 : index
+  %1 = hlfir.designate %0#0 (%c7)  : (!fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>, index) -> !fir.class<!fir.type<_QMtypesTt1>>
+  return
+}
+// CHECK-LABEL:   func.func @test_polymorphic_array_elt(
+// CHECK-SAME:        %[[VAL_0:.*]]: !fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>> {fir.bindc_name = "x"}) {
+// CHECK:           %[[VAL_1:.*]] = fir.declare %[[VAL_0]] {uniq_name = "_QFtest1Ex"} : (!fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>) -> !fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>
+// CHECK:           %[[VAL_2:.*]] = fir.rebox %[[VAL_1]] : (!fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>) -> !fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>
+// CHECK:           %[[VAL_3:.*]] = arith.constant 7 : index
+// CHECK:           %[[VAL_4:.*]] = fir.array_coor %[[VAL_1]] %[[VAL_3]] : (!fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>, index) -> !fir.ref<!fir.type<_QMtypesTt1>>
+// CHECK:           %[[VAL_5:.*]] = fir.embox %[[VAL_4]] source_box %[[VAL_1]] : (!fir.ref<!fir.type<_QMtypesTt1>>, !fir.class<!fir.array<?x!fir.type<_QMtypesTt1>>>) -> !fir.class<!fir.type<_QMtypesTt1>>
+// CHECK:           return
+// CHECK:         }