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

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