diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h --- a/flang/include/flang/Lower/ConvertVariable.h +++ b/flang/include/flang/Lower/ConvertVariable.h @@ -70,6 +70,9 @@ /// 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 diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -449,7 +449,11 @@ void copySymbolBinding(Fortran::lower::SymbolRef src, Fortran::lower::SymbolRef target) override final { - localSymbols.addSymbol(target, lookupSymbol(src).toExtendedValue()); + 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 diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -406,6 +406,82 @@ 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(); + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + + // Statement functions have their own scope, we just need to associate + // the dummy symbols to argument expressions. There 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 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()) + 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(loc, result)}; + for (auto associate : exprAssociations) + builder.create(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) { @@ -454,7 +530,7 @@ 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(); diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp --- a/flang/lib/Lower/ConvertExprToHLFIR.cpp +++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp @@ -511,13 +511,15 @@ struct BinaryOp> { using Op = Fortran::evaluate::SetLength; 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(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 &resultTypeParams) { resultTypeParams.push_back(rhs); } diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -1890,6 +1890,14 @@ } } +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) { diff --git a/flang/lib/Lower/SymbolMap.cpp b/flang/lib/Lower/SymbolMap.cpp --- a/flang/lib/Lower/SymbolMap.cpp +++ b/flang/lib/Lower/SymbolMap.cpp @@ -92,7 +92,8 @@ } llvm::Optional -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); diff --git a/flang/test/Lower/HLFIR/statement-functions.f90 b/flang/test/Lower/HLFIR/statement-functions.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/HLFIR/statement-functions.f90 @@ -0,0 +1,35 @@ +! 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, !fir.ref, i1) +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_7]]#0 : !fir.ref +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> i64 +! CHECK: %[[VAL_10:.*]] = hlfir.designate %[[VAL_4]]#0 (%[[VAL_9]]) : (!fir.box>, i64) -> !fir.ref +! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_10]] : !fir.ref + +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>, index) +! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_5]]#0 : !fir.ref +! 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>, i32) -> (!fir.boxchar<1>, !fir.ref>) +! 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>