[flang][lowering] fix vector subscripts in character elemental procedures (#156661)

jeanPerier · web-flow · commit a103b9b207f6 · 2025-09-08T12:07:37.000+02:00
Fixes #145151 Character elemental procedures require evaluating the result specification expression outside of the elemental loops when the function result length is not a constant. This is needed so that the array result storage can be allocated before the evaluation if a storage is needed. Because the result specification expression may depend on inquires about the dummy argument (but not usages of values thanks to F2023 C15121), some representation of the dummy must be created. Since this is an elemental call, this requires providing an element, and not the whole array actual argument (we only care about the properties of such element it does not matter which element is being used). The previous code was creating the element with a type cast from the base array, but this did not work with vector subscripted arrays where the lowering representation is more complex. This caused a compiler assert to fire. Switch the code to only copy the properties that can be inquired from the actual argument to the mock dummy (length parameters, dynamic type and presence). A mock one address is used instead of addressing the actual argument before the loop (one is used instead of NULL so that presence inquiry will work as expected for OPTIONAL arguments).
diff --git a/flang/include/flang/Lower/HlfirIntrinsics.h b/flang/include/flang/Lower/HlfirIntrinsics.h
@@ -105,6 +105,17 @@ struct PreparedActualArgument {
     return typeParams[0];
   }
 
+  void genLengthParameters(mlir::Location loc, fir::FirOpBuilder &builder,
+                           llvm::SmallVectorImpl<mlir::Value> &result) {
+    if (auto *actualEntity = std::get_if<hlfir::Entity>(&actual)) {
+      hlfir::genLengthParameters(loc, builder, *actualEntity, result);
+      return;
+    }
+    for (mlir::Value len :
+         std::get<hlfir::ElementalAddrOp>(actual).getTypeparams())
+      result.push_back(len);
+  }
+
   /// When the argument is polymorphic, get mold value with the same dynamic
   /// type.
   mlir::Value getPolymorphicMold(mlir::Location loc) const {
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
@@ -287,6 +287,16 @@ static void remapActualToDummyDescriptors(
   }
 }
 
+static void
+getResultLengthFromElementalOp(fir::FirOpBuilder &builder,
+                               llvm::SmallVectorImpl<mlir::Value> &lengths) {
+  auto elemental = llvm::dyn_cast_or_null<hlfir::ElementalOp>(
+      builder.getInsertionBlock()->getParentOp());
+  if (elemental)
+    for (mlir::Value len : elemental.getTypeparams())
+      lengths.push_back(len);
+}
+
 std::pair<Fortran::lower::LoweredResult, bool>
 Fortran::lower::genCallOpAndResult(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
@@ -296,7 +306,13 @@ Fortran::lower::genCallOpAndResult(
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
   bool mustPopSymMap = false;
-  if (caller.mustMapInterfaceSymbolsForResult()) {
+
+  llvm::SmallVector<mlir::Value> resultLengths;
+  if (isElemental)
+    getResultLengthFromElementalOp(builder, resultLengths);
+  if (caller.mustMapInterfaceSymbolsForResult() && resultLengths.empty()) {
+    // Do not map the dummy symbols again inside the loop to compute elemental
+    // function result whose length was already computed outside of the loop.
     symMap.pushScope();
     mustPopSymMap = true;
     Fortran::lower::mapCallInterfaceSymbolsForResult(converter, caller, symMap);
@@ -340,7 +356,6 @@ Fortran::lower::genCallOpAndResult(
         loc, idxTy, fir::getBase(converter.genExprValue(expr, stmtCtx)));
     return fir::factory::genMaxWithZero(builder, loc, convertExpr);
   };
-  llvm::SmallVector<mlir::Value> resultLengths;
   mlir::Value arrayResultShape;
   hlfir::EvaluateInMemoryOp evaluateInMemory;
   auto allocatedResult = [&]() -> std::optional<fir::ExtendedValue> {
@@ -355,11 +370,16 @@ Fortran::lower::genCallOpAndResult(
             assert(!isAssumedSizeExtent && "result cannot be assumed-size");
             extents.emplace_back(lowerSpecExpr(e));
           });
-    caller.walkResultLengths(
-        [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
-          assert(!isAssumedSizeExtent && "result cannot be assumed-size");
-          lengths.emplace_back(lowerSpecExpr(e));
-        });
+    if (resultLengths.empty()) {
+      caller.walkResultLengths(
+          [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
+            assert(!isAssumedSizeExtent && "result cannot be assumed-size");
+            lengths.emplace_back(lowerSpecExpr(e));
+          });
+    } else {
+      // Use lengths precomputed before elemental loops.
+      lengths = resultLengths;
+    }
 
     // Result length parameters should not be provided to box storage
     // allocation and save_results, but they are still useful information to
@@ -2330,6 +2350,47 @@ class ElementalCallBuilder {
   }
 };
 
+/// Helper for computing elemental function result specification
+/// expressions that depends on dummy symbols. See
+/// computeDynamicCharacterResultLength below.
+static mlir::Value genMockDummyForElementalResultSpecifications(
+    fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type dummyType,
+    Fortran::lower::PreparedActualArgument &preparedActual) {
+  // One is used as the mock address instead of NULL so that PRESENT inquires
+  // work (this is the only valid thing that specification can do with the
+  // address thanks to Fortran 2023 C15121).
+  mlir::Value one =
+      builder.createIntegerConstant(loc, builder.getIntPtrType(), 1);
+  if (auto boxCharType = llvm::dyn_cast<fir::BoxCharType>(dummyType)) {
+    mlir::Value addr = builder.createConvert(
+        loc, fir::ReferenceType::get(boxCharType.getEleTy()), one);
+    mlir::Value len = preparedActual.genCharLength(loc, builder);
+    return fir::EmboxCharOp::create(builder, loc, boxCharType, addr, len);
+  }
+  if (auto box = llvm::dyn_cast<fir::BaseBoxType>(dummyType)) {
+    mlir::Value addr =
+        builder.createConvert(loc, box.getBaseAddressType(), one);
+    llvm::SmallVector<mlir::Value> lenParams;
+    preparedActual.genLengthParameters(loc, builder, lenParams);
+    mlir::Value mold;
+    if (fir::isPolymorphicType(box))
+      mold = preparedActual.getPolymorphicMold(loc);
+    return fir::EmboxOp::create(builder, loc, box, addr,
+                                /*shape=*/mlir::Value{},
+                                /*slice=*/mlir::Value{}, lenParams, mold);
+  }
+  // Values of arguments should not be used in elemental procedure specification
+  // expressions as per C15121, so it makes no sense to have a specification
+  // expression requiring a symbol that is passed by value (there is no good
+  // value to create here).
+  assert(fir::isa_ref_type(dummyType) &&
+         (fir::isa_trivial(fir::unwrapRefType(dummyType)) ||
+          fir::isa_char(fir::unwrapRefType(dummyType))) &&
+         "Only expect symbols inquired in elemental procedure result "
+         "specifications to be passed in memory");
+  return builder.createConvert(loc, dummyType, one);
+}
+
 class ElementalUserCallBuilder
     : public ElementalCallBuilder<ElementalUserCallBuilder> {
 public:
@@ -2362,29 +2423,97 @@ class ElementalUserCallBuilder
   mlir::Value computeDynamicCharacterResultLength(
       Fortran::lower::PreparedActualArguments &loweredActuals,
       CallContext &callContext) {
+
     fir::FirOpBuilder &builder = callContext.getBuilder();
     mlir::Location loc = callContext.loc;
     auto &converter = callContext.converter;
-    mlir::Type idxTy = builder.getIndexType();
-    llvm::SmallVector<CallCleanUp> callCleanUps;
 
-    prepareUserCallArguments(loweredActuals, caller, callSiteType, callContext,
-                             callCleanUps);
+    // Gather the dummy argument symbols required directly or indirectly to
+    // evaluate the result symbol specification expressions.
+    llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 4>
+        requiredDummySymbols;
+    const Fortran::semantics::Symbol &result = caller.getResultSymbol();
+    for (Fortran::lower::pft::Variable var :
+         Fortran::lower::pft::getDependentVariableList(result))
+      if (var.hasSymbol()) {
+        const Fortran::semantics::Symbol &sym = var.getSymbol();
+        if (Fortran::semantics::IsDummy(sym) && sym.owner() == result.owner())
+          requiredDummySymbols.insert(&sym);
+      }
 
-    callContext.symMap.pushScope();
+    // Prepare mock FIR arguments for each dummy arguments required in the
+    // result specifications. These mock arguments will have the same properties
+    // (dynamic type and type parameters) as the actual arguments, except for
+    // the address. Such mock argument are needed because this evaluation is
+    // happening before the loop for the elemental call (the array result
+    // storage must be allocated before the loops if any is needed, so the
+    // result properties must be known before the loops). So it is not possible
+    // to just pick an element (like the first one) and use that because the
+    // normal argument preparation have effects (vector subscripted actual
+    // argument will require reading the vector subscript and VALUE arguments
+    // preparation involve copies of the data. This could cause segfaults in
+    // case of zero size arrays and is in general pointless extra computation
+    // since the data cannot be used in the specification expression as per
+    // C15121).
+    if (!requiredDummySymbols.empty()) {
+      const Fortran::semantics::SubprogramDetails *iface =
+          caller.getInterfaceDetails();
+      assert(iface && "interface must be explicit when result specification "
+                      "depends upon dummy symbols");
+      for (auto [maybePreparedActual, arg, sym] : llvm::zip(
+               loweredActuals, caller.getPassedArguments(), iface->dummyArgs()))
+        if (requiredDummySymbols.contains(sym)) {
+          mlir::Type dummyType = callSiteType.getInput(arg.firArgument);
+
+          if (!maybePreparedActual.has_value()) {
+            mlir::Value mockArgValue =
+                fir::AbsentOp::create(builder, loc, dummyType);
+            caller.placeInput(arg, mockArgValue);
+            continue;
+          }
 
-    // Map prepared argument to dummy symbol to be able to lower spec expr.
-    for (const auto &arg : caller.getPassedArguments()) {
-      const Fortran::semantics::Symbol *sym = caller.getDummySymbol(arg);
-      assert(sym && "expect symbol for dummy argument");
-      auto input = caller.getInput(arg);
-      fir::ExtendedValue exv = Fortran::lower::translateToExtendedValue(
-          loc, builder, hlfir::Entity{input}, callContext.stmtCtx);
-      fir::FortranVariableOpInterface variableIface = hlfir::genDeclare(
-          loc, builder, exv, "dummy.tmp", fir::FortranVariableFlagsAttr{});
-      callContext.symMap.addVariableDefinition(*sym, variableIface);
+          Fortran::lower::PreparedActualArgument &preparedActual =
+              maybePreparedActual.value();
+
+          if (preparedActual.handleDynamicOptional()) {
+            mlir::Value isPresent = preparedActual.getIsPresent();
+            mlir::Value mockArgValue =
+                builder
+                    .genIfOp(loc, {dummyType}, isPresent,
+                             /*withElseRegion=*/true)
+                    .genThen([&]() {
+                      mlir::Value mockArgValue =
+                          genMockDummyForElementalResultSpecifications(
+                              builder, loc, dummyType, preparedActual);
+                      fir::ResultOp::create(builder, loc, mockArgValue);
+                    })
+                    .genElse([&]() {
+                      mlir::Value absent =
+                          fir::AbsentOp::create(builder, loc, dummyType);
+                      fir::ResultOp::create(builder, loc, absent);
+                    })
+                    .getResults()[0];
+            caller.placeInput(arg, mockArgValue);
+          } else {
+            mlir::Value mockArgValue =
+                genMockDummyForElementalResultSpecifications(
+                    builder, loc, dummyType, preparedActual);
+            caller.placeInput(arg, mockArgValue);
+          }
+        }
     }
 
+    // Map symbols required by the result specification expressions to SSA
+    // values. This will both finish mapping the mock value created above if
+    // any, and deal with any module/common block variables accessed in the
+    // specification expressions.
+    // Map prepared argument to dummy symbol to be able to lower spec expr.
+    callContext.symMap.pushScope();
+    Fortran::lower::mapCallInterfaceSymbolsForResult(converter, caller,
+                                                     callContext.symMap);
+
+    // Evaluate the result length expression.
+    mlir::Type idxTy = builder.getIndexType();
     auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value {
       mlir::Value convertExpr = builder.createConvert(
           loc, idxTy,
diff --git a/flang/test/Lower/HLFIR/elemental-array-ops.f90 b/flang/test/Lower/HLFIR/elemental-array-ops.f90
@@ -177,13 +177,8 @@ end subroutine char_return
 ! CHECK:           ^bb0(%[[VAL_18:.*]]: index):
 ! CHECK:             %[[VAL_19:.*]] = hlfir.designate %[[VAL_12]]#0 (%[[VAL_18]])  typeparams %[[VAL_11]] : (!fir.box<!fir.array<?x!fir.char<1,3>>>, index, index) -> !fir.ref<!fir.char<1,3>>
 ! CHECK:             %[[VAL_20:.*]] = fir.emboxchar %[[VAL_19]], %[[VAL_11]] : (!fir.ref<!fir.char<1,3>>, index) -> !fir.boxchar<1>
-! CHECK:             %[[VAL_21:.*]] = arith.constant 3 : i64
-! CHECK:             %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (i64) -> index
-! CHECK:             %[[VAL_23:.*]] = arith.constant 0 : index
-! CHECK:             %[[VAL_24:.*]] = arith.cmpi sgt, %[[VAL_22]], %[[VAL_23]] : index
-! CHECK:             %[[VAL_25:.*]] = arith.select %[[VAL_24]], %[[VAL_22]], %[[VAL_23]] : index
-! CHECK:             %[[VAL_27:.*]] = fir.call @_QPcallee(%[[VAL_2]], %[[VAL_25]], %[[VAL_20]]) proc_attrs<elemental, pure> fastmath<contract> : (!fir.ref<!fir.char<1,3>>, index, !fir.boxchar<1>) -> !fir.boxchar<1>
-! CHECK:             %[[VAL_28:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[VAL_25]] {uniq_name = ".tmp.func_result"} : (!fir.ref<!fir.char<1,3>>, index) -> (!fir.ref<!fir.char<1,3>>, !fir.ref<!fir.char<1,3>>)
+! CHECK:             %[[VAL_27:.*]] = fir.call @_QPcallee(%[[VAL_2]], %[[VAL_16]], %[[VAL_20]]) proc_attrs<elemental, pure> fastmath<contract> : (!fir.ref<!fir.char<1,3>>, index, !fir.boxchar<1>) -> !fir.boxchar<1>
+! CHECK:             %[[VAL_28:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[VAL_16]] {uniq_name = ".tmp.func_result"} : (!fir.ref<!fir.char<1,3>>, index) -> (!fir.ref<!fir.char<1,3>>, !fir.ref<!fir.char<1,3>>)
 ! CHECK:             %[[MustFree:.*]] = arith.constant false
 ! CHECK:             %[[ResultTemp:.*]] = hlfir.as_expr %[[VAL_28]]#0 move %[[MustFree]] : (!fir.ref<!fir.char<1,3>>, i1) -> !hlfir.expr<!fir.char<1,3>>
 ! CHECK:             hlfir.yield_element %[[ResultTemp]] : !hlfir.expr<!fir.char<1,3>>
diff --git a/flang/test/Lower/HLFIR/elemental-result-length.f90 b/flang/test/Lower/HLFIR/elemental-result-length.f90
@@ -4,7 +4,7 @@ module m1
 contains
 elemental function fct1(a, b) result(t)
   character(*), intent(in) :: a, b
-  character(len(a) + len(b)) :: t
+  character(len(a, kind=8) + len(b,kind=8)) :: t
   t = a // b
 end function
 
@@ -27,10 +27,10 @@ subroutine sub2(a,b,c)
 ! CHECK: %[[DUMMYA:.*]]:2 = hlfir.declare %[[UNBOX_A]]#0 typeparams %[[UNBOX_A]]#1 {fortran_attrs = #fir.var_attrs<intent_in>, uniq_name = "_QMm1Ffct1Ea"} : (!fir.ref<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
 ! CHECK: %[[UNBOX_B:.*]]:2 = fir.unboxchar %[[B]]#0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
 ! CHECK: %[[DUMMYB:.*]]:2 = hlfir.declare %[[UNBOX_B]]#0 typeparams %[[UNBOX_B]]#1 {fortran_attrs = #fir.var_attrs<intent_in>, uniq_name = "_QMm1Ffct1Eb"} : (!fir.ref<!fir.char<1,?>>, index) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
-! CHECK: %[[LEN_A:.*]] = fir.convert %[[UNBOX_A]]#1 : (index) -> i32
-! CHECK: %[[LEN_B:.*]] = fir.convert %[[UNBOX_B]]#1 : (index) -> i32
-! CHECK: %[[LEN_LEN:.*]] = arith.addi %[[LEN_A]], %[[LEN_B]] : i32
-! CHECK: %[[LEN_LEN_IDX:.*]] = fir.convert %[[LEN_LEN]] : (i32) -> index
+! CHECK: %[[LEN_A:.*]] = fir.convert %[[UNBOX_A]]#1 : (index) -> i64
+! CHECK: %[[LEN_B:.*]] = fir.convert %[[UNBOX_B]]#1 : (index) -> i64
+! CHECK: %[[LEN_LEN:.*]] = arith.addi %[[LEN_A]], %[[LEN_B]] : i64
+! CHECK: %[[LEN_LEN_IDX:.*]] = fir.convert %[[LEN_LEN]] : (i64) -> index
 ! CHECK: %[[CMPI:.*]] = arith.cmpi sgt, %[[LEN_LEN_IDX]], %c0{{.*}} : index
 ! CHECK: %[[RES_LENGTH:.*]] = arith.select %[[CMPI]], %[[LEN_LEN_IDX]], %c0{{.*}} : index
 ! CHECK: %[[RES:.*]] = fir.alloca !fir.char<1,?>(%[[RES_LENGTH]] : index) {bindc_name = ".result"}
@@ -50,12 +50,12 @@ subroutine sub4(a,b,c)
 ! CHECK: %[[C:.*]]:2 = hlfir.declare %[[ARG2]] dummy_scope %{{.*}} {fortran_attrs = #fir.var_attrs<intent_inout>, uniq_name = "_QMm1Fsub4Ec"} : (!fir.box<!fir.array<?x!fir.char<1,?>>>, !fir.dscope) -> (!fir.box<!fir.array<?x!fir.char<1,?>>>, !fir.box<!fir.array<?x!fir.char<1,?>>>)
 ! CHECK: %[[LEN_A:.*]] = fir.box_elesize %[[A]]#1 : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
 ! CHECK: %[[LEN_B:.*]] = fir.box_elesize %[[B]]#1 : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
-! CHECK: %[[LEN_A_I32:.*]] = fir.convert %[[LEN_A]] : (index) -> i32
-! CHECK: %[[LEN_B_I32:.*]] = fir.convert %[[LEN_B]] : (index) -> i32
-! CHECK: %[[LEN_LEN:.*]] = arith.addi %[[LEN_A_I32]], %[[LEN_B_I32]] : i32
-! CHECK: %[[LEN_LEN_IDX:.*]] = fir.convert %[[LEN_LEN]] : (i32) -> index
+! CHECK: %[[LEN_A_I32:.*]] = fir.convert %[[LEN_A]] : (index) -> i64
+! CHECK: %[[LEN_B_I32:.*]] = fir.convert %[[LEN_B]] : (index) -> i64
+! CHECK: %[[LEN_LEN:.*]] = arith.addi %[[LEN_A_I32]], %[[LEN_B_I32]] : i64
+! CHECK: %[[LEN_LEN_IDX:.*]] = fir.convert %[[LEN_LEN]] : (i64) -> index
 ! CHECK: %[[CMPI:.*]] = arith.cmpi sgt, %[[LEN_LEN_IDX]], %c0{{.*}} : index
-! CHECK: %[[LENGTH:.*]] = arith.select %[[CMPI]], %17, %c0{{.*}} : index
+! CHECK: %[[LENGTH:.*]] = arith.select %[[CMPI]], %[[LEN_LEN_IDX]], %c0{{.*}} : index
 ! CHECK: %{{.*}} = hlfir.elemental %{{.*}} typeparams %[[LENGTH]] unordered : (!fir.shape<1>, index) -> !hlfir.expr<?x!fir.char<1,?>>
 
 end module
diff --git a/flang/test/Lower/array-elemental-calls-char-dynamic.f90 b/flang/test/Lower/array-elemental-calls-char-dynamic.f90
diff --git a/flang/test/Lower/array-elemental-calls-char.f90 b/flang/test/Lower/array-elemental-calls-char.f90
