diff --git a/flang/include/flang/Lower/ConvertCall.h b/flang/include/flang/Lower/ConvertCall.h --- a/flang/include/flang/Lower/ConvertCall.h +++ b/flang/include/flang/Lower/ConvertCall.h @@ -19,6 +19,7 @@ #include "flang/Lower/AbstractConverter.h" #include "flang/Lower/CallInterface.h" +#include "flang/Optimizer/Builder/HLFIRTools.h" namespace Fortran::lower { @@ -38,5 +39,13 @@ mlir::Value argumentHostAssocs(Fortran::lower::AbstractConverter &converter, mlir::Value arg); +/// Lower a ProcedureRef to HLFIR. If this is a function call, return the +/// lowered result value. Return nothing otherwise. +llvm::Optional convertCallToHLFIR( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const evaluate::ProcedureRef &procRef, + llvm::Optional resultType, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx); + } // namespace Fortran::lower #endif // FORTRAN_LOWER_CONVERTCALL_H diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h --- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h +++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h @@ -23,6 +23,8 @@ namespace hlfir { +class AssociateOp; + /// Is this an SSA value type for the value of a Fortran expression? inline bool isFortranValueType(mlir::Type type) { return type.isa() || fir::isa_trivial(type); @@ -151,12 +153,40 @@ llvm::StringRef name, fir::FortranVariableFlagsAttr flags); +/// Generate an hlfir.associate to build a variable from an expression value. +/// The type of the variable must be provided so that scalar logicals are +/// properly typed when placed in memory. +hlfir::AssociateOp genAssociateExpr(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity value, + mlir::Type variableType, + llvm::StringRef name); + +/// Get the raw address of a variable (simple fir.ref/fir.ptr, or fir.heap +/// value). The returned value should be used with care, it does not contain any +/// stride, shape, and type parameter information. For pointers and +/// allocatables, this returns the address of the target. +mlir::Value genVariableRawAddress(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity var); + +/// Get a fir.boxchar for character scalar or array variable (the shape is lost +/// for arrays). +mlir::Value genVariableBoxChar(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity var); + /// If the entity is a variable, load its value (dereference pointers and /// allocatables if needed). Do nothing if the entity os already a variable or /// if it is not a scalar entity of numerical or logical type. Entity loadTrivialScalar(mlir::Location loc, fir::FirOpBuilder &builder, Entity entity); +/// If \p entity is a POINTER or ALLOCATABLE, dereference it and return the +/// target entity. Return \p entity otherwise. +hlfir::Entity derefPointersAndAllocatables(mlir::Location loc, + fir::FirOpBuilder &builder, + Entity entity); + /// Compute the lower and upper bounds of an entity. llvm::SmallVector> genBounds(mlir::Location loc, fir::FirOpBuilder &builder, Entity entity); 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 @@ -14,6 +14,7 @@ #include "flang/Lower/Allocatable.h" #include "flang/Lower/CallInterface.h" #include "flang/Lower/Coarray.h" +#include "flang/Lower/ConvertCall.h" #include "flang/Lower/ConvertExpr.h" #include "flang/Lower/ConvertExprToHLFIR.h" #include "flang/Lower/ConvertType.h" @@ -1097,10 +1098,22 @@ Fortran::lower::pft::Evaluation &eval = getEval(); setCurrentPosition(stmt.v.source); assert(stmt.typedCall && "Call was not analyzed"); - // Call statement lowering shares code with function call lowering. - mlir::Value res = Fortran::lower::createSubroutineCall( - *this, *stmt.typedCall, explicitIterSpace, implicitIterSpace, - localSymbols, stmtCtx, /*isUserDefAssignment=*/false); + mlir::Value res{}; + if (bridge.getLoweringOptions().getLowerToHighLevelFIR()) { + llvm::Optional resultType = llvm::None; + if (stmt.typedCall->hasAlternateReturns()) + resultType = builder->getIndexType(); + auto hlfirRes = Fortran::lower::convertCallToHLFIR( + toLocation(), *this, *stmt.typedCall, resultType, localSymbols, + stmtCtx); + if (hlfirRes) + res = *hlfirRes; + } else { + // Call statement lowering shares code with function call lowering. + res = Fortran::lower::createSubroutineCall( + *this, *stmt.typedCall, explicitIterSpace, implicitIterSpace, + localSymbols, stmtCtx, /*isUserDefAssignment=*/false); + } if (!res) return; // "Normal" subroutine call. // Call with alternate return specifiers. 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 @@ -11,6 +11,7 @@ //===----------------------------------------------------------------------===// #include "flang/Lower/ConvertCall.h" +#include "flang/Lower/ConvertExprToHLFIR.h" #include "flang/Lower/ConvertVariable.h" #include "flang/Lower/StatementContext.h" #include "flang/Lower/SymbolMap.h" @@ -21,6 +22,7 @@ #include "flang/Optimizer/Builder/MutableBox.h" #include "flang/Optimizer/Builder/Todo.h" #include "flang/Optimizer/Dialect/FIROpsSupport.h" +#include "flang/Optimizer/HLFIR/HLFIROps.h" #include "llvm/Support/Debug.h" #define DEBUG_TYPE "flang-lower-expr" @@ -400,3 +402,183 @@ return callResult; } + +/// 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 &arg : + procRef.arguments()) + if (arg && arg->Rank() != 0) + return true; + return false; +} + +/// helper to detect statement functions +static bool +isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) { + if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol()) + if (const auto *details = + symbol->detailsIf()) + return details->stmtFunction().has_value(); + return false; +} + +namespace { +class CallBuilder { +public: + CallBuilder(mlir::Location loc, Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) + : converter{converter}, symMap{symMap}, stmtCtx{stmtCtx}, loc{loc} {} + + llvm::Optional + gen(const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional resultType) { + mlir::Location loc = getLoc(); + fir::FirOpBuilder &builder = getBuilder(); + if (isElementalProcWithArrayArgs(procRef)) + TODO(loc, "lowering elemental call to HLFIR"); + if (procRef.proc().GetSpecificIntrinsic()) + TODO(loc, "lowering ProcRef to HLFIR"); + if (isStatementFunctionCall(procRef)) + TODO(loc, "lowering Statement function call to HLFIR"); + + Fortran::lower::CallerInterface caller(procRef, converter); + using PassBy = Fortran::lower::CallerInterface::PassEntityBy; + mlir::FunctionType callSiteType = caller.genFunctionType(); + + llvm::SmallVector> + loweredActuals; + // Lower the actual arguments + for (const Fortran::lower::CallInterface< + Fortran::lower::CallerInterface>::PassedEntity &arg : + caller.getPassedArguments()) + if (const auto *actual = arg.entity) { + const auto *expr = actual->UnwrapExpr(); + if (!expr) + TODO(loc, "assumed type actual argument"); + loweredActuals.emplace_back(Fortran::lower::convertExprToHLFIR( + loc, getConverter(), *expr, getSymMap(), getStmtCtx())); + } else { + // Optional dummy argument for which there is no actual argument. + loweredActuals.emplace_back(llvm::None); + } + + llvm::SmallVector exprAssociations; + for (auto [actual, arg] : + llvm::zip(loweredActuals, caller.getPassedArguments())) { + mlir::Type argTy = callSiteType.getInput(arg.firArgument); + if (!actual) { + // Optional dummy argument for which there is no actual argument. + caller.placeInput(arg, builder.create(loc, argTy)); + continue; + } + + const auto *expr = arg.entity->UnwrapExpr(); + if (!expr) + TODO(loc, "assumed type actual argument"); + + const bool actualMayBeDynamicallyAbsent = + arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional( + *expr, getConverter().getFoldingContext()); + if (actualMayBeDynamicallyAbsent) + TODO(loc, "passing optional arguments in HLFIR"); + + const bool isSimplyContiguous = + actual->isScalar() || Fortran::evaluate::IsSimplyContiguous( + *expr, getConverter().getFoldingContext()); + + switch (arg.passBy) { + case PassBy::Value: { + // True pass-by-value semantics. + auto value = hlfir::loadTrivialScalar(loc, builder, *actual); + if (!value.isValue()) + TODO(loc, "Passing CPTR an CFUNCTPTR VALUE in HLFIR"); + caller.placeInput(arg, builder.createConvert(loc, argTy, value)); + } break; + case PassBy::BaseAddressValueAttribute: { + // VALUE attribute or pass-by-reference to a copy semantics. (byval*) + TODO(loc, "HLFIR PassBy::BaseAddressValueAttribute"); + } break; + case PassBy::BaseAddress: + case PassBy::BoxChar: { + hlfir::Entity entity = *actual; + if (entity.isVariable()) { + entity = hlfir::derefPointersAndAllocatables(loc, builder, entity); + // Copy-in non contiguous variable + if (!isSimplyContiguous) + TODO(loc, "HLFIR copy-in/copy-out"); + } else { + hlfir::AssociateOp associate = hlfir::genAssociateExpr( + loc, builder, entity, argTy, "adapt.valuebyref"); + exprAssociations.push_back(associate); + entity = hlfir::Entity{associate.getBase()}; + } + mlir::Value addr = + arg.passBy == PassBy::BaseAddress + ? hlfir::genVariableRawAddress(loc, builder, entity) + : hlfir::genVariableBoxChar(loc, builder, entity); + caller.placeInput(arg, builder.createConvert(loc, argTy, addr)); + } break; + case PassBy::CharBoxValueAttribute: { + TODO(loc, "HLFIR PassBy::CharBoxValueAttribute"); + } break; + case PassBy::AddressAndLength: + // PassBy::AddressAndLength is only used for character results. Results + // are not handled here. + fir::emitFatalError( + loc, "unexpected PassBy::AddressAndLength for actual arguments"); + break; + case PassBy::CharProcTuple: { + TODO(loc, "HLFIR PassBy::CharProcTuple"); + } break; + case PassBy::Box: { + TODO(loc, "HLFIR PassBy::Box"); + } break; + case PassBy::MutableBox: { + TODO(loc, "HLFIR PassBy::MutableBox"); + } break; + } + } + // Prepare lowered arguments according to the interface + // and map the lowered values to the dummy + // arguments. + fir::ExtendedValue result = Fortran::lower::genCallOpAndResult( + loc, getConverter(), getSymMap(), getStmtCtx(), caller, callSiteType, + resultType); + mlir::Value resultFirBase = fir::getBase(result); + + /// Clean-up associations and copy-in. + for (auto associate : exprAssociations) + builder.create(loc, associate); + if (!resultFirBase) + return llvm::None; // subroutine call. + if (fir::isa_trivial(resultFirBase.getType())) + return hlfir::EntityWithAttributes{resultFirBase}; + return hlfir::genDeclare(loc, builder, result, "tmp.funcresult", + fir::FortranVariableFlagsAttr{}); + // TODO: "move" non pointer results into hlfir.expr. + } + +private: + mlir::Location getLoc() const { return loc; } + Fortran::lower::AbstractConverter &getConverter() { return converter; } + fir::FirOpBuilder &getBuilder() { return converter.getFirOpBuilder(); } + Fortran::lower::SymMap &getSymMap() { return symMap; } + Fortran::lower::StatementContext &getStmtCtx() { return stmtCtx; } + + Fortran::lower::AbstractConverter &converter; + Fortran::lower::SymMap &symMap; + Fortran::lower::StatementContext &stmtCtx; + mlir::Location loc; +}; +} // namespace + +llvm::Optional Fortran::lower::convertCallToHLFIR( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const evaluate::ProcedureRef &procRef, + llvm::Optional resultType, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + return CallBuilder(loc, converter, symMap, stmtCtx).gen(procRef, resultType); +} 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 @@ -13,7 +13,10 @@ #include "flang/Lower/ConvertExprToHLFIR.h" #include "flang/Evaluate/shape.h" #include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/CallInterface.h" +#include "flang/Lower/ConvertCall.h" #include "flang/Lower/ConvertConstant.h" +#include "flang/Lower/ConvertType.h" #include "flang/Lower/StatementContext.h" #include "flang/Lower/SymbolMap.h" #include "flang/Optimizer/Builder/Todo.h" @@ -281,7 +284,12 @@ template hlfir::EntityWithAttributes gen(const Fortran::evaluate::FunctionRef &expr) { - TODO(getLoc(), "lowering funcRef to HLFIR"); + mlir::Type resType = + Fortran::lower::TypeBuilder::genType(getConverter(), expr); + return Fortran::lower::convertCallToHLFIR(getLoc(), getConverter(), expr, + resType, getSymMap(), + getStmtCtx()) + .value(); } template diff --git a/flang/lib/Optimizer/Builder/HLFIRTools.cpp b/flang/lib/Optimizer/Builder/HLFIRTools.cpp --- a/flang/lib/Optimizer/Builder/HLFIRTools.cpp +++ b/flang/lib/Optimizer/Builder/HLFIRTools.cpp @@ -159,16 +159,78 @@ return mlir::cast(declareOp.getOperation()); } -/// If the entity is a variable, load its value (dereference pointers and -/// allocatables if needed). Do nothing if the entity os already a variable or -/// if it is not a scalar entity of numerical or logical type. +hlfir::AssociateOp hlfir::genAssociateExpr(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity value, + mlir::Type variableType, + llvm::StringRef name) { + assert(value.isValue() && "must not be a variable"); + mlir::Value shape{}; + if (value.isArray()) + TODO(loc, "associating array expressions"); + + mlir::Value source = value; + /// Lowered scalar expression values for numerical and logical may have a + /// different type than what is required for the type in memory (logical + /// expressions are typically manipulated as i1, but needs to be stored + /// according to the fir.logical so that the storage size is correct). + /// Character length mismatch are ignored (it is ok for one to be dynamic and + /// the other static). + mlir::Type varEleTy = getFortranElementType(variableType); + mlir::Type valueEleTy = getFortranElementType(value.getType()); + if (varEleTy != valueEleTy && !(valueEleTy.isa() && + varEleTy.isa())) { + assert(value.isScalar() && fir::isa_trivial(value.getType())); + source = builder.createConvert(loc, fir::unwrapPassByRefType(variableType), + value); + } + llvm::SmallVector lenParams; + genLengthParameters(loc, builder, value, lenParams); + return builder.create(loc, source, name, shape, lenParams, + fir::FortranVariableFlagsAttr{}); +} + +mlir::Value hlfir::genVariableRawAddress(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity var) { + assert(var.isVariable() && "only address of variables can be taken"); + mlir::Value baseAddr = var.getFirBase(); + if (var.isMutableBox()) + baseAddr = builder.create(loc, baseAddr); + // Get raw address. + if (baseAddr.getType().isa()) { + auto addrType = + fir::ReferenceType::get(fir::unwrapPassByRefType(baseAddr.getType())); + baseAddr = builder.create(loc, addrType, baseAddr); + } + return baseAddr; +} + +mlir::Value hlfir::genVariableBoxChar(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity var) { + assert(var.isVariable() && "only address of variables can be taken"); + if (var.getType().isa()) + return var; + mlir::Value addr = genVariableRawAddress(loc, builder, var); + llvm::SmallVector lengths; + genLengthParameters(loc, builder, var, lengths); + assert(lengths.size() == 1); + auto charType = var.getFortranElementType().cast(); + auto boxCharType = + fir::BoxCharType::get(builder.getContext(), charType.getFKind()); + auto scalarAddr = + builder.createConvert(loc, fir::ReferenceType::get(charType), addr); + return builder.create(loc, boxCharType, scalarAddr, + lengths[0]); +} + hlfir::Entity hlfir::loadTrivialScalar(mlir::Location loc, fir::FirOpBuilder &builder, Entity entity) { if (entity.isVariable() && entity.isScalar() && fir::isa_trivial(entity.getFortranElementType())) { - if (entity.isMutableBox()) - TODO(loc, "load pointer/allocatable scalar"); + entity = derefPointersAndAllocatables(loc, builder, entity); return Entity{builder.create(loc, entity)}; } return entity; @@ -247,3 +309,11 @@ return {fir::getBase(exv), variableInterface.getShape()}; return {fir::getBase(exv), builder.createShape(loc, exv)}; } + +hlfir::Entity hlfir::derefPointersAndAllocatables(mlir::Location loc, + fir::FirOpBuilder &builder, + Entity entity) { + if (entity.isMutableBox()) + return hlfir::Entity{builder.create(loc, entity).getResult()}; + return entity; +} diff --git a/flang/test/Lower/HLFIR/calls-f77.f90 b/flang/test/Lower/HLFIR/calls-f77.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/HLFIR/calls-f77.f90 @@ -0,0 +1,188 @@ +! Test lowering of F77 calls to HLFIR +! RUN: bbc -emit-fir -hlfir -o - %s 2>&1 | FileCheck %s + +! ----------------------------------------------------------------------------- +! Test lowering of F77 procedure reference arguments +! ----------------------------------------------------------------------------- + +subroutine call_no_arg() + call void() +end subroutine +! CHECK-LABEL: func.func @_QPcall_no_arg() { +! CHECK-NEXT: fir.call @_QPvoid() fastmath : () -> () +! CHECK-NEXT: return + +subroutine call_int_arg_var(n) + integer :: n + call take_i4(n) +end subroutine +! CHECK-LABEL: func.func @_QPcall_int_arg_var( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFcall_int_arg_varEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: fir.call @_QPtake_i4(%[[VAL_1]]#1) fastmath : (!fir.ref) -> () + +subroutine call_int_arg_expr() + call take_i4(42) +end subroutine +! CHECK-LABEL: func.func @_QPcall_int_arg_expr() { +! CHECK: %[[VAL_0:.*]] = arith.constant 42 : i32 +! CHECK: %[[VAL_1:.*]]:3 = hlfir.associate %[[VAL_0]] {uniq_name = "adapt.valuebyref"} : (i32) -> (!fir.ref, !fir.ref, i1) +! CHECK: fir.call @_QPtake_i4(%[[VAL_1]]#0) fastmath : (!fir.ref) -> () +! CHECK: hlfir.end_associate %[[VAL_1]]#1, %[[VAL_1]]#2 : !fir.ref, i1 + +subroutine call_real_arg_expr() + call take_r4(0.42) +end subroutine +! CHECK-LABEL: func.func @_QPcall_real_arg_expr() { +! CHECK: %[[VAL_0:.*]] = arith.constant 4.200000e-01 : f32 +! CHECK: %[[VAL_1:.*]]:3 = hlfir.associate %[[VAL_0]] {uniq_name = "adapt.valuebyref"} : (f32) -> (!fir.ref, !fir.ref, i1) +! CHECK: fir.call @_QPtake_r4(%[[VAL_1]]#0) fastmath : (!fir.ref) -> () +! CHECK: hlfir.end_associate %[[VAL_1]]#1, %[[VAL_1]]#2 : !fir.ref, i1 + +subroutine call_real_arg_var(x) + real :: x + call take_r4(x) +end subroutine +! CHECK-LABEL: func.func @_QPcall_real_arg_var( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFcall_real_arg_varEx"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: fir.call @_QPtake_r4(%[[VAL_1]]#1) fastmath : (!fir.ref) -> () + +subroutine call_logical_arg_var(x) + logical :: x + call take_l4(x) +end subroutine +! CHECK-LABEL: func.func @_QPcall_logical_arg_var( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref> +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFcall_logical_arg_varEx"} : (!fir.ref>) -> (!fir.ref>, !fir.ref>) +! CHECK: fir.call @_QPtake_l4(%[[VAL_1]]#1) fastmath : (!fir.ref>) -> () + +subroutine call_logical_arg_expr() + call take_l4(.true.) +end subroutine +! CHECK-LABEL: func.func @_QPcall_logical_arg_expr() { +! CHECK: %[[VAL_0:.*]] = arith.constant true +! CHECK: %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (i1) -> !fir.logical<4> +! CHECK: %[[VAL_2:.*]]:3 = hlfir.associate %[[VAL_1]] {uniq_name = "adapt.valuebyref"} : (!fir.logical<4>) -> (!fir.ref>, !fir.ref>, i1) +! CHECK: fir.call @_QPtake_l4(%[[VAL_2]]#0) fastmath : (!fir.ref>) -> () +! CHECK: hlfir.end_associate %[[VAL_2]]#1, %[[VAL_2]]#2 : !fir.ref>, i1 + +subroutine call_logical_arg_expr_2() + call take_l8(.true._8) +end subroutine +! CHECK-LABEL: func.func @_QPcall_logical_arg_expr_2() { +! CHECK: %[[VAL_0:.*]] = arith.constant true +! CHECK: %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (i1) -> !fir.logical<8> +! CHECK: %[[VAL_2:.*]]:3 = hlfir.associate %[[VAL_1]] {uniq_name = "adapt.valuebyref"} : (!fir.logical<8>) -> (!fir.ref>, !fir.ref>, i1) +! CHECK: fir.call @_QPtake_l8(%[[VAL_2]]#0) fastmath : (!fir.ref>) -> () +! CHECK: hlfir.end_associate %[[VAL_2]]#1, %[[VAL_2]]#2 : !fir.ref>, i1 + +subroutine call_char_arg_var(x) + character(*) :: x + call take_c(x) +end subroutine +! CHECK-LABEL: func.func @_QPcall_char_arg_var( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxchar<1> +! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1 {uniq_name = "_QFcall_char_arg_varEx"} : (!fir.ref>, index) -> (!fir.boxchar<1>, !fir.ref>) +! CHECK: fir.call @_QPtake_c(%[[VAL_2]]#0) fastmath : (!fir.boxchar<1>) -> () + +subroutine call_char_arg_var_expr(x) + character(*) :: x + call take_c(x//x) +end subroutine +! CHECK-LABEL: func.func @_QPcall_char_arg_var_expr( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxchar<1> +! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1 {uniq_name = "_QFcall_char_arg_var_exprEx"} : (!fir.ref>, index) -> (!fir.boxchar<1>, !fir.ref>) +! CHECK: %[[VAL_3:.*]] = arith.addi %[[VAL_1]]#1, %[[VAL_1]]#1 : index +! CHECK: %[[VAL_4:.*]] = hlfir.concat %[[VAL_2]]#0, %[[VAL_2]]#0 len %[[VAL_3]] : (!fir.boxchar<1>, !fir.boxchar<1>, index) -> !hlfir.expr> +! CHECK: %[[VAL_5:.*]]:3 = hlfir.associate %[[VAL_4]] typeparams %[[VAL_3]] {uniq_name = "adapt.valuebyref"} : (!hlfir.expr>, index) -> (!fir.boxchar<1>, !fir.ref>, i1) +! CHECK: fir.call @_QPtake_c(%[[VAL_5]]#0) fastmath : (!fir.boxchar<1>) -> () +! CHECK: hlfir.end_associate %[[VAL_5]]#1, %[[VAL_5]]#2 : !fir.ref>, i1 + +subroutine call_arg_array_var(n) + integer :: n(10, 20) + call take_arr(n) +end subroutine +! CHECK-LABEL: func.func @_QPcall_arg_array_var( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref> +! CHECK: %[[VAL_1:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_2:.*]] = arith.constant 20 : index +! CHECK: %[[VAL_3:.*]] = fir.shape %[[VAL_1]], %[[VAL_2]] : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_0]](%[[VAL_3]]) {uniq_name = "_QFcall_arg_array_varEn"} : (!fir.ref>, !fir.shape<2>) -> (!fir.ref>, !fir.ref>) +! CHECK: fir.call @_QPtake_arr(%[[VAL_4]]#1) fastmath : (!fir.ref>) -> () + +subroutine call_arg_array_2(n) + integer, contiguous, optional :: n(:, :) + call take_arr_2(n) +end subroutine +! CHECK-LABEL: func.func @_QPcall_arg_array_2( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFcall_arg_array_2En"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]]#1 : (!fir.box>) -> !fir.ref> +! CHECK: fir.call @_QPtake_arr_2(%[[VAL_2]]) fastmath : (!fir.ref>) -> () + +! ----------------------------------------------------------------------------- +! Test lowering of function results +! ----------------------------------------------------------------------------- + +subroutine return_integer() + integer :: ifoo + print *, ifoo() +end subroutine +! CHECK-LABEL: func.func @_QPreturn_integer( +! CHECK: fir.call @_QPifoo() fastmath : () -> i32 + + +subroutine return_logical() + logical :: lfoo + print *, lfoo() +end subroutine +! CHECK-LABEL: func.func @_QPreturn_logical( +! CHECK: fir.call @_QPlfoo() fastmath : () -> !fir.logical<4> + +subroutine return_complex() + complex :: cplxfoo + print *, cplxfoo() +end subroutine +! CHECK-LABEL: func.func @_QPreturn_complex( +! CHECK: fir.call @_QPcplxfoo() fastmath : () -> !fir.complex<4> + +subroutine return_char(n) + integer(8) :: n + character(n) :: c2foo + print *, c2foo() +end subroutine +! CHECK-LABEL: func.func @_QPreturn_char( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}n +! CHECK: %[[VAL_2:.*]] = arith.constant -1 : i32 +! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_1]]#1 : !fir.ref +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index +! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_10:.*]] = arith.cmpi sgt, %[[VAL_8]], %[[VAL_9]] : index +! CHECK: %[[VAL_11:.*]] = arith.select %[[VAL_10]], %[[VAL_8]], %[[VAL_9]] : index +! CHECK: %[[VAL_13:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_11]] : index) {bindc_name = ".result"} +! CHECK: %[[VAL_14:.*]] = fir.call @_QPc2foo(%[[VAL_13]], %[[VAL_11]]) fastmath : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_15:.*]]:2 = hlfir.declare %[[VAL_13]] typeparams %[[VAL_11]] {uniq_name = "tmp.funcresult"} : (!fir.ref>, index) -> (!fir.boxchar<1>, !fir.ref>) + +! ----------------------------------------------------------------------------- +! Test calls with alternate returns +! ----------------------------------------------------------------------------- + +! CHECK-LABEL: func.func @_QPalternate_return_call( +subroutine alternate_return_call(n1, n2, k) + integer :: n1, n2, k + ! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}k + ! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare {{.*}}n1 + ! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare {{.*}}n2 + ! CHECK: %[[selector:.*]] = fir.call @_QPalternate_return(%[[VAL_4]]#1, %[[VAL_5]]#1) fastmath : (!fir.ref, !fir.ref) -> index + ! CHECK-NEXT: fir.select %[[selector]] : index [1, ^[[block1:bb[0-9]+]], 2, ^[[block2:bb[0-9]+]], unit, ^[[blockunit:bb[0-9]+]] + call alternate_return(n1, *5, n2, *7) + ! CHECK: ^[[blockunit]]: // pred: ^bb0 + k = 0; return; + ! CHECK: ^[[block1]]: // pred: ^bb0 +5 k = -1; return; + ! CHECK: ^[[block2]]: // pred: ^bb0 +7 k = 1; return +end