[flang] Lower statement function references in HLFIR

[jeanPerier]

Summary

Enable lowering of statement function references in HLFIR. This follows
the same principle as statement function lowering with the current
lowering:

• Actual arguments are lowered and mapped to the statement function dummy symbols.
• "HostAssociated" symbols are mapped to their host values (these are the symbols referred to inside the statement function expressions that are not statement function dummies. e.g: x in stmt_func(i) = x(i)).
• The statement function expression is evaluated.

evaluate::SetLength has to be lowered to deal with statement functions
returning characters since the front-end is generating one to ensure the
statement function expression value is trimmed/padded to match the statement
function declared type.

[PeteSteinfeld]

Aside from a couple of nits, all builds and tests correctly and looks good. @vdonaldson should take a look, though.

flang/lib/Lower/Bridge.cpp

452

I don't think you need the curly braces here.

flang/lib/Lower/ConvertCall.cpp

419

Did you mean to say "There are no"

[clementval]

LGTM

[jeanPerier]

Rebase, fix comment typo and remove braces where not needed.

[jeanPerier]

flang/lib/Lower/ConvertCall.cpp

419

Yes, thanks

flang/include/flang/Lower/ConvertVariable.h

const std::vector<std::pair<semantics::SymbolRef, std::size_t>>
         &commonBlocks);
 
 /// Lower a symbol attributes given an optional storage \p and add it to the
 /// provided symbol map. If \preAlloc is not provided, a temporary storage will
 /// be allocated. This is a low level function that should only be used if
 /// instantiateVariable cannot be called.
 void mapSymbolAttributes(AbstractConverter &, const pft::Variable &, SymMap &,
                          StatementContext &, mlir::Value preAlloc = {});
+void mapSymbolAttributes(AbstractConverter &, const semantics::SymbolRef &,
+                         SymMap &, StatementContext &,
+                         mlir::Value preAlloc = {});
 
 /// Instantiate the variables that appear in the specification expressions
 /// of the result of a function call. The instantiated variables are added
 /// to \p symMap.
 void mapCallInterfaceSymbols(AbstractConverter &,
                              const Fortran::lower::CallerInterface &caller,
                              SymMap &symMap);
 

flang/lib/Lower/Bridge.cpp

mlir::Value impliedDoBinding(llvm::StringRef name) override final {
     mlir::Value val = localSymbols.lookupImpliedDo(name);
     if (!val)
       fir::emitFatalError(toLocation(), "ac-do-variable has no binding");
     return val;
   }
 
   void copySymbolBinding(Fortran::lower::SymbolRef src,
                          Fortran::lower::SymbolRef target) override final {
+    if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) {
+      localSymbols.addVariableDefinition(
+          target, localSymbols.lookupVariableDefinition(src).value());
+    } else {
       localSymbols.addSymbol(target, lookupSymbol(src).toExtendedValue());
     }
+  }
 
   /// Add the symbol binding to the inner-most level of the symbol map and
   /// return true if it is not already present. Otherwise, return false.
   bool bindIfNewSymbol(Fortran::lower::SymbolRef sym,
                        const fir::ExtendedValue &exval) {
     if (shallowLookupSymbol(sym))
       return false;
     bindSymbol(sym, exval);

flang/lib/Lower/ConvertCall.cpp

if (caller.characterize().IsBindC() &&
     mlir::Value len = builder.createIntegerConstant(
         loc, builder.getCharacterLengthType(), charTy.getLen());
     return fir::CharBoxValue{callResult, len};
   }
 
   return callResult;
 }
 
+static hlfir::EntityWithAttributes genStmtFunctionRef(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
+    const Fortran::evaluate::ProcedureRef &procRef) {
+  const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
+  assert(symbol && "expected symbol in ProcedureRef of statement functions");
+  const auto &details = symbol->get<Fortran::semantics::SubprogramDetails>();
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+
+  // Statement functions have their own scope, we just need to associate
+  // the dummy symbols to argument expressions. They are no
+  // optional/alternate return arguments. Statement functions cannot be
+  // recursive (directly or indirectly) so it is safe to add dummy symbols to
+  // the local map here.
+  symMap.pushScope();
+  llvm::SmallVector<hlfir::AssociateOp> exprAssociations;
+  for (auto [arg, bind] : llvm::zip(details.dummyArgs(), procRef.arguments())) {
+    assert(arg && "alternate return in statement function");
+    assert(bind && "optional argument in statement function");
+    const auto *expr = bind->UnwrapExpr();
+    // TODO: assumed type in statement function, that surprisingly seems
+    // allowed, probably because nobody thought of restricting this usage.
+    // gfortran/ifort compiles this.
+    assert(expr && "assumed type used as statement function argument");
+    // As per Fortran 2018 C1580, statement function arguments can only be
+    // scalars.
+    // The only care is to use the dummy character explicit length if any
+    // instead of the actual argument length (that can be bigger).
+    hlfir::EntityWithAttributes loweredArg = Fortran::lower::convertExprToHLFIR(
+        loc, converter, *expr, symMap, stmtCtx);
+    fir::FortranVariableOpInterface variableIface = loweredArg.getIfVariable();
+    if (!variableIface) {
+      // So far only FortranVariableOpInterface can be mapped to symbols.
+      // Create an hlfir.associate to create a variable from a potential
+      // value argument.
+      mlir::Type argType = converter.genType(*arg);
+      auto associate = hlfir::genAssociateExpr(
+          loc, builder, loweredArg, argType, toStringRef(arg->name()));
+      exprAssociations.push_back(associate);
+      variableIface = associate;
+    }
+    const Fortran::semantics::DeclTypeSpec *type = arg->GetType();
+    if (type &&
+        type->category() == Fortran::semantics::DeclTypeSpec::Character) {
+      // Instantiate character as if it was a normal dummy argument so that the
+      // statement function dummy character length is applied and dealt with
+      // correctly.
+      symMap.addSymbol(*arg, variableIface.getBase());
+      Fortran::lower::mapSymbolAttributes(converter, *arg, symMap, stmtCtx);
+    } else {
+      // No need to create an extra hlfir.declare otherwise for
+      // numerical and logical scalar dummies.
+      symMap.addVariableDefinition(*arg, variableIface);
+    }
+  }
+
+  // Explicitly map statement function host associated symbols to their
+  // parent scope lowered symbol box.
+  for (const Fortran::semantics::SymbolRef &sym :
+       Fortran::evaluate::CollectSymbols(*details.stmtFunction()))
+    if (const auto *details =
+            sym->detailsIf<Fortran::semantics::HostAssocDetails>())
+      converter.copySymbolBinding(details->symbol(), sym);
+
+  hlfir::Entity result = Fortran::lower::convertExprToHLFIR(
+      loc, converter, details.stmtFunction().value(), symMap, stmtCtx);
+  symMap.popScope();
+  // The result must not be a variable.
+  result = hlfir::loadTrivialScalar(loc, builder, result);
+  if (result.isVariable())
+    result = hlfir::Entity{builder.create<hlfir::AsExprOp>(loc, result)};
+  for (auto associate : exprAssociations)
+    builder.create<hlfir::EndAssociateOp>(loc, associate);
+  return hlfir::EntityWithAttributes{result};
+}
+
 /// Is this a call to an elemental procedure with at least one array argument?
 static bool
 isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
   if (procRef.IsElemental())
     for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
          procRef.arguments())
       if (arg && arg->Rank() != 0)
         return true;
gen(const Fortran::evaluate::ProcedureRef &procRef,
       llvm::Optional<mlir::Type> resultType) {
     mlir::Location loc = getLoc();
     if (auto *specific = procRef.proc().GetSpecificIntrinsic()) {
       if (isElementalProcWithArrayArgs(procRef))
         TODO(loc, "lowering elemental intrinsic call to HLFIR");
       return genIntrinsicRef(procRef, resultType, *specific);
     }
     if (isStatementFunctionCall(procRef))
-      TODO(loc, "lowering Statement function call to HLFIR");
+      return genStmtFunctionRef(loc, converter, symMap, stmtCtx, procRef);
 
     Fortran::lower::CallerInterface caller(procRef, converter);
     mlir::FunctionType callSiteType = caller.genFunctionType();
 
     PreparedActualArguments loweredActuals;
     // Lower the actual arguments
     for (const Fortran::lower::CallInterface<
              Fortran::lower::CallerInterface>::PassedEntity &arg :

flang/lib/Lower/ConvertExprToHLFIR.cpp

static hlfir::EntityWithAttributes gen(mlir::Location loc,
     return hlfir::EntityWithAttributes{res};
   }
 };
 
 template <int KIND>
 struct BinaryOp<Fortran::evaluate::SetLength<KIND>> {
   using Op = Fortran::evaluate::SetLength<KIND>;
   static hlfir::EntityWithAttributes gen(mlir::Location loc,
-                                         fir::FirOpBuilder &, const Op &,
-                                         hlfir::Entity, hlfir::Entity) {
-    TODO(loc, "SetLength lowering to HLFIR");
+                                         fir::FirOpBuilder &builder, const Op &,
+                                         hlfir::Entity string,
+                                         hlfir::Entity length) {
+    return hlfir::EntityWithAttributes{
+        builder.create<hlfir::SetLengthOp>(loc, string, length)};
   }
   static void
-  genResultTypeParams(mlir::Location loc, fir::FirOpBuilder &builder,
-                      hlfir::Entity lhs, hlfir::Entity rhs,
+  genResultTypeParams(mlir::Location, fir::FirOpBuilder &, hlfir::Entity,
+                      hlfir::Entity rhs,
                       llvm::SmallVectorImpl<mlir::Value> &resultTypeParams) {
     resultTypeParams.push_back(rhs);
   }
 };
 
 template <int KIND>
 struct BinaryOp<Fortran::evaluate::Concat<KIND>> {
   using Op = Fortran::evaluate::Concat<KIND>;

flang/lib/Lower/ConvertVariable.cpp

for (Fortran::lower::pft::Variable var :
     // If this is neither a host associated or dummy symbol, it must be a
     // module or common block variable to satisfy specification expression
     // requirements in 10.1.11, instantiateVariable will get its address and
     // properties.
     instantiateVariable(converter, var, symMap, storeMap);
   }
 }
 
+void Fortran::lower::mapSymbolAttributes(
+    AbstractConverter &converter, const Fortran::semantics::SymbolRef &symbol,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
+    mlir::Value preAlloc) {
+  mapSymbolAttributes(converter, pft::Variable{symbol}, symMap, stmtCtx,
+                      preAlloc);
+}
+
 void Fortran::lower::createRuntimeTypeInfoGlobal(
     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
     const Fortran::semantics::Symbol &typeInfoSym) {
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   std::string globalName = Fortran::lower::mangle::mangleName(typeInfoSym);
   auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true);
   mlir::StringAttr linkage = getLinkageAttribute(builder, var);
   defineGlobal(converter, var, globalName, linkage);
 }

flang/lib/Lower/SymbolMap.cpp

 Fortran::lower::SymMap::lookupImpliedDo(Fortran::lower::SymMap::AcDoVar var) {
   for (auto [marker, binding] : llvm::reverse(impliedDoStack))
     if (var == marker)
       return binding;
   return {};
 }
 
 llvm::Optional<fir::FortranVariableOpInterface>
-Fortran::lower::SymMap::lookupVariableDefinition(semantics::SymbolRef sym) {
+Fortran::lower::SymMap::lookupVariableDefinition(semantics::SymbolRef symRef) {
+  Fortran::semantics::SymbolRef sym = symRef.get().GetUltimate();
   for (auto jmap = symbolMapStack.rbegin(), jend = symbolMapStack.rend();
        jmap != jend; ++jmap) {
     auto iter = jmap->find(&*sym);
     if (iter != jmap->end()) {
       if (const auto *varDef =
               std::get_if<fir::FortranVariableOpInterface>(&iter->second))
         return *varDef;
       else

flang/test/Lower/HLFIR/statement-functions.f90

+! Test lowering of statement functions to HLFIR
+! RUN: bbc -emit-fir -hlfir -o - %s 2>&1 | FileCheck %s
+
+subroutine numeric_test(x)
+  integer :: x(:), i, stmt_func
+  stmt_func(i) = x(i)
+  call bar(stmt_func(42))
+end subroutine
+! CHECK-LABEL: func.func @_QPnumeric_test(
+! CHECK:  %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_0:[^)]*]] {{.*}}x"
+! CHECK:  %[[VAL_6:.*]] = arith.constant 42 : i32
+! CHECK:  %[[VAL_7:.*]]:3 = hlfir.associate %[[VAL_6]] {uniq_name = "i"} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK:  %[[VAL_8:.*]] = fir.load %[[VAL_7]]#0 : !fir.ref<i32>
+! CHECK:  %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> i64
+! CHECK:  %[[VAL_10:.*]] = hlfir.designate %[[VAL_4]]#0 (%[[VAL_9]])  : (!fir.box<!fir.array<?xi32>>, i64) -> !fir.ref<i32>
+! CHECK:  %[[VAL_11:.*]] = fir.load %[[VAL_10]] : !fir.ref<i32>
+
+subroutine char_test(c, n)
+  character(*) :: c
+  character(n) :: char_stmt_func_dummy_arg
+  character(10) :: stmt_func
+  stmt_func(char_stmt_func_dummy_arg) = char_stmt_func_dummy_arg
+  call bar2(stmt_func(c))
+end subroutine
+! CHECK-LABEL: func.func @_QPchar_test(
+! CHECK:  %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3:.*]]#0 typeparams %[[VAL_3]]#1 {{.*}}c"
+! CHECK:  %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_2:[^ ]*]] {{.*}}n"
+! CHECK:  %[[VAL_13:.*]]:2 = fir.unboxchar %[[VAL_4]]#0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+! CHECK:  %[[VAL_14:.*]] = fir.load %[[VAL_5]]#0 : !fir.ref<i32>
+! CHECK:  %[[VAL_15:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_16:.*]] = arith.cmpi sgt, %[[VAL_14]], %[[VAL_15]] : i32
+! CHECK:  %[[VAL_17:.*]] = arith.select %[[VAL_16]], %[[VAL_14]], %[[VAL_15]] : i32
+! CHECK:  %[[VAL_18:.*]]:2 = hlfir.declare %[[VAL_13]]#0 typeparams %[[VAL_17]] {uniq_name = "_QFstmt_funcEchar_stmt_func_dummy_arg"} : (!fir.ref<!fir.char<1,?>>, i32) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+! CHECK:  %[[VAL_19:.*]] = arith.constant 10 : i64
+! CHECK:  %[[VAL_20:.*]] = hlfir.set_length %[[VAL_18]]#0 len %[[VAL_19]] : (!fir.boxchar<1>, i64) -> !hlfir.expr<!fir.char<1,10>>