1//===-- ConvertCall.cpp ---------------------------------------------------===//
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// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
10//
11//===----------------------------------------------------------------------===//
12
13#include "flang/Lower/ConvertCall.h"
14#include "flang/Lower/Allocatable.h"
15#include "flang/Lower/ConvertExprToHLFIR.h"
16#include "flang/Lower/ConvertProcedureDesignator.h"
17#include "flang/Lower/ConvertVariable.h"
18#include "flang/Lower/CustomIntrinsicCall.h"
19#include "flang/Lower/HlfirIntrinsics.h"
20#include "flang/Lower/StatementContext.h"
21#include "flang/Lower/SymbolMap.h"
22#include "flang/Optimizer/Builder/BoxValue.h"
23#include "flang/Optimizer/Builder/Character.h"
24#include "flang/Optimizer/Builder/FIRBuilder.h"
25#include "flang/Optimizer/Builder/HLFIRTools.h"
26#include "flang/Optimizer/Builder/IntrinsicCall.h"
27#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
28#include "flang/Optimizer/Builder/MutableBox.h"
29#include "flang/Optimizer/Builder/Runtime/Derived.h"
30#include "flang/Optimizer/Builder/Todo.h"
31#include "flang/Optimizer/Dialect/CUF/CUFOps.h"
32#include "flang/Optimizer/Dialect/FIROpsSupport.h"
33#include "flang/Optimizer/HLFIR/HLFIROps.h"
34#include "mlir/IR/IRMapping.h"
35#include "llvm/ADT/TypeSwitch.h"
36#include "llvm/Support/CommandLine.h"
37#include "llvm/Support/Debug.h"
38#include <optional>
39
40#define DEBUG_TYPE "flang-lower-expr"
41
42static llvm::cl::opt<bool> useHlfirIntrinsicOps(
43 "use-hlfir-intrinsic-ops", llvm::cl::init(Val: true),
44 llvm::cl::desc("Lower via HLFIR transformational intrinsic operations such "
45 "as hlfir.sum"));
46
47static constexpr char tempResultName[] = ".tmp.func_result";
48
49/// Helper to package a Value and its properties into an ExtendedValue.
50static fir::ExtendedValue toExtendedValue(mlir::Location loc, mlir::Value base,
51 llvm::ArrayRef<mlir::Value> extents,
52 llvm::ArrayRef<mlir::Value> lengths) {
53 mlir::Type type = base.getType();
54 if (mlir::isa<fir::BaseBoxType>(type))
55 return fir::BoxValue(base, /*lbounds=*/{}, lengths, extents);
56 type = fir::unwrapRefType(type);
57 if (mlir::isa<fir::BaseBoxType>(type))
58 return fir::MutableBoxValue(base, lengths, /*mutableProperties*/ {});
59 if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(type)) {
60 if (seqTy.getDimension() != extents.size())
61 fir::emitFatalError(loc, "incorrect number of extents for array");
62 if (mlir::isa<fir::CharacterType>(seqTy.getEleTy())) {
63 if (lengths.empty())
64 fir::emitFatalError(loc, "missing length for character");
65 assert(lengths.size() == 1);
66 return fir::CharArrayBoxValue(base, lengths[0], extents);
67 }
68 return fir::ArrayBoxValue(base, extents);
69 }
70 if (mlir::isa<fir::CharacterType>(type)) {
71 if (lengths.empty())
72 fir::emitFatalError(loc, "missing length for character");
73 assert(lengths.size() == 1);
74 return fir::CharBoxValue(base, lengths[0]);
75 }
76 return base;
77}
78
79/// Lower a type(C_PTR/C_FUNPTR) argument with VALUE attribute into a
80/// reference. A C pointer can correspond to a Fortran dummy argument of type
81/// C_PTR with the VALUE attribute. (see 18.3.6 note 3).
82static mlir::Value genRecordCPtrValueArg(fir::FirOpBuilder &builder,
83 mlir::Location loc, mlir::Value rec,
84 mlir::Type ty) {
85 mlir::Value cAddr = fir::factory::genCPtrOrCFunptrAddr(builder, loc, rec, ty);
86 mlir::Value cVal = builder.create<fir::LoadOp>(loc, cAddr);
87 return builder.createConvert(loc, cAddr.getType(), cVal);
88}
89
90// Find the argument that corresponds to the host associations.
91// Verify some assumptions about how the signature was built here.
92[[maybe_unused]] static unsigned findHostAssocTuplePos(mlir::func::FuncOp fn) {
93 // Scan the argument list from last to first as the host associations are
94 // appended for now.
95 for (unsigned i = fn.getNumArguments(); i > 0; --i)
96 if (fn.getArgAttr(i - 1, fir::getHostAssocAttrName())) {
97 // Host assoc tuple must be last argument (for now).
98 assert(i == fn.getNumArguments() && "tuple must be last");
99 return i - 1;
100 }
101 llvm_unreachable("anyFuncArgsHaveAttr failed");
102}
103
104mlir::Value
105Fortran::lower::argumentHostAssocs(Fortran::lower::AbstractConverter &converter,
106 mlir::Value arg) {
107 if (auto addr = mlir::dyn_cast_or_null<fir::AddrOfOp>(arg.getDefiningOp())) {
108 auto &builder = converter.getFirOpBuilder();
109 if (auto funcOp = builder.getNamedFunction(addr.getSymbol()))
110 if (fir::anyFuncArgsHaveAttr(funcOp, fir::getHostAssocAttrName()))
111 return converter.hostAssocTupleValue();
112 }
113 return {};
114}
115
116static bool mustCastFuncOpToCopeWithImplicitInterfaceMismatch(
117 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
118 mlir::FunctionType callSiteType, mlir::FunctionType funcOpType) {
119 // Deal with argument number mismatch by making a function pointer so
120 // that function type cast can be inserted. Do not emit a warning here
121 // because this can happen in legal program if the function is not
122 // defined here and it was first passed as an argument without any more
123 // information.
124 if (callSiteType.getNumResults() != funcOpType.getNumResults() ||
125 callSiteType.getNumInputs() != funcOpType.getNumInputs())
126 return true;
127
128 // Implicit interface result type mismatch are not standard Fortran, but
129 // some compilers are not complaining about it. The front end is not
130 // protecting lowering from this currently. Support this with a
131 // discouraging warning.
132 // Cast the actual function to the current caller implicit type because
133 // that is the behavior we would get if we could not see the definition.
134 if (callSiteType.getResults() != funcOpType.getResults()) {
135 LLVM_DEBUG(mlir::emitWarning(
136 loc, "a return type mismatch is not standard compliant and may "
137 "lead to undefined behavior."));
138 return true;
139 }
140
141 // In HLFIR, there is little attempt to cope with implicit interface
142 // mismatch on the arguments. The argument are always prepared according
143 // to the implicit interface. Cast the actual function if any of the
144 // argument mismatch cannot be dealt with a simple fir.convert.
145 if (converter.getLoweringOptions().getLowerToHighLevelFIR())
146 for (auto [actualType, dummyType] :
147 llvm::zip(callSiteType.getInputs(), funcOpType.getInputs()))
148 if (actualType != dummyType &&
149 !fir::ConvertOp::canBeConverted(actualType, dummyType))
150 return true;
151 return false;
152}
153
154static mlir::Value readDim3Value(fir::FirOpBuilder &builder, mlir::Location loc,
155 mlir::Value dim3Addr, llvm::StringRef comp) {
156 mlir::Type i32Ty = builder.getI32Type();
157 mlir::Type refI32Ty = fir::ReferenceType::get(i32Ty);
158 llvm::SmallVector<mlir::Value> lenParams;
159
160 mlir::Value designate = builder.create<hlfir::DesignateOp>(
161 loc, refI32Ty, dim3Addr, /*component=*/comp,
162 /*componentShape=*/mlir::Value{}, hlfir::DesignateOp::Subscripts{},
163 /*substring=*/mlir::ValueRange{}, /*complexPartAttr=*/std::nullopt,
164 mlir::Value{}, lenParams);
165
166 return hlfir::loadTrivialScalar(loc, builder, hlfir::Entity{designate});
167}
168
169static mlir::Value remapActualToDummyDescriptor(
170 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
171 Fortran::lower::SymMap &symMap,
172 const Fortran::lower::CallerInterface::PassedEntity &arg,
173 Fortran::lower::CallerInterface &caller, bool isBindcCall) {
174 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
175 mlir::IndexType idxTy = builder.getIndexType();
176 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
177 Fortran::lower::StatementContext localStmtCtx;
178 auto lowerSpecExpr = [&](const auto &expr,
179 bool isAssumedSizeExtent) -> mlir::Value {
180 mlir::Value convertExpr = builder.createConvert(
181 loc, idxTy, fir::getBase(converter.genExprValue(expr, localStmtCtx)));
182 if (isAssumedSizeExtent)
183 return convertExpr;
184 return fir::factory::genMaxWithZero(builder, loc, convertExpr);
185 };
186 bool mapSymbols = caller.mustMapInterfaceSymbolsForDummyArgument(arg);
187 if (mapSymbols) {
188 symMap.pushScope();
189 const Fortran::semantics::Symbol *sym = caller.getDummySymbol(arg);
190 assert(sym && "call must have explicit interface to map interface symbols");
191 Fortran::lower::mapCallInterfaceSymbolsForDummyArgument(converter, caller,
192 symMap, *sym);
193 }
194 llvm::SmallVector<mlir::Value> extents;
195 llvm::SmallVector<mlir::Value> lengths;
196 mlir::Type dummyBoxType = caller.getDummyArgumentType(arg);
197 mlir::Type dummyBaseType = fir::unwrapPassByRefType(dummyBoxType);
198 if (mlir::isa<fir::SequenceType>(dummyBaseType))
199 caller.walkDummyArgumentExtents(
200 arg, [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
201 extents.emplace_back(lowerSpecExpr(e, isAssumedSizeExtent));
202 });
203 mlir::Value shape;
204 if (!extents.empty()) {
205 if (isBindcCall) {
206 // Preserve zero lower bounds (see F'2023 18.5.3).
207 llvm::SmallVector<mlir::Value> lowerBounds(extents.size(), zero);
208 shape = builder.genShape(loc, lowerBounds, extents);
209 } else {
210 shape = builder.genShape(loc, extents);
211 }
212 }
213
214 hlfir::Entity explicitArgument = hlfir::Entity{caller.getInput(arg)};
215 mlir::Type dummyElementType = fir::unwrapSequenceType(dummyBaseType);
216 if (auto recType = llvm::dyn_cast<fir::RecordType>(dummyElementType))
217 if (recType.getNumLenParams() > 0)
218 TODO(loc, "sequence association of length parameterized derived type "
219 "dummy arguments");
220 if (fir::isa_char(dummyElementType))
221 lengths.emplace_back(hlfir::genCharLength(loc, builder, explicitArgument));
222 mlir::Value baseAddr =
223 hlfir::genVariableRawAddress(loc, builder, explicitArgument);
224 baseAddr = builder.createConvert(loc, fir::ReferenceType::get(dummyBaseType),
225 baseAddr);
226 mlir::Value mold;
227 if (fir::isPolymorphicType(dummyBoxType))
228 mold = explicitArgument;
229 mlir::Value remapped =
230 builder.create<fir::EmboxOp>(loc, dummyBoxType, baseAddr, shape,
231 /*slice=*/mlir::Value{}, lengths, mold);
232 if (mapSymbols)
233 symMap.popScope();
234 return remapped;
235}
236
237/// Create a descriptor for sequenced associated descriptor that are passed
238/// by descriptor. Sequence association (F'2023 15.5.2.12) implies that the
239/// dummy shape and rank need to not be the same as the actual argument. This
240/// helper creates a descriptor based on the dummy shape and rank (sequence
241/// association can only happen with explicit and assumed-size array) so that it
242/// is safe to assume the rank of the incoming descriptor inside the callee.
243/// This helper must be called once all the actual arguments have been lowered
244/// and placed inside "caller". Copy-in/copy-out must already have been
245/// generated if needed using the actual argument shape (the dummy shape may be
246/// assumed-size).
247static void remapActualToDummyDescriptors(
248 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
249 Fortran::lower::SymMap &symMap,
250 const Fortran::lower::PreparedActualArguments &loweredActuals,
251 Fortran::lower::CallerInterface &caller, bool isBindcCall) {
252 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
253 for (auto [preparedActual, arg] :
254 llvm::zip(loweredActuals, caller.getPassedArguments())) {
255 if (arg.isSequenceAssociatedDescriptor()) {
256 if (!preparedActual.value().handleDynamicOptional()) {
257 mlir::Value remapped = remapActualToDummyDescriptor(
258 loc, converter, symMap, arg, caller, isBindcCall);
259 caller.placeInput(arg, remapped);
260 } else {
261 // Absent optional actual argument descriptor cannot be read and
262 // remapped unconditionally.
263 mlir::Type dummyType = caller.getDummyArgumentType(arg);
264 mlir::Value isPresent = preparedActual.value().getIsPresent();
265 auto &argLambdaCapture = arg;
266 mlir::Value remapped =
267 builder
268 .genIfOp(loc, {dummyType}, isPresent,
269 /*withElseRegion=*/true)
270 .genThen([&]() {
271 mlir::Value newBox = remapActualToDummyDescriptor(
272 loc, converter, symMap, argLambdaCapture, caller,
273 isBindcCall);
274 builder.create<fir::ResultOp>(loc, newBox);
275 })
276 .genElse([&]() {
277 mlir::Value absent =
278 builder.create<fir::AbsentOp>(loc, dummyType);
279 builder.create<fir::ResultOp>(loc, absent);
280 })
281 .getResults()[0];
282 caller.placeInput(arg, remapped);
283 }
284 }
285 }
286}
287
288std::pair<Fortran::lower::LoweredResult, bool>
289Fortran::lower::genCallOpAndResult(
290 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
291 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
292 Fortran::lower::CallerInterface &caller, mlir::FunctionType callSiteType,
293 std::optional<mlir::Type> resultType, bool isElemental) {
294 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
295 using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
296 bool mustPopSymMap = false;
297 if (caller.mustMapInterfaceSymbolsForResult()) {
298 symMap.pushScope();
299 mustPopSymMap = true;
300 Fortran::lower::mapCallInterfaceSymbolsForResult(converter, caller, symMap);
301 }
302 // If this is an indirect call, retrieve the function address. Also retrieve
303 // the result length if this is a character function (note that this length
304 // will be used only if there is no explicit length in the local interface).
305 mlir::Value funcPointer;
306 mlir::Value charFuncPointerLength;
307 if (const Fortran::evaluate::ProcedureDesignator *procDesignator =
308 caller.getIfIndirectCall()) {
309 if (mlir::Value passedArg = caller.getIfPassedArg()) {
310 // Procedure pointer component call with PASS argument. To avoid
311 // "double" lowering of the ComponentRef, semantics only place the
312 // ComponentRef in the ActualArguments, not in the ProcedureDesignator (
313 // that is only the component symbol).
314 // Fetch the passed argument and addresses of its procedure pointer
315 // component.
316 funcPointer = Fortran::lower::derefPassProcPointerComponent(
317 loc, converter, *procDesignator, passedArg, symMap, stmtCtx);
318 } else {
319 Fortran::lower::SomeExpr expr{*procDesignator};
320 fir::ExtendedValue loweredProc =
321 converter.genExprAddr(loc, expr, stmtCtx);
322 funcPointer = fir::getBase(loweredProc);
323 // Dummy procedure may have assumed length, in which case the result
324 // length was passed along the dummy procedure.
325 // This is not possible with procedure pointer components.
326 if (const fir::CharBoxValue *charBox = loweredProc.getCharBox())
327 charFuncPointerLength = charBox->getLen();
328 }
329 }
330 const bool isExprCall =
331 converter.getLoweringOptions().getLowerToHighLevelFIR() &&
332 callSiteType.getNumResults() == 1 &&
333 llvm::isa<fir::SequenceType>(callSiteType.getResult(0));
334
335 mlir::IndexType idxTy = builder.getIndexType();
336 auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value {
337 mlir::Value convertExpr = builder.createConvert(
338 loc, idxTy, fir::getBase(converter.genExprValue(expr, stmtCtx)));
339 return fir::factory::genMaxWithZero(builder, loc, convertExpr);
340 };
341 llvm::SmallVector<mlir::Value> resultLengths;
342 mlir::Value arrayResultShape;
343 hlfir::EvaluateInMemoryOp evaluateInMemory;
344 auto allocatedResult = [&]() -> std::optional<fir::ExtendedValue> {
345 llvm::SmallVector<mlir::Value> extents;
346 llvm::SmallVector<mlir::Value> lengths;
347 if (!caller.callerAllocateResult())
348 return {};
349 mlir::Type type = caller.getResultStorageType();
350 if (mlir::isa<fir::SequenceType>(type))
351 caller.walkResultExtents(
352 [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
353 assert(!isAssumedSizeExtent && "result cannot be assumed-size");
354 extents.emplace_back(lowerSpecExpr(e));
355 });
356 caller.walkResultLengths(
357 [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
358 assert(!isAssumedSizeExtent && "result cannot be assumed-size");
359 lengths.emplace_back(lowerSpecExpr(e));
360 });
361
362 // Result length parameters should not be provided to box storage
363 // allocation and save_results, but they are still useful information to
364 // keep in the ExtendedValue if non-deferred.
365 if (!mlir::isa<fir::BoxType>(type)) {
366 if (fir::isa_char(fir::unwrapSequenceType(type)) && lengths.empty()) {
367 // Calling an assumed length function. This is only possible if this
368 // is a call to a character dummy procedure.
369 if (!charFuncPointerLength)
370 fir::emitFatalError(loc, "failed to retrieve character function "
371 "length while calling it");
372 lengths.push_back(charFuncPointerLength);
373 }
374 resultLengths = lengths;
375 }
376
377 if (!extents.empty())
378 arrayResultShape = builder.genShape(loc, extents);
379
380 if (isExprCall) {
381 mlir::Type exprType = hlfir::getExprType(type);
382 evaluateInMemory = builder.create<hlfir::EvaluateInMemoryOp>(
383 loc, exprType, arrayResultShape, resultLengths);
384 builder.setInsertionPointToStart(&evaluateInMemory.getBody().front());
385 return toExtendedValue(loc, evaluateInMemory.getMemory(), extents,
386 lengths);
387 }
388
389 if ((!extents.empty() || !lengths.empty()) && !isElemental) {
390 // Note: in the elemental context, the alloca ownership inside the
391 // elemental region is implicit, and later pass in lowering (stack
392 // reclaim) fir.do_loop will be in charge of emitting any stack
393 // save/restore if needed.
394 auto *bldr = &converter.getFirOpBuilder();
395 mlir::Value sp = bldr->genStackSave(loc);
396 stmtCtx.attachCleanup(
397 [bldr, loc, sp]() { bldr->genStackRestore(loc, sp); });
398 }
399 mlir::Value temp =
400 builder.createTemporary(loc, type, ".result", extents, resultLengths);
401 return toExtendedValue(loc, temp, extents, lengths);
402 }();
403
404 if (mustPopSymMap)
405 symMap.popScope();
406
407 // Place allocated result
408 if (allocatedResult) {
409 if (std::optional<Fortran::lower::CallInterface<
410 Fortran::lower::CallerInterface>::PassedEntity>
411 resultArg = caller.getPassedResult()) {
412 if (resultArg->passBy == PassBy::AddressAndLength)
413 caller.placeAddressAndLengthInput(*resultArg,
414 fir::getBase(*allocatedResult),
415 fir::getLen(*allocatedResult));
416 else if (resultArg->passBy == PassBy::BaseAddress)
417 caller.placeInput(*resultArg, fir::getBase(*allocatedResult));
418 else
419 fir::emitFatalError(
420 loc, "only expect character scalar result to be passed by ref");
421 }
422 }
423
424 // In older Fortran, procedure argument types are inferred. This may lead
425 // different view of what the function signature is in different locations.
426 // Casts are inserted as needed below to accommodate this.
427
428 // The mlir::func::FuncOp type prevails, unless it has a different number of
429 // arguments which can happen in legal program if it was passed as a dummy
430 // procedure argument earlier with no further type information.
431 mlir::SymbolRefAttr funcSymbolAttr;
432 bool addHostAssociations = false;
433 if (!funcPointer) {
434 mlir::FunctionType funcOpType = caller.getFuncOp().getFunctionType();
435 mlir::SymbolRefAttr symbolAttr =
436 builder.getSymbolRefAttr(caller.getMangledName());
437 if (callSiteType.getNumResults() == funcOpType.getNumResults() &&
438 callSiteType.getNumInputs() + 1 == funcOpType.getNumInputs() &&
439 fir::anyFuncArgsHaveAttr(caller.getFuncOp(),
440 fir::getHostAssocAttrName())) {
441 // The number of arguments is off by one, and we're lowering a function
442 // with host associations. Modify call to include host associations
443 // argument by appending the value at the end of the operands.
444 assert(funcOpType.getInput(findHostAssocTuplePos(caller.getFuncOp())) ==
445 converter.hostAssocTupleValue().getType());
446 addHostAssociations = true;
447 }
448 // When this is not a call to an internal procedure (where there is a
449 // mismatch due to the extra argument, but the interface is otherwise
450 // explicit and safe), handle interface mismatch due to F77 implicit
451 // interface "abuse" with a function address cast if needed.
452 if (!addHostAssociations &&
453 mustCastFuncOpToCopeWithImplicitInterfaceMismatch(
454 loc, converter, callSiteType, funcOpType))
455 funcPointer = builder.create<fir::AddrOfOp>(loc, funcOpType, symbolAttr);
456 else
457 funcSymbolAttr = symbolAttr;
458
459 // Issue a warning if the procedure name conflicts with
460 // a runtime function name a call to which has been already
461 // lowered (implying that the FuncOp has been created).
462 // The behavior is undefined in this case.
463 if (caller.getFuncOp()->hasAttrOfType<mlir::UnitAttr>(
464 fir::FIROpsDialect::getFirRuntimeAttrName()))
465 LLVM_DEBUG(mlir::emitWarning(
466 loc,
467 llvm::Twine("function name '") +
468 llvm::Twine(symbolAttr.getLeafReference()) +
469 llvm::Twine("' conflicts with a runtime function name used by "
470 "Flang - this may lead to undefined behavior")));
471 }
472
473 mlir::FunctionType funcType =
474 funcPointer ? callSiteType : caller.getFuncOp().getFunctionType();
475 llvm::SmallVector<mlir::Value> operands;
476 // First operand of indirect call is the function pointer. Cast it to
477 // required function type for the call to handle procedures that have a
478 // compatible interface in Fortran, but that have different signatures in
479 // FIR.
480 if (funcPointer) {
481 operands.push_back(
482 mlir::isa<fir::BoxProcType>(funcPointer.getType())
483 ? builder.create<fir::BoxAddrOp>(loc, funcType, funcPointer)
484 : builder.createConvert(loc, funcType, funcPointer));
485 }
486
487 // Deal with potential mismatches in arguments types. Passing an array to a
488 // scalar argument should for instance be tolerated here.
489 for (auto [fst, snd] : llvm::zip(caller.getInputs(), funcType.getInputs())) {
490 // When passing arguments to a procedure that can be called by implicit
491 // interface, allow any character actual arguments to be passed to dummy
492 // arguments of any type and vice versa.
493 mlir::Value cast;
494 auto *context = builder.getContext();
495 if (mlir::isa<fir::BoxProcType>(snd) &&
496 mlir::isa<mlir::FunctionType>(fst.getType())) {
497 auto funcTy =
498 mlir::FunctionType::get(context, std::nullopt, std::nullopt);
499 auto boxProcTy = builder.getBoxProcType(funcTy);
500 if (mlir::Value host = argumentHostAssocs(converter, fst)) {
501 cast = builder.create<fir::EmboxProcOp>(
502 loc, boxProcTy, llvm::ArrayRef<mlir::Value>{fst, host});
503 } else {
504 cast = builder.create<fir::EmboxProcOp>(loc, boxProcTy, fst);
505 }
506 } else {
507 mlir::Type fromTy = fir::unwrapRefType(fst.getType());
508 if (fir::isa_builtin_cptr_type(fromTy) &&
509 Fortran::lower::isCPtrArgByValueType(snd)) {
510 cast = genRecordCPtrValueArg(builder, loc, fst, fromTy);
511 } else if (fir::isa_derived(snd) && !fir::isa_derived(fst.getType())) {
512 // TODO: remove this TODO once the old lowering is gone.
513 TODO(loc, "derived type argument passed by value");
514 } else {
515 // With the lowering to HLFIR, box arguments have already been built
516 // according to the attributes, rank, bounds, and type they should have.
517 // Do not attempt any reboxing here that could break this.
518 bool legacyLowering =
519 !converter.getLoweringOptions().getLowerToHighLevelFIR();
520 // When dealing with a dummy character argument (fir.boxchar), the
521 // effective argument might be a non-character raw pointer. This may
522 // happen when calling an implicit interface that was previously called
523 // with a character argument, or when calling an explicit interface with
524 // an IgnoreTKR dummy character arguments. Allow creating a fir.boxchar
525 // from the raw pointer, which requires a non-trivial type conversion.
526 const bool allowCharacterConversions = true;
527 bool isVolatile = fir::isa_volatile_type(snd);
528 cast = builder.createVolatileCast(loc, isVolatile, fst);
529 cast = builder.convertWithSemantics(loc, snd, cast,
530 allowCharacterConversions,
531 /*allowRebox=*/legacyLowering);
532 }
533 }
534 operands.push_back(cast);
535 }
536
537 // Add host associations as necessary.
538 if (addHostAssociations)
539 operands.push_back(converter.hostAssocTupleValue());
540
541 mlir::Value callResult;
542 unsigned callNumResults;
543 fir::FortranProcedureFlagsEnumAttr procAttrs =
544 caller.getProcedureAttrs(builder.getContext());
545
546 if (!caller.getCallDescription().chevrons().empty()) {
547 // A call to a CUDA kernel with the chevron syntax.
548
549 mlir::Type i32Ty = builder.getI32Type();
550 mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);
551
552 mlir::Value grid_x, grid_y, grid_z;
553 if (caller.getCallDescription().chevrons()[0].GetType()->category() ==
554 Fortran::common::TypeCategory::Integer) {
555 // If grid is an integer, it is converted to dim3(grid,1,1). Since z is
556 // not used for the number of thread blocks, it is omitted in the op.
557 grid_x = builder.createConvert(
558 loc, i32Ty,
559 fir::getBase(converter.genExprValue(
560 caller.getCallDescription().chevrons()[0], stmtCtx)));
561 grid_y = one;
562 grid_z = one;
563 } else {
564 auto dim3Addr = converter.genExprAddr(
565 caller.getCallDescription().chevrons()[0], stmtCtx);
566 grid_x = readDim3Value(builder, loc, fir::getBase(dim3Addr), "x");
567 grid_y = readDim3Value(builder, loc, fir::getBase(dim3Addr), "y");
568 grid_z = readDim3Value(builder, loc, fir::getBase(dim3Addr), "z");
569 }
570
571 mlir::Value block_x, block_y, block_z;
572 if (caller.getCallDescription().chevrons()[1].GetType()->category() ==
573 Fortran::common::TypeCategory::Integer) {
574 // If block is an integer, it is converted to dim3(block,1,1).
575 block_x = builder.createConvert(
576 loc, i32Ty,
577 fir::getBase(converter.genExprValue(
578 caller.getCallDescription().chevrons()[1], stmtCtx)));
579 block_y = one;
580 block_z = one;
581 } else {
582 auto dim3Addr = converter.genExprAddr(
583 caller.getCallDescription().chevrons()[1], stmtCtx);
584 block_x = readDim3Value(builder, loc, fir::getBase(dim3Addr), "x");
585 block_y = readDim3Value(builder, loc, fir::getBase(dim3Addr), "y");
586 block_z = readDim3Value(builder, loc, fir::getBase(dim3Addr), "z");
587 }
588
589 mlir::Value bytes; // bytes is optional.
590 if (caller.getCallDescription().chevrons().size() > 2)
591 bytes = builder.createConvert(
592 loc, i32Ty,
593 fir::getBase(converter.genExprValue(
594 caller.getCallDescription().chevrons()[2], stmtCtx)));
595
596 mlir::Value stream; // stream is optional.
597 if (caller.getCallDescription().chevrons().size() > 3)
598 stream = fir::getBase(converter.genExprAddr(
599 caller.getCallDescription().chevrons()[3], stmtCtx));
600
601 builder.create<cuf::KernelLaunchOp>(
602 loc, funcType.getResults(), funcSymbolAttr, grid_x, grid_y, grid_z,
603 block_x, block_y, block_z, bytes, stream, operands,
604 /*arg_attrs=*/nullptr, /*res_attrs=*/nullptr);
605 callNumResults = 0;
606 } else if (caller.requireDispatchCall()) {
607 // Procedure call requiring a dynamic dispatch. Call is created with
608 // fir.dispatch.
609
610 // Get the raw procedure name. The procedure name is not mangled in the
611 // binding table, but there can be a suffix to distinguish bindings of
612 // the same name (which happens only when PRIVATE bindings exist in
613 // ancestor types in other modules).
614 const auto &ultimateSymbol =
615 caller.getCallDescription().proc().GetSymbol()->GetUltimate();
616 std::string procName = ultimateSymbol.name().ToString();
617 if (const auto &binding{
618 ultimateSymbol.get<Fortran::semantics::ProcBindingDetails>()};
619 binding.numPrivatesNotOverridden() > 0)
620 procName += "."s + std::to_string(binding.numPrivatesNotOverridden());
621 fir::DispatchOp dispatch;
622 if (std::optional<unsigned> passArg = caller.getPassArgIndex()) {
623 // PASS, PASS(arg-name)
624 // Note that caller.getInputs is used instead of operands to get the
625 // passed object because interface mismatch issues may have inserted a
626 // cast to the operand with a different declared type, which would break
627 // later type bound call resolution in the FIR to FIR pass.
628 dispatch = builder.create<fir::DispatchOp>(
629 loc, funcType.getResults(), builder.getStringAttr(procName),
630 caller.getInputs()[*passArg], operands,
631 builder.getI32IntegerAttr(*passArg), /*arg_attrs=*/nullptr,
632 /*res_attrs=*/nullptr, procAttrs);
633 } else {
634 // NOPASS
635 const Fortran::evaluate::Component *component =
636 caller.getCallDescription().proc().GetComponent();
637 assert(component && "expect component for type-bound procedure call.");
638
639 fir::ExtendedValue dataRefValue = Fortran::lower::convertDataRefToValue(
640 loc, converter, component->base(), symMap, stmtCtx);
641 mlir::Value passObject = fir::getBase(dataRefValue);
642
643 if (fir::isa_ref_type(passObject.getType()))
644 passObject = builder.create<fir::LoadOp>(loc, passObject);
645 dispatch = builder.create<fir::DispatchOp>(
646 loc, funcType.getResults(), builder.getStringAttr(procName),
647 passObject, operands, nullptr, /*arg_attrs=*/nullptr,
648 /*res_attrs=*/nullptr, procAttrs);
649 }
650 callNumResults = dispatch.getNumResults();
651 if (callNumResults != 0)
652 callResult = dispatch.getResult(0);
653 } else {
654 // Standard procedure call with fir.call.
655 auto call = builder.create<fir::CallOp>(
656 loc, funcType.getResults(), funcSymbolAttr, operands,
657 /*arg_attrs=*/nullptr, /*res_attrs=*/nullptr, procAttrs);
658
659 callNumResults = call.getNumResults();
660 if (callNumResults != 0)
661 callResult = call.getResult(0);
662 }
663
664 std::optional<Fortran::evaluate::DynamicType> retTy =
665 caller.getCallDescription().proc().GetType();
666 // With HLFIR lowering, isElemental must be set to true
667 // if we are producing an elemental call. In this case,
668 // the elemental results must not be destroyed, instead,
669 // the resulting array result will be finalized/destroyed
670 // as needed by hlfir.destroy.
671 const bool mustFinalizeResult =
672 !isElemental && callSiteType.getNumResults() > 0 &&
673 !fir::isPointerType(callSiteType.getResult(0)) && retTy.has_value() &&
674 (retTy->category() == Fortran::common::TypeCategory::Derived ||
675 retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic());
676
677 if (caller.mustSaveResult()) {
678 assert(allocatedResult.has_value());
679 builder.create<fir::SaveResultOp>(loc, callResult,
680 fir::getBase(*allocatedResult),
681 arrayResultShape, resultLengths);
682 }
683
684 if (evaluateInMemory) {
685 builder.setInsertionPointAfter(evaluateInMemory);
686 mlir::Value expr = evaluateInMemory.getResult();
687 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
688 if (!isElemental)
689 stmtCtx.attachCleanup([bldr, loc, expr, mustFinalizeResult]() {
690 bldr->create<hlfir::DestroyOp>(loc, expr,
691 /*finalize=*/mustFinalizeResult);
692 });
693 return {LoweredResult{hlfir::EntityWithAttributes{expr}},
694 mustFinalizeResult};
695 }
696
697 if (allocatedResult) {
698 // The result must be optionally destroyed (if it is of a derived type
699 // that may need finalization or deallocation of the components).
700 // For an allocatable result we have to free the memory allocated
701 // for the top-level entity. Note that the Destroy calls below
702 // do not deallocate the top-level entity. The two clean-ups
703 // must be pushed in reverse order, so that the final order is:
704 // Destroy(desc)
705 // free(desc->base_addr)
706 allocatedResult->match(
707 [&](const fir::MutableBoxValue &box) {
708 if (box.isAllocatable()) {
709 // 9.7.3.2 point 4. Deallocate allocatable results. Note that
710 // finalization was done independently by calling
711 // genDerivedTypeDestroy above and is not triggered by this inline
712 // deallocation.
713 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
714 stmtCtx.attachCleanup([bldr, loc, box]() {
715 fir::factory::genFreememIfAllocated(*bldr, loc, box);
716 });
717 }
718 },
719 [](const auto &) {});
720
721 // 7.5.6.3 point 5. Derived-type finalization for nonpointer function.
722 bool resultIsFinalized = false;
723 // Check if the derived-type is finalizable if it is a monomorphic
724 // derived-type.
725 // For polymorphic and unlimited polymorphic enities call the runtime
726 // in any cases.
727 if (mustFinalizeResult) {
728 if (retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic()) {
729 auto *bldr = &converter.getFirOpBuilder();
730 stmtCtx.attachCleanup([bldr, loc, allocatedResult]() {
731 fir::runtime::genDerivedTypeDestroy(*bldr, loc,
732 fir::getBase(*allocatedResult));
733 });
734 resultIsFinalized = true;
735 } else {
736 const Fortran::semantics::DerivedTypeSpec &typeSpec =
737 retTy->GetDerivedTypeSpec();
738 // If the result type may require finalization
739 // or have allocatable components, we need to make sure
740 // everything is properly finalized/deallocated.
741 if (Fortran::semantics::MayRequireFinalization(typeSpec) ||
742 // We can use DerivedTypeDestroy even if finalization is not needed.
743 hlfir::mayHaveAllocatableComponent(funcType.getResults()[0])) {
744 auto *bldr = &converter.getFirOpBuilder();
745 stmtCtx.attachCleanup([bldr, loc, allocatedResult]() {
746 mlir::Value box = bldr->createBox(loc, *allocatedResult);
747 fir::runtime::genDerivedTypeDestroy(*bldr, loc, box);
748 });
749 resultIsFinalized = true;
750 }
751 }
752 }
753 return {LoweredResult{*allocatedResult}, resultIsFinalized};
754 }
755
756 // subroutine call
757 if (!resultType)
758 return {LoweredResult{fir::ExtendedValue{mlir::Value{}}},
759 /*resultIsFinalized=*/false};
760
761 // For now, Fortran return values are implemented with a single MLIR
762 // function return value.
763 assert(callNumResults == 1 && "Expected exactly one result in FUNCTION call");
764 (void)callNumResults;
765
766 // Call a BIND(C) function that return a char.
767 if (caller.characterize().IsBindC() &&
768 mlir::isa<fir::CharacterType>(funcType.getResults()[0])) {
769 fir::CharacterType charTy =
770 mlir::dyn_cast<fir::CharacterType>(funcType.getResults()[0]);
771 mlir::Value len = builder.createIntegerConstant(
772 loc, builder.getCharacterLengthType(), charTy.getLen());
773 return {
774 LoweredResult{fir::ExtendedValue{fir::CharBoxValue{callResult, len}}},
775 /*resultIsFinalized=*/false};
776 }
777
778 return {LoweredResult{fir::ExtendedValue{callResult}},
779 /*resultIsFinalized=*/false};
780}
781
782static hlfir::EntityWithAttributes genStmtFunctionRef(
783 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
784 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
785 const Fortran::evaluate::ProcedureRef &procRef) {
786 const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
787 assert(symbol && "expected symbol in ProcedureRef of statement functions");
788 const auto &details = symbol->get<Fortran::semantics::SubprogramDetails>();
789 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
790
791 // Statement functions have their own scope, we just need to associate
792 // the dummy symbols to argument expressions. There are no
793 // optional/alternate return arguments. Statement functions cannot be
794 // recursive (directly or indirectly) so it is safe to add dummy symbols to
795 // the local map here.
796 symMap.pushScope();
797 llvm::SmallVector<hlfir::AssociateOp> exprAssociations;
798 for (auto [arg, bind] : llvm::zip(details.dummyArgs(), procRef.arguments())) {
799 assert(arg && "alternate return in statement function");
800 assert(bind && "optional argument in statement function");
801 const auto *expr = bind->UnwrapExpr();
802 // TODO: assumed type in statement function, that surprisingly seems
803 // allowed, probably because nobody thought of restricting this usage.
804 // gfortran/ifort compiles this.
805 assert(expr && "assumed type used as statement function argument");
806 // As per Fortran 2018 C1580, statement function arguments can only be
807 // scalars.
808 // The only care is to use the dummy character explicit length if any
809 // instead of the actual argument length (that can be bigger).
810 hlfir::EntityWithAttributes loweredArg = Fortran::lower::convertExprToHLFIR(
811 loc, converter, *expr, symMap, stmtCtx);
812 fir::FortranVariableOpInterface variableIface = loweredArg.getIfVariable();
813 if (!variableIface) {
814 // So far only FortranVariableOpInterface can be mapped to symbols.
815 // Create an hlfir.associate to create a variable from a potential
816 // value argument.
817 mlir::Type argType = converter.genType(*arg);
818 auto associate = hlfir::genAssociateExpr(
819 loc, builder, loweredArg, argType, toStringRef(arg->name()));
820 exprAssociations.push_back(associate);
821 variableIface = associate;
822 }
823 const Fortran::semantics::DeclTypeSpec *type = arg->GetType();
824 if (type &&
825 type->category() == Fortran::semantics::DeclTypeSpec::Character) {
826 // Instantiate character as if it was a normal dummy argument so that the
827 // statement function dummy character length is applied and dealt with
828 // correctly.
829 symMap.addSymbol(*arg, variableIface.getBase());
830 Fortran::lower::mapSymbolAttributes(converter, *arg, symMap, stmtCtx);
831 } else {
832 // No need to create an extra hlfir.declare otherwise for
833 // numerical and logical scalar dummies.
834 symMap.addVariableDefinition(*arg, variableIface);
835 }
836 }
837
838 // Explicitly map statement function host associated symbols to their
839 // parent scope lowered symbol box.
840 for (const Fortran::semantics::SymbolRef &sym :
841 Fortran::evaluate::CollectSymbols(*details.stmtFunction()))
842 if (const auto *details =
843 sym->detailsIf<Fortran::semantics::HostAssocDetails>())
844 converter.copySymbolBinding(details->symbol(), sym);
845
846 hlfir::Entity result = Fortran::lower::convertExprToHLFIR(
847 loc, converter, details.stmtFunction().value(), symMap, stmtCtx);
848 symMap.popScope();
849 // The result must not be a variable.
850 result = hlfir::loadTrivialScalar(loc, builder, result);
851 if (result.isVariable())
852 result = hlfir::Entity{builder.create<hlfir::AsExprOp>(loc, result)};
853 for (auto associate : exprAssociations)
854 builder.create<hlfir::EndAssociateOp>(loc, associate);
855 return hlfir::EntityWithAttributes{result};
856}
857
858namespace {
859// Structure to hold the information about the call and the lowering context.
860// This structure is intended to help threading the information
861// through the various lowering calls without having to pass every
862// required structure one by one.
863struct CallContext {
864 CallContext(const Fortran::evaluate::ProcedureRef &procRef,
865 std::optional<mlir::Type> resultType, mlir::Location loc,
866 Fortran::lower::AbstractConverter &converter,
867 Fortran::lower::SymMap &symMap,
868 Fortran::lower::StatementContext &stmtCtx)
869 : procRef{procRef}, converter{converter}, symMap{symMap},
870 stmtCtx{stmtCtx}, resultType{resultType}, loc{loc} {}
871
872 fir::FirOpBuilder &getBuilder() { return converter.getFirOpBuilder(); }
873
874 std::string getProcedureName() const {
875 if (const Fortran::semantics::Symbol *sym = procRef.proc().GetSymbol())
876 return sym->GetUltimate().name().ToString();
877 return procRef.proc().GetName();
878 }
879
880 /// Is this a call to an elemental procedure with at least one array argument?
881 bool isElementalProcWithArrayArgs() const {
882 if (procRef.IsElemental())
883 for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
884 procRef.arguments())
885 if (arg && arg->Rank() != 0)
886 return true;
887 return false;
888 }
889
890 /// Is this a statement function reference?
891 bool isStatementFunctionCall() const {
892 if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
893 if (const auto *details =
894 symbol->detailsIf<Fortran::semantics::SubprogramDetails>())
895 return details->stmtFunction().has_value();
896 return false;
897 }
898
899 /// Is this a call to a BIND(C) procedure?
900 bool isBindcCall() const {
901 if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
902 return Fortran::semantics::IsBindCProcedure(*symbol);
903 return false;
904 }
905
906 const Fortran::evaluate::ProcedureRef &procRef;
907 Fortran::lower::AbstractConverter &converter;
908 Fortran::lower::SymMap &symMap;
909 Fortran::lower::StatementContext &stmtCtx;
910 std::optional<mlir::Type> resultType;
911 mlir::Location loc;
912};
913
914using ExvAndCleanup =
915 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>;
916} // namespace
917
918// Helper to transform a fir::ExtendedValue to an hlfir::EntityWithAttributes.
919static hlfir::EntityWithAttributes
920extendedValueToHlfirEntity(mlir::Location loc, fir::FirOpBuilder &builder,
921 const fir::ExtendedValue &exv,
922 llvm::StringRef name) {
923 mlir::Value firBase = fir::getBase(exv);
924 mlir::Type firBaseTy = firBase.getType();
925 if (fir::isa_trivial(firBaseTy))
926 return hlfir::EntityWithAttributes{firBase};
927 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(firBase.getType())) {
928 // CHAR() intrinsic and BIND(C) procedures returning CHARACTER(1)
929 // are lowered to a fir.char<kind,1> that is not in memory.
930 // This tends to cause a lot of bugs because the rest of the
931 // infrastructure is mostly tested with characters that are
932 // in memory.
933 // To avoid having to deal with this special case here and there,
934 // place it in memory here. If this turns out to be suboptimal,
935 // this could be fixed, but for now llvm opt -O1 is able to get
936 // rid of the memory indirection in a = char(b), so there is
937 // little incentive to increase the compiler complexity.
938 hlfir::Entity storage{builder.createTemporary(loc, charTy)};
939 builder.create<fir::StoreOp>(loc, firBase, storage);
940 auto asExpr = builder.create<hlfir::AsExprOp>(
941 loc, storage, /*mustFree=*/builder.createBool(loc, false));
942 return hlfir::EntityWithAttributes{asExpr.getResult()};
943 }
944 return hlfir::genDeclare(loc, builder, exv, name,
945 fir::FortranVariableFlagsAttr{});
946}
947namespace {
948/// Structure to hold the clean-up related to a dummy argument preparation
949/// that may have to be done after a call (copy-out or temporary deallocation).
950struct CallCleanUp {
951 struct CopyIn {
952 void genCleanUp(mlir::Location loc, fir::FirOpBuilder &builder) {
953 builder.create<hlfir::CopyOutOp>(loc, tempBox, wasCopied, copyBackVar);
954 }
955 // address of the descriptor holding the temp if a temp was created.
956 mlir::Value tempBox;
957 // Boolean indicating if a copy was made or not.
958 mlir::Value wasCopied;
959 // copyBackVar may be null if copy back is not needed.
960 mlir::Value copyBackVar;
961 };
962 struct ExprAssociate {
963 void genCleanUp(mlir::Location loc, fir::FirOpBuilder &builder) {
964 builder.create<hlfir::EndAssociateOp>(loc, tempVar, mustFree);
965 }
966 mlir::Value tempVar;
967 mlir::Value mustFree;
968 };
969
970 /// Generate clean-up code.
971 /// If \p postponeAssociates is true, the ExprAssociate clean-up
972 /// is not generated, and instead the corresponding CallCleanUp
973 /// object is returned as the result.
974 std::optional<CallCleanUp> genCleanUp(mlir::Location loc,
975 fir::FirOpBuilder &builder,
976 bool postponeAssociates) {
977 std::optional<CallCleanUp> postponed;
978 Fortran::common::visit(Fortran::common::visitors{
979 [&](CopyIn &c) { c.genCleanUp(loc, builder); },
980 [&](ExprAssociate &c) {
981 if (postponeAssociates)
982 postponed = CallCleanUp{c};
983 else
984 c.genCleanUp(loc, builder);
985 },
986 },
987 cleanUp);
988 return postponed;
989 }
990 std::variant<CopyIn, ExprAssociate> cleanUp;
991};
992
993/// Structure representing a prepared dummy argument.
994/// It holds the value to be passed in the call and any related
995/// clean-ups to be done after the call.
996struct PreparedDummyArgument {
997 void pushCopyInCleanUp(mlir::Value tempBox, mlir::Value wasCopied,
998 mlir::Value copyBackVar) {
999 cleanups.emplace_back(
1000 Args: CallCleanUp{CallCleanUp::CopyIn{tempBox, wasCopied, copyBackVar}});
1001 }
1002 void pushExprAssociateCleanUp(mlir::Value tempVar, mlir::Value wasCopied) {
1003 cleanups.emplace_back(
1004 Args: CallCleanUp{CallCleanUp::ExprAssociate{tempVar, wasCopied}});
1005 }
1006 void pushExprAssociateCleanUp(hlfir::AssociateOp associate) {
1007 mlir::Value hlfirBase = associate.getBase();
1008 mlir::Value firBase = associate.getFirBase();
1009 cleanups.emplace_back(CallCleanUp{CallCleanUp::ExprAssociate{
1010 hlfir::mayHaveAllocatableComponent(hlfirBase.getType()) ? hlfirBase
1011 : firBase,
1012 associate.getMustFreeStrorageFlag()}});
1013 }
1014
1015 mlir::Value dummy;
1016 // NOTE: the clean-ups are executed in reverse order.
1017 llvm::SmallVector<CallCleanUp, 2> cleanups;
1018};
1019
1020/// Structure to help conditionally preparing a dummy argument based
1021/// on the actual argument presence.
1022/// It helps "wrapping" the dummy and the clean-up information in
1023/// an if (present) {...}:
1024///
1025/// %conditionallyPrepared = fir.if (%present) {
1026/// fir.result %preparedDummy
1027/// } else {
1028/// fir.result %absent
1029/// }
1030///
1031struct ConditionallyPreparedDummy {
1032 /// Create ConditionallyPreparedDummy from a preparedDummy that must
1033 /// be wrapped in a fir.if.
1034 ConditionallyPreparedDummy(PreparedDummyArgument &preparedDummy) {
1035 thenResultValues.push_back(preparedDummy.dummy);
1036 for (const CallCleanUp &c : preparedDummy.cleanups) {
1037 if (const auto *copyInCleanUp =
1038 std::get_if<CallCleanUp::CopyIn>(&c.cleanUp)) {
1039 thenResultValues.push_back(copyInCleanUp->wasCopied);
1040 if (copyInCleanUp->copyBackVar)
1041 thenResultValues.push_back(copyInCleanUp->copyBackVar);
1042 } else {
1043 const auto &exprAssociate =
1044 std::get<CallCleanUp::ExprAssociate>(c.cleanUp);
1045 thenResultValues.push_back(exprAssociate.tempVar);
1046 thenResultValues.push_back(exprAssociate.mustFree);
1047 }
1048 }
1049 }
1050
1051 /// Get the result types of the wrapping fir.if that must be created.
1052 llvm::SmallVector<mlir::Type> getIfResulTypes() const {
1053 llvm::SmallVector<mlir::Type> types;
1054 for (mlir::Value res : thenResultValues)
1055 types.push_back(res.getType());
1056 return types;
1057 }
1058
1059 /// Generate the "fir.result %preparedDummy" in the then branch of the
1060 /// wrapping fir.if.
1061 void genThenResult(mlir::Location loc, fir::FirOpBuilder &builder) const {
1062 builder.create<fir::ResultOp>(loc, thenResultValues);
1063 }
1064
1065 /// Generate the "fir.result %absent" in the else branch of the
1066 /// wrapping fir.if.
1067 void genElseResult(mlir::Location loc, fir::FirOpBuilder &builder) const {
1068 llvm::SmallVector<mlir::Value> elseResultValues;
1069 mlir::Type i1Type = builder.getI1Type();
1070 for (mlir::Value res : thenResultValues) {
1071 mlir::Type type = res.getType();
1072 if (type == i1Type)
1073 elseResultValues.push_back(builder.createBool(loc, false));
1074 else
1075 elseResultValues.push_back(builder.genAbsentOp(loc, type));
1076 }
1077 builder.create<fir::ResultOp>(loc, elseResultValues);
1078 }
1079
1080 /// Once the fir.if has been created, get the resulting %conditionallyPrepared
1081 /// dummy argument.
1082 PreparedDummyArgument
1083 getPreparedDummy(fir::IfOp ifOp,
1084 const PreparedDummyArgument &unconditionalDummy) {
1085 PreparedDummyArgument preparedDummy;
1086 preparedDummy.dummy = ifOp.getResults()[0];
1087 for (const CallCleanUp &c : unconditionalDummy.cleanups) {
1088 if (const auto *copyInCleanUp =
1089 std::get_if<CallCleanUp::CopyIn>(&c.cleanUp)) {
1090 mlir::Value copyBackVar;
1091 if (copyInCleanUp->copyBackVar)
1092 copyBackVar = ifOp.getResults().back();
1093 // tempBox is an hlfir.copy_in argument created outside of the
1094 // fir.if region. It needs not to be threaded as a fir.if result.
1095 preparedDummy.pushCopyInCleanUp(copyInCleanUp->tempBox,
1096 ifOp.getResults()[1], copyBackVar);
1097 } else {
1098 preparedDummy.pushExprAssociateCleanUp(ifOp.getResults()[1],
1099 ifOp.getResults()[2]);
1100 }
1101 }
1102 return preparedDummy;
1103 }
1104
1105 llvm::SmallVector<mlir::Value> thenResultValues;
1106};
1107} // namespace
1108
1109/// Fix-up the fact that it is supported to pass a character procedure
1110/// designator to a non character procedure dummy procedure and vice-versa, even
1111/// in case of explicit interface. Uglier cases where an object is passed as
1112/// procedure designator or vice versa are handled only for implicit interfaces
1113/// (refused by semantics with explicit interface), and handled with a funcOp
1114/// cast like other implicit interface mismatches.
1115static hlfir::Entity fixProcedureDummyMismatch(mlir::Location loc,
1116 fir::FirOpBuilder &builder,
1117 hlfir::Entity actual,
1118 mlir::Type dummyType) {
1119 if (mlir::isa<fir::BoxProcType>(actual.getType()) &&
1120 fir::isCharacterProcedureTuple(dummyType)) {
1121 mlir::Value length =
1122 builder.create<fir::UndefOp>(loc, builder.getCharacterLengthType());
1123 mlir::Value tuple = fir::factory::createCharacterProcedureTuple(
1124 builder, loc, dummyType, actual, length);
1125 return hlfir::Entity{tuple};
1126 }
1127 assert(fir::isCharacterProcedureTuple(actual.getType()) &&
1128 mlir::isa<fir::BoxProcType>(dummyType) &&
1129 "unsupported dummy procedure mismatch with the actual argument");
1130 mlir::Value boxProc = fir::factory::extractCharacterProcedureTuple(
1131 builder, loc, actual, /*openBoxProc=*/false)
1132 .first;
1133 return hlfir::Entity{boxProc};
1134}
1135
1136mlir::Value static getZeroLowerBounds(mlir::Location loc,
1137 fir::FirOpBuilder &builder,
1138 hlfir::Entity entity) {
1139 assert(!entity.isAssumedRank() &&
1140 "assumed-rank must use fir.rebox_assumed_rank");
1141 if (entity.getRank() < 1)
1142 return {};
1143 mlir::Value zero =
1144 builder.createIntegerConstant(loc, builder.getIndexType(), 0);
1145 llvm::SmallVector<mlir::Value> lowerBounds(entity.getRank(), zero);
1146 return builder.genShift(loc, lowerBounds);
1147}
1148
1149static bool
1150isSimplyContiguous(const Fortran::evaluate::ActualArgument &arg,
1151 Fortran::evaluate::FoldingContext &foldingContext) {
1152 if (const auto *expr = arg.UnwrapExpr())
1153 return Fortran::evaluate::IsSimplyContiguous(*expr, foldingContext);
1154 const Fortran::semantics::Symbol *sym = arg.GetAssumedTypeDummy();
1155 assert(sym &&
1156 "expect ActualArguments to be expression or assumed-type symbols");
1157 return sym->Rank() == 0 ||
1158 Fortran::evaluate::IsSimplyContiguous(*sym, foldingContext);
1159}
1160
1161static bool isParameterObjectOrSubObject(hlfir::Entity entity) {
1162 mlir::Value base = entity;
1163 bool foundParameter = false;
1164 while (mlir::Operation *op = base ? base.getDefiningOp() : nullptr) {
1165 base =
1166 llvm::TypeSwitch<mlir::Operation *, mlir::Value>(op)
1167 .Case<hlfir::DeclareOp>([&](auto declare) -> mlir::Value {
1168 foundParameter |= hlfir::Entity{declare}.isParameter();
1169 return foundParameter ? mlir::Value{} : declare.getMemref();
1170 })
1171 .Case<hlfir::DesignateOp, hlfir::ParentComponentOp, fir::EmboxOp>(
1172 [&](auto op) -> mlir::Value { return op.getMemref(); })
1173 .Case<fir::ReboxOp>(
1174 [&](auto rebox) -> mlir::Value { return rebox.getBox(); })
1175 .Case<fir::ConvertOp>(
1176 [&](auto convert) -> mlir::Value { return convert.getValue(); })
1177 .Default([](mlir::Operation *) -> mlir::Value { return nullptr; });
1178 }
1179 return foundParameter;
1180}
1181
1182/// When dummy is not ALLOCATABLE, POINTER and is not passed in register,
1183/// prepare the actual argument according to the interface. Do as needed:
1184/// - address element if this is an array argument in an elemental call.
1185/// - set dynamic type to the dummy type if the dummy is not polymorphic.
1186/// - copy-in into contiguous variable if the dummy must be contiguous
1187/// - copy into a temporary if the dummy has the VALUE attribute.
1188/// - package the prepared dummy as required (fir.box, fir.class,
1189/// fir.box_char...).
1190/// This function should only be called with an actual that is present.
1191/// The optional aspects must be handled by this function user.
1192static PreparedDummyArgument preparePresentUserCallActualArgument(
1193 mlir::Location loc, fir::FirOpBuilder &builder,
1194 const Fortran::lower::PreparedActualArgument &preparedActual,
1195 mlir::Type dummyType,
1196 const Fortran::lower::CallerInterface::PassedEntity &arg,
1197 CallContext &callContext) {
1198
1199 Fortran::evaluate::FoldingContext &foldingContext =
1200 callContext.converter.getFoldingContext();
1201
1202 // Step 1: get the actual argument, which includes addressing the
1203 // element if this is an array in an elemental call.
1204 hlfir::Entity actual = preparedActual.getActual(loc, builder);
1205
1206 // Handle procedure arguments (procedure pointers should go through
1207 // prepareProcedurePointerActualArgument).
1208 if (hlfir::isFortranProcedureValue(dummyType)) {
1209 // Procedure pointer or function returns procedure pointer actual to
1210 // procedure dummy.
1211 if (actual.isProcedurePointer()) {
1212 actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);
1213 return PreparedDummyArgument{actual, /*cleanups=*/{}};
1214 }
1215 // Procedure actual to procedure dummy.
1216 assert(actual.isProcedure());
1217 // Do nothing if this is a procedure argument. It is already a
1218 // fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
1219 if (!mlir::isa<fir::BoxProcType>(actual.getType()) &&
1220 actual.getType() != dummyType)
1221 // The actual argument may be a procedure that returns character (a
1222 // fir.tuple<fir.boxproc, len>) while the dummy is not. Extract the tuple
1223 // in that case.
1224 actual = fixProcedureDummyMismatch(loc, builder, actual, dummyType);
1225 return PreparedDummyArgument{actual, /*cleanups=*/{}};
1226 }
1227
1228 const bool ignoreTKRtype = arg.testTKR(Fortran::common::IgnoreTKR::Type);
1229 const bool passingPolymorphicToNonPolymorphic =
1230 actual.isPolymorphic() && !fir::isPolymorphicType(dummyType) &&
1231 !ignoreTKRtype;
1232
1233 // When passing a CLASS(T) to TYPE(T), only the "T" part must be
1234 // passed. Unless the entity is a scalar passed by raw address, a
1235 // new descriptor must be made using the dummy argument type as
1236 // dynamic type. This must be done before any copy/copy-in because the
1237 // dynamic type matters to determine the contiguity.
1238 const bool mustSetDynamicTypeToDummyType =
1239 passingPolymorphicToNonPolymorphic &&
1240 (actual.isArray() || mlir::isa<fir::BaseBoxType>(dummyType));
1241
1242 // The simple contiguity of the actual is "lost" when passing a polymorphic
1243 // to a non polymorphic entity because the dummy dynamic type matters for
1244 // the contiguity.
1245 const bool mustDoCopyInOut =
1246 actual.isArray() && arg.mustBeMadeContiguous() &&
1247 (passingPolymorphicToNonPolymorphic ||
1248 !isSimplyContiguous(*arg.entity, foldingContext));
1249
1250 const bool actualIsAssumedRank = actual.isAssumedRank();
1251 // Create dummy type with actual argument rank when the dummy is an assumed
1252 // rank. That way, all the operation to create dummy descriptors are ranked if
1253 // the actual argument is ranked, which allows simple code generation.
1254 // Also do the same when the dummy is a sequence associated descriptor
1255 // because the actual shape/rank may mismatch with the dummy, and the dummy
1256 // may be an assumed-size array, so any descriptor manipulation should use the
1257 // actual argument shape information. A descriptor with the dummy shape
1258 // information will be created later when all actual arguments are ready.
1259 mlir::Type dummyTypeWithActualRank = dummyType;
1260 if (auto baseBoxDummy = mlir::dyn_cast<fir::BaseBoxType>(dummyType)) {
1261 if (baseBoxDummy.isAssumedRank() ||
1262 arg.testTKR(Fortran::common::IgnoreTKR::Rank) ||
1263 arg.isSequenceAssociatedDescriptor()) {
1264 mlir::Type actualTy =
1265 hlfir::getFortranElementOrSequenceType(actual.getType());
1266 dummyTypeWithActualRank = baseBoxDummy.getBoxTypeWithNewShape(actualTy);
1267 }
1268 }
1269 // Preserve the actual type in the argument preparation in case IgnoreTKR(t)
1270 // is set (descriptors must be created with the actual type in this case, and
1271 // copy-in/copy-out should be driven by the contiguity with regard to the
1272 // actual type).
1273 if (ignoreTKRtype) {
1274 if (auto boxCharType =
1275 mlir::dyn_cast<fir::BoxCharType>(dummyTypeWithActualRank)) {
1276 auto maybeActualCharType =
1277 mlir::dyn_cast<fir::CharacterType>(actual.getFortranElementType());
1278 if (!maybeActualCharType ||
1279 maybeActualCharType.getFKind() != boxCharType.getKind()) {
1280 // When passing to a fir.boxchar with ignore(tk), prepare the argument
1281 // as if only the raw address must be passed.
1282 dummyTypeWithActualRank =
1283 fir::ReferenceType::get(actual.getElementOrSequenceType());
1284 }
1285 // Otherwise, the actual is already a character with the same kind as the
1286 // dummy and can be passed normally.
1287 } else {
1288 dummyTypeWithActualRank = fir::changeElementType(
1289 dummyTypeWithActualRank, actual.getFortranElementType(),
1290 actual.isPolymorphic());
1291 }
1292 }
1293
1294 PreparedDummyArgument preparedDummy;
1295
1296 // Helpers to generate hlfir.copy_in operation and register the related
1297 // hlfir.copy_out creation.
1298 auto genCopyIn = [&](hlfir::Entity var, bool doCopyOut) -> hlfir::Entity {
1299 auto baseBoxTy = mlir::dyn_cast<fir::BaseBoxType>(var.getType());
1300 assert(baseBoxTy && "expect non simply contiguous variables to be boxes");
1301 // Create allocatable descriptor for the potential temporary.
1302 mlir::Type tempBoxType = baseBoxTy.getBoxTypeWithNewAttr(
1303 fir::BaseBoxType::Attribute::Allocatable);
1304 mlir::Value tempBox = builder.createTemporary(loc, tempBoxType);
1305 auto copyIn = builder.create<hlfir::CopyInOp>(
1306 loc, var, tempBox, /*var_is_present=*/mlir::Value{});
1307 // Register the copy-out after the call.
1308 preparedDummy.pushCopyInCleanUp(copyIn.getTempBox(), copyIn.getWasCopied(),
1309 doCopyOut ? copyIn.getVar()
1310 : mlir::Value{});
1311 return hlfir::Entity{copyIn.getCopiedIn()};
1312 };
1313
1314 auto genSetDynamicTypeToDummyType = [&](hlfir::Entity var) -> hlfir::Entity {
1315 fir::BaseBoxType boxType = fir::BoxType::get(
1316 hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
1317 if (actualIsAssumedRank)
1318 return hlfir::Entity{builder.create<fir::ReboxAssumedRankOp>(
1319 loc, boxType, var, fir::LowerBoundModifierAttribute::SetToOnes)};
1320 // Use actual shape when creating descriptor with dummy type, the dummy
1321 // shape may be unknown in case of sequence association.
1322 mlir::Type actualTy =
1323 hlfir::getFortranElementOrSequenceType(actual.getType());
1324 boxType = boxType.getBoxTypeWithNewShape(actualTy);
1325 return hlfir::Entity{builder.create<fir::ReboxOp>(loc, boxType, var,
1326 /*shape=*/mlir::Value{},
1327 /*slice=*/mlir::Value{})};
1328 };
1329
1330 // Step 2: prepare the storage for the dummy arguments, ensuring that it
1331 // matches the dummy requirements (e.g., must be contiguous or must be
1332 // a temporary).
1333 hlfir::Entity entity =
1334 hlfir::derefPointersAndAllocatables(loc, builder, actual);
1335 if (entity.isVariable()) {
1336 // Set dynamic type if needed before any copy-in or copy so that the dummy
1337 // is contiguous according to the dummy type.
1338 if (mustSetDynamicTypeToDummyType)
1339 entity = genSetDynamicTypeToDummyType(entity);
1340 if (arg.hasValueAttribute() ||
1341 // Constant expressions might be lowered as variables with
1342 // 'parameter' attribute. Even though the constant expressions
1343 // are not definable and explicit assignments to them are not
1344 // possible, we have to create a temporary copies when we pass
1345 // them down the call stack because of potential compiler
1346 // generated writes in copy-out.
1347 isParameterObjectOrSubObject(entity)) {
1348 // Make a copy in a temporary.
1349 auto copy = builder.create<hlfir::AsExprOp>(loc, entity);
1350 mlir::Type storageType = entity.getType();
1351 mlir::NamedAttribute byRefAttr = fir::getAdaptToByRefAttr(builder);
1352 hlfir::AssociateOp associate = hlfir::genAssociateExpr(
1353 loc, builder, hlfir::Entity{copy}, storageType, "", byRefAttr);
1354 entity = hlfir::Entity{associate.getBase()};
1355 // Register the temporary destruction after the call.
1356 preparedDummy.pushExprAssociateCleanUp(associate);
1357 } else if (mustDoCopyInOut) {
1358 // Copy-in non contiguous variables.
1359 // TODO: for non-finalizable monomorphic derived type actual
1360 // arguments associated with INTENT(OUT) dummy arguments
1361 // we may avoid doing the copy and only allocate the temporary.
1362 // The codegen would do a "mold" allocation instead of "sourced"
1363 // allocation for the temp in this case. We can communicate
1364 // this to the codegen via some CopyInOp flag.
1365 // This is a performance concern.
1366 entity = genCopyIn(entity, arg.mayBeModifiedByCall());
1367 }
1368 } else {
1369 const Fortran::lower::SomeExpr *expr = arg.entity->UnwrapExpr();
1370 assert(expr && "expression actual argument cannot be an assumed type");
1371 // The actual is an expression value, place it into a temporary
1372 // and register the temporary destruction after the call.
1373 mlir::Type storageType = callContext.converter.genType(*expr);
1374 mlir::NamedAttribute byRefAttr = fir::getAdaptToByRefAttr(builder);
1375 hlfir::AssociateOp associate = hlfir::genAssociateExpr(
1376 loc, builder, entity, storageType, "", byRefAttr);
1377 entity = hlfir::Entity{associate.getBase()};
1378 preparedDummy.pushExprAssociateCleanUp(associate);
1379 // Rebox the actual argument to the dummy argument's type, and make sure
1380 // that we pass a contiguous entity (i.e. make copy-in, if needed).
1381 //
1382 // TODO: this can probably be optimized by associating the expression with
1383 // properly typed temporary, but this needs either a new operation or
1384 // making the hlfir.associate more complex.
1385 if (mustSetDynamicTypeToDummyType) {
1386 entity = genSetDynamicTypeToDummyType(entity);
1387 entity = genCopyIn(entity, /*doCopyOut=*/false);
1388 }
1389 }
1390
1391 // Step 3: now that the dummy argument storage has been prepared, package
1392 // it according to the interface.
1393 mlir::Value addr;
1394 if (mlir::isa<fir::BoxCharType>(dummyTypeWithActualRank)) {
1395 // Cast the argument to match the volatility of the dummy argument.
1396 auto nonVolatileEntity = hlfir::Entity{builder.createVolatileCast(
1397 loc, fir::isa_volatile_type(dummyType), entity)};
1398 addr = hlfir::genVariableBoxChar(loc, builder, nonVolatileEntity);
1399 } else if (mlir::isa<fir::BaseBoxType>(dummyTypeWithActualRank)) {
1400 entity = hlfir::genVariableBox(loc, builder, entity);
1401 // Ensures the box has the right attributes and that it holds an
1402 // addendum if needed.
1403 fir::BaseBoxType actualBoxType =
1404 mlir::cast<fir::BaseBoxType>(entity.getType());
1405 mlir::Type boxEleType = actualBoxType.getEleTy();
1406 // For now, assume it is not OK to pass the allocatable/pointer
1407 // descriptor to a non pointer/allocatable dummy. That is a strict
1408 // interpretation of 18.3.6 point 4 that stipulates the descriptor
1409 // has the dummy attributes in BIND(C) contexts.
1410 const bool actualBoxHasAllocatableOrPointerFlag =
1411 fir::isa_ref_type(boxEleType);
1412 // Fortran 2018 18.5.3, pp3: BIND(C) non pointer allocatable descriptors
1413 // must have zero lower bounds.
1414 bool needsZeroLowerBounds = callContext.isBindcCall() && entity.isArray();
1415 // On the callee side, the current code generated for unlimited
1416 // polymorphic might unconditionally read the addendum. Intrinsic type
1417 // descriptors may not have an addendum, the rebox below will create a
1418 // descriptor with an addendum in such case.
1419 const bool actualBoxHasAddendum = fir::boxHasAddendum(actualBoxType);
1420 const bool needToAddAddendum =
1421 fir::isUnlimitedPolymorphicType(dummyTypeWithActualRank) &&
1422 !actualBoxHasAddendum;
1423 if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag ||
1424 needsZeroLowerBounds) {
1425 if (actualIsAssumedRank) {
1426 auto lbModifier = needsZeroLowerBounds
1427 ? fir::LowerBoundModifierAttribute::SetToZeroes
1428 : fir::LowerBoundModifierAttribute::SetToOnes;
1429 entity = hlfir::Entity{builder.create<fir::ReboxAssumedRankOp>(
1430 loc, dummyTypeWithActualRank, entity, lbModifier)};
1431 } else {
1432 mlir::Value shift{};
1433 if (needsZeroLowerBounds)
1434 shift = getZeroLowerBounds(loc, builder, entity);
1435 entity = hlfir::Entity{builder.create<fir::ReboxOp>(
1436 loc, dummyTypeWithActualRank, entity, /*shape=*/shift,
1437 /*slice=*/mlir::Value{})};
1438 }
1439 }
1440 addr = entity;
1441 } else {
1442 addr = hlfir::genVariableRawAddress(loc, builder, entity);
1443 }
1444
1445 // If the volatility of the input type does not match the dummy type,
1446 // we need to cast the argument.
1447 const bool isToTypeVolatile = fir::isa_volatile_type(dummyTypeWithActualRank);
1448 addr = builder.createVolatileCast(loc, isToTypeVolatile, addr);
1449
1450 // For ranked actual passed to assumed-rank dummy, the cast to assumed-rank
1451 // box is inserted when building the fir.call op. Inserting it here would
1452 // cause the fir.if results to be assumed-rank in case of OPTIONAL dummy,
1453 // causing extra runtime costs due to the unknown runtime size of assumed-rank
1454 // descriptors.
1455 // For TKR dummy characters, the boxchar creation also happens later when
1456 // creating the fir.call .
1457 preparedDummy.dummy =
1458 builder.createConvert(loc, dummyTypeWithActualRank, addr);
1459 return preparedDummy;
1460}
1461
1462/// When dummy is not ALLOCATABLE, POINTER and is not passed in register,
1463/// prepare the actual argument according to the interface, taking care
1464/// of any optional aspect.
1465static PreparedDummyArgument prepareUserCallActualArgument(
1466 mlir::Location loc, fir::FirOpBuilder &builder,
1467 const Fortran::lower::PreparedActualArgument &preparedActual,
1468 mlir::Type dummyType,
1469 const Fortran::lower::CallerInterface::PassedEntity &arg,
1470 CallContext &callContext) {
1471 if (!preparedActual.handleDynamicOptional())
1472 return preparePresentUserCallActualArgument(loc, builder, preparedActual,
1473 dummyType, arg, callContext);
1474
1475 // Conditional dummy argument preparation. The actual may be absent
1476 // at runtime, causing any addressing, copy, and packaging to have
1477 // undefined behavior.
1478 // To simplify the handling of this case, the "normal" dummy preparation
1479 // helper is used, except its generated code is wrapped inside a
1480 // fir.if(present).
1481 mlir::Value isPresent = preparedActual.getIsPresent();
1482 mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
1483
1484 // Code generated in a preparation block that will become the
1485 // "then" block in "if (present) then {} else {}". The reason
1486 // for this unusual if/then/else generation is that the number
1487 // and types of the if results will depend on how the argument
1488 // is prepared, and forecasting that here would be brittle.
1489 auto badIfOp = builder.create<fir::IfOp>(loc, dummyType, isPresent,
1490 /*withElseRegion=*/false);
1491 mlir::Block *preparationBlock = &badIfOp.getThenRegion().front();
1492 builder.setInsertionPointToStart(preparationBlock);
1493 PreparedDummyArgument unconditionalDummy =
1494 preparePresentUserCallActualArgument(loc, builder, preparedActual,
1495 dummyType, arg, callContext);
1496 builder.restoreInsertionPoint(insertPt);
1497
1498 // TODO: when forwarding an optional to an optional of the same kind
1499 // (i.e, unconditionalDummy.dummy was not created in preparationBlock),
1500 // the if/then/else generation could be skipped to improve the generated
1501 // code.
1502
1503 // Now that the result types of the ifOp can be deduced, generate
1504 // the "real" ifOp (operation result types cannot be changed, so
1505 // badIfOp cannot be modified and used here).
1506 llvm::SmallVector<mlir::Type> ifOpResultTypes;
1507 ConditionallyPreparedDummy conditionalDummy(unconditionalDummy);
1508 auto ifOp = builder.create<fir::IfOp>(loc, conditionalDummy.getIfResulTypes(),
1509 isPresent,
1510 /*withElseRegion=*/true);
1511 // Move "preparationBlock" into the "then" of the new
1512 // fir.if operation and create fir.result propagating
1513 // unconditionalDummy.
1514 preparationBlock->moveBefore(&ifOp.getThenRegion().back());
1515 ifOp.getThenRegion().back().erase();
1516 builder.setInsertionPointToEnd(&ifOp.getThenRegion().front());
1517 conditionalDummy.genThenResult(loc, builder);
1518
1519 // Generate "else" branch with returning absent values.
1520 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
1521 conditionalDummy.genElseResult(loc, builder);
1522
1523 // Build dummy from IfOpResults.
1524 builder.setInsertionPointAfter(ifOp);
1525 PreparedDummyArgument result =
1526 conditionalDummy.getPreparedDummy(ifOp, unconditionalDummy);
1527 badIfOp->erase();
1528 return result;
1529}
1530
1531/// Prepare actual argument for a procedure pointer dummy.
1532static PreparedDummyArgument prepareProcedurePointerActualArgument(
1533 mlir::Location loc, fir::FirOpBuilder &builder,
1534 const Fortran::lower::PreparedActualArgument &preparedActual,
1535 mlir::Type dummyType,
1536 const Fortran::lower::CallerInterface::PassedEntity &arg,
1537 CallContext &callContext) {
1538
1539 // NULL() actual to procedure pointer dummy
1540 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
1541 *arg.entity) &&
1542 fir::isBoxProcAddressType(dummyType)) {
1543 auto boxTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
1544 auto tempBoxProc{builder.createTemporary(loc, boxTy)};
1545 hlfir::Entity nullBoxProc(
1546 fir::factory::createNullBoxProc(builder, loc, boxTy));
1547 builder.create<fir::StoreOp>(loc, nullBoxProc, tempBoxProc);
1548 return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
1549 }
1550 hlfir::Entity actual = preparedActual.getActual(loc, builder);
1551 if (actual.isProcedurePointer())
1552 return PreparedDummyArgument{actual, /*cleanups=*/{}};
1553 assert(actual.isProcedure());
1554 // Procedure actual to procedure pointer dummy.
1555 auto tempBoxProc{builder.createTemporary(loc, actual.getType())};
1556 builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
1557 return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
1558}
1559
1560/// Prepare arguments of calls to user procedures with actual arguments that
1561/// have been pre-lowered but not yet prepared according to the interface.
1562void prepareUserCallArguments(
1563 Fortran::lower::PreparedActualArguments &loweredActuals,
1564 Fortran::lower::CallerInterface &caller, mlir::FunctionType callSiteType,
1565 CallContext &callContext, llvm::SmallVector<CallCleanUp> &callCleanUps) {
1566 using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
1567 mlir::Location loc = callContext.loc;
1568 bool mustRemapActualToDummyDescriptors = false;
1569 fir::FirOpBuilder &builder = callContext.getBuilder();
1570 for (auto [preparedActual, arg] :
1571 llvm::zip(loweredActuals, caller.getPassedArguments())) {
1572 mlir::Type argTy = callSiteType.getInput(arg.firArgument);
1573 if (!preparedActual) {
1574 // Optional dummy argument for which there is no actual argument.
1575 caller.placeInput(arg, builder.genAbsentOp(loc, argTy));
1576 continue;
1577 }
1578
1579 switch (arg.passBy) {
1580 case PassBy::Value: {
1581 // True pass-by-value semantics.
1582 assert(!preparedActual->handleDynamicOptional() && "cannot be optional");
1583 hlfir::Entity actual = preparedActual->getActual(loc, builder);
1584 hlfir::Entity value = hlfir::loadTrivialScalar(loc, builder, actual);
1585
1586 mlir::Type eleTy = value.getFortranElementType();
1587 if (fir::isa_builtin_cptr_type(eleTy)) {
1588 // Pass-by-value argument of type(C_PTR/C_FUNPTR).
1589 // Load the __address component and pass it by value.
1590 if (value.isValue()) {
1591 auto associate = hlfir::genAssociateExpr(loc, builder, value, eleTy,
1592 "adapt.cptrbyval");
1593 value = hlfir::Entity{genRecordCPtrValueArg(
1594 builder, loc, associate.getFirBase(), eleTy)};
1595 builder.create<hlfir::EndAssociateOp>(loc, associate);
1596 } else {
1597 value =
1598 hlfir::Entity{genRecordCPtrValueArg(builder, loc, value, eleTy)};
1599 }
1600 } else if (fir::isa_derived(value.getFortranElementType()) ||
1601 value.isCharacter()) {
1602 // BIND(C), VALUE derived type or character. The value must really
1603 // be loaded here.
1604 auto [exv, cleanup] = hlfir::convertToValue(loc, builder, value);
1605 mlir::Value loadedValue = fir::getBase(exv);
1606 // Character actual arguments may have unknown length or a length longer
1607 // than one. Cast the memory ref to the dummy type so that the load is
1608 // valid and only loads what is needed.
1609 if (mlir::Type baseTy = fir::dyn_cast_ptrEleTy(loadedValue.getType()))
1610 if (fir::isa_char(baseTy))
1611 loadedValue = builder.createConvert(
1612 loc, fir::ReferenceType::get(argTy), loadedValue);
1613 if (fir::isa_ref_type(loadedValue.getType()))
1614 loadedValue = builder.create<fir::LoadOp>(loc, loadedValue);
1615 caller.placeInput(arg, loadedValue);
1616 if (cleanup)
1617 (*cleanup)();
1618 break;
1619 }
1620 caller.placeInput(arg, builder.createConvert(loc, argTy, value));
1621 } break;
1622 case PassBy::BaseAddressValueAttribute:
1623 case PassBy::CharBoxValueAttribute:
1624 case PassBy::Box:
1625 case PassBy::BaseAddress:
1626 case PassBy::BoxChar: {
1627 PreparedDummyArgument preparedDummy = prepareUserCallActualArgument(
1628 loc, builder, *preparedActual, argTy, arg, callContext);
1629 callCleanUps.append(preparedDummy.cleanups.rbegin(),
1630 preparedDummy.cleanups.rend());
1631 caller.placeInput(arg, preparedDummy.dummy);
1632 if (arg.passBy == PassBy::Box)
1633 mustRemapActualToDummyDescriptors |=
1634 arg.isSequenceAssociatedDescriptor();
1635 } break;
1636 case PassBy::BoxProcRef: {
1637 PreparedDummyArgument preparedDummy =
1638 prepareProcedurePointerActualArgument(loc, builder, *preparedActual,
1639 argTy, arg, callContext);
1640 callCleanUps.append(preparedDummy.cleanups.rbegin(),
1641 preparedDummy.cleanups.rend());
1642 caller.placeInput(arg, preparedDummy.dummy);
1643 } break;
1644 case PassBy::AddressAndLength:
1645 // PassBy::AddressAndLength is only used for character results. Results
1646 // are not handled here.
1647 fir::emitFatalError(
1648 loc, "unexpected PassBy::AddressAndLength for actual arguments");
1649 break;
1650 case PassBy::CharProcTuple: {
1651 hlfir::Entity actual = preparedActual->getActual(loc, builder);
1652 if (actual.isProcedurePointer())
1653 actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);
1654 if (!fir::isCharacterProcedureTuple(actual.getType()))
1655 actual = fixProcedureDummyMismatch(loc, builder, actual, argTy);
1656 caller.placeInput(arg, actual);
1657 } break;
1658 case PassBy::MutableBox: {
1659 const Fortran::lower::SomeExpr *expr = arg.entity->UnwrapExpr();
1660 // C709 and C710.
1661 assert(expr && "cannot pass TYPE(*) to POINTER or ALLOCATABLE");
1662 hlfir::Entity actual = preparedActual->getActual(loc, builder);
1663 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
1664 *expr)) {
1665 // If expr is NULL(), the mutableBox created must be a deallocated
1666 // pointer with the dummy argument characteristics (see table 16.5
1667 // in Fortran 2018 standard).
1668 // No length parameters are set for the created box because any non
1669 // deferred type parameters of the dummy will be evaluated on the
1670 // callee side, and it is illegal to use NULL without a MOLD if any
1671 // dummy length parameters are assumed.
1672 mlir::Type boxTy = fir::dyn_cast_ptrEleTy(argTy);
1673 assert(boxTy && mlir::isa<fir::BaseBoxType>(boxTy) &&
1674 "must be a fir.box type");
1675 mlir::Value boxStorage =
1676 fir::factory::genNullBoxStorage(builder, loc, boxTy);
1677 caller.placeInput(arg, boxStorage);
1678 continue;
1679 }
1680 if (fir::isPointerType(argTy) &&
1681 !Fortran::evaluate::IsObjectPointer(*expr)) {
1682 // Passing a non POINTER actual argument to a POINTER dummy argument.
1683 // Create a pointer of the dummy argument type and assign the actual
1684 // argument to it.
1685 auto dataTy = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(argTy));
1686 fir::ExtendedValue actualExv = Fortran::lower::convertToAddress(
1687 loc, callContext.converter, actual, callContext.stmtCtx,
1688 hlfir::getFortranElementType(dataTy));
1689 // If the dummy is an assumed-rank pointer, allocate a pointer
1690 // descriptor with the actual argument rank (if it is not assumed-rank
1691 // itself).
1692 if (dataTy.isAssumedRank()) {
1693 dataTy =
1694 dataTy.getBoxTypeWithNewShape(fir::getBase(actualExv).getType());
1695 }
1696 mlir::Value irBox = builder.createTemporary(loc, dataTy);
1697 fir::MutableBoxValue ptrBox(irBox,
1698 /*nonDeferredParams=*/mlir::ValueRange{},
1699 /*mutableProperties=*/{});
1700 fir::factory::associateMutableBox(builder, loc, ptrBox, actualExv,
1701 /*lbounds=*/std::nullopt);
1702 caller.placeInput(arg, irBox);
1703 continue;
1704 }
1705 // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE.
1706 assert(actual.isMutableBox() && "actual must be a mutable box");
1707 if (fir::isAllocatableType(argTy) && arg.isIntentOut() &&
1708 callContext.isBindcCall()) {
1709 // INTENT(OUT) allocatables are deallocated on the callee side,
1710 // but BIND(C) procedures may be implemented in C, so deallocation is
1711 // also done on the caller side (if the procedure is implemented in
1712 // Fortran, the deallocation attempt in the callee will be a no-op).
1713 auto [exv, cleanup] =
1714 hlfir::translateToExtendedValue(loc, builder, actual);
1715 const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>();
1716 assert(mutableBox && !cleanup && "expect allocatable");
1717 Fortran::lower::genDeallocateIfAllocated(callContext.converter,
1718 *mutableBox, loc);
1719 }
1720 caller.placeInput(arg, actual);
1721 } break;
1722 }
1723 }
1724
1725 // Handle cases where caller must allocate the result or a fir.box for it.
1726 if (mustRemapActualToDummyDescriptors)
1727 remapActualToDummyDescriptors(loc, callContext.converter,
1728 callContext.symMap, loweredActuals, caller,
1729 callContext.isBindcCall());
1730}
1731
1732/// Lower calls to user procedures with actual arguments that have been
1733/// pre-lowered but not yet prepared according to the interface.
1734/// This can be called for elemental procedures, but only with scalar
1735/// arguments: if there are array arguments, it must be provided with
1736/// the array argument elements value and will return the corresponding
1737/// scalar result value.
1738static std::optional<hlfir::EntityWithAttributes>
1739genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
1740 Fortran::lower::CallerInterface &caller,
1741 mlir::FunctionType callSiteType, CallContext &callContext) {
1742 mlir::Location loc = callContext.loc;
1743 llvm::SmallVector<CallCleanUp> callCleanUps;
1744 fir::FirOpBuilder &builder = callContext.getBuilder();
1745
1746 prepareUserCallArguments(loweredActuals, caller, callSiteType, callContext,
1747 callCleanUps);
1748
1749 // Prepare lowered arguments according to the interface
1750 // and map the lowered values to the dummy
1751 // arguments.
1752 auto [loweredResult, resultIsFinalized] = Fortran::lower::genCallOpAndResult(
1753 loc, callContext.converter, callContext.symMap, callContext.stmtCtx,
1754 caller, callSiteType, callContext.resultType,
1755 callContext.isElementalProcWithArrayArgs());
1756
1757 // Clean-up associations and copy-in.
1758 // The association clean-ups are postponed to the end of the statement
1759 // lowering. The copy-in clean-ups may be delayed as well,
1760 // but they are done immediately after the call currently.
1761 llvm::SmallVector<CallCleanUp> associateCleanups;
1762 for (auto cleanUp : callCleanUps) {
1763 auto postponed =
1764 cleanUp.genCleanUp(loc, builder, /*postponeAssociates=*/true);
1765 if (postponed)
1766 associateCleanups.push_back(Elt: *postponed);
1767 }
1768
1769 fir::FirOpBuilder *bldr = &builder;
1770 callContext.stmtCtx.attachCleanup([=]() {
1771 for (auto cleanUp : associateCleanups)
1772 (void)cleanUp.genCleanUp(loc, *bldr, /*postponeAssociates=*/false);
1773 });
1774 if (auto *entity = std::get_if<hlfir::EntityWithAttributes>(&loweredResult))
1775 return *entity;
1776
1777 auto &result = std::get<fir::ExtendedValue>(loweredResult);
1778
1779 // For procedure pointer function result, just return the call.
1780 if (callContext.resultType &&
1781 mlir::isa<fir::BoxProcType>(*callContext.resultType))
1782 return hlfir::EntityWithAttributes(fir::getBase(result));
1783
1784 if (!fir::getBase(result))
1785 return std::nullopt; // subroutine call.
1786
1787 if (fir::isPointerType(fir::getBase(result).getType()))
1788 return extendedValueToHlfirEntity(loc, builder, result, tempResultName);
1789
1790 if (!resultIsFinalized) {
1791 hlfir::Entity resultEntity =
1792 extendedValueToHlfirEntity(loc, builder, result, tempResultName);
1793 resultEntity = loadTrivialScalar(loc, builder, resultEntity);
1794 if (resultEntity.isVariable()) {
1795 // If the result has no finalization, it can be moved into an expression.
1796 // In such case, the expression should not be freed after its use since
1797 // the result is stack allocated or deallocation (for allocatable results)
1798 // was already inserted in genCallOpAndResult.
1799 auto asExpr = builder.create<hlfir::AsExprOp>(
1800 loc, resultEntity, /*mustFree=*/builder.createBool(loc, false));
1801 return hlfir::EntityWithAttributes{asExpr.getResult()};
1802 }
1803 return hlfir::EntityWithAttributes{resultEntity};
1804 }
1805 // If the result has finalization, it cannot be moved because use of its
1806 // value have been created in the statement context and may be emitted
1807 // after the hlfir.expr destroy, so the result is kept as a variable in
1808 // HLFIR. This may lead to copies when passing the result to an argument
1809 // with VALUE, and this do not convey the fact that the result will not
1810 // change, but is correct, and using hlfir.expr without the move would
1811 // trigger a copy that may be avoided.
1812
1813 // Load allocatable results before emitting the hlfir.declare and drop its
1814 // lower bounds: this is not a variable From the Fortran point of view, so
1815 // the lower bounds are ones when inquired on the caller side.
1816 const auto *allocatable = result.getBoxOf<fir::MutableBoxValue>();
1817 fir::ExtendedValue loadedResult =
1818 allocatable
1819 ? fir::factory::genMutableBoxRead(builder, loc, *allocatable,
1820 /*mayBePolymorphic=*/true,
1821 /*preserveLowerBounds=*/false)
1822 : result;
1823 return extendedValueToHlfirEntity(loc, builder, loadedResult, tempResultName);
1824}
1825
1826/// Create an optional dummy argument value from an entity that may be
1827/// absent. \p actualGetter callback returns hlfir::Entity denoting
1828/// the lowered actual argument. \p actualGetter can only return numerical
1829/// or logical scalar entity.
1830/// If the entity is considered absent according to 15.5.2.12 point 1., the
1831/// returned value is zero (or false), otherwise it is the value of the entity.
1832/// \p eleType specifies the entity's Fortran element type.
1833template <typename T>
1834static ExvAndCleanup genOptionalValue(fir::FirOpBuilder &builder,
1835 mlir::Location loc, mlir::Type eleType,
1836 T actualGetter, mlir::Value isPresent) {
1837 return {builder
1838 .genIfOp(loc, {eleType}, isPresent,
1839 /*withElseRegion=*/true)
1840 .genThen([&]() {
1841 hlfir::Entity entity = actualGetter(loc, builder);
1842 assert(eleType == entity.getFortranElementType() &&
1843 "result type mismatch in genOptionalValue");
1844 assert(entity.isScalar() && fir::isa_trivial(eleType) &&
1845 "must be a numerical or logical scalar");
1846 mlir::Value val =
1847 hlfir::loadTrivialScalar(loc, builder, entity);
1848 builder.create<fir::ResultOp>(loc, val);
1849 })
1850 .genElse([&]() {
1851 mlir::Value zero =
1852 fir::factory::createZeroValue(builder, loc, eleType);
1853 builder.create<fir::ResultOp>(loc, zero);
1854 })
1855 .getResults()[0],
1856 std::nullopt};
1857}
1858
1859/// Create an optional dummy argument address from \p entity that may be
1860/// absent. If \p entity is considered absent according to 15.5.2.12 point 1.,
1861/// the returned value is a null pointer, otherwise it is the address of \p
1862/// entity.
1863static ExvAndCleanup genOptionalAddr(fir::FirOpBuilder &builder,
1864 mlir::Location loc, hlfir::Entity entity,
1865 mlir::Value isPresent) {
1866 auto [exv, cleanup] = hlfir::translateToExtendedValue(loc, builder, entity);
1867 // If it is an exv pointer/allocatable, then it cannot be absent
1868 // because it is passed to a non-pointer/non-allocatable.
1869 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
1870 return {fir::factory::genMutableBoxRead(builder, loc, *box), cleanup};
1871 // If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL
1872 // address and can be passed directly.
1873 return {exv, cleanup};
1874}
1875
1876/// Create an optional dummy argument address from \p entity that may be
1877/// absent. If \p entity is considered absent according to 15.5.2.12 point 1.,
1878/// the returned value is an absent fir.box, otherwise it is a fir.box
1879/// describing \p entity.
1880static ExvAndCleanup genOptionalBox(fir::FirOpBuilder &builder,
1881 mlir::Location loc, hlfir::Entity entity,
1882 mlir::Value isPresent) {
1883 auto [exv, cleanup] = hlfir::translateToExtendedValue(loc, builder, entity);
1884
1885 // Non allocatable/pointer optional box -> simply forward
1886 if (exv.getBoxOf<fir::BoxValue>())
1887 return {exv, cleanup};
1888
1889 fir::ExtendedValue newExv = exv;
1890 // Optional allocatable/pointer -> Cannot be absent, but need to translate
1891 // unallocated/diassociated into absent fir.box.
1892 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
1893 newExv = fir::factory::genMutableBoxRead(builder, loc, *box);
1894
1895 // createBox will not do create any invalid memory dereferences if exv is
1896 // absent. The created fir.box will not be usable, but the SelectOp below
1897 // ensures it won't be.
1898 mlir::Value box = builder.createBox(loc, newExv);
1899 mlir::Type boxType = box.getType();
1900 auto absent = builder.create<fir::AbsentOp>(loc, boxType);
1901 auto boxOrAbsent = builder.create<mlir::arith::SelectOp>(
1902 loc, boxType, isPresent, box, absent);
1903 return {fir::BoxValue(boxOrAbsent), cleanup};
1904}
1905
1906/// Lower calls to intrinsic procedures with custom optional handling where the
1907/// actual arguments have been pre-lowered
1908static std::optional<hlfir::EntityWithAttributes> genCustomIntrinsicRefCore(
1909 Fortran::lower::PreparedActualArguments &loweredActuals,
1910 const Fortran::evaluate::SpecificIntrinsic *intrinsic,
1911 CallContext &callContext) {
1912 auto &builder = callContext.getBuilder();
1913 const auto &loc = callContext.loc;
1914 assert(intrinsic &&
1915 Fortran::lower::intrinsicRequiresCustomOptionalHandling(
1916 callContext.procRef, *intrinsic, callContext.converter));
1917
1918 // helper to get a particular prepared argument
1919 auto getArgument = [&](std::size_t i, bool loadArg) -> fir::ExtendedValue {
1920 if (!loweredActuals[i])
1921 return fir::getAbsentIntrinsicArgument();
1922 hlfir::Entity actual = loweredActuals[i]->getActual(loc, builder);
1923 if (loadArg && fir::conformsWithPassByRef(actual.getType())) {
1924 return hlfir::loadTrivialScalar(loc, builder, actual);
1925 }
1926 return Fortran::lower::translateToExtendedValue(loc, builder, actual,
1927 callContext.stmtCtx);
1928 };
1929 // helper to get the isPresent flag for a particular prepared argument
1930 auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
1931 if (!loweredActuals[i])
1932 return {builder.createBool(loc, false)};
1933 if (loweredActuals[i]->handleDynamicOptional())
1934 return {loweredActuals[i]->getIsPresent()};
1935 return std::nullopt;
1936 };
1937
1938 assert(callContext.resultType &&
1939 "the elemental intrinsics with custom handling are all functions");
1940 // if callContext.resultType is an array then this was originally an elemental
1941 // call. What we are lowering here is inside the kernel of the hlfir.elemental
1942 // so we should return the scalar type. If the return type is already a scalar
1943 // then it should be unchanged here.
1944 mlir::Type resTy = hlfir::getFortranElementType(*callContext.resultType);
1945 fir::ExtendedValue result = Fortran::lower::lowerCustomIntrinsic(
1946 builder, loc, callContext.getProcedureName(), resTy, isPresent,
1947 getArgument, loweredActuals.size(), callContext.stmtCtx);
1948
1949 return {hlfir::EntityWithAttributes{extendedValueToHlfirEntity(
1950 loc, builder, result, ".tmp.custom_intrinsic_result")}};
1951}
1952
1953/// Lower calls to intrinsic procedures with actual arguments that have been
1954/// pre-lowered but have not yet been prepared according to the interface.
1955static std::optional<hlfir::EntityWithAttributes>
1956genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals,
1957 const Fortran::evaluate::SpecificIntrinsic *intrinsic,
1958 const fir::IntrinsicHandlerEntry &intrinsicEntry,
1959 CallContext &callContext) {
1960 auto &converter = callContext.converter;
1961 if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
1962 callContext.procRef, *intrinsic, converter))
1963 return genCustomIntrinsicRefCore(loweredActuals, intrinsic, callContext);
1964 llvm::SmallVector<fir::ExtendedValue> operands;
1965 llvm::SmallVector<hlfir::CleanupFunction> cleanupFns;
1966 auto addToCleanups = [&cleanupFns](std::optional<hlfir::CleanupFunction> fn) {
1967 if (fn)
1968 cleanupFns.emplace_back(std::move(*fn));
1969 };
1970 auto &stmtCtx = callContext.stmtCtx;
1971 fir::FirOpBuilder &builder = callContext.getBuilder();
1972 mlir::Location loc = callContext.loc;
1973 const fir::IntrinsicArgumentLoweringRules *argLowering =
1974 intrinsicEntry.getArgumentLoweringRules();
1975 for (auto arg : llvm::enumerate(loweredActuals)) {
1976 if (!arg.value()) {
1977 operands.emplace_back(fir::getAbsentIntrinsicArgument());
1978 continue;
1979 }
1980 if (!argLowering) {
1981 // No argument lowering instruction, lower by value.
1982 assert(!arg.value()->handleDynamicOptional() &&
1983 "should use genOptionalValue");
1984 hlfir::Entity actual = arg.value()->getActual(loc, builder);
1985 operands.emplace_back(
1986 Fortran::lower::convertToValue(loc, converter, actual, stmtCtx));
1987 continue;
1988 }
1989 // Helper to get the type of the Fortran expression in case it is a
1990 // computed value that must be placed in memory (logicals are computed as
1991 // i1, but must be placed in memory as fir.logical).
1992 auto getActualFortranElementType = [&]() -> mlir::Type {
1993 if (const Fortran::lower::SomeExpr *expr =
1994 callContext.procRef.UnwrapArgExpr(arg.index())) {
1995
1996 mlir::Type type = converter.genType(*expr);
1997 return hlfir::getFortranElementType(type);
1998 }
1999 // TYPE(*): is already in memory anyway. Can return none
2000 // here.
2001 return builder.getNoneType();
2002 };
2003 // Ad-hoc argument lowering handling.
2004 fir::ArgLoweringRule argRules =
2005 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
2006 if (arg.value()->handleDynamicOptional()) {
2007 mlir::Value isPresent = arg.value()->getIsPresent();
2008 switch (argRules.lowerAs) {
2009 case fir::LowerIntrinsicArgAs::Value: {
2010 // In case of elemental call, getActual() may produce
2011 // a designator denoting the array element to be passed
2012 // to the subprogram. If the actual array is dynamically
2013 // optional the designator must be generated under
2014 // isPresent check, because the box bounds reads will be
2015 // generated in the codegen. These reads are illegal,
2016 // if the dynamically optional argument is absent.
2017 auto getActualCb = [&](mlir::Location loc,
2018 fir::FirOpBuilder &builder) -> hlfir::Entity {
2019 return arg.value()->getActual(loc, builder);
2020 };
2021 auto [exv, cleanup] =
2022 genOptionalValue(builder, loc, getActualFortranElementType(),
2023 getActualCb, isPresent);
2024 addToCleanups(std::move(cleanup));
2025 operands.emplace_back(exv);
2026 continue;
2027 }
2028 case fir::LowerIntrinsicArgAs::Addr: {
2029 hlfir::Entity actual = arg.value()->getActual(loc, builder);
2030 auto [exv, cleanup] = genOptionalAddr(builder, loc, actual, isPresent);
2031 addToCleanups(std::move(cleanup));
2032 operands.emplace_back(exv);
2033 continue;
2034 }
2035 case fir::LowerIntrinsicArgAs::Box: {
2036 hlfir::Entity actual = arg.value()->getActual(loc, builder);
2037 auto [exv, cleanup] = genOptionalBox(builder, loc, actual, isPresent);
2038 addToCleanups(std::move(cleanup));
2039 operands.emplace_back(exv);
2040 continue;
2041 }
2042 case fir::LowerIntrinsicArgAs::Inquired: {
2043 hlfir::Entity actual = arg.value()->getActual(loc, builder);
2044 auto [exv, cleanup] =
2045 hlfir::translateToExtendedValue(loc, builder, actual);
2046 addToCleanups(std::move(cleanup));
2047 operands.emplace_back(exv);
2048 continue;
2049 }
2050 }
2051 llvm_unreachable("bad switch");
2052 }
2053
2054 hlfir::Entity actual = arg.value()->getActual(loc, builder);
2055 switch (argRules.lowerAs) {
2056 case fir::LowerIntrinsicArgAs::Value:
2057 operands.emplace_back(
2058 Fortran::lower::convertToValue(loc, converter, actual, stmtCtx));
2059 continue;
2060 case fir::LowerIntrinsicArgAs::Addr:
2061 operands.emplace_back(Fortran::lower::convertToAddress(
2062 loc, converter, actual, stmtCtx, getActualFortranElementType()));
2063 continue;
2064 case fir::LowerIntrinsicArgAs::Box:
2065 operands.emplace_back(Fortran::lower::convertToBox(
2066 loc, converter, actual, stmtCtx, getActualFortranElementType()));
2067 continue;
2068 case fir::LowerIntrinsicArgAs::Inquired:
2069 if (const Fortran::lower::SomeExpr *expr =
2070 callContext.procRef.UnwrapArgExpr(arg.index())) {
2071 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
2072 *expr)) {
2073 // NULL() pointer without a MOLD must be passed as a deallocated
2074 // pointer (see table 16.5 in Fortran 2018 standard).
2075 // !fir.box<!fir.ptr<none>> should always be valid in this context.
2076 mlir::Type noneTy = mlir::NoneType::get(builder.getContext());
2077 mlir::Type nullPtrTy = fir::PointerType::get(noneTy);
2078 mlir::Type boxTy = fir::BoxType::get(nullPtrTy);
2079 mlir::Value boxStorage =
2080 fir::factory::genNullBoxStorage(builder, loc, boxTy);
2081 hlfir::EntityWithAttributes nullBoxEntity =
2082 extendedValueToHlfirEntity(loc, builder, boxStorage,
2083 ".tmp.null_box");
2084 operands.emplace_back(Fortran::lower::translateToExtendedValue(
2085 loc, builder, nullBoxEntity, stmtCtx));
2086 continue;
2087 }
2088 }
2089 // Place hlfir.expr in memory, and unbox fir.boxchar. Other entities
2090 // are translated to fir::ExtendedValue without transformation (notably,
2091 // pointers/allocatable are not dereferenced).
2092 // TODO: once lowering to FIR retires, UBOUND and LBOUND can be simplified
2093 // since the fir.box lowered here are now guaranteed to contain the local
2094 // lower bounds thanks to the hlfir.declare (the extra rebox can be
2095 // removed).
2096 operands.emplace_back(Fortran::lower::translateToExtendedValue(
2097 loc, builder, actual, stmtCtx));
2098 continue;
2099 }
2100 llvm_unreachable("bad switch");
2101 }
2102 // genIntrinsicCall needs the scalar type, even if this is a transformational
2103 // procedure returning an array.
2104 std::optional<mlir::Type> scalarResultType;
2105 if (callContext.resultType)
2106 scalarResultType = hlfir::getFortranElementType(*callContext.resultType);
2107 const std::string intrinsicName = callContext.getProcedureName();
2108 // Let the intrinsic library lower the intrinsic procedure call.
2109 auto [resultExv, mustBeFreed] = genIntrinsicCall(
2110 builder, loc, intrinsicEntry, scalarResultType, operands, &converter);
2111 for (const hlfir::CleanupFunction &fn : cleanupFns)
2112 fn();
2113 if (!fir::getBase(resultExv))
2114 return std::nullopt;
2115 hlfir::EntityWithAttributes resultEntity = extendedValueToHlfirEntity(
2116 loc, builder, resultExv, ".tmp.intrinsic_result");
2117 // Move result into memory into an hlfir.expr since they are immutable from
2118 // that point, and the result storage is some temp. "Null" is special: it
2119 // returns a null pointer variable that should not be transformed into a value
2120 // (what matters is the memory address).
2121 if (resultEntity.isVariable() && intrinsicName != "null") {
2122 assert(!fir::isa_trivial(fir::unwrapRefType(resultEntity.getType())) &&
2123 "expect intrinsic scalar results to not be in memory");
2124 hlfir::AsExprOp asExpr;
2125 // Character/Derived MERGE lowering returns one of its argument address
2126 // (this is the only intrinsic implemented in that way so far). The
2127 // ownership of this address cannot be taken here since it may not be a
2128 // temp.
2129 if (intrinsicName == "merge")
2130 asExpr = builder.create<hlfir::AsExprOp>(loc, resultEntity);
2131 else
2132 asExpr = builder.create<hlfir::AsExprOp>(
2133 loc, resultEntity, builder.createBool(loc, mustBeFreed));
2134 resultEntity = hlfir::EntityWithAttributes{asExpr.getResult()};
2135 }
2136 return resultEntity;
2137}
2138
2139/// Lower calls to intrinsic procedures with actual arguments that have been
2140/// pre-lowered but have not yet been prepared according to the interface.
2141static std::optional<hlfir::EntityWithAttributes> genHLFIRIntrinsicRefCore(
2142 Fortran::lower::PreparedActualArguments &loweredActuals,
2143 const Fortran::evaluate::SpecificIntrinsic *intrinsic,
2144 const fir::IntrinsicHandlerEntry &intrinsicEntry,
2145 CallContext &callContext) {
2146 // Try lowering transformational intrinsic ops to HLFIR ops if enabled
2147 // (transformational always have a result type)
2148 if (useHlfirIntrinsicOps && callContext.resultType) {
2149 fir::FirOpBuilder &builder = callContext.getBuilder();
2150 mlir::Location loc = callContext.loc;
2151 const std::string intrinsicName = callContext.getProcedureName();
2152 const fir::IntrinsicArgumentLoweringRules *argLowering =
2153 intrinsicEntry.getArgumentLoweringRules();
2154 std::optional<hlfir::EntityWithAttributes> res =
2155 Fortran::lower::lowerHlfirIntrinsic(builder, loc, intrinsicName,
2156 loweredActuals, argLowering,
2157 *callContext.resultType);
2158 if (res)
2159 return res;
2160 }
2161
2162 // fallback to calling the intrinsic via fir.call
2163 return genIntrinsicRefCore(loweredActuals, intrinsic, intrinsicEntry,
2164 callContext);
2165}
2166
2167namespace {
2168template <typename ElementalCallBuilderImpl>
2169class ElementalCallBuilder {
2170public:
2171 std::optional<hlfir::EntityWithAttributes>
2172 genElementalCall(Fortran::lower::PreparedActualArguments &loweredActuals,
2173 bool isImpure, CallContext &callContext) {
2174 mlir::Location loc = callContext.loc;
2175 fir::FirOpBuilder &builder = callContext.getBuilder();
2176 unsigned numArgs = loweredActuals.size();
2177 // Step 1: dereference pointers/allocatables and compute elemental shape.
2178 mlir::Value shape;
2179 Fortran::lower::PreparedActualArgument *optionalWithShape;
2180 // 10.1.4 p5. Impure elemental procedures must be called in element order.
2181 bool mustBeOrdered = isImpure;
2182 for (unsigned i = 0; i < numArgs; ++i) {
2183 auto &preparedActual = loweredActuals[i];
2184 if (preparedActual) {
2185 // Elemental procedure dummy arguments cannot be pointer/allocatables
2186 // (C15100), so it is safe to dereference any pointer or allocatable
2187 // actual argument now instead of doing this inside the elemental
2188 // region.
2189 preparedActual->derefPointersAndAllocatables(loc, builder);
2190 // Better to load scalars outside of the loop when possible.
2191 if (!preparedActual->handleDynamicOptional() &&
2192 impl().canLoadActualArgumentBeforeLoop(i))
2193 preparedActual->loadTrivialScalar(loc, builder);
2194 // TODO: merge shape instead of using the first one.
2195 if (!shape && preparedActual->isArray()) {
2196 if (preparedActual->handleDynamicOptional())
2197 optionalWithShape = &*preparedActual;
2198 else
2199 shape = preparedActual->genShape(loc, builder);
2200 }
2201 // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout)
2202 // arguments must be called in element order.
2203 if (impl().argMayBeModifiedByCall(i))
2204 mustBeOrdered = true;
2205 }
2206 }
2207 if (!shape && optionalWithShape) {
2208 // If all array operands appear in optional positions, then none of them
2209 // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the
2210 // first operand.
2211 shape = optionalWithShape->genShape(loc, builder);
2212 // TODO: There is an opportunity to add a runtime check here that
2213 // this array is present as required. Also, the optionality of all actual
2214 // could be checked and reset given the Fortran requirement.
2215 optionalWithShape->resetOptionalAspect();
2216 }
2217 assert(shape &&
2218 "elemental array calls must have at least one array arguments");
2219
2220 // Evaluate the actual argument array expressions before the elemental
2221 // call of an impure subprogram or a subprogram with intent(out) or
2222 // intent(inout) arguments. Note that the scalar arguments are handled
2223 // above.
2224 if (mustBeOrdered) {
2225 for (auto &preparedActual : loweredActuals) {
2226 if (preparedActual) {
2227 if (hlfir::AssociateOp associate =
2228 preparedActual->associateIfArrayExpr(loc, builder)) {
2229 fir::FirOpBuilder *bldr = &builder;
2230 callContext.stmtCtx.attachCleanup(
2231 [=]() { bldr->create<hlfir::EndAssociateOp>(loc, associate); });
2232 }
2233 }
2234 }
2235 }
2236
2237 // Push a new local scope so that any temps made inside the elemental
2238 // iterations are cleaned up inside the iterations.
2239 if (!callContext.resultType) {
2240 // Subroutine case. Generate call inside loop nest.
2241 hlfir::LoopNest loopNest =
2242 hlfir::genLoopNest(loc, builder, shape, !mustBeOrdered);
2243 mlir::ValueRange oneBasedIndices = loopNest.oneBasedIndices;
2244 auto insPt = builder.saveInsertionPoint();
2245 builder.setInsertionPointToStart(loopNest.body);
2246 callContext.stmtCtx.pushScope();
2247 for (auto &preparedActual : loweredActuals)
2248 if (preparedActual)
2249 preparedActual->setElementalIndices(oneBasedIndices);
2250 impl().genElementalKernel(loweredActuals, callContext);
2251 callContext.stmtCtx.finalizeAndPop();
2252 builder.restoreInsertionPoint(insPt);
2253 return std::nullopt;
2254 }
2255 // Function case: generate call inside hlfir.elemental
2256 mlir::Type elementType =
2257 hlfir::getFortranElementType(*callContext.resultType);
2258 // Get result length parameters.
2259 llvm::SmallVector<mlir::Value> typeParams;
2260 if (mlir::isa<fir::CharacterType>(elementType) ||
2261 fir::isRecordWithTypeParameters(elementType)) {
2262 auto charType = mlir::dyn_cast<fir::CharacterType>(elementType);
2263 if (charType && charType.hasConstantLen())
2264 typeParams.push_back(builder.createIntegerConstant(
2265 loc, builder.getIndexType(), charType.getLen()));
2266 else if (charType)
2267 typeParams.push_back(impl().computeDynamicCharacterResultLength(
2268 loweredActuals, callContext));
2269 else
2270 TODO(
2271 loc,
2272 "compute elemental PDT function result length parameters in HLFIR");
2273 }
2274 auto genKernel = [&](mlir::Location l, fir::FirOpBuilder &b,
2275 mlir::ValueRange oneBasedIndices) -> hlfir::Entity {
2276 callContext.stmtCtx.pushScope();
2277 for (auto &preparedActual : loweredActuals)
2278 if (preparedActual)
2279 preparedActual->setElementalIndices(oneBasedIndices);
2280 auto res = *impl().genElementalKernel(loweredActuals, callContext);
2281 callContext.stmtCtx.finalizeAndPop();
2282 // Note that an hlfir.destroy is not emitted for the result since it
2283 // is still used by the hlfir.yield_element that also marks its last
2284 // use.
2285 return res;
2286 };
2287 mlir::Value polymorphicMold;
2288 if (fir::isPolymorphicType(*callContext.resultType))
2289 polymorphicMold =
2290 impl().getPolymorphicResultMold(loweredActuals, callContext);
2291 mlir::Value elemental =
2292 hlfir::genElementalOp(loc, builder, elementType, shape, typeParams,
2293 genKernel, !mustBeOrdered, polymorphicMold);
2294 // If the function result requires finalization, then it has to be done
2295 // for the array result of the elemental call. We have to communicate
2296 // this via the DestroyOp's attribute.
2297 bool mustFinalizeExpr = impl().resultMayRequireFinalization(callContext);
2298 fir::FirOpBuilder *bldr = &builder;
2299 callContext.stmtCtx.attachCleanup([=]() {
2300 bldr->create<hlfir::DestroyOp>(loc, elemental, mustFinalizeExpr);
2301 });
2302 return hlfir::EntityWithAttributes{elemental};
2303 }
2304
2305private:
2306 ElementalCallBuilderImpl &impl() {
2307 return *static_cast<ElementalCallBuilderImpl *>(this);
2308 }
2309};
2310
2311class ElementalUserCallBuilder
2312 : public ElementalCallBuilder<ElementalUserCallBuilder> {
2313public:
2314 ElementalUserCallBuilder(Fortran::lower::CallerInterface &caller,
2315 mlir::FunctionType callSiteType)
2316 : caller{caller}, callSiteType{callSiteType} {}
2317 std::optional<hlfir::Entity>
2318 genElementalKernel(Fortran::lower::PreparedActualArguments &loweredActuals,
2319 CallContext &callContext) {
2320 return genUserCall(loweredActuals, caller, callSiteType, callContext);
2321 }
2322
2323 bool argMayBeModifiedByCall(unsigned argIdx) const {
2324 assert(argIdx < caller.getPassedArguments().size() && "bad argument index");
2325 return caller.getPassedArguments()[argIdx].mayBeModifiedByCall();
2326 }
2327
2328 bool canLoadActualArgumentBeforeLoop(unsigned argIdx) const {
2329 using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
2330 const auto &passedArgs{caller.getPassedArguments()};
2331 assert(argIdx < passedArgs.size() && "bad argument index");
2332 // If the actual argument does not need to be passed via an address,
2333 // or will be passed in the address of a temporary copy, it can be loaded
2334 // before the elemental loop nest.
2335 const auto &arg{passedArgs[argIdx]};
2336 return arg.passBy == PassBy::Value ||
2337 arg.passBy == PassBy::BaseAddressValueAttribute;
2338 }
2339
2340 mlir::Value computeDynamicCharacterResultLength(
2341 Fortran::lower::PreparedActualArguments &loweredActuals,
2342 CallContext &callContext) {
2343 fir::FirOpBuilder &builder = callContext.getBuilder();
2344 mlir::Location loc = callContext.loc;
2345 auto &converter = callContext.converter;
2346 mlir::Type idxTy = builder.getIndexType();
2347 llvm::SmallVector<CallCleanUp> callCleanUps;
2348
2349 prepareUserCallArguments(loweredActuals, caller, callSiteType, callContext,
2350 callCleanUps);
2351
2352 callContext.symMap.pushScope();
2353
2354 // Map prepared argument to dummy symbol to be able to lower spec expr.
2355 for (const auto &arg : caller.getPassedArguments()) {
2356 const Fortran::semantics::Symbol *sym = caller.getDummySymbol(arg);
2357 assert(sym && "expect symbol for dummy argument");
2358 auto input = caller.getInput(arg);
2359 fir::ExtendedValue exv = Fortran::lower::translateToExtendedValue(
2360 loc, builder, hlfir::Entity{input}, callContext.stmtCtx);
2361 fir::FortranVariableOpInterface variableIface = hlfir::genDeclare(
2362 loc, builder, exv, "dummy.tmp", fir::FortranVariableFlagsAttr{});
2363 callContext.symMap.addVariableDefinition(*sym, variableIface);
2364 }
2365
2366 auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value {
2367 mlir::Value convertExpr = builder.createConvert(
2368 loc, idxTy,
2369 fir::getBase(converter.genExprValue(expr, callContext.stmtCtx)));
2370 return fir::factory::genMaxWithZero(builder, loc, convertExpr);
2371 };
2372
2373 llvm::SmallVector<mlir::Value> lengths;
2374 caller.walkResultLengths(
2375 [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
2376 assert(!isAssumedSizeExtent && "result cannot be assumed-size");
2377 lengths.emplace_back(lowerSpecExpr(e));
2378 });
2379 callContext.symMap.popScope();
2380 assert(lengths.size() == 1 && "expect 1 length parameter for the result");
2381 return lengths[0];
2382 }
2383
2384 mlir::Value getPolymorphicResultMold(
2385 Fortran::lower::PreparedActualArguments &loweredActuals,
2386 CallContext &callContext) {
2387 fir::emitFatalError(callContext.loc,
2388 "elemental function call with polymorphic result");
2389 return {};
2390 }
2391
2392 bool resultMayRequireFinalization(CallContext &callContext) const {
2393 std::optional<Fortran::evaluate::DynamicType> retTy =
2394 caller.getCallDescription().proc().GetType();
2395 if (!retTy)
2396 return false;
2397
2398 if (retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic())
2399 fir::emitFatalError(
2400 callContext.loc,
2401 "elemental function call with [unlimited-]polymorphic result");
2402
2403 if (retTy->category() == Fortran::common::TypeCategory::Derived) {
2404 const Fortran::semantics::DerivedTypeSpec &typeSpec =
2405 retTy->GetDerivedTypeSpec();
2406 return Fortran::semantics::IsFinalizable(typeSpec);
2407 }
2408
2409 return false;
2410 }
2411
2412private:
2413 Fortran::lower::CallerInterface &caller;
2414 mlir::FunctionType callSiteType;
2415};
2416
2417class ElementalIntrinsicCallBuilder
2418 : public ElementalCallBuilder<ElementalIntrinsicCallBuilder> {
2419public:
2420 ElementalIntrinsicCallBuilder(
2421 const Fortran::evaluate::SpecificIntrinsic *intrinsic,
2422 const fir::IntrinsicHandlerEntry &intrinsicEntry, bool isFunction)
2423 : intrinsic{intrinsic}, intrinsicEntry{intrinsicEntry},
2424 isFunction{isFunction} {}
2425 std::optional<hlfir::Entity>
2426 genElementalKernel(Fortran::lower::PreparedActualArguments &loweredActuals,
2427 CallContext &callContext) {
2428 return genHLFIRIntrinsicRefCore(loweredActuals, intrinsic, intrinsicEntry,
2429 callContext);
2430 }
2431 // Elemental intrinsic functions cannot modify their arguments.
2432 bool argMayBeModifiedByCall(int) const { return !isFunction; }
2433 bool canLoadActualArgumentBeforeLoop(int) const {
2434 // Elemental intrinsic functions never need the actual addresses
2435 // of their arguments.
2436 return isFunction;
2437 }
2438
2439 mlir::Value computeDynamicCharacterResultLength(
2440 Fortran::lower::PreparedActualArguments &loweredActuals,
2441 CallContext &callContext) {
2442 if (intrinsic)
2443 if (intrinsic->name == "adjustr" || intrinsic->name == "adjustl" ||
2444 intrinsic->name == "merge")
2445 return loweredActuals[0].value().genCharLength(
2446 callContext.loc, callContext.getBuilder());
2447 // Character MIN/MAX is the min/max of the arguments length that are
2448 // present.
2449 TODO(callContext.loc,
2450 "compute elemental character min/max function result length in HLFIR");
2451 }
2452
2453 mlir::Value getPolymorphicResultMold(
2454 Fortran::lower::PreparedActualArguments &loweredActuals,
2455 CallContext &callContext) {
2456 if (!intrinsic)
2457 return {};
2458
2459 if (intrinsic->name == "merge") {
2460 // MERGE seems to be the only elemental function that can produce
2461 // polymorphic result. The MERGE's result is polymorphic iff
2462 // both TSOURCE and FSOURCE are polymorphic, and they also must have
2463 // the same declared and dynamic types. So any of them can be used
2464 // for the mold.
2465 assert(!loweredActuals.empty());
2466 return loweredActuals.front()->getPolymorphicMold(callContext.loc);
2467 }
2468
2469 return {};
2470 }
2471
2472 bool resultMayRequireFinalization(
2473 [[maybe_unused]] CallContext &callContext) const {
2474 // FIXME: need access to the CallerInterface's return type
2475 // to check if the result may need finalization (e.g. the result
2476 // of MERGE).
2477 return false;
2478 }
2479
2480private:
2481 const Fortran::evaluate::SpecificIntrinsic *intrinsic;
2482 fir::IntrinsicHandlerEntry intrinsicEntry;
2483 const bool isFunction;
2484};
2485} // namespace
2486
2487static std::optional<mlir::Value>
2488genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual,
2489 const Fortran::lower::SomeExpr &expr,
2490 CallContext &callContext,
2491 bool passAsAllocatableOrPointer) {
2492 if (!Fortran::evaluate::MayBePassedAsAbsentOptional(expr))
2493 return std::nullopt;
2494 fir::FirOpBuilder &builder = callContext.getBuilder();
2495 if (!passAsAllocatableOrPointer &&
2496 Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {
2497 // Passing Allocatable/Pointer to non-pointer/non-allocatable OPTIONAL.
2498 // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated, it is
2499 // as if the argument was absent. The main care here is to not do a
2500 // copy-in/copy-out because the temp address, even though pointing to a
2501 // null size storage, would not be a nullptr and therefore the argument
2502 // would not be considered absent on the callee side. Note: if the
2503 // allocatable/pointer is also optional, it cannot be absent as per
2504 // 15.5.2.12 point 7. and 8. We rely on this to un-conditionally read
2505 // the allocatable/pointer descriptor here.
2506 mlir::Value addr = genVariableRawAddress(loc, builder, actual);
2507 return builder.genIsNotNullAddr(loc, addr);
2508 }
2509 // TODO: what if passing allocatable target to optional intent(in) pointer?
2510 // May fall into the category above if the allocatable is not optional.
2511
2512 // Passing an optional to an optional.
2513 return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), actual)
2514 .getResult();
2515}
2516
2517// Lower a reference to an elemental intrinsic procedure with array arguments
2518// and custom optional handling
2519static std::optional<hlfir::EntityWithAttributes>
2520genCustomElementalIntrinsicRef(
2521 const Fortran::evaluate::SpecificIntrinsic *intrinsic,
2522 CallContext &callContext) {
2523 assert(callContext.isElementalProcWithArrayArgs() &&
2524 "Use genCustomIntrinsicRef for scalar calls");
2525 mlir::Location loc = callContext.loc;
2526 auto &converter = callContext.converter;
2527 Fortran::lower::PreparedActualArguments operands;
2528 assert(intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
2529 callContext.procRef, *intrinsic, converter));
2530
2531 // callback for optional arguments
2532 auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
2533 hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(
2534 loc, converter, expr, callContext.symMap, callContext.stmtCtx);
2535 std::optional<mlir::Value> isPresent =
2536 genIsPresentIfArgMaybeAbsent(loc, actual, expr, callContext,
2537 /*passAsAllocatableOrPointer=*/false);
2538 operands.emplace_back(
2539 Fortran::lower::PreparedActualArgument{actual, isPresent});
2540 };
2541
2542 // callback for non-optional arguments
2543 auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
2544 fir::LowerIntrinsicArgAs lowerAs) {
2545 hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(
2546 loc, converter, expr, callContext.symMap, callContext.stmtCtx);
2547 operands.emplace_back(Fortran::lower::PreparedActualArgument{
2548 actual, /*isPresent=*/std::nullopt});
2549 };
2550
2551 Fortran::lower::prepareCustomIntrinsicArgument(
2552 callContext.procRef, *intrinsic, callContext.resultType,
2553 prepareOptionalArg, prepareOtherArg, converter);
2554
2555 std::optional<fir::IntrinsicHandlerEntry> intrinsicEntry =
2556 fir::lookupIntrinsicHandler(callContext.getBuilder(),
2557 callContext.getProcedureName(),
2558 callContext.resultType);
2559 assert(intrinsicEntry.has_value() &&
2560 "intrinsic with custom handling for OPTIONAL arguments must have "
2561 "lowering entries");
2562 // All of the custom intrinsic elementals with custom handling are pure
2563 // functions
2564 return ElementalIntrinsicCallBuilder{intrinsic, *intrinsicEntry,
2565 /*isFunction=*/true}
2566 .genElementalCall(operands, /*isImpure=*/false, callContext);
2567}
2568
2569// Lower a reference to an intrinsic procedure with custom optional handling
2570static std::optional<hlfir::EntityWithAttributes>
2571genCustomIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,
2572 CallContext &callContext) {
2573 assert(!callContext.isElementalProcWithArrayArgs() &&
2574 "Needs to be run through ElementalIntrinsicCallBuilder first");
2575 mlir::Location loc = callContext.loc;
2576 fir::FirOpBuilder &builder = callContext.getBuilder();
2577 auto &converter = callContext.converter;
2578 auto &stmtCtx = callContext.stmtCtx;
2579 assert(intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
2580 callContext.procRef, *intrinsic, converter));
2581 Fortran::lower::PreparedActualArguments loweredActuals;
2582
2583 // callback for optional arguments
2584 auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
2585 hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(
2586 loc, converter, expr, callContext.symMap, callContext.stmtCtx);
2587 mlir::Value isPresent =
2588 genIsPresentIfArgMaybeAbsent(loc, actual, expr, callContext,
2589 /*passAsAllocatableOrPointer*/ false)
2590 .value();
2591 loweredActuals.emplace_back(
2592 Fortran::lower::PreparedActualArgument{actual, {isPresent}});
2593 };
2594
2595 // callback for non-optional arguments
2596 auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
2597 fir::LowerIntrinsicArgAs lowerAs) {
2598 auto getActualFortranElementType = [&]() -> mlir::Type {
2599 return hlfir::getFortranElementType(converter.genType(expr));
2600 };
2601 hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(
2602 loc, converter, expr, callContext.symMap, callContext.stmtCtx);
2603 std::optional<fir::ExtendedValue> exv;
2604 switch (lowerAs) {
2605 case fir::LowerIntrinsicArgAs::Value:
2606 exv = Fortran::lower::convertToValue(loc, converter, actual, stmtCtx);
2607 break;
2608 case fir::LowerIntrinsicArgAs::Addr:
2609 exv = Fortran::lower::convertToAddress(loc, converter, actual, stmtCtx,
2610 getActualFortranElementType());
2611 break;
2612 case fir::LowerIntrinsicArgAs::Box:
2613 exv = Fortran::lower::convertToBox(loc, converter, actual, stmtCtx,
2614 getActualFortranElementType());
2615 break;
2616 case fir::LowerIntrinsicArgAs::Inquired:
2617 exv = Fortran::lower::translateToExtendedValue(loc, builder, actual,
2618 stmtCtx);
2619 break;
2620 }
2621 if (!exv)
2622 llvm_unreachable("bad switch");
2623 actual = extendedValueToHlfirEntity(loc, builder, exv.value(),
2624 "tmp.custom_intrinsic_arg");
2625 loweredActuals.emplace_back(Fortran::lower::PreparedActualArgument{
2626 actual, /*isPresent=*/std::nullopt});
2627 };
2628
2629 Fortran::lower::prepareCustomIntrinsicArgument(
2630 callContext.procRef, *intrinsic, callContext.resultType,
2631 prepareOptionalArg, prepareOtherArg, converter);
2632
2633 return genCustomIntrinsicRefCore(loweredActuals, intrinsic, callContext);
2634}
2635
2636/// Lower an intrinsic procedure reference.
2637/// \p intrinsic is null if this is an intrinsic module procedure that must be
2638/// lowered as if it were an intrinsic module procedure (like C_LOC which is a
2639/// procedure from intrinsic module iso_c_binding). Otherwise, \p intrinsic
2640/// must not be null.
2641
2642static std::optional<hlfir::EntityWithAttributes>
2643genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,
2644 const fir::IntrinsicHandlerEntry &intrinsicEntry,
2645 CallContext &callContext) {
2646 mlir::Location loc = callContext.loc;
2647 Fortran::lower::PreparedActualArguments loweredActuals;
2648 const fir::IntrinsicArgumentLoweringRules *argLowering =
2649 intrinsicEntry.getArgumentLoweringRules();
2650 for (const auto &arg : llvm::enumerate(callContext.procRef.arguments())) {
2651
2652 if (!arg.value()) {
2653 // Absent optional.
2654 loweredActuals.push_back(std::nullopt);
2655 continue;
2656 }
2657 auto *expr =
2658 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
2659 if (!expr) {
2660 // TYPE(*) dummy. They are only allowed as argument of a few intrinsics
2661 // that do not take optional arguments: see Fortran 2018 standard C710.
2662 const Fortran::evaluate::Symbol *assumedTypeSym =
2663 arg.value()->GetAssumedTypeDummy();
2664 if (!assumedTypeSym)
2665 fir::emitFatalError(loc,
2666 "expected assumed-type symbol as actual argument");
2667 std::optional<fir::FortranVariableOpInterface> var =
2668 callContext.symMap.lookupVariableDefinition(*assumedTypeSym);
2669 if (!var)
2670 fir::emitFatalError(loc, "assumed-type symbol was not lowered");
2671 assert(
2672 (!argLowering ||
2673 !fir::lowerIntrinsicArgumentAs(*argLowering, arg.index())
2674 .handleDynamicOptional) &&
2675 "TYPE(*) are not expected to appear as optional intrinsic arguments");
2676 loweredActuals.push_back(Fortran::lower::PreparedActualArgument{
2677 hlfir::Entity{*var}, /*isPresent=*/std::nullopt});
2678 continue;
2679 }
2680 // arguments of bitwise comparison functions may not have nsw flag
2681 // even if -fno-wrapv is enabled
2682 mlir::arith::IntegerOverflowFlags iofBackup{};
2683 auto isBitwiseComparison = [](const std::string intrinsicName) -> bool {
2684 if (intrinsicName == "bge" || intrinsicName == "bgt" ||
2685 intrinsicName == "ble" || intrinsicName == "blt")
2686 return true;
2687 return false;
2688 };
2689 if (isBitwiseComparison(callContext.getProcedureName())) {
2690 iofBackup = callContext.getBuilder().getIntegerOverflowFlags();
2691 callContext.getBuilder().setIntegerOverflowFlags(
2692 mlir::arith::IntegerOverflowFlags::none);
2693 }
2694 auto loweredActual = Fortran::lower::convertExprToHLFIR(
2695 loc, callContext.converter, *expr, callContext.symMap,
2696 callContext.stmtCtx);
2697 if (isBitwiseComparison(callContext.getProcedureName()))
2698 callContext.getBuilder().setIntegerOverflowFlags(iofBackup);
2699
2700 std::optional<mlir::Value> isPresent;
2701 if (argLowering) {
2702 fir::ArgLoweringRule argRules =
2703 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
2704 if (argRules.handleDynamicOptional)
2705 isPresent =
2706 genIsPresentIfArgMaybeAbsent(loc, loweredActual, *expr, callContext,
2707 /*passAsAllocatableOrPointer=*/false);
2708 }
2709 loweredActuals.push_back(
2710 Fortran::lower::PreparedActualArgument{loweredActual, isPresent});
2711 }
2712
2713 if (callContext.isElementalProcWithArrayArgs()) {
2714 // All intrinsic elemental functions are pure.
2715 const bool isFunction = callContext.resultType.has_value();
2716 return ElementalIntrinsicCallBuilder{intrinsic, intrinsicEntry, isFunction}
2717 .genElementalCall(loweredActuals, /*isImpure=*/!isFunction,
2718 callContext);
2719 }
2720 std::optional<hlfir::EntityWithAttributes> result = genHLFIRIntrinsicRefCore(
2721 loweredActuals, intrinsic, intrinsicEntry, callContext);
2722 if (result && mlir::isa<hlfir::ExprType>(result->getType())) {
2723 fir::FirOpBuilder *bldr = &callContext.getBuilder();
2724 callContext.stmtCtx.attachCleanup(
2725 [=]() { bldr->create<hlfir::DestroyOp>(loc, *result); });
2726 }
2727 return result;
2728}
2729
2730static std::optional<hlfir::EntityWithAttributes>
2731genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,
2732 CallContext &callContext) {
2733 mlir::Location loc = callContext.loc;
2734 auto &converter = callContext.converter;
2735 if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
2736 callContext.procRef, *intrinsic, converter)) {
2737 if (callContext.isElementalProcWithArrayArgs())
2738 return genCustomElementalIntrinsicRef(intrinsic, callContext);
2739 return genCustomIntrinsicRef(intrinsic, callContext);
2740 }
2741 std::optional<fir::IntrinsicHandlerEntry> intrinsicEntry =
2742 fir::lookupIntrinsicHandler(callContext.getBuilder(),
2743 callContext.getProcedureName(),
2744 callContext.resultType);
2745 if (!intrinsicEntry)
2746 fir::crashOnMissingIntrinsic(loc, callContext.getProcedureName());
2747 return genIntrinsicRef(intrinsic, *intrinsicEntry, callContext);
2748}
2749
2750/// Main entry point to lower procedure references, regardless of what they are.
2751static std::optional<hlfir::EntityWithAttributes>
2752genProcedureRef(CallContext &callContext) {
2753 mlir::Location loc = callContext.loc;
2754 fir::FirOpBuilder &builder = callContext.getBuilder();
2755 if (auto *intrinsic = callContext.procRef.proc().GetSpecificIntrinsic())
2756 return genIntrinsicRef(intrinsic, callContext);
2757 // Intercept non BIND(C) module procedure reference that have lowering
2758 // handlers defined for there name. Otherwise, lower them as user
2759 // procedure calls and expect the implementation to be part of
2760 // runtime libraries with the proper name mangling.
2761 if (Fortran::lower::isIntrinsicModuleProcRef(callContext.procRef) &&
2762 !callContext.isBindcCall())
2763 if (std::optional<fir::IntrinsicHandlerEntry> intrinsicEntry =
2764 fir::lookupIntrinsicHandler(builder, callContext.getProcedureName(),
2765 callContext.resultType))
2766 return genIntrinsicRef(nullptr, *intrinsicEntry, callContext);
2767
2768 if (callContext.isStatementFunctionCall())
2769 return genStmtFunctionRef(loc, callContext.converter, callContext.symMap,
2770 callContext.stmtCtx, callContext.procRef);
2771
2772 Fortran::lower::CallerInterface caller(callContext.procRef,
2773 callContext.converter);
2774 mlir::FunctionType callSiteType = caller.genFunctionType();
2775 const bool isElemental = callContext.isElementalProcWithArrayArgs();
2776 Fortran::lower::PreparedActualArguments loweredActuals;
2777 // Lower the actual arguments
2778 for (const Fortran::lower::CallInterface<
2779 Fortran::lower::CallerInterface>::PassedEntity &arg :
2780 caller.getPassedArguments())
2781 if (const auto *actual = arg.entity) {
2782 const auto *expr = actual->UnwrapExpr();
2783 if (!expr) {
2784 // TYPE(*) actual argument.
2785 const Fortran::evaluate::Symbol *assumedTypeSym =
2786 actual->GetAssumedTypeDummy();
2787 if (!assumedTypeSym)
2788 fir::emitFatalError(
2789 loc, "expected assumed-type symbol as actual argument");
2790 std::optional<fir::FortranVariableOpInterface> var =
2791 callContext.symMap.lookupVariableDefinition(*assumedTypeSym);
2792 if (!var)
2793 fir::emitFatalError(loc, "assumed-type symbol was not lowered");
2794 hlfir::Entity actual{*var};
2795 std::optional<mlir::Value> isPresent;
2796 if (arg.isOptional()) {
2797 // Passing an optional TYPE(*) to an optional TYPE(*). Note that
2798 // TYPE(*) cannot be ALLOCATABLE/POINTER (C709) so there is no
2799 // need to cover the case of passing an ALLOCATABLE/POINTER to an
2800 // OPTIONAL.
2801 isPresent =
2802 builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), actual)
2803 .getResult();
2804 }
2805 loweredActuals.push_back(Fortran::lower::PreparedActualArgument{
2806 hlfir::Entity{*var}, isPresent});
2807 continue;
2808 }
2809
2810 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
2811 *expr)) {
2812 if ((arg.passBy !=
2813 Fortran::lower::CallerInterface::PassEntityBy::MutableBox) &&
2814 (arg.passBy !=
2815 Fortran::lower::CallerInterface::PassEntityBy::BoxProcRef)) {
2816 assert(
2817 arg.isOptional() &&
2818 "NULL must be passed only to pointer, allocatable, or OPTIONAL");
2819 // Trying to lower NULL() outside of any context would lead to
2820 // trouble. NULL() here is equivalent to not providing the
2821 // actual argument.
2822 loweredActuals.emplace_back(std::nullopt);
2823 continue;
2824 }
2825 }
2826
2827 if (isElemental && !arg.hasValueAttribute() &&
2828 Fortran::evaluate::IsVariable(*expr) &&
2829 Fortran::evaluate::HasVectorSubscript(*expr)) {
2830 // Vector subscripted arguments are copied in calls, except in elemental
2831 // calls without VALUE attribute where Fortran 2018 15.5.2.4 point 21
2832 // does not apply and the address of each element must be passed.
2833 hlfir::ElementalAddrOp elementalAddr =
2834 Fortran::lower::convertVectorSubscriptedExprToElementalAddr(
2835 loc, callContext.converter, *expr, callContext.symMap,
2836 callContext.stmtCtx);
2837 loweredActuals.emplace_back(
2838 Fortran::lower::PreparedActualArgument{elementalAddr});
2839 continue;
2840 }
2841
2842 auto loweredActual = Fortran::lower::convertExprToHLFIR(
2843 loc, callContext.converter, *expr, callContext.symMap,
2844 callContext.stmtCtx);
2845 std::optional<mlir::Value> isPresent;
2846 if (arg.isOptional())
2847 isPresent = genIsPresentIfArgMaybeAbsent(
2848 loc, loweredActual, *expr, callContext,
2849 arg.passBy ==
2850 Fortran::lower::CallerInterface::PassEntityBy::MutableBox);
2851
2852 loweredActuals.emplace_back(
2853 Fortran::lower::PreparedActualArgument{loweredActual, isPresent});
2854 } else {
2855 // Optional dummy argument for which there is no actual argument.
2856 loweredActuals.emplace_back(std::nullopt);
2857 }
2858 if (isElemental) {
2859 bool isImpure = false;
2860 if (const Fortran::semantics::Symbol *procSym =
2861 callContext.procRef.proc().GetSymbol())
2862 isImpure = !Fortran::semantics::IsPureProcedure(*procSym);
2863 return ElementalUserCallBuilder{caller, callSiteType}.genElementalCall(
2864 loweredActuals, isImpure, callContext);
2865 }
2866 return genUserCall(loweredActuals, caller, callSiteType, callContext);
2867}
2868
2869hlfir::Entity Fortran::lower::PreparedActualArgument::getActual(
2870 mlir::Location loc, fir::FirOpBuilder &builder) const {
2871 if (auto *actualEntity = std::get_if<hlfir::Entity>(&actual)) {
2872 if (oneBasedElementalIndices)
2873 return hlfir::getElementAt(loc, builder, *actualEntity,
2874 *oneBasedElementalIndices);
2875 return *actualEntity;
2876 }
2877 assert(oneBasedElementalIndices && "expect elemental context");
2878 hlfir::ElementalAddrOp elementalAddr =
2879 std::get<hlfir::ElementalAddrOp>(actual);
2880 mlir::IRMapping mapper;
2881 auto alwaysFalse = [](hlfir::ElementalOp) -> bool { return false; };
2882 mlir::Value addr = hlfir::inlineElementalOp(
2883 loc, builder, elementalAddr, *oneBasedElementalIndices, mapper,
2884 /*mustRecursivelyInline=*/alwaysFalse);
2885 assert(elementalAddr.getCleanup().empty() && "no clean-up expected");
2886 elementalAddr.erase();
2887 return hlfir::Entity{addr};
2888}
2889
2890bool Fortran::lower::isIntrinsicModuleProcRef(
2891 const Fortran::evaluate::ProcedureRef &procRef) {
2892 const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
2893 if (!symbol)
2894 return false;
2895 const Fortran::semantics::Symbol *module =
2896 symbol->GetUltimate().owner().GetSymbol();
2897 return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC);
2898}
2899
2900static bool isInWhereMaskedExpression(fir::FirOpBuilder &builder) {
2901 // The MASK of the outer WHERE is not masked itself.
2902 mlir::Operation *op = builder.getRegion().getParentOp();
2903 return op && op->getParentOfType<hlfir::WhereOp>();
2904}
2905
2906std::optional<hlfir::EntityWithAttributes> Fortran::lower::convertCallToHLFIR(
2907 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
2908 const evaluate::ProcedureRef &procRef, std::optional<mlir::Type> resultType,
2909 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
2910 auto &builder = converter.getFirOpBuilder();
2911 if (resultType && !procRef.IsElemental() &&
2912 isInWhereMaskedExpression(builder) &&
2913 !builder.getRegion().getParentOfType<hlfir::ExactlyOnceOp>()) {
2914 // Non elemental calls inside a where-assignment-stmt must be executed
2915 // exactly once without mask control. Lower them in a special region so that
2916 // this can be enforced whenscheduling forall/where expression evaluations.
2917 Fortran::lower::StatementContext localStmtCtx;
2918 mlir::Type bogusType = builder.getIndexType();
2919 auto exactlyOnce = builder.create<hlfir::ExactlyOnceOp>(loc, bogusType);
2920 mlir::Block *block = builder.createBlock(&exactlyOnce.getBody());
2921 builder.setInsertionPointToStart(block);
2922 CallContext callContext(procRef, resultType, loc, converter, symMap,
2923 localStmtCtx);
2924 std::optional<hlfir::EntityWithAttributes> res =
2925 genProcedureRef(callContext);
2926 assert(res.has_value() && "must be a function");
2927 auto yield = builder.create<hlfir::YieldOp>(loc, *res);
2928 Fortran::lower::genCleanUpInRegionIfAny(loc, builder, yield.getCleanup(),
2929 localStmtCtx);
2930 builder.setInsertionPointAfter(exactlyOnce);
2931 exactlyOnce->getResult(0).setType(res->getType());
2932 if (hlfir::isFortranValue(exactlyOnce.getResult()))
2933 return hlfir::EntityWithAttributes{exactlyOnce.getResult()};
2934 // Create hlfir.declare for the result to satisfy
2935 // hlfir::EntityWithAttributes requirements.
2936 auto [exv, cleanup] = hlfir::translateToExtendedValue(
2937 loc, builder, hlfir::Entity{exactlyOnce});
2938 assert(!cleanup && "resut is a variable");
2939 return hlfir::genDeclare(loc, builder, exv, ".func.pointer.result",
2940 fir::FortranVariableFlagsAttr{});
2941 }
2942 CallContext callContext(procRef, resultType, loc, converter, symMap, stmtCtx);
2943 return genProcedureRef(callContext);
2944}
2945
2946void Fortran::lower::convertUserDefinedAssignmentToHLFIR(
2947 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
2948 const evaluate::ProcedureRef &procRef, hlfir::Entity lhs, hlfir::Entity rhs,
2949 Fortran::lower::SymMap &symMap) {
2950 Fortran::lower::StatementContext definedAssignmentContext;
2951 CallContext callContext(procRef, /*resultType=*/std::nullopt, loc, converter,
2952 symMap, definedAssignmentContext);
2953 Fortran::lower::CallerInterface caller(procRef, converter);
2954 mlir::FunctionType callSiteType = caller.genFunctionType();
2955 PreparedActualArgument preparedLhs{lhs, /*isPresent=*/std::nullopt};
2956 PreparedActualArgument preparedRhs{rhs, /*isPresent=*/std::nullopt};
2957 PreparedActualArguments loweredActuals{preparedLhs, preparedRhs};
2958 genUserCall(loweredActuals, caller, callSiteType, callContext);
2959 return;
2960}
2961

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