1//===-- CustomIntrinsicCall.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/CustomIntrinsicCall.h"
14#include "flang/Evaluate/expression.h"
15#include "flang/Evaluate/fold.h"
16#include "flang/Evaluate/tools.h"
17#include "flang/Lower/StatementContext.h"
18#include "flang/Optimizer/Builder/IntrinsicCall.h"
19#include "flang/Optimizer/Builder/Todo.h"
20#include "flang/Semantics/tools.h"
21#include <optional>
22
23/// Is this a call to MIN or MAX intrinsic with arguments that may be absent at
24/// runtime? This is a special case because MIN and MAX can have any number of
25/// arguments.
26static bool isMinOrMaxWithDynamicallyOptionalArg(
27 llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
28 if (name != "min" && name != "max")
29 return false;
30 const auto &args = procRef.arguments();
31 std::size_t argSize = args.size();
32 if (argSize <= 2)
33 return false;
34 for (std::size_t i = 2; i < argSize; ++i) {
35 if (auto *expr =
36 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(args[i]))
37 if (Fortran::evaluate::MayBePassedAsAbsentOptional(*expr))
38 return true;
39 }
40 return false;
41}
42
43/// Is this a call to ISHFTC intrinsic with a SIZE argument that may be absent
44/// at runtime? This is a special case because the SIZE value to be applied
45/// when absent is not zero.
46static bool isIshftcWithDynamicallyOptionalArg(
47 llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
48 if (name != "ishftc" || procRef.arguments().size() < 3)
49 return false;
50 auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
51 procRef.arguments()[2]);
52 return expr && Fortran::evaluate::MayBePassedAsAbsentOptional(*expr);
53}
54
55/// Is this a call to ASSOCIATED where the TARGET is an OPTIONAL (but not a
56/// deallocated allocatable or disassociated pointer)?
57/// Subtle: contrary to other intrinsic optional arguments, disassociated
58/// POINTER and unallocated ALLOCATABLE actual argument are not considered
59/// absent here. This is because ASSOCIATED has special requirements for TARGET
60/// actual arguments that are POINTERs. There is no precise requirements for
61/// ALLOCATABLEs, but all existing Fortran compilers treat them similarly to
62/// POINTERs. That is: unallocated TARGETs cause ASSOCIATED to rerun false. The
63/// runtime deals with the disassociated/unallocated case. Simply ensures that
64/// TARGET that are OPTIONAL get conditionally emboxed here to convey the
65/// optional aspect to the runtime.
66static bool isAssociatedWithDynamicallyOptionalArg(
67 llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
68 if (name != "associated" || procRef.arguments().size() < 2)
69 return false;
70 auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
71 procRef.arguments()[1]);
72 const Fortran::semantics::Symbol *sym{
73 expr ? Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)
74 : nullptr};
75 return (sym && Fortran::semantics::IsOptional(*sym));
76}
77
78bool Fortran::lower::intrinsicRequiresCustomOptionalHandling(
79 const Fortran::evaluate::ProcedureRef &procRef,
80 const Fortran::evaluate::SpecificIntrinsic &intrinsic,
81 AbstractConverter &converter) {
82 llvm::StringRef name = intrinsic.name;
83 return isMinOrMaxWithDynamicallyOptionalArg(name, procRef) ||
84 isIshftcWithDynamicallyOptionalArg(name, procRef) ||
85 isAssociatedWithDynamicallyOptionalArg(name, procRef);
86}
87
88/// Generate the FIR+MLIR operations for the generic intrinsic \p name
89/// with arguments \p args and the expected result type \p resultType.
90/// Returned fir::ExtendedValue is the returned Fortran intrinsic value.
91fir::ExtendedValue
92Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
93 llvm::StringRef name,
94 std::optional<mlir::Type> resultType,
95 llvm::ArrayRef<fir::ExtendedValue> args,
96 Fortran::lower::StatementContext &stmtCtx,
97 Fortran::lower::AbstractConverter *converter) {
98 auto [result, mustBeFreed] =
99 fir::genIntrinsicCall(builder, loc, name, resultType, args, converter);
100 if (mustBeFreed) {
101 mlir::Value addr = fir::getBase(result);
102 if (auto *box = result.getBoxOf<fir::BoxValue>())
103 addr =
104 builder.create<fir::BoxAddrOp>(loc, box->getMemTy(), box->getAddr());
105 fir::FirOpBuilder *bldr = &builder;
106 stmtCtx.attachCleanup([=]() { bldr->create<fir::FreeMemOp>(loc, addr); });
107 }
108 return result;
109}
110
111static void prepareMinOrMaxArguments(
112 const Fortran::evaluate::ProcedureRef &procRef,
113 const Fortran::evaluate::SpecificIntrinsic &intrinsic,
114 std::optional<mlir::Type> retTy,
115 const Fortran::lower::OperandPrepare &prepareOptionalArgument,
116 const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
117 Fortran::lower::AbstractConverter &converter) {
118 assert(retTy && "MIN and MAX must have a return type");
119 mlir::Type resultType = *retTy;
120 mlir::Location loc = converter.getCurrentLocation();
121 if (fir::isa_char(resultType))
122 TODO(loc, "CHARACTER MIN and MAX with dynamically optional arguments");
123 for (auto arg : llvm::enumerate(procRef.arguments())) {
124 const auto *expr =
125 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
126 if (!expr)
127 continue;
128 if (arg.index() <= 1 ||
129 !Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
130 // Non optional arguments.
131 prepareOtherArgument(*expr, fir::LowerIntrinsicArgAs::Value);
132 } else {
133 // Dynamically optional arguments.
134 // Subtle: even for scalar the if-then-else will be generated in the loop
135 // nest because the then part will require the current extremum value that
136 // may depend on previous array element argument and cannot be outlined.
137 prepareOptionalArgument(*expr);
138 }
139 }
140}
141
142static fir::ExtendedValue
143lowerMinOrMax(fir::FirOpBuilder &builder, mlir::Location loc,
144 llvm::StringRef name, std::optional<mlir::Type> retTy,
145 const Fortran::lower::OperandPresent &isPresentCheck,
146 const Fortran::lower::OperandGetter &getOperand,
147 std::size_t numOperands,
148 Fortran::lower::StatementContext &stmtCtx) {
149 assert(numOperands >= 2 && !isPresentCheck(0) && !isPresentCheck(1) &&
150 "min/max must have at least two non-optional args");
151 assert(retTy && "MIN and MAX must have a return type");
152 mlir::Type resultType = *retTy;
153 llvm::SmallVector<fir::ExtendedValue> args;
154 const bool loadOperand = true;
155 args.push_back(getOperand(0, loadOperand));
156 args.push_back(getOperand(1, loadOperand));
157 mlir::Value extremum = fir::getBase(
158 genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx));
159
160 for (std::size_t opIndex = 2; opIndex < numOperands; ++opIndex) {
161 if (std::optional<mlir::Value> isPresentRuntimeCheck =
162 isPresentCheck(opIndex)) {
163 // Argument is dynamically optional.
164 extremum =
165 builder
166 .genIfOp(loc, {resultType}, *isPresentRuntimeCheck,
167 /*withElseRegion=*/true)
168 .genThen([&]() {
169 llvm::SmallVector<fir::ExtendedValue> args;
170 args.emplace_back(extremum);
171 args.emplace_back(getOperand(opIndex, loadOperand));
172 fir::ExtendedValue newExtremum = genIntrinsicCall(
173 builder, loc, name, resultType, args, stmtCtx);
174 builder.create<fir::ResultOp>(loc, fir::getBase(newExtremum));
175 })
176 .genElse([&]() { builder.create<fir::ResultOp>(loc, extremum); })
177 .getResults()[0];
178 } else {
179 // Argument is know to be present at compile time.
180 llvm::SmallVector<fir::ExtendedValue> args;
181 args.emplace_back(extremum);
182 args.emplace_back(getOperand(opIndex, loadOperand));
183 extremum = fir::getBase(
184 genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx));
185 }
186 }
187 return extremum;
188}
189
190static void prepareIshftcArguments(
191 const Fortran::evaluate::ProcedureRef &procRef,
192 const Fortran::evaluate::SpecificIntrinsic &intrinsic,
193 std::optional<mlir::Type> retTy,
194 const Fortran::lower::OperandPrepare &prepareOptionalArgument,
195 const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
196 Fortran::lower::AbstractConverter &converter) {
197 for (auto arg : llvm::enumerate(procRef.arguments())) {
198 const auto *expr =
199 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
200 assert(expr && "expected all ISHFTC argument to be textually present here");
201 if (arg.index() == 2) {
202 assert(Fortran::evaluate::MayBePassedAsAbsentOptional(*expr) &&
203 "expected ISHFTC SIZE arg to be dynamically optional");
204 prepareOptionalArgument(*expr);
205 } else {
206 // Non optional arguments.
207 prepareOtherArgument(*expr, fir::LowerIntrinsicArgAs::Value);
208 }
209 }
210}
211
212static fir::ExtendedValue
213lowerIshftc(fir::FirOpBuilder &builder, mlir::Location loc,
214 llvm::StringRef name, std::optional<mlir::Type> retTy,
215 const Fortran::lower::OperandPresent &isPresentCheck,
216 const Fortran::lower::OperandGetter &getOperand,
217 std::size_t numOperands,
218 Fortran::lower::StatementContext &stmtCtx) {
219 assert(numOperands == 3 && !isPresentCheck(0) && !isPresentCheck(1) &&
220 isPresentCheck(2) &&
221 "only ISHFTC SIZE arg is expected to be dynamically optional here");
222 assert(retTy && "ISFHTC must have a return type");
223 mlir::Type resultType = *retTy;
224 llvm::SmallVector<fir::ExtendedValue> args;
225 const bool loadOperand = true;
226 args.push_back(getOperand(0, loadOperand));
227 args.push_back(getOperand(1, loadOperand));
228 auto iPC = isPresentCheck(2);
229 assert(iPC.has_value());
230 args.push_back(builder
231 .genIfOp(loc, {resultType}, *iPC,
232 /*withElseRegion=*/true)
233 .genThen([&]() {
234 fir::ExtendedValue sizeExv = getOperand(2, loadOperand);
235 mlir::Value size = builder.createConvert(
236 loc, resultType, fir::getBase(sizeExv));
237 builder.create<fir::ResultOp>(loc, size);
238 })
239 .genElse([&]() {
240 mlir::Value bitSize = builder.createIntegerConstant(
241 loc, resultType,
242 resultType.cast<mlir::IntegerType>().getWidth());
243 builder.create<fir::ResultOp>(loc, bitSize);
244 })
245 .getResults()[0]);
246 return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
247}
248
249static void prepareAssociatedArguments(
250 const Fortran::evaluate::ProcedureRef &procRef,
251 const Fortran::evaluate::SpecificIntrinsic &intrinsic,
252 std::optional<mlir::Type> retTy,
253 const Fortran::lower::OperandPrepare &prepareOptionalArgument,
254 const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
255 Fortran::lower::AbstractConverter &converter) {
256 const auto *pointer = procRef.UnwrapArgExpr(0);
257 const auto *optionalTarget = procRef.UnwrapArgExpr(1);
258 assert(pointer && optionalTarget &&
259 "expected call to associated with a target");
260 prepareOtherArgument(*pointer, fir::LowerIntrinsicArgAs::Inquired);
261 prepareOptionalArgument(*optionalTarget);
262}
263
264static fir::ExtendedValue
265lowerAssociated(fir::FirOpBuilder &builder, mlir::Location loc,
266 llvm::StringRef name, std::optional<mlir::Type> resultType,
267 const Fortran::lower::OperandPresent &isPresentCheck,
268 const Fortran::lower::OperandGetter &getOperand,
269 std::size_t numOperands,
270 Fortran::lower::StatementContext &stmtCtx) {
271 assert(numOperands == 2 && "expect two arguments when TARGET is OPTIONAL");
272 llvm::SmallVector<fir::ExtendedValue> args;
273 args.push_back(getOperand(0, /*loadOperand=*/false));
274 // Ensure a null descriptor is passed to the code lowering Associated if
275 // TARGET is absent.
276 fir::ExtendedValue targetExv = getOperand(1, /*loadOperand=*/false);
277 mlir::Value targetBase = fir::getBase(targetExv);
278 // subtle: isPresentCheck would test for an unallocated/disassociated target,
279 // while the optionality of the target pointer/allocatable is what must be
280 // checked here.
281 mlir::Value isPresent =
282 builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), targetBase);
283 mlir::Type targetType = fir::unwrapRefType(targetBase.getType());
284 mlir::Type targetValueType = fir::unwrapPassByRefType(targetType);
285 mlir::Type boxType = targetType.isa<fir::BaseBoxType>()
286 ? targetType
287 : fir::BoxType::get(targetValueType);
288 fir::BoxValue targetBox =
289 builder
290 .genIfOp(loc, {boxType}, isPresent,
291 /*withElseRegion=*/true)
292 .genThen([&]() {
293 mlir::Value box = builder.createBox(loc, targetExv);
294 mlir::Value cast = builder.createConvert(loc, boxType, box);
295 builder.create<fir::ResultOp>(loc, cast);
296 })
297 .genElse([&]() {
298 mlir::Value absentBox = builder.create<fir::AbsentOp>(loc, boxType);
299 builder.create<fir::ResultOp>(loc, absentBox);
300 })
301 .getResults()[0];
302 args.emplace_back(std::move(targetBox));
303 return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
304}
305
306void Fortran::lower::prepareCustomIntrinsicArgument(
307 const Fortran::evaluate::ProcedureRef &procRef,
308 const Fortran::evaluate::SpecificIntrinsic &intrinsic,
309 std::optional<mlir::Type> retTy,
310 const OperandPrepare &prepareOptionalArgument,
311 const OperandPrepareAs &prepareOtherArgument,
312 AbstractConverter &converter) {
313 llvm::StringRef name = intrinsic.name;
314 if (name == "min" || name == "max")
315 return prepareMinOrMaxArguments(procRef, intrinsic, retTy,
316 prepareOptionalArgument,
317 prepareOtherArgument, converter);
318 if (name == "associated")
319 return prepareAssociatedArguments(procRef, intrinsic, retTy,
320 prepareOptionalArgument,
321 prepareOtherArgument, converter);
322 assert(name == "ishftc" && "unexpected custom intrinsic argument call");
323 return prepareIshftcArguments(procRef, intrinsic, retTy,
324 prepareOptionalArgument, prepareOtherArgument,
325 converter);
326}
327
328fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic(
329 fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
330 std::optional<mlir::Type> retTy, const OperandPresent &isPresentCheck,
331 const OperandGetter &getOperand, std::size_t numOperands,
332 Fortran::lower::StatementContext &stmtCtx) {
333 if (name == "min" || name == "max")
334 return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand,
335 numOperands, stmtCtx);
336 if (name == "associated")
337 return lowerAssociated(builder, loc, name, retTy, isPresentCheck,
338 getOperand, numOperands, stmtCtx);
339 assert(name == "ishftc" && "unexpected custom intrinsic call");
340 return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand,
341 numOperands, stmtCtx);
342}
343

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