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

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