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