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/PFTBuilder.h"
14 #include "flang/Lower/Support/Utils.h"
15 #include "flang/Lower/Todo.h"
16 #include "flang/Optimizer/Builder/FIRBuilder.h"
17 #include "flang/Optimizer/Dialect/FIRDialect.h"
18 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
19 #include "flang/Optimizer/Support/InternalNames.h"
20 #include "flang/Semantics/symbol.h"
21 #include "flang/Semantics/tools.h"
22 
23 //===----------------------------------------------------------------------===//
24 // BIND(C) mangling helpers
25 //===----------------------------------------------------------------------===//
26 
27 // Return the binding label (from BIND(C...)) or the mangled name of a symbol.
28 static std::string getMangledName(const Fortran::semantics::Symbol &symbol) {
29   const std::string *bindName = symbol.GetBindName();
30   return bindName ? *bindName : Fortran::lower::mangle::mangleName(symbol);
31 }
32 
33 //===----------------------------------------------------------------------===//
34 // Caller side interface implementation
35 //===----------------------------------------------------------------------===//
36 
37 bool Fortran::lower::CallerInterface::hasAlternateReturns() const {
38   return procRef.hasAlternateReturns();
39 }
40 
41 std::string Fortran::lower::CallerInterface::getMangledName() const {
42   const Fortran::evaluate::ProcedureDesignator &proc = procRef.proc();
43   if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())
44     return ::getMangledName(symbol->GetUltimate());
45   assert(proc.GetSpecificIntrinsic() &&
46          "expected intrinsic procedure in designator");
47   return proc.GetName();
48 }
49 
50 const Fortran::semantics::Symbol *
51 Fortran::lower::CallerInterface::getProcedureSymbol() const {
52   return procRef.proc().GetSymbol();
53 }
54 
55 bool Fortran::lower::CallerInterface::isIndirectCall() const {
56   if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
57     return Fortran::semantics::IsPointer(*symbol) ||
58            Fortran::semantics::IsDummy(*symbol);
59   return false;
60 }
61 
62 const Fortran::semantics::Symbol *
63 Fortran::lower::CallerInterface::getIfIndirectCallSymbol() const {
64   if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
65     if (Fortran::semantics::IsPointer(*symbol) ||
66         Fortran::semantics::IsDummy(*symbol))
67       return symbol;
68   return nullptr;
69 }
70 
71 mlir::Location Fortran::lower::CallerInterface::getCalleeLocation() const {
72   const Fortran::evaluate::ProcedureDesignator &proc = procRef.proc();
73   // FIXME: If the callee is defined in the same file but after the current
74   // unit we cannot get its location here and the funcOp is created at the
75   // wrong location (i.e, the caller location).
76   if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())
77     return converter.genLocation(symbol->name());
78   // Use current location for intrinsics.
79   return converter.getCurrentLocation();
80 }
81 
82 // Get dummy argument characteristic for a procedure with implicit interface
83 // from the actual argument characteristic. The actual argument may not be a F77
84 // entity. The attribute must be dropped and the shape, if any, must be made
85 // explicit.
86 static Fortran::evaluate::characteristics::DummyDataObject
87 asImplicitArg(Fortran::evaluate::characteristics::DummyDataObject &&dummy) {
88   Fortran::evaluate::Shape shape =
89       dummy.type.attrs().none() ? dummy.type.shape()
90                                 : Fortran::evaluate::Shape(dummy.type.Rank());
91   return Fortran::evaluate::characteristics::DummyDataObject(
92       Fortran::evaluate::characteristics::TypeAndShape(dummy.type.type(),
93                                                        std::move(shape)));
94 }
95 
96 static Fortran::evaluate::characteristics::DummyArgument
97 asImplicitArg(Fortran::evaluate::characteristics::DummyArgument &&dummy) {
98   return std::visit(
99       Fortran::common::visitors{
100           [&](Fortran::evaluate::characteristics::DummyDataObject &obj) {
101             return Fortran::evaluate::characteristics::DummyArgument(
102                 std::move(dummy.name), asImplicitArg(std::move(obj)));
103           },
104           [&](Fortran::evaluate::characteristics::DummyProcedure &proc) {
105             return Fortran::evaluate::characteristics::DummyArgument(
106                 std::move(dummy.name), std::move(proc));
107           },
108           [](Fortran::evaluate::characteristics::AlternateReturn &x) {
109             return Fortran::evaluate::characteristics::DummyArgument(
110                 std::move(x));
111           }},
112       dummy.u);
113 }
114 
115 Fortran::evaluate::characteristics::Procedure
116 Fortran::lower::CallerInterface::characterize() const {
117   Fortran::evaluate::FoldingContext &foldingContext =
118       converter.getFoldingContext();
119   std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
120       Fortran::evaluate::characteristics::Procedure::Characterize(
121           procRef.proc(), foldingContext);
122   assert(characteristic && "Failed to get characteristic from procRef");
123   // The characteristic may not contain the argument characteristic if the
124   // ProcedureDesignator has no interface.
125   if (!characteristic->HasExplicitInterface()) {
126     for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
127          procRef.arguments()) {
128       if (arg.value().isAlternateReturn()) {
129         characteristic->dummyArguments.emplace_back(
130             Fortran::evaluate::characteristics::AlternateReturn{});
131       } else {
132         // Argument cannot be optional with implicit interface
133         const Fortran::lower::SomeExpr *expr = arg.value().UnwrapExpr();
134         assert(
135             expr &&
136             "argument in call with implicit interface cannot be assumed type");
137         std::optional<Fortran::evaluate::characteristics::DummyArgument>
138             argCharacteristic =
139                 Fortran::evaluate::characteristics::DummyArgument::FromActual(
140                     "actual", *expr, foldingContext);
141         assert(argCharacteristic &&
142                "failed to characterize argument in implicit call");
143         characteristic->dummyArguments.emplace_back(
144             asImplicitArg(std::move(*argCharacteristic)));
145       }
146     }
147   }
148   return *characteristic;
149 }
150 
151 void Fortran::lower::CallerInterface::placeInput(
152     const PassedEntity &passedEntity, mlir::Value arg) {
153   assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&
154          passedEntity.firArgument >= 0 &&
155          passedEntity.passBy != CallInterface::PassEntityBy::AddressAndLength &&
156          "bad arg position");
157   actualInputs[passedEntity.firArgument] = arg;
158 }
159 
160 void Fortran::lower::CallerInterface::placeAddressAndLengthInput(
161     const PassedEntity &passedEntity, mlir::Value addr, mlir::Value len) {
162   assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&
163          static_cast<int>(actualInputs.size()) > passedEntity.firLength &&
164          passedEntity.firArgument >= 0 && passedEntity.firLength >= 0 &&
165          passedEntity.passBy == CallInterface::PassEntityBy::AddressAndLength &&
166          "bad arg position");
167   actualInputs[passedEntity.firArgument] = addr;
168   actualInputs[passedEntity.firLength] = len;
169 }
170 
171 bool Fortran::lower::CallerInterface::verifyActualInputs() const {
172   if (getNumFIRArguments() != actualInputs.size())
173     return false;
174   for (mlir::Value arg : actualInputs) {
175     if (!arg)
176       return false;
177   }
178   return true;
179 }
180 
181 void Fortran::lower::CallerInterface::walkResultLengths(
182     ExprVisitor visitor) const {
183   assert(characteristic && "characteristic was not computed");
184   const Fortran::evaluate::characteristics::FunctionResult &result =
185       characteristic->functionResult.value();
186   const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
187       result.GetTypeAndShape();
188   assert(typeAndShape && "no result type");
189   Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
190   // Visit result length specification expressions that are explicit.
191   if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
192     if (std::optional<Fortran::evaluate::ExtentExpr> length =
193             dynamicType.GetCharLength())
194       visitor(toEvExpr(*length));
195   } else if (dynamicType.category() == common::TypeCategory::Derived) {
196     const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec =
197         dynamicType.GetDerivedTypeSpec();
198     if (Fortran::semantics::CountLenParameters(derivedTypeSpec) > 0)
199       TODO(converter.getCurrentLocation(),
200            "function result with derived type length parameters");
201   }
202 }
203 
204 // Compute extent expr from shapeSpec of an explicit shape.
205 // TODO: Allow evaluate shape analysis to work in a mode where it disregards
206 // the non-constant aspects when building the shape to avoid having this here.
207 static Fortran::evaluate::ExtentExpr
208 getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {
209   const auto &ubound = shapeSpec.ubound().GetExplicit();
210   const auto &lbound = shapeSpec.lbound().GetExplicit();
211   assert(lbound && ubound && "shape must be explicit");
212   return Fortran::common::Clone(*ubound) - Fortran::common::Clone(*lbound) +
213          Fortran::evaluate::ExtentExpr{1};
214 }
215 
216 void Fortran::lower::CallerInterface::walkResultExtents(
217     ExprVisitor visitor) const {
218   // Walk directly the result symbol shape (the characteristic shape may contain
219   // descriptor inquiries to it that would fail to lower on the caller side).
220   const Fortran::semantics::Symbol *interfaceSymbol =
221       procRef.proc().GetInterfaceSymbol();
222   if (interfaceSymbol) {
223     const Fortran::semantics::Symbol &result =
224         interfaceSymbol->get<Fortran::semantics::SubprogramDetails>().result();
225     if (const auto *objectDetails =
226             result.detailsIf<Fortran::semantics::ObjectEntityDetails>())
227       if (objectDetails->shape().IsExplicitShape())
228         for (const Fortran::semantics::ShapeSpec &shapeSpec :
229              objectDetails->shape())
230           visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)));
231   } else {
232     if (procRef.Rank() != 0)
233       fir::emitFatalError(
234           converter.getCurrentLocation(),
235           "only scalar functions may not have an interface symbol");
236   }
237 }
238 
239 bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
240   assert(characteristic && "characteristic was not computed");
241   const std::optional<Fortran::evaluate::characteristics::FunctionResult>
242       &result = characteristic->functionResult;
243   if (!result || result->CanBeReturnedViaImplicitInterface() ||
244       !procRef.proc().GetInterfaceSymbol())
245     return false;
246   bool allResultSpecExprConstant = true;
247   auto visitor = [&](const Fortran::lower::SomeExpr &e) {
248     allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);
249   };
250   walkResultLengths(visitor);
251   walkResultExtents(visitor);
252   return !allResultSpecExprConstant;
253 }
254 
255 mlir::Value Fortran::lower::CallerInterface::getArgumentValue(
256     const semantics::Symbol &sym) const {
257   mlir::Location loc = converter.getCurrentLocation();
258   const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol();
259   if (!iface)
260     fir::emitFatalError(
261         loc, "mapping actual and dummy arguments requires an interface");
262   const std::vector<Fortran::semantics::Symbol *> &dummies =
263       iface->get<semantics::SubprogramDetails>().dummyArgs();
264   auto it = std::find(dummies.begin(), dummies.end(), &sym);
265   if (it == dummies.end())
266     fir::emitFatalError(loc, "symbol is not a dummy in this call");
267   FirValue mlirArgIndex = passedArguments[it - dummies.begin()].firArgument;
268   return actualInputs[mlirArgIndex];
269 }
270 
271 mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const {
272   if (passedResult)
273     return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type);
274   assert(saveResult && !outputs.empty());
275   return outputs[0].type;
276 }
277 
278 const Fortran::semantics::Symbol &
279 Fortran::lower::CallerInterface::getResultSymbol() const {
280   mlir::Location loc = converter.getCurrentLocation();
281   const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol();
282   if (!iface)
283     fir::emitFatalError(
284         loc, "mapping actual and dummy arguments requires an interface");
285   return iface->get<semantics::SubprogramDetails>().result();
286 }
287 
288 //===----------------------------------------------------------------------===//
289 // Callee side interface implementation
290 //===----------------------------------------------------------------------===//
291 
292 bool Fortran::lower::CalleeInterface::hasAlternateReturns() const {
293   return !funit.isMainProgram() &&
294          Fortran::semantics::HasAlternateReturns(funit.getSubprogramSymbol());
295 }
296 
297 std::string Fortran::lower::CalleeInterface::getMangledName() const {
298   if (funit.isMainProgram())
299     return fir::NameUniquer::doProgramEntry().str();
300   return ::getMangledName(funit.getSubprogramSymbol());
301 }
302 
303 const Fortran::semantics::Symbol *
304 Fortran::lower::CalleeInterface::getProcedureSymbol() const {
305   if (funit.isMainProgram())
306     return nullptr;
307   return &funit.getSubprogramSymbol();
308 }
309 
310 mlir::Location Fortran::lower::CalleeInterface::getCalleeLocation() const {
311   // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably
312   // should just stash the location in the funit regardless.
313   return converter.genLocation(funit.getStartingSourceLoc());
314 }
315 
316 Fortran::evaluate::characteristics::Procedure
317 Fortran::lower::CalleeInterface::characterize() const {
318   Fortran::evaluate::FoldingContext &foldingContext =
319       converter.getFoldingContext();
320   std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
321       Fortran::evaluate::characteristics::Procedure::Characterize(
322           funit.getSubprogramSymbol(), foldingContext);
323   assert(characteristic && "Fail to get characteristic from symbol");
324   return *characteristic;
325 }
326 
327 bool Fortran::lower::CalleeInterface::isMainProgram() const {
328   return funit.isMainProgram();
329 }
330 
331 mlir::FuncOp Fortran::lower::CalleeInterface::addEntryBlockAndMapArguments() {
332   // On the callee side, directly map the mlir::value argument of
333   // the function block to the Fortran symbols.
334   func.addEntryBlock();
335   mapPassedEntities();
336   return func;
337 }
338 
339 //===----------------------------------------------------------------------===//
340 // CallInterface implementation: this part is common to both callee and caller
341 // sides.
342 //===----------------------------------------------------------------------===//
343 
344 static void addSymbolAttribute(mlir::FuncOp func,
345                                const Fortran::semantics::Symbol &sym,
346                                mlir::MLIRContext &mlirContext) {
347   // Only add this on bind(C) functions for which the symbol is not reflected in
348   // the current context.
349   if (!Fortran::semantics::IsBindCProcedure(sym))
350     return;
351   std::string name =
352       Fortran::lower::mangle::mangleName(sym, /*keepExternalInScope=*/true);
353   func->setAttr(fir::getSymbolAttrName(),
354                 mlir::StringAttr::get(&mlirContext, name));
355 }
356 
357 /// Declare drives the different actions to be performed while analyzing the
358 /// signature and building/finding the mlir::FuncOp.
359 template <typename T>
360 void Fortran::lower::CallInterface<T>::declare() {
361   if (!side().isMainProgram()) {
362     characteristic.emplace(side().characterize());
363     bool isImplicit = characteristic->CanBeCalledViaImplicitInterface();
364     determineInterface(isImplicit, *characteristic);
365   }
366   // No input/output for main program
367 
368   // Create / get funcOp for direct calls. For indirect calls (only meaningful
369   // on the caller side), no funcOp has to be created here. The mlir::Value
370   // holding the indirection is used when creating the fir::CallOp.
371   if (!side().isIndirectCall()) {
372     std::string name = side().getMangledName();
373     mlir::ModuleOp module = converter.getModuleOp();
374     func = fir::FirOpBuilder::getNamedFunction(module, name);
375     if (!func) {
376       mlir::Location loc = side().getCalleeLocation();
377       mlir::FunctionType ty = genFunctionType();
378       func = fir::FirOpBuilder::createFunction(loc, module, name, ty);
379       if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol())
380         addSymbolAttribute(func, *sym, converter.getMLIRContext());
381       for (const auto &placeHolder : llvm::enumerate(inputs))
382         if (!placeHolder.value().attributes.empty())
383           func.setArgAttrs(placeHolder.index(), placeHolder.value().attributes);
384     }
385   }
386 }
387 
388 /// Once the signature has been analyzed and the mlir::FuncOp was built/found,
389 /// map the fir inputs to Fortran entities (the symbols or expressions).
390 template <typename T>
391 void Fortran::lower::CallInterface<T>::mapPassedEntities() {
392   // map back fir inputs to passed entities
393   if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) {
394     assert(inputs.size() == func.front().getArguments().size() &&
395            "function previously created with different number of arguments");
396     for (auto [fst, snd] : llvm::zip(inputs, func.front().getArguments()))
397       mapBackInputToPassedEntity(fst, snd);
398   } else {
399     // On the caller side, map the index of the mlir argument position
400     // to Fortran ActualArguments.
401     int firPosition = 0;
402     for (const FirPlaceHolder &placeHolder : inputs)
403       mapBackInputToPassedEntity(placeHolder, firPosition++);
404   }
405 }
406 
407 template <typename T>
408 void Fortran::lower::CallInterface<T>::mapBackInputToPassedEntity(
409     const FirPlaceHolder &placeHolder, FirValue firValue) {
410   PassedEntity &passedEntity =
411       placeHolder.passedEntityPosition == FirPlaceHolder::resultEntityPosition
412           ? passedResult.value()
413           : passedArguments[placeHolder.passedEntityPosition];
414   if (placeHolder.property == Property::CharLength)
415     passedEntity.firLength = firValue;
416   else
417     passedEntity.firArgument = firValue;
418 }
419 
420 /// Helpers to access ActualArgument/Symbols
421 static const Fortran::evaluate::ActualArguments &
422 getEntityContainer(const Fortran::evaluate::ProcedureRef &proc) {
423   return proc.arguments();
424 }
425 
426 static const std::vector<Fortran::semantics::Symbol *> &
427 getEntityContainer(Fortran::lower::pft::FunctionLikeUnit &funit) {
428   return funit.getSubprogramSymbol()
429       .get<Fortran::semantics::SubprogramDetails>()
430       .dummyArgs();
431 }
432 
433 static const Fortran::evaluate::ActualArgument *getDataObjectEntity(
434     const std::optional<Fortran::evaluate::ActualArgument> &arg) {
435   if (arg)
436     return &*arg;
437   return nullptr;
438 }
439 
440 static const Fortran::semantics::Symbol &
441 getDataObjectEntity(const Fortran::semantics::Symbol *arg) {
442   assert(arg && "expect symbol for data object entity");
443   return *arg;
444 }
445 
446 static const Fortran::evaluate::ActualArgument *
447 getResultEntity(const Fortran::evaluate::ProcedureRef &) {
448   return nullptr;
449 }
450 
451 static const Fortran::semantics::Symbol &
452 getResultEntity(Fortran::lower::pft::FunctionLikeUnit &funit) {
453   return funit.getSubprogramSymbol()
454       .get<Fortran::semantics::SubprogramDetails>()
455       .result();
456 }
457 
458 //===----------------------------------------------------------------------===//
459 // CallInterface implementation: this part is common to both caller and caller
460 // sides.
461 //===----------------------------------------------------------------------===//
462 
463 /// This is the actual part that defines the FIR interface based on the
464 /// characteristic. It directly mutates the CallInterface members.
465 template <typename T>
466 class Fortran::lower::CallInterfaceImpl {
467   using CallInterface = Fortran::lower::CallInterface<T>;
468   using PassEntityBy = typename CallInterface::PassEntityBy;
469   using PassedEntity = typename CallInterface::PassedEntity;
470   using FirValue = typename CallInterface::FirValue;
471   using FortranEntity = typename CallInterface::FortranEntity;
472   using FirPlaceHolder = typename CallInterface::FirPlaceHolder;
473   using Property = typename CallInterface::Property;
474   using TypeAndShape = Fortran::evaluate::characteristics::TypeAndShape;
475   using DummyCharacteristics =
476       Fortran::evaluate::characteristics::DummyArgument;
477 
478 public:
479   CallInterfaceImpl(CallInterface &i)
480       : interface(i), mlirContext{i.converter.getMLIRContext()} {}
481 
482   void buildImplicitInterface(
483       const Fortran::evaluate::characteristics::Procedure &procedure) {
484     // Handle result
485     if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
486             &result = procedure.functionResult)
487       handleImplicitResult(*result);
488     else if (interface.side().hasAlternateReturns())
489       addFirResult(mlir::IndexType::get(&mlirContext),
490                    FirPlaceHolder::resultEntityPosition, Property::Value);
491     // Handle arguments
492     const auto &argumentEntities =
493         getEntityContainer(interface.side().getCallDescription());
494     for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {
495       const Fortran::evaluate::characteristics::DummyArgument
496           &argCharacteristics = std::get<0>(pair);
497       std::visit(
498           Fortran::common::visitors{
499               [&](const auto &dummy) {
500                 const auto &entity = getDataObjectEntity(std::get<1>(pair));
501                 handleImplicitDummy(&argCharacteristics, dummy, entity);
502               },
503               [&](const Fortran::evaluate::characteristics::AlternateReturn &) {
504                 // nothing to do
505               },
506           },
507           argCharacteristics.u);
508     }
509   }
510 
511   void buildExplicitInterface(
512       const Fortran::evaluate::characteristics::Procedure &procedure) {
513     // Handle result
514     if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
515             &result = procedure.functionResult) {
516       if (result->CanBeReturnedViaImplicitInterface())
517         handleImplicitResult(*result);
518       else
519         handleExplicitResult(*result);
520     } else if (interface.side().hasAlternateReturns()) {
521       addFirResult(mlir::IndexType::get(&mlirContext),
522                    FirPlaceHolder::resultEntityPosition, Property::Value);
523     }
524     bool isBindC = procedure.IsBindC();
525     // Handle arguments
526     const auto &argumentEntities =
527         getEntityContainer(interface.side().getCallDescription());
528     for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {
529       const Fortran::evaluate::characteristics::DummyArgument
530           &argCharacteristics = std::get<0>(pair);
531       std::visit(
532           Fortran::common::visitors{
533               [&](const Fortran::evaluate::characteristics::DummyDataObject
534                       &dummy) {
535                 const auto &entity = getDataObjectEntity(std::get<1>(pair));
536                 if (dummy.CanBePassedViaImplicitInterface())
537                   handleImplicitDummy(&argCharacteristics, dummy, entity);
538                 else
539                   handleExplicitDummy(&argCharacteristics, dummy, entity,
540                                       isBindC);
541               },
542               [&](const Fortran::evaluate::characteristics::DummyProcedure
543                       &dummy) {
544                 const auto &entity = getDataObjectEntity(std::get<1>(pair));
545                 handleImplicitDummy(&argCharacteristics, dummy, entity);
546               },
547               [&](const Fortran::evaluate::characteristics::AlternateReturn &) {
548                 // nothing to do
549               },
550           },
551           argCharacteristics.u);
552     }
553   }
554 
555 private:
556   void handleImplicitResult(
557       const Fortran::evaluate::characteristics::FunctionResult &result) {
558     if (result.IsProcedurePointer())
559       TODO(interface.converter.getCurrentLocation(),
560            "procedure pointer result not yet handled");
561     const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
562         result.GetTypeAndShape();
563     assert(typeAndShape && "expect type for non proc pointer result");
564     Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
565     // Character result allocated by caller and passed as hidden arguments
566     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
567       handleImplicitCharacterResult(dynamicType);
568     } else if (dynamicType.category() ==
569                Fortran::common::TypeCategory::Derived) {
570       TODO(interface.converter.getCurrentLocation(),
571            "implicit result derived type");
572     } else {
573       // All result other than characters/derived are simply returned by value
574       // in implicit interfaces
575       mlir::Type mlirType =
576           getConverter().genType(dynamicType.category(), dynamicType.kind());
577       addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
578                    Property::Value);
579     }
580   }
581 
582   void
583   handleImplicitCharacterResult(const Fortran::evaluate::DynamicType &type) {
584     int resultPosition = FirPlaceHolder::resultEntityPosition;
585     setPassedResult(PassEntityBy::AddressAndLength,
586                     getResultEntity(interface.side().getCallDescription()));
587     mlir::Type lenTy = mlir::IndexType::get(&mlirContext);
588     std::optional<std::int64_t> constantLen = type.knownLength();
589     fir::CharacterType::LenType len =
590         constantLen ? *constantLen : fir::CharacterType::unknownLen();
591     mlir::Type charRefTy = fir::ReferenceType::get(
592         fir::CharacterType::get(&mlirContext, type.kind(), len));
593     mlir::Type boxCharTy = fir::BoxCharType::get(&mlirContext, type.kind());
594     addFirOperand(charRefTy, resultPosition, Property::CharAddress);
595     addFirOperand(lenTy, resultPosition, Property::CharLength);
596     /// For now, also return it by boxchar
597     addFirResult(boxCharTy, resultPosition, Property::BoxChar);
598   }
599 
600   void handleExplicitResult(
601       const Fortran::evaluate::characteristics::FunctionResult &result) {
602     using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
603 
604     if (result.IsProcedurePointer())
605       TODO(interface.converter.getCurrentLocation(),
606            "procedure pointer results");
607     const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
608         result.GetTypeAndShape();
609     assert(typeAndShape && "expect type for non proc pointer result");
610     mlir::Type mlirType = translateDynamicType(typeAndShape->type());
611     fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
612     if (!bounds.empty())
613       mlirType = fir::SequenceType::get(bounds, mlirType);
614     if (result.attrs.test(Attr::Allocatable))
615       mlirType = fir::BoxType::get(fir::HeapType::get(mlirType));
616     if (result.attrs.test(Attr::Pointer))
617       mlirType = fir::BoxType::get(fir::PointerType::get(mlirType));
618 
619     if (fir::isa_char(mlirType)) {
620       // Character scalar results must be passed as arguments in lowering so
621       // that an assumed length character function callee can access the result
622       // length. A function with a result requiring an explicit interface does
623       // not have to be compatible with assumed length function, but most
624       // compilers supports it.
625       handleImplicitCharacterResult(typeAndShape->type());
626       return;
627     }
628 
629     addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
630                  Property::Value);
631     // Explicit results require the caller to allocate the storage and save the
632     // function result in the storage with a fir.save_result.
633     setSaveResult();
634   }
635 
636   fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
637     fir::SequenceType::Shape bounds;
638     for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : shape) {
639       fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();
640       if (std::optional<std::int64_t> i = toInt64(extent))
641         bound = *i;
642       bounds.emplace_back(bound);
643     }
644     return bounds;
645   }
646   std::optional<std::int64_t>
647   toInt64(std::optional<
648           Fortran::evaluate::Expr<Fortran::evaluate::SubscriptInteger>>
649               expr) {
650     if (expr)
651       return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
652           getConverter().getFoldingContext(), toEvExpr(*expr)));
653     return std::nullopt;
654   }
655 
656   /// Return a vector with an attribute with the name of the argument if this
657   /// is a callee interface and the name is available. Otherwise, just return
658   /// an empty vector.
659   llvm::SmallVector<mlir::NamedAttribute>
660   dummyNameAttr(const FortranEntity &entity) {
661     if constexpr (std::is_same_v<FortranEntity,
662                                  std::optional<Fortran::common::Reference<
663                                      const Fortran::semantics::Symbol>>>) {
664       if (entity.has_value()) {
665         const Fortran::semantics::Symbol *argument = &*entity.value();
666         // "fir.bindc_name" is used for arguments for the sake of consistency
667         // with other attributes carrying surface syntax names in FIR.
668         return {mlir::NamedAttribute(
669             mlir::StringAttr::get(&mlirContext, "fir.bindc_name"),
670             mlir::StringAttr::get(&mlirContext,
671                                   toStringRef(argument->name())))};
672       }
673     }
674     return {};
675   }
676 
677   // Define when an explicit argument must be passed in a fir.box.
678   bool dummyRequiresBox(
679       const Fortran::evaluate::characteristics::DummyDataObject &obj) {
680     using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
681     using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attrs;
682     constexpr ShapeAttrs shapeRequiringBox = {
683         ShapeAttr::AssumedShape, ShapeAttr::DeferredShape,
684         ShapeAttr::AssumedRank, ShapeAttr::Coarray};
685     if ((obj.type.attrs() & shapeRequiringBox).any())
686       // Need to pass shape/coshape info in fir.box.
687       return true;
688     if (obj.type.type().IsPolymorphic())
689       // Need to pass dynamic type info in fir.box.
690       return true;
691     if (const Fortran::semantics::DerivedTypeSpec *derived =
692             Fortran::evaluate::GetDerivedTypeSpec(obj.type.type()))
693       // Need to pass type parameters in fir.box if any.
694       return derived->parameters().empty();
695     return false;
696   }
697 
698   mlir::Type
699   translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) {
700     Fortran::common::TypeCategory cat = dynamicType.category();
701     // DERIVED
702     if (cat == Fortran::common::TypeCategory::Derived) {
703       TODO(interface.converter.getCurrentLocation(),
704            "[translateDynamicType] Derived");
705     }
706     // CHARACTER with compile time constant length.
707     if (cat == Fortran::common::TypeCategory::Character)
708       if (std::optional<std::int64_t> constantLen =
709               toInt64(dynamicType.GetCharLength()))
710         return getConverter().genType(cat, dynamicType.kind(), {*constantLen});
711     // INTEGER, REAL, LOGICAL, COMPLEX, and CHARACTER with dynamic length.
712     return getConverter().genType(cat, dynamicType.kind());
713   }
714 
715   void handleExplicitDummy(
716       const DummyCharacteristics *characteristics,
717       const Fortran::evaluate::characteristics::DummyDataObject &obj,
718       const FortranEntity &entity, bool isBindC) {
719     using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr;
720 
721     bool isValueAttr = false;
722     [[maybe_unused]] mlir::Location loc =
723         interface.converter.getCurrentLocation();
724     llvm::SmallVector<mlir::NamedAttribute> attrs = dummyNameAttr(entity);
725     auto addMLIRAttr = [&](llvm::StringRef attr) {
726       attrs.emplace_back(mlir::StringAttr::get(&mlirContext, attr),
727                          mlir::UnitAttr::get(&mlirContext));
728     };
729     if (obj.attrs.test(Attrs::Optional))
730       addMLIRAttr(fir::getOptionalAttrName());
731     if (obj.attrs.test(Attrs::Asynchronous))
732       TODO(loc, "Asynchronous in procedure interface");
733     if (obj.attrs.test(Attrs::Contiguous))
734       addMLIRAttr(fir::getContiguousAttrName());
735     if (obj.attrs.test(Attrs::Value))
736       isValueAttr = true; // TODO: do we want an mlir::Attribute as well?
737     if (obj.attrs.test(Attrs::Volatile))
738       TODO(loc, "Volatile in procedure interface");
739     if (obj.attrs.test(Attrs::Target))
740       addMLIRAttr(fir::getTargetAttrName());
741 
742     // TODO: intents that require special care (e.g finalization)
743 
744     using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
745     const Fortran::evaluate::characteristics::TypeAndShape::Attrs &shapeAttrs =
746         obj.type.attrs();
747     if (shapeAttrs.test(ShapeAttr::AssumedRank))
748       TODO(loc, "Assumed Rank in procedure interface");
749     if (shapeAttrs.test(ShapeAttr::Coarray))
750       TODO(loc, "Coarray in procedure interface");
751 
752     // So far assume that if the argument cannot be passed by implicit interface
753     // it must be by box. That may no be always true (e.g for simple optionals)
754 
755     Fortran::evaluate::DynamicType dynamicType = obj.type.type();
756     mlir::Type type = translateDynamicType(dynamicType);
757     fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
758     if (!bounds.empty())
759       type = fir::SequenceType::get(bounds, type);
760     if (obj.attrs.test(Attrs::Allocatable))
761       type = fir::HeapType::get(type);
762     if (obj.attrs.test(Attrs::Pointer))
763       type = fir::PointerType::get(type);
764     mlir::Type boxType = fir::BoxType::get(type);
765 
766     if (obj.attrs.test(Attrs::Allocatable) || obj.attrs.test(Attrs::Pointer)) {
767       // Pass as fir.ref<fir.box>
768       mlir::Type boxRefType = fir::ReferenceType::get(boxType);
769       addFirOperand(boxRefType, nextPassedArgPosition(), Property::MutableBox,
770                     attrs);
771       addPassedArg(PassEntityBy::MutableBox, entity, characteristics);
772     } else if (dummyRequiresBox(obj)) {
773       // Pass as fir.box
774       addFirOperand(boxType, nextPassedArgPosition(), Property::Box, attrs);
775       addPassedArg(PassEntityBy::Box, entity, characteristics);
776     } else if (dynamicType.category() ==
777                Fortran::common::TypeCategory::Character) {
778       // Pass as fir.box_char
779       mlir::Type boxCharTy =
780           fir::BoxCharType::get(&mlirContext, dynamicType.kind());
781       addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
782                     attrs);
783       addPassedArg(isValueAttr ? PassEntityBy::CharBoxValueAttribute
784                                : PassEntityBy::BoxChar,
785                    entity, characteristics);
786     } else {
787       // Pass as fir.ref unless it's by VALUE and BIND(C)
788       mlir::Type passType = fir::ReferenceType::get(type);
789       PassEntityBy passBy = PassEntityBy::BaseAddress;
790       Property prop = Property::BaseAddress;
791       if (isValueAttr) {
792         if (isBindC) {
793           passBy = PassEntityBy::Value;
794           prop = Property::Value;
795           passType = type;
796         } else {
797           passBy = PassEntityBy::BaseAddressValueAttribute;
798         }
799       }
800       addFirOperand(passType, nextPassedArgPosition(), prop, attrs);
801       addPassedArg(passBy, entity, characteristics);
802     }
803   }
804 
805   void handleImplicitDummy(
806       const DummyCharacteristics *characteristics,
807       const Fortran::evaluate::characteristics::DummyDataObject &obj,
808       const FortranEntity &entity) {
809     Fortran::evaluate::DynamicType dynamicType = obj.type.type();
810     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
811       mlir::Type boxCharTy =
812           fir::BoxCharType::get(&mlirContext, dynamicType.kind());
813       addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
814                     dummyNameAttr(entity));
815       addPassedArg(PassEntityBy::BoxChar, entity, characteristics);
816     } else {
817       // non-PDT derived type allowed in implicit interface.
818       Fortran::common::TypeCategory cat = dynamicType.category();
819       mlir::Type type = getConverter().genType(cat, dynamicType.kind());
820       fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
821       if (!bounds.empty())
822         type = fir::SequenceType::get(bounds, type);
823       mlir::Type refType = fir::ReferenceType::get(type);
824       addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
825                     dummyNameAttr(entity));
826       addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
827     }
828   }
829 
830   void handleImplicitDummy(
831       const DummyCharacteristics *characteristics,
832       const Fortran::evaluate::characteristics::DummyProcedure &proc,
833       const FortranEntity &entity) {
834     TODO(interface.converter.getCurrentLocation(),
835          "handleImlicitDummy DummyProcedure");
836   }
837 
838   void
839   addFirOperand(mlir::Type type, int entityPosition, Property p,
840                 llvm::ArrayRef<mlir::NamedAttribute> attributes = llvm::None) {
841     interface.inputs.emplace_back(
842         FirPlaceHolder{type, entityPosition, p, attributes});
843   }
844   void
845   addFirResult(mlir::Type type, int entityPosition, Property p,
846                llvm::ArrayRef<mlir::NamedAttribute> attributes = llvm::None) {
847     interface.outputs.emplace_back(
848         FirPlaceHolder{type, entityPosition, p, attributes});
849   }
850   void addPassedArg(PassEntityBy p, FortranEntity entity,
851                     const DummyCharacteristics *characteristics) {
852     interface.passedArguments.emplace_back(
853         PassedEntity{p, entity, {}, {}, characteristics});
854   }
855   void setPassedResult(PassEntityBy p, FortranEntity entity) {
856     interface.passedResult =
857         PassedEntity{p, entity, emptyValue(), emptyValue()};
858   }
859   void setSaveResult() { interface.saveResult = true; }
860   int nextPassedArgPosition() { return interface.passedArguments.size(); }
861 
862   static FirValue emptyValue() {
863     if constexpr (std::is_same_v<Fortran::lower::CalleeInterface, T>) {
864       return {};
865     } else {
866       return -1;
867     }
868   }
869 
870   Fortran::lower::AbstractConverter &getConverter() {
871     return interface.converter;
872   }
873   CallInterface &interface;
874   mlir::MLIRContext &mlirContext;
875 };
876 
877 template <typename T>
878 bool Fortran::lower::CallInterface<T>::PassedEntity::isOptional() const {
879   if (!characteristics)
880     return false;
881   return characteristics->IsOptional();
882 }
883 template <typename T>
884 bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeModifiedByCall()
885     const {
886   if (!characteristics)
887     return true;
888   return characteristics->GetIntent() != Fortran::common::Intent::In;
889 }
890 template <typename T>
891 bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeReadByCall() const {
892   if (!characteristics)
893     return true;
894   return characteristics->GetIntent() != Fortran::common::Intent::Out;
895 }
896 
897 template <typename T>
898 void Fortran::lower::CallInterface<T>::determineInterface(
899     bool isImplicit,
900     const Fortran::evaluate::characteristics::Procedure &procedure) {
901   CallInterfaceImpl<T> impl(*this);
902   if (isImplicit)
903     impl.buildImplicitInterface(procedure);
904   else
905     impl.buildExplicitInterface(procedure);
906 }
907 
908 template <typename T>
909 mlir::FunctionType Fortran::lower::CallInterface<T>::genFunctionType() {
910   llvm::SmallVector<mlir::Type> returnTys;
911   llvm::SmallVector<mlir::Type> inputTys;
912   for (const FirPlaceHolder &placeHolder : outputs)
913     returnTys.emplace_back(placeHolder.type);
914   for (const FirPlaceHolder &placeHolder : inputs)
915     inputTys.emplace_back(placeHolder.type);
916   return mlir::FunctionType::get(&converter.getMLIRContext(), inputTys,
917                                  returnTys);
918 }
919 
920 template class Fortran::lower::CallInterface<Fortran::lower::CalleeInterface>;
921 template class Fortran::lower::CallInterface<Fortran::lower::CallerInterface>;
922