1791 lines · cpp
1//===-- CallInterface.cpp -- Procedure call interface ---------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Lower/CallInterface.h"10#include "flang/Evaluate/fold.h"11#include "flang/Lower/Bridge.h"12#include "flang/Lower/Mangler.h"13#include "flang/Lower/OpenACC.h"14#include "flang/Lower/PFTBuilder.h"15#include "flang/Lower/StatementContext.h"16#include "flang/Lower/Support/Utils.h"17#include "flang/Optimizer/Builder/Character.h"18#include "flang/Optimizer/Builder/FIRBuilder.h"19#include "flang/Optimizer/Builder/Todo.h"20#include "flang/Optimizer/Dialect/FIRDialect.h"21#include "flang/Optimizer/Dialect/FIROpsSupport.h"22#include "flang/Optimizer/Support/InternalNames.h"23#include "flang/Optimizer/Support/Utils.h"24#include "flang/Semantics/symbol.h"25#include "flang/Semantics/tools.h"26#include "flang/Support/Fortran.h"27#include <optional>28 29static mlir::FunctionType30getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc,31 Fortran::lower::AbstractConverter &converter);32 33mlir::Type Fortran::lower::getUntypedBoxProcType(mlir::MLIRContext *context) {34 llvm::SmallVector<mlir::Type> resultTys;35 llvm::SmallVector<mlir::Type> inputTys;36 auto untypedFunc = mlir::FunctionType::get(context, inputTys, resultTys);37 return fir::BoxProcType::get(context, untypedFunc);38}39 40/// Return the type of a dummy procedure given its characteristic (if it has41/// one).42static mlir::Type getProcedureDesignatorType(43 const Fortran::evaluate::characteristics::Procedure *,44 Fortran::lower::AbstractConverter &converter) {45 // TODO: Get actual function type of the dummy procedure, at least when an46 // interface is given. The result type should be available even if the arity47 // and type of the arguments is not.48 // In general, that is a nice to have but we cannot guarantee to find the49 // function type that will match the one of the calls, we may not even know50 // how many arguments the dummy procedure accepts (e.g. if a procedure51 // pointer is only transiting through the current procedure without being52 // called), so a function type cast must always be inserted.53 return Fortran::lower::getUntypedBoxProcType(&converter.getMLIRContext());54}55 56//===----------------------------------------------------------------------===//57// Caller side interface implementation58//===----------------------------------------------------------------------===//59 60bool Fortran::lower::CallerInterface::hasAlternateReturns() const {61 return procRef.hasAlternateReturns();62}63 64/// Return the binding label (from BIND(C...)) or the mangled name of the65/// symbol.66static std::string67getProcMangledName(const Fortran::evaluate::ProcedureDesignator &proc,68 Fortran::lower::AbstractConverter &converter) {69 if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())70 return converter.mangleName(symbol->GetUltimate());71 assert(proc.GetSpecificIntrinsic() &&72 "expected intrinsic procedure in designator");73 return proc.GetName();74}75 76std::string Fortran::lower::CallerInterface::getMangledName() const {77 return getProcMangledName(procRef.proc(), converter);78}79 80const Fortran::semantics::Symbol *81Fortran::lower::CallerInterface::getProcedureSymbol() const {82 return procRef.proc().GetSymbol();83}84 85bool Fortran::lower::CallerInterface::isIndirectCall() const {86 if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())87 return Fortran::semantics::IsPointer(*symbol) ||88 Fortran::semantics::IsDummy(*symbol);89 return false;90}91 92bool Fortran::lower::CallerInterface::requireDispatchCall() const {93 // Procedure pointer component reference do not require dispatch, but94 // have PASS/NOPASS argument.95 if (const Fortran::semantics::Symbol *sym = procRef.proc().GetSymbol())96 if (Fortran::semantics::IsPointer(*sym))97 return false;98 // calls with NOPASS attribute still have their component so check if it is99 // polymorphic.100 if (const Fortran::evaluate::Component *component =101 procRef.proc().GetComponent()) {102 if (Fortran::semantics::IsPolymorphic(component->base().GetLastSymbol()))103 return true;104 }105 // calls with PASS attribute have the passed-object already set in its106 // arguments. Just check if their is one.107 std::optional<unsigned> passArg = getPassArgIndex();108 if (passArg)109 return true;110 return false;111}112 113std::optional<unsigned>114Fortran::lower::CallerInterface::getPassArgIndex() const {115 unsigned passArgIdx = 0;116 std::optional<unsigned> passArg;117 for (const auto &arg : getCallDescription().arguments()) {118 if (arg && arg->isPassedObject()) {119 passArg = passArgIdx;120 break;121 }122 ++passArgIdx;123 }124 if (!passArg)125 return passArg;126 // Take into account result inserted as arguments.127 if (std::optional<Fortran::lower::CallInterface<128 Fortran::lower::CallerInterface>::PassedEntity>129 resultArg = getPassedResult()) {130 if (resultArg->passBy == PassEntityBy::AddressAndLength)131 passArg = *passArg + 2;132 else if (resultArg->passBy == PassEntityBy::BaseAddress)133 passArg = *passArg + 1;134 }135 return passArg;136}137 138mlir::Value Fortran::lower::CallerInterface::getIfPassedArg() const {139 if (std::optional<unsigned> passArg = getPassArgIndex()) {140 assert(actualInputs.size() > *passArg && actualInputs[*passArg] &&141 "passed arg was not set yet");142 return actualInputs[*passArg];143 }144 return {};145}146 147const Fortran::evaluate::ProcedureDesignator *148Fortran::lower::CallerInterface::getIfIndirectCall() const {149 if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())150 if (Fortran::semantics::IsPointer(*symbol) ||151 Fortran::semantics::IsDummy(*symbol))152 return &procRef.proc();153 return nullptr;154}155 156static mlir::Location157getProcedureDesignatorLoc(const Fortran::evaluate::ProcedureDesignator &proc,158 Fortran::lower::AbstractConverter &converter) {159 // Note: If the callee is defined in the same file but after the current160 // unit we cannot get its location here and the funcOp is created at the161 // wrong location (i.e, the caller location).162 // To prevent this, it is up to the bridge to first declare all functions163 // defined in the translation unit before lowering any calls or procedure164 // designator references.165 if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())166 return converter.genLocation(symbol->name());167 // Use current location for intrinsics.168 return converter.getCurrentLocation();169}170 171mlir::Location Fortran::lower::CallerInterface::getCalleeLocation() const {172 return getProcedureDesignatorLoc(procRef.proc(), converter);173}174 175// Get dummy argument characteristic for a procedure with implicit interface176// from the actual argument characteristic. The actual argument may not be a F77177// entity. The attribute must be dropped and the shape, if any, must be made178// explicit.179static Fortran::evaluate::characteristics::DummyDataObject180asImplicitArg(Fortran::evaluate::characteristics::DummyDataObject &&dummy) {181 std::optional<Fortran::evaluate::Shape> shape =182 dummy.type.attrs().none()183 ? dummy.type.shape()184 : std::make_optional<Fortran::evaluate::Shape>(dummy.type.Rank());185 return Fortran::evaluate::characteristics::DummyDataObject(186 Fortran::evaluate::characteristics::TypeAndShape(dummy.type.type(),187 std::move(shape)));188}189 190static Fortran::evaluate::characteristics::DummyArgument191asImplicitArg(Fortran::evaluate::characteristics::DummyArgument &&dummy) {192 return Fortran::common::visit(193 Fortran::common::visitors{194 [&](Fortran::evaluate::characteristics::DummyDataObject &obj) {195 return Fortran::evaluate::characteristics::DummyArgument(196 std::move(dummy.name), asImplicitArg(std::move(obj)));197 },198 [&](Fortran::evaluate::characteristics::DummyProcedure &proc) {199 return Fortran::evaluate::characteristics::DummyArgument(200 std::move(dummy.name), std::move(proc));201 },202 [](Fortran::evaluate::characteristics::AlternateReturn &x) {203 return Fortran::evaluate::characteristics::DummyArgument(204 std::move(x));205 }},206 dummy.u);207}208 209static bool isExternalDefinedInSameCompilationUnit(210 const Fortran::evaluate::ProcedureDesignator &proc) {211 if (const auto *symbol{proc.GetSymbol()})212 return symbol->has<Fortran::semantics::SubprogramDetails>() &&213 symbol->owner().IsGlobal();214 return false;215}216 217Fortran::evaluate::characteristics::Procedure218Fortran::lower::CallerInterface::characterize() const {219 Fortran::evaluate::FoldingContext &foldingContext =220 converter.getFoldingContext();221 std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =222 Fortran::evaluate::characteristics::Procedure::Characterize(223 procRef.proc(), foldingContext, /*emitError=*/false);224 assert(characteristic && "Failed to get characteristic from procRef");225 // The characteristic may not contain the argument characteristic if the226 // ProcedureDesignator has no interface, or may mismatch in case of implicit227 // interface.228 if (!characteristic->HasExplicitInterface() ||229 (converter.getLoweringOptions().getLowerToHighLevelFIR() &&230 isExternalDefinedInSameCompilationUnit(procRef.proc()) &&231 characteristic->CanBeCalledViaImplicitInterface())) {232 // In HLFIR lowering, calls to subprogram with implicit interfaces are233 // always prepared according to the actual arguments. This is to support234 // cases where the implicit interfaces are "abused" in old and not so old235 // Fortran code (e.g, passing REAL(8) to CHARACTER(8), passing object236 // pointers to procedure dummies, passing regular procedure dummies to237 // character procedure dummies, omitted arguments....).238 // In all those case, if the subprogram definition is in the same239 // compilation unit, the "characteristic" from Characterize will be the one240 // from the definition, in case of "abuses" (for which semantics raise a241 // warning), lowering will be placed in a difficult position if it is given242 // the dummy characteristic from the definition and an actual that has243 // seemingly nothing to do with it: it would need to battle to anticipate244 // and handle these mismatches (e.g., be able to prepare a fir.boxchar<>245 // from a fir.real<> and so one). This was the approach of the lowering to246 // FIR, and usually lead to compiler bug every time a new "abuse" was met in247 // the wild.248 // Instead, in HLFIR, the dummy characteristic is always computed from the249 // actual for subprogram with implicit interfaces, and in case of call site250 // vs fun.func MLIR function type signature mismatch, a function cast is251 // done before placing the call. This is a hammer that should cover all252 // cases and behave like existing compiler that "do not see" the definition253 // when placing the call.254 characteristic->dummyArguments.clear();255 for (const std::optional<Fortran::evaluate::ActualArgument> &arg :256 procRef.arguments()) {257 // "arg" may be null if this is a call with missing arguments compared258 // to the subprogram definition. Do not compute any characteristic259 // in this case.260 if (arg.has_value()) {261 if (arg.value().isAlternateReturn()) {262 characteristic->dummyArguments.emplace_back(263 Fortran::evaluate::characteristics::AlternateReturn{});264 } else {265 // Argument cannot be optional with implicit interface266 const Fortran::lower::SomeExpr *expr = arg.value().UnwrapExpr();267 assert(expr && "argument in call with implicit interface cannot be "268 "assumed type");269 std::optional<Fortran::evaluate::characteristics::DummyArgument>270 argCharacteristic =271 Fortran::evaluate::characteristics::DummyArgument::FromActual(272 "actual", *expr, foldingContext,273 /*forImplicitInterface=*/true);274 assert(argCharacteristic &&275 "failed to characterize argument in implicit call");276 characteristic->dummyArguments.emplace_back(277 asImplicitArg(std::move(*argCharacteristic)));278 }279 }280 }281 }282 return *characteristic;283}284 285void Fortran::lower::CallerInterface::placeInput(286 const PassedEntity &passedEntity, mlir::Value arg) {287 assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&288 passedEntity.firArgument >= 0 &&289 passedEntity.passBy != CallInterface::PassEntityBy::AddressAndLength &&290 "bad arg position");291 actualInputs[passedEntity.firArgument] = arg;292}293 294void Fortran::lower::CallerInterface::placeAddressAndLengthInput(295 const PassedEntity &passedEntity, mlir::Value addr, mlir::Value len) {296 assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&297 static_cast<int>(actualInputs.size()) > passedEntity.firLength &&298 passedEntity.firArgument >= 0 && passedEntity.firLength >= 0 &&299 passedEntity.passBy == CallInterface::PassEntityBy::AddressAndLength &&300 "bad arg position");301 actualInputs[passedEntity.firArgument] = addr;302 actualInputs[passedEntity.firLength] = len;303}304 305bool Fortran::lower::CallerInterface::verifyActualInputs() const {306 if (getNumFIRArguments() != actualInputs.size())307 return false;308 for (mlir::Value arg : actualInputs) {309 if (!arg)310 return false;311 }312 return true;313}314 315mlir::Value316Fortran::lower::CallerInterface::getInput(const PassedEntity &passedEntity) {317 return actualInputs[passedEntity.firArgument];318}319 320static void walkLengths(321 const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape,322 const Fortran::lower::CallerInterface::ExprVisitor &visitor,323 Fortran::lower::AbstractConverter &converter) {324 Fortran::evaluate::DynamicType dynamicType = typeAndShape.type();325 // Visit length specification expressions that are explicit.326 if (dynamicType.category() == Fortran::common::TypeCategory::Character) {327 if (std::optional<Fortran::evaluate::ExtentExpr> length =328 dynamicType.GetCharLength())329 visitor(toEvExpr(*length), /*assumedSize=*/false);330 } else if (dynamicType.category() == Fortran::common::TypeCategory::Derived &&331 !dynamicType.IsUnlimitedPolymorphic()) {332 const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec =333 dynamicType.GetDerivedTypeSpec();334 if (Fortran::semantics::CountLenParameters(derivedTypeSpec) > 0)335 TODO(converter.getCurrentLocation(),336 "function result with derived type length parameters");337 }338}339 340void Fortran::lower::CallerInterface::walkResultLengths(341 const ExprVisitor &visitor) const {342 assert(characteristic && "characteristic was not computed");343 const Fortran::evaluate::characteristics::FunctionResult &result =344 characteristic->functionResult.value();345 const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =346 result.GetTypeAndShape();347 assert(typeAndShape && "no result type");348 return walkLengths(*typeAndShape, visitor, converter);349}350 351void Fortran::lower::CallerInterface::walkDummyArgumentLengths(352 const PassedEntity &passedEntity, const ExprVisitor &visitor) const {353 if (!passedEntity.characteristics)354 return;355 if (const auto *dummy =356 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(357 &passedEntity.characteristics->u))358 walkLengths(dummy->type, visitor, converter);359}360 361// Compute extent expr from shapeSpec of an explicit shape.362static Fortran::evaluate::ExtentExpr363getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {364 if (shapeSpec.ubound().isStar())365 // F'2023 18.5.3 point 5.366 return Fortran::evaluate::ExtentExpr{-1};367 const auto &ubound = shapeSpec.ubound().GetExplicit();368 const auto &lbound = shapeSpec.lbound().GetExplicit();369 assert(lbound && ubound && "shape must be explicit");370 return Fortran::common::Clone(*ubound) - Fortran::common::Clone(*lbound) +371 Fortran::evaluate::ExtentExpr{1};372}373 374static void375walkExtents(const Fortran::semantics::Symbol &symbol,376 const Fortran::lower::CallerInterface::ExprVisitor &visitor) {377 if (const auto *objectDetails =378 symbol.detailsIf<Fortran::semantics::ObjectEntityDetails>())379 if (objectDetails->shape().IsExplicitShape() ||380 Fortran::semantics::IsAssumedSizeArray(symbol))381 for (const Fortran::semantics::ShapeSpec &shapeSpec :382 objectDetails->shape())383 visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)),384 /*assumedSize=*/shapeSpec.ubound().isStar());385}386 387void Fortran::lower::CallerInterface::walkResultExtents(388 const ExprVisitor &visitor) const {389 // Walk directly the result symbol shape (the characteristic shape may contain390 // descriptor inquiries to it that would fail to lower on the caller side).391 const Fortran::semantics::SubprogramDetails *interfaceDetails =392 getInterfaceDetails();393 if (interfaceDetails) {394 walkExtents(interfaceDetails->result(), visitor);395 } else {396 if (procRef.Rank() != 0)397 fir::emitFatalError(398 converter.getCurrentLocation(),399 "only scalar functions may not have an interface symbol");400 }401}402 403void Fortran::lower::CallerInterface::walkDummyArgumentExtents(404 const PassedEntity &passedEntity, const ExprVisitor &visitor) const {405 const Fortran::semantics::SubprogramDetails *interfaceDetails =406 getInterfaceDetails();407 if (!interfaceDetails)408 return;409 const Fortran::semantics::Symbol *dummy = getDummySymbol(passedEntity);410 assert(dummy && "dummy symbol was not set");411 walkExtents(*dummy, visitor);412}413 414bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForResult() const {415 assert(characteristic && "characteristic was not computed");416 const std::optional<Fortran::evaluate::characteristics::FunctionResult>417 &result = characteristic->functionResult;418 if (!result || result->CanBeReturnedViaImplicitInterface() ||419 !getInterfaceDetails() || result->IsProcedurePointer())420 return false;421 bool allResultSpecExprConstant = true;422 auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) {423 allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);424 };425 walkResultLengths(visitor);426 walkResultExtents(visitor);427 return !allResultSpecExprConstant;428}429 430bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForDummyArgument(431 const PassedEntity &arg) const {432 bool allResultSpecExprConstant = true;433 auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) {434 allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);435 };436 walkDummyArgumentLengths(arg, visitor);437 walkDummyArgumentExtents(arg, visitor);438 return !allResultSpecExprConstant;439}440 441mlir::Value Fortran::lower::CallerInterface::getArgumentValue(442 const semantics::Symbol &sym) const {443 mlir::Location loc = converter.getCurrentLocation();444 const Fortran::semantics::SubprogramDetails *ifaceDetails =445 getInterfaceDetails();446 if (!ifaceDetails)447 fir::emitFatalError(448 loc, "mapping actual and dummy arguments requires an interface");449 const std::vector<Fortran::semantics::Symbol *> &dummies =450 ifaceDetails->dummyArgs();451 auto it = std::find(dummies.begin(), dummies.end(), &sym);452 if (it == dummies.end())453 fir::emitFatalError(loc, "symbol is not a dummy in this call");454 FirValue mlirArgIndex = passedArguments[it - dummies.begin()].firArgument;455 return actualInputs[mlirArgIndex];456}457 458const Fortran::semantics::Symbol *459Fortran::lower::CallerInterface::getDummySymbol(460 const PassedEntity &passedEntity) const {461 const Fortran::semantics::SubprogramDetails *ifaceDetails =462 getInterfaceDetails();463 if (!ifaceDetails)464 return nullptr;465 std::size_t argPosition = 0;466 for (const auto &arg : getPassedArguments()) {467 if (&arg == &passedEntity)468 break;469 ++argPosition;470 }471 if (argPosition >= ifaceDetails->dummyArgs().size())472 return nullptr;473 return ifaceDetails->dummyArgs()[argPosition];474}475 476mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const {477 if (passedResult)478 return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type);479 assert(saveResult && !outputs.empty());480 return outputs[0].type;481}482 483mlir::Type Fortran::lower::CallerInterface::getDummyArgumentType(484 const PassedEntity &passedEntity) const {485 return inputs[passedEntity.firArgument].type;486}487 488const Fortran::semantics::Symbol &489Fortran::lower::CallerInterface::getResultSymbol() const {490 mlir::Location loc = converter.getCurrentLocation();491 const Fortran::semantics::SubprogramDetails *ifaceDetails =492 getInterfaceDetails();493 if (!ifaceDetails)494 fir::emitFatalError(495 loc, "mapping actual and dummy arguments requires an interface");496 return ifaceDetails->result();497}498 499const Fortran::semantics::SubprogramDetails *500Fortran::lower::CallerInterface::getInterfaceDetails() const {501 if (const Fortran::semantics::Symbol *iface =502 procRef.proc().GetInterfaceSymbol())503 return iface->GetUltimate()504 .detailsIf<Fortran::semantics::SubprogramDetails>();505 return nullptr;506}507 508//===----------------------------------------------------------------------===//509// Callee side interface implementation510//===----------------------------------------------------------------------===//511 512bool Fortran::lower::CalleeInterface::hasAlternateReturns() const {513 return !funit.isMainProgram() &&514 Fortran::semantics::HasAlternateReturns(funit.getSubprogramSymbol());515}516 517std::string Fortran::lower::CalleeInterface::getMangledName() const {518 if (funit.isMainProgram())519 return fir::NameUniquer::doProgramEntry().str();520 return converter.mangleName(funit.getSubprogramSymbol());521}522 523const Fortran::semantics::Symbol *524Fortran::lower::CalleeInterface::getProcedureSymbol() const {525 if (funit.isMainProgram())526 return funit.getMainProgramSymbol();527 return &funit.getSubprogramSymbol();528}529 530mlir::Location Fortran::lower::CalleeInterface::getCalleeLocation() const {531 // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably532 // should just stash the location in the funit regardless.533 return converter.genLocation(funit.getStartingSourceLoc());534}535 536Fortran::evaluate::characteristics::Procedure537Fortran::lower::CalleeInterface::characterize() const {538 Fortran::evaluate::FoldingContext &foldingContext =539 converter.getFoldingContext();540 std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =541 Fortran::evaluate::characteristics::Procedure::Characterize(542 funit.getSubprogramSymbol(), foldingContext);543 assert(characteristic && "Fail to get characteristic from symbol");544 return *characteristic;545}546 547bool Fortran::lower::CalleeInterface::isMainProgram() const {548 return funit.isMainProgram();549}550 551mlir::func::FuncOp552Fortran::lower::CalleeInterface::addEntryBlockAndMapArguments() {553 // Check for bugs in the front end. The front end must not present multiple554 // definitions of the same procedure.555 if (!func.getBlocks().empty())556 fir::emitFatalError(func.getLoc(),557 "cannot process subprogram that was already processed");558 559 // On the callee side, directly map the mlir::value argument of the function560 // block to the Fortran symbols.561 func.addEntryBlock();562 mapPassedEntities();563 return func;564}565 566bool Fortran::lower::CalleeInterface::hasHostAssociated() const {567 return funit.parentHasTupleHostAssoc();568}569 570mlir::Type Fortran::lower::CalleeInterface::getHostAssociatedTy() const {571 assert(hasHostAssociated());572 return funit.parentHostAssoc().getArgumentType(converter);573}574 575mlir::Value Fortran::lower::CalleeInterface::getHostAssociatedTuple() const {576 assert(hasHostAssociated() || !funit.getHostAssoc().empty());577 return converter.hostAssocTupleValue();578}579 580//===----------------------------------------------------------------------===//581// CallInterface implementation: this part is common to both caller and callee.582//===----------------------------------------------------------------------===//583 584static void addSymbolAttribute(mlir::func::FuncOp func,585 const Fortran::semantics::Symbol &sym,586 fir::FortranProcedureFlagsEnumAttr procAttrs,587 mlir::MLIRContext &mlirContext) {588 const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();589 // The link between an internal procedure and its host procedure is lost590 // in FIR if the host is BIND(C) since the internal mangling will not591 // allow retrieving the host bind(C) name, and therefore func.func symbol.592 // Preserve it as an attribute so that this can be later retrieved.593 if (Fortran::semantics::ClassifyProcedure(ultimate) ==594 Fortran::semantics::ProcedureDefinitionClass::Internal) {595 if (ultimate.owner().kind() ==596 Fortran::semantics::Scope::Kind::Subprogram) {597 if (const Fortran::semantics::Symbol *hostProcedure =598 ultimate.owner().symbol()) {599 std::string hostName = Fortran::lower::mangle::mangleName(600 *hostProcedure, /*keepExternalInScope=*/true);601 func->setAttr(602 fir::getHostSymbolAttrName(),603 mlir::SymbolRefAttr::get(604 &mlirContext, mlir::StringAttr::get(&mlirContext, hostName)));605 }606 } else if (ultimate.owner().kind() ==607 Fortran::semantics::Scope::Kind::MainProgram) {608 func->setAttr(fir::getHostSymbolAttrName(),609 mlir::SymbolRefAttr::get(610 &mlirContext,611 mlir::StringAttr::get(612 &mlirContext, fir::NameUniquer::doProgramEntry())));613 }614 }615 616 if (procAttrs)617 func->setAttr(fir::getFortranProcedureFlagsAttrName(), procAttrs);618 619 // Only add this on bind(C) functions for which the symbol is not reflected in620 // the current context.621 if (!Fortran::semantics::IsBindCProcedure(sym))622 return;623 std::string name =624 Fortran::lower::mangle::mangleName(sym, /*keepExternalInScope=*/true);625 func->setAttr(fir::getSymbolAttrName(),626 mlir::StringAttr::get(&mlirContext, name));627}628 629static void630setCUDAAttributes(mlir::func::FuncOp func,631 const Fortran::semantics::Symbol *sym,632 std::optional<Fortran::evaluate::characteristics::Procedure>633 characteristic) {634 if (characteristic && characteristic->cudaSubprogramAttrs) {635 func.getOperation()->setAttr(636 cuf::getProcAttrName(),637 cuf::getProcAttribute(func.getContext(),638 *characteristic->cudaSubprogramAttrs));639 }640 641 if (sym) {642 if (auto details =643 sym->GetUltimate()644 .detailsIf<Fortran::semantics::SubprogramDetails>()) {645 mlir::Type i64Ty = mlir::IntegerType::get(func.getContext(), 64);646 if (!details->cudaLaunchBounds().empty()) {647 assert(details->cudaLaunchBounds().size() >= 2 &&648 "expect at least 2 values");649 auto maxTPBAttr =650 mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[0]);651 auto minBPMAttr =652 mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[1]);653 mlir::IntegerAttr ubAttr;654 if (details->cudaLaunchBounds().size() > 2)655 ubAttr =656 mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[2]);657 func.getOperation()->setAttr(658 cuf::getLaunchBoundsAttrName(),659 cuf::LaunchBoundsAttr::get(func.getContext(), maxTPBAttr,660 minBPMAttr, ubAttr));661 }662 663 if (!details->cudaClusterDims().empty()) {664 assert(details->cudaClusterDims().size() == 3 && "expect 3 values");665 auto xAttr =666 mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[0]);667 auto yAttr =668 mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[1]);669 auto zAttr =670 mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[2]);671 func.getOperation()->setAttr(672 cuf::getClusterDimsAttrName(),673 cuf::ClusterDimsAttr::get(func.getContext(), xAttr, yAttr, zAttr));674 }675 }676 }677}678 679/// Declare drives the different actions to be performed while analyzing the680/// signature and building/finding the mlir::func::FuncOp.681template <typename T>682void Fortran::lower::CallInterface<T>::declare() {683 if (!side().isMainProgram()) {684 characteristic.emplace(side().characterize());685 bool isImplicit = characteristic->CanBeCalledViaImplicitInterface();686 determineInterface(isImplicit, *characteristic);687 }688 // No input/output for main program689 690 // Create / get funcOp for direct calls. For indirect calls (only meaningful691 // on the caller side), no funcOp has to be created here. The mlir::Value692 // holding the indirection is used when creating the fir::CallOp.693 if (!side().isIndirectCall()) {694 std::string name = side().getMangledName();695 mlir::ModuleOp module = converter.getModuleOp();696 mlir::SymbolTable *symbolTable = converter.getMLIRSymbolTable();697 func = fir::FirOpBuilder::getNamedFunction(module, symbolTable, name);698 if (!func) {699 mlir::Location loc = side().getCalleeLocation();700 mlir::MLIRContext &mlirContext = converter.getMLIRContext();701 mlir::FunctionType ty = genFunctionType();702 func =703 fir::FirOpBuilder::createFunction(loc, module, name, ty, symbolTable);704 if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol()) {705 if (side().isMainProgram()) {706 func->setAttr(fir::getSymbolAttrName(),707 mlir::StringAttr::get(&converter.getMLIRContext(),708 sym->name().ToString()));709 } else {710 addSymbolAttribute(func, *sym, getProcedureAttrs(&mlirContext),711 mlirContext);712 }713 }714 for (const auto &placeHolder : llvm::enumerate(inputs))715 if (!placeHolder.value().attributes.empty())716 func.setArgAttrs(placeHolder.index(), placeHolder.value().attributes);717 718 setCUDAAttributes(func, side().getProcedureSymbol(), characteristic);719 720 if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol()) {721 if (const auto &info{722 sym->GetUltimate()723 .detailsIf<Fortran::semantics::SubprogramDetails>()}) {724 if (!info->openACCRoutineInfos().empty()) {725 genOpenACCRoutineConstruct(converter, module, func,726 info->openACCRoutineInfos());727 }728 }729 }730 }731 }732}733 734/// Once the signature has been analyzed and the mlir::func::FuncOp was735/// built/found, map the fir inputs to Fortran entities (the symbols or736/// expressions).737template <typename T>738void Fortran::lower::CallInterface<T>::mapPassedEntities() {739 // map back fir inputs to passed entities740 if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) {741 assert(inputs.size() == func.front().getArguments().size() &&742 "function previously created with different number of arguments");743 for (auto [fst, snd] : llvm::zip(inputs, func.front().getArguments()))744 mapBackInputToPassedEntity(fst, snd);745 } else {746 // On the caller side, map the index of the mlir argument position747 // to Fortran ActualArguments.748 int firPosition = 0;749 for (const FirPlaceHolder &placeHolder : inputs)750 mapBackInputToPassedEntity(placeHolder, firPosition++);751 }752}753 754template <typename T>755void Fortran::lower::CallInterface<T>::mapBackInputToPassedEntity(756 const FirPlaceHolder &placeHolder, FirValue firValue) {757 PassedEntity &passedEntity =758 placeHolder.passedEntityPosition == FirPlaceHolder::resultEntityPosition759 ? passedResult.value()760 : passedArguments[placeHolder.passedEntityPosition];761 if (placeHolder.property == Property::CharLength)762 passedEntity.firLength = firValue;763 else764 passedEntity.firArgument = firValue;765}766 767/// Helpers to access ActualArgument/Symbols768static const Fortran::evaluate::ActualArguments &769getEntityContainer(const Fortran::evaluate::ProcedureRef &proc) {770 return proc.arguments();771}772 773static const std::vector<Fortran::semantics::Symbol *> &774getEntityContainer(Fortran::lower::pft::FunctionLikeUnit &funit) {775 return funit.getSubprogramSymbol()776 .get<Fortran::semantics::SubprogramDetails>()777 .dummyArgs();778}779 780static const Fortran::evaluate::ActualArgument *getDataObjectEntity(781 const std::optional<Fortran::evaluate::ActualArgument> &arg) {782 if (arg)783 return &*arg;784 return nullptr;785}786 787static const Fortran::semantics::Symbol &788getDataObjectEntity(const Fortran::semantics::Symbol *arg) {789 assert(arg && "expect symbol for data object entity");790 return *arg;791}792 793static const Fortran::evaluate::ActualArgument *794getResultEntity(const Fortran::evaluate::ProcedureRef &) {795 return nullptr;796}797 798static const Fortran::semantics::Symbol &799getResultEntity(Fortran::lower::pft::FunctionLikeUnit &funit) {800 return funit.getSubprogramSymbol()801 .get<Fortran::semantics::SubprogramDetails>()802 .result();803}804 805/// Bypass helpers to manipulate entities since they are not any symbol/actual806/// argument to associate. See SignatureBuilder below.807using FakeEntity = bool;808using FakeEntities = llvm::SmallVector<FakeEntity>;809static FakeEntities810getEntityContainer(const Fortran::evaluate::characteristics::Procedure &proc) {811 FakeEntities enities(proc.dummyArguments.size());812 return enities;813}814static const FakeEntity &getDataObjectEntity(const FakeEntity &e) { return e; }815static FakeEntity816getResultEntity(const Fortran::evaluate::characteristics::Procedure &proc) {817 return false;818}819 820/// This is the actual part that defines the FIR interface based on the821/// characteristic. It directly mutates the CallInterface members.822template <typename T>823class Fortran::lower::CallInterfaceImpl {824 using CallInterface = Fortran::lower::CallInterface<T>;825 using PassEntityBy = typename CallInterface::PassEntityBy;826 using PassedEntity = typename CallInterface::PassedEntity;827 using FirValue = typename CallInterface::FirValue;828 using FortranEntity = typename CallInterface::FortranEntity;829 using FirPlaceHolder = typename CallInterface::FirPlaceHolder;830 using Property = typename CallInterface::Property;831 using TypeAndShape = Fortran::evaluate::characteristics::TypeAndShape;832 using DummyCharacteristics =833 Fortran::evaluate::characteristics::DummyArgument;834 835public:836 CallInterfaceImpl(CallInterface &i)837 : interface(i), mlirContext{i.converter.getMLIRContext()} {}838 839 void buildImplicitInterface(840 const Fortran::evaluate::characteristics::Procedure &procedure) {841 // Handle result842 if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>843 &result = procedure.functionResult)844 handleImplicitResult(*result, procedure.IsBindC());845 else if (interface.side().hasAlternateReturns())846 addFirResult(mlir::IndexType::get(&mlirContext),847 FirPlaceHolder::resultEntityPosition, Property::Value);848 // Handle arguments849 const auto &argumentEntities =850 getEntityContainer(interface.side().getCallDescription());851 for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {852 const Fortran::evaluate::characteristics::DummyArgument853 &argCharacteristics = std::get<0>(pair);854 Fortran::common::visit(855 Fortran::common::visitors{856 [&](const auto &dummy) {857 const auto &entity = getDataObjectEntity(std::get<1>(pair));858 handleImplicitDummy(&argCharacteristics, dummy, entity);859 },860 [&](const Fortran::evaluate::characteristics::AlternateReturn &) {861 // nothing to do862 },863 },864 argCharacteristics.u);865 }866 }867 868 void buildExplicitInterface(869 const Fortran::evaluate::characteristics::Procedure &procedure) {870 bool isBindC = procedure.IsBindC();871 // Handle result872 if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>873 &result = procedure.functionResult) {874 if (result->CanBeReturnedViaImplicitInterface())875 handleImplicitResult(*result, isBindC);876 else877 handleExplicitResult(*result);878 } else if (interface.side().hasAlternateReturns()) {879 addFirResult(mlir::IndexType::get(&mlirContext),880 FirPlaceHolder::resultEntityPosition, Property::Value);881 }882 // Handle arguments883 const auto &argumentEntities =884 getEntityContainer(interface.side().getCallDescription());885 for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {886 const Fortran::evaluate::characteristics::DummyArgument887 &argCharacteristics = std::get<0>(pair);888 Fortran::common::visit(889 Fortran::common::visitors{890 [&](const Fortran::evaluate::characteristics::DummyDataObject891 &dummy) {892 const auto &entity = getDataObjectEntity(std::get<1>(pair));893 if (!isBindC && dummy.CanBePassedViaImplicitInterface())894 handleImplicitDummy(&argCharacteristics, dummy, entity);895 else896 handleExplicitDummy(&argCharacteristics, dummy, entity,897 isBindC);898 },899 [&](const Fortran::evaluate::characteristics::DummyProcedure900 &dummy) {901 const auto &entity = getDataObjectEntity(std::get<1>(pair));902 handleImplicitDummy(&argCharacteristics, dummy, entity);903 },904 [&](const Fortran::evaluate::characteristics::AlternateReturn &) {905 // nothing to do906 },907 },908 argCharacteristics.u);909 }910 }911 912 void appendHostAssocTupleArg(mlir::Type tupTy) {913 mlir::MLIRContext *ctxt = tupTy.getContext();914 addFirOperand(tupTy, nextPassedArgPosition(), Property::BaseAddress,915 {mlir::NamedAttribute{916 mlir::StringAttr::get(ctxt, fir::getHostAssocAttrName()),917 mlir::UnitAttr::get(ctxt)}});918 interface.passedArguments.emplace_back(919 PassedEntity{PassEntityBy::BaseAddress, std::nullopt,920 interface.side().getHostAssociatedTuple(), emptyValue()});921 }922 923 static std::optional<Fortran::evaluate::DynamicType> getResultDynamicType(924 const Fortran::evaluate::characteristics::Procedure &procedure) {925 if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>926 &result = procedure.functionResult)927 if (const auto *resultTypeAndShape = result->GetTypeAndShape())928 return resultTypeAndShape->type();929 return std::nullopt;930 }931 932 static bool mustPassLengthWithDummyProcedure(933 const Fortran::evaluate::characteristics::Procedure &procedure) {934 // When passing a character function designator `bar` as dummy procedure to935 // `foo` (e.g. `foo(bar)`), pass the result length of `bar` to `foo` so that936 // `bar` can be called inside `foo` even if its length is assumed there.937 // From an ABI perspective, the extra length argument must be handled938 // exactly as if passing a character object. Using an argument of939 // fir.boxchar type gives the expected behavior: after codegen, the940 // fir.boxchar lengths are added after all the arguments as extra value941 // arguments (the extra arguments order is the order of the fir.boxchar).942 943 // This ABI is compatible with ifort, nag, nvfortran, and xlf, but not944 // gfortran. Gfortran does not pass the length and is therefore unable to945 // handle later call to `bar` in `foo` where the length would be assumed. If946 // the result is an array, nag and ifort and xlf still pass the length, but947 // not nvfortran (and gfortran). It is not clear it is possible to call an948 // array function with assumed length (f18 forbides defining such949 // interfaces). Hence, passing the length is most likely useless, but stick950 // with ifort/nag/xlf interface here.951 if (std::optional<Fortran::evaluate::DynamicType> type =952 getResultDynamicType(procedure))953 return type->category() == Fortran::common::TypeCategory::Character;954 return false;955 }956 957private:958 void handleImplicitResult(959 const Fortran::evaluate::characteristics::FunctionResult &result,960 bool isBindC) {961 if (auto proc{result.IsProcedurePointer()}) {962 mlir::Type mlirType = fir::BoxProcType::get(963 &mlirContext, getProcedureType(*proc, interface.converter));964 addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,965 Property::Value);966 return;967 }968 const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =969 result.GetTypeAndShape();970 assert(typeAndShape && "expect type for non proc pointer result");971 Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();972 // Character result allocated by caller and passed as hidden arguments973 if (dynamicType.category() == Fortran::common::TypeCategory::Character) {974 if (isBindC) {975 mlir::Type mlirType = translateDynamicType(dynamicType);976 addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,977 Property::Value);978 } else {979 handleImplicitCharacterResult(dynamicType);980 }981 } else if (dynamicType.category() ==982 Fortran::common::TypeCategory::Derived) {983 if (!dynamicType.GetDerivedTypeSpec().IsVectorType()) {984 // Derived result need to be allocated by the caller and the result985 // value must be saved. Derived type in implicit interface cannot have986 // length parameters.987 setSaveResult();988 }989 mlir::Type mlirType = translateDynamicType(dynamicType);990 addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,991 Property::Value);992 } else {993 // All result other than characters/derived are simply returned by value994 // in implicit interfaces995 mlir::Type mlirType =996 getConverter().genType(dynamicType.category(), dynamicType.kind());997 addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,998 Property::Value);999 }1000 }1001 void1002 handleImplicitCharacterResult(const Fortran::evaluate::DynamicType &type) {1003 int resultPosition = FirPlaceHolder::resultEntityPosition;1004 setPassedResult(PassEntityBy::AddressAndLength,1005 getResultEntity(interface.side().getCallDescription()));1006 mlir::Type lenTy = mlir::IndexType::get(&mlirContext);1007 std::optional<std::int64_t> constantLen = type.knownLength();1008 fir::CharacterType::LenType len =1009 constantLen ? *constantLen : fir::CharacterType::unknownLen();1010 mlir::Type charRefTy = fir::ReferenceType::get(1011 fir::CharacterType::get(&mlirContext, type.kind(), len));1012 mlir::Type boxCharTy = fir::BoxCharType::get(&mlirContext, type.kind());1013 addFirOperand(charRefTy, resultPosition, Property::CharAddress);1014 addFirOperand(lenTy, resultPosition, Property::CharLength);1015 /// For now, also return it by boxchar1016 addFirResult(boxCharTy, resultPosition, Property::BoxChar);1017 }1018 1019 /// Return a vector with an attribute with the name of the argument if this1020 /// is a callee interface and the name is available. Otherwise, just return1021 /// an empty vector.1022 llvm::SmallVector<mlir::NamedAttribute>1023 dummyNameAttr(const FortranEntity &entity) {1024 if constexpr (std::is_same_v<FortranEntity,1025 std::optional<Fortran::common::Reference<1026 const Fortran::semantics::Symbol>>>) {1027 if (entity.has_value()) {1028 const Fortran::semantics::Symbol *argument = &*entity.value();1029 // "fir.bindc_name" is used for arguments for the sake of consistency1030 // with other attributes carrying surface syntax names in FIR.1031 return {mlir::NamedAttribute(1032 mlir::StringAttr::get(&mlirContext, "fir.bindc_name"),1033 mlir::StringAttr::get(&mlirContext,1034 toStringRef(argument->name())))};1035 }1036 }1037 return {};1038 }1039 1040 mlir::Type1041 getRefType(Fortran::evaluate::DynamicType dynamicType,1042 const Fortran::evaluate::characteristics::DummyDataObject &obj) {1043 mlir::Type type = translateDynamicType(dynamicType);1044 if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))1045 type = fir::SequenceType::get(*bounds, type);1046 return fir::ReferenceType::get(type);1047 }1048 1049 void handleImplicitDummy(1050 const DummyCharacteristics *characteristics,1051 const Fortran::evaluate::characteristics::DummyDataObject &obj,1052 const FortranEntity &entity) {1053 Fortran::evaluate::DynamicType dynamicType = obj.type.type();1054 if constexpr (std::is_same_v<FortranEntity,1055 const Fortran::evaluate::ActualArgument *>) {1056 if (entity) {1057 if (entity->isPercentVal()) {1058 mlir::Type type = translateDynamicType(dynamicType);1059 addFirOperand(type, nextPassedArgPosition(), Property::Value,1060 dummyNameAttr(entity));1061 addPassedArg(PassEntityBy::Value, entity, characteristics);1062 return;1063 }1064 if (entity->isPercentRef()) {1065 mlir::Type refType = getRefType(dynamicType, obj);1066 addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,1067 dummyNameAttr(entity));1068 addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);1069 return;1070 }1071 }1072 }1073 if (dynamicType.category() == Fortran::common::TypeCategory::Character) {1074 mlir::Type boxCharTy =1075 fir::BoxCharType::get(&mlirContext, dynamicType.kind());1076 addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,1077 dummyNameAttr(entity));1078 addPassedArg(PassEntityBy::BoxChar, entity, characteristics);1079 } else {1080 // non-PDT derived type allowed in implicit interface.1081 mlir::Type refType = getRefType(dynamicType, obj);1082 addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,1083 dummyNameAttr(entity));1084 addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);1085 }1086 }1087 1088 mlir::Type1089 translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) {1090 Fortran::common::TypeCategory cat = dynamicType.category();1091 // DERIVED1092 if (cat == Fortran::common::TypeCategory::Derived) {1093 if (dynamicType.IsUnlimitedPolymorphic())1094 return mlir::NoneType::get(&mlirContext);1095 return getConverter().genType(dynamicType.GetDerivedTypeSpec());1096 }1097 // CHARACTER with compile time constant length.1098 if (cat == Fortran::common::TypeCategory::Character)1099 if (std::optional<std::int64_t> constantLen =1100 toInt64(dynamicType.GetCharLength()))1101 return getConverter().genType(cat, dynamicType.kind(), {*constantLen});1102 // INTEGER, REAL, LOGICAL, COMPLEX, and CHARACTER with dynamic length.1103 return getConverter().genType(cat, dynamicType.kind());1104 }1105 1106 void handleExplicitDummy(1107 const DummyCharacteristics *characteristics,1108 const Fortran::evaluate::characteristics::DummyDataObject &obj,1109 const FortranEntity &entity, bool isBindC) {1110 using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr;1111 1112 bool isValueAttr = false;1113 [[maybe_unused]] mlir::Location loc =1114 interface.converter.getCurrentLocation();1115 llvm::SmallVector<mlir::NamedAttribute> attrs = dummyNameAttr(entity);1116 auto addMLIRAttr = [&](llvm::StringRef attr) {1117 attrs.emplace_back(mlir::StringAttr::get(&mlirContext, attr),1118 mlir::UnitAttr::get(&mlirContext));1119 };1120 if (obj.attrs.test(Attrs::Optional))1121 addMLIRAttr(fir::getOptionalAttrName());1122 if (obj.attrs.test(Attrs::Contiguous))1123 addMLIRAttr(fir::getContiguousAttrName());1124 if (obj.attrs.test(Attrs::Value))1125 isValueAttr = true; // TODO: do we want an mlir::Attribute as well?1126 1127 // obj.attrs.test(Attrs::Asynchronous) does not impact the way the argument1128 // is passed given flang implement asynch IO synchronously. However, it's1129 // added to determine whether the argument is captured.1130 // TODO: it would be safer to treat them as volatile because since Fortran1131 // 2018 asynchronous can also be used for C defined asynchronous user1132 // processes (see 18.10.4 Asynchronous communication).1133 if (obj.attrs.test(Attrs::Asynchronous))1134 addMLIRAttr(fir::getAsynchronousAttrName());1135 if (obj.attrs.test(Attrs::Target))1136 addMLIRAttr(fir::getTargetAttrName());1137 if (obj.cudaDataAttr)1138 attrs.emplace_back(1139 mlir::StringAttr::get(&mlirContext, cuf::getDataAttrName()),1140 cuf::getDataAttribute(&mlirContext, obj.cudaDataAttr));1141 1142 // TODO: intents that require special care (e.g finalization)1143 1144 if (obj.type.corank() > 0)1145 TODO(loc, "coarray: dummy argument coarray in procedure interface");1146 1147 // So far assume that if the argument cannot be passed by implicit interface1148 // it must be by box. That may no be always true (e.g for simple optionals)1149 1150 Fortran::evaluate::DynamicType dynamicType = obj.type.type();1151 mlir::Type type = translateDynamicType(dynamicType);1152 if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))1153 type = fir::SequenceType::get(*bounds, type);1154 if (obj.attrs.test(Attrs::Allocatable))1155 type = fir::HeapType::get(type);1156 if (obj.attrs.test(Attrs::Pointer))1157 type = fir::PointerType::get(type);1158 mlir::Type boxType = fir::wrapInClassOrBoxType(1159 type, obj.type.type().IsPolymorphic(), obj.type.type().IsAssumedType());1160 1161 if (obj.attrs.test(Attrs::Allocatable) || obj.attrs.test(Attrs::Pointer)) {1162 // Pass as fir.ref<fir.box> or fir.ref<fir.class>1163 const bool isVolatile = obj.attrs.test(Attrs::Volatile);1164 mlir::Type boxRefType = fir::ReferenceType::get(boxType, isVolatile);1165 addFirOperand(boxRefType, nextPassedArgPosition(), Property::MutableBox,1166 attrs);1167 addPassedArg(PassEntityBy::MutableBox, entity, characteristics);1168 } else if (obj.IsPassedByDescriptor(isBindC)) {1169 // Pass as fir.box or fir.class1170 if (isValueAttr &&1171 !getConverter().getLoweringOptions().getLowerToHighLevelFIR())1172 TODO(loc, "assumed shape dummy argument with VALUE attribute");1173 addFirOperand(boxType, nextPassedArgPosition(), Property::Box, attrs);1174 addPassedArg(PassEntityBy::Box, entity, characteristics);1175 } else if (dynamicType.category() ==1176 Fortran::common::TypeCategory::Character) {1177 if (isValueAttr && isBindC) {1178 // Pass as fir.char<1>1179 mlir::Type charTy =1180 fir::CharacterType::getSingleton(&mlirContext, dynamicType.kind());1181 addFirOperand(charTy, nextPassedArgPosition(), Property::Value, attrs);1182 addPassedArg(PassEntityBy::Value, entity, characteristics);1183 } else {1184 // Pass as fir.box_char1185 mlir::Type boxCharTy =1186 fir::BoxCharType::get(&mlirContext, dynamicType.kind());1187 addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,1188 attrs);1189 addPassedArg(isValueAttr ? PassEntityBy::CharBoxValueAttribute1190 : PassEntityBy::BoxChar,1191 entity, characteristics);1192 }1193 } else {1194 // Pass as fir.ref unless it's by VALUE and BIND(C). Also pass-by-value1195 // for numerical/logical scalar without OPTIONAL so that the behavior is1196 // consistent with gfortran/nvfortran.1197 // TODO: pass-by-value for derived type is not supported yet1198 mlir::Type passType = fir::ReferenceType::get(type);1199 PassEntityBy passBy = PassEntityBy::BaseAddress;1200 Property prop = Property::BaseAddress;1201 if (isValueAttr) {1202 bool isBuiltinCptrType = fir::isa_builtin_cptr_type(type);1203 if (isBindC || (!mlir::isa<fir::SequenceType>(type) &&1204 !obj.attrs.test(Attrs::Optional) &&1205 (dynamicType.category() !=1206 Fortran::common::TypeCategory::Derived ||1207 isBuiltinCptrType))) {1208 passBy = PassEntityBy::Value;1209 prop = Property::Value;1210 if (isBuiltinCptrType) {1211 auto recTy = mlir::dyn_cast<fir::RecordType>(type);1212 mlir::Type fieldTy = recTy.getTypeList()[0].second;1213 passType = fir::ReferenceType::get(fieldTy);1214 } else {1215 passType = type;1216 }1217 } else {1218 passBy = PassEntityBy::BaseAddressValueAttribute;1219 }1220 }1221 addFirOperand(passType, nextPassedArgPosition(), prop, attrs);1222 addPassedArg(passBy, entity, characteristics);1223 }1224 }1225 1226 void handleImplicitDummy(1227 const DummyCharacteristics *characteristics,1228 const Fortran::evaluate::characteristics::DummyProcedure &proc,1229 const FortranEntity &entity) {1230 if (!interface.converter.getLoweringOptions().getLowerToHighLevelFIR() &&1231 proc.attrs.test(1232 Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer))1233 TODO(interface.converter.getCurrentLocation(),1234 "procedure pointer arguments");1235 const Fortran::evaluate::characteristics::Procedure &procedure =1236 proc.procedure.value();1237 mlir::Type funcType =1238 getProcedureDesignatorType(&procedure, interface.converter);1239 if (proc.attrs.test(Fortran::evaluate::characteristics::DummyProcedure::1240 Attr::Pointer)) {1241 // Prodecure pointer dummy argument.1242 funcType = fir::ReferenceType::get(funcType);1243 addFirOperand(funcType, nextPassedArgPosition(), Property::BoxProcRef);1244 addPassedArg(PassEntityBy::BoxProcRef, entity, characteristics);1245 return;1246 }1247 // Otherwise, it is a dummy procedure.1248 std::optional<Fortran::evaluate::DynamicType> resultTy =1249 getResultDynamicType(procedure);1250 if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {1251 // The result length of dummy procedures that are character functions must1252 // be passed so that the dummy procedure can be called if it has assumed1253 // length on the callee side.1254 mlir::Type tupleType =1255 fir::factory::getCharacterProcedureTupleType(funcType);1256 llvm::StringRef charProcAttr = fir::getCharacterProcedureDummyAttrName();1257 addFirOperand(tupleType, nextPassedArgPosition(), Property::CharProcTuple,1258 {mlir::NamedAttribute{1259 mlir::StringAttr::get(&mlirContext, charProcAttr),1260 mlir::UnitAttr::get(&mlirContext)}});1261 addPassedArg(PassEntityBy::CharProcTuple, entity, characteristics);1262 return;1263 }1264 addFirOperand(funcType, nextPassedArgPosition(), Property::BaseAddress);1265 addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);1266 }1267 1268 void handleExplicitResult(1269 const Fortran::evaluate::characteristics::FunctionResult &result) {1270 using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;1271 mlir::Type mlirType;1272 if (auto proc{result.IsProcedurePointer()}) {1273 mlirType = fir::BoxProcType::get(1274 &mlirContext, getProcedureType(*proc, interface.converter));1275 addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,1276 Property::Value);1277 return;1278 }1279 const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =1280 result.GetTypeAndShape();1281 assert(typeAndShape && "expect type for non proc pointer result");1282 mlirType = translateDynamicType(typeAndShape->type());1283 const auto *resTypeAndShape{result.GetTypeAndShape()};1284 bool resIsPolymorphic =1285 resTypeAndShape && resTypeAndShape->type().IsPolymorphic();1286 bool resIsAssumedType =1287 resTypeAndShape && resTypeAndShape->type().IsAssumedType();1288 if (std::optional<fir::SequenceType::Shape> bounds =1289 getBounds(*typeAndShape))1290 mlirType = fir::SequenceType::get(*bounds, mlirType);1291 if (result.attrs.test(Attr::Allocatable))1292 mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),1293 resIsPolymorphic, resIsAssumedType);1294 if (result.attrs.test(Attr::Pointer))1295 mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),1296 resIsPolymorphic, resIsAssumedType);1297 1298 if (fir::isa_char(mlirType)) {1299 // Character scalar results must be passed as arguments in lowering so1300 // that an assumed length character function callee can access the1301 // result length. A function with a result requiring an explicit1302 // interface does not have to be compatible with assumed length1303 // function, but most compilers supports it.1304 handleImplicitCharacterResult(typeAndShape->type());1305 return;1306 }1307 1308 addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,1309 Property::Value);1310 // Explicit results require the caller to allocate the storage and save the1311 // function result in the storage with a fir.save_result.1312 setSaveResult();1313 }1314 1315 // Return nullopt for scalars, empty vector for assumed rank, and a vector1316 // with the shape (may contain unknown extents) for arrays.1317 std::optional<fir::SequenceType::Shape> getBounds(1318 const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape) {1319 if (typeAndShape.shape() && typeAndShape.shape()->empty())1320 return std::nullopt;1321 fir::SequenceType::Shape bounds;1322 if (typeAndShape.shape())1323 for (const std::optional<Fortran::evaluate::ExtentExpr> &extent :1324 *typeAndShape.shape()) {1325 fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();1326 if (std::optional<std::int64_t> i = toInt64(extent))1327 bound = *i;1328 bounds.emplace_back(bound);1329 }1330 return bounds;1331 }1332 std::optional<std::int64_t>1333 toInt64(std::optional<1334 Fortran::evaluate::Expr<Fortran::evaluate::SubscriptInteger>>1335 expr) {1336 if (expr)1337 return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(1338 getConverter().getFoldingContext(), toEvExpr(*expr)));1339 return std::nullopt;1340 }1341 void addFirOperand(mlir::Type type, int entityPosition, Property p,1342 llvm::ArrayRef<mlir::NamedAttribute> attributes = {}) {1343 interface.inputs.emplace_back(1344 FirPlaceHolder{type, entityPosition, p, attributes});1345 }1346 void addFirResult(mlir::Type type, int entityPosition, Property p,1347 llvm::ArrayRef<mlir::NamedAttribute> attributes = {}) {1348 interface.outputs.emplace_back(1349 FirPlaceHolder{type, entityPosition, p, attributes});1350 }1351 void addPassedArg(PassEntityBy p, FortranEntity entity,1352 const DummyCharacteristics *characteristics) {1353 interface.passedArguments.emplace_back(1354 PassedEntity{p, entity, emptyValue(), emptyValue(), characteristics});1355 }1356 void setPassedResult(PassEntityBy p, FortranEntity entity) {1357 interface.passedResult =1358 PassedEntity{p, entity, emptyValue(), emptyValue()};1359 }1360 void setSaveResult() { interface.saveResult = true; }1361 int nextPassedArgPosition() { return interface.passedArguments.size(); }1362 1363 static FirValue emptyValue() {1364 if constexpr (std::is_same_v<Fortran::lower::CalleeInterface, T>) {1365 return {};1366 } else {1367 return -1;1368 }1369 }1370 1371 Fortran::lower::AbstractConverter &getConverter() {1372 return interface.converter;1373 }1374 CallInterface &interface;1375 mlir::MLIRContext &mlirContext;1376};1377 1378template <typename T>1379bool Fortran::lower::CallInterface<T>::PassedEntity::isOptional() const {1380 if (!characteristics)1381 return false;1382 return characteristics->IsOptional();1383}1384template <typename T>1385bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeModifiedByCall()1386 const {1387 if (!characteristics)1388 return true;1389 if (characteristics->GetIntent() == Fortran::common::Intent::In)1390 return false;1391 return !hasValueAttribute();1392}1393template <typename T>1394bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeReadByCall() const {1395 if (!characteristics)1396 return true;1397 return characteristics->GetIntent() != Fortran::common::Intent::Out;1398}1399 1400template <typename T>1401bool Fortran::lower::CallInterface<T>::PassedEntity::testTKR(1402 Fortran::common::IgnoreTKR flag) const {1403 if (!characteristics)1404 return false;1405 const auto *dummy =1406 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(1407 &characteristics->u);1408 if (!dummy)1409 return false;1410 return dummy->ignoreTKR.test(flag);1411}1412 1413template <typename T>1414bool Fortran::lower::CallInterface<T>::PassedEntity::isIntentOut() const {1415 if (!characteristics)1416 return true;1417 return characteristics->GetIntent() == Fortran::common::Intent::Out;1418}1419template <typename T>1420bool Fortran::lower::CallInterface<T>::PassedEntity::mustBeMadeContiguous()1421 const {1422 if (!characteristics)1423 return true;1424 const auto *dummy =1425 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(1426 &characteristics->u);1427 if (!dummy)1428 return false;1429 const auto &shapeAttrs = dummy->type.attrs();1430 using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attr;1431 if (shapeAttrs.test(ShapeAttrs::AssumedRank) ||1432 shapeAttrs.test(ShapeAttrs::AssumedShape))1433 return dummy->attrs.test(1434 Fortran::evaluate::characteristics::DummyDataObject::Attr::Contiguous);1435 if (shapeAttrs.test(ShapeAttrs::DeferredShape))1436 return false;1437 // Explicit shape arrays are contiguous.1438 return dummy->type.Rank() > 0;1439}1440 1441template <typename T>1442bool Fortran::lower::CallInterface<T>::PassedEntity::hasValueAttribute() const {1443 if (!characteristics)1444 return false;1445 const auto *dummy =1446 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(1447 &characteristics->u);1448 return dummy &&1449 dummy->attrs.test(1450 Fortran::evaluate::characteristics::DummyDataObject::Attr::Value);1451}1452 1453template <typename T>1454bool Fortran::lower::CallInterface<T>::PassedEntity::hasAllocatableAttribute()1455 const {1456 if (!characteristics)1457 return false;1458 const auto *dummy =1459 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(1460 &characteristics->u);1461 using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr;1462 return dummy && dummy->attrs.test(Attrs::Allocatable);1463}1464 1465template <typename T>1466bool Fortran::lower::CallInterface<1467 T>::PassedEntity::mayRequireIntentoutFinalization() const {1468 // Conservatively assume that the finalization is needed.1469 if (!characteristics)1470 return true;1471 1472 // No INTENT(OUT) dummy arguments do not require finalization on entry.1473 if (!isIntentOut())1474 return false;1475 1476 const auto *dummy =1477 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(1478 &characteristics->u);1479 if (!dummy)1480 return true;1481 1482 // POINTER/ALLOCATABLE dummy arguments do not require finalization.1483 using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr;1484 if (dummy->attrs.test(Attrs::Allocatable) ||1485 dummy->attrs.test(Attrs::Pointer))1486 return false;1487 1488 // Polymorphic and unlimited polymorphic INTENT(OUT) dummy arguments1489 // may need finalization.1490 const Fortran::evaluate::DynamicType &type = dummy->type.type();1491 if (type.IsPolymorphic() || type.IsUnlimitedPolymorphic())1492 return true;1493 1494 // INTENT(OUT) dummy arguments of derived types require finalization,1495 // if their type has finalization.1496 const Fortran::semantics::DerivedTypeSpec *derived =1497 Fortran::evaluate::GetDerivedTypeSpec(type);1498 if (!derived)1499 return false;1500 1501 return Fortran::semantics::IsFinalizable(*derived);1502}1503 1504template <typename T>1505bool Fortran::lower::CallInterface<1506 T>::PassedEntity::isSequenceAssociatedDescriptor() const {1507 if (!characteristics || passBy != PassEntityBy::Box)1508 return false;1509 const auto *dummy =1510 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(1511 &characteristics->u);1512 return dummy && dummy->type.CanBeSequenceAssociated();1513}1514 1515template <typename T>1516void Fortran::lower::CallInterface<T>::determineInterface(1517 bool isImplicit,1518 const Fortran::evaluate::characteristics::Procedure &procedure) {1519 CallInterfaceImpl<T> impl(*this);1520 if (isImplicit)1521 impl.buildImplicitInterface(procedure);1522 else1523 impl.buildExplicitInterface(procedure);1524 // We only expect the extra host asspciations argument from the callee side as1525 // the definition of internal procedures will be present, and we'll always1526 // have a FuncOp definition in the ModuleOp, when lowering.1527 if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) {1528 if (side().hasHostAssociated())1529 impl.appendHostAssocTupleArg(side().getHostAssociatedTy());1530 }1531}1532 1533template <typename T>1534mlir::FunctionType Fortran::lower::CallInterface<T>::genFunctionType() {1535 llvm::SmallVector<mlir::Type> returnTys;1536 llvm::SmallVector<mlir::Type> inputTys;1537 for (const FirPlaceHolder &placeHolder : outputs)1538 returnTys.emplace_back(placeHolder.type);1539 for (const FirPlaceHolder &placeHolder : inputs)1540 inputTys.emplace_back(placeHolder.type);1541 return mlir::FunctionType::get(&converter.getMLIRContext(), inputTys,1542 returnTys);1543}1544 1545template <typename T>1546llvm::SmallVector<mlir::Type>1547Fortran::lower::CallInterface<T>::getResultType() const {1548 llvm::SmallVector<mlir::Type> types;1549 for (const FirPlaceHolder &out : outputs)1550 types.emplace_back(out.type);1551 return types;1552}1553 1554template <typename T>1555fir::FortranProcedureFlagsEnumAttr1556Fortran::lower::CallInterface<T>::getProcedureAttrs(1557 mlir::MLIRContext *mlirContext) const {1558 fir::FortranProcedureFlagsEnum flags = fir::FortranProcedureFlagsEnum::none;1559 if (characteristic) {1560 if (characteristic->IsBindC())1561 flags = flags | fir::FortranProcedureFlagsEnum::bind_c;1562 if (characteristic->IsPure())1563 flags = flags | fir::FortranProcedureFlagsEnum::pure;1564 if (characteristic->IsElemental())1565 flags = flags | fir::FortranProcedureFlagsEnum::elemental;1566 // TODO:1567 // - SIMPLE: F2023, not yet handled by semantics.1568 }1569 1570 if constexpr (std::is_same_v<Fortran::lower::CalleeInterface, T>) {1571 // Only gather and set NON_RECURSIVE for procedure definition. It is1572 // meaningless on calls since this is not part of Fortran characteristics1573 // (Fortran 2023 15.3.1) so there is no way to always know if the procedure1574 // called is recursive or not.1575 if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol()) {1576 // Note: By default procedures are RECURSIVE unless1577 // -fno-automatic/-save/-Msave is set. NON_RECURSIVE is is made explicit1578 // in that case in FIR.1579 if (sym->attrs().test(Fortran::semantics::Attr::NON_RECURSIVE) ||1580 (sym->owner().context().languageFeatures().IsEnabled(1581 Fortran::common::LanguageFeature::DefaultSave) &&1582 !sym->attrs().test(Fortran::semantics::Attr::RECURSIVE))) {1583 flags = flags | fir::FortranProcedureFlagsEnum::non_recursive;1584 }1585 }1586 }1587 if (flags != fir::FortranProcedureFlagsEnum::none)1588 return fir::FortranProcedureFlagsEnumAttr::get(mlirContext, flags);1589 return nullptr;1590}1591 1592template class Fortran::lower::CallInterface<Fortran::lower::CalleeInterface>;1593template class Fortran::lower::CallInterface<Fortran::lower::CallerInterface>;1594 1595//===----------------------------------------------------------------------===//1596// Function Type Translation1597//===----------------------------------------------------------------------===//1598 1599/// Build signature from characteristics when there is no Fortran entity to1600/// associate with the arguments (i.e, this is not a call site or a procedure1601/// declaration. This is needed when dealing with function pointers/dummy1602/// arguments.1603 1604class SignatureBuilder;1605template <>1606struct Fortran::lower::PassedEntityTypes<SignatureBuilder> {1607 using FortranEntity = FakeEntity;1608 using FirValue = int;1609};1610 1611/// SignatureBuilder is a CRTP implementation of CallInterface intended to1612/// help translating characteristics::Procedure to mlir::FunctionType using1613/// the CallInterface translation.1614class SignatureBuilder1615 : public Fortran::lower::CallInterface<SignatureBuilder> {1616public:1617 SignatureBuilder(const Fortran::evaluate::characteristics::Procedure &p,1618 Fortran::lower::AbstractConverter &c, bool forceImplicit)1619 : CallInterface{c}, proc{p} {1620 bool isImplicit = forceImplicit || proc.CanBeCalledViaImplicitInterface();1621 determineInterface(isImplicit, proc);1622 }1623 SignatureBuilder(const Fortran::evaluate::ProcedureDesignator &procDes,1624 Fortran::lower::AbstractConverter &c)1625 : CallInterface{c}, procDesignator{&procDes},1626 proc{Fortran::evaluate::characteristics::Procedure::Characterize(1627 procDes, converter.getFoldingContext(), /*emitError=*/false)1628 .value()} {}1629 /// Does the procedure characteristics being translated have alternate1630 /// returns ?1631 bool hasAlternateReturns() const {1632 for (const Fortran::evaluate::characteristics::DummyArgument &dummy :1633 proc.dummyArguments)1634 if (std::holds_alternative<1635 Fortran::evaluate::characteristics::AlternateReturn>(dummy.u))1636 return true;1637 return false;1638 };1639 1640 /// This is only here to fulfill CRTP dependencies and should not be called.1641 std::string getMangledName() const {1642 if (procDesignator)1643 return getProcMangledName(*procDesignator, converter);1644 fir::emitFatalError(1645 converter.getCurrentLocation(),1646 "should not query name when only building function type");1647 }1648 1649 /// This is only here to fulfill CRTP dependencies and should not be called.1650 mlir::Location getCalleeLocation() const {1651 if (procDesignator)1652 return getProcedureDesignatorLoc(*procDesignator, converter);1653 return converter.getCurrentLocation();1654 }1655 1656 const Fortran::semantics::Symbol *getProcedureSymbol() const {1657 if (procDesignator)1658 return procDesignator->GetSymbol();1659 return nullptr;1660 };1661 1662 Fortran::evaluate::characteristics::Procedure characterize() const {1663 return proc;1664 }1665 /// SignatureBuilder cannot be used on main program.1666 static constexpr bool isMainProgram() { return false; }1667 1668 /// Return the characteristics::Procedure that is being translated to1669 /// mlir::FunctionType.1670 const Fortran::evaluate::characteristics::Procedure &1671 getCallDescription() const {1672 return proc;1673 }1674 1675 /// This is not the description of an indirect call.1676 static constexpr bool isIndirectCall() { return false; }1677 1678 /// Return the translated signature.1679 mlir::FunctionType getFunctionType() {1680 if (interfaceDetermined)1681 fir::emitFatalError(converter.getCurrentLocation(),1682 "SignatureBuilder should only be used once");1683 // Most unrestricted intrinsic characteristics have the Elemental attribute1684 // which triggers CanBeCalledViaImplicitInterface to return false. However,1685 // using implicit interface rules is just fine here.1686 bool forceImplicit =1687 procDesignator && procDesignator->GetSpecificIntrinsic();1688 bool isImplicit = forceImplicit || proc.CanBeCalledViaImplicitInterface();1689 determineInterface(isImplicit, proc);1690 interfaceDetermined = true;1691 return genFunctionType();1692 }1693 1694 mlir::func::FuncOp getOrCreateFuncOp() {1695 if (interfaceDetermined)1696 fir::emitFatalError(converter.getCurrentLocation(),1697 "SignatureBuilder should only be used once");1698 declare();1699 interfaceDetermined = true;1700 return getFuncOp();1701 }1702 1703 // Copy of base implementation.1704 static constexpr bool hasHostAssociated() { return false; }1705 mlir::Type getHostAssociatedTy() const {1706 llvm_unreachable("getting host associated type in SignatureBuilder");1707 }1708 1709private:1710 const Fortran::evaluate::ProcedureDesignator *procDesignator = nullptr;1711 Fortran::evaluate::characteristics::Procedure proc;1712 bool interfaceDetermined = false;1713};1714 1715mlir::FunctionType Fortran::lower::translateSignature(1716 const Fortran::evaluate::ProcedureDesignator &proc,1717 Fortran::lower::AbstractConverter &converter) {1718 return SignatureBuilder{proc, converter}.getFunctionType();1719}1720 1721mlir::func::FuncOp Fortran::lower::getOrDeclareFunction(1722 const Fortran::evaluate::ProcedureDesignator &proc,1723 Fortran::lower::AbstractConverter &converter) {1724 mlir::ModuleOp module = converter.getModuleOp();1725 std::string name = getProcMangledName(proc, converter);1726 mlir::func::FuncOp func = fir::FirOpBuilder::getNamedFunction(1727 module, converter.getMLIRSymbolTable(), name);1728 if (func)1729 return func;1730 1731 // getOrDeclareFunction is only used for functions not defined in the current1732 // program unit, so use the location of the procedure designator symbol, which1733 // is the first occurrence of the procedure in the program unit.1734 return SignatureBuilder{proc, converter}.getOrCreateFuncOp();1735}1736 1737// Is it required to pass a dummy procedure with \p characteristics as a tuple1738// containing the function address and the result length ?1739static bool mustPassLengthWithDummyProcedure(1740 const std::optional<Fortran::evaluate::characteristics::Procedure>1741 &characteristics) {1742 return characteristics &&1743 Fortran::lower::CallInterfaceImpl<SignatureBuilder>::1744 mustPassLengthWithDummyProcedure(*characteristics);1745}1746 1747bool Fortran::lower::mustPassLengthWithDummyProcedure(1748 const Fortran::evaluate::ProcedureDesignator &procedure,1749 Fortran::lower::AbstractConverter &converter) {1750 std::optional<Fortran::evaluate::characteristics::Procedure> characteristics =1751 Fortran::evaluate::characteristics::Procedure::Characterize(1752 procedure, converter.getFoldingContext(), /*emitError=*/false);1753 return ::mustPassLengthWithDummyProcedure(characteristics);1754}1755 1756mlir::Type Fortran::lower::getDummyProcedureType(1757 const Fortran::semantics::Symbol &dummyProc,1758 Fortran::lower::AbstractConverter &converter) {1759 std::optional<Fortran::evaluate::characteristics::Procedure> iface =1760 Fortran::evaluate::characteristics::Procedure::Characterize(1761 dummyProc, converter.getFoldingContext());1762 mlir::Type procType = getProcedureDesignatorType(1763 iface.has_value() ? &*iface : nullptr, converter);1764 if (::mustPassLengthWithDummyProcedure(iface))1765 return fir::factory::getCharacterProcedureTupleType(procType);1766 return procType;1767}1768 1769mlir::Type Fortran::lower::getDummyProcedurePointerType(1770 const Fortran::semantics::Symbol &dummyProcPtr,1771 Fortran::lower::AbstractConverter &converter) {1772 std::optional<Fortran::evaluate::characteristics::Procedure> iface =1773 Fortran::evaluate::characteristics::Procedure::Characterize(1774 dummyProcPtr, converter.getFoldingContext());1775 mlir::Type procPtrType = getProcedureDesignatorType(1776 iface.has_value() ? &*iface : nullptr, converter);1777 return fir::ReferenceType::get(procPtrType);1778}1779 1780bool Fortran::lower::isCPtrArgByValueType(mlir::Type ty) {1781 return mlir::isa<fir::ReferenceType>(ty) &&1782 fir::isa_integer(fir::unwrapRefType(ty));1783}1784 1785// Return the mlir::FunctionType of a procedure1786static mlir::FunctionType1787getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc,1788 Fortran::lower::AbstractConverter &converter) {1789 return SignatureBuilder{proc, converter, false}.genFunctionType();1790}1791