| //===-- CallInterface.cpp -- Procedure call interface ---------------------===// |
| // |
| // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
| // See https://llvm.org/LICENSE.txt for license information. |
| // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
| // |
| //===----------------------------------------------------------------------===// |
| |
| #include "flang/Lower/CallInterface.h" |
| #include "flang/Common/Fortran.h" |
| #include "flang/Evaluate/fold.h" |
| #include "flang/Lower/Bridge.h" |
| #include "flang/Lower/Mangler.h" |
| #include "flang/Lower/PFTBuilder.h" |
| #include "flang/Lower/StatementContext.h" |
| #include "flang/Lower/Support/Utils.h" |
| #include "flang/Optimizer/Builder/Character.h" |
| #include "flang/Optimizer/Builder/FIRBuilder.h" |
| #include "flang/Optimizer/Builder/Todo.h" |
| #include "flang/Optimizer/Dialect/FIRDialect.h" |
| #include "flang/Optimizer/Dialect/FIROpsSupport.h" |
| #include "flang/Optimizer/Support/InternalNames.h" |
| #include "flang/Optimizer/Support/Utils.h" |
| #include "flang/Semantics/symbol.h" |
| #include "flang/Semantics/tools.h" |
| #include <optional> |
| |
| static mlir::FunctionType |
| getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc, |
| Fortran::lower::AbstractConverter &converter); |
| |
| mlir::Type Fortran::lower::getUntypedBoxProcType(mlir::MLIRContext *context) { |
| llvm::SmallVector<mlir::Type> resultTys; |
| llvm::SmallVector<mlir::Type> inputTys; |
| auto untypedFunc = mlir::FunctionType::get(context, inputTys, resultTys); |
| return fir::BoxProcType::get(context, untypedFunc); |
| } |
| |
| /// Return the type of a dummy procedure given its characteristic (if it has |
| /// one). |
| static mlir::Type getProcedureDesignatorType( |
| const Fortran::evaluate::characteristics::Procedure *, |
| Fortran::lower::AbstractConverter &converter) { |
| // TODO: Get actual function type of the dummy procedure, at least when an |
| // interface is given. The result type should be available even if the arity |
| // and type of the arguments is not. |
| // In general, that is a nice to have but we cannot guarantee to find the |
| // function type that will match the one of the calls, we may not even know |
| // how many arguments the dummy procedure accepts (e.g. if a procedure |
| // pointer is only transiting through the current procedure without being |
| // called), so a function type cast must always be inserted. |
| return Fortran::lower::getUntypedBoxProcType(&converter.getMLIRContext()); |
| } |
| |
| //===----------------------------------------------------------------------===// |
| // Caller side interface implementation |
| //===----------------------------------------------------------------------===// |
| |
| bool Fortran::lower::CallerInterface::hasAlternateReturns() const { |
| return procRef.hasAlternateReturns(); |
| } |
| |
| /// Return the binding label (from BIND(C...)) or the mangled name of the |
| /// symbol. |
| static std::string |
| getProcMangledName(const Fortran::evaluate::ProcedureDesignator &proc, |
| Fortran::lower::AbstractConverter &converter) { |
| if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol()) |
| return converter.mangleName(symbol->GetUltimate()); |
| assert(proc.GetSpecificIntrinsic() && |
| "expected intrinsic procedure in designator"); |
| return proc.GetName(); |
| } |
| |
| std::string Fortran::lower::CallerInterface::getMangledName() const { |
| return getProcMangledName(procRef.proc(), converter); |
| } |
| |
| const Fortran::semantics::Symbol * |
| Fortran::lower::CallerInterface::getProcedureSymbol() const { |
| return procRef.proc().GetSymbol(); |
| } |
| |
| bool Fortran::lower::CallerInterface::isIndirectCall() const { |
| if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol()) |
| return Fortran::semantics::IsPointer(*symbol) || |
| Fortran::semantics::IsDummy(*symbol); |
| return false; |
| } |
| |
| bool Fortran::lower::CallerInterface::requireDispatchCall() const { |
| // Procedure pointer component reference do not require dispatch, but |
| // have PASS/NOPASS argument. |
| if (const Fortran::semantics::Symbol *sym = procRef.proc().GetSymbol()) |
| if (Fortran::semantics::IsPointer(*sym)) |
| return false; |
| // calls with NOPASS attribute still have their component so check if it is |
| // polymorphic. |
| if (const Fortran::evaluate::Component *component = |
| procRef.proc().GetComponent()) { |
| if (Fortran::semantics::IsPolymorphic(component->base().GetLastSymbol())) |
| return true; |
| } |
| // calls with PASS attribute have the passed-object already set in its |
| // arguments. Just check if their is one. |
| std::optional<unsigned> passArg = getPassArgIndex(); |
| if (passArg) |
| return true; |
| return false; |
| } |
| |
| std::optional<unsigned> |
| Fortran::lower::CallerInterface::getPassArgIndex() const { |
| unsigned passArgIdx = 0; |
| std::optional<unsigned> passArg; |
| for (const auto &arg : getCallDescription().arguments()) { |
| if (arg && arg->isPassedObject()) { |
| passArg = passArgIdx; |
| break; |
| } |
| ++passArgIdx; |
| } |
| if (!passArg) |
| return passArg; |
| // Take into account result inserted as arguments. |
| if (std::optional<Fortran::lower::CallInterface< |
| Fortran::lower::CallerInterface>::PassedEntity> |
| resultArg = getPassedResult()) { |
| if (resultArg->passBy == PassEntityBy::AddressAndLength) |
| passArg = *passArg + 2; |
| else if (resultArg->passBy == PassEntityBy::BaseAddress) |
| passArg = *passArg + 1; |
| } |
| return passArg; |
| } |
| |
| mlir::Value Fortran::lower::CallerInterface::getIfPassedArg() const { |
| if (std::optional<unsigned> passArg = getPassArgIndex()) { |
| assert(actualInputs.size() > *passArg && actualInputs[*passArg] && |
| "passed arg was not set yet"); |
| return actualInputs[*passArg]; |
| } |
| return {}; |
| } |
| |
| const Fortran::evaluate::ProcedureDesignator * |
| Fortran::lower::CallerInterface::getIfIndirectCall() const { |
| if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol()) |
| if (Fortran::semantics::IsPointer(*symbol) || |
| Fortran::semantics::IsDummy(*symbol)) |
| return &procRef.proc(); |
| return nullptr; |
| } |
| |
| static mlir::Location |
| getProcedureDesignatorLoc(const Fortran::evaluate::ProcedureDesignator &proc, |
| Fortran::lower::AbstractConverter &converter) { |
| // Note: If the callee is defined in the same file but after the current |
| // unit we cannot get its location here and the funcOp is created at the |
| // wrong location (i.e, the caller location). |
| // To prevent this, it is up to the bridge to first declare all functions |
| // defined in the translation unit before lowering any calls or procedure |
| // designator references. |
| if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol()) |
| return converter.genLocation(symbol->name()); |
| // Use current location for intrinsics. |
| return converter.getCurrentLocation(); |
| } |
| |
| mlir::Location Fortran::lower::CallerInterface::getCalleeLocation() const { |
| return getProcedureDesignatorLoc(procRef.proc(), converter); |
| } |
| |
| // Get dummy argument characteristic for a procedure with implicit interface |
| // from the actual argument characteristic. The actual argument may not be a F77 |
| // entity. The attribute must be dropped and the shape, if any, must be made |
| // explicit. |
| static Fortran::evaluate::characteristics::DummyDataObject |
| asImplicitArg(Fortran::evaluate::characteristics::DummyDataObject &&dummy) { |
| Fortran::evaluate::Shape shape = |
| dummy.type.attrs().none() ? dummy.type.shape() |
| : Fortran::evaluate::Shape(dummy.type.Rank()); |
| return Fortran::evaluate::characteristics::DummyDataObject( |
| Fortran::evaluate::characteristics::TypeAndShape(dummy.type.type(), |
| std::move(shape))); |
| } |
| |
| static Fortran::evaluate::characteristics::DummyArgument |
| asImplicitArg(Fortran::evaluate::characteristics::DummyArgument &&dummy) { |
| return std::visit( |
| Fortran::common::visitors{ |
| [&](Fortran::evaluate::characteristics::DummyDataObject &obj) { |
| return Fortran::evaluate::characteristics::DummyArgument( |
| std::move(dummy.name), asImplicitArg(std::move(obj))); |
| }, |
| [&](Fortran::evaluate::characteristics::DummyProcedure &proc) { |
| return Fortran::evaluate::characteristics::DummyArgument( |
| std::move(dummy.name), std::move(proc)); |
| }, |
| [](Fortran::evaluate::characteristics::AlternateReturn &x) { |
| return Fortran::evaluate::characteristics::DummyArgument( |
| std::move(x)); |
| }}, |
| dummy.u); |
| } |
| |
| static bool isExternalDefinedInSameCompilationUnit( |
| const Fortran::evaluate::ProcedureDesignator &proc) { |
| if (const auto *symbol{proc.GetSymbol()}) |
| return symbol->has<Fortran::semantics::SubprogramDetails>() && |
| symbol->owner().IsGlobal(); |
| return false; |
| } |
| |
| Fortran::evaluate::characteristics::Procedure |
| Fortran::lower::CallerInterface::characterize() const { |
| Fortran::evaluate::FoldingContext &foldingContext = |
| converter.getFoldingContext(); |
| std::optional<Fortran::evaluate::characteristics::Procedure> characteristic = |
| Fortran::evaluate::characteristics::Procedure::Characterize( |
| procRef.proc(), foldingContext, /*emitError=*/false); |
| assert(characteristic && "Failed to get characteristic from procRef"); |
| // The characteristic may not contain the argument characteristic if the |
| // ProcedureDesignator has no interface, or may mismatch in case of implicit |
| // interface. |
| if (!characteristic->HasExplicitInterface() || |
| (converter.getLoweringOptions().getLowerToHighLevelFIR() && |
| isExternalDefinedInSameCompilationUnit(procRef.proc()) && |
| characteristic->CanBeCalledViaImplicitInterface())) { |
| // In HLFIR lowering, calls to subprogram with implicit interfaces are |
| // always prepared according to the actual arguments. This is to support |
| // cases where the implicit interfaces are "abused" in old and not so old |
| // Fortran code (e.g, passing REAL(8) to CHARACTER(8), passing object |
| // pointers to procedure dummies, passing regular procedure dummies to |
| // character procedure dummies, omitted arguments....). |
| // In all those case, if the subprogram definition is in the same |
| // compilation unit, the "characteristic" from Characterize will be the one |
| // from the definition, in case of "abuses" (for which semantics raise a |
| // warning), lowering will be placed in a difficult position if it is given |
| // the dummy characteristic from the definition and an actual that has |
| // seemingly nothing to do with it: it would need to battle to anticipate |
| // and handle these mismatches (e.g., be able to prepare a fir.boxchar<> |
| // from a fir.real<> and so one). This was the approach of the lowering to |
| // FIR, and usually lead to compiler bug every time a new "abuse" was met in |
| // the wild. |
| // Instead, in HLFIR, the dummy characteristic is always computed from the |
| // actual for subprogram with implicit interfaces, and in case of call site |
| // vs fun.func MLIR function type signature mismatch, a function cast is |
| // done before placing the call. This is a hammer that should cover all |
| // cases and behave like existing compiler that "do not see" the definition |
| // when placing the call. |
| characteristic->dummyArguments.clear(); |
| for (const std::optional<Fortran::evaluate::ActualArgument> &arg : |
| procRef.arguments()) { |
| // "arg" may be null if this is a call with missing arguments compared |
| // to the subprogram definition. Do not compute any characteristic |
| // in this case. |
| if (arg.has_value()) { |
| if (arg.value().isAlternateReturn()) { |
| characteristic->dummyArguments.emplace_back( |
| Fortran::evaluate::characteristics::AlternateReturn{}); |
| } else { |
| // Argument cannot be optional with implicit interface |
| const Fortran::lower::SomeExpr *expr = arg.value().UnwrapExpr(); |
| assert(expr && "argument in call with implicit interface cannot be " |
| "assumed type"); |
| std::optional<Fortran::evaluate::characteristics::DummyArgument> |
| argCharacteristic = |
| Fortran::evaluate::characteristics::DummyArgument::FromActual( |
| "actual", *expr, foldingContext, |
| /*forImplicitInterface=*/true); |
| assert(argCharacteristic && |
| "failed to characterize argument in implicit call"); |
| characteristic->dummyArguments.emplace_back( |
| asImplicitArg(std::move(*argCharacteristic))); |
| } |
| } |
| } |
| } |
| return *characteristic; |
| } |
| |
| void Fortran::lower::CallerInterface::placeInput( |
| const PassedEntity &passedEntity, mlir::Value arg) { |
| assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument && |
| passedEntity.firArgument >= 0 && |
| passedEntity.passBy != CallInterface::PassEntityBy::AddressAndLength && |
| "bad arg position"); |
| actualInputs[passedEntity.firArgument] = arg; |
| } |
| |
| void Fortran::lower::CallerInterface::placeAddressAndLengthInput( |
| const PassedEntity &passedEntity, mlir::Value addr, mlir::Value len) { |
| assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument && |
| static_cast<int>(actualInputs.size()) > passedEntity.firLength && |
| passedEntity.firArgument >= 0 && passedEntity.firLength >= 0 && |
| passedEntity.passBy == CallInterface::PassEntityBy::AddressAndLength && |
| "bad arg position"); |
| actualInputs[passedEntity.firArgument] = addr; |
| actualInputs[passedEntity.firLength] = len; |
| } |
| |
| bool Fortran::lower::CallerInterface::verifyActualInputs() const { |
| if (getNumFIRArguments() != actualInputs.size()) |
| return false; |
| for (mlir::Value arg : actualInputs) { |
| if (!arg) |
| return false; |
| } |
| return true; |
| } |
| |
| mlir::Value |
| Fortran::lower::CallerInterface::getInput(const PassedEntity &passedEntity) { |
| return actualInputs[passedEntity.firArgument]; |
| } |
| |
| static void walkLengths( |
| const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape, |
| const Fortran::lower::CallerInterface::ExprVisitor &visitor, |
| Fortran::lower::AbstractConverter &converter) { |
| Fortran::evaluate::DynamicType dynamicType = typeAndShape.type(); |
| // Visit length specification expressions that are explicit. |
| if (dynamicType.category() == Fortran::common::TypeCategory::Character) { |
| if (std::optional<Fortran::evaluate::ExtentExpr> length = |
| dynamicType.GetCharLength()) |
| visitor(toEvExpr(*length), /*assumedSize=*/false); |
| } else if (dynamicType.category() == Fortran::common::TypeCategory::Derived && |
| !dynamicType.IsUnlimitedPolymorphic()) { |
| const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec = |
| dynamicType.GetDerivedTypeSpec(); |
| if (Fortran::semantics::CountLenParameters(derivedTypeSpec) > 0) |
| TODO(converter.getCurrentLocation(), |
| "function result with derived type length parameters"); |
| } |
| } |
| |
| void Fortran::lower::CallerInterface::walkResultLengths( |
| const ExprVisitor &visitor) const { |
| assert(characteristic && "characteristic was not computed"); |
| const Fortran::evaluate::characteristics::FunctionResult &result = |
| characteristic->functionResult.value(); |
| const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape = |
| result.GetTypeAndShape(); |
| assert(typeAndShape && "no result type"); |
| return walkLengths(*typeAndShape, visitor, converter); |
| } |
| |
| void Fortran::lower::CallerInterface::walkDummyArgumentLengths( |
| const PassedEntity &passedEntity, const ExprVisitor &visitor) const { |
| if (!passedEntity.characteristics) |
| return; |
| if (const auto *dummy = |
| std::get_if<Fortran::evaluate::characteristics::DummyDataObject>( |
| &passedEntity.characteristics->u)) |
| walkLengths(dummy->type, visitor, converter); |
| } |
| |
| // Compute extent expr from shapeSpec of an explicit shape. |
| static Fortran::evaluate::ExtentExpr |
| getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) { |
| if (shapeSpec.ubound().isStar()) |
| // F'2023 18.5.3 point 5. |
| return Fortran::evaluate::ExtentExpr{-1}; |
| const auto &ubound = shapeSpec.ubound().GetExplicit(); |
| const auto &lbound = shapeSpec.lbound().GetExplicit(); |
| assert(lbound && ubound && "shape must be explicit"); |
| return Fortran::common::Clone(*ubound) - Fortran::common::Clone(*lbound) + |
| Fortran::evaluate::ExtentExpr{1}; |
| } |
| |
| static void |
| walkExtents(const Fortran::semantics::Symbol &symbol, |
| const Fortran::lower::CallerInterface::ExprVisitor &visitor) { |
| if (const auto *objectDetails = |
| symbol.detailsIf<Fortran::semantics::ObjectEntityDetails>()) |
| if (objectDetails->shape().IsExplicitShape() || |
| Fortran::semantics::IsAssumedSizeArray(symbol)) |
| for (const Fortran::semantics::ShapeSpec &shapeSpec : |
| objectDetails->shape()) |
| visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)), |
| /*assumedSize=*/shapeSpec.ubound().isStar()); |
| } |
| |
| void Fortran::lower::CallerInterface::walkResultExtents( |
| const ExprVisitor &visitor) const { |
| // Walk directly the result symbol shape (the characteristic shape may contain |
| // descriptor inquiries to it that would fail to lower on the caller side). |
| const Fortran::semantics::SubprogramDetails *interfaceDetails = |
| getInterfaceDetails(); |
| if (interfaceDetails) { |
| walkExtents(interfaceDetails->result(), visitor); |
| } else { |
| if (procRef.Rank() != 0) |
| fir::emitFatalError( |
| converter.getCurrentLocation(), |
| "only scalar functions may not have an interface symbol"); |
| } |
| } |
| |
| void Fortran::lower::CallerInterface::walkDummyArgumentExtents( |
| const PassedEntity &passedEntity, const ExprVisitor &visitor) const { |
| const Fortran::semantics::SubprogramDetails *interfaceDetails = |
| getInterfaceDetails(); |
| if (!interfaceDetails) |
| return; |
| const Fortran::semantics::Symbol *dummy = getDummySymbol(passedEntity); |
| assert(dummy && "dummy symbol was not set"); |
| walkExtents(*dummy, visitor); |
| } |
| |
| bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForResult() const { |
| assert(characteristic && "characteristic was not computed"); |
| const std::optional<Fortran::evaluate::characteristics::FunctionResult> |
| &result = characteristic->functionResult; |
| if (!result || result->CanBeReturnedViaImplicitInterface() || |
| !getInterfaceDetails() || result->IsProcedurePointer()) |
| return false; |
| bool allResultSpecExprConstant = true; |
| auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) { |
| allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e); |
| }; |
| walkResultLengths(visitor); |
| walkResultExtents(visitor); |
| return !allResultSpecExprConstant; |
| } |
| |
| bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForDummyArgument( |
| const PassedEntity &arg) const { |
| bool allResultSpecExprConstant = true; |
| auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) { |
| allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e); |
| }; |
| walkDummyArgumentLengths(arg, visitor); |
| walkDummyArgumentExtents(arg, visitor); |
| return !allResultSpecExprConstant; |
| } |
| |
| mlir::Value Fortran::lower::CallerInterface::getArgumentValue( |
| const semantics::Symbol &sym) const { |
| mlir::Location loc = converter.getCurrentLocation(); |
| const Fortran::semantics::SubprogramDetails *ifaceDetails = |
| getInterfaceDetails(); |
| if (!ifaceDetails) |
| fir::emitFatalError( |
| loc, "mapping actual and dummy arguments requires an interface"); |
| const std::vector<Fortran::semantics::Symbol *> &dummies = |
| ifaceDetails->dummyArgs(); |
| auto it = std::find(dummies.begin(), dummies.end(), &sym); |
| if (it == dummies.end()) |
| fir::emitFatalError(loc, "symbol is not a dummy in this call"); |
| FirValue mlirArgIndex = passedArguments[it - dummies.begin()].firArgument; |
| return actualInputs[mlirArgIndex]; |
| } |
| |
| const Fortran::semantics::Symbol * |
| Fortran::lower::CallerInterface::getDummySymbol( |
| const PassedEntity &passedEntity) const { |
| const Fortran::semantics::SubprogramDetails *ifaceDetails = |
| getInterfaceDetails(); |
| if (!ifaceDetails) |
| return nullptr; |
| std::size_t argPosition = 0; |
| for (const auto &arg : getPassedArguments()) { |
| if (&arg == &passedEntity) |
| break; |
| ++argPosition; |
| } |
| if (argPosition >= ifaceDetails->dummyArgs().size()) |
| return nullptr; |
| return ifaceDetails->dummyArgs()[argPosition]; |
| } |
| |
| mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const { |
| if (passedResult) |
| return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type); |
| assert(saveResult && !outputs.empty()); |
| return outputs[0].type; |
| } |
| |
| mlir::Type Fortran::lower::CallerInterface::getDummyArgumentType( |
| const PassedEntity &passedEntity) const { |
| return inputs[passedEntity.firArgument].type; |
| } |
| |
| const Fortran::semantics::Symbol & |
| Fortran::lower::CallerInterface::getResultSymbol() const { |
| mlir::Location loc = converter.getCurrentLocation(); |
| const Fortran::semantics::SubprogramDetails *ifaceDetails = |
| getInterfaceDetails(); |
| if (!ifaceDetails) |
| fir::emitFatalError( |
| loc, "mapping actual and dummy arguments requires an interface"); |
| return ifaceDetails->result(); |
| } |
| |
| const Fortran::semantics::SubprogramDetails * |
| Fortran::lower::CallerInterface::getInterfaceDetails() const { |
| if (const Fortran::semantics::Symbol *iface = |
| procRef.proc().GetInterfaceSymbol()) |
| return iface->GetUltimate() |
| .detailsIf<Fortran::semantics::SubprogramDetails>(); |
| return nullptr; |
| } |
| |
| //===----------------------------------------------------------------------===// |
| // Callee side interface implementation |
| //===----------------------------------------------------------------------===// |
| |
| bool Fortran::lower::CalleeInterface::hasAlternateReturns() const { |
| return !funit.isMainProgram() && |
| Fortran::semantics::HasAlternateReturns(funit.getSubprogramSymbol()); |
| } |
| |
| std::string Fortran::lower::CalleeInterface::getMangledName() const { |
| if (funit.isMainProgram()) |
| return fir::NameUniquer::doProgramEntry().str(); |
| return converter.mangleName(funit.getSubprogramSymbol()); |
| } |
| |
| const Fortran::semantics::Symbol * |
| Fortran::lower::CalleeInterface::getProcedureSymbol() const { |
| if (funit.isMainProgram()) |
| return funit.getMainProgramSymbol(); |
| return &funit.getSubprogramSymbol(); |
| } |
| |
| mlir::Location Fortran::lower::CalleeInterface::getCalleeLocation() const { |
| // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably |
| // should just stash the location in the funit regardless. |
| return converter.genLocation(funit.getStartingSourceLoc()); |
| } |
| |
| Fortran::evaluate::characteristics::Procedure |
| Fortran::lower::CalleeInterface::characterize() const { |
| Fortran::evaluate::FoldingContext &foldingContext = |
| converter.getFoldingContext(); |
| std::optional<Fortran::evaluate::characteristics::Procedure> characteristic = |
| Fortran::evaluate::characteristics::Procedure::Characterize( |
| funit.getSubprogramSymbol(), foldingContext); |
| assert(characteristic && "Fail to get characteristic from symbol"); |
| return *characteristic; |
| } |
| |
| bool Fortran::lower::CalleeInterface::isMainProgram() const { |
| return funit.isMainProgram(); |
| } |
| |
| mlir::func::FuncOp |
| Fortran::lower::CalleeInterface::addEntryBlockAndMapArguments() { |
| // Check for bugs in the front end. The front end must not present multiple |
| // definitions of the same procedure. |
| if (!func.getBlocks().empty()) |
| fir::emitFatalError(func.getLoc(), |
| "cannot process subprogram that was already processed"); |
| |
| // On the callee side, directly map the mlir::value argument of the function |
| // block to the Fortran symbols. |
| func.addEntryBlock(); |
| mapPassedEntities(); |
| return func; |
| } |
| |
| bool Fortran::lower::CalleeInterface::hasHostAssociated() const { |
| return funit.parentHasTupleHostAssoc(); |
| } |
| |
| mlir::Type Fortran::lower::CalleeInterface::getHostAssociatedTy() const { |
| assert(hasHostAssociated()); |
| return funit.parentHostAssoc().getArgumentType(converter); |
| } |
| |
| mlir::Value Fortran::lower::CalleeInterface::getHostAssociatedTuple() const { |
| assert(hasHostAssociated() || !funit.getHostAssoc().empty()); |
| return converter.hostAssocTupleValue(); |
| } |
| |
| //===----------------------------------------------------------------------===// |
| // CallInterface implementation: this part is common to both caller and callee. |
| //===----------------------------------------------------------------------===// |
| |
| static void addSymbolAttribute(mlir::func::FuncOp func, |
| const Fortran::semantics::Symbol &sym, |
| mlir::MLIRContext &mlirContext) { |
| const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); |
| // The link between an internal procedure and its host procedure is lost |
| // in FIR if the host is BIND(C) since the internal mangling will not |
| // allow retrieving the host bind(C) name, and therefore func.func symbol. |
| // Preserve it as an attribute so that this can be later retrieved. |
| if (Fortran::semantics::ClassifyProcedure(ultimate) == |
| Fortran::semantics::ProcedureDefinitionClass::Internal) { |
| if (ultimate.owner().kind() == |
| Fortran::semantics::Scope::Kind::Subprogram) { |
| if (const Fortran::semantics::Symbol *hostProcedure = |
| ultimate.owner().symbol()) { |
| std::string hostName = Fortran::lower::mangle::mangleName( |
| *hostProcedure, /*keepExternalInScope=*/true); |
| func->setAttr( |
| fir::getHostSymbolAttrName(), |
| mlir::SymbolRefAttr::get( |
| &mlirContext, mlir::StringAttr::get(&mlirContext, hostName))); |
| } |
| } else if (ultimate.owner().kind() == |
| Fortran::semantics::Scope::Kind::MainProgram) { |
| func->setAttr(fir::getHostSymbolAttrName(), |
| mlir::SymbolRefAttr::get( |
| &mlirContext, |
| mlir::StringAttr::get( |
| &mlirContext, fir::NameUniquer::doProgramEntry()))); |
| } |
| } |
| |
| // Only add this on bind(C) functions for which the symbol is not reflected in |
| // the current context. |
| if (!Fortran::semantics::IsBindCProcedure(sym)) |
| return; |
| std::string name = |
| Fortran::lower::mangle::mangleName(sym, /*keepExternalInScope=*/true); |
| func->setAttr(fir::getSymbolAttrName(), |
| mlir::StringAttr::get(&mlirContext, name)); |
| } |
| |
| static void |
| setCUDAAttributes(mlir::func::FuncOp func, |
| const Fortran::semantics::Symbol *sym, |
| std::optional<Fortran::evaluate::characteristics::Procedure> |
| characteristic) { |
| if (characteristic && characteristic->cudaSubprogramAttrs) { |
| func.getOperation()->setAttr( |
| fir::getCUDAAttrName(), |
| fir::getCUDAProcAttribute(func.getContext(), |
| *characteristic->cudaSubprogramAttrs)); |
| } |
| |
| if (sym) { |
| if (auto details = |
| sym->GetUltimate() |
| .detailsIf<Fortran::semantics::SubprogramDetails>()) { |
| mlir::Type i64Ty = mlir::IntegerType::get(func.getContext(), 64); |
| if (!details->cudaLaunchBounds().empty()) { |
| assert(details->cudaLaunchBounds().size() >= 2 && |
| "expect at least 2 values"); |
| auto maxTPBAttr = |
| mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[0]); |
| auto minBPMAttr = |
| mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[1]); |
| mlir::IntegerAttr ubAttr; |
| if (details->cudaLaunchBounds().size() > 2) |
| ubAttr = |
| mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[2]); |
| func.getOperation()->setAttr( |
| fir::getCUDALaunchBoundsAttrName(), |
| fir::CUDALaunchBoundsAttr::get(func.getContext(), maxTPBAttr, |
| minBPMAttr, ubAttr)); |
| } |
| |
| if (!details->cudaClusterDims().empty()) { |
| assert(details->cudaClusterDims().size() == 3 && "expect 3 values"); |
| auto xAttr = |
| mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[0]); |
| auto yAttr = |
| mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[1]); |
| auto zAttr = |
| mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[2]); |
| func.getOperation()->setAttr( |
| fir::getCUDAClusterDimsAttrName(), |
| fir::CUDAClusterDimsAttr::get(func.getContext(), xAttr, yAttr, |
| zAttr)); |
| } |
| } |
| } |
| } |
| |
| /// Declare drives the different actions to be performed while analyzing the |
| /// signature and building/finding the mlir::func::FuncOp. |
| template <typename T> |
| void Fortran::lower::CallInterface<T>::declare() { |
| if (!side().isMainProgram()) { |
| characteristic.emplace(side().characterize()); |
| bool isImplicit = characteristic->CanBeCalledViaImplicitInterface(); |
| determineInterface(isImplicit, *characteristic); |
| } |
| // No input/output for main program |
| |
| // Create / get funcOp for direct calls. For indirect calls (only meaningful |
| // on the caller side), no funcOp has to be created here. The mlir::Value |
| // holding the indirection is used when creating the fir::CallOp. |
| if (!side().isIndirectCall()) { |
| std::string name = side().getMangledName(); |
| mlir::ModuleOp module = converter.getModuleOp(); |
| mlir::SymbolTable *symbolTable = converter.getMLIRSymbolTable(); |
| func = fir::FirOpBuilder::getNamedFunction(module, symbolTable, name); |
| if (!func) { |
| mlir::Location loc = side().getCalleeLocation(); |
| mlir::FunctionType ty = genFunctionType(); |
| func = |
| fir::FirOpBuilder::createFunction(loc, module, name, ty, symbolTable); |
| if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol()) { |
| if (side().isMainProgram()) { |
| func->setAttr(fir::getSymbolAttrName(), |
| mlir::StringAttr::get(&converter.getMLIRContext(), |
| sym->name().ToString())); |
| } else { |
| addSymbolAttribute(func, *sym, converter.getMLIRContext()); |
| } |
| } |
| for (const auto &placeHolder : llvm::enumerate(inputs)) |
| if (!placeHolder.value().attributes.empty()) |
| func.setArgAttrs(placeHolder.index(), placeHolder.value().attributes); |
| |
| setCUDAAttributes(func, side().getProcedureSymbol(), characteristic); |
| } |
| } |
| } |
| |
| /// Once the signature has been analyzed and the mlir::func::FuncOp was |
| /// built/found, map the fir inputs to Fortran entities (the symbols or |
| /// expressions). |
| template <typename T> |
| void Fortran::lower::CallInterface<T>::mapPassedEntities() { |
| // map back fir inputs to passed entities |
| if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) { |
| assert(inputs.size() == func.front().getArguments().size() && |
| "function previously created with different number of arguments"); |
| for (auto [fst, snd] : llvm::zip(inputs, func.front().getArguments())) |
| mapBackInputToPassedEntity(fst, snd); |
| } else { |
| // On the caller side, map the index of the mlir argument position |
| // to Fortran ActualArguments. |
| int firPosition = 0; |
| for (const FirPlaceHolder &placeHolder : inputs) |
| mapBackInputToPassedEntity(placeHolder, firPosition++); |
| } |
| } |
| |
| template <typename T> |
| void Fortran::lower::CallInterface<T>::mapBackInputToPassedEntity( |
| const FirPlaceHolder &placeHolder, FirValue firValue) { |
| PassedEntity &passedEntity = |
| placeHolder.passedEntityPosition == FirPlaceHolder::resultEntityPosition |
| ? passedResult.value() |
| : passedArguments[placeHolder.passedEntityPosition]; |
| if (placeHolder.property == Property::CharLength) |
| passedEntity.firLength = firValue; |
| else |
| passedEntity.firArgument = firValue; |
| } |
| |
| /// Helpers to access ActualArgument/Symbols |
| static const Fortran::evaluate::ActualArguments & |
| getEntityContainer(const Fortran::evaluate::ProcedureRef &proc) { |
| return proc.arguments(); |
| } |
| |
| static const std::vector<Fortran::semantics::Symbol *> & |
| getEntityContainer(Fortran::lower::pft::FunctionLikeUnit &funit) { |
| return funit.getSubprogramSymbol() |
| .get<Fortran::semantics::SubprogramDetails>() |
| .dummyArgs(); |
| } |
| |
| static const Fortran::evaluate::ActualArgument *getDataObjectEntity( |
| const std::optional<Fortran::evaluate::ActualArgument> &arg) { |
| if (arg) |
| return &*arg; |
| return nullptr; |
| } |
| |
| static const Fortran::semantics::Symbol & |
| getDataObjectEntity(const Fortran::semantics::Symbol *arg) { |
| assert(arg && "expect symbol for data object entity"); |
| return *arg; |
| } |
| |
| static const Fortran::evaluate::ActualArgument * |
| getResultEntity(const Fortran::evaluate::ProcedureRef &) { |
| return nullptr; |
| } |
| |
| static const Fortran::semantics::Symbol & |
| getResultEntity(Fortran::lower::pft::FunctionLikeUnit &funit) { |
| return funit.getSubprogramSymbol() |
| .get<Fortran::semantics::SubprogramDetails>() |
| .result(); |
| } |
| |
| /// Bypass helpers to manipulate entities since they are not any symbol/actual |
| /// argument to associate. See SignatureBuilder below. |
| using FakeEntity = bool; |
| using FakeEntities = llvm::SmallVector<FakeEntity>; |
| static FakeEntities |
| getEntityContainer(const Fortran::evaluate::characteristics::Procedure &proc) { |
| FakeEntities enities(proc.dummyArguments.size()); |
| return enities; |
| } |
| static const FakeEntity &getDataObjectEntity(const FakeEntity &e) { return e; } |
| static FakeEntity |
| getResultEntity(const Fortran::evaluate::characteristics::Procedure &proc) { |
| return false; |
| } |
| |
| /// This is the actual part that defines the FIR interface based on the |
| /// characteristic. It directly mutates the CallInterface members. |
| template <typename T> |
| class Fortran::lower::CallInterfaceImpl { |
| using CallInterface = Fortran::lower::CallInterface<T>; |
| using PassEntityBy = typename CallInterface::PassEntityBy; |
| using PassedEntity = typename CallInterface::PassedEntity; |
| using FirValue = typename CallInterface::FirValue; |
| using FortranEntity = typename CallInterface::FortranEntity; |
| using FirPlaceHolder = typename CallInterface::FirPlaceHolder; |
| using Property = typename CallInterface::Property; |
| using TypeAndShape = Fortran::evaluate::characteristics::TypeAndShape; |
| using DummyCharacteristics = |
| Fortran::evaluate::characteristics::DummyArgument; |
| |
| public: |
| CallInterfaceImpl(CallInterface &i) |
| : interface(i), mlirContext{i.converter.getMLIRContext()} {} |
| |
| void buildImplicitInterface( |
| const Fortran::evaluate::characteristics::Procedure &procedure) { |
| // Handle result |
| if (const std::optional<Fortran::evaluate::characteristics::FunctionResult> |
| &result = procedure.functionResult) |
| handleImplicitResult(*result, procedure.IsBindC()); |
| else if (interface.side().hasAlternateReturns()) |
| addFirResult(mlir::IndexType::get(&mlirContext), |
| FirPlaceHolder::resultEntityPosition, Property::Value); |
| // Handle arguments |
| const auto &argumentEntities = |
| getEntityContainer(interface.side().getCallDescription()); |
| for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) { |
| const Fortran::evaluate::characteristics::DummyArgument |
| &argCharacteristics = std::get<0>(pair); |
| std::visit( |
| Fortran::common::visitors{ |
| [&](const auto &dummy) { |
| const auto &entity = getDataObjectEntity(std::get<1>(pair)); |
| handleImplicitDummy(&argCharacteristics, dummy, entity); |
| }, |
| [&](const Fortran::evaluate::characteristics::AlternateReturn &) { |
| // nothing to do |
| }, |
| }, |
| argCharacteristics.u); |
| } |
| } |
| |
| void buildExplicitInterface( |
| const Fortran::evaluate::characteristics::Procedure &procedure) { |
| bool isBindC = procedure.IsBindC(); |
| // Handle result |
| if (const std::optional<Fortran::evaluate::characteristics::FunctionResult> |
| &result = procedure.functionResult) { |
| if (result->CanBeReturnedViaImplicitInterface()) |
| handleImplicitResult(*result, isBindC); |
| else |
| handleExplicitResult(*result); |
| } else if (interface.side().hasAlternateReturns()) { |
| addFirResult(mlir::IndexType::get(&mlirContext), |
| FirPlaceHolder::resultEntityPosition, Property::Value); |
| } |
| // Handle arguments |
| const auto &argumentEntities = |
| getEntityContainer(interface.side().getCallDescription()); |
| for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) { |
| const Fortran::evaluate::characteristics::DummyArgument |
| &argCharacteristics = std::get<0>(pair); |
| std::visit( |
| Fortran::common::visitors{ |
| [&](const Fortran::evaluate::characteristics::DummyDataObject |
| &dummy) { |
| const auto &entity = getDataObjectEntity(std::get<1>(pair)); |
| if (!isBindC && dummy.CanBePassedViaImplicitInterface()) |
| handleImplicitDummy(&argCharacteristics, dummy, entity); |
| else |
| handleExplicitDummy(&argCharacteristics, dummy, entity, |
| isBindC); |
| }, |
| [&](const Fortran::evaluate::characteristics::DummyProcedure |
| &dummy) { |
| const auto &entity = getDataObjectEntity(std::get<1>(pair)); |
| handleImplicitDummy(&argCharacteristics, dummy, entity); |
| }, |
| [&](const Fortran::evaluate::characteristics::AlternateReturn &) { |
| // nothing to do |
| }, |
| }, |
| argCharacteristics.u); |
| } |
| } |
| |
| void appendHostAssocTupleArg(mlir::Type tupTy) { |
| mlir::MLIRContext *ctxt = tupTy.getContext(); |
| addFirOperand(tupTy, nextPassedArgPosition(), Property::BaseAddress, |
| {mlir::NamedAttribute{ |
| mlir::StringAttr::get(ctxt, fir::getHostAssocAttrName()), |
| mlir::UnitAttr::get(ctxt)}}); |
| interface.passedArguments.emplace_back( |
| PassedEntity{PassEntityBy::BaseAddress, std::nullopt, |
| interface.side().getHostAssociatedTuple(), emptyValue()}); |
| } |
| |
| static std::optional<Fortran::evaluate::DynamicType> getResultDynamicType( |
| const Fortran::evaluate::characteristics::Procedure &procedure) { |
| if (const std::optional<Fortran::evaluate::characteristics::FunctionResult> |
| &result = procedure.functionResult) |
| if (const auto *resultTypeAndShape = result->GetTypeAndShape()) |
| return resultTypeAndShape->type(); |
| return std::nullopt; |
| } |
| |
| static bool mustPassLengthWithDummyProcedure( |
| const Fortran::evaluate::characteristics::Procedure &procedure) { |
| // When passing a character function designator `bar` as dummy procedure to |
| // `foo` (e.g. `foo(bar)`), pass the result length of `bar` to `foo` so that |
| // `bar` can be called inside `foo` even if its length is assumed there. |
| // From an ABI perspective, the extra length argument must be handled |
| // exactly as if passing a character object. Using an argument of |
| // fir.boxchar type gives the expected behavior: after codegen, the |
| // fir.boxchar lengths are added after all the arguments as extra value |
| // arguments (the extra arguments order is the order of the fir.boxchar). |
| |
| // This ABI is compatible with ifort, nag, nvfortran, and xlf, but not |
| // gfortran. Gfortran does not pass the length and is therefore unable to |
| // handle later call to `bar` in `foo` where the length would be assumed. If |
| // the result is an array, nag and ifort and xlf still pass the length, but |
| // not nvfortran (and gfortran). It is not clear it is possible to call an |
| // array function with assumed length (f18 forbides defining such |
| // interfaces). Hence, passing the length is most likely useless, but stick |
| // with ifort/nag/xlf interface here. |
| if (std::optional<Fortran::evaluate::DynamicType> type = |
| getResultDynamicType(procedure)) |
| return type->category() == Fortran::common::TypeCategory::Character; |
| return false; |
| } |
| |
| private: |
| void handleImplicitResult( |
| const Fortran::evaluate::characteristics::FunctionResult &result, |
| bool isBindC) { |
| if (auto proc{result.IsProcedurePointer()}) { |
| mlir::Type mlirType = fir::BoxProcType::get( |
| &mlirContext, getProcedureType(*proc, interface.converter)); |
| addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, |
| Property::Value); |
| return; |
| } |
| const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape = |
| result.GetTypeAndShape(); |
| assert(typeAndShape && "expect type for non proc pointer result"); |
| Fortran::evaluate::DynamicType dynamicType = typeAndShape->type(); |
| // Character result allocated by caller and passed as hidden arguments |
| if (dynamicType.category() == Fortran::common::TypeCategory::Character) { |
| if (isBindC) { |
| mlir::Type mlirType = translateDynamicType(dynamicType); |
| addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, |
| Property::Value); |
| } else { |
| handleImplicitCharacterResult(dynamicType); |
| } |
| } else if (dynamicType.category() == |
| Fortran::common::TypeCategory::Derived) { |
| if (!dynamicType.GetDerivedTypeSpec().IsVectorType()) { |
| // Derived result need to be allocated by the caller and the result |
| // value must be saved. Derived type in implicit interface cannot have |
| // length parameters. |
| setSaveResult(); |
| } |
| mlir::Type mlirType = translateDynamicType(dynamicType); |
| addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, |
| Property::Value); |
| } else { |
| // All result other than characters/derived are simply returned by value |
| // in implicit interfaces |
| mlir::Type mlirType = |
| getConverter().genType(dynamicType.category(), dynamicType.kind()); |
| addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, |
| Property::Value); |
| } |
| } |
| void |
| handleImplicitCharacterResult(const Fortran::evaluate::DynamicType &type) { |
| int resultPosition = FirPlaceHolder::resultEntityPosition; |
| setPassedResult(PassEntityBy::AddressAndLength, |
| getResultEntity(interface.side().getCallDescription())); |
| mlir::Type lenTy = mlir::IndexType::get(&mlirContext); |
| std::optional<std::int64_t> constantLen = type.knownLength(); |
| fir::CharacterType::LenType len = |
| constantLen ? *constantLen : fir::CharacterType::unknownLen(); |
| mlir::Type charRefTy = fir::ReferenceType::get( |
| fir::CharacterType::get(&mlirContext, type.kind(), len)); |
| mlir::Type boxCharTy = fir::BoxCharType::get(&mlirContext, type.kind()); |
| addFirOperand(charRefTy, resultPosition, Property::CharAddress); |
| addFirOperand(lenTy, resultPosition, Property::CharLength); |
| /// For now, also return it by boxchar |
| addFirResult(boxCharTy, resultPosition, Property::BoxChar); |
| } |
| |
| /// Return a vector with an attribute with the name of the argument if this |
| /// is a callee interface and the name is available. Otherwise, just return |
| /// an empty vector. |
| llvm::SmallVector<mlir::NamedAttribute> |
| dummyNameAttr(const FortranEntity &entity) { |
| if constexpr (std::is_same_v<FortranEntity, |
| std::optional<Fortran::common::Reference< |
| const Fortran::semantics::Symbol>>>) { |
| if (entity.has_value()) { |
| const Fortran::semantics::Symbol *argument = &*entity.value(); |
| // "fir.bindc_name" is used for arguments for the sake of consistency |
| // with other attributes carrying surface syntax names in FIR. |
| return {mlir::NamedAttribute( |
| mlir::StringAttr::get(&mlirContext, "fir.bindc_name"), |
| mlir::StringAttr::get(&mlirContext, |
| toStringRef(argument->name())))}; |
| } |
| } |
| return {}; |
| } |
| |
| mlir::Type |
| getRefType(Fortran::evaluate::DynamicType dynamicType, |
| const Fortran::evaluate::characteristics::DummyDataObject &obj) { |
| mlir::Type type = translateDynamicType(dynamicType); |
| if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type)) |
| type = fir::SequenceType::get(*bounds, type); |
| return fir::ReferenceType::get(type); |
| } |
| |
| void handleImplicitDummy( |
| const DummyCharacteristics *characteristics, |
| const Fortran::evaluate::characteristics::DummyDataObject &obj, |
| const FortranEntity &entity) { |
| Fortran::evaluate::DynamicType dynamicType = obj.type.type(); |
| if constexpr (std::is_same_v<FortranEntity, |
| const Fortran::evaluate::ActualArgument *>) { |
| if (entity) { |
| if (entity->isPercentVal()) { |
| mlir::Type type = translateDynamicType(dynamicType); |
| addFirOperand(type, nextPassedArgPosition(), Property::Value, |
| dummyNameAttr(entity)); |
| addPassedArg(PassEntityBy::Value, entity, characteristics); |
| return; |
| } |
| if (entity->isPercentRef()) { |
| mlir::Type refType = getRefType(dynamicType, obj); |
| addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress, |
| dummyNameAttr(entity)); |
| addPassedArg(PassEntityBy::BaseAddress, entity, characteristics); |
| return; |
| } |
| } |
| } |
| if (dynamicType.category() == Fortran::common::TypeCategory::Character) { |
| mlir::Type boxCharTy = |
| fir::BoxCharType::get(&mlirContext, dynamicType.kind()); |
| addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar, |
| dummyNameAttr(entity)); |
| addPassedArg(PassEntityBy::BoxChar, entity, characteristics); |
| } else { |
| // non-PDT derived type allowed in implicit interface. |
| mlir::Type refType = getRefType(dynamicType, obj); |
| addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress, |
| dummyNameAttr(entity)); |
| addPassedArg(PassEntityBy::BaseAddress, entity, characteristics); |
| } |
| } |
| |
| mlir::Type |
| translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) { |
| Fortran::common::TypeCategory cat = dynamicType.category(); |
| // DERIVED |
| if (cat == Fortran::common::TypeCategory::Derived) { |
| if (dynamicType.IsUnlimitedPolymorphic()) |
| return mlir::NoneType::get(&mlirContext); |
| return getConverter().genType(dynamicType.GetDerivedTypeSpec()); |
| } |
| // CHARACTER with compile time constant length. |
| if (cat == Fortran::common::TypeCategory::Character) |
| if (std::optional<std::int64_t> constantLen = |
| toInt64(dynamicType.GetCharLength())) |
| return getConverter().genType(cat, dynamicType.kind(), {*constantLen}); |
| // INTEGER, REAL, LOGICAL, COMPLEX, and CHARACTER with dynamic length. |
| return getConverter().genType(cat, dynamicType.kind()); |
| } |
| |
| void handleExplicitDummy( |
| const DummyCharacteristics *characteristics, |
| const Fortran::evaluate::characteristics::DummyDataObject &obj, |
| const FortranEntity &entity, bool isBindC) { |
| using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr; |
| |
| bool isValueAttr = false; |
| [[maybe_unused]] mlir::Location loc = |
| interface.converter.getCurrentLocation(); |
| llvm::SmallVector<mlir::NamedAttribute> attrs = dummyNameAttr(entity); |
| auto addMLIRAttr = [&](llvm::StringRef attr) { |
| attrs.emplace_back(mlir::StringAttr::get(&mlirContext, attr), |
| mlir::UnitAttr::get(&mlirContext)); |
| }; |
| if (obj.attrs.test(Attrs::Optional)) |
| addMLIRAttr(fir::getOptionalAttrName()); |
| // Skipping obj.attrs.test(Attrs::Asynchronous), this does not impact the |
| // way the argument is passed given flang implement asynch IO synchronously. |
| // TODO: it would be safer to treat them as volatile because since Fortran |
| // 2018 asynchronous can also be used for C defined asynchronous user |
| // processes (see 18.10.4 Asynchronous communication). |
| if (obj.attrs.test(Attrs::Contiguous)) |
| addMLIRAttr(fir::getContiguousAttrName()); |
| if (obj.attrs.test(Attrs::Value)) |
| isValueAttr = true; // TODO: do we want an mlir::Attribute as well? |
| if (obj.attrs.test(Attrs::Volatile)) |
| TODO(loc, "VOLATILE in procedure interface"); |
| if (obj.attrs.test(Attrs::Target)) |
| addMLIRAttr(fir::getTargetAttrName()); |
| if (obj.cudaDataAttr) |
| attrs.emplace_back( |
| mlir::StringAttr::get(&mlirContext, fir::getCUDAAttrName()), |
| fir::getCUDADataAttribute(&mlirContext, obj.cudaDataAttr)); |
| |
| // TODO: intents that require special care (e.g finalization) |
| |
| using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr; |
| const Fortran::evaluate::characteristics::TypeAndShape::Attrs &shapeAttrs = |
| obj.type.attrs(); |
| if (shapeAttrs.test(ShapeAttr::Coarray)) |
| TODO(loc, "coarray: dummy argument coarray in procedure interface"); |
| |
| // So far assume that if the argument cannot be passed by implicit interface |
| // it must be by box. That may no be always true (e.g for simple optionals) |
| |
| Fortran::evaluate::DynamicType dynamicType = obj.type.type(); |
| mlir::Type type = translateDynamicType(dynamicType); |
| if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type)) |
| type = fir::SequenceType::get(*bounds, type); |
| if (obj.attrs.test(Attrs::Allocatable)) |
| type = fir::HeapType::get(type); |
| if (obj.attrs.test(Attrs::Pointer)) |
| type = fir::PointerType::get(type); |
| mlir::Type boxType = fir::wrapInClassOrBoxType( |
| type, obj.type.type().IsPolymorphic(), obj.type.type().IsAssumedType()); |
| |
| if (obj.attrs.test(Attrs::Allocatable) || obj.attrs.test(Attrs::Pointer)) { |
| // Pass as fir.ref<fir.box> or fir.ref<fir.class> |
| mlir::Type boxRefType = fir::ReferenceType::get(boxType); |
| addFirOperand(boxRefType, nextPassedArgPosition(), Property::MutableBox, |
| attrs); |
| addPassedArg(PassEntityBy::MutableBox, entity, characteristics); |
| } else if (obj.IsPassedByDescriptor(isBindC)) { |
| // Pass as fir.box or fir.class |
| if (isValueAttr && |
| !getConverter().getLoweringOptions().getLowerToHighLevelFIR()) |
| TODO(loc, "assumed shape dummy argument with VALUE attribute"); |
| addFirOperand(boxType, nextPassedArgPosition(), Property::Box, attrs); |
| addPassedArg(PassEntityBy::Box, entity, characteristics); |
| } else if (dynamicType.category() == |
| Fortran::common::TypeCategory::Character) { |
| if (isValueAttr && isBindC) { |
| // Pass as fir.char<1> |
| mlir::Type charTy = |
| fir::CharacterType::getSingleton(&mlirContext, dynamicType.kind()); |
| addFirOperand(charTy, nextPassedArgPosition(), Property::Value, attrs); |
| addPassedArg(PassEntityBy::Value, entity, characteristics); |
| } else { |
| // Pass as fir.box_char |
| mlir::Type boxCharTy = |
| fir::BoxCharType::get(&mlirContext, dynamicType.kind()); |
| addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar, |
| attrs); |
| addPassedArg(isValueAttr ? PassEntityBy::CharBoxValueAttribute |
| : PassEntityBy::BoxChar, |
| entity, characteristics); |
| } |
| } else { |
| // Pass as fir.ref unless it's by VALUE and BIND(C). Also pass-by-value |
| // for numerical/logical scalar without OPTIONAL so that the behavior is |
| // consistent with gfortran/nvfortran. |
| // TODO: pass-by-value for derived type is not supported yet |
| mlir::Type passType = fir::ReferenceType::get(type); |
| PassEntityBy passBy = PassEntityBy::BaseAddress; |
| Property prop = Property::BaseAddress; |
| if (isValueAttr) { |
| bool isBuiltinCptrType = fir::isa_builtin_cptr_type(type); |
| if (isBindC || (!mlir::isa<fir::SequenceType>(type) && |
| !obj.attrs.test(Attrs::Optional) && |
| (dynamicType.category() != |
| Fortran::common::TypeCategory::Derived || |
| isBuiltinCptrType))) { |
| passBy = PassEntityBy::Value; |
| prop = Property::Value; |
| if (isBuiltinCptrType) { |
| auto recTy = mlir::dyn_cast<fir::RecordType>(type); |
| mlir::Type fieldTy = recTy.getTypeList()[0].second; |
| passType = fir::ReferenceType::get(fieldTy); |
| } else { |
| passType = type; |
| } |
| } else { |
| passBy = PassEntityBy::BaseAddressValueAttribute; |
| } |
| } |
| addFirOperand(passType, nextPassedArgPosition(), prop, attrs); |
| addPassedArg(passBy, entity, characteristics); |
| } |
| } |
| |
| void handleImplicitDummy( |
| const DummyCharacteristics *characteristics, |
| const Fortran::evaluate::characteristics::DummyProcedure &proc, |
| const FortranEntity &entity) { |
| if (!interface.converter.getLoweringOptions().getLowerToHighLevelFIR() && |
| proc.attrs.test( |
| Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer)) |
| TODO(interface.converter.getCurrentLocation(), |
| "procedure pointer arguments"); |
| const Fortran::evaluate::characteristics::Procedure &procedure = |
| proc.procedure.value(); |
| mlir::Type funcType = |
| getProcedureDesignatorType(&procedure, interface.converter); |
| if (proc.attrs.test(Fortran::evaluate::characteristics::DummyProcedure:: |
| Attr::Pointer)) { |
| // Prodecure pointer dummy argument. |
| funcType = fir::ReferenceType::get(funcType); |
| addFirOperand(funcType, nextPassedArgPosition(), Property::BoxProcRef); |
| addPassedArg(PassEntityBy::BoxProcRef, entity, characteristics); |
| return; |
| } |
| // Otherwise, it is a dummy procedure. |
| std::optional<Fortran::evaluate::DynamicType> resultTy = |
| getResultDynamicType(procedure); |
| if (resultTy && mustPassLengthWithDummyProcedure(procedure)) { |
| // The result length of dummy procedures that are character functions must |
| // be passed so that the dummy procedure can be called if it has assumed |
| // length on the callee side. |
| mlir::Type tupleType = |
| fir::factory::getCharacterProcedureTupleType(funcType); |
| llvm::StringRef charProcAttr = fir::getCharacterProcedureDummyAttrName(); |
| addFirOperand(tupleType, nextPassedArgPosition(), Property::CharProcTuple, |
| {mlir::NamedAttribute{ |
| mlir::StringAttr::get(&mlirContext, charProcAttr), |
| mlir::UnitAttr::get(&mlirContext)}}); |
| addPassedArg(PassEntityBy::CharProcTuple, entity, characteristics); |
| return; |
| } |
| addFirOperand(funcType, nextPassedArgPosition(), Property::BaseAddress); |
| addPassedArg(PassEntityBy::BaseAddress, entity, characteristics); |
| } |
| |
| void handleExplicitResult( |
| const Fortran::evaluate::characteristics::FunctionResult &result) { |
| using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr; |
| mlir::Type mlirType; |
| if (auto proc{result.IsProcedurePointer()}) { |
| mlirType = fir::BoxProcType::get( |
| &mlirContext, getProcedureType(*proc, interface.converter)); |
| addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, |
| Property::Value); |
| return; |
| } |
| const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape = |
| result.GetTypeAndShape(); |
| assert(typeAndShape && "expect type for non proc pointer result"); |
| mlirType = translateDynamicType(typeAndShape->type()); |
| const auto *resTypeAndShape{result.GetTypeAndShape()}; |
| bool resIsPolymorphic = |
| resTypeAndShape && resTypeAndShape->type().IsPolymorphic(); |
| bool resIsAssumedType = |
| resTypeAndShape && resTypeAndShape->type().IsAssumedType(); |
| if (std::optional<fir::SequenceType::Shape> bounds = |
| getBounds(*typeAndShape)) |
| mlirType = fir::SequenceType::get(*bounds, mlirType); |
| if (result.attrs.test(Attr::Allocatable)) |
| mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType), |
| resIsPolymorphic, resIsAssumedType); |
| if (result.attrs.test(Attr::Pointer)) |
| mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType), |
| resIsPolymorphic, resIsAssumedType); |
| |
| if (fir::isa_char(mlirType)) { |
| // Character scalar results must be passed as arguments in lowering so |
| // that an assumed length character function callee can access the |
| // result length. A function with a result requiring an explicit |
| // interface does not have to be compatible with assumed length |
| // function, but most compilers supports it. |
| handleImplicitCharacterResult(typeAndShape->type()); |
| return; |
| } |
| |
| addFirResult(mlirType, FirPlaceHolder::resultEntityPosition, |
| Property::Value); |
| // Explicit results require the caller to allocate the storage and save the |
| // function result in the storage with a fir.save_result. |
| setSaveResult(); |
| } |
| |
| // Return nullopt for scalars, empty vector for assumed rank, and a vector |
| // with the shape (may contain unknown extents) for arrays. |
| std::optional<fir::SequenceType::Shape> getBounds( |
| const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape) { |
| using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr; |
| if (typeAndShape.shape().empty() && |
| !typeAndShape.attrs().test(ShapeAttr::AssumedRank)) |
| return std::nullopt; |
| fir::SequenceType::Shape bounds; |
| for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : |
| typeAndShape.shape()) { |
| fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent(); |
| if (std::optional<std::int64_t> i = toInt64(extent)) |
| bound = *i; |
| bounds.emplace_back(bound); |
| } |
| return bounds; |
| } |
| std::optional<std::int64_t> |
| toInt64(std::optional< |
| Fortran::evaluate::Expr<Fortran::evaluate::SubscriptInteger>> |
| expr) { |
| if (expr) |
| return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold( |
| getConverter().getFoldingContext(), toEvExpr(*expr))); |
| return std::nullopt; |
| } |
| void addFirOperand( |
| mlir::Type type, int entityPosition, Property p, |
| llvm::ArrayRef<mlir::NamedAttribute> attributes = std::nullopt) { |
| interface.inputs.emplace_back( |
| FirPlaceHolder{type, entityPosition, p, attributes}); |
| } |
| void |
| addFirResult(mlir::Type type, int entityPosition, Property p, |
| llvm::ArrayRef<mlir::NamedAttribute> attributes = std::nullopt) { |
| interface.outputs.emplace_back( |
| FirPlaceHolder{type, entityPosition, p, attributes}); |
| } |
| void addPassedArg(PassEntityBy p, FortranEntity entity, |
| const DummyCharacteristics *characteristics) { |
| interface.passedArguments.emplace_back( |
| PassedEntity{p, entity, emptyValue(), emptyValue(), characteristics}); |
| } |
| void setPassedResult(PassEntityBy p, FortranEntity entity) { |
| interface.passedResult = |
| PassedEntity{p, entity, emptyValue(), emptyValue()}; |
| } |
| void setSaveResult() { interface.saveResult = true; } |
| int nextPassedArgPosition() { return interface.passedArguments.size(); } |
| |
| static FirValue emptyValue() { |
| if constexpr (std::is_same_v<Fortran::lower::CalleeInterface, T>) { |
| return {}; |
| } else { |
| return -1; |
| } |
| } |
| |
| Fortran::lower::AbstractConverter &getConverter() { |
| return interface.converter; |
| } |
| CallInterface &interface; |
| mlir::MLIRContext &mlirContext; |
| }; |
| |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::isOptional() const { |
| if (!characteristics) |
| return false; |
| return characteristics->IsOptional(); |
| } |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeModifiedByCall() |
| const { |
| if (!characteristics) |
| return true; |
| if (characteristics->GetIntent() == Fortran::common::Intent::In) |
| return false; |
| return !hasValueAttribute(); |
| } |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeReadByCall() const { |
| if (!characteristics) |
| return true; |
| return characteristics->GetIntent() != Fortran::common::Intent::Out; |
| } |
| |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::testTKR( |
| Fortran::common::IgnoreTKR flag) const { |
| if (!characteristics) |
| return false; |
| const auto *dummy = |
| std::get_if<Fortran::evaluate::characteristics::DummyDataObject>( |
| &characteristics->u); |
| if (!dummy) |
| return false; |
| return dummy->ignoreTKR.test(flag); |
| } |
| |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::isIntentOut() const { |
| if (!characteristics) |
| return true; |
| return characteristics->GetIntent() == Fortran::common::Intent::Out; |
| } |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::mustBeMadeContiguous() |
| const { |
| if (!characteristics) |
| return true; |
| const auto *dummy = |
| std::get_if<Fortran::evaluate::characteristics::DummyDataObject>( |
| &characteristics->u); |
| if (!dummy) |
| return false; |
| const auto &shapeAttrs = dummy->type.attrs(); |
| using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attr; |
| if (shapeAttrs.test(ShapeAttrs::AssumedRank) || |
| shapeAttrs.test(ShapeAttrs::AssumedShape)) |
| return dummy->attrs.test( |
| Fortran::evaluate::characteristics::DummyDataObject::Attr::Contiguous); |
| if (shapeAttrs.test(ShapeAttrs::DeferredShape)) |
| return false; |
| // Explicit shape arrays are contiguous. |
| return dummy->type.Rank() > 0; |
| } |
| |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::hasValueAttribute() const { |
| if (!characteristics) |
| return false; |
| const auto *dummy = |
| std::get_if<Fortran::evaluate::characteristics::DummyDataObject>( |
| &characteristics->u); |
| return dummy && |
| dummy->attrs.test( |
| Fortran::evaluate::characteristics::DummyDataObject::Attr::Value); |
| } |
| |
| template <typename T> |
| bool Fortran::lower::CallInterface<T>::PassedEntity::hasAllocatableAttribute() |
| const { |
| if (!characteristics) |
| return false; |
| const auto *dummy = |
| std::get_if<Fortran::evaluate::characteristics::DummyDataObject>( |
| &characteristics->u); |
| using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr; |
| return dummy && dummy->attrs.test(Attrs::Allocatable); |
| } |
| |
| template <typename T> |
| bool Fortran::lower::CallInterface< |
| T>::PassedEntity::mayRequireIntentoutFinalization() const { |
| // Conservatively assume that the finalization is needed. |
| if (!characteristics) |
| return true; |
| |
| // No INTENT(OUT) dummy arguments do not require finalization on entry. |
| if (!isIntentOut()) |
| return false; |
| |
| const auto *dummy = |
| std::get_if<Fortran::evaluate::characteristics::DummyDataObject>( |
| &characteristics->u); |
| if (!dummy) |
| return true; |
| |
| // POINTER/ALLOCATABLE dummy arguments do not require finalization. |
| using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr; |
| if (dummy->attrs.test(Attrs::Allocatable) || |
| dummy->attrs.test(Attrs::Pointer)) |
| return false; |
| |
| // Polymorphic and unlimited polymorphic INTENT(OUT) dummy arguments |
| // may need finalization. |
| const Fortran::evaluate::DynamicType &type = dummy->type.type(); |
| if (type.IsPolymorphic() || type.IsUnlimitedPolymorphic()) |
| return true; |
| |
| // INTENT(OUT) dummy arguments of derived types require finalization, |
| // if their type has finalization. |
| const Fortran::semantics::DerivedTypeSpec *derived = |
| Fortran::evaluate::GetDerivedTypeSpec(type); |
| if (!derived) |
| return false; |
| |
| return Fortran::semantics::IsFinalizable(*derived); |
| } |
| |
| template <typename T> |
| bool Fortran::lower::CallInterface< |
| T>::PassedEntity::isSequenceAssociatedDescriptor() const { |
| if (!characteristics || passBy != PassEntityBy::Box) |
| return false; |
| const auto *dummy = |
| std::get_if<Fortran::evaluate::characteristics::DummyDataObject>( |
| &characteristics->u); |
| return dummy && dummy->type.CanBeSequenceAssociated(); |
| } |
| |
| template <typename T> |
| void Fortran::lower::CallInterface<T>::determineInterface( |
| bool isImplicit, |
| const Fortran::evaluate::characteristics::Procedure &procedure) { |
| CallInterfaceImpl<T> impl(*this); |
| if (isImplicit) |
| impl.buildImplicitInterface(procedure); |
| else |
| impl.buildExplicitInterface(procedure); |
| // We only expect the extra host asspciations argument from the callee side as |
| // the definition of internal procedures will be present, and we'll always |
| // have a FuncOp definition in the ModuleOp, when lowering. |
| if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) { |
| if (side().hasHostAssociated()) |
| impl.appendHostAssocTupleArg(side().getHostAssociatedTy()); |
| } |
| } |
| |
| template <typename T> |
| mlir::FunctionType Fortran::lower::CallInterface<T>::genFunctionType() { |
| llvm::SmallVector<mlir::Type> returnTys; |
| llvm::SmallVector<mlir::Type> inputTys; |
| for (const FirPlaceHolder &placeHolder : outputs) |
| returnTys.emplace_back(placeHolder.type); |
| for (const FirPlaceHolder &placeHolder : inputs) |
| inputTys.emplace_back(placeHolder.type); |
| return mlir::FunctionType::get(&converter.getMLIRContext(), inputTys, |
| returnTys); |
| } |
| |
| template <typename T> |
| llvm::SmallVector<mlir::Type> |
| Fortran::lower::CallInterface<T>::getResultType() const { |
| llvm::SmallVector<mlir::Type> types; |
| for (const FirPlaceHolder &out : outputs) |
| types.emplace_back(out.type); |
| return types; |
| } |
| |
| template class Fortran::lower::CallInterface<Fortran::lower::CalleeInterface>; |
| template class Fortran::lower::CallInterface<Fortran::lower::CallerInterface>; |
| |
| //===----------------------------------------------------------------------===// |
| // Function Type Translation |
| //===----------------------------------------------------------------------===// |
| |
| /// Build signature from characteristics when there is no Fortran entity to |
| /// associate with the arguments (i.e, this is not a call site or a procedure |
| /// declaration. This is needed when dealing with function pointers/dummy |
| /// arguments. |
| |
| class SignatureBuilder; |
| template <> |
| struct Fortran::lower::PassedEntityTypes<SignatureBuilder> { |
| using FortranEntity = FakeEntity; |
| using FirValue = int; |
| }; |
| |
| /// SignatureBuilder is a CRTP implementation of CallInterface intended to |
| /// help translating characteristics::Procedure to mlir::FunctionType using |
| /// the CallInterface translation. |
| class SignatureBuilder |
| : public Fortran::lower::CallInterface<SignatureBuilder> { |
| public: |
| SignatureBuilder(const Fortran::evaluate::characteristics::Procedure &p, |
| Fortran::lower::AbstractConverter &c, bool forceImplicit) |
| : CallInterface{c}, proc{p} { |
| bool isImplicit = forceImplicit || proc.CanBeCalledViaImplicitInterface(); |
| determineInterface(isImplicit, proc); |
| } |
| SignatureBuilder(const Fortran::evaluate::ProcedureDesignator &procDes, |
| Fortran::lower::AbstractConverter &c) |
| : CallInterface{c}, procDesignator{&procDes}, |
| proc{Fortran::evaluate::characteristics::Procedure::Characterize( |
| procDes, converter.getFoldingContext(), /*emitError=*/false) |
| .value()} {} |
| /// Does the procedure characteristics being translated have alternate |
| /// returns ? |
| bool hasAlternateReturns() const { |
| for (const Fortran::evaluate::characteristics::DummyArgument &dummy : |
| proc.dummyArguments) |
| if (std::holds_alternative< |
| Fortran::evaluate::characteristics::AlternateReturn>(dummy.u)) |
| return true; |
| return false; |
| }; |
| |
| /// This is only here to fulfill CRTP dependencies and should not be called. |
| std::string getMangledName() const { |
| if (procDesignator) |
| return getProcMangledName(*procDesignator, converter); |
| fir::emitFatalError( |
| converter.getCurrentLocation(), |
| "should not query name when only building function type"); |
| } |
| |
| /// This is only here to fulfill CRTP dependencies and should not be called. |
| mlir::Location getCalleeLocation() const { |
| if (procDesignator) |
| return getProcedureDesignatorLoc(*procDesignator, converter); |
| return converter.getCurrentLocation(); |
| } |
| |
| const Fortran::semantics::Symbol *getProcedureSymbol() const { |
| if (procDesignator) |
| return procDesignator->GetSymbol(); |
| return nullptr; |
| }; |
| |
| Fortran::evaluate::characteristics::Procedure characterize() const { |
| return proc; |
| } |
| /// SignatureBuilder cannot be used on main program. |
| static constexpr bool isMainProgram() { return false; } |
| |
| /// Return the characteristics::Procedure that is being translated to |
| /// mlir::FunctionType. |
| const Fortran::evaluate::characteristics::Procedure & |
| getCallDescription() const { |
| return proc; |
| } |
| |
| /// This is not the description of an indirect call. |
| static constexpr bool isIndirectCall() { return false; } |
| |
| /// Return the translated signature. |
| mlir::FunctionType getFunctionType() { |
| if (interfaceDetermined) |
| fir::emitFatalError(converter.getCurrentLocation(), |
| "SignatureBuilder should only be used once"); |
| // Most unrestricted intrinsic characteristics have the Elemental attribute |
| // which triggers CanBeCalledViaImplicitInterface to return false. However, |
| // using implicit interface rules is just fine here. |
| bool forceImplicit = |
| procDesignator && procDesignator->GetSpecificIntrinsic(); |
| bool isImplicit = forceImplicit || proc.CanBeCalledViaImplicitInterface(); |
| determineInterface(isImplicit, proc); |
| interfaceDetermined = true; |
| return genFunctionType(); |
| } |
| |
| mlir::func::FuncOp getOrCreateFuncOp() { |
| if (interfaceDetermined) |
| fir::emitFatalError(converter.getCurrentLocation(), |
| "SignatureBuilder should only be used once"); |
| declare(); |
| interfaceDetermined = true; |
| return getFuncOp(); |
| } |
| |
| // Copy of base implementation. |
| static constexpr bool hasHostAssociated() { return false; } |
| mlir::Type getHostAssociatedTy() const { |
| llvm_unreachable("getting host associated type in SignatureBuilder"); |
| } |
| |
| private: |
| const Fortran::evaluate::ProcedureDesignator *procDesignator = nullptr; |
| Fortran::evaluate::characteristics::Procedure proc; |
| bool interfaceDetermined = false; |
| }; |
| |
| mlir::FunctionType Fortran::lower::translateSignature( |
| const Fortran::evaluate::ProcedureDesignator &proc, |
| Fortran::lower::AbstractConverter &converter) { |
| return SignatureBuilder{proc, converter}.getFunctionType(); |
| } |
| |
| mlir::func::FuncOp Fortran::lower::getOrDeclareFunction( |
| const Fortran::evaluate::ProcedureDesignator &proc, |
| Fortran::lower::AbstractConverter &converter) { |
| mlir::ModuleOp module = converter.getModuleOp(); |
| std::string name = getProcMangledName(proc, converter); |
| mlir::func::FuncOp func = fir::FirOpBuilder::getNamedFunction( |
| module, converter.getMLIRSymbolTable(), name); |
| if (func) |
| return func; |
| |
| // getOrDeclareFunction is only used for functions not defined in the current |
| // program unit, so use the location of the procedure designator symbol, which |
| // is the first occurrence of the procedure in the program unit. |
| return SignatureBuilder{proc, converter}.getOrCreateFuncOp(); |
| } |
| |
| // Is it required to pass a dummy procedure with \p characteristics as a tuple |
| // containing the function address and the result length ? |
| static bool mustPassLengthWithDummyProcedure( |
| const std::optional<Fortran::evaluate::characteristics::Procedure> |
| &characteristics) { |
| return characteristics && |
| Fortran::lower::CallInterfaceImpl<SignatureBuilder>:: |
| mustPassLengthWithDummyProcedure(*characteristics); |
| } |
| |
| bool Fortran::lower::mustPassLengthWithDummyProcedure( |
| const Fortran::evaluate::ProcedureDesignator &procedure, |
| Fortran::lower::AbstractConverter &converter) { |
| std::optional<Fortran::evaluate::characteristics::Procedure> characteristics = |
| Fortran::evaluate::characteristics::Procedure::Characterize( |
| procedure, converter.getFoldingContext(), /*emitError=*/false); |
| return ::mustPassLengthWithDummyProcedure(characteristics); |
| } |
| |
| mlir::Type Fortran::lower::getDummyProcedureType( |
| const Fortran::semantics::Symbol &dummyProc, |
| Fortran::lower::AbstractConverter &converter) { |
| std::optional<Fortran::evaluate::characteristics::Procedure> iface = |
| Fortran::evaluate::characteristics::Procedure::Characterize( |
| dummyProc, converter.getFoldingContext()); |
| mlir::Type procType = getProcedureDesignatorType( |
| iface.has_value() ? &*iface : nullptr, converter); |
| if (::mustPassLengthWithDummyProcedure(iface)) |
| return fir::factory::getCharacterProcedureTupleType(procType); |
| return procType; |
| } |
| |
| bool Fortran::lower::isCPtrArgByValueType(mlir::Type ty) { |
| return mlir::isa<fir::ReferenceType>(ty) && |
| fir::isa_integer(fir::unwrapRefType(ty)); |
| } |
| |
| // Return the mlir::FunctionType of a procedure |
| static mlir::FunctionType |
| getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc, |
| Fortran::lower::AbstractConverter &converter) { |
| return SignatureBuilder{proc, converter, false}.genFunctionType(); |
| } |