[flang] Handle lowering of ranked array

[clementval]

Summary

This patch adds lowering of ranked array as function return.

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

Co-authored-by: Jean Perier <[e-mail]>

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Lower/CallInterface.cpp

void buildImplicitInterface(
     if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
             &result = procedure.functionResult)
       handleImplicitResult(*result);
     else if (interface.side().hasAlternateReturns())
       addFirResult(mlir::IndexType::get(&mlirContext),
                    FirPlaceHolder::resultEntityPosition, Property::Value);
   }
 
+  void buildExplicitInterface(
+      const Fortran::evaluate::characteristics::Procedure &procedure) {
+    // Handle result
+    if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
+            &result = procedure.functionResult) {
+      if (result->CanBeReturnedViaImplicitInterface())
+        handleImplicitResult(*result);
+      else
+        handleExplicitResult(*result);
+    } else if (interface.side().hasAlternateReturns()) {
+      addFirResult(mlir::IndexType::get(&mlirContext),
+                   FirPlaceHolder::resultEntityPosition, Property::Value);
+    }
+  }
+
 private:
   void handleImplicitResult(
       const Fortran::evaluate::characteristics::FunctionResult &result) {
     if (result.IsProcedurePointer())
       TODO(interface.converter.getCurrentLocation(),
            "procedure pointer result not yet handled");
     const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
         result.GetTypeAndShape();
if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
       // in implicit interfaces
       mlir::Type mlirType =
           getConverter().genType(dynamicType.category(), dynamicType.kind());
       addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
                    Property::Value);
     }
   }
 
+  void handleExplicitResult(
+      const Fortran::evaluate::characteristics::FunctionResult &result) {
+    using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
+
+    if (result.IsProcedurePointer())
+      TODO(interface.converter.getCurrentLocation(),
+           "procedure pointer results");
+    const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
+        result.GetTypeAndShape();
+    assert(typeAndShape && "expect type for non proc pointer result");
+    Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
+    if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
+      TODO(interface.converter.getCurrentLocation(),
+           "implicit result character type");
+    } else if (dynamicType.category() ==
+               Fortran::common::TypeCategory::Derived) {
+      TODO(interface.converter.getCurrentLocation(),
+           "implicit result derived type");
+    }
+    mlir::Type mlirType =
+        getConverter().genType(dynamicType.category(), dynamicType.kind());
+    fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
+    if (!bounds.empty())
+      mlirType = fir::SequenceType::get(bounds, mlirType);
+    if (result.attrs.test(Attr::Allocatable))
+      mlirType = fir::BoxType::get(fir::HeapType::get(mlirType));
+    if (result.attrs.test(Attr::Pointer))
+      mlirType = fir::BoxType::get(fir::PointerType::get(mlirType));
+
+    addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
+                 Property::Value);
+  }
+
+  fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
+    fir::SequenceType::Shape bounds;
+    for (Fortran::evaluate::MaybeExtentExpr extentExpr : shape) {
+      fir::SequenceType::Extent extent = fir::SequenceType::getUnknownExtent();
+      if (std::optional<std::int64_t> constantExtent =
+              toInt64(std::move(extentExpr)))
+        extent = *constantExtent;
+      bounds.push_back(extent);
+    }
+    return bounds;
+  }
+
+  template <typename A>
+  std::optional<std::int64_t> toInt64(A &&expr) {
+    return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
+        getConverter().getFoldingContext(), std::move(expr)));
+  }
+
   void addFirResult(mlir::Type type, int entityPosition, Property p) {
     interface.outputs.emplace_back(FirPlaceHolder{type, entityPosition, p});
   }
 
   Fortran::lower::AbstractConverter &getConverter() {
     return interface.converter;
   }
   CallInterface &interface;
   mlir::MLIRContext &mlirContext;
 };
 
 template <typename T>
 void Fortran::lower::CallInterface<T>::determineInterface(
     bool isImplicit,
     const Fortran::evaluate::characteristics::Procedure &procedure) {
   CallInterfaceImpl<T> impl(*this);
   if (isImplicit)
     impl.buildImplicitInterface(procedure);
   else
-    TODO_NOLOC("determineImplicitInterface");
+    impl.buildExplicitInterface(procedure);
 }
 
 template <typename T>
 mlir::FunctionType Fortran::lower::CallInterface<T>::genFunctionType() {
   llvm::SmallVector<mlir::Type> returnTys;
   for (const FirPlaceHolder &placeHolder : outputs)
     returnTys.emplace_back(placeHolder.type);
   return mlir::FunctionType::get(&converter.getMLIRContext(), {}, returnTys);
 }
 
 template class Fortran::lower::CallInterface<Fortran::lower::CalleeInterface>;

flang/lib/Lower/ConvertType.cpp

 /// Discover the type of an Fortran::evaluate::Expr<T> and convert it to an
 /// mlir::Type. The type returned may be an MLIR standard or FIR type.
 class TypeBuilder {
 public:
   TypeBuilder(Fortran::lower::AbstractConverter &converter)
       : converter{converter}, context{&converter.getMLIRContext()} {}
 
   template <typename A>
+  void translateShape(A &shape, Fortran::evaluate::Shape &&shapeExpr) {
+    for (Fortran::evaluate::MaybeExtentExpr extentExpr : shapeExpr) {
+      fir::SequenceType::Extent extent = fir::SequenceType::getUnknownExtent();
+      if (std::optional<std::int64_t> constantExtent =
+              toInt64(std::move(extentExpr)))
+        extent = *constantExtent;
+      shape.push_back(extent);
+    }
+  }
+
+  template <typename A>
   std::optional<std::int64_t> toInt64(A &&expr) {
     return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
         converter.getFoldingContext(), std::move(expr)));
   }
 
   mlir::Type genSymbolType(const Fortran::semantics::Symbol &symbol,
                            bool isAlloc = false, bool isPtr = false) {
     mlir::Location loc = converter.genLocation(symbol.name());
if (const Fortran::semantics::DeclTypeSpec *type = ultimate.GetType()) {
       } else if (type->AsDerived()) {
         TODO(loc, "genSymbolType derived type");
       } else {
         fir::emitFatalError(loc, "symbol's type must have a type spec");
       }
     } else {
       fir::emitFatalError(loc, "symbol must have a type");
     }
+    if (ultimate.IsObjectArray()) {
+      auto shapeExpr = Fortran::evaluate::GetShapeHelper{
+          converter.getFoldingContext()}(ultimate);
+      if (!shapeExpr)
+        TODO(loc, "assumed rank symbol type lowering");
+      fir::SequenceType::Shape shape;
+      translateShape(shape, std::move(*shapeExpr));
+      ty = fir::SequenceType::get(shape, ty);
+    }
 
     if (Fortran::semantics::IsPointer(symbol))
       return fir::BoxType::get(fir::PointerType::get(ty));
     if (Fortran::semantics::IsAllocatable(symbol))
       return fir::BoxType::get(fir::HeapType::get(ty));
     // isPtr and isAlloc are variable that were promoted to be on the
     // heap or to be pointers, but they do not have Fortran allocatable
     // or pointer semantics, so do not use box for them.

flang/test/Lower/basic-function.f90

 end
 
 ! CHECK-LABEL: func @_QPfct_body() -> i32
 ! CHECK:         cf.br ^bb1
 ! CHECK:       ^bb1
 ! CHECK:         %{{.*}} = fir.call @_FortranAStopStatement
 ! CHECK:         fir.unreachable
 
+function fct_iarr1()
+  integer, dimension(10) :: fct_iarr1
+end
+
+! CHECK-LABEL: func @_QPfct_iarr1() -> !fir.array<10xi32>
+! CHECK:         return %{{.*}} : !fir.array<10xi32>
+
+function fct_iarr2()
+  integer, dimension(10, 20) :: fct_iarr2
+end
+
+! CHECK-LABEL: func @_QPfct_iarr2() -> !fir.array<10x20xi32>
+! CHECK:         return %{{.*}} : !fir.array<10x20xi32>
+
+function fct_iarr3()
+  integer, dimension(:, :), allocatable :: fct_iarr3
+end
+
+! CHECK-LABEL: func @_QPfct_iarr3() -> !fir.box<!fir.heap<!fir.array<?x?xi32>>>
+! CHECK:        return %{{.*}} : !fir.box<!fir.heap<!fir.array<?x?xi32>>>
+
+function fct_iarr4()
+  integer, dimension(:), pointer :: fct_iarr4
+end
+
+! CHECK-LABEL: func @_QPfct_iarr4() -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
+! CHECK:         return %{{.*}} : !fir.box<!fir.ptr<!fir.array<?xi32>>>
+
 logical(1) function lfct1()
 end
 ! CHECK-LABEL: func @_QPlfct1() -> !fir.logical<1>
 ! CHECK:         return %{{.*}} : !fir.logical<1>
 
 logical(2) function lfct2()
 end
 ! CHECK-LABEL: func @_QPlfct2() -> !fir.logical<2>