Zero size arrays of derived type (#1050)

Fix two problems with zero size arrays with derived type elements.

The first problem occurs when the derived type element of a zero size
array has default initialization.  -- fix in ConvertVariable.cpp

  type dt
    integer :: j = 17
  end type
  type(dt) :: z(0)

The second problem occurs when the derived type element of a zero size
array has an explicit, conformable, scalar initialization.  That appears
to be standard conforming, if not too useful, although it has the side
affect of forcing the SAVE attribute on z.  -- fix in ConvertExpr.cpp

  type dt
    integer :: j
  end type
  type(dt) :: z(0) = dt(99)

Also add a verifier for fir.insert_on_range ops, which triggers for
the first test case without the corresponding fix.

Author: vdonaldson

flang/include/flang/Optimizer/Dialect/FIROps.td

@@ -2222,9 +2222,20 @@ def fir_InsertOnRangeOp : fir_OneResultOp<"insert_on_range", [NoSideEffect]> {
   let summary = "insert sub-value into a range on an existing sequence";
 
   let description = [{
-    Insert a constant value into an entity with an array type. Returns a
-    new ssa value where the range of offsets from the original array have been
-    replaced with the constant. The result is an array type entity.
+    Insert copies of a value into an entity with an array type.
+    Returns a new ssa value with the same type as the original entity.
+    The values are inserted at a contiguous range of indices in Fortran
+    row-to-column element order as specified by lower and upper bound
+    coordinates.
+
+    ```mlir
+      %a = fir.undefined !fir.array<10x10xf32>
+      %c = constant 3.0 : f32
+      %1 = fir.insert_on_range %a, %c, [0 : index, 7 : index, 0 : index, 2 : index] : (!fir.array<10x10xf32>, f32) -> !fir.array<10x10xf32>
+    ```
+
+    The first 28 elements of %1, with coordinates from (0,0) to (7,2), have
+    the value 3.0.
   }];
 
   let arguments = (ins fir_SequenceType:$seq, AnyType:$val, ArrayAttr:$coor);
@@ -2238,6 +2249,8 @@ def fir_InsertOnRangeOp : fir_OneResultOp<"insert_on_range", [NoSideEffect]> {
     OpBuilder<(ins "mlir::Type":$rty, "mlir::Value":$adt, "mlir::Value":$val,
       "llvm::ArrayRef<mlir::Value>":$vcoor)>
   ];
+
+  let verifier = [{ return ::verify(*this); }];
 }
 
 def fir_LenParamIndexOp : fir_OneResultOp<"len_param_index", [NoSideEffect]> {

flang/lib/Lower/ConvertExpr.cpp

@@ -1100,20 +1100,20 @@ class ScalarExprLowering {
       eleTy = converter.genType(TC, KIND);
     auto arrayTy = fir::SequenceType::get(shape, eleTy);
     mlir::Value array = builder.create<fir::UndefOp>(loc, arrayTy);
-    if (size == 0) {
-      if constexpr (TC == Fortran::common::TypeCategory::Character) {
-        auto len = builder.createIntegerConstant(loc, idxTy, con.LEN());
-        return fir::CharArrayBoxValue{array, len, {}, {}};
-      } else {
-        return fir::ArrayBoxValue{array, {}, {}};
-      }
-    }
     llvm::SmallVector<mlir::Value> lbounds;
     llvm::SmallVector<mlir::Value> extents;
     for (auto [lb, extent] : llvm::zip(con.lbounds(), shape)) {
       lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1));
       extents.push_back(builder.createIntegerConstant(loc, idxTy, extent));
     }
+    if (size == 0) {
+      if constexpr (TC == Fortran::common::TypeCategory::Character) {
+        auto len = builder.createIntegerConstant(loc, idxTy, con.LEN());
+        return fir::CharArrayBoxValue{array, len, extents, lbounds};
+      } else {
+        return fir::ArrayBoxValue{array, extents, lbounds};
+      }
+    }
     Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds();
     auto createIdx = [&]() {
       llvm::SmallVector<mlir::Value> idx;
@@ -1169,25 +1169,28 @@ class ScalarExprLowering {
 
   fir::ExtendedValue genArrayLit(
       const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) {
+    auto loc = getLoc();
+    auto idxTy = builder.getIndexType();
+    auto size = Fortran::evaluate::GetSize(con.shape());
+    fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end());
+    auto eleTy = converter.genType(con.GetType().GetDerivedTypeSpec());
+    auto arrayTy = fir::SequenceType::get(shape, eleTy);
+    mlir::Value array = builder.create<fir::UndefOp>(loc, arrayTy);
     llvm::SmallVector<mlir::Value> lbounds;
     llvm::SmallVector<mlir::Value> extents;
-    auto idxTy = builder.getIndexType();
     for (auto [lb, extent] : llvm::zip(con.lbounds(), con.shape())) {
-      lbounds.push_back(builder.createIntegerConstant(getLoc(), idxTy, lb - 1));
-      extents.push_back(builder.createIntegerConstant(getLoc(), idxTy, extent));
+      lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1));
+      extents.push_back(builder.createIntegerConstant(loc, idxTy, extent));
     }
-    fir::SequenceType::Shape shape;
-    shape.append(con.shape().begin(), con.shape().end());
-    auto recTy = converter.genType(con.GetType().GetDerivedTypeSpec());
-    auto arrayTy = fir::SequenceType::get(shape, recTy);
-    mlir::Value array = builder.create<fir::UndefOp>(getLoc(), arrayTy);
+    if (size == 0)
+      return fir::ArrayBoxValue{array, extents, lbounds};
     Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds();
     do {
       auto derivedVal = fir::getBase(genval(con.At(subscripts)));
       llvm::SmallVector<mlir::Value> idx;
       for (auto [dim, lb] : llvm::zip(subscripts, con.lbounds()))
-        idx.push_back(builder.createIntegerConstant(getLoc(), idxTy, dim - lb));
-      array = builder.create<fir::InsertValueOp>(getLoc(), arrayTy, array,
+        idx.push_back(builder.createIntegerConstant(loc, idxTy, dim - lb));
+      array = builder.create<fir::InsertValueOp>(loc, arrayTy, array,
                                                  derivedVal, idx);
     } while (con.IncrementSubscripts(subscripts));
     return fir::ArrayBoxValue{array, extents, lbounds};

flang/lib/Lower/ConvertVariable.cpp

@@ -87,9 +87,9 @@ static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter,
       loc, converter, expr, symMap, context));
 }
 
-/// Does this variable has a default initialization ?
+/// Does this variable have a default initialization?
 static bool hasDefaultInitialization(const Fortran::semantics::Symbol &sym) {
-  if (sym.has<Fortran::semantics::ObjectEntityDetails>())
+  if (sym.has<Fortran::semantics::ObjectEntityDetails>() && sym.size())
     if (!Fortran::semantics::IsAllocatableOrPointer(sym))
       if (const auto *declTypeSpec = sym.GetType())
         if (const auto *derivedTypeSpec = declTypeSpec->AsDerived())

flang/lib/Optimizer/Dialect/FIROps.cpp

@@ -991,6 +991,23 @@ void fir::InsertOnRangeOp::build(mlir::OpBuilder &builder,
   build(builder, result, resTy, aggVal, eleVal, aa);
 }
 
+/// Range bounds must be nonnegative, and the range must not be empty.
+static mlir::LogicalResult verify(fir::InsertOnRangeOp op) {
+  bool rangeIsKnownToBeNonempty = false;
+  for (auto i = op.coor().end(), b = op.coor().begin(); i != b;) {
+    int64_t ub = (*--i).cast<IntegerAttr>().getInt();
+    int64_t lb = (*--i).cast<IntegerAttr>().getInt();
+    if (lb < 0 || ub < 0)
+      return op.emitOpError("negative range bound");
+    if (rangeIsKnownToBeNonempty)
+      continue;
+    if (lb > ub)
+      return op.emitOpError("empty range");
+    rangeIsKnownToBeNonempty = lb < ub;
+  }
+  return mlir::success();
+}
+
 //===----------------------------------------------------------------------===//
 // InsertValueOp
 //===----------------------------------------------------------------------===//

flang/test/Lower/zero-size.f90

@@ -1,20 +1,46 @@
 ! RUN: bbc -o - %s | FileCheck %s
 
-! CHECK-LABEL: _QPzero
-subroutine zero(aa)
-  real, dimension(:) :: aa
-  print*, size(aa)
+! CHECK-LABEL: _QPzero1
+subroutine zero1(z)
+  real, dimension(:) :: z
+  print*, size(z), z, ':'
+end
+
+! CHECK-LABEL: _QPzero2
+subroutine zero2
+  type dt
+    integer :: j = 17
+  end type
+  ! CHECK: %[[z:[0-9]*]] = fir.alloca !fir.array<0x!fir.type<_QFzero2Tdt{j:i32}>> {bindc_name = "z", uniq_name = "_QFzero2Ez"}
+  ! CHECK: %[[shape:[0-9]*]] = fir.shape %c0 : (index) -> !fir.shape<1>
+  ! CHECK: fir.embox %[[z]](%[[shape]]) : (!fir.ref<!fir.array<0x!fir.type<_QFzero2Tdt{j:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<0x!fir.type<_QFzero2Tdt{j:i32}>>>
+  type(dt) :: z(0)
+  print*, size(z), z, ':'
+end
+
+! CHECK-LABEL: _QPzero3
+subroutine zero3
+  type dt
+    integer :: j
+  end type
+  ! CHECK: %[[z:[0-9]*]] = fir.address_of(@_QFzero3Ez) : !fir.ref<!fir.array<0x!fir.type<_QFzero3Tdt{j:i32}>>>
+  ! CHECK: %[[shape:[0-9]*]] = fir.shape %c0 : (index) -> !fir.shape<1>
+  ! CHECK: fir.embox %[[z]](%[[shape]]) : (!fir.ref<!fir.array<0x!fir.type<_QFzero3Tdt{j:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<0x!fir.type<_QFzero3Tdt{j:i32}>>>
+  type(dt) :: z(0) = dt(99)
+  print*, size(z), z, ':'
 end
 
 ! CHECK-LABEL: _QQmain
 program prog
   real nada(2:-1)
   interface
-    subroutine zero(aa)
+    subroutine zero1(aa)
       real, dimension(:) :: aa
     end
   end interface
   ! CHECK: %[[shape:[0-9]*]] = fir.shape_shift %c2, %c0 : (index, index) -> !fir.shapeshift<1>
   ! CHECK: %2 = fir.embox %0(%[[shape]]) : (!fir.ref<!fir.array<0xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.array<0xf32>>
-  call zero(nada)
+  call zero1(nada)
+  call zero2
+  call zero3
 end