[flang][hlfir] Lower some character elemental references

[jeanPerier]

Summary

Lower character elemental user procedures with constant length, and
bot dynamic and constant length ADJUSTL, ADJUSTR, and MERGE references
(which leaves out MIN/MAX).

Character elemental user procedures with dynamic length are a bit more
involving and since it is an edge-case that is not currently supported,
I will take this on later.

Depends on D141841

[clementval]

LGTM

[jeanPerier]

rebase

flang/lib/Lower/ConvertCall.cpp

static hlfir::EntityWithAttributes genIntrinsicRefCore(
   // Let the intrinsic library lower the intrinsic procedure call.
   auto [resultExv, mustBeFreed] = Fortran::lower::genIntrinsicCall(
       callContext.getBuilder(), loc, intrinsic.name, scalarResultType,
       operands);
   hlfir::EntityWithAttributes resultEntity = extendedValueToHlfirEntity(
       loc, builder, resultExv, ".tmp.intrinsic_result");
   // Move result into memory into an hlfir.expr since they are immutable from
   // that point, and the result storage is some temp.
-  if (!fir::isa_trivial(resultEntity.getType()))
-    resultEntity = hlfir::EntityWithAttributes{
-        builder
-            .create<hlfir::AsExprOp>(loc, resultEntity,
-                                     builder.createBool(loc, mustBeFreed))
-            .getResult()};
+  if (!fir::isa_trivial(resultEntity.getType())) {
+    hlfir::AsExprOp asExpr;
+    // Character/Derived MERGE lowering returns one of its argument address
+    // (this is the only intrinsic implemented in that way so far). The
+    // ownership of this address cannot be taken here since it may not be a
+    // temp.
+    if (intrinsic.name == "merge")
+      asExpr = builder.create<hlfir::AsExprOp>(loc, resultEntity);
+    else
+      asExpr = builder.create<hlfir::AsExprOp>(
+          loc, resultEntity, builder.createBool(loc, mustBeFreed));
+    resultEntity = hlfir::EntityWithAttributes{asExpr.getResult()};
+  }
   return resultEntity;
 }
 
 namespace {
 template <typename ElementalCallBuilderImpl>
 class ElementalCallBuilder {
 public:
   std::optional<hlfir::EntityWithAttributes>
if (!callContext.resultType) {
       return std::nullopt;
     }
     // Function case: generate call inside hlfir.elemental
     mlir::Type elementType =
         hlfir::getFortranElementType(*callContext.resultType);
     // Get result length parameters.
     llvm::SmallVector<mlir::Value> typeParams;
     if (elementType.isa<fir::CharacterType>() ||
-        fir::isRecordWithTypeParameters(elementType))
-      TODO(loc, "compute elemental function result length parameters in HLFIR");
+        fir::isRecordWithTypeParameters(elementType)) {
+      auto charType = elementType.dyn_cast<fir::CharacterType>();
+      if (charType && charType.hasConstantLen())
+        typeParams.push_back(builder.createIntegerConstant(
+            loc, builder.getIndexType(), charType.getLen()));
+      else if (charType)
+        typeParams.push_back(impl().computeDynamicCharacterResultLength(
+            loweredActuals, callContext));
+      else
+        TODO(
+            loc,
+            "compute elemental PDT function result length parameters in HLFIR");
+    }
     auto genKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
                          mlir::ValueRange oneBasedIndices) -> hlfir::Entity {
       callContext.stmtCtx.pushScope();
       for (auto &preparedActual : loweredActuals)
         if (preparedActual)
           preparedActual->actual = hlfir::getElementAt(
               l, b, preparedActual->actual, oneBasedIndices);
       auto res = *impl().genElementalKernel(loweredActuals, callContext);
bool canLoadActualArgumentBeforeLoop(unsigned argIdx) const {
     // If the actual argument does not need to be passed via an address,
     // or will be passed in the address of a temporary copy, it can be loaded
     // before the elemental loop nest.
     const auto &arg = caller.getPassedArguments()[argIdx];
     return arg.passBy == PassBy::Value ||
            arg.passBy == PassBy::BaseAddressValueAttribute;
   }
 
+  mlir::Value
+  computeDynamicCharacterResultLength(PreparedActualArguments &loweredActuals,
+                                      CallContext &callContext) {
+    TODO(callContext.loc,
+         "compute elemental function result length parameters in HLFIR");
+  }
+
 private:
   Fortran::lower::CallerInterface &caller;
   mlir::FunctionType callSiteType;
 };
 
 class ElementalIntrinsicCallBuilder
     : public ElementalCallBuilder<ElementalIntrinsicCallBuilder> {
 public:
public:
   // Elemental intrinsic functions cannot modify their arguments.
   bool argMayBeModifiedByCall(int) const { return !isFunction; }
   bool canLoadActualArgumentBeforeLoop(int) const {
     // Elemental intrinsic functions never need the actual addresses
     // of their arguments.
     return isFunction;
   }
 
+  mlir::Value
+  computeDynamicCharacterResultLength(PreparedActualArguments &loweredActuals,
+                                      CallContext &callContext) {
+    if (intrinsic.name == "adjustr" || intrinsic.name == "adjustl" ||
+        intrinsic.name == "merge")
+      return hlfir::genCharLength(callContext.loc, callContext.getBuilder(),
+                                  loweredActuals[0].value().actual);
+    // Character MIN/MAX is the min/max of the arguments length that are
+    // present.
+    TODO(callContext.loc,
+         "compute elemental character min/max function result length in HLFIR");
+  }
+
 private:
   const Fortran::evaluate::SpecificIntrinsic &intrinsic;
   const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering;
   const bool isFunction;
 };
 } // namespace
 
 /// Lower an intrinsic procedure reference.

flang/lib/Lower/ConvertType.cpp

getCharacterLength(const Fortran::semantics::Symbol &symbol) {
     }
     llvm_unreachable("unknown character kind");
   }
 
   template <typename A>
   Fortran::lower::LenParameterTy getCharacterLength(const A &expr) {
     return fir::SequenceType::getUnknownExtent();
   }
+
+  template <typename T>
+  Fortran::lower::LenParameterTy
+  getCharacterLength(const Fortran::evaluate::FunctionRef<T> &funcRef) {
+    if (auto constantLen = toInt64(funcRef.LEN()))
+      return *constantLen;
+    return fir::SequenceType::getUnknownExtent();
+  }
+
   Fortran::lower::LenParameterTy
   getCharacterLength(const Fortran::lower::SomeExpr &expr) {
     // Do not use dynamic type length here. We would miss constant
     // lengths opportunities because dynamic type only has the length
     // if it comes from a declaration.
     auto charExpr =
         std::get<Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter>>(
             expr.u);

flang/test/Lower/HLFIR/elemental-intrinsics.f90

 ! CHECK:    %[[VAL_23:.*]] = fir.convert %[[VAL_19]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
 ! CHECK:    %[[VAL_24:.*]] = fir.convert %[[VAL_16]] : (index) -> i64
 ! CHECK:    %[[VAL_25:.*]] = fir.call @_FortranAScan1(%[[VAL_21]], %[[VAL_22]], %[[VAL_23]], %[[VAL_24]], %[[VAL_20]])
 ! CHECK:    %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (i64) -> i32
 ! CHECK:    hlfir.yield_element %[[VAL_26]] : i32
 ! CHECK:  }
 ! CHECK: fir.call
 ! CHECK: hlfir.destroy %[[VAL_13]]
+
+
+! -----------------------------------------------------------------------------
+!  Test elemental character intrinsics with non compile time constant result
+!  length.
+! -----------------------------------------------------------------------------
+
+subroutine test_adjustl(x)
+  character(*) :: x(100)
+  call bar(adjustl(x))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_adjustl(
+! CHECK:  %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_3:.*]](%[[VAL_5:[a-z0-9]*]]) typeparams %[[VAL_2:[a-z0-9]*]]#1  {{.*}}Ex
+! CHECK:  %[[VAL_7:.*]] = hlfir.elemental %[[VAL_5]] typeparams %[[VAL_2]]#1 : (!fir.shape<1>, index) -> !hlfir.expr<100x!fir.char<1,?>> {
+! CHECK:  ^bb0(%[[VAL_8:.*]]: index):
+! CHECK:    %[[VAL_9:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_8]])  typeparams %[[VAL_2]]#1 : (!fir.box<!fir.array<100x!fir.char<1,?>>>, index, index) -> !fir.boxchar<1>
+! CHECK:    fir.call @_FortranAAdjustl
+! CHECK:    %[[VAL_24:.*]]:2 = hlfir.declare %{{.*}} typeparams %[[VAL_22:.*]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.heap<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.heap<!fir.char<1,?>>)
+! CHECK:    %[[VAL_25:.*]] = arith.constant true
+! CHECK:    %[[VAL_26:.*]] = hlfir.as_expr %[[VAL_24]]#0 move %[[VAL_25]] : (!fir.boxchar<1>, i1) -> !hlfir.expr<!fir.char<1,?>>
+! CHECK:    hlfir.yield_element %[[VAL_26]] : !hlfir.expr<!fir.char<1,?>>
+! CHECK:  }
+
+subroutine test_adjustr(x)
+  character(*) :: x(100)
+  call bar(adjustr(x))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_adjustr(
+! CHECK:  %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_3:.*]](%[[VAL_5:[a-z0-9]*]]) typeparams %[[VAL_2:[a-z0-9]*]]#1  {{.*}}Ex
+! CHECK:  %[[VAL_7:.*]] = hlfir.elemental %[[VAL_5]] typeparams %[[VAL_2]]#1 : (!fir.shape<1>, index) -> !hlfir.expr<100x!fir.char<1,?>> {
+! CHECK:  ^bb0(%[[VAL_8:.*]]: index):
+! CHECK:    %[[VAL_9:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_8]])  typeparams %[[VAL_2]]#1 : (!fir.box<!fir.array<100x!fir.char<1,?>>>, index, index) -> !fir.boxchar<1>
+! CHECK:    fir.call @_FortranAAdjustr
+! CHECK:    %[[VAL_24:.*]]:2 = hlfir.declare %{{.*}} typeparams %[[VAL_22:.*]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.heap<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.heap<!fir.char<1,?>>)
+! CHECK:    %[[VAL_25:.*]] = arith.constant true
+! CHECK:    %[[VAL_26:.*]] = hlfir.as_expr %[[VAL_24]]#0 move %[[VAL_25]] : (!fir.boxchar<1>, i1) -> !hlfir.expr<!fir.char<1,?>>
+! CHECK:    hlfir.yield_element %[[VAL_26]] : !hlfir.expr<!fir.char<1,?>>
+! CHECK:  }
+
+subroutine test_merge(x, y, mask)
+  character(*) :: x(100), y(100)
+  logical :: mask(100)
+  call bar(merge(x, y, mask))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_merge(
+! CHECK:  %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_2:[a-z0-9]*]](%[[VAL_4:[a-z0-9]*]])  {{.*}}Emask
+! CHECK:  %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_7:[a-z0-9]*]](%[[VAL_9:[a-z0-9]*]]) typeparams %[[VAL_6:[a-z0-9]*]]#1  {{.*}}Ex
+! CHECK:  %[[VAL_15:.*]]:2 = hlfir.declare %[[VAL_12:[a-z0-9]*]](%[[VAL_14:[a-z0-9]*]]) typeparams %[[VAL_11:[a-z0-9]*]]#1  {{.*}}Ey
+! CHECK:  %[[VAL_16:.*]] = hlfir.elemental %[[VAL_9]] typeparams %[[VAL_6]]#1 : (!fir.shape<1>, index) -> !hlfir.expr<100x!fir.char<1,?>> {
+! CHECK:  ^bb0(%[[VAL_17:.*]]: index):
+! CHECK:    %[[VAL_18:.*]] = hlfir.designate %[[VAL_10]]#0 (%[[VAL_17]])  typeparams %[[VAL_6]]#1 : (!fir.box<!fir.array<100x!fir.char<1,?>>>, index, index) -> !fir.boxchar<1>
+! CHECK:    %[[VAL_19:.*]] = hlfir.designate %[[VAL_15]]#0 (%[[VAL_17]])  typeparams %[[VAL_11]]#1 : (!fir.box<!fir.array<100x!fir.char<1,?>>>, index, index) -> !fir.boxchar<1>
+! CHECK:    %[[VAL_20:.*]] = hlfir.designate %[[VAL_5]]#0 (%[[VAL_17]])  : (!fir.ref<!fir.array<100x!fir.logical<4>>>, index) -> !fir.ref<!fir.logical<4>>
+! CHECK:    %[[VAL_21:.*]]:2 = fir.unboxchar %[[VAL_18]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+! CHECK:    %[[VAL_22:.*]]:2 = fir.unboxchar %[[VAL_19]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+! CHECK:    %[[VAL_23:.*]] = fir.load %[[VAL_20]] : !fir.ref<!fir.logical<4>>
+! CHECK:    %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (!fir.logical<4>) -> i1
+! CHECK:    %[[VAL_25:.*]] = arith.select %[[VAL_24]], %[[VAL_21]]#0, %[[VAL_22]]#0 : !fir.ref<!fir.char<1,?>>
+! CHECK:    %[[VAL_26:.*]]:2 = hlfir.declare %[[VAL_25]] typeparams %[[VAL_6]]#1 {uniq_name = ".tmp.intrinsic_result"} : (!fir.ref<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+! CHECK:    %[[VAL_27:.*]] = hlfir.as_expr %[[VAL_26]]#0 : (!fir.boxchar<1>) -> !hlfir.expr<!fir.char<1,?>>
+! CHECK:    hlfir.yield_element %[[VAL_27]] : !hlfir.expr<!fir.char<1,?>>
+! CHECK:  }