[flang] Lower simple character return

[clementval]

Summary

Handles function with character return.

Character scalar results are passed as arguments in lowering so
that an assumed length character function callee can access the result
length.

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

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Lower/Bridge.cpp

 #include "flang/Lower/IterationSpace.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/PFTBuilder.h"
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Support/FIRContext.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "mlir/IR/PatternMatch.h"
 #include "mlir/Transforms/RegionUtils.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
public:
   /// variables. When the result is passed as a hidden argument, the Fortran
   /// result is also mapped. The symbol map is used to hold this mapping.
   void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
                             const Fortran::lower::CalleeInterface &callee) {
     assert(builder && "require a builder object at this point");
     using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
     auto mapPassedEntity = [&](const auto arg) -> void {
       if (arg.passBy == PassBy::AddressAndLength) {
-        // // TODO: now that fir call has some attributes regarding character
-        // // return, PassBy::AddressAndLength should be retired.
-        // mlir::Location loc = toLocation();
-        // fir::factory::CharacterExprHelper charHelp{*builder, loc};
-        // mlir::Value box =
-        //     charHelp.createEmboxChar(arg.firArgument, arg.firLength);
-        // addSymbol(arg.entity->get(), box);
+        // TODO: now that fir call has some attributes regarding character
+        // return, PassBy::AddressAndLength should be retired.
+        mlir::Location loc = toLocation();
+        fir::factory::CharacterExprHelper charHelp{*builder, loc};
+        mlir::Value box =
+            charHelp.createEmboxChar(arg.firArgument, arg.firLength);
+        addSymbol(arg.entity->get(), box);
       } else {
         if (arg.entity.has_value()) {
           addSymbol(arg.entity->get(), arg.firArgument);
         } else {
           // assert(funit.parentHasHostAssoc());
           // funit.parentHostAssoc().internalProcedureBindings(*this,
           //                                                   localSymbols);
         }
void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) {
     Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym);
     mlir::Location loc = toLocation();
     if (!resultSymBox) {
       mlir::emitError(loc, "failed lowering function return");
       return;
     }
     mlir::Value resultVal = resultSymBox.match(
         [&](const fir::CharBoxValue &x) -> mlir::Value {
-          TODO(loc, "Function return CharBoxValue");
+          return fir::factory::CharacterExprHelper{*builder, loc}
+              .createEmboxChar(x.getBuffer(), x.getLen());
         },
         [&](const auto &) -> mlir::Value {
           mlir::Value resultRef = resultSymBox.getAddr();
           mlir::Type resultType = genType(resultSym);
           mlir::Type resultRefType = builder->getRefType(resultType);
           // A function with multiple entry points returning different types
           // tags all result variables with one of the largest types to allow
           // them to share the same storage.  Convert this to the actual type.

flang/lib/Lower/CallInterface.cpp

 }
 
 static const Fortran::semantics::Symbol &
 getDataObjectEntity(const Fortran::semantics::Symbol *arg) {
   assert(arg && "expect symbol for data object entity");
   return *arg;
 }
 
+static const Fortran::evaluate::ActualArgument *
+getResultEntity(const Fortran::evaluate::ProcedureRef &) {
+  return nullptr;
+}
+
+static const Fortran::semantics::Symbol &
+getResultEntity(Fortran::lower::pft::FunctionLikeUnit &funit) {
+  return funit.getSubprogramSymbol()
+      .get<Fortran::semantics::SubprogramDetails>()
+      .result();
+}
+
 //===----------------------------------------------------------------------===//
 // CallInterface implementation: this part is common to both caller and caller
 // sides.
 //===----------------------------------------------------------------------===//
 
 /// This is the actual part that defines the FIR interface based on the
 /// characteristic. It directly mutates the CallInterface members.
 template <typename T>
 class Fortran::lower::CallInterfaceImpl {
   using CallInterface = Fortran::lower::CallInterface<T>;
   using PassEntityBy = typename CallInterface::PassEntityBy;
   using PassedEntity = typename CallInterface::PassedEntity;
+  using FirValue = typename CallInterface::FirValue;
   using FortranEntity = typename CallInterface::FortranEntity;
   using FirPlaceHolder = typename CallInterface::FirPlaceHolder;
   using Property = typename CallInterface::Property;
   using TypeAndShape = Fortran::evaluate::characteristics::TypeAndShape;
   using DummyCharacteristics =
       Fortran::evaluate::characteristics::DummyArgument;
 
 public:
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();
     assert(typeAndShape && "expect type for non proc pointer result");
     Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
+    // Character result allocated by caller and passed as hidden arguments
     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
-      TODO(interface.converter.getCurrentLocation(),
-           "implicit result character type");
+      handleImplicitCharacterResult(dynamicType);
     } else if (dynamicType.category() ==
                Fortran::common::TypeCategory::Derived) {
       TODO(interface.converter.getCurrentLocation(),
            "implicit result derived type");
     } else {
       // All result other than characters/derived are simply returned by value
       // in implicit interfaces
       mlir::Type mlirType =
           getConverter().genType(dynamicType.category(), dynamicType.kind());
       addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
                    Property::Value);
     }
   }
 
+  void
+  handleImplicitCharacterResult(const Fortran::evaluate::DynamicType &type) {
+    int resultPosition = FirPlaceHolder::resultEntityPosition;
+    setPassedResult(PassEntityBy::AddressAndLength,
+                    getResultEntity(interface.side().getCallDescription()));
+    mlir::Type lenTy = mlir::IndexType::get(&mlirContext);
+    std::optional<std::int64_t> constantLen = type.knownLength();
+    fir::CharacterType::LenType len =
+        constantLen ? *constantLen : fir::CharacterType::unknownLen();
+    mlir::Type charRefTy = fir::ReferenceType::get(
+        fir::CharacterType::get(&mlirContext, type.kind(), len));
+    mlir::Type boxCharTy = fir::BoxCharType::get(&mlirContext, type.kind());
+    addFirOperand(charRefTy, resultPosition, Property::CharAddress);
+    addFirOperand(lenTy, resultPosition, Property::CharLength);
+    /// For now, also return it by boxchar
+    addFirResult(boxCharTy, resultPosition, Property::BoxChar);
+  }
+
   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());
+    mlir::Type mlirType = translateDynamicType(typeAndShape->type());
     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));
 
+    if (fir::isa_char(mlirType)) {
+      // Character scalar results must be passed as arguments in lowering so
+      // that an assumed length character function callee can access the result
+      // length. A function with a result requiring an explicit interface does
+      // not have to be compatible with assumed length function, but most
+      // compilers supports it.
+      handleImplicitCharacterResult(typeAndShape->type());
+      return;
+    }
+
     addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
                  Property::Value);
+    // Explicit results require the caller to allocate the storage and save the
+    // function result in the storage with a fir.save_result.
+    setSaveResult();
   }
 
   fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
     fir::SequenceType::Shape bounds;
     for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : shape) {
       fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();
       if (std::optional<std::int64_t> i = toInt64(extent))
         bound = *i;
addFirResult(mlir::Type type, int entityPosition, Property p,
     interface.outputs.emplace_back(
         FirPlaceHolder{type, entityPosition, p, attributes});
   }
   void addPassedArg(PassEntityBy p, FortranEntity entity,
                     const DummyCharacteristics *characteristics) {
     interface.passedArguments.emplace_back(
         PassedEntity{p, entity, {}, {}, characteristics});
   }
+  void setPassedResult(PassEntityBy p, FortranEntity entity) {
+    interface.passedResult =
+        PassedEntity{p, entity, emptyValue(), emptyValue()};
+  }
+  void setSaveResult() { interface.saveResult = true; }
   int nextPassedArgPosition() { return interface.passedArguments.size(); }
 
+  static FirValue emptyValue() {
+    if constexpr (std::is_same_v<Fortran::lower::CalleeInterface, T>) {
+      return {};
+    } else {
+      return -1;
+    }
+  }
+
   Fortran::lower::AbstractConverter &getConverter() {
     return interface.converter;
   }
   CallInterface &interface;
   mlir::MLIRContext &mlirContext;
 };
 
 template <typename T>

flang/lib/Lower/ConvertVariable.cpp

ba.match(
       // need to be cast to a multi-dimensional array with constant bounds
       // (possibly with a missing column), bounds computed in the callee
       // (here), or with bounds from the caller (boxed somewhere else). Locals
       // have the same properties except they are never boxed arguments from
       // the caller and never having a missing column size.
       //===--------------------------------------------------------------===//
 
       [&](const Fortran::lower::details::ScalarStaticChar &x) {
-        TODO(loc, "ScalarStaticChar variable lowering");
+        // type is a CHARACTER, determine the LEN value
+        auto charLen = x.charLen();
+        if (replace) {
+          Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(sym);
+          std::pair<mlir::Value, mlir::Value> unboxchar =
+              charHelp.createUnboxChar(symBox.getAddr());
+          mlir::Value boxAddr = unboxchar.first;
+          // Set/override LEN with a constant
+          mlir::Value len = builder.createIntegerConstant(loc, idxTy, charLen);
+          symMap.addCharSymbol(sym, boxAddr, len, true);
+          return;
+        }
+        mlir::Value len = builder.createIntegerConstant(loc, idxTy, charLen);
+        if (preAlloc) {
+          symMap.addCharSymbol(sym, preAlloc, len);
+          return;
+        }
+        mlir::Value local = createNewLocal(converter, loc, var, preAlloc);
+        symMap.addCharSymbol(sym, local, len);
       },
 
       //===--------------------------------------------------------------===//
 
       [&](const Fortran::lower::details::ScalarDynamicChar &x) {
         TODO(loc, "ScalarDynamicChar variable lowering");
       },
 

flang/test/Lower/basic-function.f90

 end
 ! CHECK-LABEL: func @_QPcplxfct5() -> !fir.complex<10>
 ! CHECK:         return %{{.*}} : !fir.complex<10>
 
 complex(16) function cplxfct6()
 end
 ! CHECK-LABEL: func @_QPcplxfct6() -> !fir.complex<16>
 ! CHECK:         return %{{.*}} : !fir.complex<16>
+
+function fct_with_character_return(i)
+  character(10) :: fct_with_character_return
+  integer :: i
+end
+! CHECK-LABEL: func @_QPfct_with_character_return(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.char<1,10>>{{.*}}, %{{.*}}: index{{.*}}, %{{.*}}: !fir.ref<i32>{{.*}}) -> !fir.boxchar<1> {