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

source code of flang/lib/Lower/CallInterface.cpp