[flang] Handle lowering of ranked array

This patch adds lowering of ranked array as function return.

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

Reviewed By: PeteSteinfeld

Differential Revision: https://reviews.llvm.org/D119835

Co-authored-by: Jean Perier <jperier@nvidia.com>

Author: clementval

flang/lib/Lower/CallInterface.cpp

@@ -155,6 +155,21 @@ class Fortran::lower::CallInterfaceImpl {
                    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) {
@@ -182,6 +197,57 @@ class Fortran::lower::CallInterfaceImpl {
     }
   }
 
+  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});
   }
@@ -201,7 +267,7 @@ void Fortran::lower::CallInterface<T>::determineInterface(
   if (isImplicit)
     impl.buildImplicitInterface(procedure);
   else
-    TODO_NOLOC("determineImplicitInterface");
+    impl.buildExplicitInterface(procedure);
 }
 
 template <typename T>

flang/lib/Lower/ConvertType.cpp

@@ -154,6 +154,17 @@ class TypeBuilder {
   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(
@@ -186,6 +197,15 @@ class TypeBuilder {
     } 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));

flang/test/Lower/basic-function.f90

@@ -48,6 +48,34 @@ integer function fct_body()
 ! 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>