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