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

flang/include/flang/Lower/HlfirIntrinsics.h

@@ -58,6 +58,11 @@ struct PreparedActualArgument {
   /// call, the current element value will be returned.
   hlfir::Entity getActual(mlir::Location loc, fir::FirOpBuilder &builder) const;
 
+  /// Lower the actual argument that needs to be handled as dynamically
+  /// optional Value.
+  mlir::Value getOptionalValue(mlir::Location loc,
+                               fir::FirOpBuilder &builder) const;
+
   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;
   }
@@ -3039,6 +3044,38 @@ hlfir::Entity Fortran::lower::PreparedActualArgument::getActual(
   return hlfir::Entity{addr};
 }
 
+mlir::Value Fortran::lower::PreparedActualArgument::getOptionalValue(
+    mlir::Location loc, fir::FirOpBuilder &builder) const {
+  mlir::Type eleType;
+  if (auto *actualEntity = std::get_if<hlfir::Entity>(&actual))
+    eleType = hlfir::getFortranElementType(actualEntity->getType());
+  else
+    TODO(loc, "compute element type from hlfir::ElementalAddrOp");
+
+  // 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}, getIsPresent(),
+               /*withElseRegion=*/true)
+      .genThen([&]() {
+        hlfir::Entity actual = 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);
+        fir::ResultOp::create(builder, loc, val);
+      })
+      .genElse([&]() {
+        mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType);
+        fir::ResultOp::create(builder, loc, zero);
+      })
+      .getResults()[0];
+}
+
 bool Fortran::lower::isIntrinsicModuleProcRef(
     const Fortran::evaluate::ProcedureRef &procRef) {
   const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();

flang/lib/Lower/HlfirIntrinsics.cpp

@@ -69,6 +69,9 @@ class HlfirTransformationalIntrinsic {
   mlir::Value loadBoxAddress(
       const std::optional<Fortran::lower::PreparedActualArgument> &arg);
 
+  mlir::Value loadTrivialScalar(
+      const std::optional<Fortran::lower::PreparedActualArgument> &arg);
+
   void addCleanup(std::optional<hlfir::CleanupFunction> cleanup) {
     if (cleanup)
       cleanupFns.emplace_back(std::move(*cleanup));
@@ -204,6 +207,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,29 +253,10 @@ 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 isPresent = arg->getIsPresent();
-  mlir::Type eleType = hlfir::getFortranElementType(actual.getType());
-  return builder
-      .genIfOp(loc, {eleType}, isPresent,
-               /*withElseRegion=*/true)
-      .genThen([&]() {
-        assert(actual.isScalar() && fir::isa_trivial(eleType) &&
-               "must be a numerical or logical scalar");
-        hlfir::Entity val = hlfir::loadTrivialScalar(loc, builder, actual);
-        fir::ResultOp::create(builder, loc, val);
-      })
-      .genElse([&]() {
-        mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType);
-        fir::ResultOp::create(builder, loc, zero);
-      })
-      .getResults()[0];
+mlir::Value HlfirTransformationalIntrinsic::loadTrivialScalar(
+    const std::optional<Fortran::lower::PreparedActualArgument> &arg) {
+  hlfir::Entity actual = arg->getActual(loc, builder);
+  return hlfir::loadTrivialScalar(loc, builder, actual);
 }
 
 llvm::SmallVector<mlir::Value> HlfirTransformationalIntrinsic::getOperandVector(
@@ -277,29 +272,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 = arg->getOptionalValue(loc, builder);
+        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 +512,35 @@ 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);
+  assert(operands.size() == 4);
+  mlir::Value substr = operands[1];
+  mlir::Value str = operands[0];
+  mlir::Value back = operands[2];
+  mlir::Value kind = operands[3];
+
+  mlir::Type resultType;
+  if (kind) {
+    auto kindCst = fir::getIntIfConstant(kind);
+    assert(kindCst &&
+           "kind argument of index must be an integer constant expression");
+    unsigned bits = builder.getKindMap().getIntegerBitsize(*kindCst);
+    assert(bits != 0 && "failed to convert kind to integer bitsize");
+    resultType = builder.getIntegerType(bits);
+  } else {
+    resultType = builder.getDefaultIntegerType();
+  }
+  mlir::Value result = createOp<hlfir::IndexOp>(resultType, substr, str, back);
+
+  if (resultType != stmtResultType)
+    return builder.createConvert(loc, stmtResultType, result);
+  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 +595,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
 //===----------------------------------------------------------------------===//