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(
231 builder
232 .genIfOp(loc, {resultType}, *iPC,
233 /*withElseRegion=*/true)
234 .genThen([&]() {
235 fir::ExtendedValue sizeExv = getOperand(2, loadOperand);
236 mlir::Value size =
237 builder.createConvert(loc, resultType, fir::getBase(sizeExv));
238 builder.create<fir::ResultOp>(loc, size);
239 })
240 .genElse([&]() {
241 mlir::Value bitSize = builder.createIntegerConstant(
242 loc, resultType,
243 mlir::cast<mlir::IntegerType>(resultType).getWidth());
244 builder.create<fir::ResultOp>(loc, bitSize);
245 })
246 .getResults()[0]);
247 return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
248}
249
250static void prepareAssociatedArguments(
251 const Fortran::evaluate::ProcedureRef &procRef,
252 const Fortran::evaluate::SpecificIntrinsic &intrinsic,
253 std::optional<mlir::Type> retTy,
254 const Fortran::lower::OperandPrepare &prepareOptionalArgument,
255 const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
256 Fortran::lower::AbstractConverter &converter) {
257 const auto *pointer = procRef.UnwrapArgExpr(0);
258 const auto *optionalTarget = procRef.UnwrapArgExpr(1);
259 assert(pointer && optionalTarget &&
260 "expected call to associated with a target");
261 prepareOtherArgument(*pointer, fir::LowerIntrinsicArgAs::Inquired);
262 prepareOptionalArgument(*optionalTarget);
263}
264
265static fir::ExtendedValue
266lowerAssociated(fir::FirOpBuilder &builder, mlir::Location loc,
267 llvm::StringRef name, std::optional<mlir::Type> resultType,
268 const Fortran::lower::OperandPresent &isPresentCheck,
269 const Fortran::lower::OperandGetter &getOperand,
270 std::size_t numOperands,
271 Fortran::lower::StatementContext &stmtCtx) {
272 assert(numOperands == 2 && "expect two arguments when TARGET is OPTIONAL");
273 llvm::SmallVector<fir::ExtendedValue> args;
274 args.push_back(getOperand(0, /*loadOperand=*/false));
275 // Ensure a null descriptor is passed to the code lowering Associated if
276 // TARGET is absent.
277 fir::ExtendedValue targetExv = getOperand(1, /*loadOperand=*/false);
278 mlir::Value targetBase = fir::getBase(targetExv);
279 // subtle: isPresentCheck would test for an unallocated/disassociated target,
280 // while the optionality of the target pointer/allocatable is what must be
281 // checked here.
282 mlir::Value isPresent =
283 builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), targetBase);
284 mlir::Type targetType = fir::unwrapRefType(targetBase.getType());
285 mlir::Type targetValueType = fir::unwrapPassByRefType(targetType);
286 mlir::Type boxType = mlir::isa<fir::BaseBoxType>(targetType)
287 ? targetType
288 : fir::BoxType::get(targetValueType);
289 fir::BoxValue targetBox =
290 builder
291 .genIfOp(loc, {boxType}, isPresent,
292 /*withElseRegion=*/true)
293 .genThen([&]() {
294 mlir::Value box = builder.createBox(loc, targetExv);
295 mlir::Value cast = builder.createConvert(loc, boxType, box);
296 builder.create<fir::ResultOp>(loc, cast);
297 })
298 .genElse([&]() {
299 mlir::Value absentBox = builder.create<fir::AbsentOp>(loc, boxType);
300 builder.create<fir::ResultOp>(loc, absentBox);
301 })
302 .getResults()[0];
303 args.emplace_back(std::move(targetBox));
304 return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
305}
306
307void Fortran::lower::prepareCustomIntrinsicArgument(
308 const Fortran::evaluate::ProcedureRef &procRef,
309 const Fortran::evaluate::SpecificIntrinsic &intrinsic,
310 std::optional<mlir::Type> retTy,
311 const OperandPrepare &prepareOptionalArgument,
312 const OperandPrepareAs &prepareOtherArgument,
313 AbstractConverter &converter) {
314 llvm::StringRef name = intrinsic.name;
315 if (name == "min" || name == "max")
316 return prepareMinOrMaxArguments(procRef, intrinsic, retTy,
317 prepareOptionalArgument,
318 prepareOtherArgument, converter);
319 if (name == "associated")
320 return prepareAssociatedArguments(procRef, intrinsic, retTy,
321 prepareOptionalArgument,
322 prepareOtherArgument, converter);
323 assert(name == "ishftc" && "unexpected custom intrinsic argument call");
324 return prepareIshftcArguments(procRef, intrinsic, retTy,
325 prepareOptionalArgument, prepareOtherArgument,
326 converter);
327}
328
329fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic(
330 fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
331 std::optional<mlir::Type> retTy, const OperandPresent &isPresentCheck,
332 const OperandGetter &getOperand, std::size_t numOperands,
333 Fortran::lower::StatementContext &stmtCtx) {
334 if (name == "min" || name == "max")
335 return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand,
336 numOperands, stmtCtx);
337 if (name == "associated")
338 return lowerAssociated(builder, loc, name, retTy, isPresentCheck,
339 getOperand, numOperands, stmtCtx);
340 assert(name == "ishftc" && "unexpected custom intrinsic call");
341 return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand,
342 numOperands, stmtCtx);
343}
344

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