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