[flang] Add hlfir.index op to represent index intrinsic function

flang/include/flang/Lower/HlfirIntrinsics.h

@@ -58,6 +58,14 @@ struct PreparedActualArgument {
   /// call, the current element value will be returned.
   hlfir::Entity getActual(mlir::Location loc, fir::FirOpBuilder &builder) const;
 
+  mlir::Type getFortranElementType() {
+    if (auto *actualEntity = std::get_if<hlfir::Entity>(&actual))
+      return hlfir::getFortranElementType(actualEntity->getType());
+    mlir::Value entity =
+        std::get<hlfir::ElementalAddrOp>(actual).getElementEntity();
+    return hlfir::getFortranElementType(entity.getType());
+  }
+
   void derefPointersAndAllocatables(mlir::Location loc,
                                     fir::FirOpBuilder &builder) {
     if (auto *actualEntity = std::get_if<hlfir::Entity>(&actual))

flang/include/flang/Optimizer/Builder/Runtime/Character.h

@@ -65,6 +65,14 @@ mlir::Value genIndex(fir::FirOpBuilder &builder, mlir::Location loc, int kind,
                      mlir::Value substringBase, mlir::Value substringLen,
                      mlir::Value back);
 
+/// Generate call to INDEX runtime.
+/// This calls the simple runtime entry points based on the KIND of the string.
+/// A version of interface taking a `boxchar` for string and substring.
+/// Uses no-descriptors flow.
+mlir::Value genIndex(fir::FirOpBuilder &builder, mlir::Location loc,
+                     const fir::ExtendedValue &str,
+                     const fir::ExtendedValue &substr, mlir::Value back);
+
 /// Generate call to INDEX runtime.
 /// This calls the descriptor based runtime call implementation for the index
 /// intrinsic.

flang/include/flang/Optimizer/HLFIR/HLFIROps.td

@@ -394,6 +394,27 @@ def hlfir_CharTrimOp
   let builders = [OpBuilder<(ins "mlir::Value":$chr)>];
 }
 
+def hlfir_IndexOp
+    : hlfir_Op<"index", [DeclareOpInterfaceMethods<MemoryEffectsOpInterface>]> {
+  let summary = "index transformational intrinsic";
+  let description = [{
+    Search for a substring position within a string, optionally backward
+    if back is set to true.
+  }];
+
+  let arguments = (ins AnyScalarCharacterEntity:$substr,
+      AnyScalarCharacterEntity:$str,
+      Optional<Type<AnyLogicalLike.predicate>>:$back);
+
+  let results = (outs AnyIntegerType);
+
+  let assemblyFormat = [{
+      $substr `in` $str  (`back` $back^)? attr-dict `:` functional-type(operands, results)
+  }];
+
+  let hasVerifier = 1;
+}
+
 def hlfir_AllOp : hlfir_Op<"all", [DeclareOpInterfaceMethods<MemoryEffectsOpInterface>]> {
   let summary = "ALL transformational intrinsic";
   let description = [{

flang/lib/Lower/ConvertCall.cpp

@@ -2193,10 +2193,15 @@ static std::optional<hlfir::EntityWithAttributes> genHLFIRIntrinsicRefCore(
     const std::string intrinsicName = callContext.getProcedureName();
     const fir::IntrinsicArgumentLoweringRules *argLowering =
         intrinsicEntry.getArgumentLoweringRules();
+    mlir::Type resultType =
+        callContext.isElementalProcWithArrayArgs()
+            ? hlfir::getFortranElementType(*callContext.resultType)
+            : *callContext.resultType;
+
     std::optional<hlfir::EntityWithAttributes> res =
         Fortran::lower::lowerHlfirIntrinsic(builder, loc, intrinsicName,
                                             loweredActuals, argLowering,
-                                            *callContext.resultType);
+                                            resultType);
     if (res)
       return res;
   }

flang/lib/Lower/HlfirIntrinsics.cpp

@@ -69,6 +69,11 @@ class HlfirTransformationalIntrinsic {
   mlir::Value loadBoxAddress(
       const std::optional<Fortran::lower::PreparedActualArgument> &arg);
 
+  mlir::Value
+  loadTrivialScalar(const Fortran::lower::PreparedActualArgument &arg);
+
+  mlir::Value loadOptionalValue(Fortran::lower::PreparedActualArgument &arg);
+
   void addCleanup(std::optional<hlfir::CleanupFunction> cleanup) {
     if (cleanup)
       cleanupFns.emplace_back(std::move(*cleanup));
@@ -204,6 +209,17 @@ class HlfirReshapeLowering : public HlfirTransformationalIntrinsic {
             mlir::Type stmtResultType) override;
 };
 
+class HlfirIndexLowering : public HlfirTransformationalIntrinsic {
+public:
+  using HlfirTransformationalIntrinsic::HlfirTransformationalIntrinsic;
+
+protected:
+  mlir::Value
+  lowerImpl(const Fortran::lower::PreparedActualArguments &loweredActuals,
+            const fir::IntrinsicArgumentLoweringRules *argLowering,
+            mlir::Type stmtResultType) override;
+};
+
 } // namespace
 
 mlir::Value HlfirTransformationalIntrinsic::loadBoxAddress(
@@ -239,19 +255,22 @@ mlir::Value HlfirTransformationalIntrinsic::loadBoxAddress(
   return boxOrAbsent;
 }
 
-static mlir::Value loadOptionalValue(
-    mlir::Location loc, fir::FirOpBuilder &builder,
-    const std::optional<Fortran::lower::PreparedActualArgument> &arg,
-    hlfir::Entity actual) {
-  if (!arg->handleDynamicOptional())
-    return hlfir::loadTrivialScalar(loc, builder, actual);
+mlir::Value HlfirTransformationalIntrinsic::loadOptionalValue(
+    Fortran::lower::PreparedActualArgument &arg) {
+  mlir::Type eleType = arg.getFortranElementType();
 
-  mlir::Value isPresent = arg->getIsPresent();
-  mlir::Type eleType = hlfir::getFortranElementType(actual.getType());
+  // For an elemental call, getActual() may produce
+  // a designator denoting the array element to be passed
+  // to the subprogram. If the actual array is dynamically
+  // optional the designator must be generated under
+  // isPresent check (see also genIntrinsicRefCore).
   return builder
-      .genIfOp(loc, {eleType}, isPresent,
+      .genIfOp(loc, {eleType}, arg.getIsPresent(),
                /*withElseRegion=*/true)
       .genThen([&]() {
+        hlfir::Entity actual = arg.getActual(loc, builder);
+        assert(eleType == actual.getFortranElementType() &&
+               "result type mismatch in genOptionalValue");
         assert(actual.isScalar() && fir::isa_trivial(eleType) &&
                "must be a numerical or logical scalar");
         hlfir::Entity val = hlfir::loadTrivialScalar(loc, builder, actual);
@@ -264,6 +283,12 @@ static mlir::Value loadOptionalValue(
       .getResults()[0];
 }
 
+mlir::Value HlfirTransformationalIntrinsic::loadTrivialScalar(
+    const Fortran::lower::PreparedActualArgument &arg) {
+  hlfir::Entity actual = arg.getActual(loc, builder);
+  return hlfir::loadTrivialScalar(loc, builder, actual);
+}
+
 llvm::SmallVector<mlir::Value> HlfirTransformationalIntrinsic::getOperandVector(
     const Fortran::lower::PreparedActualArguments &loweredActuals,
     const fir::IntrinsicArgumentLoweringRules *argLowering) {
@@ -277,29 +302,33 @@ llvm::SmallVector<mlir::Value> HlfirTransformationalIntrinsic::getOperandVector(
       operands.emplace_back();
       continue;
     }
-    hlfir::Entity actual = arg->getActual(loc, builder);
     mlir::Value valArg;
-
     if (!argLowering) {
-      valArg = hlfir::loadTrivialScalar(loc, builder, actual);
-    } else {
-      fir::ArgLoweringRule argRules =
-          fir::lowerIntrinsicArgumentAs(*argLowering, i);
-      if (argRules.lowerAs == fir::LowerIntrinsicArgAs::Box)
-        valArg = loadBoxAddress(arg);
-      else if (!argRules.handleDynamicOptional &&
-               argRules.lowerAs != fir::LowerIntrinsicArgAs::Inquired)
-        valArg = hlfir::derefPointersAndAllocatables(loc, builder, actual);
-      else if (argRules.handleDynamicOptional &&
-               argRules.lowerAs == fir::LowerIntrinsicArgAs::Value)
-        valArg = loadOptionalValue(loc, builder, arg, actual);
-      else if (argRules.handleDynamicOptional)
+      valArg = loadTrivialScalar(*arg);
+      operands.emplace_back(valArg);
+      continue;
+    }
+    fir::ArgLoweringRule argRules =
+        fir::lowerIntrinsicArgumentAs(*argLowering, i);
+    if (argRules.lowerAs == fir::LowerIntrinsicArgAs::Box) {
+      valArg = loadBoxAddress(arg);
+    } else if (argRules.handleDynamicOptional) {
+      if (argRules.lowerAs == fir::LowerIntrinsicArgAs::Value) {
+        if (arg->handleDynamicOptional())
+          valArg = loadOptionalValue(*arg);
+        else
+          valArg = loadTrivialScalar(*arg);
+      } else {
         TODO(loc, "hlfir transformational intrinsic dynamically optional "
                   "argument without box lowering");
+      }
+    } else {
+      hlfir::Entity actual = arg->getActual(loc, builder);
+      if (argRules.lowerAs != fir::LowerIntrinsicArgAs::Inquired)
+        valArg = hlfir::derefPointersAndAllocatables(loc, builder, actual);
       else
         valArg = actual.getBase();
     }
-
     operands.emplace_back(valArg);
   }
   return operands;
@@ -513,6 +542,22 @@ mlir::Value HlfirReshapeLowering::lowerImpl(
                                     operands[2], operands[3]);
 }
 
+mlir::Value HlfirIndexLowering::lowerImpl(
+    const Fortran::lower::PreparedActualArguments &loweredActuals,
+    const fir::IntrinsicArgumentLoweringRules *argLowering,
+    mlir::Type stmtResultType) {
+  auto operands = getOperandVector(loweredActuals, argLowering);
+  // 'kind' optional operand is unused here as it has already been
+  // translated into result type.
+  assert(operands.size() == 4);
+  mlir::Value substr = operands[1];
+  mlir::Value str = operands[0];
+  mlir::Value back = operands[2];
+  mlir::Value result =
+      createOp<hlfir::IndexOp>(stmtResultType, substr, str, back);
+  return result;
+}
+
 std::optional<hlfir::EntityWithAttributes> Fortran::lower::lowerHlfirIntrinsic(
     fir::FirOpBuilder &builder, mlir::Location loc, const std::string &name,
     const Fortran::lower::PreparedActualArguments &loweredActuals,
@@ -567,6 +612,10 @@ std::optional<hlfir::EntityWithAttributes> Fortran::lower::lowerHlfirIntrinsic(
   if (name == "reshape")
     return HlfirReshapeLowering{builder, loc}.lower(loweredActuals, argLowering,
                                                     stmtResultType);
+  if (name == "index")
+    return HlfirIndexLowering{builder, loc}.lower(loweredActuals, argLowering,
+                                                  stmtResultType);
+
   if (mlir::isa<fir::CharacterType>(stmtResultType)) {
     if (name == "min")
       return HlfirCharExtremumLowering{builder, loc,

flang/lib/Optimizer/Builder/Runtime/Character.cpp

@@ -119,23 +119,23 @@ fir::runtime::genCharCompare(fir::FirOpBuilder &builder, mlir::Location loc,
   return mlir::arith::CmpIOp::create(builder, loc, cmp, tri, zero);
 }
 
+static mlir::Value allocateIfNotInMemory(fir::FirOpBuilder &builder,
+                                         mlir::Location loc, mlir::Value base) {
+  if (fir::isa_ref_type(base.getType()))
+    return base;
+  auto mem =
+      fir::AllocaOp::create(builder, loc, base.getType(), /*pinned=*/false);
+  fir::StoreOp::create(builder, loc, base, mem);
+  return mem;
+}
+
 mlir::Value fir::runtime::genCharCompare(fir::FirOpBuilder &builder,
                                          mlir::Location loc,
                                          mlir::arith::CmpIPredicate cmp,
                                          const fir::ExtendedValue &lhs,
                                          const fir::ExtendedValue &rhs) {
-  if (lhs.getBoxOf<fir::BoxValue>() || rhs.getBoxOf<fir::BoxValue>())
-    TODO(loc, "character compare from descriptors");
-  auto allocateIfNotInMemory = [&](mlir::Value base) -> mlir::Value {
-    if (fir::isa_ref_type(base.getType()))
-      return base;
-    auto mem =
-        fir::AllocaOp::create(builder, loc, base.getType(), /*pinned=*/false);
-    fir::StoreOp::create(builder, loc, base, mem);
-    return mem;
-  };
-  auto lhsBuffer = allocateIfNotInMemory(fir::getBase(lhs));
-  auto rhsBuffer = allocateIfNotInMemory(fir::getBase(rhs));
+  auto lhsBuffer = allocateIfNotInMemory(builder, loc, fir::getBase(lhs));
+  auto rhsBuffer = allocateIfNotInMemory(builder, loc, fir::getBase(rhs));
   return genCharCompare(builder, loc, cmp, lhsBuffer, fir::getLen(lhs),
                         rhsBuffer, fir::getLen(rhs));
 }
@@ -168,6 +168,20 @@ mlir::Value fir::runtime::genIndex(fir::FirOpBuilder &builder,
   return fir::CallOp::create(builder, loc, indexFunc, args).getResult(0);
 }
 
+mlir::Value fir::runtime::genIndex(fir::FirOpBuilder &builder,
+                                   mlir::Location loc,
+                                   const fir::ExtendedValue &str,
+                                   const fir::ExtendedValue &substr,
+                                   mlir::Value back) {
+  assert(!substr.getBoxOf<fir::BoxValue>() && !str.getBoxOf<fir::BoxValue>() &&
+         "shall use genIndexDescriptor version");
+  auto strBuffer = allocateIfNotInMemory(builder, loc, fir::getBase(str));
+  auto substrBuffer = allocateIfNotInMemory(builder, loc, fir::getBase(substr));
+  int kind = discoverKind(strBuffer.getType());
+  return genIndex(builder, loc, kind, strBuffer, fir::getLen(str), substrBuffer,
+                  fir::getLen(substr), back);
+}
+
 void fir::runtime::genIndexDescriptor(fir::FirOpBuilder &builder,
                                       mlir::Location loc, mlir::Value resultBox,
                                       mlir::Value stringBox,

flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp

@@ -878,6 +878,28 @@ void hlfir::CharTrimOp::getEffects(
   getIntrinsicEffects(getOperation(), effects);
 }
 
+//===----------------------------------------------------------------------===//
+// IndexOp
+//===----------------------------------------------------------------------===//
+
+llvm::LogicalResult hlfir::IndexOp::verify() {
+  mlir::Value substr = getSubstr();
+  mlir::Value str = getStr();
+
+  unsigned charKind = getCharacterKind(substr.getType());
+  if (charKind != getCharacterKind(str.getType()))
+    return emitOpError("character arguments must have the same KIND");
+
+  return mlir::success();
+}
+
+void hlfir::IndexOp::getEffects(
+    llvm::SmallVectorImpl<
+        mlir::SideEffects::EffectInstance<mlir::MemoryEffects::Effect>>
+        &effects) {
+  getIntrinsicEffects(getOperation(), effects);
+}
+
 //===----------------------------------------------------------------------===//
 // NumericalReductionOp
 //===----------------------------------------------------------------------===//

flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIRIntrinsics.cpp

@@ -613,6 +613,45 @@ class CharTrimOpConversion
   }
 };
 
+class IndexOpConversion : public HlfirIntrinsicConversion<hlfir::IndexOp> {
+  using HlfirIntrinsicConversion<hlfir::IndexOp>::HlfirIntrinsicConversion;
+
+  llvm::LogicalResult
+  matchAndRewrite(hlfir::IndexOp op,
+                  mlir::PatternRewriter &rewriter) const override {
+    fir::FirOpBuilder builder{rewriter, op.getOperation()};
+    const mlir::Location &loc = op->getLoc();
+    hlfir::Entity substr{op.getSubstr()};
+    hlfir::Entity str{op.getStr()};
+
+    auto [substrExv, substrCleanUp] =
+        hlfir::translateToExtendedValue(loc, builder, substr);
+    auto [strExv, strCleanUp] =
+        hlfir::translateToExtendedValue(loc, builder, str);
+
+    mlir::Value back = op.getBack();
+    if (!back)
+      back = builder.createBool(loc, false);
+
+    mlir::Value result =
+        fir::runtime::genIndex(builder, loc, strExv, substrExv, back);
+    result = builder.createConvert(loc, op.getType(), result);
+    if (strCleanUp || substrCleanUp) {
+      mlir::OpBuilder::InsertionGuard guard(builder);
+      builder.setInsertionPointAfter(op);
+      if (strCleanUp)
+        (*strCleanUp)();
+      if (substrCleanUp)
+        (*substrCleanUp)();
+    }
+    auto resultEntity = hlfir::EntityWithAttributes{result};
+
+    processReturnValue(op, resultEntity, /*mustBeFreed=*/false, builder,
+                       rewriter);
+    return mlir::success();
+  }
+};
+
 class LowerHLFIRIntrinsics
     : public hlfir::impl::LowerHLFIRIntrinsicsBase<LowerHLFIRIntrinsics> {
 public:
@@ -627,7 +666,7 @@ class LowerHLFIRIntrinsics
         MaxvalOpConversion, MinvalOpConversion, MinlocOpConversion,
         MaxlocOpConversion, ArrayShiftOpConversion<hlfir::CShiftOp>,
         ArrayShiftOpConversion<hlfir::EOShiftOp>, ReshapeOpConversion,
-        CmpCharOpConversion, CharTrimOpConversion>(context);
+        CmpCharOpConversion, CharTrimOpConversion, IndexOpConversion>(context);
 
     // While conceptually this pass is performing dialect conversion, we use
     // pattern rewrites here instead of dialect conversion because this pass