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 // Callee side interface implementation
35 //===----------------------------------------------------------------------===//
36 
37 bool Fortran::lower::CalleeInterface::hasAlternateReturns() const {
38   return !funit.isMainProgram() &&
39          Fortran::semantics::HasAlternateReturns(funit.getSubprogramSymbol());
40 }
41 
42 std::string Fortran::lower::CalleeInterface::getMangledName() const {
43   if (funit.isMainProgram())
44     return fir::NameUniquer::doProgramEntry().str();
45   return ::getMangledName(funit.getSubprogramSymbol());
46 }
47 
48 const Fortran::semantics::Symbol *
49 Fortran::lower::CalleeInterface::getProcedureSymbol() const {
50   if (funit.isMainProgram())
51     return nullptr;
52   return &funit.getSubprogramSymbol();
53 }
54 
55 mlir::Location Fortran::lower::CalleeInterface::getCalleeLocation() const {
56   // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably
57   // should just stash the location in the funit regardless.
58   return converter.genLocation(funit.getStartingSourceLoc());
59 }
60 
61 Fortran::evaluate::characteristics::Procedure
62 Fortran::lower::CalleeInterface::characterize() const {
63   Fortran::evaluate::FoldingContext &foldingContext =
64       converter.getFoldingContext();
65   std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
66       Fortran::evaluate::characteristics::Procedure::Characterize(
67           funit.getSubprogramSymbol(), foldingContext);
68   assert(characteristic && "Fail to get characteristic from symbol");
69   return *characteristic;
70 }
71 
72 bool Fortran::lower::CalleeInterface::isMainProgram() const {
73   return funit.isMainProgram();
74 }
75 
76 mlir::FuncOp Fortran::lower::CalleeInterface::addEntryBlockAndMapArguments() {
77   // On the callee side, directly map the mlir::value argument of
78   // the function block to the Fortran symbols.
79   func.addEntryBlock();
80   mapPassedEntities();
81   return func;
82 }
83 
84 //===----------------------------------------------------------------------===//
85 // CallInterface implementation: this part is common to both callee and caller
86 // sides.
87 //===----------------------------------------------------------------------===//
88 
89 static void addSymbolAttribute(mlir::FuncOp func,
90                                const Fortran::semantics::Symbol &sym,
91                                mlir::MLIRContext &mlirContext) {
92   // Only add this on bind(C) functions for which the symbol is not reflected in
93   // the current context.
94   if (!Fortran::semantics::IsBindCProcedure(sym))
95     return;
96   std::string name =
97       Fortran::lower::mangle::mangleName(sym, /*keepExternalInScope=*/true);
98   func->setAttr(fir::getSymbolAttrName(),
99                 mlir::StringAttr::get(&mlirContext, name));
100 }
101 
102 /// Declare drives the different actions to be performed while analyzing the
103 /// signature and building/finding the mlir::FuncOp.
104 template <typename T>
105 void Fortran::lower::CallInterface<T>::declare() {
106   if (!side().isMainProgram()) {
107     characteristic.emplace(side().characterize());
108     bool isImplicit = characteristic->CanBeCalledViaImplicitInterface();
109     determineInterface(isImplicit, *characteristic);
110   }
111   // No input/output for main program
112 
113   // Create / get funcOp for direct calls. For indirect calls (only meaningful
114   // on the caller side), no funcOp has to be created here. The mlir::Value
115   // holding the indirection is used when creating the fir::CallOp.
116   if (!side().isIndirectCall()) {
117     std::string name = side().getMangledName();
118     mlir::ModuleOp module = converter.getModuleOp();
119     func = fir::FirOpBuilder::getNamedFunction(module, name);
120     if (!func) {
121       mlir::Location loc = side().getCalleeLocation();
122       mlir::FunctionType ty = genFunctionType();
123       func = fir::FirOpBuilder::createFunction(loc, module, name, ty);
124       if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol())
125         addSymbolAttribute(func, *sym, converter.getMLIRContext());
126       for (const auto &placeHolder : llvm::enumerate(inputs))
127         if (!placeHolder.value().attributes.empty())
128           func.setArgAttrs(placeHolder.index(), placeHolder.value().attributes);
129     }
130   }
131 }
132 
133 /// Once the signature has been analyzed and the mlir::FuncOp was built/found,
134 /// map the fir inputs to Fortran entities (the symbols or expressions).
135 template <typename T>
136 void Fortran::lower::CallInterface<T>::mapPassedEntities() {
137   // map back fir inputs to passed entities
138   if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) {
139     assert(inputs.size() == func.front().getArguments().size() &&
140            "function previously created with different number of arguments");
141     for (auto [fst, snd] : llvm::zip(inputs, func.front().getArguments()))
142       mapBackInputToPassedEntity(fst, snd);
143   } else {
144     // On the caller side, map the index of the mlir argument position
145     // to Fortran ActualArguments.
146     int firPosition = 0;
147     for (const FirPlaceHolder &placeHolder : inputs)
148       mapBackInputToPassedEntity(placeHolder, firPosition++);
149   }
150 }
151 
152 template <typename T>
153 void Fortran::lower::CallInterface<T>::mapBackInputToPassedEntity(
154     const FirPlaceHolder &placeHolder, FirValue firValue) {
155   PassedEntity &passedEntity =
156       placeHolder.passedEntityPosition == FirPlaceHolder::resultEntityPosition
157           ? passedResult.value()
158           : passedArguments[placeHolder.passedEntityPosition];
159   if (placeHolder.property == Property::CharLength)
160     passedEntity.firLength = firValue;
161   else
162     passedEntity.firArgument = firValue;
163 }
164 
165 static const std::vector<Fortran::semantics::Symbol *> &
166 getEntityContainer(Fortran::lower::pft::FunctionLikeUnit &funit) {
167   return funit.getSubprogramSymbol()
168       .get<Fortran::semantics::SubprogramDetails>()
169       .dummyArgs();
170 }
171 
172 static const Fortran::semantics::Symbol &
173 getDataObjectEntity(const Fortran::semantics::Symbol *arg) {
174   assert(arg && "expect symbol for data object entity");
175   return *arg;
176 }
177 
178 //===----------------------------------------------------------------------===//
179 // CallInterface implementation: this part is common to both caller and caller
180 // sides.
181 //===----------------------------------------------------------------------===//
182 
183 /// This is the actual part that defines the FIR interface based on the
184 /// characteristic. It directly mutates the CallInterface members.
185 template <typename T>
186 class Fortran::lower::CallInterfaceImpl {
187   using CallInterface = Fortran::lower::CallInterface<T>;
188   using PassEntityBy = typename CallInterface::PassEntityBy;
189   using PassedEntity = typename CallInterface::PassedEntity;
190   using FortranEntity = typename CallInterface::FortranEntity;
191   using FirPlaceHolder = typename CallInterface::FirPlaceHolder;
192   using Property = typename CallInterface::Property;
193   using TypeAndShape = Fortran::evaluate::characteristics::TypeAndShape;
194   using DummyCharacteristics =
195       Fortran::evaluate::characteristics::DummyArgument;
196 
197 public:
198   CallInterfaceImpl(CallInterface &i)
199       : interface(i), mlirContext{i.converter.getMLIRContext()} {}
200 
201   void buildImplicitInterface(
202       const Fortran::evaluate::characteristics::Procedure &procedure) {
203     // Handle result
204     if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
205             &result = procedure.functionResult)
206       handleImplicitResult(*result);
207     else if (interface.side().hasAlternateReturns())
208       addFirResult(mlir::IndexType::get(&mlirContext),
209                    FirPlaceHolder::resultEntityPosition, Property::Value);
210     // Handle arguments
211     const auto &argumentEntities =
212         getEntityContainer(interface.side().getCallDescription());
213     for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {
214       const Fortran::evaluate::characteristics::DummyArgument
215           &argCharacteristics = std::get<0>(pair);
216       std::visit(
217           Fortran::common::visitors{
218               [&](const auto &dummy) {
219                 const auto &entity = getDataObjectEntity(std::get<1>(pair));
220                 handleImplicitDummy(&argCharacteristics, dummy, entity);
221               },
222               [&](const Fortran::evaluate::characteristics::AlternateReturn &) {
223                 // nothing to do
224               },
225           },
226           argCharacteristics.u);
227     }
228   }
229 
230   void buildExplicitInterface(
231       const Fortran::evaluate::characteristics::Procedure &procedure) {
232     // Handle result
233     if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
234             &result = procedure.functionResult) {
235       if (result->CanBeReturnedViaImplicitInterface())
236         handleImplicitResult(*result);
237       else
238         handleExplicitResult(*result);
239     } else if (interface.side().hasAlternateReturns()) {
240       addFirResult(mlir::IndexType::get(&mlirContext),
241                    FirPlaceHolder::resultEntityPosition, Property::Value);
242     }
243   }
244 
245 private:
246   void handleImplicitResult(
247       const Fortran::evaluate::characteristics::FunctionResult &result) {
248     if (result.IsProcedurePointer())
249       TODO(interface.converter.getCurrentLocation(),
250            "procedure pointer result not yet handled");
251     const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
252         result.GetTypeAndShape();
253     assert(typeAndShape && "expect type for non proc pointer result");
254     Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
255     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
256       TODO(interface.converter.getCurrentLocation(),
257            "implicit result character type");
258     } else if (dynamicType.category() ==
259                Fortran::common::TypeCategory::Derived) {
260       TODO(interface.converter.getCurrentLocation(),
261            "implicit result derived type");
262     } else {
263       // All result other than characters/derived are simply returned by value
264       // in implicit interfaces
265       mlir::Type mlirType =
266           getConverter().genType(dynamicType.category(), dynamicType.kind());
267       addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
268                    Property::Value);
269     }
270   }
271 
272   void handleExplicitResult(
273       const Fortran::evaluate::characteristics::FunctionResult &result) {
274     using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
275 
276     if (result.IsProcedurePointer())
277       TODO(interface.converter.getCurrentLocation(),
278            "procedure pointer results");
279     const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
280         result.GetTypeAndShape();
281     assert(typeAndShape && "expect type for non proc pointer result");
282     Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
283     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
284       TODO(interface.converter.getCurrentLocation(),
285            "implicit result character type");
286     } else if (dynamicType.category() ==
287                Fortran::common::TypeCategory::Derived) {
288       TODO(interface.converter.getCurrentLocation(),
289            "implicit result derived type");
290     }
291     mlir::Type mlirType =
292         getConverter().genType(dynamicType.category(), dynamicType.kind());
293     fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
294     if (!bounds.empty())
295       mlirType = fir::SequenceType::get(bounds, mlirType);
296     if (result.attrs.test(Attr::Allocatable))
297       mlirType = fir::BoxType::get(fir::HeapType::get(mlirType));
298     if (result.attrs.test(Attr::Pointer))
299       mlirType = fir::BoxType::get(fir::PointerType::get(mlirType));
300 
301     addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
302                  Property::Value);
303   }
304 
305   fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
306     fir::SequenceType::Shape bounds;
307     for (Fortran::evaluate::MaybeExtentExpr extentExpr : shape) {
308       fir::SequenceType::Extent extent = fir::SequenceType::getUnknownExtent();
309       if (std::optional<std::int64_t> constantExtent =
310               toInt64(std::move(extentExpr)))
311         extent = *constantExtent;
312       bounds.push_back(extent);
313     }
314     return bounds;
315   }
316 
317   template <typename A>
318   std::optional<std::int64_t> toInt64(A &&expr) {
319     return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
320         getConverter().getFoldingContext(), std::move(expr)));
321   }
322 
323   /// Return a vector with an attribute with the name of the argument if this
324   /// is a callee interface and the name is available. Otherwise, just return
325   /// an empty vector.
326   llvm::SmallVector<mlir::NamedAttribute>
327   dummyNameAttr(const FortranEntity &entity) {
328     if constexpr (std::is_same_v<FortranEntity,
329                                  std::optional<Fortran::common::Reference<
330                                      const Fortran::semantics::Symbol>>>) {
331       if (entity.has_value()) {
332         const Fortran::semantics::Symbol *argument = &*entity.value();
333         // "fir.bindc_name" is used for arguments for the sake of consistency
334         // with other attributes carrying surface syntax names in FIR.
335         return {mlir::NamedAttribute(
336             mlir::StringAttr::get(&mlirContext, "fir.bindc_name"),
337             mlir::StringAttr::get(&mlirContext,
338                                   toStringRef(argument->name())))};
339       }
340     }
341     return {};
342   }
343 
344   void handleImplicitDummy(
345       const DummyCharacteristics *characteristics,
346       const Fortran::evaluate::characteristics::DummyDataObject &obj,
347       const FortranEntity &entity) {
348     Fortran::evaluate::DynamicType dynamicType = obj.type.type();
349     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
350       mlir::Type boxCharTy =
351           fir::BoxCharType::get(&mlirContext, dynamicType.kind());
352       addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
353                     dummyNameAttr(entity));
354       addPassedArg(PassEntityBy::BoxChar, entity, characteristics);
355     } else {
356       // non-PDT derived type allowed in implicit interface.
357       Fortran::common::TypeCategory cat = dynamicType.category();
358       mlir::Type type = getConverter().genType(cat, dynamicType.kind());
359       fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
360       if (!bounds.empty())
361         type = fir::SequenceType::get(bounds, type);
362       mlir::Type refType = fir::ReferenceType::get(type);
363       addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
364                     dummyNameAttr(entity));
365       addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
366     }
367   }
368 
369   void handleImplicitDummy(
370       const DummyCharacteristics *characteristics,
371       const Fortran::evaluate::characteristics::DummyProcedure &proc,
372       const FortranEntity &entity) {
373     TODO(interface.converter.getCurrentLocation(),
374          "handleImlicitDummy DummyProcedure");
375   }
376 
377   void
378   addFirOperand(mlir::Type type, int entityPosition, Property p,
379                 llvm::ArrayRef<mlir::NamedAttribute> attributes = llvm::None) {
380     interface.inputs.emplace_back(
381         FirPlaceHolder{type, entityPosition, p, attributes});
382   }
383   void
384   addFirResult(mlir::Type type, int entityPosition, Property p,
385                llvm::ArrayRef<mlir::NamedAttribute> attributes = llvm::None) {
386     interface.outputs.emplace_back(
387         FirPlaceHolder{type, entityPosition, p, attributes});
388   }
389   void addPassedArg(PassEntityBy p, FortranEntity entity,
390                     const DummyCharacteristics *characteristics) {
391     interface.passedArguments.emplace_back(
392         PassedEntity{p, entity, {}, {}, characteristics});
393   }
394   int nextPassedArgPosition() { return interface.passedArguments.size(); }
395 
396   Fortran::lower::AbstractConverter &getConverter() {
397     return interface.converter;
398   }
399   CallInterface &interface;
400   mlir::MLIRContext &mlirContext;
401 };
402 
403 template <typename T>
404 void Fortran::lower::CallInterface<T>::determineInterface(
405     bool isImplicit,
406     const Fortran::evaluate::characteristics::Procedure &procedure) {
407   CallInterfaceImpl<T> impl(*this);
408   if (isImplicit)
409     impl.buildImplicitInterface(procedure);
410   else
411     impl.buildExplicitInterface(procedure);
412 }
413 
414 template <typename T>
415 mlir::FunctionType Fortran::lower::CallInterface<T>::genFunctionType() {
416   llvm::SmallVector<mlir::Type> returnTys;
417   llvm::SmallVector<mlir::Type> inputTys;
418   for (const FirPlaceHolder &placeHolder : outputs)
419     returnTys.emplace_back(placeHolder.type);
420   for (const FirPlaceHolder &placeHolder : inputs)
421     inputTys.emplace_back(placeHolder.type);
422   return mlir::FunctionType::get(&converter.getMLIRContext(), inputTys,
423                                  returnTys);
424 }
425 
426 template class Fortran::lower::CallInterface<Fortran::lower::CalleeInterface>;
427