[flang] Handle dynamic array lowering

[clementval]

Summary

This patch enables dynamic array lowering
and use the funcationality inside some IO tests.

This patch is part of the upstreaming effort from fir-dev branch.

Depends on D120743

[PeteSteinfeld]

All builds and tests correctly and looks good.

[clementval]

Rebase

[clementval]

Rebase

flang/lib/Lower/Bridge.cpp

private:
   void genFIR(const Fortran::parser::AssociateStmt &) {
     TODO(toLocation(), "AssociateStmt lowering");
   }
 
   void genFIR(const Fortran::parser::CaseStmt &) {
     TODO(toLocation(), "CaseStmt lowering");
   }
 
-  void genFIR(const Fortran::parser::ContinueStmt &) {
-    TODO(toLocation(), "ContinueStmt lowering");
-  }
-
   void genFIR(const Fortran::parser::ElseIfStmt &) {
     TODO(toLocation(), "ElseIfStmt lowering");
   }
 
   void genFIR(const Fortran::parser::ElseStmt &) {
     TODO(toLocation(), "ElseStmt lowering");
   }
 
void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {
     TODO(toLocation(), "EndMpSubprogramStmt lowering");
   }
 
   void genFIR(const Fortran::parser::EndSelectStmt &) {
     TODO(toLocation(), "EndSelectStmt lowering");
   }
 
   // Nop statements - No code, or code is generated at the construct level.
+  void genFIR(const Fortran::parser::ContinueStmt &) {}      // nop
   void genFIR(const Fortran::parser::EndFunctionStmt &) {}   // nop
   void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
 
   void genFIR(const Fortran::parser::EntryStmt &) {
     TODO(toLocation(), "EntryStmt lowering");
   }
 
   void genFIR(const Fortran::parser::IfStmt &) {

flang/lib/Lower/ConvertExpr.cpp

 #include "flang/Lower/ComponentPath.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/DumpEvaluateExpr.h"
 #include "flang/Lower/IntrinsicCall.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/Factory.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
   mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) {
     assert(box.rank() > 0 && "must be an array");
     mlir::Location loc = getLoc();
     mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
     mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one);
     return builder.createConvert(loc, ty, lb);
   }
 
+  static bool isSlice(const Fortran::evaluate::ArrayRef &aref) {
+    for (const Fortran::evaluate::Subscript &sub : aref.subscript())
+      if (std::holds_alternative<Fortran::evaluate::Triplet>(sub.u))
+        return true;
+    return false;
+  }
+
   /// Lower an ArrayRef to a fir.coordinate_of given its lowered base.
   ExtValue genCoordinateOp(const ExtValue &array,
                            const Fortran::evaluate::ArrayRef &aref) {
     mlir::Location loc = getLoc();
     // References to array of rank > 1 with non constant shape that are not
     // fir.box must be collapsed into an offset computation in lowering already.
     // The same is needed with dynamic length character arrays of all ranks.
     mlir::Type baseType =
         fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(array).getType());
     if ((array.rank() > 1 && fir::hasDynamicSize(baseType)) ||
         fir::characterWithDynamicLen(fir::unwrapSequenceType(baseType)))
       if (!array.getBoxOf<fir::BoxValue>())
-        TODO(getLoc(), "genOffsetAndCoordinateOp");
+        return genOffsetAndCoordinateOp(array, aref);
     // Generate a fir.coordinate_of with zero based array indexes.
     llvm::SmallVector<mlir::Value> args;
     for (const auto &subsc : llvm::enumerate(aref.subscript())) {
       ExtValue subVal = genSubscript(subsc.value());
       assert(fir::isUnboxedValue(subVal) && "subscript must be simple scalar");
       mlir::Value val = fir::getBase(subVal);
       mlir::Type ty = val.getType();
       mlir::Value lb = getLBound(array, subsc.index(), ty);
       args.push_back(builder.create<mlir::arith::SubIOp>(loc, ty, val, lb));
     }
 
     mlir::Value base = fir::getBase(array);
     auto seqTy =
         fir::dyn_cast_ptrOrBoxEleTy(base.getType()).cast<fir::SequenceType>();
     assert(args.size() == seqTy.getDimension());
     mlir::Type ty = builder.getRefType(seqTy.getEleTy());
     auto addr = builder.create<fir::CoordinateOp>(loc, ty, base, args);
     return fir::factory::arrayElementToExtendedValue(builder, loc, array, addr);
   }
 
+  /// Lower an ArrayRef to a fir.coordinate_of using an element offset instead
+  /// of array indexes.
+  /// This generates offset computation from the indexes and length parameters,
+  /// and use the offset to access the element with a fir.coordinate_of. This
+  /// must only be used if it is not possible to generate a normal
+  /// fir.coordinate_of using array indexes (i.e. when the shape information is
+  /// unavailable in the IR).
+  ExtValue genOffsetAndCoordinateOp(const ExtValue &array,
+                                    const Fortran::evaluate::ArrayRef &aref) {
+    mlir::Location loc = getLoc();
+    mlir::Value addr = fir::getBase(array);
+    mlir::Type arrTy = fir::dyn_cast_ptrEleTy(addr.getType());
+    auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
+    mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(eleTy));
+    mlir::Type refTy = builder.getRefType(eleTy);
+    mlir::Value base = builder.createConvert(loc, seqTy, addr);
+    mlir::IndexType idxTy = builder.getIndexType();
+    mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+    mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
+    auto getLB = [&](const auto &arr, unsigned dim) -> mlir::Value {
+      return arr.getLBounds().empty() ? one : arr.getLBounds()[dim];
+    };
+    auto genFullDim = [&](const auto &arr, mlir::Value delta) -> mlir::Value {
+      mlir::Value total = zero;
+      assert(arr.getExtents().size() == aref.subscript().size());
+      delta = builder.createConvert(loc, idxTy, delta);
+      unsigned dim = 0;
+      for (auto [ext, sub] : llvm::zip(arr.getExtents(), aref.subscript())) {
+        ExtValue subVal = genSubscript(sub);
+        assert(fir::isUnboxedValue(subVal));
+        mlir::Value val =
+            builder.createConvert(loc, idxTy, fir::getBase(subVal));
+        mlir::Value lb = builder.createConvert(loc, idxTy, getLB(arr, dim));
+        mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, val, lb);
+        mlir::Value prod =
+            builder.create<mlir::arith::MulIOp>(loc, delta, diff);
+        total = builder.create<mlir::arith::AddIOp>(loc, prod, total);
+        if (ext)
+          delta = builder.create<mlir::arith::MulIOp>(loc, delta, ext);
+        ++dim;
+      }
+      mlir::Type origRefTy = refTy;
+      if (fir::factory::CharacterExprHelper::isCharacterScalar(refTy)) {
+        fir::CharacterType chTy =
+            fir::factory::CharacterExprHelper::getCharacterType(refTy);
+        if (fir::characterWithDynamicLen(chTy)) {
+          mlir::MLIRContext *ctx = builder.getContext();
+          fir::KindTy kind =
+              fir::factory::CharacterExprHelper::getCharacterKind(chTy);
+          fir::CharacterType singleTy =
+              fir::CharacterType::getSingleton(ctx, kind);
+          refTy = builder.getRefType(singleTy);
+          mlir::Type seqRefTy =
+              builder.getRefType(builder.getVarLenSeqTy(singleTy));
+          base = builder.createConvert(loc, seqRefTy, base);
+        }
+      }
+      auto coor = builder.create<fir::CoordinateOp>(
+          loc, refTy, base, llvm::ArrayRef<mlir::Value>{total});
+      // Convert to expected, original type after address arithmetic.
+      return builder.createConvert(loc, origRefTy, coor);
+    };
+    return array.match(
+        [&](const fir::ArrayBoxValue &arr) -> ExtValue {
+          // FIXME: this check can be removed when slicing is implemented
+          if (isSlice(aref))
+            fir::emitFatalError(
+                getLoc(),
+                "slice should be handled in array expression context");
+          return genFullDim(arr, one);
+        },
+        [&](const fir::CharArrayBoxValue &arr) -> ExtValue {
+          mlir::Value delta = arr.getLen();
+          // If the length is known in the type, fir.coordinate_of will
+          // already take the length into account.
+          if (fir::factory::CharacterExprHelper::hasConstantLengthInType(arr))
+            delta = one;
+          return fir::CharBoxValue(genFullDim(arr, delta), arr.getLen());
+        },
+        [&](const fir::BoxValue &arr) -> ExtValue {
+          // CoordinateOp for BoxValue is not generated here. The dimensions
+          // must be kept in the fir.coordinate_op so that potential fir.box
+          // strides can be applied by codegen.
+          fir::emitFatalError(
+              loc, "internal: BoxValue in dim-collapsed fir.coordinate_of");
+        },
+        [&](const auto &) -> ExtValue {
+          fir::emitFatalError(loc, "internal: array lowering failed");
+        });
+  }
+
   ExtValue gen(const Fortran::evaluate::ArrayRef &aref) {
     ExtValue base = aref.base().IsSymbol() ? gen(aref.base().GetFirstSymbol())
                                            : gen(aref.base().GetComponent());
     return genCoordinateOp(base, aref);
   }
   ExtValue genval(const Fortran::evaluate::ArrayRef &aref) {
-    TODO(getLoc(), "genval ArrayRef");
+    return genLoad(gen(aref));
   }
 
   ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) {
     TODO(getLoc(), "gen CoarrayRef");
   }
   ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) {
     TODO(getLoc(), "genval CoarrayRef");
   }

flang/lib/Lower/ConvertVariable.cpp

if (lowerToBoxValue(sym, dummyArg)) {
       lowerExplicitExtents(converter, loc, ba, lbounds, extents, symMap,
                            stmtCtx);
       symMap.addBoxSymbol(sym, dummyArg, lbounds, explicitParams, extents,
                           replace);
       return;
     }
   }
 
+  // Helper to generate scalars for the symbol properties.
+  auto genValue = [&](const Fortran::lower::SomeExpr &expr) {
+    return genScalarValue(converter, loc, expr, symMap, stmtCtx);
+  };
+
+  // For symbols reaching this point, all properties are constant and can be
+  // read/computed already into ssa values.
+
+  // The origin must be \vec{1}.
+  auto populateShape = [&](auto &shapes, const auto &bounds, mlir::Value box) {
+    for (auto iter : llvm::enumerate(bounds)) {
+      auto *spec = iter.value();
+      assert(spec->lbound().GetExplicit() &&
+             "lbound must be explicit with constant value 1");
+      if (auto high = spec->ubound().GetExplicit()) {
+        Fortran::lower::SomeExpr highEx{*high};
+        mlir::Value ub = genValue(highEx);
+        shapes.emplace_back(builder.createConvert(loc, idxTy, ub));
+      } else if (spec->ubound().isColon()) {
+        assert(box && "assumed bounds require a descriptor");
+        mlir::Value dim =
+            builder.createIntegerConstant(loc, idxTy, iter.index());
+        auto dimInfo =
+            builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim);
+        shapes.emplace_back(dimInfo.getResult(1));
+      } else if (spec->ubound().isStar()) {
+        shapes.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
+      } else {
+        llvm::report_fatal_error("unknown bound category");
+      }
+    }
+  };
+
+  // The origin is not \vec{1}.
+  auto populateLBoundsExtents = [&](auto &lbounds, auto &extents,
+                                    const auto &bounds, mlir::Value box) {
+    for (auto iter : llvm::enumerate(bounds)) {
+      auto *spec = iter.value();
+      fir::BoxDimsOp dimInfo;
+      mlir::Value ub, lb;
+      if (spec->lbound().isColon() || spec->ubound().isColon()) {
+        // This is an assumed shape because allocatables and pointers extents
+        // are not constant in the scope and are not read here.
+        assert(box && "deferred bounds require a descriptor");
+        mlir::Value dim =
+            builder.createIntegerConstant(loc, idxTy, iter.index());
+        dimInfo =
+            builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim);
+        extents.emplace_back(dimInfo.getResult(1));
+        if (auto low = spec->lbound().GetExplicit()) {
+          auto expr = Fortran::lower::SomeExpr{*low};
+          mlir::Value lb = builder.createConvert(loc, idxTy, genValue(expr));
+          lbounds.emplace_back(lb);
+        } else {
+          // Implicit lower bound is 1 (Fortran 2018 section 8.5.8.3 point 3.)
+          lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, 1));
+        }
+      } else {
+        if (auto low = spec->lbound().GetExplicit()) {
+          auto expr = Fortran::lower::SomeExpr{*low};
+          lb = builder.createConvert(loc, idxTy, genValue(expr));
+        } else {
+          TODO(loc, "assumed rank lowering");
+        }
+
+        if (auto high = spec->ubound().GetExplicit()) {
+          auto expr = Fortran::lower::SomeExpr{*high};
+          ub = builder.createConvert(loc, idxTy, genValue(expr));
+          lbounds.emplace_back(lb);
+          extents.emplace_back(computeExtent(builder, loc, lb, ub));
+        } else {
+          // An assumed size array. The extent is not computed.
+          assert(spec->ubound().isStar() && "expected assumed size");
+          lbounds.emplace_back(lb);
+          extents.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
+        }
+      }
+    }
+  };
+
   // For symbols reaching this point, all properties are constant and can be
   // read/computed already into ssa values.
 
   ba.match(
       //===--------------------------------------------------------------===//
       // Trivial case.
       //===--------------------------------------------------------------===//
       [&](const Fortran::lower::details::ScalarSym &) {
ba.match(
                     : createNewLocal(converter, loc, var, preAlloc, extents);
         assert(isDummy || Fortran::lower::isExplicitShape(sym));
         symMap.addSymbolWithBounds(sym, local, extents, lbounds, isDummy);
       },
 
       //===--------------------------------------------------------------===//
 
       [&](const Fortran::lower::details::DynamicArray &x) {
-        TODO(loc, "DynamicArray variable lowering");
+        // cast to the known constant parts from the declaration
+        mlir::Type varType = converter.genType(var);
+        mlir::Value addr = symMap.lookupSymbol(sym).getAddr();
+        mlir::Value argBox;
+        mlir::Type castTy = builder.getRefType(varType);
+        if (addr) {
+          if (auto boxTy = addr.getType().dyn_cast<fir::BoxType>()) {
+            argBox = addr;
+            mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
+            addr = builder.create<fir::BoxAddrOp>(loc, refTy, argBox);
+          }
+          addr = builder.createConvert(loc, castTy, addr);
+        }
+        if (x.lboundAllOnes()) {
+          // if lower bounds are all ones, build simple shaped object
+          llvm::SmallVector<mlir::Value> shapes;
+          populateShape(shapes, x.bounds, argBox);
+          if (isDummy) {
+            symMap.addSymbolWithShape(sym, addr, shapes, true);
+            return;
+          }
+          // local array with computed bounds
+          assert(Fortran::lower::isExplicitShape(sym) ||
+                 Fortran::semantics::IsAllocatableOrPointer(sym));
+          mlir::Value local =
+              createNewLocal(converter, loc, var, preAlloc, shapes);
+          symMap.addSymbolWithShape(sym, local, shapes);
+          return;
+        }
+        // if object is an array process the lower bound and extent values
+        llvm::SmallVector<mlir::Value> extents;
+        llvm::SmallVector<mlir::Value> lbounds;
+        populateLBoundsExtents(lbounds, extents, x.bounds, argBox);
+        if (isDummy) {
+          symMap.addSymbolWithBounds(sym, addr, extents, lbounds, true);
+          return;
+        }
+        // local array with computed bounds
+        assert(Fortran::lower::isExplicitShape(sym));
+        mlir::Value local =
+            createNewLocal(converter, loc, var, preAlloc, extents);
+        symMap.addSymbolWithBounds(sym, local, extents, lbounds);
       },
 
       //===--------------------------------------------------------------===//
 
       [&](const Fortran::lower::details::StaticArrayStaticChar &x) {
         TODO(loc, "StaticArrayStaticChar variable lowering");
       },
 

flang/test/Lower/io-statement-1.f90

-! RUN: bbc %s -o - | FileCheck %s
+! RUN: bbc %s -emit-fir -o - | FileCheck %s
 ! UNSUPPORTED: system-windows
 
  logical :: existsvar
  integer :: length
  real :: a(100)
 
   ! CHECK-LABEL: _QQmain
   ! CHECK: call {{.*}}BeginExternalListInput

flang/test/Lower/io-statement-2.f90

 ! RUN: bbc -emit-fir -o - %s | FileCheck %s
+! UNSUPPORTED: system-windows
 
    character*10 :: exx
    character*30 :: m
    integer*2 :: s
    exx = 'AA'
    m = 'CCCCCC'
    s = -13
    ! CHECK: call {{.*}}BeginExternalFormattedInput
    ! CHECK: call {{.*}}EnableHandlers
    ! CHECK: call {{.*}}SetAdvance
    ! CHECK: call {{.*}}InputReal
    ! CHECK: call {{.*}}GetIoMsg
    ! CHECK: call {{.*}}EndIoStatement
    ! CHECK: fir.select %{{.*}} : index [-2, ^bb4, -1, ^bb3, 0, ^bb1, unit, ^bb2]
    read(*, '(A)', ADVANCE='NO', ERR=10, END=20, EOR=30, IOSTAT=s, IOMSG=m) f
    ! CHECK-LABEL: ^bb1:
    exx = 'Zip'; goto 90
 10 exx = 'Err'; goto 90
 20 exx = 'End'; goto 90
 30 exx = 'Eor'; goto 90
 90 print*, exx, c, m, s
 end
 
+! CHECK-LABEL: func @_QPcontrol0
+subroutine control0(n) ! no I/O condition specifier control flow
+dimension c(n), d(n,n), e(n,n), f(n)
+! CHECK-NOT: fir.if
+! CHECK: BeginExternalFormattedInput
+! CHECK-NOT: fir.if
+! CHECK: SetAdvance
+! CHECK-NOT: fir.if
+! CHECK: InputReal32
+! CHECK-NOT: fir.if
+! CHECK: InputReal32
+! CHECK-NOT: fir.if
+! CHECK: fir.do_loop
+! CHECK-NOT: fir.if
+! CHECK: InputReal32
+! CHECK-NOT: fir.if
+! CHECK: fir.do_loop
+! CHECK-NOT: fir.if
+! CHECK: InputReal32
+! CHECK-NOT: fir.if
+! CHECK: InputReal32
+! CHECK-NOT: fir.if
+! CHECK: InputReal32
+! CHECK-NOT: fir.if
+! CHECK: InputReal32
+! CHECK-NOT: fir.if
+! CHECK: EndIoStatement
+! CHECK-NOT: fir.if
+read(*,'(F7.2)', advance='no') a, b, (c(j), (d(k,j), e(k,j), k=1,n), f(j), j=1,n), g
+end
+
+! CHECK-LABEL: func @_QPcontrol1
+subroutine control1(n) ! I/O condition specifier control flow
+! CHECK: BeginExternalFormattedInput
+! CHECK: EnableHandlers
+! CHECK: SetAdvance
+! CHECK: fir.if
+! CHECK: InputReal32
+! CHECK: fir.if
+! CHECK: InputReal32
+! CHECK: fir.if
+! CHECK: fir.iterate_while
+! CHECK: fir.if
+! CHECK: InputReal32
+! CHECK: fir.if
+! CHECK: fir.iterate_while
+! CHECK: fir.if
+! CHECK: InputReal32
+! CHECK: fir.if
+! CHECK: InputReal32
+! CHECK: fir.if
+! CHECK: InputReal32
+! CHECK: fir.if
+! CHECK: InputReal32
+! CHECK: EndIoStatement
+dimension c(n), d(n,n), e(n,n), f(n)
+read(*,'(F7.2)', iostat=mm, advance='no') a, b, (c(j), (d(k,j), e(k,j), k=1,n), f(j), j=1,n), g
+end
+
+! CHECK-LABEL: func @_QPcontrol2
+subroutine control2() ! I/O condition specifier control flow (use index result)
+c = 1; d = 9
+! CHECK: BeginExternalFormattedOutput
+! CHECK: EnableHandlers
+! CHECK: :2 = fir.iterate_while
+! CHECK: = fir.if
+! CHECK: OutputReal
+! CHECK: = fir.if
+! CHECK: OutputReal
+! CHECK: fir.result
+! CHECK: else
+! CHECK: fir.result %false
+! CHECK: fir.result
+! CHECK: else
+! CHECK: fir.result %false
+! CHECK: = arith.addi %arg0, %c1
+! CHECK: = arith.select
+! CHECK: fir.result
+! CHECK: fir.if %{{[0-9]*}}#1
+! CHECK: OutputInteger
+! CHECK: EndIoStatement
+write(*,'(8F4.1,I5)',iostat=m) (c,d,j=11,14), j
+end
+
+! CHECK-LABEL: func @_QPloopnest
+subroutine loopnest
+   integer :: aa(3,3)
+   aa = 10
+   ! CHECK: BeginExternalListOutput
+   ! CHECK: EnableHandlers
+   ! CHECK: {{.*}}:2 = fir.iterate_while ({{.*}} = {{.*}} to {{.*}} step {{.*}}) and ({{.*}} = {{.*}}) -> (index, i1) {
+   ! CHECK:   fir.if {{.*}} -> (i1) {
+   ! CHECK:     {{.*}}:2 = fir.iterate_while ({{.*}} = {{.*}} to {{.*}} step {{.*}}) and ({{.*}} = {{.*}}) -> (index, i1) {
+   ! CHECK:       fir.if {{.*}} -> (i1) {
+   ! CHECK:         OutputInteger32
+   ! CHECK:         fir.result {{.*}} : i1
+   ! CHECK:       } else {
+   ! CHECK:         fir.result {{.*}} : i1
+   ! CHECK:       }
+   ! CHECK:       fir.result {{.*}}, {{.*}} : index, i1
+   ! CHECK:     }
+   ! CHECK:     fir.result {{.*}}#1 : i1
+   ! CHECK:   } else {
+   ! CHECK:     fir.result {{.*}} : i1
+   ! CHECK:   }
+   ! CHECK:   fir.result {{.*}}, {{.*}} : index, i1
+   ! CHECK: }
+   ! CHECK: EndIoStatement
+   write(*,*,err=66) ((aa(j,k)+j+k,j=1,3),k=1,3)
+66 continue
+end
+
 ! CHECK-LABEL: func @_QPimpliedformat
 subroutine impliedformat
   ! CHECK: BeginExternalListInput(%c-1
   ! CHECK: InputReal32
   ! CHECK: EndIoStatement(%3) : (!fir.ref<i8>) -> i32
   read*, x
   ! CHECK: BeginExternalListOutput(%c-1
   ! CHECK: OutputReal32
   ! CHECK: EndIoStatement
   print*, x
 end