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