1 //===-- IntrinsicCall.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 // Helper routines for constructing the FIR dialect of MLIR. As FIR is a
10 // dialect of MLIR, it makes extensive use of MLIR interfaces and MLIR's coding
11 // style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this
12 // module.
13 //
14 //===----------------------------------------------------------------------===//
15
16 #include "flang/Lower/IntrinsicCall.h"
17 #include "flang/Common/static-multimap-view.h"
18 #include "flang/Lower/Mangler.h"
19 #include "flang/Lower/Runtime.h"
20 #include "flang/Lower/StatementContext.h"
21 #include "flang/Lower/SymbolMap.h"
22 #include "flang/Optimizer/Builder/Character.h"
23 #include "flang/Optimizer/Builder/Complex.h"
24 #include "flang/Optimizer/Builder/FIRBuilder.h"
25 #include "flang/Optimizer/Builder/MutableBox.h"
26 #include "flang/Optimizer/Builder/Runtime/Character.h"
27 #include "flang/Optimizer/Builder/Runtime/Command.h"
28 #include "flang/Optimizer/Builder/Runtime/Inquiry.h"
29 #include "flang/Optimizer/Builder/Runtime/Numeric.h"
30 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
31 #include "flang/Optimizer/Builder/Runtime/Reduction.h"
32 #include "flang/Optimizer/Builder/Runtime/Stop.h"
33 #include "flang/Optimizer/Builder/Runtime/Transformational.h"
34 #include "flang/Optimizer/Builder/Todo.h"
35 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
36 #include "flang/Optimizer/Support/FatalError.h"
37 #include "mlir/Dialect/LLVMIR/LLVMDialect.h"
38 #include "mlir/Dialect/Math/IR/Math.h"
39 #include "llvm/Support/CommandLine.h"
40 #include "llvm/Support/Debug.h"
41
42 #define DEBUG_TYPE "flang-lower-intrinsic"
43
44 #define PGMATH_DECLARE
45 #include "flang/Evaluate/pgmath.h.inc"
46
47 /// This file implements lowering of Fortran intrinsic procedures and Fortran
48 /// intrinsic module procedures. A call may be inlined with a mix of FIR and
49 /// MLIR operations, or as a call to a runtime function or LLVM intrinsic.
50
51 /// Lowering of intrinsic procedure calls is based on a map that associates
52 /// Fortran intrinsic generic names to FIR generator functions.
53 /// All generator functions are member functions of the IntrinsicLibrary class
54 /// and have the same interface.
55 /// If no generator is given for an intrinsic name, a math runtime library
56 /// is searched for an implementation and, if a runtime function is found,
57 /// a call is generated for it. LLVM intrinsics are handled as a math
58 /// runtime library here.
59
60 /// Enums used to templatize and share lowering of MIN and MAX.
61 enum class Extremum { Min, Max };
62
63 // There are different ways to deal with NaNs in MIN and MAX.
64 // Known existing behaviors are listed below and can be selected for
65 // f18 MIN/MAX implementation.
66 enum class ExtremumBehavior {
67 // Note: the Signaling/quiet aspect of NaNs in the behaviors below are
68 // not described because there is no way to control/observe such aspect in
69 // MLIR/LLVM yet. The IEEE behaviors come with requirements regarding this
70 // aspect that are therefore currently not enforced. In the descriptions
71 // below, NaNs can be signaling or quite. Returned NaNs may be signaling
72 // if one of the input NaN was signaling but it cannot be guaranteed either.
73 // Existing compilers using an IEEE behavior (gfortran) also do not fulfill
74 // signaling/quiet requirements.
75 IeeeMinMaximumNumber,
76 // IEEE minimumNumber/maximumNumber behavior (754-2019, section 9.6):
77 // If one of the argument is and number and the other is NaN, return the
78 // number. If both arguements are NaN, return NaN.
79 // Compilers: gfortran.
80 IeeeMinMaximum,
81 // IEEE minimum/maximum behavior (754-2019, section 9.6):
82 // If one of the argument is NaN, return NaN.
83 MinMaxss,
84 // x86 minss/maxss behavior:
85 // If the second argument is a number and the other is NaN, return the number.
86 // In all other cases where at least one operand is NaN, return NaN.
87 // Compilers: xlf (only for MAX), ifort, pgfortran -nollvm, and nagfor.
88 PgfortranLlvm,
89 // "Opposite of" x86 minss/maxss behavior:
90 // If the first argument is a number and the other is NaN, return the
91 // number.
92 // In all other cases where at least one operand is NaN, return NaN.
93 // Compilers: xlf (only for MIN), and pgfortran (with llvm).
94 IeeeMinMaxNum
95 // IEEE minNum/maxNum behavior (754-2008, section 5.3.1):
96 // TODO: Not implemented.
97 // It is the only behavior where the signaling/quiet aspect of a NaN argument
98 // impacts if the result should be NaN or the argument that is a number.
99 // LLVM/MLIR do not provide ways to observe this aspect, so it is not
100 // possible to implement it without some target dependent runtime.
101 };
102
getAbsentIntrinsicArgument()103 fir::ExtendedValue Fortran::lower::getAbsentIntrinsicArgument() {
104 return fir::UnboxedValue{};
105 }
106
107 /// Test if an ExtendedValue is absent. This is used to test if an intrinsic
108 /// argument are absent at compile time.
isStaticallyAbsent(const fir::ExtendedValue & exv)109 static bool isStaticallyAbsent(const fir::ExtendedValue &exv) {
110 return !fir::getBase(exv);
111 }
isStaticallyAbsent(llvm::ArrayRef<fir::ExtendedValue> args,size_t argIndex)112 static bool isStaticallyAbsent(llvm::ArrayRef<fir::ExtendedValue> args,
113 size_t argIndex) {
114 return args.size() <= argIndex || isStaticallyAbsent(args[argIndex]);
115 }
isStaticallyAbsent(llvm::ArrayRef<mlir::Value> args,size_t argIndex)116 static bool isStaticallyAbsent(llvm::ArrayRef<mlir::Value> args,
117 size_t argIndex) {
118 return args.size() <= argIndex || !args[argIndex];
119 }
120
121 /// Test if an ExtendedValue is present. This is used to test if an intrinsic
122 /// argument is present at compile time. This does not imply that the related
123 /// value may not be an absent dummy optional, disassociated pointer, or a
124 /// deallocated allocatable. See `handleDynamicOptional` to deal with these
125 /// cases when it makes sense.
isStaticallyPresent(const fir::ExtendedValue & exv)126 static bool isStaticallyPresent(const fir::ExtendedValue &exv) {
127 return !isStaticallyAbsent(exv);
128 }
129
130 /// Process calls to Maxval, Minval, Product, Sum intrinsic functions that
131 /// take a DIM argument.
132 template <typename FD>
133 static fir::ExtendedValue
genFuncDim(FD funcDim,mlir::Type resultType,fir::FirOpBuilder & builder,mlir::Location loc,Fortran::lower::StatementContext * stmtCtx,llvm::StringRef errMsg,mlir::Value array,fir::ExtendedValue dimArg,mlir::Value mask,int rank)134 genFuncDim(FD funcDim, mlir::Type resultType, fir::FirOpBuilder &builder,
135 mlir::Location loc, Fortran::lower::StatementContext *stmtCtx,
136 llvm::StringRef errMsg, mlir::Value array, fir::ExtendedValue dimArg,
137 mlir::Value mask, int rank) {
138
139 // Create mutable fir.box to be passed to the runtime for the result.
140 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
141 fir::MutableBoxValue resultMutableBox =
142 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
143 mlir::Value resultIrBox =
144 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
145
146 mlir::Value dim =
147 isStaticallyAbsent(dimArg)
148 ? builder.createIntegerConstant(loc, builder.getIndexType(), 0)
149 : fir::getBase(dimArg);
150 funcDim(builder, loc, resultIrBox, array, dim, mask);
151
152 fir::ExtendedValue res =
153 fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
154 return res.match(
155 [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
156 // Add cleanup code
157 assert(stmtCtx);
158 fir::FirOpBuilder *bldr = &builder;
159 mlir::Value temp = box.getAddr();
160 stmtCtx->attachCleanup(
161 [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
162 return box;
163 },
164 [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue {
165 // Add cleanup code
166 assert(stmtCtx);
167 fir::FirOpBuilder *bldr = &builder;
168 mlir::Value temp = box.getAddr();
169 stmtCtx->attachCleanup(
170 [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
171 return box;
172 },
173 [&](const auto &) -> fir::ExtendedValue {
174 fir::emitFatalError(loc, errMsg);
175 });
176 }
177
178 /// Process calls to Product, Sum intrinsic functions
179 template <typename FN, typename FD>
180 static fir::ExtendedValue
genProdOrSum(FN func,FD funcDim,mlir::Type resultType,fir::FirOpBuilder & builder,mlir::Location loc,Fortran::lower::StatementContext * stmtCtx,llvm::StringRef errMsg,llvm::ArrayRef<fir::ExtendedValue> args)181 genProdOrSum(FN func, FD funcDim, mlir::Type resultType,
182 fir::FirOpBuilder &builder, mlir::Location loc,
183 Fortran::lower::StatementContext *stmtCtx, llvm::StringRef errMsg,
184 llvm::ArrayRef<fir::ExtendedValue> args) {
185
186 assert(args.size() == 3);
187
188 // Handle required array argument
189 fir::BoxValue arryTmp = builder.createBox(loc, args[0]);
190 mlir::Value array = fir::getBase(arryTmp);
191 int rank = arryTmp.rank();
192 assert(rank >= 1);
193
194 // Handle optional mask argument
195 auto mask = isStaticallyAbsent(args[2])
196 ? builder.create<fir::AbsentOp>(
197 loc, fir::BoxType::get(builder.getI1Type()))
198 : builder.createBox(loc, args[2]);
199
200 bool absentDim = isStaticallyAbsent(args[1]);
201
202 // We call the type specific versions because the result is scalar
203 // in the case below.
204 if (absentDim || rank == 1) {
205 mlir::Type ty = array.getType();
206 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(ty);
207 auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
208 if (fir::isa_complex(eleTy)) {
209 mlir::Value result = builder.createTemporary(loc, eleTy);
210 func(builder, loc, array, mask, result);
211 return builder.create<fir::LoadOp>(loc, result);
212 }
213 auto resultBox = builder.create<fir::AbsentOp>(
214 loc, fir::BoxType::get(builder.getI1Type()));
215 return func(builder, loc, array, mask, resultBox);
216 }
217 // Handle Product/Sum cases that have an array result.
218 return genFuncDim(funcDim, resultType, builder, loc, stmtCtx, errMsg, array,
219 args[1], mask, rank);
220 }
221
222 /// Process calls to DotProduct
223 template <typename FN>
224 static fir::ExtendedValue
genDotProd(FN func,mlir::Type resultType,fir::FirOpBuilder & builder,mlir::Location loc,Fortran::lower::StatementContext * stmtCtx,llvm::ArrayRef<fir::ExtendedValue> args)225 genDotProd(FN func, mlir::Type resultType, fir::FirOpBuilder &builder,
226 mlir::Location loc, Fortran::lower::StatementContext *stmtCtx,
227 llvm::ArrayRef<fir::ExtendedValue> args) {
228
229 assert(args.size() == 2);
230
231 // Handle required vector arguments
232 mlir::Value vectorA = fir::getBase(args[0]);
233 mlir::Value vectorB = fir::getBase(args[1]);
234
235 mlir::Type eleTy = fir::dyn_cast_ptrOrBoxEleTy(vectorA.getType())
236 .cast<fir::SequenceType>()
237 .getEleTy();
238 if (fir::isa_complex(eleTy)) {
239 mlir::Value result = builder.createTemporary(loc, eleTy);
240 func(builder, loc, vectorA, vectorB, result);
241 return builder.create<fir::LoadOp>(loc, result);
242 }
243
244 auto resultBox = builder.create<fir::AbsentOp>(
245 loc, fir::BoxType::get(builder.getI1Type()));
246 return func(builder, loc, vectorA, vectorB, resultBox);
247 }
248
249 /// Process calls to Maxval, Minval, Product, Sum intrinsic functions
250 template <typename FN, typename FD, typename FC>
251 static fir::ExtendedValue
genExtremumVal(FN func,FD funcDim,FC funcChar,mlir::Type resultType,fir::FirOpBuilder & builder,mlir::Location loc,Fortran::lower::StatementContext * stmtCtx,llvm::StringRef errMsg,llvm::ArrayRef<fir::ExtendedValue> args)252 genExtremumVal(FN func, FD funcDim, FC funcChar, mlir::Type resultType,
253 fir::FirOpBuilder &builder, mlir::Location loc,
254 Fortran::lower::StatementContext *stmtCtx,
255 llvm::StringRef errMsg,
256 llvm::ArrayRef<fir::ExtendedValue> args) {
257
258 assert(args.size() == 3);
259
260 // Handle required array argument
261 fir::BoxValue arryTmp = builder.createBox(loc, args[0]);
262 mlir::Value array = fir::getBase(arryTmp);
263 int rank = arryTmp.rank();
264 assert(rank >= 1);
265 bool hasCharacterResult = arryTmp.isCharacter();
266
267 // Handle optional mask argument
268 auto mask = isStaticallyAbsent(args[2])
269 ? builder.create<fir::AbsentOp>(
270 loc, fir::BoxType::get(builder.getI1Type()))
271 : builder.createBox(loc, args[2]);
272
273 bool absentDim = isStaticallyAbsent(args[1]);
274
275 // For Maxval/MinVal, we call the type specific versions of
276 // Maxval/Minval because the result is scalar in the case below.
277 if (!hasCharacterResult && (absentDim || rank == 1))
278 return func(builder, loc, array, mask);
279
280 if (hasCharacterResult && (absentDim || rank == 1)) {
281 // Create mutable fir.box to be passed to the runtime for the result.
282 fir::MutableBoxValue resultMutableBox =
283 fir::factory::createTempMutableBox(builder, loc, resultType);
284 mlir::Value resultIrBox =
285 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
286
287 funcChar(builder, loc, resultIrBox, array, mask);
288
289 // Handle cleanup of allocatable result descriptor and return
290 fir::ExtendedValue res =
291 fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
292 return res.match(
293 [&](const fir::CharBoxValue &box) -> fir::ExtendedValue {
294 // Add cleanup code
295 assert(stmtCtx);
296 fir::FirOpBuilder *bldr = &builder;
297 mlir::Value temp = box.getAddr();
298 stmtCtx->attachCleanup(
299 [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
300 return box;
301 },
302 [&](const auto &) -> fir::ExtendedValue {
303 fir::emitFatalError(loc, errMsg);
304 });
305 }
306
307 // Handle Min/Maxval cases that have an array result.
308 return genFuncDim(funcDim, resultType, builder, loc, stmtCtx, errMsg, array,
309 args[1], mask, rank);
310 }
311
312 /// Process calls to Minloc, Maxloc intrinsic functions
313 template <typename FN, typename FD>
genExtremumloc(FN func,FD funcDim,mlir::Type resultType,fir::FirOpBuilder & builder,mlir::Location loc,Fortran::lower::StatementContext * stmtCtx,llvm::StringRef errMsg,llvm::ArrayRef<fir::ExtendedValue> args)314 static fir::ExtendedValue genExtremumloc(
315 FN func, FD funcDim, mlir::Type resultType, fir::FirOpBuilder &builder,
316 mlir::Location loc, Fortran::lower::StatementContext *stmtCtx,
317 llvm::StringRef errMsg, llvm::ArrayRef<fir::ExtendedValue> args) {
318
319 assert(args.size() == 5);
320
321 // Handle required array argument
322 mlir::Value array = builder.createBox(loc, args[0]);
323 unsigned rank = fir::BoxValue(array).rank();
324 assert(rank >= 1);
325
326 // Handle optional mask argument
327 auto mask = isStaticallyAbsent(args[2])
328 ? builder.create<fir::AbsentOp>(
329 loc, fir::BoxType::get(builder.getI1Type()))
330 : builder.createBox(loc, args[2]);
331
332 // Handle optional kind argument
333 auto kind = isStaticallyAbsent(args[3])
334 ? builder.createIntegerConstant(
335 loc, builder.getIndexType(),
336 builder.getKindMap().defaultIntegerKind())
337 : fir::getBase(args[3]);
338
339 // Handle optional back argument
340 auto back = isStaticallyAbsent(args[4]) ? builder.createBool(loc, false)
341 : fir::getBase(args[4]);
342
343 bool absentDim = isStaticallyAbsent(args[1]);
344
345 if (!absentDim && rank == 1) {
346 // If dim argument is present and the array is rank 1, then the result is
347 // a scalar (since the the result is rank-1 or 0).
348 // Therefore, we use a scalar result descriptor with Min/MaxlocDim().
349 mlir::Value dim = fir::getBase(args[1]);
350 // Create mutable fir.box to be passed to the runtime for the result.
351 fir::MutableBoxValue resultMutableBox =
352 fir::factory::createTempMutableBox(builder, loc, resultType);
353 mlir::Value resultIrBox =
354 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
355
356 funcDim(builder, loc, resultIrBox, array, dim, mask, kind, back);
357
358 // Handle cleanup of allocatable result descriptor and return
359 fir::ExtendedValue res =
360 fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
361 return res.match(
362 [&](const mlir::Value &tempAddr) -> fir::ExtendedValue {
363 // Add cleanup code
364 assert(stmtCtx);
365 fir::FirOpBuilder *bldr = &builder;
366 stmtCtx->attachCleanup(
367 [=]() { bldr->create<fir::FreeMemOp>(loc, tempAddr); });
368 return builder.create<fir::LoadOp>(loc, resultType, tempAddr);
369 },
370 [&](const auto &) -> fir::ExtendedValue {
371 fir::emitFatalError(loc, errMsg);
372 });
373 }
374
375 // Note: The Min/Maxloc/val cases below have an array result.
376
377 // Create mutable fir.box to be passed to the runtime for the result.
378 mlir::Type resultArrayType =
379 builder.getVarLenSeqTy(resultType, absentDim ? 1 : rank - 1);
380 fir::MutableBoxValue resultMutableBox =
381 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
382 mlir::Value resultIrBox =
383 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
384
385 if (absentDim) {
386 // Handle min/maxloc/val case where there is no dim argument
387 // (calls Min/Maxloc()/MinMaxval() runtime routine)
388 func(builder, loc, resultIrBox, array, mask, kind, back);
389 } else {
390 // else handle min/maxloc case with dim argument (calls
391 // Min/Max/loc/val/Dim() runtime routine).
392 mlir::Value dim = fir::getBase(args[1]);
393 funcDim(builder, loc, resultIrBox, array, dim, mask, kind, back);
394 }
395
396 return fir::factory::genMutableBoxRead(builder, loc, resultMutableBox)
397 .match(
398 [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
399 // Add cleanup code
400 assert(stmtCtx);
401 fir::FirOpBuilder *bldr = &builder;
402 mlir::Value temp = box.getAddr();
403 stmtCtx->attachCleanup(
404 [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
405 return box;
406 },
407 [&](const auto &) -> fir::ExtendedValue {
408 fir::emitFatalError(loc, errMsg);
409 });
410 }
411
412 // TODO error handling -> return a code or directly emit messages ?
413 struct IntrinsicLibrary {
414
415 // Constructors.
IntrinsicLibraryIntrinsicLibrary416 explicit IntrinsicLibrary(fir::FirOpBuilder &builder, mlir::Location loc,
417 Fortran::lower::StatementContext *stmtCtx = nullptr)
418 : builder{builder}, loc{loc}, stmtCtx{stmtCtx} {}
419 IntrinsicLibrary() = delete;
420 IntrinsicLibrary(const IntrinsicLibrary &) = delete;
421
422 /// Generate FIR for call to Fortran intrinsic \p name with arguments \p arg
423 /// and expected result type \p resultType.
424 fir::ExtendedValue genIntrinsicCall(llvm::StringRef name,
425 llvm::Optional<mlir::Type> resultType,
426 llvm::ArrayRef<fir::ExtendedValue> arg);
427
428 /// Search a runtime function that is associated to the generic intrinsic name
429 /// and whose signature matches the intrinsic arguments and result types.
430 /// If no such runtime function is found but a runtime function associated
431 /// with the Fortran generic exists and has the same number of arguments,
432 /// conversions will be inserted before and/or after the call. This is to
433 /// mainly to allow 16 bits float support even-though little or no math
434 /// runtime is currently available for it.
435 mlir::Value genRuntimeCall(llvm::StringRef name, mlir::Type,
436 llvm::ArrayRef<mlir::Value>);
437
438 using RuntimeCallGenerator = std::function<mlir::Value(
439 fir::FirOpBuilder &, mlir::Location, llvm::ArrayRef<mlir::Value>)>;
440 RuntimeCallGenerator
441 getRuntimeCallGenerator(llvm::StringRef name,
442 mlir::FunctionType soughtFuncType);
443
444 /// Lowering for the ABS intrinsic. The ABS intrinsic expects one argument in
445 /// the llvm::ArrayRef. The ABS intrinsic is lowered into MLIR/FIR operation
446 /// if the argument is an integer, into llvm intrinsics if the argument is
447 /// real and to the `hypot` math routine if the argument is of complex type.
448 mlir::Value genAbs(mlir::Type, llvm::ArrayRef<mlir::Value>);
449 template <void (*CallRuntime)(fir::FirOpBuilder &, mlir::Location loc,
450 mlir::Value, mlir::Value)>
451 fir::ExtendedValue genAdjustRtCall(mlir::Type,
452 llvm::ArrayRef<fir::ExtendedValue>);
453 mlir::Value genAimag(mlir::Type, llvm::ArrayRef<mlir::Value>);
454 mlir::Value genAint(mlir::Type, llvm::ArrayRef<mlir::Value>);
455 fir::ExtendedValue genAll(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
456 fir::ExtendedValue genAllocated(mlir::Type,
457 llvm::ArrayRef<fir::ExtendedValue>);
458 mlir::Value genAnint(mlir::Type, llvm::ArrayRef<mlir::Value>);
459 fir::ExtendedValue genAny(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
460 fir::ExtendedValue
461 genCommandArgumentCount(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
462 fir::ExtendedValue genAssociated(mlir::Type,
463 llvm::ArrayRef<fir::ExtendedValue>);
464
465 /// Lower a bitwise comparison intrinsic using the given comparator.
466 template <mlir::arith::CmpIPredicate pred>
467 mlir::Value genBitwiseCompare(mlir::Type resultType,
468 llvm::ArrayRef<mlir::Value> args);
469
470 mlir::Value genBtest(mlir::Type, llvm::ArrayRef<mlir::Value>);
471 mlir::Value genCeiling(mlir::Type, llvm::ArrayRef<mlir::Value>);
472 fir::ExtendedValue genChar(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
473 template <mlir::arith::CmpIPredicate pred>
474 fir::ExtendedValue genCharacterCompare(mlir::Type,
475 llvm::ArrayRef<fir::ExtendedValue>);
476 mlir::Value genCmplx(mlir::Type, llvm::ArrayRef<mlir::Value>);
477 mlir::Value genConjg(mlir::Type, llvm::ArrayRef<mlir::Value>);
478 fir::ExtendedValue genCount(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
479 void genCpuTime(llvm::ArrayRef<fir::ExtendedValue>);
480 fir::ExtendedValue genCshift(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
481 void genDateAndTime(llvm::ArrayRef<fir::ExtendedValue>);
482 mlir::Value genDim(mlir::Type, llvm::ArrayRef<mlir::Value>);
483 fir::ExtendedValue genDotProduct(mlir::Type,
484 llvm::ArrayRef<fir::ExtendedValue>);
485 mlir::Value genDprod(mlir::Type, llvm::ArrayRef<mlir::Value>);
486 mlir::Value genDshiftl(mlir::Type, llvm::ArrayRef<mlir::Value>);
487 mlir::Value genDshiftr(mlir::Type, llvm::ArrayRef<mlir::Value>);
488 fir::ExtendedValue genEoshift(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
489 void genExit(llvm::ArrayRef<fir::ExtendedValue>);
490 mlir::Value genExponent(mlir::Type, llvm::ArrayRef<mlir::Value>);
491 template <Extremum, ExtremumBehavior>
492 mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
493 mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
494 mlir::Value genFraction(mlir::Type resultType,
495 mlir::ArrayRef<mlir::Value> args);
496 void genGetCommandArgument(mlir::ArrayRef<fir::ExtendedValue> args);
497 void genGetEnvironmentVariable(llvm::ArrayRef<fir::ExtendedValue>);
498 /// Lowering for the IAND intrinsic. The IAND intrinsic expects two arguments
499 /// in the llvm::ArrayRef.
500 mlir::Value genIand(mlir::Type, llvm::ArrayRef<mlir::Value>);
501 mlir::Value genIbclr(mlir::Type, llvm::ArrayRef<mlir::Value>);
502 mlir::Value genIbits(mlir::Type, llvm::ArrayRef<mlir::Value>);
503 mlir::Value genIbset(mlir::Type, llvm::ArrayRef<mlir::Value>);
504 fir::ExtendedValue genIchar(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
505 mlir::Value genIeeeIsFinite(mlir::Type, llvm::ArrayRef<mlir::Value>);
506 template <mlir::arith::CmpIPredicate pred>
507 fir::ExtendedValue genIeeeTypeCompare(mlir::Type,
508 llvm::ArrayRef<fir::ExtendedValue>);
509 mlir::Value genIeor(mlir::Type, llvm::ArrayRef<mlir::Value>);
510 fir::ExtendedValue genIndex(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
511 mlir::Value genIor(mlir::Type, llvm::ArrayRef<mlir::Value>);
512 mlir::Value genIshft(mlir::Type, llvm::ArrayRef<mlir::Value>);
513 mlir::Value genIshftc(mlir::Type, llvm::ArrayRef<mlir::Value>);
514 fir::ExtendedValue genLbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
515 mlir::Value genLeadz(mlir::Type, llvm::ArrayRef<mlir::Value>);
516 fir::ExtendedValue genLen(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
517 fir::ExtendedValue genLenTrim(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
518 template <typename Shift>
519 mlir::Value genMask(mlir::Type, llvm::ArrayRef<mlir::Value>);
520 fir::ExtendedValue genMatmul(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
521 fir::ExtendedValue genMaxloc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
522 fir::ExtendedValue genMaxval(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
523 fir::ExtendedValue genMerge(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
524 mlir::Value genMergeBits(mlir::Type, llvm::ArrayRef<mlir::Value>);
525 fir::ExtendedValue genMinloc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
526 fir::ExtendedValue genMinval(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
527 mlir::Value genMod(mlir::Type, llvm::ArrayRef<mlir::Value>);
528 mlir::Value genModulo(mlir::Type, llvm::ArrayRef<mlir::Value>);
529 void genMvbits(llvm::ArrayRef<fir::ExtendedValue>);
530 mlir::Value genNearest(mlir::Type, llvm::ArrayRef<mlir::Value>);
531 mlir::Value genNint(mlir::Type, llvm::ArrayRef<mlir::Value>);
532 mlir::Value genNot(mlir::Type, llvm::ArrayRef<mlir::Value>);
533 fir::ExtendedValue genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
534 fir::ExtendedValue genPack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
535 mlir::Value genPopcnt(mlir::Type, llvm::ArrayRef<mlir::Value>);
536 mlir::Value genPoppar(mlir::Type, llvm::ArrayRef<mlir::Value>);
537 fir::ExtendedValue genPresent(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
538 fir::ExtendedValue genProduct(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
539 void genRandomInit(llvm::ArrayRef<fir::ExtendedValue>);
540 void genRandomNumber(llvm::ArrayRef<fir::ExtendedValue>);
541 void genRandomSeed(llvm::ArrayRef<fir::ExtendedValue>);
542 fir::ExtendedValue genRepeat(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
543 fir::ExtendedValue genReshape(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
544 mlir::Value genRRSpacing(mlir::Type resultType,
545 llvm::ArrayRef<mlir::Value> args);
546 mlir::Value genScale(mlir::Type, llvm::ArrayRef<mlir::Value>);
547 fir::ExtendedValue genScan(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
548 mlir::Value genSelectedIntKind(mlir::Type, llvm::ArrayRef<mlir::Value>);
549 mlir::Value genSelectedRealKind(mlir::Type, llvm::ArrayRef<mlir::Value>);
550 mlir::Value genSetExponent(mlir::Type resultType,
551 llvm::ArrayRef<mlir::Value> args);
552 template <typename Shift>
553 mlir::Value genShift(mlir::Type resultType, llvm::ArrayRef<mlir::Value>);
554 mlir::Value genSign(mlir::Type, llvm::ArrayRef<mlir::Value>);
555 fir::ExtendedValue genSize(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
556 mlir::Value genSpacing(mlir::Type resultType,
557 llvm::ArrayRef<mlir::Value> args);
558 fir::ExtendedValue genSpread(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
559 fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
560 void genSystemClock(llvm::ArrayRef<fir::ExtendedValue>);
561 mlir::Value genTrailz(mlir::Type, llvm::ArrayRef<mlir::Value>);
562 fir::ExtendedValue genTransfer(mlir::Type,
563 llvm::ArrayRef<fir::ExtendedValue>);
564 fir::ExtendedValue genTranspose(mlir::Type,
565 llvm::ArrayRef<fir::ExtendedValue>);
566 fir::ExtendedValue genTrim(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
567 fir::ExtendedValue genUbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
568 fir::ExtendedValue genUnpack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
569 fir::ExtendedValue genVerify(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
570 /// Implement all conversion functions like DBLE, the first argument is
571 /// the value to convert. There may be an additional KIND arguments that
572 /// is ignored because this is already reflected in the result type.
573 mlir::Value genConversion(mlir::Type, llvm::ArrayRef<mlir::Value>);
574
575 /// Define the different FIR generators that can be mapped to intrinsic to
576 /// generate the related code.
577 using ElementalGenerator = decltype(&IntrinsicLibrary::genAbs);
578 using ExtendedGenerator = decltype(&IntrinsicLibrary::genLenTrim);
579 using SubroutineGenerator = decltype(&IntrinsicLibrary::genDateAndTime);
580 using Generator =
581 std::variant<ElementalGenerator, ExtendedGenerator, SubroutineGenerator>;
582
583 /// All generators can be outlined. This will build a function named
584 /// "fir."+ <generic name> + "." + <result type code> and generate the
585 /// intrinsic implementation inside instead of at the intrinsic call sites.
586 /// This can be used to keep the FIR more readable. Only one function will
587 /// be generated for all the similar calls in a program.
588 /// If the Generator is nullptr, the wrapper uses genRuntimeCall.
589 template <typename GeneratorType>
590 mlir::Value outlineInWrapper(GeneratorType, llvm::StringRef name,
591 mlir::Type resultType,
592 llvm::ArrayRef<mlir::Value> args);
593 template <typename GeneratorType>
594 fir::ExtendedValue
595 outlineInExtendedWrapper(GeneratorType, llvm::StringRef name,
596 llvm::Optional<mlir::Type> resultType,
597 llvm::ArrayRef<fir::ExtendedValue> args);
598
599 template <typename GeneratorType>
600 mlir::func::FuncOp getWrapper(GeneratorType, llvm::StringRef name,
601 mlir::FunctionType,
602 bool loadRefArguments = false);
603
604 /// Generate calls to ElementalGenerator, handling the elemental aspects
605 template <typename GeneratorType>
606 fir::ExtendedValue
607 genElementalCall(GeneratorType, llvm::StringRef name, mlir::Type resultType,
608 llvm::ArrayRef<fir::ExtendedValue> args, bool outline);
609
610 /// Helper to invoke code generator for the intrinsics given arguments.
611 mlir::Value invokeGenerator(ElementalGenerator generator,
612 mlir::Type resultType,
613 llvm::ArrayRef<mlir::Value> args);
614 mlir::Value invokeGenerator(RuntimeCallGenerator generator,
615 mlir::Type resultType,
616 llvm::ArrayRef<mlir::Value> args);
617 mlir::Value invokeGenerator(ExtendedGenerator generator,
618 mlir::Type resultType,
619 llvm::ArrayRef<mlir::Value> args);
620 mlir::Value invokeGenerator(SubroutineGenerator generator,
621 llvm::ArrayRef<mlir::Value> args);
622
623 /// Get pointer to unrestricted intrinsic. Generate the related unrestricted
624 /// intrinsic if it is not defined yet.
625 mlir::SymbolRefAttr
626 getUnrestrictedIntrinsicSymbolRefAttr(llvm::StringRef name,
627 mlir::FunctionType signature);
628
629 /// Add clean-up for \p temp to the current statement context;
630 void addCleanUpForTemp(mlir::Location loc, mlir::Value temp);
631 /// Helper function for generating code clean-up for result descriptors
632 fir::ExtendedValue readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,
633 mlir::Type resultType,
634 llvm::StringRef errMsg);
635
636 fir::FirOpBuilder &builder;
637 mlir::Location loc;
638 Fortran::lower::StatementContext *stmtCtx;
639 };
640
641 struct IntrinsicDummyArgument {
642 const char *name = nullptr;
643 Fortran::lower::LowerIntrinsicArgAs lowerAs =
644 Fortran::lower::LowerIntrinsicArgAs::Value;
645 bool handleDynamicOptional = false;
646 };
647
648 struct Fortran::lower::IntrinsicArgumentLoweringRules {
649 /// There is no more than 7 non repeated arguments in Fortran intrinsics.
650 IntrinsicDummyArgument args[7];
hasDefaultRulesFortran::lower::IntrinsicArgumentLoweringRules651 constexpr bool hasDefaultRules() const { return args[0].name == nullptr; }
652 };
653
654 /// Structure describing what needs to be done to lower intrinsic "name".
655 struct IntrinsicHandler {
656 const char *name;
657 IntrinsicLibrary::Generator generator;
658 // The following may be omitted in the table below.
659 Fortran::lower::IntrinsicArgumentLoweringRules argLoweringRules = {};
660 bool isElemental = true;
661 /// Code heavy intrinsic can be outlined to make FIR
662 /// more readable.
663 bool outline = false;
664 };
665
666 constexpr auto asValue = Fortran::lower::LowerIntrinsicArgAs::Value;
667 constexpr auto asAddr = Fortran::lower::LowerIntrinsicArgAs::Addr;
668 constexpr auto asBox = Fortran::lower::LowerIntrinsicArgAs::Box;
669 constexpr auto asInquired = Fortran::lower::LowerIntrinsicArgAs::Inquired;
670 using I = IntrinsicLibrary;
671
672 /// Flag to indicate that an intrinsic argument has to be handled as
673 /// being dynamically optional (e.g. special handling when actual
674 /// argument is an optional variable in the current scope).
675 static constexpr bool handleDynamicOptional = true;
676
677 /// Table that drives the fir generation depending on the intrinsic.
678 /// one to one mapping with Fortran arguments. If no mapping is
679 /// defined here for a generic intrinsic, genRuntimeCall will be called
680 /// to look for a match in the runtime a emit a call. Note that the argument
681 /// lowering rules for an intrinsic need to be provided only if at least one
682 /// argument must not be lowered by value. In which case, the lowering rules
683 /// should be provided for all the intrinsic arguments for completeness.
684 static constexpr IntrinsicHandler handlers[]{
685 {"abs", &I::genAbs},
686 {"achar", &I::genChar},
687 {"adjustl",
688 &I::genAdjustRtCall<fir::runtime::genAdjustL>,
689 {{{"string", asAddr}}},
690 /*isElemental=*/true},
691 {"adjustr",
692 &I::genAdjustRtCall<fir::runtime::genAdjustR>,
693 {{{"string", asAddr}}},
694 /*isElemental=*/true},
695 {"aimag", &I::genAimag},
696 {"aint", &I::genAint},
697 {"all",
698 &I::genAll,
699 {{{"mask", asAddr}, {"dim", asValue}}},
700 /*isElemental=*/false},
701 {"allocated",
702 &I::genAllocated,
703 {{{"array", asInquired}, {"scalar", asInquired}}},
704 /*isElemental=*/false},
705 {"anint", &I::genAnint},
706 {"any",
707 &I::genAny,
708 {{{"mask", asAddr}, {"dim", asValue}}},
709 /*isElemental=*/false},
710 {"associated",
711 &I::genAssociated,
712 {{{"pointer", asInquired}, {"target", asInquired}}},
713 /*isElemental=*/false},
714 {"bge", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::uge>},
715 {"bgt", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ugt>},
716 {"ble", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ule>},
717 {"blt", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ult>},
718 {"btest", &I::genBtest},
719 {"ceiling", &I::genCeiling},
720 {"char", &I::genChar},
721 {"cmplx",
722 &I::genCmplx,
723 {{{"x", asValue}, {"y", asValue, handleDynamicOptional}}}},
724 {"command_argument_count", &I::genCommandArgumentCount},
725 {"conjg", &I::genConjg},
726 {"count",
727 &I::genCount,
728 {{{"mask", asAddr}, {"dim", asValue}, {"kind", asValue}}},
729 /*isElemental=*/false},
730 {"cpu_time",
731 &I::genCpuTime,
732 {{{"time", asAddr}}},
733 /*isElemental=*/false},
734 {"cshift",
735 &I::genCshift,
736 {{{"array", asAddr}, {"shift", asAddr}, {"dim", asValue}}},
737 /*isElemental=*/false},
738 {"date_and_time",
739 &I::genDateAndTime,
740 {{{"date", asAddr, handleDynamicOptional},
741 {"time", asAddr, handleDynamicOptional},
742 {"zone", asAddr, handleDynamicOptional},
743 {"values", asBox, handleDynamicOptional}}},
744 /*isElemental=*/false},
745 {"dble", &I::genConversion},
746 {"dim", &I::genDim},
747 {"dot_product",
748 &I::genDotProduct,
749 {{{"vector_a", asBox}, {"vector_b", asBox}}},
750 /*isElemental=*/false},
751 {"dprod", &I::genDprod},
752 {"dshiftl", &I::genDshiftl},
753 {"dshiftr", &I::genDshiftr},
754 {"eoshift",
755 &I::genEoshift,
756 {{{"array", asBox},
757 {"shift", asAddr},
758 {"boundary", asBox, handleDynamicOptional},
759 {"dim", asValue}}},
760 /*isElemental=*/false},
761 {"exit",
762 &I::genExit,
763 {{{"status", asValue, handleDynamicOptional}}},
764 /*isElemental=*/false},
765 {"exponent", &I::genExponent},
766 {"floor", &I::genFloor},
767 {"fraction", &I::genFraction},
768 {"get_command_argument",
769 &I::genGetCommandArgument,
770 {{{"number", asValue},
771 {"value", asBox, handleDynamicOptional},
772 {"length", asAddr},
773 {"status", asAddr},
774 {"errmsg", asBox, handleDynamicOptional}}},
775 /*isElemental=*/false},
776 {"get_environment_variable",
777 &I::genGetEnvironmentVariable,
778 {{{"name", asBox},
779 {"value", asBox, handleDynamicOptional},
780 {"length", asAddr},
781 {"status", asAddr},
782 {"trim_name", asAddr},
783 {"errmsg", asBox, handleDynamicOptional}}},
784 /*isElemental=*/false},
785 {"iachar", &I::genIchar},
786 {"iand", &I::genIand},
787 {"ibclr", &I::genIbclr},
788 {"ibits", &I::genIbits},
789 {"ibset", &I::genIbset},
790 {"ichar", &I::genIchar},
791 {"ieee_class_eq", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::eq>},
792 {"ieee_class_ne", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::ne>},
793 {"ieee_is_finite", &I::genIeeeIsFinite},
794 {"ieee_round_eq", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::eq>},
795 {"ieee_round_ne", &I::genIeeeTypeCompare<mlir::arith::CmpIPredicate::ne>},
796 {"ieor", &I::genIeor},
797 {"index",
798 &I::genIndex,
799 {{{"string", asAddr},
800 {"substring", asAddr},
801 {"back", asValue, handleDynamicOptional},
802 {"kind", asValue}}}},
803 {"ior", &I::genIor},
804 {"ishft", &I::genIshft},
805 {"ishftc", &I::genIshftc},
806 {"lbound",
807 &I::genLbound,
808 {{{"array", asInquired}, {"dim", asValue}, {"kind", asValue}}},
809 /*isElemental=*/false},
810 {"leadz", &I::genLeadz},
811 {"len",
812 &I::genLen,
813 {{{"string", asInquired}, {"kind", asValue}}},
814 /*isElemental=*/false},
815 {"len_trim", &I::genLenTrim},
816 {"lge", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sge>},
817 {"lgt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sgt>},
818 {"lle", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sle>},
819 {"llt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::slt>},
820 {"maskl", &I::genMask<mlir::arith::ShLIOp>},
821 {"maskr", &I::genMask<mlir::arith::ShRUIOp>},
822 {"matmul",
823 &I::genMatmul,
824 {{{"matrix_a", asAddr}, {"matrix_b", asAddr}}},
825 /*isElemental=*/false},
826 {"max", &I::genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>},
827 {"maxloc",
828 &I::genMaxloc,
829 {{{"array", asBox},
830 {"dim", asValue},
831 {"mask", asBox, handleDynamicOptional},
832 {"kind", asValue},
833 {"back", asValue, handleDynamicOptional}}},
834 /*isElemental=*/false},
835 {"maxval",
836 &I::genMaxval,
837 {{{"array", asBox},
838 {"dim", asValue},
839 {"mask", asBox, handleDynamicOptional}}},
840 /*isElemental=*/false},
841 {"merge", &I::genMerge},
842 {"merge_bits", &I::genMergeBits},
843 {"min", &I::genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>},
844 {"minloc",
845 &I::genMinloc,
846 {{{"array", asBox},
847 {"dim", asValue},
848 {"mask", asBox, handleDynamicOptional},
849 {"kind", asValue},
850 {"back", asValue, handleDynamicOptional}}},
851 /*isElemental=*/false},
852 {"minval",
853 &I::genMinval,
854 {{{"array", asBox},
855 {"dim", asValue},
856 {"mask", asBox, handleDynamicOptional}}},
857 /*isElemental=*/false},
858 {"mod", &I::genMod},
859 {"modulo", &I::genModulo},
860 {"mvbits",
861 &I::genMvbits,
862 {{{"from", asValue},
863 {"frompos", asValue},
864 {"len", asValue},
865 {"to", asAddr},
866 {"topos", asValue}}}},
867 {"nearest", &I::genNearest},
868 {"nint", &I::genNint},
869 {"not", &I::genNot},
870 {"null", &I::genNull, {{{"mold", asInquired}}}, /*isElemental=*/false},
871 {"pack",
872 &I::genPack,
873 {{{"array", asBox},
874 {"mask", asBox},
875 {"vector", asBox, handleDynamicOptional}}},
876 /*isElemental=*/false},
877 {"popcnt", &I::genPopcnt},
878 {"poppar", &I::genPoppar},
879 {"present",
880 &I::genPresent,
881 {{{"a", asInquired}}},
882 /*isElemental=*/false},
883 {"product",
884 &I::genProduct,
885 {{{"array", asBox},
886 {"dim", asValue},
887 {"mask", asBox, handleDynamicOptional}}},
888 /*isElemental=*/false},
889 {"random_init",
890 &I::genRandomInit,
891 {{{"repeatable", asValue}, {"image_distinct", asValue}}},
892 /*isElemental=*/false},
893 {"random_number",
894 &I::genRandomNumber,
895 {{{"harvest", asBox}}},
896 /*isElemental=*/false},
897 {"random_seed",
898 &I::genRandomSeed,
899 {{{"size", asBox}, {"put", asBox}, {"get", asBox}}},
900 /*isElemental=*/false},
901 {"repeat",
902 &I::genRepeat,
903 {{{"string", asAddr}, {"ncopies", asValue}}},
904 /*isElemental=*/false},
905 {"reshape",
906 &I::genReshape,
907 {{{"source", asBox},
908 {"shape", asBox},
909 {"pad", asBox, handleDynamicOptional},
910 {"order", asBox, handleDynamicOptional}}},
911 /*isElemental=*/false},
912 {"rrspacing", &I::genRRSpacing},
913 {"scale",
914 &I::genScale,
915 {{{"x", asValue}, {"i", asValue}}},
916 /*isElemental=*/true},
917 {"scan",
918 &I::genScan,
919 {{{"string", asAddr},
920 {"set", asAddr},
921 {"back", asValue, handleDynamicOptional},
922 {"kind", asValue}}},
923 /*isElemental=*/true},
924 {"selected_int_kind",
925 &I::genSelectedIntKind,
926 {{{"scalar", asAddr}}},
927 /*isElemental=*/false},
928 {"selected_real_kind",
929 &I::genSelectedRealKind,
930 {{{"precision", asAddr, handleDynamicOptional},
931 {"range", asAddr, handleDynamicOptional},
932 {"radix", asAddr, handleDynamicOptional}}},
933 /*isElemental=*/false},
934 {"set_exponent", &I::genSetExponent},
935 {"shifta", &I::genShift<mlir::arith::ShRSIOp>},
936 {"shiftl", &I::genShift<mlir::arith::ShLIOp>},
937 {"shiftr", &I::genShift<mlir::arith::ShRUIOp>},
938 {"sign", &I::genSign},
939 {"size",
940 &I::genSize,
941 {{{"array", asBox},
942 {"dim", asAddr, handleDynamicOptional},
943 {"kind", asValue}}},
944 /*isElemental=*/false},
945 {"spacing", &I::genSpacing},
946 {"spread",
947 &I::genSpread,
948 {{{"source", asAddr}, {"dim", asValue}, {"ncopies", asValue}}},
949 /*isElemental=*/false},
950 {"sum",
951 &I::genSum,
952 {{{"array", asBox},
953 {"dim", asValue},
954 {"mask", asBox, handleDynamicOptional}}},
955 /*isElemental=*/false},
956 {"system_clock",
957 &I::genSystemClock,
958 {{{"count", asAddr}, {"count_rate", asAddr}, {"count_max", asAddr}}},
959 /*isElemental=*/false},
960 {"trailz", &I::genTrailz},
961 {"transfer",
962 &I::genTransfer,
963 {{{"source", asAddr}, {"mold", asAddr}, {"size", asValue}}},
964 /*isElemental=*/false},
965 {"transpose",
966 &I::genTranspose,
967 {{{"matrix", asAddr}}},
968 /*isElemental=*/false},
969 {"trim", &I::genTrim, {{{"string", asAddr}}}, /*isElemental=*/false},
970 {"ubound",
971 &I::genUbound,
972 {{{"array", asBox}, {"dim", asValue}, {"kind", asValue}}},
973 /*isElemental=*/false},
974 {"unpack",
975 &I::genUnpack,
976 {{{"vector", asBox}, {"mask", asBox}, {"field", asBox}}},
977 /*isElemental=*/false},
978 {"verify",
979 &I::genVerify,
980 {{{"string", asAddr},
981 {"set", asAddr},
982 {"back", asValue, handleDynamicOptional},
983 {"kind", asValue}}},
984 /*isElemental=*/true},
985 };
986
findIntrinsicHandler(llvm::StringRef name)987 static const IntrinsicHandler *findIntrinsicHandler(llvm::StringRef name) {
988 auto compare = [](const IntrinsicHandler &handler, llvm::StringRef name) {
989 return name.compare(handler.name) > 0;
990 };
991 auto result =
992 std::lower_bound(std::begin(handlers), std::end(handlers), name, compare);
993 return result != std::end(handlers) && result->name == name ? result
994 : nullptr;
995 }
996
997 /// To make fir output more readable for debug, one can outline all intrinsic
998 /// implementation in wrappers (overrides the IntrinsicHandler::outline flag).
999 static llvm::cl::opt<bool> outlineAllIntrinsics(
1000 "outline-intrinsics",
1001 llvm::cl::desc(
1002 "Lower all intrinsic procedure implementation in their own functions"),
1003 llvm::cl::init(false));
1004
1005 //===----------------------------------------------------------------------===//
1006 // Math runtime description and matching utility
1007 //===----------------------------------------------------------------------===//
1008
1009 /// Command line option to modify math runtime behavior used to implement
1010 /// intrinsics. This option applies both to early and late math-lowering modes.
1011 enum MathRuntimeVersion { fastVersion, relaxedVersion, preciseVersion };
1012 llvm::cl::opt<MathRuntimeVersion> mathRuntimeVersion(
1013 "math-runtime", llvm::cl::desc("Select math operations' runtime behavior:"),
1014 llvm::cl::values(
1015 clEnumValN(fastVersion, "fast", "use fast runtime behavior"),
1016 clEnumValN(relaxedVersion, "relaxed", "use relaxed runtime behavior"),
1017 clEnumValN(preciseVersion, "precise", "use precise runtime behavior")),
1018 llvm::cl::init(fastVersion));
1019
1020 struct RuntimeFunction {
1021 // llvm::StringRef comparison operator are not constexpr, so use string_view.
1022 using Key = std::string_view;
1023 // Needed for implicit compare with keys.
operator KeyRuntimeFunction1024 constexpr operator Key() const { return key; }
1025 Key key; // intrinsic name
1026
1027 // Name of a runtime function that implements the operation.
1028 llvm::StringRef symbol;
1029 fir::runtime::FuncTypeBuilderFunc typeGenerator;
1030 };
1031
1032 #define RUNTIME_STATIC_DESCRIPTION(name, func) \
1033 {#name, #func, fir::runtime::RuntimeTableKey<decltype(func)>::getTypeModel()},
1034 static constexpr RuntimeFunction pgmathFast[] = {
1035 #define PGMATH_FAST
1036 #define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func)
1037 #include "flang/Evaluate/pgmath.h.inc"
1038 };
1039 static constexpr RuntimeFunction pgmathRelaxed[] = {
1040 #define PGMATH_RELAXED
1041 #define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func)
1042 #include "flang/Evaluate/pgmath.h.inc"
1043 };
1044 static constexpr RuntimeFunction pgmathPrecise[] = {
1045 #define PGMATH_PRECISE
1046 #define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func)
1047 #include "flang/Evaluate/pgmath.h.inc"
1048 };
1049
genF32F32FuncType(mlir::MLIRContext * context)1050 static mlir::FunctionType genF32F32FuncType(mlir::MLIRContext *context) {
1051 mlir::Type t = mlir::FloatType::getF32(context);
1052 return mlir::FunctionType::get(context, {t}, {t});
1053 }
1054
genF64F64FuncType(mlir::MLIRContext * context)1055 static mlir::FunctionType genF64F64FuncType(mlir::MLIRContext *context) {
1056 mlir::Type t = mlir::FloatType::getF64(context);
1057 return mlir::FunctionType::get(context, {t}, {t});
1058 }
1059
genF80F80FuncType(mlir::MLIRContext * context)1060 static mlir::FunctionType genF80F80FuncType(mlir::MLIRContext *context) {
1061 mlir::Type t = mlir::FloatType::getF80(context);
1062 return mlir::FunctionType::get(context, {t}, {t});
1063 }
1064
genF128F128FuncType(mlir::MLIRContext * context)1065 static mlir::FunctionType genF128F128FuncType(mlir::MLIRContext *context) {
1066 mlir::Type t = mlir::FloatType::getF128(context);
1067 return mlir::FunctionType::get(context, {t}, {t});
1068 }
1069
genF32F32F32FuncType(mlir::MLIRContext * context)1070 static mlir::FunctionType genF32F32F32FuncType(mlir::MLIRContext *context) {
1071 auto t = mlir::FloatType::getF32(context);
1072 return mlir::FunctionType::get(context, {t, t}, {t});
1073 }
1074
genF64F64F64FuncType(mlir::MLIRContext * context)1075 static mlir::FunctionType genF64F64F64FuncType(mlir::MLIRContext *context) {
1076 auto t = mlir::FloatType::getF64(context);
1077 return mlir::FunctionType::get(context, {t, t}, {t});
1078 }
1079
genF80F80F80FuncType(mlir::MLIRContext * context)1080 static mlir::FunctionType genF80F80F80FuncType(mlir::MLIRContext *context) {
1081 auto t = mlir::FloatType::getF80(context);
1082 return mlir::FunctionType::get(context, {t, t}, {t});
1083 }
1084
genF128F128F128FuncType(mlir::MLIRContext * context)1085 static mlir::FunctionType genF128F128F128FuncType(mlir::MLIRContext *context) {
1086 auto t = mlir::FloatType::getF128(context);
1087 return mlir::FunctionType::get(context, {t, t}, {t});
1088 }
1089
1090 template <int Bits>
genIntF64FuncType(mlir::MLIRContext * context)1091 static mlir::FunctionType genIntF64FuncType(mlir::MLIRContext *context) {
1092 auto t = mlir::FloatType::getF64(context);
1093 auto r = mlir::IntegerType::get(context, Bits);
1094 return mlir::FunctionType::get(context, {t}, {r});
1095 }
1096
1097 template <int Bits>
genIntF32FuncType(mlir::MLIRContext * context)1098 static mlir::FunctionType genIntF32FuncType(mlir::MLIRContext *context) {
1099 auto t = mlir::FloatType::getF32(context);
1100 auto r = mlir::IntegerType::get(context, Bits);
1101 return mlir::FunctionType::get(context, {t}, {r});
1102 }
1103
1104 template <int Bits>
genF64F64IntFuncType(mlir::MLIRContext * context)1105 static mlir::FunctionType genF64F64IntFuncType(mlir::MLIRContext *context) {
1106 auto ftype = mlir::FloatType::getF64(context);
1107 auto itype = mlir::IntegerType::get(context, Bits);
1108 return mlir::FunctionType::get(context, {ftype, itype}, {ftype});
1109 }
1110
1111 template <int Bits>
genF32F32IntFuncType(mlir::MLIRContext * context)1112 static mlir::FunctionType genF32F32IntFuncType(mlir::MLIRContext *context) {
1113 auto ftype = mlir::FloatType::getF32(context);
1114 auto itype = mlir::IntegerType::get(context, Bits);
1115 return mlir::FunctionType::get(context, {ftype, itype}, {ftype});
1116 }
1117
1118 /// Callback type for generating lowering for a math operation.
1119 using MathGeneratorTy = mlir::Value (*)(fir::FirOpBuilder &, mlir::Location,
1120 llvm::StringRef, mlir::FunctionType,
1121 llvm::ArrayRef<mlir::Value>);
1122
1123 struct MathOperation {
1124 // llvm::StringRef comparison operator are not constexpr, so use string_view.
1125 using Key = std::string_view;
1126 // Needed for implicit compare with keys.
operator KeyMathOperation1127 constexpr operator Key() const { return key; }
1128 // Intrinsic name.
1129 Key key;
1130
1131 // Name of a runtime function that implements the operation.
1132 llvm::StringRef runtimeFunc;
1133 fir::runtime::FuncTypeBuilderFunc typeGenerator;
1134
1135 // A callback to generate FIR for the intrinsic defined by 'key'.
1136 // A callback may generate either dedicated MLIR operation(s) or
1137 // a function call to a runtime function with name defined by
1138 // 'runtimeFunc'.
1139 MathGeneratorTy funcGenerator;
1140 };
1141
genLibCall(fir::FirOpBuilder & builder,mlir::Location loc,llvm::StringRef libFuncName,mlir::FunctionType libFuncType,llvm::ArrayRef<mlir::Value> args)1142 static mlir::Value genLibCall(fir::FirOpBuilder &builder, mlir::Location loc,
1143 llvm::StringRef libFuncName,
1144 mlir::FunctionType libFuncType,
1145 llvm::ArrayRef<mlir::Value> args) {
1146 LLVM_DEBUG(llvm::dbgs() << "Generating '" << libFuncName
1147 << "' call with type ";
1148 libFuncType.dump(); llvm::dbgs() << "\n");
1149 mlir::func::FuncOp funcOp =
1150 builder.addNamedFunction(loc, libFuncName, libFuncType);
1151 // TODO: ensure 'strictfp' setting on the call for "precise/strict"
1152 // FP mode. Set appropriate Fast-Math Flags otherwise.
1153 // TODO: we should also mark as many libm function as possible
1154 // with 'pure' attribute (of course, not in strict FP mode).
1155 auto libCall = builder.create<fir::CallOp>(loc, funcOp, args);
1156 LLVM_DEBUG(libCall.dump(); llvm::dbgs() << "\n");
1157 return libCall.getResult(0);
1158 }
1159
1160 template <typename T>
genMathOp(fir::FirOpBuilder & builder,mlir::Location loc,llvm::StringRef mathLibFuncName,mlir::FunctionType mathLibFuncType,llvm::ArrayRef<mlir::Value> args)1161 static mlir::Value genMathOp(fir::FirOpBuilder &builder, mlir::Location loc,
1162 llvm::StringRef mathLibFuncName,
1163 mlir::FunctionType mathLibFuncType,
1164 llvm::ArrayRef<mlir::Value> args) {
1165 // TODO: we have to annotate the math operations with flags
1166 // that will allow to define FP accuracy/exception
1167 // behavior per operation, so that after early multi-module
1168 // MLIR inlining we can distiguish operation that were
1169 // compiled with different settings.
1170 // Suggestion:
1171 // * For "relaxed" FP mode set all Fast-Math Flags
1172 // (see "[RFC] FastMath flags support in MLIR (arith dialect)"
1173 // topic at discourse.llvm.org).
1174 // * For "fast" FP mode set all Fast-Math Flags except 'afn'.
1175 // * For "precise/strict" FP mode generate fir.calls to libm
1176 // entries and annotate them with an attribute that will
1177 // end up transformed into 'strictfp' LLVM attribute (TBD).
1178 // Elsewhere, "precise/strict" FP mode should also set
1179 // 'strictfp' for all user functions and calls so that
1180 // LLVM backend does the right job.
1181 // * Operations that cannot be reasonably optimized in MLIR
1182 // can be also lowered to libm calls for "fast" and "relaxed"
1183 // modes.
1184 mlir::Value result;
1185 if (mathRuntimeVersion == preciseVersion) {
1186 result = genLibCall(builder, loc, mathLibFuncName, mathLibFuncType, args);
1187 } else {
1188 LLVM_DEBUG(llvm::dbgs() << "Generating '" << mathLibFuncName
1189 << "' operation with type ";
1190 mathLibFuncType.dump(); llvm::dbgs() << "\n");
1191 result = builder.create<T>(loc, args);
1192 }
1193 LLVM_DEBUG(result.dump(); llvm::dbgs() << "\n");
1194 return result;
1195 }
1196
1197 /// Mapping between mathematical intrinsic operations and MLIR operations
1198 /// of some appropriate dialect (math, complex, etc.) or libm calls.
1199 /// TODO: support remaining Fortran math intrinsics.
1200 /// See https://gcc.gnu.org/onlinedocs/gcc-12.1.0/gfortran/\
1201 /// Intrinsic-Procedures.html for a reference.
1202 static constexpr MathOperation mathOperations[] = {
1203 {"abs", "fabsf", genF32F32FuncType, genMathOp<mlir::math::AbsOp>},
1204 {"abs", "fabs", genF64F64FuncType, genMathOp<mlir::math::AbsOp>},
1205 {"abs", "llvm.fabs.f128", genF128F128FuncType,
1206 genMathOp<mlir::math::AbsOp>},
1207 // llvm.trunc behaves the same way as libm's trunc.
1208 {"aint", "llvm.trunc.f32", genF32F32FuncType, genLibCall},
1209 {"aint", "llvm.trunc.f64", genF64F64FuncType, genLibCall},
1210 {"aint", "llvm.trunc.f80", genF80F80FuncType, genLibCall},
1211 // llvm.round behaves the same way as libm's round.
1212 {"anint", "llvm.round.f32", genF32F32FuncType,
1213 genMathOp<mlir::LLVM::RoundOp>},
1214 {"anint", "llvm.round.f64", genF64F64FuncType,
1215 genMathOp<mlir::LLVM::RoundOp>},
1216 {"anint", "llvm.round.f80", genF80F80FuncType,
1217 genMathOp<mlir::LLVM::RoundOp>},
1218 {"atan", "atanf", genF32F32FuncType, genMathOp<mlir::math::AtanOp>},
1219 {"atan", "atan", genF64F64FuncType, genMathOp<mlir::math::AtanOp>},
1220 {"atan2", "atan2f", genF32F32F32FuncType, genMathOp<mlir::math::Atan2Op>},
1221 {"atan2", "atan2", genF64F64F64FuncType, genMathOp<mlir::math::Atan2Op>},
1222 // math::CeilOp returns a real, while Fortran CEILING returns integer.
1223 {"ceil", "ceilf", genF32F32FuncType, genMathOp<mlir::math::CeilOp>},
1224 {"ceil", "ceil", genF64F64FuncType, genMathOp<mlir::math::CeilOp>},
1225 {"cos", "cosf", genF32F32FuncType, genMathOp<mlir::math::CosOp>},
1226 {"cos", "cos", genF64F64FuncType, genMathOp<mlir::math::CosOp>},
1227 {"cosh", "coshf", genF32F32FuncType, genLibCall},
1228 {"cosh", "cosh", genF64F64FuncType, genLibCall},
1229 {"erf", "erff", genF32F32FuncType, genMathOp<mlir::math::ErfOp>},
1230 {"erf", "erf", genF64F64FuncType, genMathOp<mlir::math::ErfOp>},
1231 {"exp", "expf", genF32F32FuncType, genMathOp<mlir::math::ExpOp>},
1232 {"exp", "exp", genF64F64FuncType, genMathOp<mlir::math::ExpOp>},
1233 // math::FloorOp returns a real, while Fortran FLOOR returns integer.
1234 {"floor", "floorf", genF32F32FuncType, genMathOp<mlir::math::FloorOp>},
1235 {"floor", "floor", genF64F64FuncType, genMathOp<mlir::math::FloorOp>},
1236 {"hypot", "hypotf", genF32F32F32FuncType, genLibCall},
1237 {"hypot", "hypot", genF64F64F64FuncType, genLibCall},
1238 {"log", "logf", genF32F32FuncType, genMathOp<mlir::math::LogOp>},
1239 {"log", "log", genF64F64FuncType, genMathOp<mlir::math::LogOp>},
1240 {"log10", "log10f", genF32F32FuncType, genMathOp<mlir::math::Log10Op>},
1241 {"log10", "log10", genF64F64FuncType, genMathOp<mlir::math::Log10Op>},
1242 // llvm.lround behaves the same way as libm's lround.
1243 {"nint", "llvm.lround.i64.f64", genIntF64FuncType<64>, genLibCall},
1244 {"nint", "llvm.lround.i64.f32", genIntF32FuncType<64>, genLibCall},
1245 {"nint", "llvm.lround.i32.f64", genIntF64FuncType<32>, genLibCall},
1246 {"nint", "llvm.lround.i32.f32", genIntF32FuncType<32>, genLibCall},
1247 {"pow", "powf", genF32F32F32FuncType, genMathOp<mlir::math::PowFOp>},
1248 {"pow", "pow", genF64F64F64FuncType, genMathOp<mlir::math::PowFOp>},
1249 // TODO: add PowIOp in math and complex dialects.
1250 {"pow", "llvm.powi.f32.i32", genF32F32IntFuncType<32>, genLibCall},
1251 {"pow", "llvm.powi.f64.i32", genF64F64IntFuncType<32>, genLibCall},
1252 {"sign", "copysignf", genF32F32F32FuncType,
1253 genMathOp<mlir::math::CopySignOp>},
1254 {"sign", "copysign", genF64F64F64FuncType,
1255 genMathOp<mlir::math::CopySignOp>},
1256 {"sign", "copysignl", genF80F80F80FuncType,
1257 genMathOp<mlir::math::CopySignOp>},
1258 {"sign", "llvm.copysign.f128", genF128F128F128FuncType,
1259 genMathOp<mlir::math::CopySignOp>},
1260 {"sin", "sinf", genF32F32FuncType, genMathOp<mlir::math::SinOp>},
1261 {"sin", "sin", genF64F64FuncType, genMathOp<mlir::math::SinOp>},
1262 {"sinh", "sinhf", genF32F32FuncType, genLibCall},
1263 {"sinh", "sinh", genF64F64FuncType, genLibCall},
1264 {"sqrt", "sqrtf", genF32F32FuncType, genMathOp<mlir::math::SqrtOp>},
1265 {"sqrt", "sqrt", genF64F64FuncType, genMathOp<mlir::math::SqrtOp>},
1266 {"tan", "tanf", genF32F32FuncType, genMathOp<mlir::math::TanOp>},
1267 {"tan", "tan", genF64F64FuncType, genMathOp<mlir::math::TanOp>},
1268 {"tanh", "tanhf", genF32F32FuncType, genMathOp<mlir::math::TanhOp>},
1269 {"tanh", "tanh", genF64F64FuncType, genMathOp<mlir::math::TanhOp>},
1270 };
1271
1272 // This helper class computes a "distance" between two function types.
1273 // The distance measures how many narrowing conversions of actual arguments
1274 // and result of "from" must be made in order to use "to" instead of "from".
1275 // For instance, the distance between ACOS(REAL(10)) and ACOS(REAL(8)) is
1276 // greater than the one between ACOS(REAL(10)) and ACOS(REAL(16)). This means
1277 // if no implementation of ACOS(REAL(10)) is available, it is better to use
1278 // ACOS(REAL(16)) with casts rather than ACOS(REAL(8)).
1279 // Note that this is not a symmetric distance and the order of "from" and "to"
1280 // arguments matters, d(foo, bar) may not be the same as d(bar, foo) because it
1281 // may be safe to replace foo by bar, but not the opposite.
1282 class FunctionDistance {
1283 public:
FunctionDistance()1284 FunctionDistance() : infinite{true} {}
1285
FunctionDistance(mlir::FunctionType from,mlir::FunctionType to)1286 FunctionDistance(mlir::FunctionType from, mlir::FunctionType to) {
1287 unsigned nInputs = from.getNumInputs();
1288 unsigned nResults = from.getNumResults();
1289 if (nResults != to.getNumResults() || nInputs != to.getNumInputs()) {
1290 infinite = true;
1291 } else {
1292 for (decltype(nInputs) i = 0; i < nInputs && !infinite; ++i)
1293 addArgumentDistance(from.getInput(i), to.getInput(i));
1294 for (decltype(nResults) i = 0; i < nResults && !infinite; ++i)
1295 addResultDistance(to.getResult(i), from.getResult(i));
1296 }
1297 }
1298
1299 /// Beware both d1.isSmallerThan(d2) *and* d2.isSmallerThan(d1) may be
1300 /// false if both d1 and d2 are infinite. This implies that
1301 /// d1.isSmallerThan(d2) is not equivalent to !d2.isSmallerThan(d1)
isSmallerThan(const FunctionDistance & d) const1302 bool isSmallerThan(const FunctionDistance &d) const {
1303 return !infinite &&
1304 (d.infinite || std::lexicographical_compare(
1305 conversions.begin(), conversions.end(),
1306 d.conversions.begin(), d.conversions.end()));
1307 }
1308
isLosingPrecision() const1309 bool isLosingPrecision() const {
1310 return conversions[narrowingArg] != 0 || conversions[extendingResult] != 0;
1311 }
1312
isInfinite() const1313 bool isInfinite() const { return infinite; }
1314
1315 private:
1316 enum class Conversion { Forbidden, None, Narrow, Extend };
1317
addArgumentDistance(mlir::Type from,mlir::Type to)1318 void addArgumentDistance(mlir::Type from, mlir::Type to) {
1319 switch (conversionBetweenTypes(from, to)) {
1320 case Conversion::Forbidden:
1321 infinite = true;
1322 break;
1323 case Conversion::None:
1324 break;
1325 case Conversion::Narrow:
1326 conversions[narrowingArg]++;
1327 break;
1328 case Conversion::Extend:
1329 conversions[nonNarrowingArg]++;
1330 break;
1331 }
1332 }
1333
addResultDistance(mlir::Type from,mlir::Type to)1334 void addResultDistance(mlir::Type from, mlir::Type to) {
1335 switch (conversionBetweenTypes(from, to)) {
1336 case Conversion::Forbidden:
1337 infinite = true;
1338 break;
1339 case Conversion::None:
1340 break;
1341 case Conversion::Narrow:
1342 conversions[nonExtendingResult]++;
1343 break;
1344 case Conversion::Extend:
1345 conversions[extendingResult]++;
1346 break;
1347 }
1348 }
1349
1350 // Floating point can be mlir::FloatType or fir::real
getFloatingPointWidth(mlir::Type t)1351 static unsigned getFloatingPointWidth(mlir::Type t) {
1352 if (auto f{t.dyn_cast<mlir::FloatType>()})
1353 return f.getWidth();
1354 // FIXME: Get width another way for fir.real/complex
1355 // - use fir/KindMapping.h and llvm::Type
1356 // - or use evaluate/type.h
1357 if (auto r{t.dyn_cast<fir::RealType>()})
1358 return r.getFKind() * 4;
1359 if (auto cplx{t.dyn_cast<fir::ComplexType>()})
1360 return cplx.getFKind() * 4;
1361 llvm_unreachable("not a floating-point type");
1362 }
1363
conversionBetweenTypes(mlir::Type from,mlir::Type to)1364 static Conversion conversionBetweenTypes(mlir::Type from, mlir::Type to) {
1365 if (from == to)
1366 return Conversion::None;
1367
1368 if (auto fromIntTy{from.dyn_cast<mlir::IntegerType>()}) {
1369 if (auto toIntTy{to.dyn_cast<mlir::IntegerType>()}) {
1370 return fromIntTy.getWidth() > toIntTy.getWidth() ? Conversion::Narrow
1371 : Conversion::Extend;
1372 }
1373 }
1374
1375 if (fir::isa_real(from) && fir::isa_real(to)) {
1376 return getFloatingPointWidth(from) > getFloatingPointWidth(to)
1377 ? Conversion::Narrow
1378 : Conversion::Extend;
1379 }
1380
1381 if (auto fromCplxTy{from.dyn_cast<fir::ComplexType>()}) {
1382 if (auto toCplxTy{to.dyn_cast<fir::ComplexType>()}) {
1383 return getFloatingPointWidth(fromCplxTy) >
1384 getFloatingPointWidth(toCplxTy)
1385 ? Conversion::Narrow
1386 : Conversion::Extend;
1387 }
1388 }
1389 // Notes:
1390 // - No conversion between character types, specialization of runtime
1391 // functions should be made instead.
1392 // - It is not clear there is a use case for automatic conversions
1393 // around Logical and it may damage hidden information in the physical
1394 // storage so do not do it.
1395 return Conversion::Forbidden;
1396 }
1397
1398 // Below are indexes to access data in conversions.
1399 // The order in data does matter for lexicographical_compare
1400 enum {
1401 narrowingArg = 0, // usually bad
1402 extendingResult, // usually bad
1403 nonExtendingResult, // usually ok
1404 nonNarrowingArg, // usually ok
1405 dataSize
1406 };
1407
1408 std::array<int, dataSize> conversions = {};
1409 bool infinite = false; // When forbidden conversion or wrong argument number
1410 };
1411
1412 /// Build mlir::func::FuncOp from runtime symbol description and add
1413 /// fir.runtime attribute.
getFuncOp(mlir::Location loc,fir::FirOpBuilder & builder,const RuntimeFunction & runtime)1414 static mlir::func::FuncOp getFuncOp(mlir::Location loc,
1415 fir::FirOpBuilder &builder,
1416 const RuntimeFunction &runtime) {
1417 mlir::func::FuncOp function = builder.addNamedFunction(
1418 loc, runtime.symbol, runtime.typeGenerator(builder.getContext()));
1419 function->setAttr("fir.runtime", builder.getUnitAttr());
1420 return function;
1421 }
1422
1423 /// Select runtime function that has the smallest distance to the intrinsic
1424 /// function type and that will not imply narrowing arguments or extending the
1425 /// result.
1426 /// If nothing is found, the mlir::func::FuncOp will contain a nullptr.
searchFunctionInLibrary(mlir::Location loc,fir::FirOpBuilder & builder,const Fortran::common::StaticMultimapView<RuntimeFunction> & lib,llvm::StringRef name,mlir::FunctionType funcType,const RuntimeFunction ** bestNearMatch,FunctionDistance & bestMatchDistance)1427 static mlir::func::FuncOp searchFunctionInLibrary(
1428 mlir::Location loc, fir::FirOpBuilder &builder,
1429 const Fortran::common::StaticMultimapView<RuntimeFunction> &lib,
1430 llvm::StringRef name, mlir::FunctionType funcType,
1431 const RuntimeFunction **bestNearMatch,
1432 FunctionDistance &bestMatchDistance) {
1433 std::pair<const RuntimeFunction *, const RuntimeFunction *> range =
1434 lib.equal_range(name);
1435 for (auto iter = range.first; iter != range.second && iter; ++iter) {
1436 const RuntimeFunction &impl = *iter;
1437 mlir::FunctionType implType = impl.typeGenerator(builder.getContext());
1438 if (funcType == implType)
1439 return getFuncOp(loc, builder, impl); // exact match
1440
1441 FunctionDistance distance(funcType, implType);
1442 if (distance.isSmallerThan(bestMatchDistance)) {
1443 *bestNearMatch = &impl;
1444 bestMatchDistance = std::move(distance);
1445 }
1446 }
1447 return {};
1448 }
1449
1450 using RtMap = Fortran::common::StaticMultimapView<MathOperation>;
1451 static constexpr RtMap mathOps(mathOperations);
1452 static_assert(mathOps.Verify() && "map must be sorted");
1453
1454 /// Look for a MathOperation entry specifying how to lower a mathematical
1455 /// operation defined by \p name with its result' and operands' types
1456 /// specified in the form of a FunctionType \p funcType.
1457 /// If exact match for the given types is found, then the function
1458 /// returns a pointer to the corresponding MathOperation.
1459 /// Otherwise, the function returns nullptr.
1460 /// If there is a MathOperation that can be used with additional
1461 /// type casts for the operands or/and result (non-exact match),
1462 /// then it is returned via \p bestNearMatch argument, and
1463 /// \p bestMatchDistance specifies the FunctionDistance between
1464 /// the requested operation and the non-exact match.
1465 static const MathOperation *
searchMathOperation(fir::FirOpBuilder & builder,llvm::StringRef name,mlir::FunctionType funcType,const MathOperation ** bestNearMatch,FunctionDistance & bestMatchDistance)1466 searchMathOperation(fir::FirOpBuilder &builder, llvm::StringRef name,
1467 mlir::FunctionType funcType,
1468 const MathOperation **bestNearMatch,
1469 FunctionDistance &bestMatchDistance) {
1470 auto range = mathOps.equal_range(name);
1471 for (auto iter = range.first; iter != range.second && iter; ++iter) {
1472 const auto &impl = *iter;
1473 auto implType = impl.typeGenerator(builder.getContext());
1474 if (funcType == implType)
1475 return &impl; // exact match
1476
1477 FunctionDistance distance(funcType, implType);
1478 if (distance.isSmallerThan(bestMatchDistance)) {
1479 *bestNearMatch = &impl;
1480 bestMatchDistance = std::move(distance);
1481 }
1482 }
1483 return nullptr;
1484 }
1485
1486 /// Implementation of the operation defined by \p name with type
1487 /// \p funcType is not precise, and the actual available implementation
1488 /// is \p distance away from the requested. If using the available
1489 /// implementation results in a precision loss, emit an error message
1490 /// with the given code location \p loc.
checkPrecisionLoss(llvm::StringRef name,mlir::FunctionType funcType,const FunctionDistance & distance,mlir::Location loc)1491 static void checkPrecisionLoss(llvm::StringRef name,
1492 mlir::FunctionType funcType,
1493 const FunctionDistance &distance,
1494 mlir::Location loc) {
1495 if (!distance.isLosingPrecision())
1496 return;
1497
1498 // Using this runtime version requires narrowing the arguments
1499 // or extending the result. It is not numerically safe. There
1500 // is currently no quad math library that was described in
1501 // lowering and could be used here. Emit an error and continue
1502 // generating the code with the narrowing cast so that the user
1503 // can get a complete list of the problematic intrinsic calls.
1504 std::string message("not yet implemented: no math runtime available for '");
1505 llvm::raw_string_ostream sstream(message);
1506 if (name == "pow") {
1507 assert(funcType.getNumInputs() == 2 && "power operator has two arguments");
1508 sstream << funcType.getInput(0) << " ** " << funcType.getInput(1);
1509 } else {
1510 sstream << name << "(";
1511 if (funcType.getNumInputs() > 0)
1512 sstream << funcType.getInput(0);
1513 for (mlir::Type argType : funcType.getInputs().drop_front())
1514 sstream << ", " << argType;
1515 sstream << ")";
1516 }
1517 sstream << "'";
1518 mlir::emitError(loc, message);
1519 }
1520
1521 /// Search runtime for the best runtime function given an intrinsic name
1522 /// and interface. The interface may not be a perfect match in which case
1523 /// the caller is responsible to insert argument and return value conversions.
1524 /// If nothing is found, the mlir::func::FuncOp will contain a nullptr.
getRuntimeFunction(mlir::Location loc,fir::FirOpBuilder & builder,llvm::StringRef name,mlir::FunctionType funcType)1525 static mlir::func::FuncOp getRuntimeFunction(mlir::Location loc,
1526 fir::FirOpBuilder &builder,
1527 llvm::StringRef name,
1528 mlir::FunctionType funcType) {
1529 const RuntimeFunction *bestNearMatch = nullptr;
1530 FunctionDistance bestMatchDistance;
1531 mlir::func::FuncOp match;
1532 using RtMap = Fortran::common::StaticMultimapView<RuntimeFunction>;
1533 static constexpr RtMap pgmathF(pgmathFast);
1534 static_assert(pgmathF.Verify() && "map must be sorted");
1535 static constexpr RtMap pgmathR(pgmathRelaxed);
1536 static_assert(pgmathR.Verify() && "map must be sorted");
1537 static constexpr RtMap pgmathP(pgmathPrecise);
1538 static_assert(pgmathP.Verify() && "map must be sorted");
1539
1540 if (mathRuntimeVersion == fastVersion)
1541 match = searchFunctionInLibrary(loc, builder, pgmathF, name, funcType,
1542 &bestNearMatch, bestMatchDistance);
1543 else if (mathRuntimeVersion == relaxedVersion)
1544 match = searchFunctionInLibrary(loc, builder, pgmathR, name, funcType,
1545 &bestNearMatch, bestMatchDistance);
1546 else if (mathRuntimeVersion == preciseVersion)
1547 match = searchFunctionInLibrary(loc, builder, pgmathP, name, funcType,
1548 &bestNearMatch, bestMatchDistance);
1549 else
1550 llvm_unreachable("unsupported mathRuntimeVersion");
1551
1552 return match;
1553 }
1554
1555 /// Helpers to get function type from arguments and result type.
getFunctionType(llvm::Optional<mlir::Type> resultType,llvm::ArrayRef<mlir::Value> arguments,fir::FirOpBuilder & builder)1556 static mlir::FunctionType getFunctionType(llvm::Optional<mlir::Type> resultType,
1557 llvm::ArrayRef<mlir::Value> arguments,
1558 fir::FirOpBuilder &builder) {
1559 llvm::SmallVector<mlir::Type> argTypes;
1560 for (mlir::Value arg : arguments)
1561 argTypes.push_back(arg.getType());
1562 llvm::SmallVector<mlir::Type> resTypes;
1563 if (resultType)
1564 resTypes.push_back(*resultType);
1565 return mlir::FunctionType::get(builder.getModule().getContext(), argTypes,
1566 resTypes);
1567 }
1568
1569 /// fir::ExtendedValue to mlir::Value translation layer
1570
toExtendedValue(mlir::Value val,fir::FirOpBuilder & builder,mlir::Location loc)1571 fir::ExtendedValue toExtendedValue(mlir::Value val, fir::FirOpBuilder &builder,
1572 mlir::Location loc) {
1573 assert(val && "optional unhandled here");
1574 mlir::Type type = val.getType();
1575 mlir::Value base = val;
1576 mlir::IndexType indexType = builder.getIndexType();
1577 llvm::SmallVector<mlir::Value> extents;
1578
1579 fir::factory::CharacterExprHelper charHelper{builder, loc};
1580 // FIXME: we may want to allow non character scalar here.
1581 if (charHelper.isCharacterScalar(type))
1582 return charHelper.toExtendedValue(val);
1583
1584 if (auto refType = type.dyn_cast<fir::ReferenceType>())
1585 type = refType.getEleTy();
1586
1587 if (auto arrayType = type.dyn_cast<fir::SequenceType>()) {
1588 type = arrayType.getEleTy();
1589 for (fir::SequenceType::Extent extent : arrayType.getShape()) {
1590 if (extent == fir::SequenceType::getUnknownExtent())
1591 break;
1592 extents.emplace_back(
1593 builder.createIntegerConstant(loc, indexType, extent));
1594 }
1595 // Last extent might be missing in case of assumed-size. If more extents
1596 // could not be deduced from type, that's an error (a fir.box should
1597 // have been used in the interface).
1598 if (extents.size() + 1 < arrayType.getShape().size())
1599 mlir::emitError(loc, "cannot retrieve array extents from type");
1600 } else if (type.isa<fir::BoxType>() || type.isa<fir::RecordType>()) {
1601 fir::emitFatalError(loc, "not yet implemented: descriptor or derived type");
1602 }
1603
1604 if (!extents.empty())
1605 return fir::ArrayBoxValue{base, extents};
1606 return base;
1607 }
1608
toValue(const fir::ExtendedValue & val,fir::FirOpBuilder & builder,mlir::Location loc)1609 mlir::Value toValue(const fir::ExtendedValue &val, fir::FirOpBuilder &builder,
1610 mlir::Location loc) {
1611 if (const fir::CharBoxValue *charBox = val.getCharBox()) {
1612 mlir::Value buffer = charBox->getBuffer();
1613 auto buffTy = buffer.getType();
1614 if (buffTy.isa<mlir::FunctionType>())
1615 fir::emitFatalError(
1616 loc, "A character's buffer type cannot be a function type.");
1617 if (buffTy.isa<fir::BoxCharType>())
1618 return buffer;
1619 return fir::factory::CharacterExprHelper{builder, loc}.createEmboxChar(
1620 buffer, charBox->getLen());
1621 }
1622
1623 // FIXME: need to access other ExtendedValue variants and handle them
1624 // properly.
1625 return fir::getBase(val);
1626 }
1627
1628 //===----------------------------------------------------------------------===//
1629 // IntrinsicLibrary
1630 //===----------------------------------------------------------------------===//
1631
isIntrinsicModuleProcedure(llvm::StringRef name)1632 static bool isIntrinsicModuleProcedure(llvm::StringRef name) {
1633 return name.startswith("c_") || name.startswith("compiler_") ||
1634 name.startswith("ieee_");
1635 }
1636
1637 /// Return the generic name of an intrinsic module procedure specific name.
1638 /// Remove any "__builtin_" prefix, and any specific suffix of the form
1639 /// {_[ail]?[0-9]+}*, such as _1 or _a4.
genericName(llvm::StringRef specificName)1640 llvm::StringRef genericName(llvm::StringRef specificName) {
1641 const std::string builtin = "__builtin_";
1642 llvm::StringRef name = specificName.startswith(builtin)
1643 ? specificName.drop_front(builtin.size())
1644 : specificName;
1645 size_t size = name.size();
1646 if (isIntrinsicModuleProcedure(name))
1647 while (isdigit(name[size - 1]))
1648 while (name[--size] != '_')
1649 ;
1650 return name.drop_back(name.size() - size);
1651 }
1652
1653 /// Generate a TODO error message for an as yet unimplemented intrinsic.
crashOnMissingIntrinsic(mlir::Location loc,llvm::StringRef name)1654 void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) {
1655 if (isIntrinsicModuleProcedure(name))
1656 TODO(loc, "intrinsic module procedure: " + llvm::Twine(name));
1657 else
1658 TODO(loc, "intrinsic: " + llvm::Twine(name));
1659 }
1660
1661 template <typename GeneratorType>
genElementalCall(GeneratorType generator,llvm::StringRef name,mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args,bool outline)1662 fir::ExtendedValue IntrinsicLibrary::genElementalCall(
1663 GeneratorType generator, llvm::StringRef name, mlir::Type resultType,
1664 llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
1665 llvm::SmallVector<mlir::Value> scalarArgs;
1666 for (const fir::ExtendedValue &arg : args)
1667 if (arg.getUnboxed() || arg.getCharBox())
1668 scalarArgs.emplace_back(fir::getBase(arg));
1669 else
1670 fir::emitFatalError(loc, "nonscalar intrinsic argument");
1671 if (outline)
1672 return outlineInWrapper(generator, name, resultType, scalarArgs);
1673 return invokeGenerator(generator, resultType, scalarArgs);
1674 }
1675
1676 template <>
1677 fir::ExtendedValue
genElementalCall(ExtendedGenerator generator,llvm::StringRef name,mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args,bool outline)1678 IntrinsicLibrary::genElementalCall<IntrinsicLibrary::ExtendedGenerator>(
1679 ExtendedGenerator generator, llvm::StringRef name, mlir::Type resultType,
1680 llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
1681 for (const fir::ExtendedValue &arg : args)
1682 if (!arg.getUnboxed() && !arg.getCharBox())
1683 fir::emitFatalError(loc, "nonscalar intrinsic argument");
1684 if (outline)
1685 return outlineInExtendedWrapper(generator, name, resultType, args);
1686 return std::invoke(generator, *this, resultType, args);
1687 }
1688
1689 template <>
1690 fir::ExtendedValue
genElementalCall(SubroutineGenerator generator,llvm::StringRef name,mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args,bool outline)1691 IntrinsicLibrary::genElementalCall<IntrinsicLibrary::SubroutineGenerator>(
1692 SubroutineGenerator generator, llvm::StringRef name, mlir::Type resultType,
1693 llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
1694 for (const fir::ExtendedValue &arg : args)
1695 if (!arg.getUnboxed() && !arg.getCharBox())
1696 // fir::emitFatalError(loc, "nonscalar intrinsic argument");
1697 crashOnMissingIntrinsic(loc, name);
1698 if (outline)
1699 return outlineInExtendedWrapper(generator, name, resultType, args);
1700 std::invoke(generator, *this, args);
1701 return mlir::Value();
1702 }
1703
1704 static fir::ExtendedValue
invokeHandler(IntrinsicLibrary::ElementalGenerator generator,const IntrinsicHandler & handler,llvm::Optional<mlir::Type> resultType,llvm::ArrayRef<fir::ExtendedValue> args,bool outline,IntrinsicLibrary & lib)1705 invokeHandler(IntrinsicLibrary::ElementalGenerator generator,
1706 const IntrinsicHandler &handler,
1707 llvm::Optional<mlir::Type> resultType,
1708 llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
1709 IntrinsicLibrary &lib) {
1710 assert(resultType && "expect elemental intrinsic to be functions");
1711 return lib.genElementalCall(generator, handler.name, *resultType, args,
1712 outline);
1713 }
1714
1715 static fir::ExtendedValue
invokeHandler(IntrinsicLibrary::ExtendedGenerator generator,const IntrinsicHandler & handler,llvm::Optional<mlir::Type> resultType,llvm::ArrayRef<fir::ExtendedValue> args,bool outline,IntrinsicLibrary & lib)1716 invokeHandler(IntrinsicLibrary::ExtendedGenerator generator,
1717 const IntrinsicHandler &handler,
1718 llvm::Optional<mlir::Type> resultType,
1719 llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
1720 IntrinsicLibrary &lib) {
1721 assert(resultType && "expect intrinsic function");
1722 if (handler.isElemental)
1723 return lib.genElementalCall(generator, handler.name, *resultType, args,
1724 outline);
1725 if (outline)
1726 return lib.outlineInExtendedWrapper(generator, handler.name, *resultType,
1727 args);
1728 return std::invoke(generator, lib, *resultType, args);
1729 }
1730
1731 static fir::ExtendedValue
invokeHandler(IntrinsicLibrary::SubroutineGenerator generator,const IntrinsicHandler & handler,llvm::Optional<mlir::Type> resultType,llvm::ArrayRef<fir::ExtendedValue> args,bool outline,IntrinsicLibrary & lib)1732 invokeHandler(IntrinsicLibrary::SubroutineGenerator generator,
1733 const IntrinsicHandler &handler,
1734 llvm::Optional<mlir::Type> resultType,
1735 llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
1736 IntrinsicLibrary &lib) {
1737 if (handler.isElemental)
1738 return lib.genElementalCall(generator, handler.name, mlir::Type{}, args,
1739 outline);
1740 if (outline)
1741 return lib.outlineInExtendedWrapper(generator, handler.name, resultType,
1742 args);
1743 std::invoke(generator, lib, args);
1744 return mlir::Value{};
1745 }
1746
1747 fir::ExtendedValue
genIntrinsicCall(llvm::StringRef specificName,llvm::Optional<mlir::Type> resultType,llvm::ArrayRef<fir::ExtendedValue> args)1748 IntrinsicLibrary::genIntrinsicCall(llvm::StringRef specificName,
1749 llvm::Optional<mlir::Type> resultType,
1750 llvm::ArrayRef<fir::ExtendedValue> args) {
1751 llvm::StringRef name = genericName(specificName);
1752 if (const IntrinsicHandler *handler = findIntrinsicHandler(name)) {
1753 bool outline = handler->outline || outlineAllIntrinsics;
1754 return std::visit(
1755 [&](auto &generator) -> fir::ExtendedValue {
1756 return invokeHandler(generator, *handler, resultType, args, outline,
1757 *this);
1758 },
1759 handler->generator);
1760 }
1761
1762 if (!resultType)
1763 // Subroutine should have a handler, they are likely missing for now.
1764 crashOnMissingIntrinsic(loc, name);
1765
1766 // Try the runtime if no special handler was defined for the
1767 // intrinsic being called. Maths runtime only has numerical elemental.
1768 // No optional arguments are expected at this point, the code will
1769 // crash if it gets absent optional.
1770
1771 // FIXME: using toValue to get the type won't work with array arguments.
1772 llvm::SmallVector<mlir::Value> mlirArgs;
1773 for (const fir::ExtendedValue &extendedVal : args) {
1774 mlir::Value val = toValue(extendedVal, builder, loc);
1775 if (!val)
1776 // If an absent optional gets there, most likely its handler has just
1777 // not yet been defined.
1778 crashOnMissingIntrinsic(loc, name);
1779 mlirArgs.emplace_back(val);
1780 }
1781 mlir::FunctionType soughtFuncType =
1782 getFunctionType(*resultType, mlirArgs, builder);
1783
1784 IntrinsicLibrary::RuntimeCallGenerator runtimeCallGenerator =
1785 getRuntimeCallGenerator(name, soughtFuncType);
1786 return genElementalCall(runtimeCallGenerator, name, *resultType, args,
1787 /*outline=*/outlineAllIntrinsics);
1788 }
1789
1790 mlir::Value
invokeGenerator(ElementalGenerator generator,mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)1791 IntrinsicLibrary::invokeGenerator(ElementalGenerator generator,
1792 mlir::Type resultType,
1793 llvm::ArrayRef<mlir::Value> args) {
1794 return std::invoke(generator, *this, resultType, args);
1795 }
1796
1797 mlir::Value
invokeGenerator(RuntimeCallGenerator generator,mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)1798 IntrinsicLibrary::invokeGenerator(RuntimeCallGenerator generator,
1799 mlir::Type resultType,
1800 llvm::ArrayRef<mlir::Value> args) {
1801 return generator(builder, loc, args);
1802 }
1803
1804 mlir::Value
invokeGenerator(ExtendedGenerator generator,mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)1805 IntrinsicLibrary::invokeGenerator(ExtendedGenerator generator,
1806 mlir::Type resultType,
1807 llvm::ArrayRef<mlir::Value> args) {
1808 llvm::SmallVector<fir::ExtendedValue> extendedArgs;
1809 for (mlir::Value arg : args)
1810 extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
1811 auto extendedResult = std::invoke(generator, *this, resultType, extendedArgs);
1812 return toValue(extendedResult, builder, loc);
1813 }
1814
1815 mlir::Value
invokeGenerator(SubroutineGenerator generator,llvm::ArrayRef<mlir::Value> args)1816 IntrinsicLibrary::invokeGenerator(SubroutineGenerator generator,
1817 llvm::ArrayRef<mlir::Value> args) {
1818 llvm::SmallVector<fir::ExtendedValue> extendedArgs;
1819 for (mlir::Value arg : args)
1820 extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
1821 std::invoke(generator, *this, extendedArgs);
1822 return {};
1823 }
1824
1825 template <typename GeneratorType>
getWrapper(GeneratorType generator,llvm::StringRef name,mlir::FunctionType funcType,bool loadRefArguments)1826 mlir::func::FuncOp IntrinsicLibrary::getWrapper(GeneratorType generator,
1827 llvm::StringRef name,
1828 mlir::FunctionType funcType,
1829 bool loadRefArguments) {
1830 std::string wrapperName = fir::mangleIntrinsicProcedure(name, funcType);
1831 mlir::func::FuncOp function = builder.getNamedFunction(wrapperName);
1832 if (!function) {
1833 // First time this wrapper is needed, build it.
1834 function = builder.createFunction(loc, wrapperName, funcType);
1835 function->setAttr("fir.intrinsic", builder.getUnitAttr());
1836 auto internalLinkage = mlir::LLVM::linkage::Linkage::Internal;
1837 auto linkage =
1838 mlir::LLVM::LinkageAttr::get(builder.getContext(), internalLinkage);
1839 function->setAttr("llvm.linkage", linkage);
1840 function.addEntryBlock();
1841
1842 // Create local context to emit code into the newly created function
1843 // This new function is not linked to a source file location, only
1844 // its calls will be.
1845 auto localBuilder =
1846 std::make_unique<fir::FirOpBuilder>(function, builder.getKindMap());
1847 localBuilder->setInsertionPointToStart(&function.front());
1848 // Location of code inside wrapper of the wrapper is independent from
1849 // the location of the intrinsic call.
1850 mlir::Location localLoc = localBuilder->getUnknownLoc();
1851 llvm::SmallVector<mlir::Value> localArguments;
1852 for (mlir::BlockArgument bArg : function.front().getArguments()) {
1853 auto refType = bArg.getType().dyn_cast<fir::ReferenceType>();
1854 if (loadRefArguments && refType) {
1855 auto loaded = localBuilder->create<fir::LoadOp>(localLoc, bArg);
1856 localArguments.push_back(loaded);
1857 } else {
1858 localArguments.push_back(bArg);
1859 }
1860 }
1861
1862 IntrinsicLibrary localLib{*localBuilder, localLoc};
1863
1864 if constexpr (std::is_same_v<GeneratorType, SubroutineGenerator>) {
1865 localLib.invokeGenerator(generator, localArguments);
1866 localBuilder->create<mlir::func::ReturnOp>(localLoc);
1867 } else {
1868 assert(funcType.getNumResults() == 1 &&
1869 "expect one result for intrinsic function wrapper type");
1870 mlir::Type resultType = funcType.getResult(0);
1871 auto result =
1872 localLib.invokeGenerator(generator, resultType, localArguments);
1873 localBuilder->create<mlir::func::ReturnOp>(localLoc, result);
1874 }
1875 } else {
1876 // Wrapper was already built, ensure it has the sought type
1877 assert(function.getFunctionType() == funcType &&
1878 "conflict between intrinsic wrapper types");
1879 }
1880 return function;
1881 }
1882
1883 /// Helpers to detect absent optional (not yet supported in outlining).
hasAbsentOptional(llvm::ArrayRef<mlir::Value> args)1884 bool static hasAbsentOptional(llvm::ArrayRef<mlir::Value> args) {
1885 for (const mlir::Value &arg : args)
1886 if (!arg)
1887 return true;
1888 return false;
1889 }
hasAbsentOptional(llvm::ArrayRef<fir::ExtendedValue> args)1890 bool static hasAbsentOptional(llvm::ArrayRef<fir::ExtendedValue> args) {
1891 for (const fir::ExtendedValue &arg : args)
1892 if (!fir::getBase(arg))
1893 return true;
1894 return false;
1895 }
1896
1897 template <typename GeneratorType>
1898 mlir::Value
outlineInWrapper(GeneratorType generator,llvm::StringRef name,mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)1899 IntrinsicLibrary::outlineInWrapper(GeneratorType generator,
1900 llvm::StringRef name, mlir::Type resultType,
1901 llvm::ArrayRef<mlir::Value> args) {
1902 if (hasAbsentOptional(args)) {
1903 // TODO: absent optional in outlining is an issue: we cannot just ignore
1904 // them. Needs a better interface here. The issue is that we cannot easily
1905 // tell that a value is optional or not here if it is presents. And if it is
1906 // absent, we cannot tell what it type should be.
1907 TODO(loc, "cannot outline call to intrinsic " + llvm::Twine(name) +
1908 " with absent optional argument");
1909 }
1910
1911 mlir::FunctionType funcType = getFunctionType(resultType, args, builder);
1912 mlir::func::FuncOp wrapper = getWrapper(generator, name, funcType);
1913 return builder.create<fir::CallOp>(loc, wrapper, args).getResult(0);
1914 }
1915
1916 template <typename GeneratorType>
outlineInExtendedWrapper(GeneratorType generator,llvm::StringRef name,llvm::Optional<mlir::Type> resultType,llvm::ArrayRef<fir::ExtendedValue> args)1917 fir::ExtendedValue IntrinsicLibrary::outlineInExtendedWrapper(
1918 GeneratorType generator, llvm::StringRef name,
1919 llvm::Optional<mlir::Type> resultType,
1920 llvm::ArrayRef<fir::ExtendedValue> args) {
1921 if (hasAbsentOptional(args))
1922 TODO(loc, "cannot outline call to intrinsic " + llvm::Twine(name) +
1923 " with absent optional argument");
1924 llvm::SmallVector<mlir::Value> mlirArgs;
1925 for (const auto &extendedVal : args)
1926 mlirArgs.emplace_back(toValue(extendedVal, builder, loc));
1927 mlir::FunctionType funcType = getFunctionType(resultType, mlirArgs, builder);
1928 mlir::func::FuncOp wrapper = getWrapper(generator, name, funcType);
1929 auto call = builder.create<fir::CallOp>(loc, wrapper, mlirArgs);
1930 if (resultType)
1931 return toExtendedValue(call.getResult(0), builder, loc);
1932 // Subroutine calls
1933 return mlir::Value{};
1934 }
1935
1936 IntrinsicLibrary::RuntimeCallGenerator
getRuntimeCallGenerator(llvm::StringRef name,mlir::FunctionType soughtFuncType)1937 IntrinsicLibrary::getRuntimeCallGenerator(llvm::StringRef name,
1938 mlir::FunctionType soughtFuncType) {
1939 mlir::func::FuncOp funcOp;
1940 mlir::FunctionType actualFuncType;
1941 const MathOperation *mathOp = nullptr;
1942
1943 // Look for a dedicated math operation generator, which
1944 // normally produces a single MLIR operation implementing
1945 // the math operation.
1946 // If not found fall back to a runtime function lookup.
1947 const MathOperation *bestNearMatch = nullptr;
1948 FunctionDistance bestMatchDistance;
1949 mathOp = searchMathOperation(builder, name, soughtFuncType, &bestNearMatch,
1950 bestMatchDistance);
1951 if (!mathOp && bestNearMatch) {
1952 // Use the best near match, optionally issuing an error,
1953 // if types conversions cause precision loss.
1954 bool useBestNearMatch = true;
1955 // TODO: temporary workaround to avoid using math::PowFOp
1956 // for pow(fp, i64) case and fall back to pgmath runtime.
1957 // When proper Math dialect operations are available
1958 // and added into mathOperations table, this can be removed.
1959 // This is WIP in D129812.
1960 if (name == "pow" && soughtFuncType.getInput(0).isa<mlir::FloatType>())
1961 if (auto exponentTy =
1962 soughtFuncType.getInput(1).dyn_cast<mlir::IntegerType>())
1963 useBestNearMatch = exponentTy.getWidth() != 64;
1964
1965 if (useBestNearMatch) {
1966 checkPrecisionLoss(name, soughtFuncType, bestMatchDistance, loc);
1967 mathOp = bestNearMatch;
1968 }
1969 }
1970 if (mathOp)
1971 actualFuncType = mathOp->typeGenerator(builder.getContext());
1972
1973 if (!mathOp)
1974 if ((funcOp = getRuntimeFunction(loc, builder, name, soughtFuncType)))
1975 actualFuncType = funcOp.getFunctionType();
1976
1977 if (!mathOp && !funcOp) {
1978 std::string nameAndType;
1979 llvm::raw_string_ostream sstream(nameAndType);
1980 sstream << name << "\nrequested type: " << soughtFuncType;
1981 crashOnMissingIntrinsic(loc, nameAndType);
1982 }
1983
1984 assert(actualFuncType.getNumResults() == soughtFuncType.getNumResults() &&
1985 actualFuncType.getNumInputs() == soughtFuncType.getNumInputs() &&
1986 actualFuncType.getNumResults() == 1 && "Bad intrinsic match");
1987
1988 return [funcOp, actualFuncType, mathOp,
1989 soughtFuncType](fir::FirOpBuilder &builder, mlir::Location loc,
1990 llvm::ArrayRef<mlir::Value> args) {
1991 llvm::SmallVector<mlir::Value> convertedArguments;
1992 for (auto [fst, snd] : llvm::zip(actualFuncType.getInputs(), args))
1993 convertedArguments.push_back(builder.createConvert(loc, fst, snd));
1994 mlir::Value result;
1995 // Use math operation generator, if available.
1996 if (mathOp)
1997 result = mathOp->funcGenerator(builder, loc, mathOp->runtimeFunc,
1998 actualFuncType, convertedArguments);
1999 else
2000 result = builder.create<fir::CallOp>(loc, funcOp, convertedArguments)
2001 .getResult(0);
2002 mlir::Type soughtType = soughtFuncType.getResult(0);
2003 return builder.createConvert(loc, soughtType, result);
2004 };
2005 }
2006
getUnrestrictedIntrinsicSymbolRefAttr(llvm::StringRef name,mlir::FunctionType signature)2007 mlir::SymbolRefAttr IntrinsicLibrary::getUnrestrictedIntrinsicSymbolRefAttr(
2008 llvm::StringRef name, mlir::FunctionType signature) {
2009 // Unrestricted intrinsics signature follows implicit rules: argument
2010 // are passed by references. But the runtime versions expect values.
2011 // So instead of duplicating the runtime, just have the wrappers loading
2012 // this before calling the code generators.
2013 bool loadRefArguments = true;
2014 mlir::func::FuncOp funcOp;
2015 if (const IntrinsicHandler *handler = findIntrinsicHandler(name))
2016 funcOp = std::visit(
2017 [&](auto generator) {
2018 return getWrapper(generator, name, signature, loadRefArguments);
2019 },
2020 handler->generator);
2021
2022 if (!funcOp) {
2023 llvm::SmallVector<mlir::Type> argTypes;
2024 for (mlir::Type type : signature.getInputs()) {
2025 if (auto refType = type.dyn_cast<fir::ReferenceType>())
2026 argTypes.push_back(refType.getEleTy());
2027 else
2028 argTypes.push_back(type);
2029 }
2030 mlir::FunctionType soughtFuncType =
2031 builder.getFunctionType(argTypes, signature.getResults());
2032 IntrinsicLibrary::RuntimeCallGenerator rtCallGenerator =
2033 getRuntimeCallGenerator(name, soughtFuncType);
2034 funcOp = getWrapper(rtCallGenerator, name, signature, loadRefArguments);
2035 }
2036
2037 return mlir::SymbolRefAttr::get(funcOp);
2038 }
2039
addCleanUpForTemp(mlir::Location loc,mlir::Value temp)2040 void IntrinsicLibrary::addCleanUpForTemp(mlir::Location loc, mlir::Value temp) {
2041 assert(stmtCtx);
2042 fir::FirOpBuilder *bldr = &builder;
2043 stmtCtx->attachCleanup([=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
2044 }
2045
2046 fir::ExtendedValue
readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,mlir::Type resultType,llvm::StringRef intrinsicName)2047 IntrinsicLibrary::readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,
2048 mlir::Type resultType,
2049 llvm::StringRef intrinsicName) {
2050 fir::ExtendedValue res =
2051 fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
2052 return res.match(
2053 [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
2054 // Add cleanup code
2055 addCleanUpForTemp(loc, box.getAddr());
2056 return box;
2057 },
2058 [&](const fir::BoxValue &box) -> fir::ExtendedValue {
2059 // Add cleanup code
2060 auto addr =
2061 builder.create<fir::BoxAddrOp>(loc, box.getMemTy(), box.getAddr());
2062 addCleanUpForTemp(loc, addr);
2063 return box;
2064 },
2065 [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue {
2066 // Add cleanup code
2067 addCleanUpForTemp(loc, box.getAddr());
2068 return box;
2069 },
2070 [&](const mlir::Value &tempAddr) -> fir::ExtendedValue {
2071 // Add cleanup code
2072 addCleanUpForTemp(loc, tempAddr);
2073 return builder.create<fir::LoadOp>(loc, resultType, tempAddr);
2074 },
2075 [&](const fir::CharBoxValue &box) -> fir::ExtendedValue {
2076 // Add cleanup code
2077 addCleanUpForTemp(loc, box.getAddr());
2078 return box;
2079 },
2080 [&](const auto &) -> fir::ExtendedValue {
2081 fir::emitFatalError(loc, "unexpected result for " + intrinsicName);
2082 });
2083 }
2084
2085 //===----------------------------------------------------------------------===//
2086 // Code generators for the intrinsic
2087 //===----------------------------------------------------------------------===//
2088
genRuntimeCall(llvm::StringRef name,mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2089 mlir::Value IntrinsicLibrary::genRuntimeCall(llvm::StringRef name,
2090 mlir::Type resultType,
2091 llvm::ArrayRef<mlir::Value> args) {
2092 mlir::FunctionType soughtFuncType =
2093 getFunctionType(resultType, args, builder);
2094 return getRuntimeCallGenerator(name, soughtFuncType)(builder, loc, args);
2095 }
2096
genConversion(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2097 mlir::Value IntrinsicLibrary::genConversion(mlir::Type resultType,
2098 llvm::ArrayRef<mlir::Value> args) {
2099 // There can be an optional kind in second argument.
2100 assert(args.size() >= 1);
2101 return builder.convertWithSemantics(loc, resultType, args[0]);
2102 }
2103
2104 // ABS
genAbs(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2105 mlir::Value IntrinsicLibrary::genAbs(mlir::Type resultType,
2106 llvm::ArrayRef<mlir::Value> args) {
2107 assert(args.size() == 1);
2108 mlir::Value arg = args[0];
2109 mlir::Type type = arg.getType();
2110 if (fir::isa_real(type)) {
2111 // Runtime call to fp abs. An alternative would be to use mlir
2112 // math::AbsFOp but it does not support all fir floating point types.
2113 return genRuntimeCall("abs", resultType, args);
2114 }
2115 if (auto intType = type.dyn_cast<mlir::IntegerType>()) {
2116 // At the time of this implementation there is no abs op in mlir.
2117 // So, implement abs here without branching.
2118 mlir::Value shift =
2119 builder.createIntegerConstant(loc, intType, intType.getWidth() - 1);
2120 auto mask = builder.create<mlir::arith::ShRSIOp>(loc, arg, shift);
2121 auto xored = builder.create<mlir::arith::XOrIOp>(loc, arg, mask);
2122 return builder.create<mlir::arith::SubIOp>(loc, xored, mask);
2123 }
2124 if (fir::isa_complex(type)) {
2125 // Use HYPOT to fulfill the no underflow/overflow requirement.
2126 auto parts = fir::factory::Complex{builder, loc}.extractParts(arg);
2127 llvm::SmallVector<mlir::Value> args = {parts.first, parts.second};
2128 return genRuntimeCall("hypot", resultType, args);
2129 }
2130 llvm_unreachable("unexpected type in ABS argument");
2131 }
2132
2133 // ADJUSTL & ADJUSTR
2134 template <void (*CallRuntime)(fir::FirOpBuilder &, mlir::Location loc,
2135 mlir::Value, mlir::Value)>
2136 fir::ExtendedValue
genAdjustRtCall(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2137 IntrinsicLibrary::genAdjustRtCall(mlir::Type resultType,
2138 llvm::ArrayRef<fir::ExtendedValue> args) {
2139 assert(args.size() == 1);
2140 mlir::Value string = builder.createBox(loc, args[0]);
2141 // Create a mutable fir.box to be passed to the runtime for the result.
2142 fir::MutableBoxValue resultMutableBox =
2143 fir::factory::createTempMutableBox(builder, loc, resultType);
2144 mlir::Value resultIrBox =
2145 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2146
2147 // Call the runtime -- the runtime will allocate the result.
2148 CallRuntime(builder, loc, resultIrBox, string);
2149
2150 // Read result from mutable fir.box and add it to the list of temps to be
2151 // finalized by the StatementContext.
2152 fir::ExtendedValue res =
2153 fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
2154 return res.match(
2155 [&](const fir::CharBoxValue &box) -> fir::ExtendedValue {
2156 addCleanUpForTemp(loc, fir::getBase(box));
2157 return box;
2158 },
2159 [&](const auto &) -> fir::ExtendedValue {
2160 fir::emitFatalError(loc, "result of ADJUSTL is not a scalar character");
2161 });
2162 }
2163
2164 // AIMAG
genAimag(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2165 mlir::Value IntrinsicLibrary::genAimag(mlir::Type resultType,
2166 llvm::ArrayRef<mlir::Value> args) {
2167 assert(args.size() == 1);
2168 return fir::factory::Complex{builder, loc}.extractComplexPart(
2169 args[0], /*isImagPart=*/true);
2170 }
2171
2172 // AINT
genAint(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2173 mlir::Value IntrinsicLibrary::genAint(mlir::Type resultType,
2174 llvm::ArrayRef<mlir::Value> args) {
2175 assert(args.size() >= 1 && args.size() <= 2);
2176 // Skip optional kind argument to search the runtime; it is already reflected
2177 // in result type.
2178 return genRuntimeCall("aint", resultType, {args[0]});
2179 }
2180
2181 // ALL
2182 fir::ExtendedValue
genAll(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2183 IntrinsicLibrary::genAll(mlir::Type resultType,
2184 llvm::ArrayRef<fir::ExtendedValue> args) {
2185
2186 assert(args.size() == 2);
2187 // Handle required mask argument
2188 mlir::Value mask = builder.createBox(loc, args[0]);
2189
2190 fir::BoxValue maskArry = builder.createBox(loc, args[0]);
2191 int rank = maskArry.rank();
2192 assert(rank >= 1);
2193
2194 // Handle optional dim argument
2195 bool absentDim = isStaticallyAbsent(args[1]);
2196 mlir::Value dim =
2197 absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
2198 : fir::getBase(args[1]);
2199
2200 if (rank == 1 || absentDim)
2201 return builder.createConvert(loc, resultType,
2202 fir::runtime::genAll(builder, loc, mask, dim));
2203
2204 // else use the result descriptor AllDim() intrinsic
2205
2206 // Create mutable fir.box to be passed to the runtime for the result.
2207
2208 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
2209 fir::MutableBoxValue resultMutableBox =
2210 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2211 mlir::Value resultIrBox =
2212 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2213
2214 // Call runtime. The runtime is allocating the result.
2215 fir::runtime::genAllDescriptor(builder, loc, resultIrBox, mask, dim);
2216 return fir::factory::genMutableBoxRead(builder, loc, resultMutableBox)
2217 .match(
2218 [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
2219 addCleanUpForTemp(loc, box.getAddr());
2220 return box;
2221 },
2222 [&](const auto &) -> fir::ExtendedValue {
2223 fir::emitFatalError(loc, "Invalid result for ALL");
2224 });
2225 }
2226
2227 // ALLOCATED
2228 fir::ExtendedValue
genAllocated(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2229 IntrinsicLibrary::genAllocated(mlir::Type resultType,
2230 llvm::ArrayRef<fir::ExtendedValue> args) {
2231 assert(args.size() == 1);
2232 return args[0].match(
2233 [&](const fir::MutableBoxValue &x) -> fir::ExtendedValue {
2234 return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, x);
2235 },
2236 [&](const auto &) -> fir::ExtendedValue {
2237 fir::emitFatalError(loc,
2238 "allocated arg not lowered to MutableBoxValue");
2239 });
2240 }
2241
2242 // ANINT
genAnint(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2243 mlir::Value IntrinsicLibrary::genAnint(mlir::Type resultType,
2244 llvm::ArrayRef<mlir::Value> args) {
2245 assert(args.size() >= 1 && args.size() <= 2);
2246 // Skip optional kind argument to search the runtime; it is already reflected
2247 // in result type.
2248 return genRuntimeCall("anint", resultType, {args[0]});
2249 }
2250
2251 // ANY
2252 fir::ExtendedValue
genAny(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2253 IntrinsicLibrary::genAny(mlir::Type resultType,
2254 llvm::ArrayRef<fir::ExtendedValue> args) {
2255
2256 assert(args.size() == 2);
2257 // Handle required mask argument
2258 mlir::Value mask = builder.createBox(loc, args[0]);
2259
2260 fir::BoxValue maskArry = builder.createBox(loc, args[0]);
2261 int rank = maskArry.rank();
2262 assert(rank >= 1);
2263
2264 // Handle optional dim argument
2265 bool absentDim = isStaticallyAbsent(args[1]);
2266 mlir::Value dim =
2267 absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
2268 : fir::getBase(args[1]);
2269
2270 if (rank == 1 || absentDim)
2271 return builder.createConvert(loc, resultType,
2272 fir::runtime::genAny(builder, loc, mask, dim));
2273
2274 // else use the result descriptor AnyDim() intrinsic
2275
2276 // Create mutable fir.box to be passed to the runtime for the result.
2277
2278 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
2279 fir::MutableBoxValue resultMutableBox =
2280 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2281 mlir::Value resultIrBox =
2282 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2283
2284 // Call runtime. The runtime is allocating the result.
2285 fir::runtime::genAnyDescriptor(builder, loc, resultIrBox, mask, dim);
2286 return fir::factory::genMutableBoxRead(builder, loc, resultMutableBox)
2287 .match(
2288 [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
2289 addCleanUpForTemp(loc, box.getAddr());
2290 return box;
2291 },
2292 [&](const auto &) -> fir::ExtendedValue {
2293 fir::emitFatalError(loc, "Invalid result for ANY");
2294 });
2295 }
2296
2297 // ASSOCIATED
2298 fir::ExtendedValue
genAssociated(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2299 IntrinsicLibrary::genAssociated(mlir::Type resultType,
2300 llvm::ArrayRef<fir::ExtendedValue> args) {
2301 assert(args.size() == 2);
2302 auto *pointer =
2303 args[0].match([&](const fir::MutableBoxValue &x) { return &x; },
2304 [&](const auto &) -> const fir::MutableBoxValue * {
2305 fir::emitFatalError(loc, "pointer not a MutableBoxValue");
2306 });
2307 const fir::ExtendedValue &target = args[1];
2308 if (isStaticallyAbsent(target))
2309 return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, *pointer);
2310
2311 mlir::Value targetBox = builder.createBox(loc, target);
2312 if (fir::valueHasFirAttribute(fir::getBase(target),
2313 fir::getOptionalAttrName())) {
2314 // Subtle: contrary to other intrinsic optional arguments, disassociated
2315 // POINTER and unallocated ALLOCATABLE actual argument are not considered
2316 // absent here. This is because ASSOCIATED has special requirements for
2317 // TARGET actual arguments that are POINTERs. There is no precise
2318 // requirements for ALLOCATABLEs, but all existing Fortran compilers treat
2319 // them similarly to POINTERs. That is: unallocated TARGETs cause ASSOCIATED
2320 // to rerun false. The runtime deals with the disassociated/unallocated
2321 // case. Simply ensures that TARGET that are OPTIONAL get conditionally
2322 // emboxed here to convey the optional aspect to the runtime.
2323 auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
2324 fir::getBase(target));
2325 auto absentBox = builder.create<fir::AbsentOp>(loc, targetBox.getType());
2326 targetBox = builder.create<mlir::arith::SelectOp>(loc, isPresent, targetBox,
2327 absentBox);
2328 }
2329 mlir::Value pointerBoxRef =
2330 fir::factory::getMutableIRBox(builder, loc, *pointer);
2331 auto pointerBox = builder.create<fir::LoadOp>(loc, pointerBoxRef);
2332 return Fortran::lower::genAssociated(builder, loc, pointerBox, targetBox);
2333 }
2334
2335 // BGE, BGT, BLE, BLT
2336 template <mlir::arith::CmpIPredicate pred>
2337 mlir::Value
genBitwiseCompare(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2338 IntrinsicLibrary::genBitwiseCompare(mlir::Type resultType,
2339 llvm::ArrayRef<mlir::Value> args) {
2340 assert(args.size() == 2);
2341
2342 mlir::Value arg0 = args[0];
2343 mlir::Value arg1 = args[1];
2344 mlir::Type arg0Ty = arg0.getType();
2345 mlir::Type arg1Ty = arg1.getType();
2346 unsigned bits0 = arg0Ty.getIntOrFloatBitWidth();
2347 unsigned bits1 = arg1Ty.getIntOrFloatBitWidth();
2348
2349 // Arguments do not have to be of the same integer type. However, if neither
2350 // of the arguments is a BOZ literal, then the shorter of the two needs
2351 // to be converted to the longer by zero-extending (not sign-extending)
2352 // to the left [Fortran 2008, 13.3.2].
2353 //
2354 // In the case of BOZ literals, the standard describes zero-extension or
2355 // truncation depending on the kind of the result [Fortran 2008, 13.3.3].
2356 // However, that seems to be relevant for the case where the type of the
2357 // result must match the type of the BOZ literal. That is not the case for
2358 // these intrinsics, so, again, zero-extend to the larger type.
2359 //
2360 if (bits0 > bits1)
2361 arg1 = builder.create<mlir::arith::ExtUIOp>(loc, arg0Ty, arg1);
2362 else if (bits0 < bits1)
2363 arg0 = builder.create<mlir::arith::ExtUIOp>(loc, arg1Ty, arg0);
2364
2365 return builder.create<mlir::arith::CmpIOp>(loc, pred, arg0, arg1);
2366 }
2367
2368 // BTEST
genBtest(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2369 mlir::Value IntrinsicLibrary::genBtest(mlir::Type resultType,
2370 llvm::ArrayRef<mlir::Value> args) {
2371 // A conformant BTEST(I,POS) call satisfies:
2372 // POS >= 0
2373 // POS < BIT_SIZE(I)
2374 // Return: (I >> POS) & 1
2375 assert(args.size() == 2);
2376 mlir::Type argType = args[0].getType();
2377 mlir::Value pos = builder.createConvert(loc, argType, args[1]);
2378 auto shift = builder.create<mlir::arith::ShRUIOp>(loc, args[0], pos);
2379 mlir::Value one = builder.createIntegerConstant(loc, argType, 1);
2380 auto res = builder.create<mlir::arith::AndIOp>(loc, shift, one);
2381 return builder.createConvert(loc, resultType, res);
2382 }
2383
2384 // CEILING
genCeiling(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2385 mlir::Value IntrinsicLibrary::genCeiling(mlir::Type resultType,
2386 llvm::ArrayRef<mlir::Value> args) {
2387 // Optional KIND argument.
2388 assert(args.size() >= 1);
2389 mlir::Value arg = args[0];
2390 // Use ceil that is not an actual Fortran intrinsic but that is
2391 // an llvm intrinsic that does the same, but return a floating
2392 // point.
2393 mlir::Value ceil = genRuntimeCall("ceil", arg.getType(), {arg});
2394 return builder.createConvert(loc, resultType, ceil);
2395 }
2396
2397 // CHAR
2398 fir::ExtendedValue
genChar(mlir::Type type,llvm::ArrayRef<fir::ExtendedValue> args)2399 IntrinsicLibrary::genChar(mlir::Type type,
2400 llvm::ArrayRef<fir::ExtendedValue> args) {
2401 // Optional KIND argument.
2402 assert(args.size() >= 1);
2403 const mlir::Value *arg = args[0].getUnboxed();
2404 // expect argument to be a scalar integer
2405 if (!arg)
2406 mlir::emitError(loc, "CHAR intrinsic argument not unboxed");
2407 fir::factory::CharacterExprHelper helper{builder, loc};
2408 fir::CharacterType::KindTy kind = helper.getCharacterType(type).getFKind();
2409 mlir::Value cast = helper.createSingletonFromCode(*arg, kind);
2410 mlir::Value len =
2411 builder.createIntegerConstant(loc, builder.getCharacterLengthType(), 1);
2412 return fir::CharBoxValue{cast, len};
2413 }
2414
2415 // CMPLX
genCmplx(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2416 mlir::Value IntrinsicLibrary::genCmplx(mlir::Type resultType,
2417 llvm::ArrayRef<mlir::Value> args) {
2418 assert(args.size() >= 1);
2419 fir::factory::Complex complexHelper(builder, loc);
2420 mlir::Type partType = complexHelper.getComplexPartType(resultType);
2421 mlir::Value real = builder.createConvert(loc, partType, args[0]);
2422 mlir::Value imag = isStaticallyAbsent(args, 1)
2423 ? builder.createRealZeroConstant(loc, partType)
2424 : builder.createConvert(loc, partType, args[1]);
2425 return fir::factory::Complex{builder, loc}.createComplex(resultType, real,
2426 imag);
2427 }
2428
2429 // COMMAND_ARGUMENT_COUNT
genCommandArgumentCount(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2430 fir::ExtendedValue IntrinsicLibrary::genCommandArgumentCount(
2431 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args) {
2432 assert(args.size() == 0);
2433 assert(resultType == builder.getDefaultIntegerType() &&
2434 "result type is not default integer kind type");
2435 return builder.createConvert(
2436 loc, resultType, fir::runtime::genCommandArgumentCount(builder, loc));
2437 ;
2438 }
2439
2440 // CONJG
genConjg(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2441 mlir::Value IntrinsicLibrary::genConjg(mlir::Type resultType,
2442 llvm::ArrayRef<mlir::Value> args) {
2443 assert(args.size() == 1);
2444 if (resultType != args[0].getType())
2445 llvm_unreachable("argument type mismatch");
2446
2447 mlir::Value cplx = args[0];
2448 auto imag = fir::factory::Complex{builder, loc}.extractComplexPart(
2449 cplx, /*isImagPart=*/true);
2450 auto negImag = builder.create<mlir::arith::NegFOp>(loc, imag);
2451 return fir::factory::Complex{builder, loc}.insertComplexPart(
2452 cplx, negImag, /*isImagPart=*/true);
2453 }
2454
2455 // COUNT
2456 fir::ExtendedValue
genCount(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2457 IntrinsicLibrary::genCount(mlir::Type resultType,
2458 llvm::ArrayRef<fir::ExtendedValue> args) {
2459 assert(args.size() == 3);
2460
2461 // Handle mask argument
2462 fir::BoxValue mask = builder.createBox(loc, args[0]);
2463 unsigned maskRank = mask.rank();
2464
2465 assert(maskRank > 0);
2466
2467 // Handle optional dim argument
2468 bool absentDim = isStaticallyAbsent(args[1]);
2469 mlir::Value dim =
2470 absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 0)
2471 : fir::getBase(args[1]);
2472
2473 if (absentDim || maskRank == 1) {
2474 // Result is scalar if no dim argument or mask is rank 1.
2475 // So, call specialized Count runtime routine.
2476 return builder.createConvert(
2477 loc, resultType,
2478 fir::runtime::genCount(builder, loc, fir::getBase(mask), dim));
2479 }
2480
2481 // Call general CountDim runtime routine.
2482
2483 // Handle optional kind argument
2484 bool absentKind = isStaticallyAbsent(args[2]);
2485 mlir::Value kind = absentKind ? builder.createIntegerConstant(
2486 loc, builder.getIndexType(),
2487 builder.getKindMap().defaultIntegerKind())
2488 : fir::getBase(args[2]);
2489
2490 // Create mutable fir.box to be passed to the runtime for the result.
2491 mlir::Type type = builder.getVarLenSeqTy(resultType, maskRank - 1);
2492 fir::MutableBoxValue resultMutableBox =
2493 fir::factory::createTempMutableBox(builder, loc, type);
2494
2495 mlir::Value resultIrBox =
2496 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2497
2498 fir::runtime::genCountDim(builder, loc, resultIrBox, fir::getBase(mask), dim,
2499 kind);
2500
2501 // Handle cleanup of allocatable result descriptor and return
2502 fir::ExtendedValue res =
2503 fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
2504 return res.match(
2505 [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
2506 // Add cleanup code
2507 addCleanUpForTemp(loc, box.getAddr());
2508 return box;
2509 },
2510 [&](const auto &) -> fir::ExtendedValue {
2511 fir::emitFatalError(loc, "unexpected result for COUNT");
2512 });
2513 }
2514
2515 // CPU_TIME
genCpuTime(llvm::ArrayRef<fir::ExtendedValue> args)2516 void IntrinsicLibrary::genCpuTime(llvm::ArrayRef<fir::ExtendedValue> args) {
2517 assert(args.size() == 1);
2518 const mlir::Value *arg = args[0].getUnboxed();
2519 assert(arg && "nonscalar cpu_time argument");
2520 mlir::Value res1 = Fortran::lower::genCpuTime(builder, loc);
2521 mlir::Value res2 =
2522 builder.createConvert(loc, fir::dyn_cast_ptrEleTy(arg->getType()), res1);
2523 builder.create<fir::StoreOp>(loc, res2, *arg);
2524 }
2525
2526 // CSHIFT
2527 fir::ExtendedValue
genCshift(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2528 IntrinsicLibrary::genCshift(mlir::Type resultType,
2529 llvm::ArrayRef<fir::ExtendedValue> args) {
2530 assert(args.size() == 3);
2531
2532 // Handle required ARRAY argument
2533 fir::BoxValue arrayBox = builder.createBox(loc, args[0]);
2534 mlir::Value array = fir::getBase(arrayBox);
2535 unsigned arrayRank = arrayBox.rank();
2536
2537 // Create mutable fir.box to be passed to the runtime for the result.
2538 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, arrayRank);
2539 fir::MutableBoxValue resultMutableBox =
2540 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2541 mlir::Value resultIrBox =
2542 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2543
2544 if (arrayRank == 1) {
2545 // Vector case
2546 // Handle required SHIFT argument as a scalar
2547 const mlir::Value *shiftAddr = args[1].getUnboxed();
2548 assert(shiftAddr && "nonscalar CSHIFT argument");
2549 auto shift = builder.create<fir::LoadOp>(loc, *shiftAddr);
2550
2551 fir::runtime::genCshiftVector(builder, loc, resultIrBox, array, shift);
2552 } else {
2553 // Non-vector case
2554 // Handle required SHIFT argument as an array
2555 mlir::Value shift = builder.createBox(loc, args[1]);
2556
2557 // Handle optional DIM argument
2558 mlir::Value dim =
2559 isStaticallyAbsent(args[2])
2560 ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
2561 : fir::getBase(args[2]);
2562 fir::runtime::genCshift(builder, loc, resultIrBox, array, shift, dim);
2563 }
2564 return readAndAddCleanUp(resultMutableBox, resultType, "CSHIFT");
2565 }
2566
2567 // DATE_AND_TIME
genDateAndTime(llvm::ArrayRef<fir::ExtendedValue> args)2568 void IntrinsicLibrary::genDateAndTime(llvm::ArrayRef<fir::ExtendedValue> args) {
2569 assert(args.size() == 4 && "date_and_time has 4 args");
2570 llvm::SmallVector<llvm::Optional<fir::CharBoxValue>> charArgs(3);
2571 for (unsigned i = 0; i < 3; ++i)
2572 if (const fir::CharBoxValue *charBox = args[i].getCharBox())
2573 charArgs[i] = *charBox;
2574
2575 mlir::Value values = fir::getBase(args[3]);
2576 if (!values)
2577 values = builder.create<fir::AbsentOp>(
2578 loc, fir::BoxType::get(builder.getNoneType()));
2579
2580 Fortran::lower::genDateAndTime(builder, loc, charArgs[0], charArgs[1],
2581 charArgs[2], values);
2582 }
2583
2584 // DIM
genDim(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2585 mlir::Value IntrinsicLibrary::genDim(mlir::Type resultType,
2586 llvm::ArrayRef<mlir::Value> args) {
2587 assert(args.size() == 2);
2588 if (resultType.isa<mlir::IntegerType>()) {
2589 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
2590 auto diff = builder.create<mlir::arith::SubIOp>(loc, args[0], args[1]);
2591 auto cmp = builder.create<mlir::arith::CmpIOp>(
2592 loc, mlir::arith::CmpIPredicate::sgt, diff, zero);
2593 return builder.create<mlir::arith::SelectOp>(loc, cmp, diff, zero);
2594 }
2595 assert(fir::isa_real(resultType) && "Only expects real and integer in DIM");
2596 mlir::Value zero = builder.createRealZeroConstant(loc, resultType);
2597 auto diff = builder.create<mlir::arith::SubFOp>(loc, args[0], args[1]);
2598 auto cmp = builder.create<mlir::arith::CmpFOp>(
2599 loc, mlir::arith::CmpFPredicate::OGT, diff, zero);
2600 return builder.create<mlir::arith::SelectOp>(loc, cmp, diff, zero);
2601 }
2602
2603 // DOT_PRODUCT
2604 fir::ExtendedValue
genDotProduct(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2605 IntrinsicLibrary::genDotProduct(mlir::Type resultType,
2606 llvm::ArrayRef<fir::ExtendedValue> args) {
2607 return genDotProd(fir::runtime::genDotProduct, resultType, builder, loc,
2608 stmtCtx, args);
2609 }
2610
2611 // DPROD
genDprod(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2612 mlir::Value IntrinsicLibrary::genDprod(mlir::Type resultType,
2613 llvm::ArrayRef<mlir::Value> args) {
2614 assert(args.size() == 2);
2615 assert(fir::isa_real(resultType) &&
2616 "Result must be double precision in DPROD");
2617 mlir::Value a = builder.createConvert(loc, resultType, args[0]);
2618 mlir::Value b = builder.createConvert(loc, resultType, args[1]);
2619 return builder.create<mlir::arith::MulFOp>(loc, a, b);
2620 }
2621
2622 // DSHIFTL
genDshiftl(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2623 mlir::Value IntrinsicLibrary::genDshiftl(mlir::Type resultType,
2624 llvm::ArrayRef<mlir::Value> args) {
2625 assert(args.size() == 3);
2626
2627 mlir::Value i = args[0];
2628 mlir::Value j = args[1];
2629 mlir::Value shift = builder.createConvert(loc, resultType, args[2]);
2630 mlir::Value bitSize = builder.createIntegerConstant(
2631 loc, resultType, resultType.getIntOrFloatBitWidth());
2632
2633 // Per the standard, the value of DSHIFTL(I, J, SHIFT) is equal to
2634 // IOR (SHIFTL(I, SHIFT), SHIFTR(J, BIT_SIZE(J) - SHIFT))
2635 mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, bitSize, shift);
2636
2637 mlir::Value lArgs[2]{i, shift};
2638 mlir::Value lft = genShift<mlir::arith::ShLIOp>(resultType, lArgs);
2639
2640 mlir::Value rArgs[2]{j, diff};
2641 mlir::Value rgt = genShift<mlir::arith::ShRUIOp>(resultType, rArgs);
2642
2643 return builder.create<mlir::arith::OrIOp>(loc, lft, rgt);
2644 }
2645
2646 // DSHIFTR
genDshiftr(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2647 mlir::Value IntrinsicLibrary::genDshiftr(mlir::Type resultType,
2648 llvm::ArrayRef<mlir::Value> args) {
2649 assert(args.size() == 3);
2650
2651 mlir::Value i = args[0];
2652 mlir::Value j = args[1];
2653 mlir::Value shift = builder.createConvert(loc, resultType, args[2]);
2654 mlir::Value bitSize = builder.createIntegerConstant(
2655 loc, resultType, resultType.getIntOrFloatBitWidth());
2656
2657 // Per the standard, the value of DSHIFTR(I, J, SHIFT) is equal to
2658 // IOR (SHIFTL(I, BIT_SIZE(I) - SHIFT), SHIFTR(J, SHIFT))
2659 mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, bitSize, shift);
2660
2661 mlir::Value lArgs[2]{i, diff};
2662 mlir::Value lft = genShift<mlir::arith::ShLIOp>(resultType, lArgs);
2663
2664 mlir::Value rArgs[2]{j, shift};
2665 mlir::Value rgt = genShift<mlir::arith::ShRUIOp>(resultType, rArgs);
2666
2667 return builder.create<mlir::arith::OrIOp>(loc, lft, rgt);
2668 }
2669
2670 // EOSHIFT
2671 fir::ExtendedValue
genEoshift(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2672 IntrinsicLibrary::genEoshift(mlir::Type resultType,
2673 llvm::ArrayRef<fir::ExtendedValue> args) {
2674 assert(args.size() == 4);
2675
2676 // Handle required ARRAY argument
2677 fir::BoxValue arrayBox = builder.createBox(loc, args[0]);
2678 mlir::Value array = fir::getBase(arrayBox);
2679 unsigned arrayRank = arrayBox.rank();
2680
2681 // Create mutable fir.box to be passed to the runtime for the result.
2682 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, arrayRank);
2683 fir::MutableBoxValue resultMutableBox =
2684 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2685 mlir::Value resultIrBox =
2686 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2687
2688 // Handle optional BOUNDARY argument
2689 mlir::Value boundary =
2690 isStaticallyAbsent(args[2])
2691 ? builder.create<fir::AbsentOp>(
2692 loc, fir::BoxType::get(builder.getNoneType()))
2693 : builder.createBox(loc, args[2]);
2694
2695 if (arrayRank == 1) {
2696 // Vector case
2697 // Handle required SHIFT argument as a scalar
2698 const mlir::Value *shiftAddr = args[1].getUnboxed();
2699 assert(shiftAddr && "nonscalar EOSHIFT SHIFT argument");
2700 auto shift = builder.create<fir::LoadOp>(loc, *shiftAddr);
2701 fir::runtime::genEoshiftVector(builder, loc, resultIrBox, array, shift,
2702 boundary);
2703 } else {
2704 // Non-vector case
2705 // Handle required SHIFT argument as an array
2706 mlir::Value shift = builder.createBox(loc, args[1]);
2707
2708 // Handle optional DIM argument
2709 mlir::Value dim =
2710 isStaticallyAbsent(args[3])
2711 ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
2712 : fir::getBase(args[3]);
2713 fir::runtime::genEoshift(builder, loc, resultIrBox, array, shift, boundary,
2714 dim);
2715 }
2716 return readAndAddCleanUp(resultMutableBox, resultType,
2717 "unexpected result for EOSHIFT");
2718 }
2719
2720 // EXIT
genExit(llvm::ArrayRef<fir::ExtendedValue> args)2721 void IntrinsicLibrary::genExit(llvm::ArrayRef<fir::ExtendedValue> args) {
2722 assert(args.size() == 1);
2723
2724 mlir::Value status =
2725 isStaticallyAbsent(args[0])
2726 ? builder.createIntegerConstant(loc, builder.getDefaultIntegerType(),
2727 EXIT_SUCCESS)
2728 : fir::getBase(args[0]);
2729
2730 assert(status.getType() == builder.getDefaultIntegerType() &&
2731 "STATUS parameter must be an INTEGER of default kind");
2732
2733 fir::runtime::genExit(builder, loc, status);
2734 }
2735
2736 // EXPONENT
genExponent(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2737 mlir::Value IntrinsicLibrary::genExponent(mlir::Type resultType,
2738 llvm::ArrayRef<mlir::Value> args) {
2739 assert(args.size() == 1);
2740
2741 return builder.createConvert(
2742 loc, resultType,
2743 fir::runtime::genExponent(builder, loc, resultType,
2744 fir::getBase(args[0])));
2745 }
2746
2747 // FLOOR
genFloor(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2748 mlir::Value IntrinsicLibrary::genFloor(mlir::Type resultType,
2749 llvm::ArrayRef<mlir::Value> args) {
2750 // Optional KIND argument.
2751 assert(args.size() >= 1);
2752 mlir::Value arg = args[0];
2753 // Use LLVM floor that returns real.
2754 mlir::Value floor = genRuntimeCall("floor", arg.getType(), {arg});
2755 return builder.createConvert(loc, resultType, floor);
2756 }
2757
2758 // FRACTION
genFraction(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2759 mlir::Value IntrinsicLibrary::genFraction(mlir::Type resultType,
2760 llvm::ArrayRef<mlir::Value> args) {
2761 assert(args.size() == 1);
2762
2763 return builder.createConvert(
2764 loc, resultType,
2765 fir::runtime::genFraction(builder, loc, fir::getBase(args[0])));
2766 }
2767
2768 // GET_COMMAND_ARGUMENT
genGetCommandArgument(llvm::ArrayRef<fir::ExtendedValue> args)2769 void IntrinsicLibrary::genGetCommandArgument(
2770 llvm::ArrayRef<fir::ExtendedValue> args) {
2771 assert(args.size() == 5);
2772 mlir::Value number = fir::getBase(args[0]);
2773 const fir::ExtendedValue &value = args[1];
2774 const fir::ExtendedValue &length = args[2];
2775 const fir::ExtendedValue &status = args[3];
2776 const fir::ExtendedValue &errmsg = args[4];
2777
2778 if (!number)
2779 fir::emitFatalError(loc, "expected NUMBER parameter");
2780
2781 if (isStaticallyPresent(value) || isStaticallyPresent(status) ||
2782 isStaticallyPresent(errmsg)) {
2783 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
2784 mlir::Value valBox =
2785 isStaticallyPresent(value)
2786 ? fir::getBase(value)
2787 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
2788 mlir::Value errBox =
2789 isStaticallyPresent(errmsg)
2790 ? fir::getBase(errmsg)
2791 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
2792 mlir::Value stat =
2793 fir::runtime::genArgumentValue(builder, loc, number, valBox, errBox);
2794 if (isStaticallyPresent(status)) {
2795 mlir::Value statAddr = fir::getBase(status);
2796 mlir::Value statIsPresentAtRuntime =
2797 builder.genIsNotNullAddr(loc, statAddr);
2798 builder.genIfThen(loc, statIsPresentAtRuntime)
2799 .genThen(
2800 [&]() { builder.createStoreWithConvert(loc, stat, statAddr); })
2801 .end();
2802 }
2803 }
2804 if (isStaticallyPresent(length)) {
2805 mlir::Value lenAddr = fir::getBase(length);
2806 mlir::Value lenIsPresentAtRuntime = builder.genIsNotNullAddr(loc, lenAddr);
2807 builder.genIfThen(loc, lenIsPresentAtRuntime)
2808 .genThen([&]() {
2809 mlir::Value len =
2810 fir::runtime::genArgumentLength(builder, loc, number);
2811 builder.createStoreWithConvert(loc, len, lenAddr);
2812 })
2813 .end();
2814 }
2815 }
2816
2817 // GET_ENVIRONMENT_VARIABLE
genGetEnvironmentVariable(llvm::ArrayRef<fir::ExtendedValue> args)2818 void IntrinsicLibrary::genGetEnvironmentVariable(
2819 llvm::ArrayRef<fir::ExtendedValue> args) {
2820 assert(args.size() == 6);
2821 mlir::Value name = fir::getBase(args[0]);
2822 const fir::ExtendedValue &value = args[1];
2823 const fir::ExtendedValue &length = args[2];
2824 const fir::ExtendedValue &status = args[3];
2825 const fir::ExtendedValue &trimName = args[4];
2826 const fir::ExtendedValue &errmsg = args[5];
2827
2828 // Handle optional TRIM_NAME argument
2829 mlir::Value trim;
2830 if (isStaticallyAbsent(trimName)) {
2831 trim = builder.createBool(loc, true);
2832 } else {
2833 mlir::Type i1Ty = builder.getI1Type();
2834 mlir::Value trimNameAddr = fir::getBase(trimName);
2835 mlir::Value trimNameIsPresentAtRuntime =
2836 builder.genIsNotNullAddr(loc, trimNameAddr);
2837 trim = builder
2838 .genIfOp(loc, {i1Ty}, trimNameIsPresentAtRuntime,
2839 /*withElseRegion=*/true)
2840 .genThen([&]() {
2841 auto trimLoad = builder.create<fir::LoadOp>(loc, trimNameAddr);
2842 mlir::Value cast = builder.createConvert(loc, i1Ty, trimLoad);
2843 builder.create<fir::ResultOp>(loc, cast);
2844 })
2845 .genElse([&]() {
2846 mlir::Value trueVal = builder.createBool(loc, true);
2847 builder.create<fir::ResultOp>(loc, trueVal);
2848 })
2849 .getResults()[0];
2850 }
2851
2852 if (isStaticallyPresent(value) || isStaticallyPresent(status) ||
2853 isStaticallyPresent(errmsg)) {
2854 mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
2855 mlir::Value valBox =
2856 isStaticallyPresent(value)
2857 ? fir::getBase(value)
2858 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
2859 mlir::Value errBox =
2860 isStaticallyPresent(errmsg)
2861 ? fir::getBase(errmsg)
2862 : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
2863 mlir::Value stat = fir::runtime::genEnvVariableValue(builder, loc, name,
2864 valBox, trim, errBox);
2865 if (isStaticallyPresent(status)) {
2866 mlir::Value statAddr = fir::getBase(status);
2867 mlir::Value statIsPresentAtRuntime =
2868 builder.genIsNotNullAddr(loc, statAddr);
2869 builder.genIfThen(loc, statIsPresentAtRuntime)
2870 .genThen(
2871 [&]() { builder.createStoreWithConvert(loc, stat, statAddr); })
2872 .end();
2873 }
2874 }
2875
2876 if (isStaticallyPresent(length)) {
2877 mlir::Value lenAddr = fir::getBase(length);
2878 mlir::Value lenIsPresentAtRuntime = builder.genIsNotNullAddr(loc, lenAddr);
2879 builder.genIfThen(loc, lenIsPresentAtRuntime)
2880 .genThen([&]() {
2881 mlir::Value len =
2882 fir::runtime::genEnvVariableLength(builder, loc, name, trim);
2883 builder.createStoreWithConvert(loc, len, lenAddr);
2884 })
2885 .end();
2886 }
2887 }
2888
2889 // IAND
genIand(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2890 mlir::Value IntrinsicLibrary::genIand(mlir::Type resultType,
2891 llvm::ArrayRef<mlir::Value> args) {
2892 assert(args.size() == 2);
2893 auto arg0 = builder.createConvert(loc, resultType, args[0]);
2894 auto arg1 = builder.createConvert(loc, resultType, args[1]);
2895 return builder.create<mlir::arith::AndIOp>(loc, arg0, arg1);
2896 }
2897
2898 // IBCLR
genIbclr(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2899 mlir::Value IntrinsicLibrary::genIbclr(mlir::Type resultType,
2900 llvm::ArrayRef<mlir::Value> args) {
2901 // A conformant IBCLR(I,POS) call satisfies:
2902 // POS >= 0
2903 // POS < BIT_SIZE(I)
2904 // Return: I & (!(1 << POS))
2905 assert(args.size() == 2);
2906 mlir::Value pos = builder.createConvert(loc, resultType, args[1]);
2907 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
2908 mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
2909 auto mask = builder.create<mlir::arith::ShLIOp>(loc, one, pos);
2910 auto res = builder.create<mlir::arith::XOrIOp>(loc, ones, mask);
2911 return builder.create<mlir::arith::AndIOp>(loc, args[0], res);
2912 }
2913
2914 // IBITS
genIbits(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2915 mlir::Value IntrinsicLibrary::genIbits(mlir::Type resultType,
2916 llvm::ArrayRef<mlir::Value> args) {
2917 // A conformant IBITS(I,POS,LEN) call satisfies:
2918 // POS >= 0
2919 // LEN >= 0
2920 // POS + LEN <= BIT_SIZE(I)
2921 // Return: LEN == 0 ? 0 : (I >> POS) & (-1 >> (BIT_SIZE(I) - LEN))
2922 // For a conformant call, implementing (I >> POS) with a signed or an
2923 // unsigned shift produces the same result. For a nonconformant call,
2924 // the two choices may produce different results.
2925 assert(args.size() == 3);
2926 mlir::Value pos = builder.createConvert(loc, resultType, args[1]);
2927 mlir::Value len = builder.createConvert(loc, resultType, args[2]);
2928 mlir::Value bitSize = builder.createIntegerConstant(
2929 loc, resultType, resultType.cast<mlir::IntegerType>().getWidth());
2930 auto shiftCount = builder.create<mlir::arith::SubIOp>(loc, bitSize, len);
2931 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
2932 mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
2933 auto mask = builder.create<mlir::arith::ShRUIOp>(loc, ones, shiftCount);
2934 auto res1 = builder.create<mlir::arith::ShRSIOp>(loc, args[0], pos);
2935 auto res2 = builder.create<mlir::arith::AndIOp>(loc, res1, mask);
2936 auto lenIsZero = builder.create<mlir::arith::CmpIOp>(
2937 loc, mlir::arith::CmpIPredicate::eq, len, zero);
2938 return builder.create<mlir::arith::SelectOp>(loc, lenIsZero, zero, res2);
2939 }
2940
2941 // IBSET
genIbset(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)2942 mlir::Value IntrinsicLibrary::genIbset(mlir::Type resultType,
2943 llvm::ArrayRef<mlir::Value> args) {
2944 // A conformant IBSET(I,POS) call satisfies:
2945 // POS >= 0
2946 // POS < BIT_SIZE(I)
2947 // Return: I | (1 << POS)
2948 assert(args.size() == 2);
2949 mlir::Value pos = builder.createConvert(loc, resultType, args[1]);
2950 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
2951 auto mask = builder.create<mlir::arith::ShLIOp>(loc, one, pos);
2952 return builder.create<mlir::arith::OrIOp>(loc, args[0], mask);
2953 }
2954
2955 // ICHAR
2956 fir::ExtendedValue
genIchar(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2957 IntrinsicLibrary::genIchar(mlir::Type resultType,
2958 llvm::ArrayRef<fir::ExtendedValue> args) {
2959 // There can be an optional kind in second argument.
2960 assert(args.size() == 2);
2961 const fir::CharBoxValue *charBox = args[0].getCharBox();
2962 if (!charBox)
2963 llvm::report_fatal_error("expected character scalar");
2964
2965 fir::factory::CharacterExprHelper helper{builder, loc};
2966 mlir::Value buffer = charBox->getBuffer();
2967 mlir::Type bufferTy = buffer.getType();
2968 mlir::Value charVal;
2969 if (auto charTy = bufferTy.dyn_cast<fir::CharacterType>()) {
2970 assert(charTy.singleton());
2971 charVal = buffer;
2972 } else {
2973 // Character is in memory, cast to fir.ref<char> and load.
2974 mlir::Type ty = fir::dyn_cast_ptrEleTy(bufferTy);
2975 if (!ty)
2976 llvm::report_fatal_error("expected memory type");
2977 // The length of in the character type may be unknown. Casting
2978 // to a singleton ref is required before loading.
2979 fir::CharacterType eleType = helper.getCharacterType(ty);
2980 fir::CharacterType charType =
2981 fir::CharacterType::get(builder.getContext(), eleType.getFKind(), 1);
2982 mlir::Type toTy = builder.getRefType(charType);
2983 mlir::Value cast = builder.createConvert(loc, toTy, buffer);
2984 charVal = builder.create<fir::LoadOp>(loc, cast);
2985 }
2986 LLVM_DEBUG(llvm::dbgs() << "ichar(" << charVal << ")\n");
2987 auto code = helper.extractCodeFromSingleton(charVal);
2988 if (code.getType() == resultType)
2989 return code;
2990 return builder.create<mlir::arith::ExtUIOp>(loc, resultType, code);
2991 }
2992
2993 // IEEE_CLASS_TYPE OPERATOR(==), OPERATOR(/=)
2994 // IEEE_ROUND_TYPE OPERATOR(==), OPERATOR(/=)
2995 template <mlir::arith::CmpIPredicate pred>
2996 fir::ExtendedValue
genIeeeTypeCompare(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)2997 IntrinsicLibrary::genIeeeTypeCompare(mlir::Type resultType,
2998 llvm::ArrayRef<fir::ExtendedValue> args) {
2999 assert(args.size() == 2);
3000 mlir::Value arg0 = fir::getBase(args[0]);
3001 mlir::Value arg1 = fir::getBase(args[1]);
3002 auto recType =
3003 fir::unwrapPassByRefType(arg0.getType()).dyn_cast<fir::RecordType>();
3004 assert(recType.getTypeList().size() == 1 && "expected exactly one component");
3005 auto [fieldName, fieldType] = recType.getTypeList().front();
3006 mlir::Type fieldIndexType = fir::FieldType::get(recType.getContext());
3007 mlir::Value field = builder.create<fir::FieldIndexOp>(
3008 loc, fieldIndexType, fieldName, recType, fir::getTypeParams(arg0));
3009 mlir::Value left = builder.create<fir::LoadOp>(
3010 loc, fieldType,
3011 builder.create<fir::CoordinateOp>(loc, builder.getRefType(fieldType),
3012 arg0, field));
3013 mlir::Value right = builder.create<fir::LoadOp>(
3014 loc, fieldType,
3015 builder.create<fir::CoordinateOp>(loc, builder.getRefType(fieldType),
3016 arg1, field));
3017 return builder.create<mlir::arith::CmpIOp>(loc, pred, left, right);
3018 }
3019
3020 // IEEE_IS_FINITE
3021 mlir::Value
genIeeeIsFinite(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3022 IntrinsicLibrary::genIeeeIsFinite(mlir::Type resultType,
3023 llvm::ArrayRef<mlir::Value> args) {
3024 // IEEE_IS_FINITE(X) is true iff exponent(X) is the max exponent of kind(X).
3025 assert(args.size() == 1);
3026 mlir::Value floatVal = fir::getBase(args[0]);
3027 mlir::FloatType floatType = floatVal.getType().dyn_cast<mlir::FloatType>();
3028 int floatBits = floatType.getWidth();
3029 mlir::Type intType = builder.getIntegerType(
3030 floatType.isa<mlir::Float80Type>() ? 128 : floatBits);
3031 mlir::Value intVal =
3032 builder.create<mlir::arith::BitcastOp>(loc, intType, floatVal);
3033 int significandBits;
3034 if (floatType.isa<mlir::Float32Type>())
3035 significandBits = 23;
3036 else if (floatType.isa<mlir::Float64Type>())
3037 significandBits = 52;
3038 else // problems elsewhere for other kinds
3039 TODO(loc, "intrinsic module procedure: ieee_is_finite");
3040 mlir::Value significand =
3041 builder.createIntegerConstant(loc, intType, significandBits);
3042 int exponentBits = floatBits - 1 - significandBits;
3043 mlir::Value maxExponent =
3044 builder.createIntegerConstant(loc, intType, (1 << exponentBits) - 1);
3045 mlir::Value exponent = genIbits(
3046 intType, {intVal, significand,
3047 builder.createIntegerConstant(loc, intType, exponentBits)});
3048 return builder.createConvert(
3049 loc, resultType,
3050 builder.create<mlir::arith::CmpIOp>(loc, mlir::arith::CmpIPredicate::ne,
3051 exponent, maxExponent));
3052 }
3053
3054 // IEOR
genIeor(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3055 mlir::Value IntrinsicLibrary::genIeor(mlir::Type resultType,
3056 llvm::ArrayRef<mlir::Value> args) {
3057 assert(args.size() == 2);
3058 return builder.create<mlir::arith::XOrIOp>(loc, args[0], args[1]);
3059 }
3060
3061 // INDEX
3062 fir::ExtendedValue
genIndex(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3063 IntrinsicLibrary::genIndex(mlir::Type resultType,
3064 llvm::ArrayRef<fir::ExtendedValue> args) {
3065 assert(args.size() >= 2 && args.size() <= 4);
3066
3067 mlir::Value stringBase = fir::getBase(args[0]);
3068 fir::KindTy kind =
3069 fir::factory::CharacterExprHelper{builder, loc}.getCharacterKind(
3070 stringBase.getType());
3071 mlir::Value stringLen = fir::getLen(args[0]);
3072 mlir::Value substringBase = fir::getBase(args[1]);
3073 mlir::Value substringLen = fir::getLen(args[1]);
3074 mlir::Value back =
3075 isStaticallyAbsent(args, 2)
3076 ? builder.createIntegerConstant(loc, builder.getI1Type(), 0)
3077 : fir::getBase(args[2]);
3078 if (isStaticallyAbsent(args, 3))
3079 return builder.createConvert(
3080 loc, resultType,
3081 fir::runtime::genIndex(builder, loc, kind, stringBase, stringLen,
3082 substringBase, substringLen, back));
3083
3084 // Call the descriptor-based Index implementation
3085 mlir::Value string = builder.createBox(loc, args[0]);
3086 mlir::Value substring = builder.createBox(loc, args[1]);
3087 auto makeRefThenEmbox = [&](mlir::Value b) {
3088 fir::LogicalType logTy = fir::LogicalType::get(
3089 builder.getContext(), builder.getKindMap().defaultLogicalKind());
3090 mlir::Value temp = builder.createTemporary(loc, logTy);
3091 mlir::Value castb = builder.createConvert(loc, logTy, b);
3092 builder.create<fir::StoreOp>(loc, castb, temp);
3093 return builder.createBox(loc, temp);
3094 };
3095 mlir::Value backOpt = isStaticallyAbsent(args, 2)
3096 ? builder.create<fir::AbsentOp>(
3097 loc, fir::BoxType::get(builder.getI1Type()))
3098 : makeRefThenEmbox(fir::getBase(args[2]));
3099 mlir::Value kindVal = isStaticallyAbsent(args, 3)
3100 ? builder.createIntegerConstant(
3101 loc, builder.getIndexType(),
3102 builder.getKindMap().defaultIntegerKind())
3103 : fir::getBase(args[3]);
3104 // Create mutable fir.box to be passed to the runtime for the result.
3105 fir::MutableBoxValue mutBox =
3106 fir::factory::createTempMutableBox(builder, loc, resultType);
3107 mlir::Value resBox = fir::factory::getMutableIRBox(builder, loc, mutBox);
3108 // Call runtime. The runtime is allocating the result.
3109 fir::runtime::genIndexDescriptor(builder, loc, resBox, string, substring,
3110 backOpt, kindVal);
3111 // Read back the result from the mutable box.
3112 return readAndAddCleanUp(mutBox, resultType, "INDEX");
3113 }
3114
3115 // IOR
genIor(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3116 mlir::Value IntrinsicLibrary::genIor(mlir::Type resultType,
3117 llvm::ArrayRef<mlir::Value> args) {
3118 assert(args.size() == 2);
3119 return builder.create<mlir::arith::OrIOp>(loc, args[0], args[1]);
3120 }
3121
3122 // ISHFT
genIshft(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3123 mlir::Value IntrinsicLibrary::genIshft(mlir::Type resultType,
3124 llvm::ArrayRef<mlir::Value> args) {
3125 // A conformant ISHFT(I,SHIFT) call satisfies:
3126 // abs(SHIFT) <= BIT_SIZE(I)
3127 // Return: abs(SHIFT) >= BIT_SIZE(I)
3128 // ? 0
3129 // : SHIFT < 0
3130 // ? I >> abs(SHIFT)
3131 // : I << abs(SHIFT)
3132 assert(args.size() == 2);
3133 mlir::Value bitSize = builder.createIntegerConstant(
3134 loc, resultType, resultType.cast<mlir::IntegerType>().getWidth());
3135 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
3136 mlir::Value shift = builder.createConvert(loc, resultType, args[1]);
3137 mlir::Value absShift = genAbs(resultType, {shift});
3138 auto left = builder.create<mlir::arith::ShLIOp>(loc, args[0], absShift);
3139 auto right = builder.create<mlir::arith::ShRUIOp>(loc, args[0], absShift);
3140 auto shiftIsLarge = builder.create<mlir::arith::CmpIOp>(
3141 loc, mlir::arith::CmpIPredicate::sge, absShift, bitSize);
3142 auto shiftIsNegative = builder.create<mlir::arith::CmpIOp>(
3143 loc, mlir::arith::CmpIPredicate::slt, shift, zero);
3144 auto sel =
3145 builder.create<mlir::arith::SelectOp>(loc, shiftIsNegative, right, left);
3146 return builder.create<mlir::arith::SelectOp>(loc, shiftIsLarge, zero, sel);
3147 }
3148
3149 // ISHFTC
genIshftc(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3150 mlir::Value IntrinsicLibrary::genIshftc(mlir::Type resultType,
3151 llvm::ArrayRef<mlir::Value> args) {
3152 // A conformant ISHFTC(I,SHIFT,SIZE) call satisfies:
3153 // SIZE > 0
3154 // SIZE <= BIT_SIZE(I)
3155 // abs(SHIFT) <= SIZE
3156 // if SHIFT > 0
3157 // leftSize = abs(SHIFT)
3158 // rightSize = SIZE - abs(SHIFT)
3159 // else [if SHIFT < 0]
3160 // leftSize = SIZE - abs(SHIFT)
3161 // rightSize = abs(SHIFT)
3162 // unchanged = SIZE == BIT_SIZE(I) ? 0 : (I >> SIZE) << SIZE
3163 // leftMaskShift = BIT_SIZE(I) - leftSize
3164 // rightMaskShift = BIT_SIZE(I) - rightSize
3165 // left = (I >> rightSize) & (-1 >> leftMaskShift)
3166 // right = (I & (-1 >> rightMaskShift)) << leftSize
3167 // Return: SHIFT == 0 || SIZE == abs(SHIFT) ? I : (unchanged | left | right)
3168 assert(args.size() == 3);
3169 mlir::Value bitSize = builder.createIntegerConstant(
3170 loc, resultType, resultType.cast<mlir::IntegerType>().getWidth());
3171 mlir::Value I = args[0];
3172 mlir::Value shift = builder.createConvert(loc, resultType, args[1]);
3173 mlir::Value size =
3174 args[2] ? builder.createConvert(loc, resultType, args[2]) : bitSize;
3175 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
3176 mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
3177 mlir::Value absShift = genAbs(resultType, {shift});
3178 auto elseSize = builder.create<mlir::arith::SubIOp>(loc, size, absShift);
3179 auto shiftIsZero = builder.create<mlir::arith::CmpIOp>(
3180 loc, mlir::arith::CmpIPredicate::eq, shift, zero);
3181 auto shiftEqualsSize = builder.create<mlir::arith::CmpIOp>(
3182 loc, mlir::arith::CmpIPredicate::eq, absShift, size);
3183 auto shiftIsNop =
3184 builder.create<mlir::arith::OrIOp>(loc, shiftIsZero, shiftEqualsSize);
3185 auto shiftIsPositive = builder.create<mlir::arith::CmpIOp>(
3186 loc, mlir::arith::CmpIPredicate::sgt, shift, zero);
3187 auto leftSize = builder.create<mlir::arith::SelectOp>(loc, shiftIsPositive,
3188 absShift, elseSize);
3189 auto rightSize = builder.create<mlir::arith::SelectOp>(loc, shiftIsPositive,
3190 elseSize, absShift);
3191 auto hasUnchanged = builder.create<mlir::arith::CmpIOp>(
3192 loc, mlir::arith::CmpIPredicate::ne, size, bitSize);
3193 auto unchangedTmp1 = builder.create<mlir::arith::ShRUIOp>(loc, I, size);
3194 auto unchangedTmp2 =
3195 builder.create<mlir::arith::ShLIOp>(loc, unchangedTmp1, size);
3196 auto unchanged = builder.create<mlir::arith::SelectOp>(loc, hasUnchanged,
3197 unchangedTmp2, zero);
3198 auto leftMaskShift =
3199 builder.create<mlir::arith::SubIOp>(loc, bitSize, leftSize);
3200 auto leftMask =
3201 builder.create<mlir::arith::ShRUIOp>(loc, ones, leftMaskShift);
3202 auto leftTmp = builder.create<mlir::arith::ShRUIOp>(loc, I, rightSize);
3203 auto left = builder.create<mlir::arith::AndIOp>(loc, leftTmp, leftMask);
3204 auto rightMaskShift =
3205 builder.create<mlir::arith::SubIOp>(loc, bitSize, rightSize);
3206 auto rightMask =
3207 builder.create<mlir::arith::ShRUIOp>(loc, ones, rightMaskShift);
3208 auto rightTmp = builder.create<mlir::arith::AndIOp>(loc, I, rightMask);
3209 auto right = builder.create<mlir::arith::ShLIOp>(loc, rightTmp, leftSize);
3210 auto resTmp = builder.create<mlir::arith::OrIOp>(loc, unchanged, left);
3211 auto res = builder.create<mlir::arith::OrIOp>(loc, resTmp, right);
3212 return builder.create<mlir::arith::SelectOp>(loc, shiftIsNop, I, res);
3213 }
3214
3215 // LEADZ
genLeadz(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3216 mlir::Value IntrinsicLibrary::genLeadz(mlir::Type resultType,
3217 llvm::ArrayRef<mlir::Value> args) {
3218 assert(args.size() == 1);
3219
3220 mlir::Value result =
3221 builder.create<mlir::math::CountLeadingZerosOp>(loc, args);
3222
3223 return builder.createConvert(loc, resultType, result);
3224 }
3225
3226 // LEN
3227 // Note that this is only used for an unrestricted intrinsic LEN call.
3228 // Other uses of LEN are rewritten as descriptor inquiries by the front-end.
3229 fir::ExtendedValue
genLen(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3230 IntrinsicLibrary::genLen(mlir::Type resultType,
3231 llvm::ArrayRef<fir::ExtendedValue> args) {
3232 // Optional KIND argument reflected in result type and otherwise ignored.
3233 assert(args.size() == 1 || args.size() == 2);
3234 mlir::Value len = fir::factory::readCharLen(builder, loc, args[0]);
3235 return builder.createConvert(loc, resultType, len);
3236 }
3237
3238 // LEN_TRIM
3239 fir::ExtendedValue
genLenTrim(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3240 IntrinsicLibrary::genLenTrim(mlir::Type resultType,
3241 llvm::ArrayRef<fir::ExtendedValue> args) {
3242 // Optional KIND argument reflected in result type and otherwise ignored.
3243 assert(args.size() == 1 || args.size() == 2);
3244 const fir::CharBoxValue *charBox = args[0].getCharBox();
3245 if (!charBox)
3246 TODO(loc, "character array len_trim");
3247 auto len =
3248 fir::factory::CharacterExprHelper(builder, loc).createLenTrim(*charBox);
3249 return builder.createConvert(loc, resultType, len);
3250 }
3251
3252 // LGE, LGT, LLE, LLT
3253 template <mlir::arith::CmpIPredicate pred>
3254 fir::ExtendedValue
genCharacterCompare(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3255 IntrinsicLibrary::genCharacterCompare(mlir::Type resultType,
3256 llvm::ArrayRef<fir::ExtendedValue> args) {
3257 assert(args.size() == 2);
3258 return fir::runtime::genCharCompare(
3259 builder, loc, pred, fir::getBase(args[0]), fir::getLen(args[0]),
3260 fir::getBase(args[1]), fir::getLen(args[1]));
3261 }
3262
3263 // MASKL, MASKR
3264 template <typename Shift>
genMask(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3265 mlir::Value IntrinsicLibrary::genMask(mlir::Type resultType,
3266 llvm::ArrayRef<mlir::Value> args) {
3267 assert(args.size() == 2);
3268
3269 mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
3270 mlir::Value bitSize = builder.createIntegerConstant(
3271 loc, resultType, resultType.getIntOrFloatBitWidth());
3272 mlir::Value bitsToSet = builder.createConvert(loc, resultType, args[0]);
3273
3274 // The standard does not specify what to return if the number of bits to be
3275 // set, I < 0 or I >= BIT_SIZE(KIND). The shift instruction used below will
3276 // produce a poison value which may return a possibly platform-specific and/or
3277 // non-deterministic result. Other compilers don't produce a consistent result
3278 // in this case either, so we choose the most efficient implementation.
3279 mlir::Value shift =
3280 builder.create<mlir::arith::SubIOp>(loc, bitSize, bitsToSet);
3281 return builder.create<Shift>(loc, ones, shift);
3282 }
3283
3284 // MATMUL
3285 fir::ExtendedValue
genMatmul(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3286 IntrinsicLibrary::genMatmul(mlir::Type resultType,
3287 llvm::ArrayRef<fir::ExtendedValue> args) {
3288 assert(args.size() == 2);
3289
3290 // Handle required matmul arguments
3291 fir::BoxValue matrixTmpA = builder.createBox(loc, args[0]);
3292 mlir::Value matrixA = fir::getBase(matrixTmpA);
3293 fir::BoxValue matrixTmpB = builder.createBox(loc, args[1]);
3294 mlir::Value matrixB = fir::getBase(matrixTmpB);
3295 unsigned resultRank =
3296 (matrixTmpA.rank() == 1 || matrixTmpB.rank() == 1) ? 1 : 2;
3297
3298 // Create mutable fir.box to be passed to the runtime for the result.
3299 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, resultRank);
3300 fir::MutableBoxValue resultMutableBox =
3301 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
3302 mlir::Value resultIrBox =
3303 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3304 // Call runtime. The runtime is allocating the result.
3305 fir::runtime::genMatmul(builder, loc, resultIrBox, matrixA, matrixB);
3306 // Read result from mutable fir.box and add it to the list of temps to be
3307 // finalized by the StatementContext.
3308 return readAndAddCleanUp(resultMutableBox, resultType,
3309 "unexpected result for MATMUL");
3310 }
3311
3312 // MERGE
3313 fir::ExtendedValue
genMerge(mlir::Type,llvm::ArrayRef<fir::ExtendedValue> args)3314 IntrinsicLibrary::genMerge(mlir::Type,
3315 llvm::ArrayRef<fir::ExtendedValue> args) {
3316 assert(args.size() == 3);
3317 mlir::Value tsource = fir::getBase(args[0]);
3318 mlir::Value fsource = fir::getBase(args[1]);
3319 mlir::Value rawMask = fir::getBase(args[2]);
3320 mlir::Type type0 = fir::unwrapRefType(tsource.getType());
3321 bool isCharRslt = fir::isa_char(type0); // result is same as first argument
3322 mlir::Value mask = builder.createConvert(loc, builder.getI1Type(), rawMask);
3323 // FSOURCE has the same type as TSOURCE, but they may not have the same MLIR
3324 // types (one can have dynamic length while the other has constant lengths,
3325 // or one may be a fir.logical<> while the other is an i1). Insert a cast to
3326 // fulfill mlir::SelectOp constraint that the MLIR types must be the same.
3327 mlir::Value fsourceCast =
3328 builder.createConvert(loc, tsource.getType(), fsource);
3329 auto rslt =
3330 builder.create<mlir::arith::SelectOp>(loc, mask, tsource, fsourceCast);
3331 if (isCharRslt) {
3332 // Need a CharBoxValue for character results
3333 const fir::CharBoxValue *charBox = args[0].getCharBox();
3334 fir::CharBoxValue charRslt(rslt, charBox->getLen());
3335 return charRslt;
3336 }
3337 return rslt;
3338 }
3339
3340 // MERGE_BITS
genMergeBits(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3341 mlir::Value IntrinsicLibrary::genMergeBits(mlir::Type resultType,
3342 llvm::ArrayRef<mlir::Value> args) {
3343 assert(args.size() == 3);
3344
3345 mlir::Value i = builder.createConvert(loc, resultType, args[0]);
3346 mlir::Value j = builder.createConvert(loc, resultType, args[1]);
3347 mlir::Value mask = builder.createConvert(loc, resultType, args[2]);
3348 mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
3349
3350 // MERGE_BITS(I, J, MASK) = IOR(IAND(I, MASK), IAND(J, NOT(MASK)))
3351 mlir::Value notMask = builder.create<mlir::arith::XOrIOp>(loc, mask, ones);
3352 mlir::Value lft = builder.create<mlir::arith::AndIOp>(loc, i, mask);
3353 mlir::Value rgt = builder.create<mlir::arith::AndIOp>(loc, j, notMask);
3354
3355 return builder.create<mlir::arith::OrIOp>(loc, lft, rgt);
3356 }
3357
3358 // MOD
genMod(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3359 mlir::Value IntrinsicLibrary::genMod(mlir::Type resultType,
3360 llvm::ArrayRef<mlir::Value> args) {
3361 assert(args.size() == 2);
3362 if (resultType.isa<mlir::IntegerType>())
3363 return builder.create<mlir::arith::RemSIOp>(loc, args[0], args[1]);
3364
3365 // Use runtime. Note that mlir::arith::RemFOp implements floating point
3366 // remainder, but it does not work with fir::Real type.
3367 // TODO: consider using mlir::arith::RemFOp when possible, that may help
3368 // folding and optimizations.
3369 return genRuntimeCall("mod", resultType, args);
3370 }
3371
3372 // MODULO
genModulo(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3373 mlir::Value IntrinsicLibrary::genModulo(mlir::Type resultType,
3374 llvm::ArrayRef<mlir::Value> args) {
3375 assert(args.size() == 2);
3376 // No floored modulo op in LLVM/MLIR yet. TODO: add one to MLIR.
3377 // In the meantime, use a simple inlined implementation based on truncated
3378 // modulo (MOD(A, P) implemented by RemIOp, RemFOp). This avoids making manual
3379 // division and multiplication from MODULO formula.
3380 // - If A/P > 0 or MOD(A,P)=0, then INT(A/P) = FLOOR(A/P), and MODULO = MOD.
3381 // - Otherwise, when A/P < 0 and MOD(A,P) !=0, then MODULO(A, P) =
3382 // A-FLOOR(A/P)*P = A-(INT(A/P)-1)*P = A-INT(A/P)*P+P = MOD(A,P)+P
3383 // Note that A/P < 0 if and only if A and P signs are different.
3384 if (resultType.isa<mlir::IntegerType>()) {
3385 auto remainder =
3386 builder.create<mlir::arith::RemSIOp>(loc, args[0], args[1]);
3387 auto argXor = builder.create<mlir::arith::XOrIOp>(loc, args[0], args[1]);
3388 mlir::Value zero = builder.createIntegerConstant(loc, argXor.getType(), 0);
3389 auto argSignDifferent = builder.create<mlir::arith::CmpIOp>(
3390 loc, mlir::arith::CmpIPredicate::slt, argXor, zero);
3391 auto remainderIsNotZero = builder.create<mlir::arith::CmpIOp>(
3392 loc, mlir::arith::CmpIPredicate::ne, remainder, zero);
3393 auto mustAddP = builder.create<mlir::arith::AndIOp>(loc, remainderIsNotZero,
3394 argSignDifferent);
3395 auto remPlusP =
3396 builder.create<mlir::arith::AddIOp>(loc, remainder, args[1]);
3397 return builder.create<mlir::arith::SelectOp>(loc, mustAddP, remPlusP,
3398 remainder);
3399 }
3400 // Real case
3401 auto remainder = builder.create<mlir::arith::RemFOp>(loc, args[0], args[1]);
3402 mlir::Value zero = builder.createRealZeroConstant(loc, remainder.getType());
3403 auto remainderIsNotZero = builder.create<mlir::arith::CmpFOp>(
3404 loc, mlir::arith::CmpFPredicate::UNE, remainder, zero);
3405 auto aLessThanZero = builder.create<mlir::arith::CmpFOp>(
3406 loc, mlir::arith::CmpFPredicate::OLT, args[0], zero);
3407 auto pLessThanZero = builder.create<mlir::arith::CmpFOp>(
3408 loc, mlir::arith::CmpFPredicate::OLT, args[1], zero);
3409 auto argSignDifferent =
3410 builder.create<mlir::arith::XOrIOp>(loc, aLessThanZero, pLessThanZero);
3411 auto mustAddP = builder.create<mlir::arith::AndIOp>(loc, remainderIsNotZero,
3412 argSignDifferent);
3413 auto remPlusP = builder.create<mlir::arith::AddFOp>(loc, remainder, args[1]);
3414 return builder.create<mlir::arith::SelectOp>(loc, mustAddP, remPlusP,
3415 remainder);
3416 }
3417
3418 // MVBITS
genMvbits(llvm::ArrayRef<fir::ExtendedValue> args)3419 void IntrinsicLibrary::genMvbits(llvm::ArrayRef<fir::ExtendedValue> args) {
3420 // A conformant MVBITS(FROM,FROMPOS,LEN,TO,TOPOS) call satisfies:
3421 // FROMPOS >= 0
3422 // LEN >= 0
3423 // TOPOS >= 0
3424 // FROMPOS + LEN <= BIT_SIZE(FROM)
3425 // TOPOS + LEN <= BIT_SIZE(TO)
3426 // MASK = -1 >> (BIT_SIZE(FROM) - LEN)
3427 // TO = LEN == 0 ? TO : ((!(MASK << TOPOS)) & TO) |
3428 // (((FROM >> FROMPOS) & MASK) << TOPOS)
3429 assert(args.size() == 5);
3430 auto unbox = [&](fir::ExtendedValue exv) {
3431 const mlir::Value *arg = exv.getUnboxed();
3432 assert(arg && "nonscalar mvbits argument");
3433 return *arg;
3434 };
3435 mlir::Value from = unbox(args[0]);
3436 mlir::Type resultType = from.getType();
3437 mlir::Value frompos = builder.createConvert(loc, resultType, unbox(args[1]));
3438 mlir::Value len = builder.createConvert(loc, resultType, unbox(args[2]));
3439 mlir::Value toAddr = unbox(args[3]);
3440 assert(fir::dyn_cast_ptrEleTy(toAddr.getType()) == resultType &&
3441 "mismatched mvbits types");
3442 auto to = builder.create<fir::LoadOp>(loc, resultType, toAddr);
3443 mlir::Value topos = builder.createConvert(loc, resultType, unbox(args[4]));
3444 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
3445 mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
3446 mlir::Value bitSize = builder.createIntegerConstant(
3447 loc, resultType, resultType.cast<mlir::IntegerType>().getWidth());
3448 auto shiftCount = builder.create<mlir::arith::SubIOp>(loc, bitSize, len);
3449 auto mask = builder.create<mlir::arith::ShRUIOp>(loc, ones, shiftCount);
3450 auto unchangedTmp1 = builder.create<mlir::arith::ShLIOp>(loc, mask, topos);
3451 auto unchangedTmp2 =
3452 builder.create<mlir::arith::XOrIOp>(loc, unchangedTmp1, ones);
3453 auto unchanged = builder.create<mlir::arith::AndIOp>(loc, unchangedTmp2, to);
3454 auto frombitsTmp1 = builder.create<mlir::arith::ShRUIOp>(loc, from, frompos);
3455 auto frombitsTmp2 =
3456 builder.create<mlir::arith::AndIOp>(loc, frombitsTmp1, mask);
3457 auto frombits = builder.create<mlir::arith::ShLIOp>(loc, frombitsTmp2, topos);
3458 auto resTmp = builder.create<mlir::arith::OrIOp>(loc, unchanged, frombits);
3459 auto lenIsZero = builder.create<mlir::arith::CmpIOp>(
3460 loc, mlir::arith::CmpIPredicate::eq, len, zero);
3461 auto res = builder.create<mlir::arith::SelectOp>(loc, lenIsZero, to, resTmp);
3462 builder.create<fir::StoreOp>(loc, res, toAddr);
3463 }
3464
3465 // NEAREST
genNearest(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3466 mlir::Value IntrinsicLibrary::genNearest(mlir::Type resultType,
3467 llvm::ArrayRef<mlir::Value> args) {
3468 assert(args.size() == 2);
3469
3470 mlir::Value realX = fir::getBase(args[0]);
3471 mlir::Value realS = fir::getBase(args[1]);
3472
3473 return builder.createConvert(
3474 loc, resultType, fir::runtime::genNearest(builder, loc, realX, realS));
3475 }
3476
3477 // NINT
genNint(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3478 mlir::Value IntrinsicLibrary::genNint(mlir::Type resultType,
3479 llvm::ArrayRef<mlir::Value> args) {
3480 assert(args.size() >= 1);
3481 // Skip optional kind argument to search the runtime; it is already reflected
3482 // in result type.
3483 return genRuntimeCall("nint", resultType, {args[0]});
3484 }
3485
3486 // NOT
genNot(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3487 mlir::Value IntrinsicLibrary::genNot(mlir::Type resultType,
3488 llvm::ArrayRef<mlir::Value> args) {
3489 assert(args.size() == 1);
3490 mlir::Value allOnes = builder.createIntegerConstant(loc, resultType, -1);
3491 return builder.create<mlir::arith::XOrIOp>(loc, args[0], allOnes);
3492 }
3493
3494 // NULL
3495 fir::ExtendedValue
genNull(mlir::Type,llvm::ArrayRef<fir::ExtendedValue> args)3496 IntrinsicLibrary::genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue> args) {
3497 // NULL() without MOLD must be handled in the contexts where it can appear
3498 // (see table 16.5 of Fortran 2018 standard).
3499 assert(args.size() == 1 && isStaticallyPresent(args[0]) &&
3500 "MOLD argument required to lower NULL outside of any context");
3501 const auto *mold = args[0].getBoxOf<fir::MutableBoxValue>();
3502 assert(mold && "MOLD must be a pointer or allocatable");
3503 fir::BoxType boxType = mold->getBoxTy();
3504 mlir::Value boxStorage = builder.createTemporary(loc, boxType);
3505 mlir::Value box = fir::factory::createUnallocatedBox(
3506 builder, loc, boxType, mold->nonDeferredLenParams());
3507 builder.create<fir::StoreOp>(loc, box, boxStorage);
3508 return fir::MutableBoxValue(boxStorage, mold->nonDeferredLenParams(), {});
3509 }
3510
3511 // PACK
3512 fir::ExtendedValue
genPack(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3513 IntrinsicLibrary::genPack(mlir::Type resultType,
3514 llvm::ArrayRef<fir::ExtendedValue> args) {
3515 [[maybe_unused]] auto numArgs = args.size();
3516 assert(numArgs == 2 || numArgs == 3);
3517
3518 // Handle required array argument
3519 mlir::Value array = builder.createBox(loc, args[0]);
3520
3521 // Handle required mask argument
3522 mlir::Value mask = builder.createBox(loc, args[1]);
3523
3524 // Handle optional vector argument
3525 mlir::Value vector = isStaticallyAbsent(args, 2)
3526 ? builder.create<fir::AbsentOp>(
3527 loc, fir::BoxType::get(builder.getI1Type()))
3528 : builder.createBox(loc, args[2]);
3529
3530 // Create mutable fir.box to be passed to the runtime for the result.
3531 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, 1);
3532 fir::MutableBoxValue resultMutableBox =
3533 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
3534 mlir::Value resultIrBox =
3535 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3536
3537 fir::runtime::genPack(builder, loc, resultIrBox, array, mask, vector);
3538
3539 return readAndAddCleanUp(resultMutableBox, resultType,
3540 "unexpected result for PACK");
3541 }
3542
3543 // POPCNT
genPopcnt(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3544 mlir::Value IntrinsicLibrary::genPopcnt(mlir::Type resultType,
3545 llvm::ArrayRef<mlir::Value> args) {
3546 assert(args.size() == 1);
3547
3548 mlir::Value count = builder.create<mlir::math::CtPopOp>(loc, args);
3549
3550 return builder.createConvert(loc, resultType, count);
3551 }
3552
3553 // POPPAR
genPoppar(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3554 mlir::Value IntrinsicLibrary::genPoppar(mlir::Type resultType,
3555 llvm::ArrayRef<mlir::Value> args) {
3556 assert(args.size() == 1);
3557
3558 mlir::Value count = genPopcnt(resultType, args);
3559 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
3560
3561 return builder.create<mlir::arith::AndIOp>(loc, count, one);
3562 }
3563
3564 // PRESENT
3565 fir::ExtendedValue
genPresent(mlir::Type,llvm::ArrayRef<fir::ExtendedValue> args)3566 IntrinsicLibrary::genPresent(mlir::Type,
3567 llvm::ArrayRef<fir::ExtendedValue> args) {
3568 assert(args.size() == 1);
3569 return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
3570 fir::getBase(args[0]));
3571 }
3572
3573 // PRODUCT
3574 fir::ExtendedValue
genProduct(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3575 IntrinsicLibrary::genProduct(mlir::Type resultType,
3576 llvm::ArrayRef<fir::ExtendedValue> args) {
3577 return genProdOrSum(fir::runtime::genProduct, fir::runtime::genProductDim,
3578 resultType, builder, loc, stmtCtx,
3579 "unexpected result for Product", args);
3580 }
3581
3582 // RANDOM_INIT
genRandomInit(llvm::ArrayRef<fir::ExtendedValue> args)3583 void IntrinsicLibrary::genRandomInit(llvm::ArrayRef<fir::ExtendedValue> args) {
3584 assert(args.size() == 2);
3585 Fortran::lower::genRandomInit(builder, loc, fir::getBase(args[0]),
3586 fir::getBase(args[1]));
3587 }
3588
3589 // RANDOM_NUMBER
genRandomNumber(llvm::ArrayRef<fir::ExtendedValue> args)3590 void IntrinsicLibrary::genRandomNumber(
3591 llvm::ArrayRef<fir::ExtendedValue> args) {
3592 assert(args.size() == 1);
3593 Fortran::lower::genRandomNumber(builder, loc, fir::getBase(args[0]));
3594 }
3595
3596 // RANDOM_SEED
genRandomSeed(llvm::ArrayRef<fir::ExtendedValue> args)3597 void IntrinsicLibrary::genRandomSeed(llvm::ArrayRef<fir::ExtendedValue> args) {
3598 assert(args.size() == 3);
3599 for (int i = 0; i < 3; ++i)
3600 if (isStaticallyPresent(args[i])) {
3601 Fortran::lower::genRandomSeed(builder, loc, i, fir::getBase(args[i]));
3602 return;
3603 }
3604 Fortran::lower::genRandomSeed(builder, loc, -1, mlir::Value{});
3605 }
3606
3607 // REPEAT
3608 fir::ExtendedValue
genRepeat(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3609 IntrinsicLibrary::genRepeat(mlir::Type resultType,
3610 llvm::ArrayRef<fir::ExtendedValue> args) {
3611 assert(args.size() == 2);
3612 mlir::Value string = builder.createBox(loc, args[0]);
3613 mlir::Value ncopies = fir::getBase(args[1]);
3614 // Create mutable fir.box to be passed to the runtime for the result.
3615 fir::MutableBoxValue resultMutableBox =
3616 fir::factory::createTempMutableBox(builder, loc, resultType);
3617 mlir::Value resultIrBox =
3618 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3619 // Call runtime. The runtime is allocating the result.
3620 fir::runtime::genRepeat(builder, loc, resultIrBox, string, ncopies);
3621 // Read result from mutable fir.box and add it to the list of temps to be
3622 // finalized by the StatementContext.
3623 return readAndAddCleanUp(resultMutableBox, resultType, "REPEAT");
3624 }
3625
3626 // RESHAPE
3627 fir::ExtendedValue
genReshape(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3628 IntrinsicLibrary::genReshape(mlir::Type resultType,
3629 llvm::ArrayRef<fir::ExtendedValue> args) {
3630 assert(args.size() == 4);
3631
3632 // Handle source argument
3633 mlir::Value source = builder.createBox(loc, args[0]);
3634
3635 // Handle shape argument
3636 mlir::Value shape = builder.createBox(loc, args[1]);
3637 assert(fir::BoxValue(shape).rank() == 1);
3638 mlir::Type shapeTy = shape.getType();
3639 mlir::Type shapeArrTy = fir::dyn_cast_ptrOrBoxEleTy(shapeTy);
3640 auto resultRank = shapeArrTy.cast<fir::SequenceType>().getShape()[0];
3641
3642 if (resultRank == fir::SequenceType::getUnknownExtent())
3643 TODO(loc, "RESHAPE intrinsic requires computing rank of result");
3644
3645 // Handle optional pad argument
3646 mlir::Value pad = isStaticallyAbsent(args[2])
3647 ? builder.create<fir::AbsentOp>(
3648 loc, fir::BoxType::get(builder.getI1Type()))
3649 : builder.createBox(loc, args[2]);
3650
3651 // Handle optional order argument
3652 mlir::Value order = isStaticallyAbsent(args[3])
3653 ? builder.create<fir::AbsentOp>(
3654 loc, fir::BoxType::get(builder.getI1Type()))
3655 : builder.createBox(loc, args[3]);
3656
3657 // Create mutable fir.box to be passed to the runtime for the result.
3658 mlir::Type type = builder.getVarLenSeqTy(resultType, resultRank);
3659 fir::MutableBoxValue resultMutableBox =
3660 fir::factory::createTempMutableBox(builder, loc, type);
3661
3662 mlir::Value resultIrBox =
3663 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3664
3665 fir::runtime::genReshape(builder, loc, resultIrBox, source, shape, pad,
3666 order);
3667
3668 return readAndAddCleanUp(resultMutableBox, resultType,
3669 "unexpected result for RESHAPE");
3670 }
3671
3672 // RRSPACING
genRRSpacing(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3673 mlir::Value IntrinsicLibrary::genRRSpacing(mlir::Type resultType,
3674 llvm::ArrayRef<mlir::Value> args) {
3675 assert(args.size() == 1);
3676
3677 return builder.createConvert(
3678 loc, resultType,
3679 fir::runtime::genRRSpacing(builder, loc, fir::getBase(args[0])));
3680 }
3681
3682 // SCALE
genScale(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3683 mlir::Value IntrinsicLibrary::genScale(mlir::Type resultType,
3684 llvm::ArrayRef<mlir::Value> args) {
3685 assert(args.size() == 2);
3686
3687 mlir::Value realX = fir::getBase(args[0]);
3688 mlir::Value intI = fir::getBase(args[1]);
3689
3690 return builder.createConvert(
3691 loc, resultType, fir::runtime::genScale(builder, loc, realX, intI));
3692 }
3693
3694 // SCAN
3695 fir::ExtendedValue
genScan(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3696 IntrinsicLibrary::genScan(mlir::Type resultType,
3697 llvm::ArrayRef<fir::ExtendedValue> args) {
3698
3699 assert(args.size() == 4);
3700
3701 if (isStaticallyAbsent(args[3])) {
3702 // Kind not specified, so call scan/verify runtime routine that is
3703 // specialized on the kind of characters in string.
3704
3705 // Handle required string base arg
3706 mlir::Value stringBase = fir::getBase(args[0]);
3707
3708 // Handle required set string base arg
3709 mlir::Value setBase = fir::getBase(args[1]);
3710
3711 // Handle kind argument; it is the kind of character in this case
3712 fir::KindTy kind =
3713 fir::factory::CharacterExprHelper{builder, loc}.getCharacterKind(
3714 stringBase.getType());
3715
3716 // Get string length argument
3717 mlir::Value stringLen = fir::getLen(args[0]);
3718
3719 // Get set string length argument
3720 mlir::Value setLen = fir::getLen(args[1]);
3721
3722 // Handle optional back argument
3723 mlir::Value back =
3724 isStaticallyAbsent(args[2])
3725 ? builder.createIntegerConstant(loc, builder.getI1Type(), 0)
3726 : fir::getBase(args[2]);
3727
3728 return builder.createConvert(loc, resultType,
3729 fir::runtime::genScan(builder, loc, kind,
3730 stringBase, stringLen,
3731 setBase, setLen, back));
3732 }
3733 // else use the runtime descriptor version of scan/verify
3734
3735 // Handle optional argument, back
3736 auto makeRefThenEmbox = [&](mlir::Value b) {
3737 fir::LogicalType logTy = fir::LogicalType::get(
3738 builder.getContext(), builder.getKindMap().defaultLogicalKind());
3739 mlir::Value temp = builder.createTemporary(loc, logTy);
3740 mlir::Value castb = builder.createConvert(loc, logTy, b);
3741 builder.create<fir::StoreOp>(loc, castb, temp);
3742 return builder.createBox(loc, temp);
3743 };
3744 mlir::Value back = fir::isUnboxedValue(args[2])
3745 ? makeRefThenEmbox(*args[2].getUnboxed())
3746 : builder.create<fir::AbsentOp>(
3747 loc, fir::BoxType::get(builder.getI1Type()));
3748
3749 // Handle required string argument
3750 mlir::Value string = builder.createBox(loc, args[0]);
3751
3752 // Handle required set argument
3753 mlir::Value set = builder.createBox(loc, args[1]);
3754
3755 // Handle kind argument
3756 mlir::Value kind = fir::getBase(args[3]);
3757
3758 // Create result descriptor
3759 fir::MutableBoxValue resultMutableBox =
3760 fir::factory::createTempMutableBox(builder, loc, resultType);
3761 mlir::Value resultIrBox =
3762 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
3763
3764 fir::runtime::genScanDescriptor(builder, loc, resultIrBox, string, set, back,
3765 kind);
3766
3767 // Handle cleanup of allocatable result descriptor and return
3768 return readAndAddCleanUp(resultMutableBox, resultType, "SCAN");
3769 }
3770
3771 // SELECTED_INT_KIND
3772 mlir::Value
genSelectedIntKind(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3773 IntrinsicLibrary::genSelectedIntKind(mlir::Type resultType,
3774 llvm::ArrayRef<mlir::Value> args) {
3775 assert(args.size() == 1);
3776
3777 return builder.createConvert(
3778 loc, resultType,
3779 fir::runtime::genSelectedIntKind(builder, loc, fir::getBase(args[0])));
3780 }
3781
3782 // SELECTED_REAL_KIND
3783 mlir::Value
genSelectedRealKind(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3784 IntrinsicLibrary::genSelectedRealKind(mlir::Type resultType,
3785 llvm::ArrayRef<mlir::Value> args) {
3786 assert(args.size() == 3);
3787
3788 // Handle optional precision(P) argument
3789 mlir::Value precision =
3790 isStaticallyAbsent(args[0])
3791 ? builder.create<fir::AbsentOp>(
3792 loc, fir::ReferenceType::get(builder.getI1Type()))
3793 : fir::getBase(args[0]);
3794
3795 // Handle optional range(R) argument
3796 mlir::Value range =
3797 isStaticallyAbsent(args[1])
3798 ? builder.create<fir::AbsentOp>(
3799 loc, fir::ReferenceType::get(builder.getI1Type()))
3800 : fir::getBase(args[1]);
3801
3802 // Handle optional radix(RADIX) argument
3803 mlir::Value radix =
3804 isStaticallyAbsent(args[2])
3805 ? builder.create<fir::AbsentOp>(
3806 loc, fir::ReferenceType::get(builder.getI1Type()))
3807 : fir::getBase(args[2]);
3808
3809 return builder.createConvert(
3810 loc, resultType,
3811 fir::runtime::genSelectedRealKind(builder, loc, precision, range, radix));
3812 }
3813
3814 // SET_EXPONENT
genSetExponent(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3815 mlir::Value IntrinsicLibrary::genSetExponent(mlir::Type resultType,
3816 llvm::ArrayRef<mlir::Value> args) {
3817 assert(args.size() == 2);
3818
3819 return builder.createConvert(
3820 loc, resultType,
3821 fir::runtime::genSetExponent(builder, loc, fir::getBase(args[0]),
3822 fir::getBase(args[1])));
3823 }
3824
3825 // SHIFTA, SHIFTL, SHIFTR
3826 template <typename Shift>
genShift(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3827 mlir::Value IntrinsicLibrary::genShift(mlir::Type resultType,
3828 llvm::ArrayRef<mlir::Value> args) {
3829 assert(args.size() == 2);
3830
3831 // If SHIFT < 0 or SHIFT >= BIT_SIZE(I), return 0. This is not required by
3832 // the standard. However, several other compilers behave this way, so try and
3833 // maintain compatibility with them to an extent.
3834
3835 unsigned bits = resultType.getIntOrFloatBitWidth();
3836 mlir::Value bitSize = builder.createIntegerConstant(loc, resultType, bits);
3837 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
3838 mlir::Value shift = builder.createConvert(loc, resultType, args[1]);
3839
3840 mlir::Value tooSmall = builder.create<mlir::arith::CmpIOp>(
3841 loc, mlir::arith::CmpIPredicate::slt, shift, zero);
3842 mlir::Value tooLarge = builder.create<mlir::arith::CmpIOp>(
3843 loc, mlir::arith::CmpIPredicate::sge, shift, bitSize);
3844 mlir::Value outOfBounds =
3845 builder.create<mlir::arith::OrIOp>(loc, tooSmall, tooLarge);
3846
3847 mlir::Value shifted = builder.create<Shift>(loc, args[0], shift);
3848 return builder.create<mlir::arith::SelectOp>(loc, outOfBounds, zero, shifted);
3849 }
3850
3851 // SIGN
genSign(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3852 mlir::Value IntrinsicLibrary::genSign(mlir::Type resultType,
3853 llvm::ArrayRef<mlir::Value> args) {
3854 assert(args.size() == 2);
3855 if (resultType.isa<mlir::IntegerType>()) {
3856 mlir::Value abs = genAbs(resultType, {args[0]});
3857 mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
3858 auto neg = builder.create<mlir::arith::SubIOp>(loc, zero, abs);
3859 auto cmp = builder.create<mlir::arith::CmpIOp>(
3860 loc, mlir::arith::CmpIPredicate::slt, args[1], zero);
3861 return builder.create<mlir::arith::SelectOp>(loc, cmp, neg, abs);
3862 }
3863 return genRuntimeCall("sign", resultType, args);
3864 }
3865
3866 // SIZE
3867 fir::ExtendedValue
genSize(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)3868 IntrinsicLibrary::genSize(mlir::Type resultType,
3869 llvm::ArrayRef<fir::ExtendedValue> args) {
3870 // Note that the value of the KIND argument is already reflected in the
3871 // resultType
3872 assert(args.size() == 3);
3873 if (const auto *boxValue = args[0].getBoxOf<fir::BoxValue>())
3874 if (boxValue->hasAssumedRank())
3875 TODO(loc, "SIZE intrinsic with assumed rank argument");
3876
3877 // Get the ARRAY argument
3878 mlir::Value array = builder.createBox(loc, args[0]);
3879
3880 // The front-end rewrites SIZE without the DIM argument to
3881 // an array of SIZE with DIM in most cases, but it may not be
3882 // possible in some cases like when in SIZE(function_call()).
3883 if (isStaticallyAbsent(args, 1))
3884 return builder.createConvert(loc, resultType,
3885 fir::runtime::genSize(builder, loc, array));
3886
3887 // Get the DIM argument.
3888 mlir::Value dim = fir::getBase(args[1]);
3889 if (!fir::isa_ref_type(dim.getType()))
3890 return builder.createConvert(
3891 loc, resultType, fir::runtime::genSizeDim(builder, loc, array, dim));
3892
3893 mlir::Value isDynamicallyAbsent = builder.genIsNullAddr(loc, dim);
3894 return builder
3895 .genIfOp(loc, {resultType}, isDynamicallyAbsent,
3896 /*withElseRegion=*/true)
3897 .genThen([&]() {
3898 mlir::Value size = builder.createConvert(
3899 loc, resultType, fir::runtime::genSize(builder, loc, array));
3900 builder.create<fir::ResultOp>(loc, size);
3901 })
3902 .genElse([&]() {
3903 mlir::Value dimValue = builder.create<fir::LoadOp>(loc, dim);
3904 mlir::Value size = builder.createConvert(
3905 loc, resultType,
3906 fir::runtime::genSizeDim(builder, loc, array, dimValue));
3907 builder.create<fir::ResultOp>(loc, size);
3908 })
3909 .getResults()[0];
3910 }
3911
3912 // TRAILZ
genTrailz(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)3913 mlir::Value IntrinsicLibrary::genTrailz(mlir::Type resultType,
3914 llvm::ArrayRef<mlir::Value> args) {
3915 assert(args.size() == 1);
3916
3917 mlir::Value result =
3918 builder.create<mlir::math::CountTrailingZerosOp>(loc, args);
3919
3920 return builder.createConvert(loc, resultType, result);
3921 }
3922
hasDefaultLowerBound(const fir::ExtendedValue & exv)3923 static bool hasDefaultLowerBound(const fir::ExtendedValue &exv) {
3924 return exv.match(
3925 [](const fir::ArrayBoxValue &arr) { return arr.getLBounds().empty(); },
3926 [](const fir::CharArrayBoxValue &arr) {
3927 return arr.getLBounds().empty();
3928 },
3929 [](const fir::BoxValue &arr) { return arr.getLBounds().empty(); },
3930 [](const auto &) { return false; });
3931 }
3932
3933 /// Compute the lower bound in dimension \p dim (zero based) of \p array
3934 /// taking care of returning one when the related extent is zero.
computeLBOUND(fir::FirOpBuilder & builder,mlir::Location loc,const fir::ExtendedValue & array,unsigned dim,mlir::Value zero,mlir::Value one)3935 static mlir::Value computeLBOUND(fir::FirOpBuilder &builder, mlir::Location loc,
3936 const fir::ExtendedValue &array, unsigned dim,
3937 mlir::Value zero, mlir::Value one) {
3938 assert(dim < array.rank() && "invalid dimension");
3939 if (hasDefaultLowerBound(array))
3940 return one;
3941 mlir::Value lb = fir::factory::readLowerBound(builder, loc, array, dim, one);
3942 if (dim + 1 == array.rank() && array.isAssumedSize())
3943 return lb;
3944 mlir::Value extent = fir::factory::readExtent(builder, loc, array, dim);
3945 zero = builder.createConvert(loc, extent.getType(), zero);
3946 auto dimIsEmpty = builder.create<mlir::arith::CmpIOp>(
3947 loc, mlir::arith::CmpIPredicate::eq, extent, zero);
3948 one = builder.createConvert(loc, lb.getType(), one);
3949 return builder.create<mlir::arith::SelectOp>(loc, dimIsEmpty, one, lb);
3950 }
3951
3952 /// Create a fir.box to be passed to the LBOUND runtime.
3953 /// This ensure that local lower bounds of assumed shape are propagated and that
3954 /// a fir.box with equivalent LBOUNDs but an explicit shape is created for
3955 /// assumed size arrays to avoid undefined behaviors in codegen or the runtime.
createBoxForLBOUND(mlir::Location loc,fir::FirOpBuilder & builder,const fir::ExtendedValue & array)3956 static mlir::Value createBoxForLBOUND(mlir::Location loc,
3957 fir::FirOpBuilder &builder,
3958 const fir::ExtendedValue &array) {
3959 if (!array.isAssumedSize())
3960 return array.match(
3961 [&](const fir::BoxValue &boxValue) -> mlir::Value {
3962 // This entity is mapped to a fir.box that may not contain the local
3963 // lower bound information if it is a dummy. Rebox it with the local
3964 // shape information.
3965 mlir::Value localShape = builder.createShape(loc, array);
3966 mlir::Value oldBox = boxValue.getAddr();
3967 return builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
3968 localShape,
3969 /*slice=*/mlir::Value{});
3970 },
3971 [&](const auto &) -> mlir::Value {
3972 // This a pointer/allocatable, or an entity not yet tracked with a
3973 // fir.box. For pointer/allocatable, createBox will forward the
3974 // descriptor that contains the correct lower bound information. For
3975 // other entities, a new fir.box will be made with the local lower
3976 // bounds.
3977 return builder.createBox(loc, array);
3978 });
3979 // Assumed sized are not meant to be emboxed. This could cause the undefined
3980 // extent cannot safely be understood by the runtime/codegen that will
3981 // consider that the dimension is empty and that the related LBOUND value must
3982 // be one. Pretend that the related extent is one to get the correct LBOUND
3983 // value.
3984 llvm::SmallVector<mlir::Value> shape =
3985 fir::factory::getExtents(loc, builder, array);
3986 assert(!shape.empty() && "assumed size must have at least one dimension");
3987 shape.back() = builder.createIntegerConstant(loc, builder.getIndexType(), 1);
3988 auto safeToEmbox = array.match(
3989 [&](const fir::CharArrayBoxValue &x) -> fir::ExtendedValue {
3990 return fir::CharArrayBoxValue{x.getAddr(), x.getLen(), shape,
3991 x.getLBounds()};
3992 },
3993 [&](const fir::ArrayBoxValue &x) -> fir::ExtendedValue {
3994 return fir::ArrayBoxValue{x.getAddr(), shape, x.getLBounds()};
3995 },
3996 [&](const auto &) -> fir::ExtendedValue {
3997 fir::emitFatalError(loc, "not an assumed size array");
3998 });
3999 return builder.createBox(loc, safeToEmbox);
4000 }
4001
4002 // LBOUND
4003 fir::ExtendedValue
genLbound(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4004 IntrinsicLibrary::genLbound(mlir::Type resultType,
4005 llvm::ArrayRef<fir::ExtendedValue> args) {
4006 assert(args.size() == 2 || args.size() == 3);
4007 const fir::ExtendedValue &array = args[0];
4008 if (const auto *boxValue = array.getBoxOf<fir::BoxValue>())
4009 if (boxValue->hasAssumedRank())
4010 TODO(loc, "LBOUND intrinsic with assumed rank argument");
4011
4012 //===----------------------------------------------------------------------===//
4013 mlir::Type indexType = builder.getIndexType();
4014
4015 // Semantics builds signatures for LBOUND calls as either
4016 // LBOUND(array, dim, [kind]) or LBOUND(array, [kind]).
4017 if (args.size() == 2 || isStaticallyAbsent(args, 1)) {
4018 // DIM is absent.
4019 mlir::Type lbType = fir::unwrapSequenceType(resultType);
4020 unsigned rank = array.rank();
4021 mlir::Type lbArrayType = fir::SequenceType::get(
4022 {static_cast<fir::SequenceType::Extent>(array.rank())}, lbType);
4023 mlir::Value lbArray = builder.createTemporary(loc, lbArrayType);
4024 mlir::Type lbAddrType = builder.getRefType(lbType);
4025 mlir::Value one = builder.createIntegerConstant(loc, lbType, 1);
4026 mlir::Value zero = builder.createIntegerConstant(loc, indexType, 0);
4027 for (unsigned dim = 0; dim < rank; ++dim) {
4028 mlir::Value lb = computeLBOUND(builder, loc, array, dim, zero, one);
4029 lb = builder.createConvert(loc, lbType, lb);
4030 auto index = builder.createIntegerConstant(loc, indexType, dim);
4031 auto lbAddr =
4032 builder.create<fir::CoordinateOp>(loc, lbAddrType, lbArray, index);
4033 builder.create<fir::StoreOp>(loc, lb, lbAddr);
4034 }
4035 mlir::Value lbArrayExtent =
4036 builder.createIntegerConstant(loc, indexType, rank);
4037 llvm::SmallVector<mlir::Value> extents{lbArrayExtent};
4038 return fir::ArrayBoxValue{lbArray, extents};
4039 }
4040 // DIM is present.
4041 mlir::Value dim = fir::getBase(args[1]);
4042
4043 // If it is a compile time constant, skip the runtime call.
4044 if (llvm::Optional<std::int64_t> cstDim =
4045 fir::factory::getIntIfConstant(dim)) {
4046 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
4047 mlir::Value zero = builder.createIntegerConstant(loc, indexType, 0);
4048 mlir::Value lb = computeLBOUND(builder, loc, array, *cstDim - 1, zero, one);
4049 return builder.createConvert(loc, resultType, lb);
4050 }
4051
4052 fir::ExtendedValue box = createBoxForLBOUND(loc, builder, array);
4053 return builder.createConvert(
4054 loc, resultType,
4055 fir::runtime::genLboundDim(builder, loc, fir::getBase(box), dim));
4056 }
4057
4058 // UBOUND
4059 fir::ExtendedValue
genUbound(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4060 IntrinsicLibrary::genUbound(mlir::Type resultType,
4061 llvm::ArrayRef<fir::ExtendedValue> args) {
4062 assert(args.size() == 3 || args.size() == 2);
4063 if (args.size() == 3) {
4064 // Handle calls to UBOUND with the DIM argument, which return a scalar
4065 mlir::Value extent = fir::getBase(genSize(resultType, args));
4066 mlir::Value lbound = fir::getBase(genLbound(resultType, args));
4067
4068 mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
4069 mlir::Value ubound = builder.create<mlir::arith::SubIOp>(loc, lbound, one);
4070 return builder.create<mlir::arith::AddIOp>(loc, ubound, extent);
4071 } else {
4072 // Handle calls to UBOUND without the DIM argument, which return an array
4073 mlir::Value kind = isStaticallyAbsent(args[1])
4074 ? builder.createIntegerConstant(
4075 loc, builder.getIndexType(),
4076 builder.getKindMap().defaultIntegerKind())
4077 : fir::getBase(args[1]);
4078
4079 // Create mutable fir.box to be passed to the runtime for the result.
4080 mlir::Type type = builder.getVarLenSeqTy(resultType, /*rank=*/1);
4081 fir::MutableBoxValue resultMutableBox =
4082 fir::factory::createTempMutableBox(builder, loc, type);
4083 mlir::Value resultIrBox =
4084 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4085
4086 fir::runtime::genUbound(builder, loc, resultIrBox, fir::getBase(args[0]),
4087 kind);
4088
4089 return readAndAddCleanUp(resultMutableBox, resultType, "UBOUND");
4090 }
4091 return mlir::Value();
4092 }
4093
4094 // SPACING
genSpacing(mlir::Type resultType,llvm::ArrayRef<mlir::Value> args)4095 mlir::Value IntrinsicLibrary::genSpacing(mlir::Type resultType,
4096 llvm::ArrayRef<mlir::Value> args) {
4097 assert(args.size() == 1);
4098
4099 return builder.createConvert(
4100 loc, resultType,
4101 fir::runtime::genSpacing(builder, loc, fir::getBase(args[0])));
4102 }
4103
4104 // SPREAD
4105 fir::ExtendedValue
genSpread(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4106 IntrinsicLibrary::genSpread(mlir::Type resultType,
4107 llvm::ArrayRef<fir::ExtendedValue> args) {
4108
4109 assert(args.size() == 3);
4110
4111 // Handle source argument
4112 mlir::Value source = builder.createBox(loc, args[0]);
4113 fir::BoxValue sourceTmp = source;
4114 unsigned sourceRank = sourceTmp.rank();
4115
4116 // Handle Dim argument
4117 mlir::Value dim = fir::getBase(args[1]);
4118
4119 // Handle ncopies argument
4120 mlir::Value ncopies = fir::getBase(args[2]);
4121
4122 // Generate result descriptor
4123 mlir::Type resultArrayType =
4124 builder.getVarLenSeqTy(resultType, sourceRank + 1);
4125 fir::MutableBoxValue resultMutableBox =
4126 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
4127 mlir::Value resultIrBox =
4128 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4129
4130 fir::runtime::genSpread(builder, loc, resultIrBox, source, dim, ncopies);
4131
4132 return readAndAddCleanUp(resultMutableBox, resultType,
4133 "unexpected result for SPREAD");
4134 }
4135
4136 // SUM
4137 fir::ExtendedValue
genSum(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4138 IntrinsicLibrary::genSum(mlir::Type resultType,
4139 llvm::ArrayRef<fir::ExtendedValue> args) {
4140 return genProdOrSum(fir::runtime::genSum, fir::runtime::genSumDim, resultType,
4141 builder, loc, stmtCtx, "unexpected result for Sum", args);
4142 }
4143
4144 // SYSTEM_CLOCK
genSystemClock(llvm::ArrayRef<fir::ExtendedValue> args)4145 void IntrinsicLibrary::genSystemClock(llvm::ArrayRef<fir::ExtendedValue> args) {
4146 assert(args.size() == 3);
4147 Fortran::lower::genSystemClock(builder, loc, fir::getBase(args[0]),
4148 fir::getBase(args[1]), fir::getBase(args[2]));
4149 }
4150
4151 // TRANSFER
4152 fir::ExtendedValue
genTransfer(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4153 IntrinsicLibrary::genTransfer(mlir::Type resultType,
4154 llvm::ArrayRef<fir::ExtendedValue> args) {
4155
4156 assert(args.size() >= 2); // args.size() == 2 when size argument is omitted.
4157
4158 // Handle source argument
4159 mlir::Value source = builder.createBox(loc, args[0]);
4160
4161 // Handle mold argument
4162 mlir::Value mold = builder.createBox(loc, args[1]);
4163 fir::BoxValue moldTmp = mold;
4164 unsigned moldRank = moldTmp.rank();
4165
4166 bool absentSize = (args.size() == 2);
4167
4168 // Create mutable fir.box to be passed to the runtime for the result.
4169 mlir::Type type = (moldRank == 0 && absentSize)
4170 ? resultType
4171 : builder.getVarLenSeqTy(resultType, 1);
4172 fir::MutableBoxValue resultMutableBox =
4173 fir::factory::createTempMutableBox(builder, loc, type);
4174
4175 if (moldRank == 0 && absentSize) {
4176 // This result is a scalar in this case.
4177 mlir::Value resultIrBox =
4178 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4179
4180 Fortran::lower::genTransfer(builder, loc, resultIrBox, source, mold);
4181 } else {
4182 // The result is a rank one array in this case.
4183 mlir::Value resultIrBox =
4184 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4185
4186 if (absentSize) {
4187 Fortran::lower::genTransfer(builder, loc, resultIrBox, source, mold);
4188 } else {
4189 mlir::Value sizeArg = fir::getBase(args[2]);
4190 Fortran::lower::genTransferSize(builder, loc, resultIrBox, source, mold,
4191 sizeArg);
4192 }
4193 }
4194 return readAndAddCleanUp(resultMutableBox, resultType,
4195 "unexpected result for TRANSFER");
4196 }
4197
4198 // TRANSPOSE
4199 fir::ExtendedValue
genTranspose(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4200 IntrinsicLibrary::genTranspose(mlir::Type resultType,
4201 llvm::ArrayRef<fir::ExtendedValue> args) {
4202
4203 assert(args.size() == 1);
4204
4205 // Handle source argument
4206 mlir::Value source = builder.createBox(loc, args[0]);
4207
4208 // Create mutable fir.box to be passed to the runtime for the result.
4209 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, 2);
4210 fir::MutableBoxValue resultMutableBox =
4211 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
4212 mlir::Value resultIrBox =
4213 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4214 // Call runtime. The runtime is allocating the result.
4215 fir::runtime::genTranspose(builder, loc, resultIrBox, source);
4216 // Read result from mutable fir.box and add it to the list of temps to be
4217 // finalized by the StatementContext.
4218 return readAndAddCleanUp(resultMutableBox, resultType,
4219 "unexpected result for TRANSPOSE");
4220 }
4221
4222 // TRIM
4223 fir::ExtendedValue
genTrim(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4224 IntrinsicLibrary::genTrim(mlir::Type resultType,
4225 llvm::ArrayRef<fir::ExtendedValue> args) {
4226 assert(args.size() == 1);
4227 mlir::Value string = builder.createBox(loc, args[0]);
4228 // Create mutable fir.box to be passed to the runtime for the result.
4229 fir::MutableBoxValue resultMutableBox =
4230 fir::factory::createTempMutableBox(builder, loc, resultType);
4231 mlir::Value resultIrBox =
4232 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4233 // Call runtime. The runtime is allocating the result.
4234 fir::runtime::genTrim(builder, loc, resultIrBox, string);
4235 // Read result from mutable fir.box and add it to the list of temps to be
4236 // finalized by the StatementContext.
4237 return readAndAddCleanUp(resultMutableBox, resultType, "TRIM");
4238 }
4239
4240 // Compare two FIR values and return boolean result as i1.
4241 template <Extremum extremum, ExtremumBehavior behavior>
createExtremumCompare(mlir::Location loc,fir::FirOpBuilder & builder,mlir::Value left,mlir::Value right)4242 static mlir::Value createExtremumCompare(mlir::Location loc,
4243 fir::FirOpBuilder &builder,
4244 mlir::Value left, mlir::Value right) {
4245 static constexpr mlir::arith::CmpIPredicate integerPredicate =
4246 extremum == Extremum::Max ? mlir::arith::CmpIPredicate::sgt
4247 : mlir::arith::CmpIPredicate::slt;
4248 static constexpr mlir::arith::CmpFPredicate orderedCmp =
4249 extremum == Extremum::Max ? mlir::arith::CmpFPredicate::OGT
4250 : mlir::arith::CmpFPredicate::OLT;
4251 mlir::Type type = left.getType();
4252 mlir::Value result;
4253 if (fir::isa_real(type)) {
4254 // Note: the signaling/quit aspect of the result required by IEEE
4255 // cannot currently be obtained with LLVM without ad-hoc runtime.
4256 if constexpr (behavior == ExtremumBehavior::IeeeMinMaximumNumber) {
4257 // Return the number if one of the inputs is NaN and the other is
4258 // a number.
4259 auto leftIsResult =
4260 builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
4261 auto rightIsNan = builder.create<mlir::arith::CmpFOp>(
4262 loc, mlir::arith::CmpFPredicate::UNE, right, right);
4263 result =
4264 builder.create<mlir::arith::OrIOp>(loc, leftIsResult, rightIsNan);
4265 } else if constexpr (behavior == ExtremumBehavior::IeeeMinMaximum) {
4266 // Always return NaNs if one the input is NaNs
4267 auto leftIsResult =
4268 builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
4269 auto leftIsNan = builder.create<mlir::arith::CmpFOp>(
4270 loc, mlir::arith::CmpFPredicate::UNE, left, left);
4271 result = builder.create<mlir::arith::OrIOp>(loc, leftIsResult, leftIsNan);
4272 } else if constexpr (behavior == ExtremumBehavior::MinMaxss) {
4273 // If the left is a NaN, return the right whatever it is.
4274 result =
4275 builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
4276 } else if constexpr (behavior == ExtremumBehavior::PgfortranLlvm) {
4277 // If one of the operand is a NaN, return left whatever it is.
4278 static constexpr auto unorderedCmp =
4279 extremum == Extremum::Max ? mlir::arith::CmpFPredicate::UGT
4280 : mlir::arith::CmpFPredicate::ULT;
4281 result =
4282 builder.create<mlir::arith::CmpFOp>(loc, unorderedCmp, left, right);
4283 } else {
4284 // TODO: ieeeMinNum/ieeeMaxNum
4285 static_assert(behavior == ExtremumBehavior::IeeeMinMaxNum,
4286 "ieeeMinNum/ieeeMaxNum behavior not implemented");
4287 }
4288 } else if (fir::isa_integer(type)) {
4289 result =
4290 builder.create<mlir::arith::CmpIOp>(loc, integerPredicate, left, right);
4291 } else if (fir::isa_char(type) || fir::isa_char(fir::unwrapRefType(type))) {
4292 // TODO: ! character min and max is tricky because the result
4293 // length is the length of the longest argument!
4294 // So we may need a temp.
4295 TODO(loc, "CHARACTER min and max");
4296 }
4297 assert(result && "result must be defined");
4298 return result;
4299 }
4300
4301 // UNPACK
4302 fir::ExtendedValue
genUnpack(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4303 IntrinsicLibrary::genUnpack(mlir::Type resultType,
4304 llvm::ArrayRef<fir::ExtendedValue> args) {
4305 assert(args.size() == 3);
4306
4307 // Handle required vector argument
4308 mlir::Value vector = builder.createBox(loc, args[0]);
4309
4310 // Handle required mask argument
4311 fir::BoxValue maskBox = builder.createBox(loc, args[1]);
4312 mlir::Value mask = fir::getBase(maskBox);
4313 unsigned maskRank = maskBox.rank();
4314
4315 // Handle required field argument
4316 mlir::Value field = builder.createBox(loc, args[2]);
4317
4318 // Create mutable fir.box to be passed to the runtime for the result.
4319 mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, maskRank);
4320 fir::MutableBoxValue resultMutableBox =
4321 fir::factory::createTempMutableBox(builder, loc, resultArrayType);
4322 mlir::Value resultIrBox =
4323 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4324
4325 fir::runtime::genUnpack(builder, loc, resultIrBox, vector, mask, field);
4326
4327 return readAndAddCleanUp(resultMutableBox, resultType,
4328 "unexpected result for UNPACK");
4329 }
4330
4331 // VERIFY
4332 fir::ExtendedValue
genVerify(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4333 IntrinsicLibrary::genVerify(mlir::Type resultType,
4334 llvm::ArrayRef<fir::ExtendedValue> args) {
4335
4336 assert(args.size() == 4);
4337
4338 if (isStaticallyAbsent(args[3])) {
4339 // Kind not specified, so call scan/verify runtime routine that is
4340 // specialized on the kind of characters in string.
4341
4342 // Handle required string base arg
4343 mlir::Value stringBase = fir::getBase(args[0]);
4344
4345 // Handle required set string base arg
4346 mlir::Value setBase = fir::getBase(args[1]);
4347
4348 // Handle kind argument; it is the kind of character in this case
4349 fir::KindTy kind =
4350 fir::factory::CharacterExprHelper{builder, loc}.getCharacterKind(
4351 stringBase.getType());
4352
4353 // Get string length argument
4354 mlir::Value stringLen = fir::getLen(args[0]);
4355
4356 // Get set string length argument
4357 mlir::Value setLen = fir::getLen(args[1]);
4358
4359 // Handle optional back argument
4360 mlir::Value back =
4361 isStaticallyAbsent(args[2])
4362 ? builder.createIntegerConstant(loc, builder.getI1Type(), 0)
4363 : fir::getBase(args[2]);
4364
4365 return builder.createConvert(
4366 loc, resultType,
4367 fir::runtime::genVerify(builder, loc, kind, stringBase, stringLen,
4368 setBase, setLen, back));
4369 }
4370 // else use the runtime descriptor version of scan/verify
4371
4372 // Handle optional argument, back
4373 auto makeRefThenEmbox = [&](mlir::Value b) {
4374 fir::LogicalType logTy = fir::LogicalType::get(
4375 builder.getContext(), builder.getKindMap().defaultLogicalKind());
4376 mlir::Value temp = builder.createTemporary(loc, logTy);
4377 mlir::Value castb = builder.createConvert(loc, logTy, b);
4378 builder.create<fir::StoreOp>(loc, castb, temp);
4379 return builder.createBox(loc, temp);
4380 };
4381 mlir::Value back = fir::isUnboxedValue(args[2])
4382 ? makeRefThenEmbox(*args[2].getUnboxed())
4383 : builder.create<fir::AbsentOp>(
4384 loc, fir::BoxType::get(builder.getI1Type()));
4385
4386 // Handle required string argument
4387 mlir::Value string = builder.createBox(loc, args[0]);
4388
4389 // Handle required set argument
4390 mlir::Value set = builder.createBox(loc, args[1]);
4391
4392 // Handle kind argument
4393 mlir::Value kind = fir::getBase(args[3]);
4394
4395 // Create result descriptor
4396 fir::MutableBoxValue resultMutableBox =
4397 fir::factory::createTempMutableBox(builder, loc, resultType);
4398 mlir::Value resultIrBox =
4399 fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
4400
4401 fir::runtime::genVerifyDescriptor(builder, loc, resultIrBox, string, set,
4402 back, kind);
4403
4404 // Handle cleanup of allocatable result descriptor and return
4405 return readAndAddCleanUp(resultMutableBox, resultType, "VERIFY");
4406 }
4407
4408 // MAXLOC
4409 fir::ExtendedValue
genMaxloc(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4410 IntrinsicLibrary::genMaxloc(mlir::Type resultType,
4411 llvm::ArrayRef<fir::ExtendedValue> args) {
4412 return genExtremumloc(fir::runtime::genMaxloc, fir::runtime::genMaxlocDim,
4413 resultType, builder, loc, stmtCtx,
4414 "unexpected result for Maxloc", args);
4415 }
4416
4417 // MAXVAL
4418 fir::ExtendedValue
genMaxval(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4419 IntrinsicLibrary::genMaxval(mlir::Type resultType,
4420 llvm::ArrayRef<fir::ExtendedValue> args) {
4421 return genExtremumVal(fir::runtime::genMaxval, fir::runtime::genMaxvalDim,
4422 fir::runtime::genMaxvalChar, resultType, builder, loc,
4423 stmtCtx, "unexpected result for Maxval", args);
4424 }
4425
4426 // MINLOC
4427 fir::ExtendedValue
genMinloc(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4428 IntrinsicLibrary::genMinloc(mlir::Type resultType,
4429 llvm::ArrayRef<fir::ExtendedValue> args) {
4430 return genExtremumloc(fir::runtime::genMinloc, fir::runtime::genMinlocDim,
4431 resultType, builder, loc, stmtCtx,
4432 "unexpected result for Minloc", args);
4433 }
4434
4435 // MINVAL
4436 fir::ExtendedValue
genMinval(mlir::Type resultType,llvm::ArrayRef<fir::ExtendedValue> args)4437 IntrinsicLibrary::genMinval(mlir::Type resultType,
4438 llvm::ArrayRef<fir::ExtendedValue> args) {
4439 return genExtremumVal(fir::runtime::genMinval, fir::runtime::genMinvalDim,
4440 fir::runtime::genMinvalChar, resultType, builder, loc,
4441 stmtCtx, "unexpected result for Minval", args);
4442 }
4443
4444 // MIN and MAX
4445 template <Extremum extremum, ExtremumBehavior behavior>
genExtremum(mlir::Type,llvm::ArrayRef<mlir::Value> args)4446 mlir::Value IntrinsicLibrary::genExtremum(mlir::Type,
4447 llvm::ArrayRef<mlir::Value> args) {
4448 assert(args.size() >= 1);
4449 mlir::Value result = args[0];
4450 for (auto arg : args.drop_front()) {
4451 mlir::Value mask =
4452 createExtremumCompare<extremum, behavior>(loc, builder, result, arg);
4453 result = builder.create<mlir::arith::SelectOp>(loc, mask, result, arg);
4454 }
4455 return result;
4456 }
4457
4458 //===----------------------------------------------------------------------===//
4459 // Argument lowering rules interface
4460 //===----------------------------------------------------------------------===//
4461
4462 const Fortran::lower::IntrinsicArgumentLoweringRules *
getIntrinsicArgumentLowering(llvm::StringRef intrinsicName)4463 Fortran::lower::getIntrinsicArgumentLowering(llvm::StringRef intrinsicName) {
4464 if (const IntrinsicHandler *handler = findIntrinsicHandler(intrinsicName))
4465 if (!handler->argLoweringRules.hasDefaultRules())
4466 return &handler->argLoweringRules;
4467 return nullptr;
4468 }
4469
4470 /// Return how argument \p argName should be lowered given the rules for the
4471 /// intrinsic function.
lowerIntrinsicArgumentAs(const IntrinsicArgumentLoweringRules & rules,unsigned position)4472 Fortran::lower::ArgLoweringRule Fortran::lower::lowerIntrinsicArgumentAs(
4473 const IntrinsicArgumentLoweringRules &rules, unsigned position) {
4474 assert(position < sizeof(rules.args) / sizeof(decltype(*rules.args)) &&
4475 "invalid argument");
4476 return {rules.args[position].lowerAs,
4477 rules.args[position].handleDynamicOptional};
4478 }
4479
4480 //===----------------------------------------------------------------------===//
4481 // Public intrinsic call helpers
4482 //===----------------------------------------------------------------------===//
4483
4484 fir::ExtendedValue
genIntrinsicCall(fir::FirOpBuilder & builder,mlir::Location loc,llvm::StringRef name,llvm::Optional<mlir::Type> resultType,llvm::ArrayRef<fir::ExtendedValue> args,Fortran::lower::StatementContext & stmtCtx)4485 Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
4486 llvm::StringRef name,
4487 llvm::Optional<mlir::Type> resultType,
4488 llvm::ArrayRef<fir::ExtendedValue> args,
4489 Fortran::lower::StatementContext &stmtCtx) {
4490 return IntrinsicLibrary{builder, loc, &stmtCtx}.genIntrinsicCall(
4491 name, resultType, args);
4492 }
4493
genMax(fir::FirOpBuilder & builder,mlir::Location loc,llvm::ArrayRef<mlir::Value> args)4494 mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder,
4495 mlir::Location loc,
4496 llvm::ArrayRef<mlir::Value> args) {
4497 assert(args.size() > 0 && "max requires at least one argument");
4498 return IntrinsicLibrary{builder, loc}
4499 .genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>(args[0].getType(),
4500 args);
4501 }
4502
genMin(fir::FirOpBuilder & builder,mlir::Location loc,llvm::ArrayRef<mlir::Value> args)4503 mlir::Value Fortran::lower::genMin(fir::FirOpBuilder &builder,
4504 mlir::Location loc,
4505 llvm::ArrayRef<mlir::Value> args) {
4506 assert(args.size() > 0 && "min requires at least one argument");
4507 return IntrinsicLibrary{builder, loc}
4508 .genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>(args[0].getType(),
4509 args);
4510 }
4511
genPow(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Type type,mlir::Value x,mlir::Value y)4512 mlir::Value Fortran::lower::genPow(fir::FirOpBuilder &builder,
4513 mlir::Location loc, mlir::Type type,
4514 mlir::Value x, mlir::Value y) {
4515 // TODO: since there is no libm version of pow with integer exponent,
4516 // we have to provide an alternative implementation for
4517 // "precise/strict" FP mode.
4518 // One option is to generate internal function with inlined
4519 // implementation and mark it 'strictfp'.
4520 // Another option is to implement it in Fortran runtime library
4521 // (just like matmul).
4522 return IntrinsicLibrary{builder, loc}.genRuntimeCall("pow", type, {x, y});
4523 }
4524
getUnrestrictedIntrinsicSymbolRefAttr(fir::FirOpBuilder & builder,mlir::Location loc,llvm::StringRef name,mlir::FunctionType signature)4525 mlir::SymbolRefAttr Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr(
4526 fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
4527 mlir::FunctionType signature) {
4528 return IntrinsicLibrary{builder, loc}.getUnrestrictedIntrinsicSymbolRefAttr(
4529 name, signature);
4530 }
4531