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/Lower/Todo.h"
23 #include "flang/Optimizer/Builder/Character.h"
24 #include "flang/Optimizer/Builder/Complex.h"
25 #include "flang/Optimizer/Builder/FIRBuilder.h"
26 #include "flang/Optimizer/Builder/MutableBox.h"
27 #include "flang/Optimizer/Builder/Runtime/Character.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/Transformational.h"
33 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
34 #include "flang/Optimizer/Support/FatalError.h"
35 #include "mlir/Dialect/LLVMIR/LLVMDialect.h"
36 #include "llvm/Support/CommandLine.h"
37 #include "llvm/Support/Debug.h"
38 
39 #define DEBUG_TYPE "flang-lower-intrinsic"
40 
41 #define PGMATH_DECLARE
42 #include "flang/Evaluate/pgmath.h.inc"
43 
44 /// This file implements lowering of Fortran intrinsic procedures.
45 /// Intrinsics are lowered to a mix of FIR and MLIR operations as
46 /// well as call to runtime functions or LLVM intrinsics.
47 
48 /// Lowering of intrinsic procedure calls is based on a map that associates
49 /// Fortran intrinsic generic names to FIR generator functions.
50 /// All generator functions are member functions of the IntrinsicLibrary class
51 /// and have the same interface.
52 /// If no generator is given for an intrinsic name, a math runtime library
53 /// is searched for an implementation and, if a runtime function is found,
54 /// a call is generated for it. LLVM intrinsics are handled as a math
55 /// runtime library here.
56 
57 /// Enums used to templatize and share lowering of MIN and MAX.
58 enum class Extremum { Min, Max };
59 
60 // There are different ways to deal with NaNs in MIN and MAX.
61 // Known existing behaviors are listed below and can be selected for
62 // f18 MIN/MAX implementation.
63 enum class ExtremumBehavior {
64   // Note: the Signaling/quiet aspect of NaNs in the behaviors below are
65   // not described because there is no way to control/observe such aspect in
66   // MLIR/LLVM yet. The IEEE behaviors come with requirements regarding this
67   // aspect that are therefore currently not enforced. In the descriptions
68   // below, NaNs can be signaling or quite. Returned NaNs may be signaling
69   // if one of the input NaN was signaling but it cannot be guaranteed either.
70   // Existing compilers using an IEEE behavior (gfortran) also do not fulfill
71   // signaling/quiet requirements.
72   IeeeMinMaximumNumber,
73   // IEEE minimumNumber/maximumNumber behavior (754-2019, section 9.6):
74   // If one of the argument is and number and the other is NaN, return the
75   // number. If both arguements are NaN, return NaN.
76   // Compilers: gfortran.
77   IeeeMinMaximum,
78   // IEEE minimum/maximum behavior (754-2019, section 9.6):
79   // If one of the argument is NaN, return NaN.
80   MinMaxss,
81   // x86 minss/maxss behavior:
82   // If the second argument is a number and the other is NaN, return the number.
83   // In all other cases where at least one operand is NaN, return NaN.
84   // Compilers: xlf (only for MAX), ifort, pgfortran -nollvm, and nagfor.
85   PgfortranLlvm,
86   // "Opposite of" x86 minss/maxss behavior:
87   // If the first argument is a number and the other is NaN, return the
88   // number.
89   // In all other cases where at least one operand is NaN, return NaN.
90   // Compilers: xlf (only for MIN), and pgfortran (with llvm).
91   IeeeMinMaxNum
92   // IEEE minNum/maxNum behavior (754-2008, section 5.3.1):
93   // TODO: Not implemented.
94   // It is the only behavior where the signaling/quiet aspect of a NaN argument
95   // impacts if the result should be NaN or the argument that is a number.
96   // LLVM/MLIR do not provide ways to observe this aspect, so it is not
97   // possible to implement it without some target dependent runtime.
98 };
99 
100 fir::ExtendedValue Fortran::lower::getAbsentIntrinsicArgument() {
101   return fir::UnboxedValue{};
102 }
103 
104 /// Test if an ExtendedValue is absent.
105 static bool isAbsent(const fir::ExtendedValue &exv) {
106   return !fir::getBase(exv);
107 }
108 static bool isAbsent(llvm::ArrayRef<fir::ExtendedValue> args, size_t argIndex) {
109   return args.size() <= argIndex || isAbsent(args[argIndex]);
110 }
111 
112 /// Test if an ExtendedValue is present.
113 static bool isPresent(const fir::ExtendedValue &exv) { return !isAbsent(exv); }
114 
115 /// Process calls to Maxval, Minval, Product, Sum intrinsic functions that
116 /// take a DIM argument.
117 template <typename FD>
118 static fir::ExtendedValue
119 genFuncDim(FD funcDim, mlir::Type resultType, fir::FirOpBuilder &builder,
120            mlir::Location loc, Fortran::lower::StatementContext *stmtCtx,
121            llvm::StringRef errMsg, mlir::Value array, fir::ExtendedValue dimArg,
122            mlir::Value mask, int rank) {
123 
124   // Create mutable fir.box to be passed to the runtime for the result.
125   mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
126   fir::MutableBoxValue resultMutableBox =
127       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
128   mlir::Value resultIrBox =
129       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
130 
131   mlir::Value dim =
132       isAbsent(dimArg)
133           ? builder.createIntegerConstant(loc, builder.getIndexType(), 0)
134           : fir::getBase(dimArg);
135   funcDim(builder, loc, resultIrBox, array, dim, mask);
136 
137   fir::ExtendedValue res =
138       fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
139   return res.match(
140       [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
141         // Add cleanup code
142         assert(stmtCtx);
143         fir::FirOpBuilder *bldr = &builder;
144         mlir::Value temp = box.getAddr();
145         stmtCtx->attachCleanup(
146             [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
147         return box;
148       },
149       [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue {
150         // Add cleanup code
151         assert(stmtCtx);
152         fir::FirOpBuilder *bldr = &builder;
153         mlir::Value temp = box.getAddr();
154         stmtCtx->attachCleanup(
155             [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
156         return box;
157       },
158       [&](const auto &) -> fir::ExtendedValue {
159         fir::emitFatalError(loc, errMsg);
160       });
161 }
162 
163 /// Process calls to Product, Sum intrinsic functions
164 template <typename FN, typename FD>
165 static fir::ExtendedValue
166 genProdOrSum(FN func, FD funcDim, mlir::Type resultType,
167              fir::FirOpBuilder &builder, mlir::Location loc,
168              Fortran::lower::StatementContext *stmtCtx, llvm::StringRef errMsg,
169              llvm::ArrayRef<fir::ExtendedValue> args) {
170 
171   assert(args.size() == 3);
172 
173   // Handle required array argument
174   fir::BoxValue arryTmp = builder.createBox(loc, args[0]);
175   mlir::Value array = fir::getBase(arryTmp);
176   int rank = arryTmp.rank();
177   assert(rank >= 1);
178 
179   // Handle optional mask argument
180   auto mask = isAbsent(args[2])
181                   ? builder.create<fir::AbsentOp>(
182                         loc, fir::BoxType::get(builder.getI1Type()))
183                   : builder.createBox(loc, args[2]);
184 
185   bool absentDim = isAbsent(args[1]);
186 
187   // We call the type specific versions because the result is scalar
188   // in the case below.
189   if (absentDim || rank == 1) {
190     mlir::Type ty = array.getType();
191     mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(ty);
192     auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
193     if (fir::isa_complex(eleTy)) {
194       mlir::Value result = builder.createTemporary(loc, eleTy);
195       func(builder, loc, array, mask, result);
196       return builder.create<fir::LoadOp>(loc, result);
197     }
198     auto resultBox = builder.create<fir::AbsentOp>(
199         loc, fir::BoxType::get(builder.getI1Type()));
200     return func(builder, loc, array, mask, resultBox);
201   }
202   // Handle Product/Sum cases that have an array result.
203   return genFuncDim(funcDim, resultType, builder, loc, stmtCtx, errMsg, array,
204                     args[1], mask, rank);
205 }
206 
207 /// Process calls to DotProduct
208 template <typename FN>
209 static fir::ExtendedValue
210 genDotProd(FN func, mlir::Type resultType, fir::FirOpBuilder &builder,
211            mlir::Location loc, Fortran::lower::StatementContext *stmtCtx,
212            llvm::ArrayRef<fir::ExtendedValue> args) {
213 
214   assert(args.size() == 2);
215 
216   // Handle required vector arguments
217   mlir::Value vectorA = fir::getBase(args[0]);
218   mlir::Value vectorB = fir::getBase(args[1]);
219 
220   mlir::Type eleTy = fir::dyn_cast_ptrOrBoxEleTy(vectorA.getType())
221                          .cast<fir::SequenceType>()
222                          .getEleTy();
223   if (fir::isa_complex(eleTy)) {
224     mlir::Value result = builder.createTemporary(loc, eleTy);
225     func(builder, loc, vectorA, vectorB, result);
226     return builder.create<fir::LoadOp>(loc, result);
227   }
228 
229   auto resultBox = builder.create<fir::AbsentOp>(
230       loc, fir::BoxType::get(builder.getI1Type()));
231   return func(builder, loc, vectorA, vectorB, resultBox);
232 }
233 
234 /// Process calls to Maxval, Minval, Product, Sum intrinsic functions
235 template <typename FN, typename FD, typename FC>
236 static fir::ExtendedValue
237 genExtremumVal(FN func, FD funcDim, FC funcChar, mlir::Type resultType,
238                fir::FirOpBuilder &builder, mlir::Location loc,
239                Fortran::lower::StatementContext *stmtCtx,
240                llvm::StringRef errMsg,
241                llvm::ArrayRef<fir::ExtendedValue> args) {
242 
243   assert(args.size() == 3);
244 
245   // Handle required array argument
246   fir::BoxValue arryTmp = builder.createBox(loc, args[0]);
247   mlir::Value array = fir::getBase(arryTmp);
248   int rank = arryTmp.rank();
249   assert(rank >= 1);
250   bool hasCharacterResult = arryTmp.isCharacter();
251 
252   // Handle optional mask argument
253   auto mask = isAbsent(args[2])
254                   ? builder.create<fir::AbsentOp>(
255                         loc, fir::BoxType::get(builder.getI1Type()))
256                   : builder.createBox(loc, args[2]);
257 
258   bool absentDim = isAbsent(args[1]);
259 
260   // For Maxval/MinVal, we call the type specific versions of
261   // Maxval/Minval because the result is scalar in the case below.
262   if (!hasCharacterResult && (absentDim || rank == 1))
263     return func(builder, loc, array, mask);
264 
265   if (hasCharacterResult && (absentDim || rank == 1)) {
266     // Create mutable fir.box to be passed to the runtime for the result.
267     fir::MutableBoxValue resultMutableBox =
268         fir::factory::createTempMutableBox(builder, loc, resultType);
269     mlir::Value resultIrBox =
270         fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
271 
272     funcChar(builder, loc, resultIrBox, array, mask);
273 
274     // Handle cleanup of allocatable result descriptor and return
275     fir::ExtendedValue res =
276         fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
277     return res.match(
278         [&](const fir::CharBoxValue &box) -> fir::ExtendedValue {
279           // Add cleanup code
280           assert(stmtCtx);
281           fir::FirOpBuilder *bldr = &builder;
282           mlir::Value temp = box.getAddr();
283           stmtCtx->attachCleanup(
284               [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
285           return box;
286         },
287         [&](const auto &) -> fir::ExtendedValue {
288           fir::emitFatalError(loc, errMsg);
289         });
290   }
291 
292   // Handle Min/Maxval cases that have an array result.
293   return genFuncDim(funcDim, resultType, builder, loc, stmtCtx, errMsg, array,
294                     args[1], mask, rank);
295 }
296 
297 /// Process calls to Minloc, Maxloc intrinsic functions
298 template <typename FN, typename FD>
299 static fir::ExtendedValue genExtremumloc(
300     FN func, FD funcDim, mlir::Type resultType, fir::FirOpBuilder &builder,
301     mlir::Location loc, Fortran::lower::StatementContext *stmtCtx,
302     llvm::StringRef errMsg, llvm::ArrayRef<fir::ExtendedValue> args) {
303 
304   assert(args.size() == 5);
305 
306   // Handle required array argument
307   mlir::Value array = builder.createBox(loc, args[0]);
308   unsigned rank = fir::BoxValue(array).rank();
309   assert(rank >= 1);
310 
311   // Handle optional mask argument
312   auto mask = isAbsent(args[2])
313                   ? builder.create<fir::AbsentOp>(
314                         loc, fir::BoxType::get(builder.getI1Type()))
315                   : builder.createBox(loc, args[2]);
316 
317   // Handle optional kind argument
318   auto kind = isAbsent(args[3]) ? builder.createIntegerConstant(
319                                       loc, builder.getIndexType(),
320                                       builder.getKindMap().defaultIntegerKind())
321                                 : fir::getBase(args[3]);
322 
323   // Handle optional back argument
324   auto back = isAbsent(args[4]) ? builder.createBool(loc, false)
325                                 : fir::getBase(args[4]);
326 
327   bool absentDim = isAbsent(args[1]);
328 
329   if (!absentDim && rank == 1) {
330     // If dim argument is present and the array is rank 1, then the result is
331     // a scalar (since the the result is rank-1 or 0).
332     // Therefore, we use a scalar result descriptor with Min/MaxlocDim().
333     mlir::Value dim = fir::getBase(args[1]);
334     // Create mutable fir.box to be passed to the runtime for the result.
335     fir::MutableBoxValue resultMutableBox =
336         fir::factory::createTempMutableBox(builder, loc, resultType);
337     mlir::Value resultIrBox =
338         fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
339 
340     funcDim(builder, loc, resultIrBox, array, dim, mask, kind, back);
341 
342     // Handle cleanup of allocatable result descriptor and return
343     fir::ExtendedValue res =
344         fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
345     return res.match(
346         [&](const mlir::Value &tempAddr) -> fir::ExtendedValue {
347           // Add cleanup code
348           assert(stmtCtx);
349           fir::FirOpBuilder *bldr = &builder;
350           stmtCtx->attachCleanup(
351               [=]() { bldr->create<fir::FreeMemOp>(loc, tempAddr); });
352           return builder.create<fir::LoadOp>(loc, resultType, tempAddr);
353         },
354         [&](const auto &) -> fir::ExtendedValue {
355           fir::emitFatalError(loc, errMsg);
356         });
357   }
358 
359   // Note: The Min/Maxloc/val cases below have an array result.
360 
361   // Create mutable fir.box to be passed to the runtime for the result.
362   mlir::Type resultArrayType =
363       builder.getVarLenSeqTy(resultType, absentDim ? 1 : rank - 1);
364   fir::MutableBoxValue resultMutableBox =
365       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
366   mlir::Value resultIrBox =
367       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
368 
369   if (absentDim) {
370     // Handle min/maxloc/val case where there is no dim argument
371     // (calls Min/Maxloc()/MinMaxval() runtime routine)
372     func(builder, loc, resultIrBox, array, mask, kind, back);
373   } else {
374     // else handle min/maxloc case with dim argument (calls
375     // Min/Max/loc/val/Dim() runtime routine).
376     mlir::Value dim = fir::getBase(args[1]);
377     funcDim(builder, loc, resultIrBox, array, dim, mask, kind, back);
378   }
379 
380   return fir::factory::genMutableBoxRead(builder, loc, resultMutableBox)
381       .match(
382           [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
383             // Add cleanup code
384             assert(stmtCtx);
385             fir::FirOpBuilder *bldr = &builder;
386             mlir::Value temp = box.getAddr();
387             stmtCtx->attachCleanup(
388                 [=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
389             return box;
390           },
391           [&](const auto &) -> fir::ExtendedValue {
392             fir::emitFatalError(loc, errMsg);
393           });
394 }
395 
396 // TODO error handling -> return a code or directly emit messages ?
397 struct IntrinsicLibrary {
398 
399   // Constructors.
400   explicit IntrinsicLibrary(fir::FirOpBuilder &builder, mlir::Location loc,
401                             Fortran::lower::StatementContext *stmtCtx = nullptr)
402       : builder{builder}, loc{loc}, stmtCtx{stmtCtx} {}
403   IntrinsicLibrary() = delete;
404   IntrinsicLibrary(const IntrinsicLibrary &) = delete;
405 
406   /// Generate FIR for call to Fortran intrinsic \p name with arguments \p arg
407   /// and expected result type \p resultType.
408   fir::ExtendedValue genIntrinsicCall(llvm::StringRef name,
409                                       llvm::Optional<mlir::Type> resultType,
410                                       llvm::ArrayRef<fir::ExtendedValue> arg);
411 
412   /// Search a runtime function that is associated to the generic intrinsic name
413   /// and whose signature matches the intrinsic arguments and result types.
414   /// If no such runtime function is found but a runtime function associated
415   /// with the Fortran generic exists and has the same number of arguments,
416   /// conversions will be inserted before and/or after the call. This is to
417   /// mainly to allow 16 bits float support even-though little or no math
418   /// runtime is currently available for it.
419   mlir::Value genRuntimeCall(llvm::StringRef name, mlir::Type,
420                              llvm::ArrayRef<mlir::Value>);
421 
422   using RuntimeCallGenerator = std::function<mlir::Value(
423       fir::FirOpBuilder &, mlir::Location, llvm::ArrayRef<mlir::Value>)>;
424   RuntimeCallGenerator
425   getRuntimeCallGenerator(llvm::StringRef name,
426                           mlir::FunctionType soughtFuncType);
427 
428   /// Lowering for the ABS intrinsic. The ABS intrinsic expects one argument in
429   /// the llvm::ArrayRef. The ABS intrinsic is lowered into MLIR/FIR operation
430   /// if the argument is an integer, into llvm intrinsics if the argument is
431   /// real and to the `hypot` math routine if the argument is of complex type.
432   mlir::Value genAbs(mlir::Type, llvm::ArrayRef<mlir::Value>);
433   template <void (*CallRuntime)(fir::FirOpBuilder &, mlir::Location loc,
434                                 mlir::Value, mlir::Value)>
435   fir::ExtendedValue genAdjustRtCall(mlir::Type,
436                                      llvm::ArrayRef<fir::ExtendedValue>);
437   mlir::Value genAimag(mlir::Type, llvm::ArrayRef<mlir::Value>);
438   fir::ExtendedValue genAll(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
439   fir::ExtendedValue genAllocated(mlir::Type,
440                                   llvm::ArrayRef<fir::ExtendedValue>);
441   fir::ExtendedValue genAny(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
442   fir::ExtendedValue genAssociated(mlir::Type,
443                                    llvm::ArrayRef<fir::ExtendedValue>);
444   fir::ExtendedValue genChar(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
445   fir::ExtendedValue genCount(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
446   template <mlir::arith::CmpIPredicate pred>
447   fir::ExtendedValue genCharacterCompare(mlir::Type,
448                                          llvm::ArrayRef<fir::ExtendedValue>);
449   void genCpuTime(llvm::ArrayRef<fir::ExtendedValue>);
450   fir::ExtendedValue genCshift(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
451   void genDateAndTime(llvm::ArrayRef<fir::ExtendedValue>);
452   mlir::Value genDim(mlir::Type, llvm::ArrayRef<mlir::Value>);
453   fir::ExtendedValue genDotProduct(mlir::Type,
454                                    llvm::ArrayRef<fir::ExtendedValue>);
455   fir::ExtendedValue genEoshift(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
456   mlir::Value genExponent(mlir::Type, llvm::ArrayRef<mlir::Value>);
457   template <Extremum, ExtremumBehavior>
458   mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
459   mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
460   mlir::Value genFraction(mlir::Type resultType,
461                           mlir::ArrayRef<mlir::Value> args);
462   /// Lowering for the IAND intrinsic. The IAND intrinsic expects two arguments
463   /// in the llvm::ArrayRef.
464   mlir::Value genIand(mlir::Type, llvm::ArrayRef<mlir::Value>);
465   mlir::Value genIbclr(mlir::Type, llvm::ArrayRef<mlir::Value>);
466   mlir::Value genIbits(mlir::Type, llvm::ArrayRef<mlir::Value>);
467   mlir::Value genIbset(mlir::Type, llvm::ArrayRef<mlir::Value>);
468   fir::ExtendedValue genIchar(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
469   mlir::Value genIeor(mlir::Type, llvm::ArrayRef<mlir::Value>);
470   mlir::Value genIshft(mlir::Type, llvm::ArrayRef<mlir::Value>);
471   mlir::Value genIshftc(mlir::Type, llvm::ArrayRef<mlir::Value>);
472   fir::ExtendedValue genLbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
473   fir::ExtendedValue genLen(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
474   fir::ExtendedValue genLenTrim(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
475   fir::ExtendedValue genMaxloc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
476   fir::ExtendedValue genMaxval(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
477   fir::ExtendedValue genMinloc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
478   fir::ExtendedValue genMinval(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
479   mlir::Value genMod(mlir::Type, llvm::ArrayRef<mlir::Value>);
480   mlir::Value genModulo(mlir::Type, llvm::ArrayRef<mlir::Value>);
481   mlir::Value genNint(mlir::Type, llvm::ArrayRef<mlir::Value>);
482   mlir::Value genNot(mlir::Type, llvm::ArrayRef<mlir::Value>);
483   fir::ExtendedValue genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
484   fir::ExtendedValue genPack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
485   fir::ExtendedValue genProduct(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
486   void genRandomInit(llvm::ArrayRef<fir::ExtendedValue>);
487   void genRandomNumber(llvm::ArrayRef<fir::ExtendedValue>);
488   void genRandomSeed(llvm::ArrayRef<fir::ExtendedValue>);
489   mlir::Value genSetExponent(mlir::Type resultType,
490                              llvm::ArrayRef<mlir::Value> args);
491   fir::ExtendedValue genSize(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
492   fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
493   void genSystemClock(llvm::ArrayRef<fir::ExtendedValue>);
494   fir::ExtendedValue genTransfer(mlir::Type,
495                                  llvm::ArrayRef<fir::ExtendedValue>);
496   fir::ExtendedValue genUbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
497   fir::ExtendedValue genUnpack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
498 
499   /// Define the different FIR generators that can be mapped to intrinsic to
500   /// generate the related code.
501   using ElementalGenerator = decltype(&IntrinsicLibrary::genAbs);
502   using ExtendedGenerator = decltype(&IntrinsicLibrary::genSum);
503   using SubroutineGenerator = decltype(&IntrinsicLibrary::genRandomInit);
504   using Generator =
505       std::variant<ElementalGenerator, ExtendedGenerator, SubroutineGenerator>;
506 
507   template <typename GeneratorType>
508   fir::ExtendedValue
509   outlineInExtendedWrapper(GeneratorType, llvm::StringRef name,
510                            llvm::Optional<mlir::Type> resultType,
511                            llvm::ArrayRef<fir::ExtendedValue> args);
512 
513   template <typename GeneratorType>
514   mlir::FuncOp getWrapper(GeneratorType, llvm::StringRef name,
515                           mlir::FunctionType, bool loadRefArguments = false);
516 
517   /// Generate calls to ElementalGenerator, handling the elemental aspects
518   template <typename GeneratorType>
519   fir::ExtendedValue
520   genElementalCall(GeneratorType, llvm::StringRef name, mlir::Type resultType,
521                    llvm::ArrayRef<fir::ExtendedValue> args, bool outline);
522 
523   /// Helper to invoke code generator for the intrinsics given arguments.
524   mlir::Value invokeGenerator(ElementalGenerator generator,
525                               mlir::Type resultType,
526                               llvm::ArrayRef<mlir::Value> args);
527   mlir::Value invokeGenerator(RuntimeCallGenerator generator,
528                               mlir::Type resultType,
529                               llvm::ArrayRef<mlir::Value> args);
530   mlir::Value invokeGenerator(ExtendedGenerator generator,
531                               mlir::Type resultType,
532                               llvm::ArrayRef<mlir::Value> args);
533   mlir::Value invokeGenerator(SubroutineGenerator generator,
534                               llvm::ArrayRef<mlir::Value> args);
535 
536   /// Add clean-up for \p temp to the current statement context;
537   void addCleanUpForTemp(mlir::Location loc, mlir::Value temp);
538   /// Helper function for generating code clean-up for result descriptors
539   fir::ExtendedValue readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,
540                                        mlir::Type resultType,
541                                        llvm::StringRef errMsg);
542 
543   fir::FirOpBuilder &builder;
544   mlir::Location loc;
545   Fortran::lower::StatementContext *stmtCtx;
546 };
547 
548 struct IntrinsicDummyArgument {
549   const char *name = nullptr;
550   Fortran::lower::LowerIntrinsicArgAs lowerAs =
551       Fortran::lower::LowerIntrinsicArgAs::Value;
552   bool handleDynamicOptional = false;
553 };
554 
555 struct Fortran::lower::IntrinsicArgumentLoweringRules {
556   /// There is no more than 7 non repeated arguments in Fortran intrinsics.
557   IntrinsicDummyArgument args[7];
558   constexpr bool hasDefaultRules() const { return args[0].name == nullptr; }
559 };
560 
561 /// Structure describing what needs to be done to lower intrinsic "name".
562 struct IntrinsicHandler {
563   const char *name;
564   IntrinsicLibrary::Generator generator;
565   // The following may be omitted in the table below.
566   Fortran::lower::IntrinsicArgumentLoweringRules argLoweringRules = {};
567   bool isElemental = true;
568   /// Code heavy intrinsic can be outlined to make FIR
569   /// more readable.
570   bool outline = false;
571 };
572 
573 constexpr auto asValue = Fortran::lower::LowerIntrinsicArgAs::Value;
574 constexpr auto asAddr = Fortran::lower::LowerIntrinsicArgAs::Addr;
575 constexpr auto asBox = Fortran::lower::LowerIntrinsicArgAs::Box;
576 constexpr auto asInquired = Fortran::lower::LowerIntrinsicArgAs::Inquired;
577 using I = IntrinsicLibrary;
578 
579 /// Flag to indicate that an intrinsic argument has to be handled as
580 /// being dynamically optional (e.g. special handling when actual
581 /// argument is an optional variable in the current scope).
582 static constexpr bool handleDynamicOptional = true;
583 
584 /// Table that drives the fir generation depending on the intrinsic.
585 /// one to one mapping with Fortran arguments. If no mapping is
586 /// defined here for a generic intrinsic, genRuntimeCall will be called
587 /// to look for a match in the runtime a emit a call. Note that the argument
588 /// lowering rules for an intrinsic need to be provided only if at least one
589 /// argument must not be lowered by value. In which case, the lowering rules
590 /// should be provided for all the intrinsic arguments for completeness.
591 static constexpr IntrinsicHandler handlers[]{
592     {"abs", &I::genAbs},
593     {"adjustl",
594      &I::genAdjustRtCall<fir::runtime::genAdjustL>,
595      {{{"string", asAddr}}},
596      /*isElemental=*/true},
597     {"adjustr",
598      &I::genAdjustRtCall<fir::runtime::genAdjustR>,
599      {{{"string", asAddr}}},
600      /*isElemental=*/true},
601     {"aimag", &I::genAimag},
602     {"all",
603      &I::genAll,
604      {{{"mask", asAddr}, {"dim", asValue}}},
605      /*isElemental=*/false},
606     {"allocated",
607      &I::genAllocated,
608      {{{"array", asInquired}, {"scalar", asInquired}}},
609      /*isElemental=*/false},
610     {"any",
611      &I::genAny,
612      {{{"mask", asAddr}, {"dim", asValue}}},
613      /*isElemental=*/false},
614     {"associated",
615      &I::genAssociated,
616      {{{"pointer", asInquired}, {"target", asInquired}}},
617      /*isElemental=*/false},
618     {"char", &I::genChar},
619     {"count",
620      &I::genCount,
621      {{{"mask", asAddr}, {"dim", asValue}, {"kind", asValue}}},
622      /*isElemental=*/false},
623     {"cpu_time",
624      &I::genCpuTime,
625      {{{"time", asAddr}}},
626      /*isElemental=*/false},
627     {"cshift",
628      &I::genCshift,
629      {{{"array", asAddr}, {"shift", asAddr}, {"dim", asValue}}},
630      /*isElemental=*/false},
631     {"date_and_time",
632      &I::genDateAndTime,
633      {{{"date", asAddr, handleDynamicOptional},
634        {"time", asAddr, handleDynamicOptional},
635        {"zone", asAddr, handleDynamicOptional},
636        {"values", asBox, handleDynamicOptional}}},
637      /*isElemental=*/false},
638     {"dim", &I::genDim},
639     {"dot_product",
640      &I::genDotProduct,
641      {{{"vector_a", asBox}, {"vector_b", asBox}}},
642      /*isElemental=*/false},
643     {"eoshift",
644      &I::genEoshift,
645      {{{"array", asBox},
646        {"shift", asAddr},
647        {"boundary", asBox, handleDynamicOptional},
648        {"dim", asValue}}},
649      /*isElemental=*/false},
650     {"exponent", &I::genExponent},
651     {"floor", &I::genFloor},
652     {"fraction", &I::genFraction},
653     {"iachar", &I::genIchar},
654     {"iand", &I::genIand},
655     {"ibclr", &I::genIbclr},
656     {"ibits", &I::genIbits},
657     {"ibset", &I::genIbset},
658     {"ichar", &I::genIchar},
659     {"ieor", &I::genIeor},
660     {"ishft", &I::genIshft},
661     {"ishftc", &I::genIshftc},
662     {"len",
663      &I::genLen,
664      {{{"string", asInquired}, {"kind", asValue}}},
665      /*isElemental=*/false},
666     {"len_trim", &I::genLenTrim},
667     {"lge", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sge>},
668     {"lgt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sgt>},
669     {"lle", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sle>},
670     {"llt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::slt>},
671     {"max", &I::genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>},
672     {"maxloc",
673      &I::genMaxloc,
674      {{{"array", asBox},
675        {"dim", asValue},
676        {"mask", asBox, handleDynamicOptional},
677        {"kind", asValue},
678        {"back", asValue, handleDynamicOptional}}},
679      /*isElemental=*/false},
680     {"maxval",
681      &I::genMaxval,
682      {{{"array", asBox},
683        {"dim", asValue},
684        {"mask", asBox, handleDynamicOptional}}},
685      /*isElemental=*/false},
686     {"min", &I::genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>},
687     {"minloc",
688      &I::genMinloc,
689      {{{"array", asBox},
690        {"dim", asValue},
691        {"mask", asBox, handleDynamicOptional},
692        {"kind", asValue},
693        {"back", asValue, handleDynamicOptional}}},
694      /*isElemental=*/false},
695     {"minval",
696      &I::genMinval,
697      {{{"array", asBox},
698        {"dim", asValue},
699        {"mask", asBox, handleDynamicOptional}}},
700      /*isElemental=*/false},
701     {"mod", &I::genMod},
702     {"modulo", &I::genModulo},
703     {"nint", &I::genNint},
704     {"not", &I::genNot},
705     {"null", &I::genNull, {{{"mold", asInquired}}}, /*isElemental=*/false},
706     {"pack",
707      &I::genPack,
708      {{{"array", asBox},
709        {"mask", asBox},
710        {"vector", asBox, handleDynamicOptional}}},
711      /*isElemental=*/false},
712     {"product",
713      &I::genProduct,
714      {{{"array", asBox},
715        {"dim", asValue},
716        {"mask", asBox, handleDynamicOptional}}},
717      /*isElemental=*/false},
718     {"random_init",
719      &I::genRandomInit,
720      {{{"repeatable", asValue}, {"image_distinct", asValue}}},
721      /*isElemental=*/false},
722     {"random_number",
723      &I::genRandomNumber,
724      {{{"harvest", asBox}}},
725      /*isElemental=*/false},
726     {"random_seed",
727      &I::genRandomSeed,
728      {{{"size", asBox}, {"put", asBox}, {"get", asBox}}},
729      /*isElemental=*/false},
730     {"set_exponent", &I::genSetExponent},
731     {"size",
732      &I::genSize,
733      {{{"array", asBox},
734        {"dim", asAddr, handleDynamicOptional},
735        {"kind", asValue}}},
736      /*isElemental=*/false},
737     {"sum",
738      &I::genSum,
739      {{{"array", asBox},
740        {"dim", asValue},
741        {"mask", asBox, handleDynamicOptional}}},
742      /*isElemental=*/false},
743     {"system_clock",
744      &I::genSystemClock,
745      {{{"count", asAddr}, {"count_rate", asAddr}, {"count_max", asAddr}}},
746      /*isElemental=*/false},
747     {"transfer",
748      &I::genTransfer,
749      {{{"source", asAddr}, {"mold", asAddr}, {"size", asValue}}},
750      /*isElemental=*/false},
751     {"ubound",
752      &I::genUbound,
753      {{{"array", asBox}, {"dim", asValue}, {"kind", asValue}}},
754      /*isElemental=*/false},
755     {"unpack",
756      &I::genUnpack,
757      {{{"vector", asBox}, {"mask", asBox}, {"field", asBox}}},
758      /*isElemental=*/false},
759 };
760 
761 static const IntrinsicHandler *findIntrinsicHandler(llvm::StringRef name) {
762   auto compare = [](const IntrinsicHandler &handler, llvm::StringRef name) {
763     return name.compare(handler.name) > 0;
764   };
765   auto result =
766       std::lower_bound(std::begin(handlers), std::end(handlers), name, compare);
767   return result != std::end(handlers) && result->name == name ? result
768                                                               : nullptr;
769 }
770 
771 /// To make fir output more readable for debug, one can outline all intrinsic
772 /// implementation in wrappers (overrides the IntrinsicHandler::outline flag).
773 static llvm::cl::opt<bool> outlineAllIntrinsics(
774     "outline-intrinsics",
775     llvm::cl::desc(
776         "Lower all intrinsic procedure implementation in their own functions"),
777     llvm::cl::init(false));
778 
779 //===----------------------------------------------------------------------===//
780 // Math runtime description and matching utility
781 //===----------------------------------------------------------------------===//
782 
783 /// Command line option to modify math runtime version used to implement
784 /// intrinsics.
785 enum MathRuntimeVersion { fastVersion, llvmOnly };
786 llvm::cl::opt<MathRuntimeVersion> mathRuntimeVersion(
787     "math-runtime", llvm::cl::desc("Select math runtime version:"),
788     llvm::cl::values(
789         clEnumValN(fastVersion, "fast", "use pgmath fast runtime"),
790         clEnumValN(llvmOnly, "llvm",
791                    "only use LLVM intrinsics (may be incomplete)")),
792     llvm::cl::init(fastVersion));
793 
794 struct RuntimeFunction {
795   // llvm::StringRef comparison operator are not constexpr, so use string_view.
796   using Key = std::string_view;
797   // Needed for implicit compare with keys.
798   constexpr operator Key() const { return key; }
799   Key key; // intrinsic name
800   llvm::StringRef symbol;
801   fir::runtime::FuncTypeBuilderFunc typeGenerator;
802 };
803 
804 #define RUNTIME_STATIC_DESCRIPTION(name, func)                                 \
805   {#name, #func, fir::runtime::RuntimeTableKey<decltype(func)>::getTypeModel()},
806 static constexpr RuntimeFunction pgmathFast[] = {
807 #define PGMATH_FAST
808 #define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func)
809 #include "flang/Evaluate/pgmath.h.inc"
810 };
811 
812 static mlir::FunctionType genF32F32FuncType(mlir::MLIRContext *context) {
813   mlir::Type t = mlir::FloatType::getF32(context);
814   return mlir::FunctionType::get(context, {t}, {t});
815 }
816 
817 static mlir::FunctionType genF64F64FuncType(mlir::MLIRContext *context) {
818   mlir::Type t = mlir::FloatType::getF64(context);
819   return mlir::FunctionType::get(context, {t}, {t});
820 }
821 
822 static mlir::FunctionType genF32F32F32FuncType(mlir::MLIRContext *context) {
823   auto t = mlir::FloatType::getF32(context);
824   return mlir::FunctionType::get(context, {t, t}, {t});
825 }
826 
827 static mlir::FunctionType genF64F64F64FuncType(mlir::MLIRContext *context) {
828   auto t = mlir::FloatType::getF64(context);
829   return mlir::FunctionType::get(context, {t, t}, {t});
830 }
831 
832 template <int Bits>
833 static mlir::FunctionType genIntF64FuncType(mlir::MLIRContext *context) {
834   auto t = mlir::FloatType::getF64(context);
835   auto r = mlir::IntegerType::get(context, Bits);
836   return mlir::FunctionType::get(context, {t}, {r});
837 }
838 
839 template <int Bits>
840 static mlir::FunctionType genIntF32FuncType(mlir::MLIRContext *context) {
841   auto t = mlir::FloatType::getF32(context);
842   auto r = mlir::IntegerType::get(context, Bits);
843   return mlir::FunctionType::get(context, {t}, {r});
844 }
845 
846 // TODO : Fill-up this table with more intrinsic.
847 // Note: These are also defined as operations in LLVM dialect. See if this
848 // can be use and has advantages.
849 static constexpr RuntimeFunction llvmIntrinsics[] = {
850     {"abs", "llvm.fabs.f32", genF32F32FuncType},
851     {"abs", "llvm.fabs.f64", genF64F64FuncType},
852     // llvm.floor is used for FLOOR, but returns real.
853     {"floor", "llvm.floor.f32", genF32F32FuncType},
854     {"floor", "llvm.floor.f64", genF64F64FuncType},
855     {"nint", "llvm.lround.i64.f64", genIntF64FuncType<64>},
856     {"nint", "llvm.lround.i64.f32", genIntF32FuncType<64>},
857     {"nint", "llvm.lround.i32.f64", genIntF64FuncType<32>},
858     {"nint", "llvm.lround.i32.f32", genIntF32FuncType<32>},
859     {"pow", "llvm.pow.f32", genF32F32F32FuncType},
860     {"pow", "llvm.pow.f64", genF64F64F64FuncType},
861 };
862 
863 // This helper class computes a "distance" between two function types.
864 // The distance measures how many narrowing conversions of actual arguments
865 // and result of "from" must be made in order to use "to" instead of "from".
866 // For instance, the distance between ACOS(REAL(10)) and ACOS(REAL(8)) is
867 // greater than the one between ACOS(REAL(10)) and ACOS(REAL(16)). This means
868 // if no implementation of ACOS(REAL(10)) is available, it is better to use
869 // ACOS(REAL(16)) with casts rather than ACOS(REAL(8)).
870 // Note that this is not a symmetric distance and the order of "from" and "to"
871 // arguments matters, d(foo, bar) may not be the same as d(bar, foo) because it
872 // may be safe to replace foo by bar, but not the opposite.
873 class FunctionDistance {
874 public:
875   FunctionDistance() : infinite{true} {}
876 
877   FunctionDistance(mlir::FunctionType from, mlir::FunctionType to) {
878     unsigned nInputs = from.getNumInputs();
879     unsigned nResults = from.getNumResults();
880     if (nResults != to.getNumResults() || nInputs != to.getNumInputs()) {
881       infinite = true;
882     } else {
883       for (decltype(nInputs) i = 0; i < nInputs && !infinite; ++i)
884         addArgumentDistance(from.getInput(i), to.getInput(i));
885       for (decltype(nResults) i = 0; i < nResults && !infinite; ++i)
886         addResultDistance(to.getResult(i), from.getResult(i));
887     }
888   }
889 
890   /// Beware both d1.isSmallerThan(d2) *and* d2.isSmallerThan(d1) may be
891   /// false if both d1 and d2 are infinite. This implies that
892   ///  d1.isSmallerThan(d2) is not equivalent to !d2.isSmallerThan(d1)
893   bool isSmallerThan(const FunctionDistance &d) const {
894     return !infinite &&
895            (d.infinite || std::lexicographical_compare(
896                               conversions.begin(), conversions.end(),
897                               d.conversions.begin(), d.conversions.end()));
898   }
899 
900   bool isLosingPrecision() const {
901     return conversions[narrowingArg] != 0 || conversions[extendingResult] != 0;
902   }
903 
904   bool isInfinite() const { return infinite; }
905 
906 private:
907   enum class Conversion { Forbidden, None, Narrow, Extend };
908 
909   void addArgumentDistance(mlir::Type from, mlir::Type to) {
910     switch (conversionBetweenTypes(from, to)) {
911     case Conversion::Forbidden:
912       infinite = true;
913       break;
914     case Conversion::None:
915       break;
916     case Conversion::Narrow:
917       conversions[narrowingArg]++;
918       break;
919     case Conversion::Extend:
920       conversions[nonNarrowingArg]++;
921       break;
922     }
923   }
924 
925   void addResultDistance(mlir::Type from, mlir::Type to) {
926     switch (conversionBetweenTypes(from, to)) {
927     case Conversion::Forbidden:
928       infinite = true;
929       break;
930     case Conversion::None:
931       break;
932     case Conversion::Narrow:
933       conversions[nonExtendingResult]++;
934       break;
935     case Conversion::Extend:
936       conversions[extendingResult]++;
937       break;
938     }
939   }
940 
941   // Floating point can be mlir::FloatType or fir::real
942   static unsigned getFloatingPointWidth(mlir::Type t) {
943     if (auto f{t.dyn_cast<mlir::FloatType>()})
944       return f.getWidth();
945     // FIXME: Get width another way for fir.real/complex
946     // - use fir/KindMapping.h and llvm::Type
947     // - or use evaluate/type.h
948     if (auto r{t.dyn_cast<fir::RealType>()})
949       return r.getFKind() * 4;
950     if (auto cplx{t.dyn_cast<fir::ComplexType>()})
951       return cplx.getFKind() * 4;
952     llvm_unreachable("not a floating-point type");
953   }
954 
955   static Conversion conversionBetweenTypes(mlir::Type from, mlir::Type to) {
956     if (from == to)
957       return Conversion::None;
958 
959     if (auto fromIntTy{from.dyn_cast<mlir::IntegerType>()}) {
960       if (auto toIntTy{to.dyn_cast<mlir::IntegerType>()}) {
961         return fromIntTy.getWidth() > toIntTy.getWidth() ? Conversion::Narrow
962                                                          : Conversion::Extend;
963       }
964     }
965 
966     if (fir::isa_real(from) && fir::isa_real(to)) {
967       return getFloatingPointWidth(from) > getFloatingPointWidth(to)
968                  ? Conversion::Narrow
969                  : Conversion::Extend;
970     }
971 
972     if (auto fromCplxTy{from.dyn_cast<fir::ComplexType>()}) {
973       if (auto toCplxTy{to.dyn_cast<fir::ComplexType>()}) {
974         return getFloatingPointWidth(fromCplxTy) >
975                        getFloatingPointWidth(toCplxTy)
976                    ? Conversion::Narrow
977                    : Conversion::Extend;
978       }
979     }
980     // Notes:
981     // - No conversion between character types, specialization of runtime
982     // functions should be made instead.
983     // - It is not clear there is a use case for automatic conversions
984     // around Logical and it may damage hidden information in the physical
985     // storage so do not do it.
986     return Conversion::Forbidden;
987   }
988 
989   // Below are indexes to access data in conversions.
990   // The order in data does matter for lexicographical_compare
991   enum {
992     narrowingArg = 0,   // usually bad
993     extendingResult,    // usually bad
994     nonExtendingResult, // usually ok
995     nonNarrowingArg,    // usually ok
996     dataSize
997   };
998 
999   std::array<int, dataSize> conversions = {};
1000   bool infinite = false; // When forbidden conversion or wrong argument number
1001 };
1002 
1003 /// Build mlir::FuncOp from runtime symbol description and add
1004 /// fir.runtime attribute.
1005 static mlir::FuncOp getFuncOp(mlir::Location loc, fir::FirOpBuilder &builder,
1006                               const RuntimeFunction &runtime) {
1007   mlir::FuncOp function = builder.addNamedFunction(
1008       loc, runtime.symbol, runtime.typeGenerator(builder.getContext()));
1009   function->setAttr("fir.runtime", builder.getUnitAttr());
1010   return function;
1011 }
1012 
1013 /// Select runtime function that has the smallest distance to the intrinsic
1014 /// function type and that will not imply narrowing arguments or extending the
1015 /// result.
1016 /// If nothing is found, the mlir::FuncOp will contain a nullptr.
1017 mlir::FuncOp searchFunctionInLibrary(
1018     mlir::Location loc, fir::FirOpBuilder &builder,
1019     const Fortran::common::StaticMultimapView<RuntimeFunction> &lib,
1020     llvm::StringRef name, mlir::FunctionType funcType,
1021     const RuntimeFunction **bestNearMatch,
1022     FunctionDistance &bestMatchDistance) {
1023   std::pair<const RuntimeFunction *, const RuntimeFunction *> range =
1024       lib.equal_range(name);
1025   for (auto iter = range.first; iter != range.second && iter; ++iter) {
1026     const RuntimeFunction &impl = *iter;
1027     mlir::FunctionType implType = impl.typeGenerator(builder.getContext());
1028     if (funcType == implType)
1029       return getFuncOp(loc, builder, impl); // exact match
1030 
1031     FunctionDistance distance(funcType, implType);
1032     if (distance.isSmallerThan(bestMatchDistance)) {
1033       *bestNearMatch = &impl;
1034       bestMatchDistance = std::move(distance);
1035     }
1036   }
1037   return {};
1038 }
1039 
1040 /// Search runtime for the best runtime function given an intrinsic name
1041 /// and interface. The interface may not be a perfect match in which case
1042 /// the caller is responsible to insert argument and return value conversions.
1043 /// If nothing is found, the mlir::FuncOp will contain a nullptr.
1044 static mlir::FuncOp getRuntimeFunction(mlir::Location loc,
1045                                        fir::FirOpBuilder &builder,
1046                                        llvm::StringRef name,
1047                                        mlir::FunctionType funcType) {
1048   const RuntimeFunction *bestNearMatch = nullptr;
1049   FunctionDistance bestMatchDistance{};
1050   mlir::FuncOp match;
1051   using RtMap = Fortran::common::StaticMultimapView<RuntimeFunction>;
1052   static constexpr RtMap pgmathF(pgmathFast);
1053   static_assert(pgmathF.Verify() && "map must be sorted");
1054   if (mathRuntimeVersion == fastVersion) {
1055     match = searchFunctionInLibrary(loc, builder, pgmathF, name, funcType,
1056                                     &bestNearMatch, bestMatchDistance);
1057   } else {
1058     assert(mathRuntimeVersion == llvmOnly && "unknown math runtime");
1059   }
1060   if (match)
1061     return match;
1062 
1063   // Go through llvm intrinsics if not exact match in libpgmath or if
1064   // mathRuntimeVersion == llvmOnly
1065   static constexpr RtMap llvmIntr(llvmIntrinsics);
1066   static_assert(llvmIntr.Verify() && "map must be sorted");
1067   if (mlir::FuncOp exactMatch =
1068           searchFunctionInLibrary(loc, builder, llvmIntr, name, funcType,
1069                                   &bestNearMatch, bestMatchDistance))
1070     return exactMatch;
1071 
1072   if (bestNearMatch != nullptr) {
1073     if (bestMatchDistance.isLosingPrecision()) {
1074       // Using this runtime version requires narrowing the arguments
1075       // or extending the result. It is not numerically safe. There
1076       // is currently no quad math library that was described in
1077       // lowering and could be used here. Emit an error and continue
1078       // generating the code with the narrowing cast so that the user
1079       // can get a complete list of the problematic intrinsic calls.
1080       std::string message("TODO: no math runtime available for '");
1081       llvm::raw_string_ostream sstream(message);
1082       if (name == "pow") {
1083         assert(funcType.getNumInputs() == 2 &&
1084                "power operator has two arguments");
1085         sstream << funcType.getInput(0) << " ** " << funcType.getInput(1);
1086       } else {
1087         sstream << name << "(";
1088         if (funcType.getNumInputs() > 0)
1089           sstream << funcType.getInput(0);
1090         for (mlir::Type argType : funcType.getInputs().drop_front())
1091           sstream << ", " << argType;
1092         sstream << ")";
1093       }
1094       sstream << "'";
1095       mlir::emitError(loc, message);
1096     }
1097     return getFuncOp(loc, builder, *bestNearMatch);
1098   }
1099   return {};
1100 }
1101 
1102 /// Helpers to get function type from arguments and result type.
1103 static mlir::FunctionType getFunctionType(llvm::Optional<mlir::Type> resultType,
1104                                           llvm::ArrayRef<mlir::Value> arguments,
1105                                           fir::FirOpBuilder &builder) {
1106   llvm::SmallVector<mlir::Type> argTypes;
1107   for (mlir::Value arg : arguments)
1108     argTypes.push_back(arg.getType());
1109   llvm::SmallVector<mlir::Type> resTypes;
1110   if (resultType)
1111     resTypes.push_back(*resultType);
1112   return mlir::FunctionType::get(builder.getModule().getContext(), argTypes,
1113                                  resTypes);
1114 }
1115 
1116 /// fir::ExtendedValue to mlir::Value translation layer
1117 
1118 fir::ExtendedValue toExtendedValue(mlir::Value val, fir::FirOpBuilder &builder,
1119                                    mlir::Location loc) {
1120   assert(val && "optional unhandled here");
1121   mlir::Type type = val.getType();
1122   mlir::Value base = val;
1123   mlir::IndexType indexType = builder.getIndexType();
1124   llvm::SmallVector<mlir::Value> extents;
1125 
1126   fir::factory::CharacterExprHelper charHelper{builder, loc};
1127   // FIXME: we may want to allow non character scalar here.
1128   if (charHelper.isCharacterScalar(type))
1129     return charHelper.toExtendedValue(val);
1130 
1131   if (auto refType = type.dyn_cast<fir::ReferenceType>())
1132     type = refType.getEleTy();
1133 
1134   if (auto arrayType = type.dyn_cast<fir::SequenceType>()) {
1135     type = arrayType.getEleTy();
1136     for (fir::SequenceType::Extent extent : arrayType.getShape()) {
1137       if (extent == fir::SequenceType::getUnknownExtent())
1138         break;
1139       extents.emplace_back(
1140           builder.createIntegerConstant(loc, indexType, extent));
1141     }
1142     // Last extent might be missing in case of assumed-size. If more extents
1143     // could not be deduced from type, that's an error (a fir.box should
1144     // have been used in the interface).
1145     if (extents.size() + 1 < arrayType.getShape().size())
1146       mlir::emitError(loc, "cannot retrieve array extents from type");
1147   } else if (type.isa<fir::BoxType>() || type.isa<fir::RecordType>()) {
1148     fir::emitFatalError(loc, "not yet implemented: descriptor or derived type");
1149   }
1150 
1151   if (!extents.empty())
1152     return fir::ArrayBoxValue{base, extents};
1153   return base;
1154 }
1155 
1156 mlir::Value toValue(const fir::ExtendedValue &val, fir::FirOpBuilder &builder,
1157                     mlir::Location loc) {
1158   if (const fir::CharBoxValue *charBox = val.getCharBox()) {
1159     mlir::Value buffer = charBox->getBuffer();
1160     if (buffer.getType().isa<fir::BoxCharType>())
1161       return buffer;
1162     return fir::factory::CharacterExprHelper{builder, loc}.createEmboxChar(
1163         buffer, charBox->getLen());
1164   }
1165 
1166   // FIXME: need to access other ExtendedValue variants and handle them
1167   // properly.
1168   return fir::getBase(val);
1169 }
1170 
1171 //===----------------------------------------------------------------------===//
1172 // IntrinsicLibrary
1173 //===----------------------------------------------------------------------===//
1174 
1175 /// Emit a TODO error message for as yet unimplemented intrinsics.
1176 static void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) {
1177   TODO(loc, "missing intrinsic lowering: " + llvm::Twine(name));
1178 }
1179 
1180 template <typename GeneratorType>
1181 fir::ExtendedValue IntrinsicLibrary::genElementalCall(
1182     GeneratorType generator, llvm::StringRef name, mlir::Type resultType,
1183     llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
1184   llvm::SmallVector<mlir::Value> scalarArgs;
1185   for (const fir::ExtendedValue &arg : args)
1186     if (arg.getUnboxed() || arg.getCharBox())
1187       scalarArgs.emplace_back(fir::getBase(arg));
1188     else
1189       fir::emitFatalError(loc, "nonscalar intrinsic argument");
1190   return invokeGenerator(generator, resultType, scalarArgs);
1191 }
1192 
1193 template <>
1194 fir::ExtendedValue
1195 IntrinsicLibrary::genElementalCall<IntrinsicLibrary::ExtendedGenerator>(
1196     ExtendedGenerator generator, llvm::StringRef name, mlir::Type resultType,
1197     llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
1198   for (const fir::ExtendedValue &arg : args)
1199     if (!arg.getUnboxed() && !arg.getCharBox())
1200       fir::emitFatalError(loc, "nonscalar intrinsic argument");
1201   if (outline)
1202     return outlineInExtendedWrapper(generator, name, resultType, args);
1203   return std::invoke(generator, *this, resultType, args);
1204 }
1205 
1206 template <>
1207 fir::ExtendedValue
1208 IntrinsicLibrary::genElementalCall<IntrinsicLibrary::SubroutineGenerator>(
1209     SubroutineGenerator generator, llvm::StringRef name, mlir::Type resultType,
1210     llvm::ArrayRef<fir::ExtendedValue> args, bool outline) {
1211   for (const fir::ExtendedValue &arg : args)
1212     if (!arg.getUnboxed() && !arg.getCharBox())
1213       // fir::emitFatalError(loc, "nonscalar intrinsic argument");
1214       crashOnMissingIntrinsic(loc, name);
1215   if (outline)
1216     return outlineInExtendedWrapper(generator, name, resultType, args);
1217   std::invoke(generator, *this, args);
1218   return mlir::Value();
1219 }
1220 
1221 static fir::ExtendedValue
1222 invokeHandler(IntrinsicLibrary::ElementalGenerator generator,
1223               const IntrinsicHandler &handler,
1224               llvm::Optional<mlir::Type> resultType,
1225               llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
1226               IntrinsicLibrary &lib) {
1227   assert(resultType && "expect elemental intrinsic to be functions");
1228   return lib.genElementalCall(generator, handler.name, *resultType, args,
1229                               outline);
1230 }
1231 
1232 static fir::ExtendedValue
1233 invokeHandler(IntrinsicLibrary::ExtendedGenerator generator,
1234               const IntrinsicHandler &handler,
1235               llvm::Optional<mlir::Type> resultType,
1236               llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
1237               IntrinsicLibrary &lib) {
1238   assert(resultType && "expect intrinsic function");
1239   if (handler.isElemental)
1240     return lib.genElementalCall(generator, handler.name, *resultType, args,
1241                                 outline);
1242   if (outline)
1243     return lib.outlineInExtendedWrapper(generator, handler.name, *resultType,
1244                                         args);
1245   return std::invoke(generator, lib, *resultType, args);
1246 }
1247 
1248 static fir::ExtendedValue
1249 invokeHandler(IntrinsicLibrary::SubroutineGenerator generator,
1250               const IntrinsicHandler &handler,
1251               llvm::Optional<mlir::Type> resultType,
1252               llvm::ArrayRef<fir::ExtendedValue> args, bool outline,
1253               IntrinsicLibrary &lib) {
1254   if (handler.isElemental)
1255     return lib.genElementalCall(generator, handler.name, mlir::Type{}, args,
1256                                 outline);
1257   if (outline)
1258     return lib.outlineInExtendedWrapper(generator, handler.name, resultType,
1259                                         args);
1260   std::invoke(generator, lib, args);
1261   return mlir::Value{};
1262 }
1263 
1264 fir::ExtendedValue
1265 IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name,
1266                                    llvm::Optional<mlir::Type> resultType,
1267                                    llvm::ArrayRef<fir::ExtendedValue> args) {
1268   if (const IntrinsicHandler *handler = findIntrinsicHandler(name)) {
1269     bool outline = handler->outline || outlineAllIntrinsics;
1270     return std::visit(
1271         [&](auto &generator) -> fir::ExtendedValue {
1272           return invokeHandler(generator, *handler, resultType, args, outline,
1273                                *this);
1274         },
1275         handler->generator);
1276   }
1277 
1278   if (!resultType)
1279     // Subroutine should have a handler, they are likely missing for now.
1280     crashOnMissingIntrinsic(loc, name);
1281 
1282   // Try the runtime if no special handler was defined for the
1283   // intrinsic being called. Maths runtime only has numerical elemental.
1284   // No optional arguments are expected at this point, the code will
1285   // crash if it gets absent optional.
1286 
1287   // FIXME: using toValue to get the type won't work with array arguments.
1288   llvm::SmallVector<mlir::Value> mlirArgs;
1289   for (const fir::ExtendedValue &extendedVal : args) {
1290     mlir::Value val = toValue(extendedVal, builder, loc);
1291     if (!val)
1292       // If an absent optional gets there, most likely its handler has just
1293       // not yet been defined.
1294       crashOnMissingIntrinsic(loc, name);
1295     mlirArgs.emplace_back(val);
1296   }
1297   mlir::FunctionType soughtFuncType =
1298       getFunctionType(*resultType, mlirArgs, builder);
1299 
1300   IntrinsicLibrary::RuntimeCallGenerator runtimeCallGenerator =
1301       getRuntimeCallGenerator(name, soughtFuncType);
1302   return genElementalCall(runtimeCallGenerator, name, *resultType, args,
1303                           /* outline */ true);
1304 }
1305 
1306 mlir::Value
1307 IntrinsicLibrary::invokeGenerator(ElementalGenerator generator,
1308                                   mlir::Type resultType,
1309                                   llvm::ArrayRef<mlir::Value> args) {
1310   return std::invoke(generator, *this, resultType, args);
1311 }
1312 
1313 mlir::Value
1314 IntrinsicLibrary::invokeGenerator(RuntimeCallGenerator generator,
1315                                   mlir::Type resultType,
1316                                   llvm::ArrayRef<mlir::Value> args) {
1317   return generator(builder, loc, args);
1318 }
1319 
1320 mlir::Value
1321 IntrinsicLibrary::invokeGenerator(ExtendedGenerator generator,
1322                                   mlir::Type resultType,
1323                                   llvm::ArrayRef<mlir::Value> args) {
1324   llvm::SmallVector<fir::ExtendedValue> extendedArgs;
1325   for (mlir::Value arg : args)
1326     extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
1327   auto extendedResult = std::invoke(generator, *this, resultType, extendedArgs);
1328   return toValue(extendedResult, builder, loc);
1329 }
1330 
1331 mlir::Value
1332 IntrinsicLibrary::invokeGenerator(SubroutineGenerator generator,
1333                                   llvm::ArrayRef<mlir::Value> args) {
1334   llvm::SmallVector<fir::ExtendedValue> extendedArgs;
1335   for (mlir::Value arg : args)
1336     extendedArgs.emplace_back(toExtendedValue(arg, builder, loc));
1337   std::invoke(generator, *this, extendedArgs);
1338   return {};
1339 }
1340 
1341 template <typename GeneratorType>
1342 mlir::FuncOp IntrinsicLibrary::getWrapper(GeneratorType generator,
1343                                           llvm::StringRef name,
1344                                           mlir::FunctionType funcType,
1345                                           bool loadRefArguments) {
1346   std::string wrapperName = fir::mangleIntrinsicProcedure(name, funcType);
1347   mlir::FuncOp function = builder.getNamedFunction(wrapperName);
1348   if (!function) {
1349     // First time this wrapper is needed, build it.
1350     function = builder.createFunction(loc, wrapperName, funcType);
1351     function->setAttr("fir.intrinsic", builder.getUnitAttr());
1352     auto internalLinkage = mlir::LLVM::linkage::Linkage::Internal;
1353     auto linkage =
1354         mlir::LLVM::LinkageAttr::get(builder.getContext(), internalLinkage);
1355     function->setAttr("llvm.linkage", linkage);
1356     function.addEntryBlock();
1357 
1358     // Create local context to emit code into the newly created function
1359     // This new function is not linked to a source file location, only
1360     // its calls will be.
1361     auto localBuilder =
1362         std::make_unique<fir::FirOpBuilder>(function, builder.getKindMap());
1363     localBuilder->setInsertionPointToStart(&function.front());
1364     // Location of code inside wrapper of the wrapper is independent from
1365     // the location of the intrinsic call.
1366     mlir::Location localLoc = localBuilder->getUnknownLoc();
1367     llvm::SmallVector<mlir::Value> localArguments;
1368     for (mlir::BlockArgument bArg : function.front().getArguments()) {
1369       auto refType = bArg.getType().dyn_cast<fir::ReferenceType>();
1370       if (loadRefArguments && refType) {
1371         auto loaded = localBuilder->create<fir::LoadOp>(localLoc, bArg);
1372         localArguments.push_back(loaded);
1373       } else {
1374         localArguments.push_back(bArg);
1375       }
1376     }
1377 
1378     IntrinsicLibrary localLib{*localBuilder, localLoc};
1379 
1380     if constexpr (std::is_same_v<GeneratorType, SubroutineGenerator>) {
1381       localLib.invokeGenerator(generator, localArguments);
1382       localBuilder->create<mlir::func::ReturnOp>(localLoc);
1383     } else {
1384       assert(funcType.getNumResults() == 1 &&
1385              "expect one result for intrinsic function wrapper type");
1386       mlir::Type resultType = funcType.getResult(0);
1387       auto result =
1388           localLib.invokeGenerator(generator, resultType, localArguments);
1389       localBuilder->create<mlir::func::ReturnOp>(localLoc, result);
1390     }
1391   } else {
1392     // Wrapper was already built, ensure it has the sought type
1393     assert(function.getType() == funcType &&
1394            "conflict between intrinsic wrapper types");
1395   }
1396   return function;
1397 }
1398 
1399 /// Helpers to detect absent optional (not yet supported in outlining).
1400 bool static hasAbsentOptional(llvm::ArrayRef<fir::ExtendedValue> args) {
1401   for (const fir::ExtendedValue &arg : args)
1402     if (!fir::getBase(arg))
1403       return true;
1404   return false;
1405 }
1406 
1407 template <typename GeneratorType>
1408 fir::ExtendedValue IntrinsicLibrary::outlineInExtendedWrapper(
1409     GeneratorType generator, llvm::StringRef name,
1410     llvm::Optional<mlir::Type> resultType,
1411     llvm::ArrayRef<fir::ExtendedValue> args) {
1412   if (hasAbsentOptional(args))
1413     TODO(loc, "cannot outline call to intrinsic " + llvm::Twine(name) +
1414                   " with absent optional argument");
1415   llvm::SmallVector<mlir::Value> mlirArgs;
1416   for (const auto &extendedVal : args)
1417     mlirArgs.emplace_back(toValue(extendedVal, builder, loc));
1418   mlir::FunctionType funcType = getFunctionType(resultType, mlirArgs, builder);
1419   mlir::FuncOp wrapper = getWrapper(generator, name, funcType);
1420   auto call = builder.create<fir::CallOp>(loc, wrapper, mlirArgs);
1421   if (resultType)
1422     return toExtendedValue(call.getResult(0), builder, loc);
1423   // Subroutine calls
1424   return mlir::Value{};
1425 }
1426 
1427 IntrinsicLibrary::RuntimeCallGenerator
1428 IntrinsicLibrary::getRuntimeCallGenerator(llvm::StringRef name,
1429                                           mlir::FunctionType soughtFuncType) {
1430   mlir::FuncOp funcOp = getRuntimeFunction(loc, builder, name, soughtFuncType);
1431   if (!funcOp) {
1432     std::string buffer("not yet implemented: missing intrinsic lowering: ");
1433     llvm::raw_string_ostream sstream(buffer);
1434     sstream << name << "\nrequested type was: " << soughtFuncType << '\n';
1435     fir::emitFatalError(loc, buffer);
1436   }
1437 
1438   mlir::FunctionType actualFuncType = funcOp.getType();
1439   assert(actualFuncType.getNumResults() == soughtFuncType.getNumResults() &&
1440          actualFuncType.getNumInputs() == soughtFuncType.getNumInputs() &&
1441          actualFuncType.getNumResults() == 1 && "Bad intrinsic match");
1442 
1443   return [funcOp, actualFuncType,
1444           soughtFuncType](fir::FirOpBuilder &builder, mlir::Location loc,
1445                           llvm::ArrayRef<mlir::Value> args) {
1446     llvm::SmallVector<mlir::Value> convertedArguments;
1447     for (auto [fst, snd] : llvm::zip(actualFuncType.getInputs(), args))
1448       convertedArguments.push_back(builder.createConvert(loc, fst, snd));
1449     auto call = builder.create<fir::CallOp>(loc, funcOp, convertedArguments);
1450     mlir::Type soughtType = soughtFuncType.getResult(0);
1451     return builder.createConvert(loc, soughtType, call.getResult(0));
1452   };
1453 }
1454 
1455 void IntrinsicLibrary::addCleanUpForTemp(mlir::Location loc, mlir::Value temp) {
1456   assert(stmtCtx);
1457   fir::FirOpBuilder *bldr = &builder;
1458   stmtCtx->attachCleanup([=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
1459 }
1460 
1461 fir::ExtendedValue
1462 IntrinsicLibrary::readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,
1463                                     mlir::Type resultType,
1464                                     llvm::StringRef intrinsicName) {
1465   fir::ExtendedValue res =
1466       fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
1467   return res.match(
1468       [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
1469         // Add cleanup code
1470         addCleanUpForTemp(loc, box.getAddr());
1471         return box;
1472       },
1473       [&](const fir::BoxValue &box) -> fir::ExtendedValue {
1474         // Add cleanup code
1475         auto addr =
1476             builder.create<fir::BoxAddrOp>(loc, box.getMemTy(), box.getAddr());
1477         addCleanUpForTemp(loc, addr);
1478         return box;
1479       },
1480       [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue {
1481         // Add cleanup code
1482         addCleanUpForTemp(loc, box.getAddr());
1483         return box;
1484       },
1485       [&](const mlir::Value &tempAddr) -> fir::ExtendedValue {
1486         // Add cleanup code
1487         addCleanUpForTemp(loc, tempAddr);
1488         return builder.create<fir::LoadOp>(loc, resultType, tempAddr);
1489       },
1490       [&](const fir::CharBoxValue &box) -> fir::ExtendedValue {
1491         // Add cleanup code
1492         addCleanUpForTemp(loc, box.getAddr());
1493         return box;
1494       },
1495       [&](const auto &) -> fir::ExtendedValue {
1496         fir::emitFatalError(loc, "unexpected result for " + intrinsicName);
1497       });
1498 }
1499 
1500 //===----------------------------------------------------------------------===//
1501 // Code generators for the intrinsic
1502 //===----------------------------------------------------------------------===//
1503 
1504 mlir::Value IntrinsicLibrary::genRuntimeCall(llvm::StringRef name,
1505                                              mlir::Type resultType,
1506                                              llvm::ArrayRef<mlir::Value> args) {
1507   mlir::FunctionType soughtFuncType =
1508       getFunctionType(resultType, args, builder);
1509   return getRuntimeCallGenerator(name, soughtFuncType)(builder, loc, args);
1510 }
1511 
1512 // ABS
1513 mlir::Value IntrinsicLibrary::genAbs(mlir::Type resultType,
1514                                      llvm::ArrayRef<mlir::Value> args) {
1515   assert(args.size() == 1);
1516   mlir::Value arg = args[0];
1517   mlir::Type type = arg.getType();
1518   if (fir::isa_real(type)) {
1519     // Runtime call to fp abs. An alternative would be to use mlir
1520     // math::AbsFOp but it does not support all fir floating point types.
1521     return genRuntimeCall("abs", resultType, args);
1522   }
1523   if (auto intType = type.dyn_cast<mlir::IntegerType>()) {
1524     // At the time of this implementation there is no abs op in mlir.
1525     // So, implement abs here without branching.
1526     mlir::Value shift =
1527         builder.createIntegerConstant(loc, intType, intType.getWidth() - 1);
1528     auto mask = builder.create<mlir::arith::ShRSIOp>(loc, arg, shift);
1529     auto xored = builder.create<mlir::arith::XOrIOp>(loc, arg, mask);
1530     return builder.create<mlir::arith::SubIOp>(loc, xored, mask);
1531   }
1532   if (fir::isa_complex(type)) {
1533     // Use HYPOT to fulfill the no underflow/overflow requirement.
1534     auto parts = fir::factory::Complex{builder, loc}.extractParts(arg);
1535     llvm::SmallVector<mlir::Value> args = {parts.first, parts.second};
1536     return genRuntimeCall("hypot", resultType, args);
1537   }
1538   llvm_unreachable("unexpected type in ABS argument");
1539 }
1540 
1541 // ADJUSTL & ADJUSTR
1542 template <void (*CallRuntime)(fir::FirOpBuilder &, mlir::Location loc,
1543                               mlir::Value, mlir::Value)>
1544 fir::ExtendedValue
1545 IntrinsicLibrary::genAdjustRtCall(mlir::Type resultType,
1546                                   llvm::ArrayRef<fir::ExtendedValue> args) {
1547   assert(args.size() == 1);
1548   mlir::Value string = builder.createBox(loc, args[0]);
1549   // Create a mutable fir.box to be passed to the runtime for the result.
1550   fir::MutableBoxValue resultMutableBox =
1551       fir::factory::createTempMutableBox(builder, loc, resultType);
1552   mlir::Value resultIrBox =
1553       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
1554 
1555   // Call the runtime -- the runtime will allocate the result.
1556   CallRuntime(builder, loc, resultIrBox, string);
1557 
1558   // Read result from mutable fir.box and add it to the list of temps to be
1559   // finalized by the StatementContext.
1560   fir::ExtendedValue res =
1561       fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
1562   return res.match(
1563       [&](const fir::CharBoxValue &box) -> fir::ExtendedValue {
1564         addCleanUpForTemp(loc, fir::getBase(box));
1565         return box;
1566       },
1567       [&](const auto &) -> fir::ExtendedValue {
1568         fir::emitFatalError(loc, "result of ADJUSTL is not a scalar character");
1569       });
1570 }
1571 
1572 // AIMAG
1573 mlir::Value IntrinsicLibrary::genAimag(mlir::Type resultType,
1574                                        llvm::ArrayRef<mlir::Value> args) {
1575   assert(args.size() == 1);
1576   return fir::factory::Complex{builder, loc}.extractComplexPart(
1577       args[0], true /* isImagPart */);
1578 }
1579 
1580 // ALL
1581 fir::ExtendedValue
1582 IntrinsicLibrary::genAll(mlir::Type resultType,
1583                          llvm::ArrayRef<fir::ExtendedValue> args) {
1584 
1585   assert(args.size() == 2);
1586   // Handle required mask argument
1587   mlir::Value mask = builder.createBox(loc, args[0]);
1588 
1589   fir::BoxValue maskArry = builder.createBox(loc, args[0]);
1590   int rank = maskArry.rank();
1591   assert(rank >= 1);
1592 
1593   // Handle optional dim argument
1594   bool absentDim = isAbsent(args[1]);
1595   mlir::Value dim =
1596       absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
1597                 : fir::getBase(args[1]);
1598 
1599   if (rank == 1 || absentDim)
1600     return builder.createConvert(loc, resultType,
1601                                  fir::runtime::genAll(builder, loc, mask, dim));
1602 
1603   // else use the result descriptor AllDim() intrinsic
1604 
1605   // Create mutable fir.box to be passed to the runtime for the result.
1606 
1607   mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
1608   fir::MutableBoxValue resultMutableBox =
1609       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
1610   mlir::Value resultIrBox =
1611       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
1612 
1613   // Call runtime. The runtime is allocating the result.
1614   fir::runtime::genAllDescriptor(builder, loc, resultIrBox, mask, dim);
1615   return fir::factory::genMutableBoxRead(builder, loc, resultMutableBox)
1616       .match(
1617           [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
1618             addCleanUpForTemp(loc, box.getAddr());
1619             return box;
1620           },
1621           [&](const auto &) -> fir::ExtendedValue {
1622             fir::emitFatalError(loc, "Invalid result for ALL");
1623           });
1624 }
1625 
1626 // ALLOCATED
1627 fir::ExtendedValue
1628 IntrinsicLibrary::genAllocated(mlir::Type resultType,
1629                                llvm::ArrayRef<fir::ExtendedValue> args) {
1630   assert(args.size() == 1);
1631   return args[0].match(
1632       [&](const fir::MutableBoxValue &x) -> fir::ExtendedValue {
1633         return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, x);
1634       },
1635       [&](const auto &) -> fir::ExtendedValue {
1636         fir::emitFatalError(loc,
1637                             "allocated arg not lowered to MutableBoxValue");
1638       });
1639 }
1640 
1641 // ANY
1642 fir::ExtendedValue
1643 IntrinsicLibrary::genAny(mlir::Type resultType,
1644                          llvm::ArrayRef<fir::ExtendedValue> args) {
1645 
1646   assert(args.size() == 2);
1647   // Handle required mask argument
1648   mlir::Value mask = builder.createBox(loc, args[0]);
1649 
1650   fir::BoxValue maskArry = builder.createBox(loc, args[0]);
1651   int rank = maskArry.rank();
1652   assert(rank >= 1);
1653 
1654   // Handle optional dim argument
1655   bool absentDim = isAbsent(args[1]);
1656   mlir::Value dim =
1657       absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
1658                 : fir::getBase(args[1]);
1659 
1660   if (rank == 1 || absentDim)
1661     return builder.createConvert(loc, resultType,
1662                                  fir::runtime::genAny(builder, loc, mask, dim));
1663 
1664   // else use the result descriptor AnyDim() intrinsic
1665 
1666   // Create mutable fir.box to be passed to the runtime for the result.
1667 
1668   mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
1669   fir::MutableBoxValue resultMutableBox =
1670       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
1671   mlir::Value resultIrBox =
1672       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
1673 
1674   // Call runtime. The runtime is allocating the result.
1675   fir::runtime::genAnyDescriptor(builder, loc, resultIrBox, mask, dim);
1676   return fir::factory::genMutableBoxRead(builder, loc, resultMutableBox)
1677       .match(
1678           [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
1679             addCleanUpForTemp(loc, box.getAddr());
1680             return box;
1681           },
1682           [&](const auto &) -> fir::ExtendedValue {
1683             fir::emitFatalError(loc, "Invalid result for ANY");
1684           });
1685 }
1686 
1687 // ASSOCIATED
1688 fir::ExtendedValue
1689 IntrinsicLibrary::genAssociated(mlir::Type resultType,
1690                                 llvm::ArrayRef<fir::ExtendedValue> args) {
1691   assert(args.size() == 2);
1692   auto *pointer =
1693       args[0].match([&](const fir::MutableBoxValue &x) { return &x; },
1694                     [&](const auto &) -> const fir::MutableBoxValue * {
1695                       fir::emitFatalError(loc, "pointer not a MutableBoxValue");
1696                     });
1697   const fir::ExtendedValue &target = args[1];
1698   if (isAbsent(target))
1699     return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, *pointer);
1700 
1701   mlir::Value targetBox = builder.createBox(loc, target);
1702   if (fir::valueHasFirAttribute(fir::getBase(target),
1703                                 fir::getOptionalAttrName())) {
1704     // Subtle: contrary to other intrinsic optional arguments, disassociated
1705     // POINTER and unallocated ALLOCATABLE actual argument are not considered
1706     // absent here. This is because ASSOCIATED has special requirements for
1707     // TARGET actual arguments that are POINTERs. There is no precise
1708     // requirements for ALLOCATABLEs, but all existing Fortran compilers treat
1709     // them similarly to POINTERs. That is: unallocated TARGETs cause ASSOCIATED
1710     // to rerun false.  The runtime deals with the disassociated/unallocated
1711     // case. Simply ensures that TARGET that are OPTIONAL get conditionally
1712     // emboxed here to convey the optional aspect to the runtime.
1713     auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
1714                                                       fir::getBase(target));
1715     auto absentBox = builder.create<fir::AbsentOp>(loc, targetBox.getType());
1716     targetBox = builder.create<mlir::arith::SelectOp>(loc, isPresent, targetBox,
1717                                                       absentBox);
1718   }
1719   mlir::Value pointerBoxRef =
1720       fir::factory::getMutableIRBox(builder, loc, *pointer);
1721   auto pointerBox = builder.create<fir::LoadOp>(loc, pointerBoxRef);
1722   return Fortran::lower::genAssociated(builder, loc, pointerBox, targetBox);
1723 }
1724 
1725 // CHAR
1726 fir::ExtendedValue
1727 IntrinsicLibrary::genChar(mlir::Type type,
1728                           llvm::ArrayRef<fir::ExtendedValue> args) {
1729   // Optional KIND argument.
1730   assert(args.size() >= 1);
1731   const mlir::Value *arg = args[0].getUnboxed();
1732   // expect argument to be a scalar integer
1733   if (!arg)
1734     mlir::emitError(loc, "CHAR intrinsic argument not unboxed");
1735   fir::factory::CharacterExprHelper helper{builder, loc};
1736   fir::CharacterType::KindTy kind = helper.getCharacterType(type).getFKind();
1737   mlir::Value cast = helper.createSingletonFromCode(*arg, kind);
1738   mlir::Value len =
1739       builder.createIntegerConstant(loc, builder.getCharacterLengthType(), 1);
1740   return fir::CharBoxValue{cast, len};
1741 }
1742 
1743 // COUNT
1744 fir::ExtendedValue
1745 IntrinsicLibrary::genCount(mlir::Type resultType,
1746                            llvm::ArrayRef<fir::ExtendedValue> args) {
1747   assert(args.size() == 3);
1748 
1749   // Handle mask argument
1750   fir::BoxValue mask = builder.createBox(loc, args[0]);
1751   unsigned maskRank = mask.rank();
1752 
1753   assert(maskRank > 0);
1754 
1755   // Handle optional dim argument
1756   bool absentDim = isAbsent(args[1]);
1757   mlir::Value dim =
1758       absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 0)
1759                 : fir::getBase(args[1]);
1760 
1761   if (absentDim || maskRank == 1) {
1762     // Result is scalar if no dim argument or mask is rank 1.
1763     // So, call specialized Count runtime routine.
1764     return builder.createConvert(
1765         loc, resultType,
1766         fir::runtime::genCount(builder, loc, fir::getBase(mask), dim));
1767   }
1768 
1769   // Call general CountDim runtime routine.
1770 
1771   // Handle optional kind argument
1772   bool absentKind = isAbsent(args[2]);
1773   mlir::Value kind = absentKind ? builder.createIntegerConstant(
1774                                       loc, builder.getIndexType(),
1775                                       builder.getKindMap().defaultIntegerKind())
1776                                 : fir::getBase(args[2]);
1777 
1778   // Create mutable fir.box to be passed to the runtime for the result.
1779   mlir::Type type = builder.getVarLenSeqTy(resultType, maskRank - 1);
1780   fir::MutableBoxValue resultMutableBox =
1781       fir::factory::createTempMutableBox(builder, loc, type);
1782 
1783   mlir::Value resultIrBox =
1784       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
1785 
1786   fir::runtime::genCountDim(builder, loc, resultIrBox, fir::getBase(mask), dim,
1787                             kind);
1788 
1789   // Handle cleanup of allocatable result descriptor and return
1790   fir::ExtendedValue res =
1791       fir::factory::genMutableBoxRead(builder, loc, resultMutableBox);
1792   return res.match(
1793       [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
1794         // Add cleanup code
1795         addCleanUpForTemp(loc, box.getAddr());
1796         return box;
1797       },
1798       [&](const auto &) -> fir::ExtendedValue {
1799         fir::emitFatalError(loc, "unexpected result for COUNT");
1800       });
1801 }
1802 
1803 // CPU_TIME
1804 void IntrinsicLibrary::genCpuTime(llvm::ArrayRef<fir::ExtendedValue> args) {
1805   assert(args.size() == 1);
1806   const mlir::Value *arg = args[0].getUnboxed();
1807   assert(arg && "nonscalar cpu_time argument");
1808   mlir::Value res1 = Fortran::lower::genCpuTime(builder, loc);
1809   mlir::Value res2 =
1810       builder.createConvert(loc, fir::dyn_cast_ptrEleTy(arg->getType()), res1);
1811   builder.create<fir::StoreOp>(loc, res2, *arg);
1812 }
1813 
1814 // CSHIFT
1815 fir::ExtendedValue
1816 IntrinsicLibrary::genCshift(mlir::Type resultType,
1817                             llvm::ArrayRef<fir::ExtendedValue> args) {
1818   assert(args.size() == 3);
1819 
1820   // Handle required ARRAY argument
1821   fir::BoxValue arrayBox = builder.createBox(loc, args[0]);
1822   mlir::Value array = fir::getBase(arrayBox);
1823   unsigned arrayRank = arrayBox.rank();
1824 
1825   // Create mutable fir.box to be passed to the runtime for the result.
1826   mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, arrayRank);
1827   fir::MutableBoxValue resultMutableBox =
1828       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
1829   mlir::Value resultIrBox =
1830       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
1831 
1832   if (arrayRank == 1) {
1833     // Vector case
1834     // Handle required SHIFT argument as a scalar
1835     const mlir::Value *shiftAddr = args[1].getUnboxed();
1836     assert(shiftAddr && "nonscalar CSHIFT argument");
1837     auto shift = builder.create<fir::LoadOp>(loc, *shiftAddr);
1838 
1839     fir::runtime::genCshiftVector(builder, loc, resultIrBox, array, shift);
1840   } else {
1841     // Non-vector case
1842     // Handle required SHIFT argument as an array
1843     mlir::Value shift = builder.createBox(loc, args[1]);
1844 
1845     // Handle optional DIM argument
1846     mlir::Value dim =
1847         isAbsent(args[2])
1848             ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
1849             : fir::getBase(args[2]);
1850     fir::runtime::genCshift(builder, loc, resultIrBox, array, shift, dim);
1851   }
1852   return readAndAddCleanUp(resultMutableBox, resultType, "CSHIFT");
1853 }
1854 
1855 // DATE_AND_TIME
1856 void IntrinsicLibrary::genDateAndTime(llvm::ArrayRef<fir::ExtendedValue> args) {
1857   assert(args.size() == 4 && "date_and_time has 4 args");
1858   llvm::SmallVector<llvm::Optional<fir::CharBoxValue>> charArgs(3);
1859   for (unsigned i = 0; i < 3; ++i)
1860     if (const fir::CharBoxValue *charBox = args[i].getCharBox())
1861       charArgs[i] = *charBox;
1862 
1863   mlir::Value values = fir::getBase(args[3]);
1864   if (!values)
1865     values = builder.create<fir::AbsentOp>(
1866         loc, fir::BoxType::get(builder.getNoneType()));
1867 
1868   Fortran::lower::genDateAndTime(builder, loc, charArgs[0], charArgs[1],
1869                                  charArgs[2], values);
1870 }
1871 
1872 // DIM
1873 mlir::Value IntrinsicLibrary::genDim(mlir::Type resultType,
1874                                      llvm::ArrayRef<mlir::Value> args) {
1875   assert(args.size() == 2);
1876   if (resultType.isa<mlir::IntegerType>()) {
1877     mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
1878     auto diff = builder.create<mlir::arith::SubIOp>(loc, args[0], args[1]);
1879     auto cmp = builder.create<mlir::arith::CmpIOp>(
1880         loc, mlir::arith::CmpIPredicate::sgt, diff, zero);
1881     return builder.create<mlir::arith::SelectOp>(loc, cmp, diff, zero);
1882   }
1883   assert(fir::isa_real(resultType) && "Only expects real and integer in DIM");
1884   mlir::Value zero = builder.createRealZeroConstant(loc, resultType);
1885   auto diff = builder.create<mlir::arith::SubFOp>(loc, args[0], args[1]);
1886   auto cmp = builder.create<mlir::arith::CmpFOp>(
1887       loc, mlir::arith::CmpFPredicate::OGT, diff, zero);
1888   return builder.create<mlir::arith::SelectOp>(loc, cmp, diff, zero);
1889 }
1890 
1891 // DOT_PRODUCT
1892 fir::ExtendedValue
1893 IntrinsicLibrary::genDotProduct(mlir::Type resultType,
1894                                 llvm::ArrayRef<fir::ExtendedValue> args) {
1895   return genDotProd(fir::runtime::genDotProduct, resultType, builder, loc,
1896                     stmtCtx, args);
1897 }
1898 
1899 // EOSHIFT
1900 fir::ExtendedValue
1901 IntrinsicLibrary::genEoshift(mlir::Type resultType,
1902                              llvm::ArrayRef<fir::ExtendedValue> args) {
1903   assert(args.size() == 4);
1904 
1905   // Handle required ARRAY argument
1906   fir::BoxValue arrayBox = builder.createBox(loc, args[0]);
1907   mlir::Value array = fir::getBase(arrayBox);
1908   unsigned arrayRank = arrayBox.rank();
1909 
1910   // Create mutable fir.box to be passed to the runtime for the result.
1911   mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, arrayRank);
1912   fir::MutableBoxValue resultMutableBox =
1913       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
1914   mlir::Value resultIrBox =
1915       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
1916 
1917   // Handle optional BOUNDARY argument
1918   mlir::Value boundary =
1919       isAbsent(args[2]) ? builder.create<fir::AbsentOp>(
1920                               loc, fir::BoxType::get(builder.getNoneType()))
1921                         : builder.createBox(loc, args[2]);
1922 
1923   if (arrayRank == 1) {
1924     // Vector case
1925     // Handle required SHIFT argument as a scalar
1926     const mlir::Value *shiftAddr = args[1].getUnboxed();
1927     assert(shiftAddr && "nonscalar EOSHIFT SHIFT argument");
1928     auto shift = builder.create<fir::LoadOp>(loc, *shiftAddr);
1929     fir::runtime::genEoshiftVector(builder, loc, resultIrBox, array, shift,
1930                                    boundary);
1931   } else {
1932     // Non-vector case
1933     // Handle required SHIFT argument as an array
1934     mlir::Value shift = builder.createBox(loc, args[1]);
1935 
1936     // Handle optional DIM argument
1937     mlir::Value dim =
1938         isAbsent(args[3])
1939             ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
1940             : fir::getBase(args[3]);
1941     fir::runtime::genEoshift(builder, loc, resultIrBox, array, shift, boundary,
1942                              dim);
1943   }
1944   return readAndAddCleanUp(resultMutableBox, resultType,
1945                            "unexpected result for EOSHIFT");
1946 }
1947 
1948 // EXPONENT
1949 mlir::Value IntrinsicLibrary::genExponent(mlir::Type resultType,
1950                                           llvm::ArrayRef<mlir::Value> args) {
1951   assert(args.size() == 1);
1952 
1953   return builder.createConvert(
1954       loc, resultType,
1955       fir::runtime::genExponent(builder, loc, resultType,
1956                                 fir::getBase(args[0])));
1957 }
1958 
1959 // FLOOR
1960 mlir::Value IntrinsicLibrary::genFloor(mlir::Type resultType,
1961                                        llvm::ArrayRef<mlir::Value> args) {
1962   // Optional KIND argument.
1963   assert(args.size() >= 1);
1964   mlir::Value arg = args[0];
1965   // Use LLVM floor that returns real.
1966   mlir::Value floor = genRuntimeCall("floor", arg.getType(), {arg});
1967   return builder.createConvert(loc, resultType, floor);
1968 }
1969 
1970 // FRACTION
1971 mlir::Value IntrinsicLibrary::genFraction(mlir::Type resultType,
1972                                           llvm::ArrayRef<mlir::Value> args) {
1973   assert(args.size() == 1);
1974 
1975   return builder.createConvert(
1976       loc, resultType,
1977       fir::runtime::genFraction(builder, loc, fir::getBase(args[0])));
1978 }
1979 
1980 // IAND
1981 mlir::Value IntrinsicLibrary::genIand(mlir::Type resultType,
1982                                       llvm::ArrayRef<mlir::Value> args) {
1983   assert(args.size() == 2);
1984   return builder.create<mlir::arith::AndIOp>(loc, args[0], args[1]);
1985 }
1986 
1987 // IBCLR
1988 mlir::Value IntrinsicLibrary::genIbclr(mlir::Type resultType,
1989                                        llvm::ArrayRef<mlir::Value> args) {
1990   // A conformant IBCLR(I,POS) call satisfies:
1991   //     POS >= 0
1992   //     POS < BIT_SIZE(I)
1993   // Return:  I & (!(1 << POS))
1994   assert(args.size() == 2);
1995   mlir::Value pos = builder.createConvert(loc, resultType, args[1]);
1996   mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
1997   mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
1998   auto mask = builder.create<mlir::arith::ShLIOp>(loc, one, pos);
1999   auto res = builder.create<mlir::arith::XOrIOp>(loc, ones, mask);
2000   return builder.create<mlir::arith::AndIOp>(loc, args[0], res);
2001 }
2002 
2003 // IBITS
2004 mlir::Value IntrinsicLibrary::genIbits(mlir::Type resultType,
2005                                        llvm::ArrayRef<mlir::Value> args) {
2006   // A conformant IBITS(I,POS,LEN) call satisfies:
2007   //     POS >= 0
2008   //     LEN >= 0
2009   //     POS + LEN <= BIT_SIZE(I)
2010   // Return:  LEN == 0 ? 0 : (I >> POS) & (-1 >> (BIT_SIZE(I) - LEN))
2011   // For a conformant call, implementing (I >> POS) with a signed or an
2012   // unsigned shift produces the same result.  For a nonconformant call,
2013   // the two choices may produce different results.
2014   assert(args.size() == 3);
2015   mlir::Value pos = builder.createConvert(loc, resultType, args[1]);
2016   mlir::Value len = builder.createConvert(loc, resultType, args[2]);
2017   mlir::Value bitSize = builder.createIntegerConstant(
2018       loc, resultType, resultType.cast<mlir::IntegerType>().getWidth());
2019   auto shiftCount = builder.create<mlir::arith::SubIOp>(loc, bitSize, len);
2020   mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
2021   mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
2022   auto mask = builder.create<mlir::arith::ShRUIOp>(loc, ones, shiftCount);
2023   auto res1 = builder.create<mlir::arith::ShRSIOp>(loc, args[0], pos);
2024   auto res2 = builder.create<mlir::arith::AndIOp>(loc, res1, mask);
2025   auto lenIsZero = builder.create<mlir::arith::CmpIOp>(
2026       loc, mlir::arith::CmpIPredicate::eq, len, zero);
2027   return builder.create<mlir::arith::SelectOp>(loc, lenIsZero, zero, res2);
2028 }
2029 
2030 // IBSET
2031 mlir::Value IntrinsicLibrary::genIbset(mlir::Type resultType,
2032                                        llvm::ArrayRef<mlir::Value> args) {
2033   // A conformant IBSET(I,POS) call satisfies:
2034   //     POS >= 0
2035   //     POS < BIT_SIZE(I)
2036   // Return:  I | (1 << POS)
2037   assert(args.size() == 2);
2038   mlir::Value pos = builder.createConvert(loc, resultType, args[1]);
2039   mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
2040   auto mask = builder.create<mlir::arith::ShLIOp>(loc, one, pos);
2041   return builder.create<mlir::arith::OrIOp>(loc, args[0], mask);
2042 }
2043 
2044 // ICHAR
2045 fir::ExtendedValue
2046 IntrinsicLibrary::genIchar(mlir::Type resultType,
2047                            llvm::ArrayRef<fir::ExtendedValue> args) {
2048   // There can be an optional kind in second argument.
2049   assert(args.size() == 2);
2050   const fir::CharBoxValue *charBox = args[0].getCharBox();
2051   if (!charBox)
2052     llvm::report_fatal_error("expected character scalar");
2053 
2054   fir::factory::CharacterExprHelper helper{builder, loc};
2055   mlir::Value buffer = charBox->getBuffer();
2056   mlir::Type bufferTy = buffer.getType();
2057   mlir::Value charVal;
2058   if (auto charTy = bufferTy.dyn_cast<fir::CharacterType>()) {
2059     assert(charTy.singleton());
2060     charVal = buffer;
2061   } else {
2062     // Character is in memory, cast to fir.ref<char> and load.
2063     mlir::Type ty = fir::dyn_cast_ptrEleTy(bufferTy);
2064     if (!ty)
2065       llvm::report_fatal_error("expected memory type");
2066     // The length of in the character type may be unknown. Casting
2067     // to a singleton ref is required before loading.
2068     fir::CharacterType eleType = helper.getCharacterType(ty);
2069     fir::CharacterType charType =
2070         fir::CharacterType::get(builder.getContext(), eleType.getFKind(), 1);
2071     mlir::Type toTy = builder.getRefType(charType);
2072     mlir::Value cast = builder.createConvert(loc, toTy, buffer);
2073     charVal = builder.create<fir::LoadOp>(loc, cast);
2074   }
2075   LLVM_DEBUG(llvm::dbgs() << "ichar(" << charVal << ")\n");
2076   auto code = helper.extractCodeFromSingleton(charVal);
2077   return builder.create<mlir::arith::ExtUIOp>(loc, resultType, code);
2078 }
2079 
2080 // IEOR
2081 mlir::Value IntrinsicLibrary::genIeor(mlir::Type resultType,
2082                                       llvm::ArrayRef<mlir::Value> args) {
2083   assert(args.size() == 2);
2084   return builder.create<mlir::arith::XOrIOp>(loc, args[0], args[1]);
2085 }
2086 
2087 // ISHFT
2088 mlir::Value IntrinsicLibrary::genIshft(mlir::Type resultType,
2089                                        llvm::ArrayRef<mlir::Value> args) {
2090   // A conformant ISHFT(I,SHIFT) call satisfies:
2091   //     abs(SHIFT) <= BIT_SIZE(I)
2092   // Return:  abs(SHIFT) >= BIT_SIZE(I)
2093   //              ? 0
2094   //              : SHIFT < 0
2095   //                    ? I >> abs(SHIFT)
2096   //                    : I << abs(SHIFT)
2097   assert(args.size() == 2);
2098   mlir::Value bitSize = builder.createIntegerConstant(
2099       loc, resultType, resultType.cast<mlir::IntegerType>().getWidth());
2100   mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
2101   mlir::Value shift = builder.createConvert(loc, resultType, args[1]);
2102   mlir::Value absShift = genAbs(resultType, {shift});
2103   auto left = builder.create<mlir::arith::ShLIOp>(loc, args[0], absShift);
2104   auto right = builder.create<mlir::arith::ShRUIOp>(loc, args[0], absShift);
2105   auto shiftIsLarge = builder.create<mlir::arith::CmpIOp>(
2106       loc, mlir::arith::CmpIPredicate::sge, absShift, bitSize);
2107   auto shiftIsNegative = builder.create<mlir::arith::CmpIOp>(
2108       loc, mlir::arith::CmpIPredicate::slt, shift, zero);
2109   auto sel =
2110       builder.create<mlir::arith::SelectOp>(loc, shiftIsNegative, right, left);
2111   return builder.create<mlir::arith::SelectOp>(loc, shiftIsLarge, zero, sel);
2112 }
2113 
2114 // ISHFTC
2115 mlir::Value IntrinsicLibrary::genIshftc(mlir::Type resultType,
2116                                         llvm::ArrayRef<mlir::Value> args) {
2117   // A conformant ISHFTC(I,SHIFT,SIZE) call satisfies:
2118   //     SIZE > 0
2119   //     SIZE <= BIT_SIZE(I)
2120   //     abs(SHIFT) <= SIZE
2121   // if SHIFT > 0
2122   //     leftSize = abs(SHIFT)
2123   //     rightSize = SIZE - abs(SHIFT)
2124   // else [if SHIFT < 0]
2125   //     leftSize = SIZE - abs(SHIFT)
2126   //     rightSize = abs(SHIFT)
2127   // unchanged = SIZE == BIT_SIZE(I) ? 0 : (I >> SIZE) << SIZE
2128   // leftMaskShift = BIT_SIZE(I) - leftSize
2129   // rightMaskShift = BIT_SIZE(I) - rightSize
2130   // left = (I >> rightSize) & (-1 >> leftMaskShift)
2131   // right = (I & (-1 >> rightMaskShift)) << leftSize
2132   // Return:  SHIFT == 0 || SIZE == abs(SHIFT) ? I : (unchanged | left | right)
2133   assert(args.size() == 3);
2134   mlir::Value bitSize = builder.createIntegerConstant(
2135       loc, resultType, resultType.cast<mlir::IntegerType>().getWidth());
2136   mlir::Value I = args[0];
2137   mlir::Value shift = builder.createConvert(loc, resultType, args[1]);
2138   mlir::Value size =
2139       args[2] ? builder.createConvert(loc, resultType, args[2]) : bitSize;
2140   mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
2141   mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);
2142   mlir::Value absShift = genAbs(resultType, {shift});
2143   auto elseSize = builder.create<mlir::arith::SubIOp>(loc, size, absShift);
2144   auto shiftIsZero = builder.create<mlir::arith::CmpIOp>(
2145       loc, mlir::arith::CmpIPredicate::eq, shift, zero);
2146   auto shiftEqualsSize = builder.create<mlir::arith::CmpIOp>(
2147       loc, mlir::arith::CmpIPredicate::eq, absShift, size);
2148   auto shiftIsNop =
2149       builder.create<mlir::arith::OrIOp>(loc, shiftIsZero, shiftEqualsSize);
2150   auto shiftIsPositive = builder.create<mlir::arith::CmpIOp>(
2151       loc, mlir::arith::CmpIPredicate::sgt, shift, zero);
2152   auto leftSize = builder.create<mlir::arith::SelectOp>(loc, shiftIsPositive,
2153                                                         absShift, elseSize);
2154   auto rightSize = builder.create<mlir::arith::SelectOp>(loc, shiftIsPositive,
2155                                                          elseSize, absShift);
2156   auto hasUnchanged = builder.create<mlir::arith::CmpIOp>(
2157       loc, mlir::arith::CmpIPredicate::ne, size, bitSize);
2158   auto unchangedTmp1 = builder.create<mlir::arith::ShRUIOp>(loc, I, size);
2159   auto unchangedTmp2 =
2160       builder.create<mlir::arith::ShLIOp>(loc, unchangedTmp1, size);
2161   auto unchanged = builder.create<mlir::arith::SelectOp>(loc, hasUnchanged,
2162                                                          unchangedTmp2, zero);
2163   auto leftMaskShift =
2164       builder.create<mlir::arith::SubIOp>(loc, bitSize, leftSize);
2165   auto leftMask =
2166       builder.create<mlir::arith::ShRUIOp>(loc, ones, leftMaskShift);
2167   auto leftTmp = builder.create<mlir::arith::ShRUIOp>(loc, I, rightSize);
2168   auto left = builder.create<mlir::arith::AndIOp>(loc, leftTmp, leftMask);
2169   auto rightMaskShift =
2170       builder.create<mlir::arith::SubIOp>(loc, bitSize, rightSize);
2171   auto rightMask =
2172       builder.create<mlir::arith::ShRUIOp>(loc, ones, rightMaskShift);
2173   auto rightTmp = builder.create<mlir::arith::AndIOp>(loc, I, rightMask);
2174   auto right = builder.create<mlir::arith::ShLIOp>(loc, rightTmp, leftSize);
2175   auto resTmp = builder.create<mlir::arith::OrIOp>(loc, unchanged, left);
2176   auto res = builder.create<mlir::arith::OrIOp>(loc, resTmp, right);
2177   return builder.create<mlir::arith::SelectOp>(loc, shiftIsNop, I, res);
2178 }
2179 
2180 // LEN
2181 // Note that this is only used for an unrestricted intrinsic LEN call.
2182 // Other uses of LEN are rewritten as descriptor inquiries by the front-end.
2183 fir::ExtendedValue
2184 IntrinsicLibrary::genLen(mlir::Type resultType,
2185                          llvm::ArrayRef<fir::ExtendedValue> args) {
2186   // Optional KIND argument reflected in result type and otherwise ignored.
2187   assert(args.size() == 1 || args.size() == 2);
2188   mlir::Value len = fir::factory::readCharLen(builder, loc, args[0]);
2189   return builder.createConvert(loc, resultType, len);
2190 }
2191 
2192 // LEN_TRIM
2193 fir::ExtendedValue
2194 IntrinsicLibrary::genLenTrim(mlir::Type resultType,
2195                              llvm::ArrayRef<fir::ExtendedValue> args) {
2196   // Optional KIND argument reflected in result type and otherwise ignored.
2197   assert(args.size() == 1 || args.size() == 2);
2198   const fir::CharBoxValue *charBox = args[0].getCharBox();
2199   if (!charBox)
2200     TODO(loc, "character array len_trim");
2201   auto len =
2202       fir::factory::CharacterExprHelper(builder, loc).createLenTrim(*charBox);
2203   return builder.createConvert(loc, resultType, len);
2204 }
2205 
2206 // LGE, LGT, LLE, LLT
2207 template <mlir::arith::CmpIPredicate pred>
2208 fir::ExtendedValue
2209 IntrinsicLibrary::genCharacterCompare(mlir::Type type,
2210                                       llvm::ArrayRef<fir::ExtendedValue> args) {
2211   assert(args.size() == 2);
2212   return fir::runtime::genCharCompare(
2213       builder, loc, pred, fir::getBase(args[0]), fir::getLen(args[0]),
2214       fir::getBase(args[1]), fir::getLen(args[1]));
2215 }
2216 
2217 // Compare two FIR values and return boolean result as i1.
2218 template <Extremum extremum, ExtremumBehavior behavior>
2219 static mlir::Value createExtremumCompare(mlir::Location loc,
2220                                          fir::FirOpBuilder &builder,
2221                                          mlir::Value left, mlir::Value right) {
2222   static constexpr mlir::arith::CmpIPredicate integerPredicate =
2223       extremum == Extremum::Max ? mlir::arith::CmpIPredicate::sgt
2224                                 : mlir::arith::CmpIPredicate::slt;
2225   static constexpr mlir::arith::CmpFPredicate orderedCmp =
2226       extremum == Extremum::Max ? mlir::arith::CmpFPredicate::OGT
2227                                 : mlir::arith::CmpFPredicate::OLT;
2228   mlir::Type type = left.getType();
2229   mlir::Value result;
2230   if (fir::isa_real(type)) {
2231     // Note: the signaling/quit aspect of the result required by IEEE
2232     // cannot currently be obtained with LLVM without ad-hoc runtime.
2233     if constexpr (behavior == ExtremumBehavior::IeeeMinMaximumNumber) {
2234       // Return the number if one of the inputs is NaN and the other is
2235       // a number.
2236       auto leftIsResult =
2237           builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
2238       auto rightIsNan = builder.create<mlir::arith::CmpFOp>(
2239           loc, mlir::arith::CmpFPredicate::UNE, right, right);
2240       result =
2241           builder.create<mlir::arith::OrIOp>(loc, leftIsResult, rightIsNan);
2242     } else if constexpr (behavior == ExtremumBehavior::IeeeMinMaximum) {
2243       // Always return NaNs if one the input is NaNs
2244       auto leftIsResult =
2245           builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
2246       auto leftIsNan = builder.create<mlir::arith::CmpFOp>(
2247           loc, mlir::arith::CmpFPredicate::UNE, left, left);
2248       result = builder.create<mlir::arith::OrIOp>(loc, leftIsResult, leftIsNan);
2249     } else if constexpr (behavior == ExtremumBehavior::MinMaxss) {
2250       // If the left is a NaN, return the right whatever it is.
2251       result =
2252           builder.create<mlir::arith::CmpFOp>(loc, orderedCmp, left, right);
2253     } else if constexpr (behavior == ExtremumBehavior::PgfortranLlvm) {
2254       // If one of the operand is a NaN, return left whatever it is.
2255       static constexpr auto unorderedCmp =
2256           extremum == Extremum::Max ? mlir::arith::CmpFPredicate::UGT
2257                                     : mlir::arith::CmpFPredicate::ULT;
2258       result =
2259           builder.create<mlir::arith::CmpFOp>(loc, unorderedCmp, left, right);
2260     } else {
2261       // TODO: ieeeMinNum/ieeeMaxNum
2262       static_assert(behavior == ExtremumBehavior::IeeeMinMaxNum,
2263                     "ieeeMinNum/ieeeMaxNum behavior not implemented");
2264     }
2265   } else if (fir::isa_integer(type)) {
2266     result =
2267         builder.create<mlir::arith::CmpIOp>(loc, integerPredicate, left, right);
2268   } else if (fir::isa_char(type)) {
2269     // TODO: ! character min and max is tricky because the result
2270     // length is the length of the longest argument!
2271     // So we may need a temp.
2272     TODO(loc, "CHARACTER min and max");
2273   }
2274   assert(result && "result must be defined");
2275   return result;
2276 }
2277 
2278 // MAXLOC
2279 fir::ExtendedValue
2280 IntrinsicLibrary::genMaxloc(mlir::Type resultType,
2281                             llvm::ArrayRef<fir::ExtendedValue> args) {
2282   return genExtremumloc(fir::runtime::genMaxloc, fir::runtime::genMaxlocDim,
2283                         resultType, builder, loc, stmtCtx,
2284                         "unexpected result for Maxloc", args);
2285 }
2286 
2287 // MAXVAL
2288 fir::ExtendedValue
2289 IntrinsicLibrary::genMaxval(mlir::Type resultType,
2290                             llvm::ArrayRef<fir::ExtendedValue> args) {
2291   return genExtremumVal(fir::runtime::genMaxval, fir::runtime::genMaxvalDim,
2292                         fir::runtime::genMaxvalChar, resultType, builder, loc,
2293                         stmtCtx, "unexpected result for Maxval", args);
2294 }
2295 
2296 // MINLOC
2297 fir::ExtendedValue
2298 IntrinsicLibrary::genMinloc(mlir::Type resultType,
2299                             llvm::ArrayRef<fir::ExtendedValue> args) {
2300   return genExtremumloc(fir::runtime::genMinloc, fir::runtime::genMinlocDim,
2301                         resultType, builder, loc, stmtCtx,
2302                         "unexpected result for Minloc", args);
2303 }
2304 
2305 // MINVAL
2306 fir::ExtendedValue
2307 IntrinsicLibrary::genMinval(mlir::Type resultType,
2308                             llvm::ArrayRef<fir::ExtendedValue> args) {
2309   return genExtremumVal(fir::runtime::genMinval, fir::runtime::genMinvalDim,
2310                         fir::runtime::genMinvalChar, resultType, builder, loc,
2311                         stmtCtx, "unexpected result for Minval", args);
2312 }
2313 
2314 // MIN and MAX
2315 template <Extremum extremum, ExtremumBehavior behavior>
2316 mlir::Value IntrinsicLibrary::genExtremum(mlir::Type,
2317                                           llvm::ArrayRef<mlir::Value> args) {
2318   assert(args.size() >= 1);
2319   mlir::Value result = args[0];
2320   for (auto arg : args.drop_front()) {
2321     mlir::Value mask =
2322         createExtremumCompare<extremum, behavior>(loc, builder, result, arg);
2323     result = builder.create<mlir::arith::SelectOp>(loc, mask, result, arg);
2324   }
2325   return result;
2326 }
2327 
2328 // MOD
2329 mlir::Value IntrinsicLibrary::genMod(mlir::Type resultType,
2330                                      llvm::ArrayRef<mlir::Value> args) {
2331   assert(args.size() == 2);
2332   if (resultType.isa<mlir::IntegerType>())
2333     return builder.create<mlir::arith::RemSIOp>(loc, args[0], args[1]);
2334 
2335   // Use runtime. Note that mlir::arith::RemFOp implements floating point
2336   // remainder, but it does not work with fir::Real type.
2337   // TODO: consider using mlir::arith::RemFOp when possible, that may help
2338   // folding and  optimizations.
2339   return genRuntimeCall("mod", resultType, args);
2340 }
2341 
2342 // MODULO
2343 mlir::Value IntrinsicLibrary::genModulo(mlir::Type resultType,
2344                                         llvm::ArrayRef<mlir::Value> args) {
2345   assert(args.size() == 2);
2346   // No floored modulo op in LLVM/MLIR yet. TODO: add one to MLIR.
2347   // In the meantime, use a simple inlined implementation based on truncated
2348   // modulo (MOD(A, P) implemented by RemIOp, RemFOp). This avoids making manual
2349   // division and multiplication from MODULO formula.
2350   //  - If A/P > 0 or MOD(A,P)=0, then INT(A/P) = FLOOR(A/P), and MODULO = MOD.
2351   //  - Otherwise, when A/P < 0 and MOD(A,P) !=0, then MODULO(A, P) =
2352   //    A-FLOOR(A/P)*P = A-(INT(A/P)-1)*P = A-INT(A/P)*P+P = MOD(A,P)+P
2353   // Note that A/P < 0 if and only if A and P signs are different.
2354   if (resultType.isa<mlir::IntegerType>()) {
2355     auto remainder =
2356         builder.create<mlir::arith::RemSIOp>(loc, args[0], args[1]);
2357     auto argXor = builder.create<mlir::arith::XOrIOp>(loc, args[0], args[1]);
2358     mlir::Value zero = builder.createIntegerConstant(loc, argXor.getType(), 0);
2359     auto argSignDifferent = builder.create<mlir::arith::CmpIOp>(
2360         loc, mlir::arith::CmpIPredicate::slt, argXor, zero);
2361     auto remainderIsNotZero = builder.create<mlir::arith::CmpIOp>(
2362         loc, mlir::arith::CmpIPredicate::ne, remainder, zero);
2363     auto mustAddP = builder.create<mlir::arith::AndIOp>(loc, remainderIsNotZero,
2364                                                         argSignDifferent);
2365     auto remPlusP =
2366         builder.create<mlir::arith::AddIOp>(loc, remainder, args[1]);
2367     return builder.create<mlir::arith::SelectOp>(loc, mustAddP, remPlusP,
2368                                                  remainder);
2369   }
2370   // Real case
2371   auto remainder = builder.create<mlir::arith::RemFOp>(loc, args[0], args[1]);
2372   mlir::Value zero = builder.createRealZeroConstant(loc, remainder.getType());
2373   auto remainderIsNotZero = builder.create<mlir::arith::CmpFOp>(
2374       loc, mlir::arith::CmpFPredicate::UNE, remainder, zero);
2375   auto aLessThanZero = builder.create<mlir::arith::CmpFOp>(
2376       loc, mlir::arith::CmpFPredicate::OLT, args[0], zero);
2377   auto pLessThanZero = builder.create<mlir::arith::CmpFOp>(
2378       loc, mlir::arith::CmpFPredicate::OLT, args[1], zero);
2379   auto argSignDifferent =
2380       builder.create<mlir::arith::XOrIOp>(loc, aLessThanZero, pLessThanZero);
2381   auto mustAddP = builder.create<mlir::arith::AndIOp>(loc, remainderIsNotZero,
2382                                                       argSignDifferent);
2383   auto remPlusP = builder.create<mlir::arith::AddFOp>(loc, remainder, args[1]);
2384   return builder.create<mlir::arith::SelectOp>(loc, mustAddP, remPlusP,
2385                                                remainder);
2386 }
2387 
2388 // NINT
2389 mlir::Value IntrinsicLibrary::genNint(mlir::Type resultType,
2390                                       llvm::ArrayRef<mlir::Value> args) {
2391   assert(args.size() >= 1);
2392   // Skip optional kind argument to search the runtime; it is already reflected
2393   // in result type.
2394   return genRuntimeCall("nint", resultType, {args[0]});
2395 }
2396 
2397 // NOT
2398 mlir::Value IntrinsicLibrary::genNot(mlir::Type resultType,
2399                                      llvm::ArrayRef<mlir::Value> args) {
2400   assert(args.size() == 1);
2401   mlir::Value allOnes = builder.createIntegerConstant(loc, resultType, -1);
2402   return builder.create<mlir::arith::XOrIOp>(loc, args[0], allOnes);
2403 }
2404 
2405 // NULL
2406 fir::ExtendedValue
2407 IntrinsicLibrary::genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue> args) {
2408   // NULL() without MOLD must be handled in the contexts where it can appear
2409   // (see table 16.5 of Fortran 2018 standard).
2410   assert(args.size() == 1 && isPresent(args[0]) &&
2411          "MOLD argument required to lower NULL outside of any context");
2412   const auto *mold = args[0].getBoxOf<fir::MutableBoxValue>();
2413   assert(mold && "MOLD must be a pointer or allocatable");
2414   fir::BoxType boxType = mold->getBoxTy();
2415   mlir::Value boxStorage = builder.createTemporary(loc, boxType);
2416   mlir::Value box = fir::factory::createUnallocatedBox(
2417       builder, loc, boxType, mold->nonDeferredLenParams());
2418   builder.create<fir::StoreOp>(loc, box, boxStorage);
2419   return fir::MutableBoxValue(boxStorage, mold->nonDeferredLenParams(), {});
2420 }
2421 
2422 // PACK
2423 fir::ExtendedValue
2424 IntrinsicLibrary::genPack(mlir::Type resultType,
2425                           llvm::ArrayRef<fir::ExtendedValue> args) {
2426   [[maybe_unused]] auto numArgs = args.size();
2427   assert(numArgs == 2 || numArgs == 3);
2428 
2429   // Handle required array argument
2430   mlir::Value array = builder.createBox(loc, args[0]);
2431 
2432   // Handle required mask argument
2433   mlir::Value mask = builder.createBox(loc, args[1]);
2434 
2435   // Handle optional vector argument
2436   mlir::Value vector = isAbsent(args, 2)
2437                            ? builder.create<fir::AbsentOp>(
2438                                  loc, fir::BoxType::get(builder.getI1Type()))
2439                            : builder.createBox(loc, args[2]);
2440 
2441   // Create mutable fir.box to be passed to the runtime for the result.
2442   mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, 1);
2443   fir::MutableBoxValue resultMutableBox =
2444       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2445   mlir::Value resultIrBox =
2446       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2447 
2448   fir::runtime::genPack(builder, loc, resultIrBox, array, mask, vector);
2449 
2450   return readAndAddCleanUp(resultMutableBox, resultType,
2451                            "unexpected result for PACK");
2452 }
2453 
2454 // PRODUCT
2455 fir::ExtendedValue
2456 IntrinsicLibrary::genProduct(mlir::Type resultType,
2457                              llvm::ArrayRef<fir::ExtendedValue> args) {
2458   return genProdOrSum(fir::runtime::genProduct, fir::runtime::genProductDim,
2459                       resultType, builder, loc, stmtCtx,
2460                       "unexpected result for Product", args);
2461 }
2462 
2463 // RANDOM_INIT
2464 void IntrinsicLibrary::genRandomInit(llvm::ArrayRef<fir::ExtendedValue> args) {
2465   assert(args.size() == 2);
2466   Fortran::lower::genRandomInit(builder, loc, fir::getBase(args[0]),
2467                                 fir::getBase(args[1]));
2468 }
2469 
2470 // RANDOM_NUMBER
2471 void IntrinsicLibrary::genRandomNumber(
2472     llvm::ArrayRef<fir::ExtendedValue> args) {
2473   assert(args.size() == 1);
2474   Fortran::lower::genRandomNumber(builder, loc, fir::getBase(args[0]));
2475 }
2476 
2477 // RANDOM_SEED
2478 void IntrinsicLibrary::genRandomSeed(llvm::ArrayRef<fir::ExtendedValue> args) {
2479   assert(args.size() == 3);
2480   for (int i = 0; i < 3; ++i)
2481     if (isPresent(args[i])) {
2482       Fortran::lower::genRandomSeed(builder, loc, i, fir::getBase(args[i]));
2483       return;
2484     }
2485   Fortran::lower::genRandomSeed(builder, loc, -1, mlir::Value{});
2486 }
2487 
2488 // SET_EXPONENT
2489 mlir::Value IntrinsicLibrary::genSetExponent(mlir::Type resultType,
2490                                              llvm::ArrayRef<mlir::Value> args) {
2491   assert(args.size() == 2);
2492 
2493   return builder.createConvert(
2494       loc, resultType,
2495       fir::runtime::genSetExponent(builder, loc, fir::getBase(args[0]),
2496                                    fir::getBase(args[1])));
2497 }
2498 
2499 // SUM
2500 fir::ExtendedValue
2501 IntrinsicLibrary::genSum(mlir::Type resultType,
2502                          llvm::ArrayRef<fir::ExtendedValue> args) {
2503   return genProdOrSum(fir::runtime::genSum, fir::runtime::genSumDim, resultType,
2504                       builder, loc, stmtCtx, "unexpected result for Sum", args);
2505 }
2506 
2507 // SYSTEM_CLOCK
2508 void IntrinsicLibrary::genSystemClock(llvm::ArrayRef<fir::ExtendedValue> args) {
2509   assert(args.size() == 3);
2510   Fortran::lower::genSystemClock(builder, loc, fir::getBase(args[0]),
2511                                  fir::getBase(args[1]), fir::getBase(args[2]));
2512 }
2513 
2514 // SIZE
2515 fir::ExtendedValue
2516 IntrinsicLibrary::genSize(mlir::Type resultType,
2517                           llvm::ArrayRef<fir::ExtendedValue> args) {
2518   // Note that the value of the KIND argument is already reflected in the
2519   // resultType
2520   assert(args.size() == 3);
2521   if (const auto *boxValue = args[0].getBoxOf<fir::BoxValue>())
2522     if (boxValue->hasAssumedRank())
2523       TODO(loc, "SIZE intrinsic with assumed rank argument");
2524 
2525   // Get the ARRAY argument
2526   mlir::Value array = builder.createBox(loc, args[0]);
2527 
2528   // The front-end rewrites SIZE without the DIM argument to
2529   // an array of SIZE with DIM in most cases, but it may not be
2530   // possible in some cases like when in SIZE(function_call()).
2531   if (isAbsent(args, 1))
2532     return builder.createConvert(loc, resultType,
2533                                  fir::runtime::genSize(builder, loc, array));
2534 
2535   // Get the DIM argument.
2536   mlir::Value dim = fir::getBase(args[1]);
2537   if (!fir::isa_ref_type(dim.getType()))
2538     return builder.createConvert(
2539         loc, resultType, fir::runtime::genSizeDim(builder, loc, array, dim));
2540 
2541   mlir::Value isDynamicallyAbsent = builder.genIsNull(loc, dim);
2542   return builder
2543       .genIfOp(loc, {resultType}, isDynamicallyAbsent,
2544                /*withElseRegion=*/true)
2545       .genThen([&]() {
2546         mlir::Value size = builder.createConvert(
2547             loc, resultType, fir::runtime::genSize(builder, loc, array));
2548         builder.create<fir::ResultOp>(loc, size);
2549       })
2550       .genElse([&]() {
2551         mlir::Value dimValue = builder.create<fir::LoadOp>(loc, dim);
2552         mlir::Value size = builder.createConvert(
2553             loc, resultType,
2554             fir::runtime::genSizeDim(builder, loc, array, dimValue));
2555         builder.create<fir::ResultOp>(loc, size);
2556       })
2557       .getResults()[0];
2558 }
2559 
2560 // TRANSFER
2561 fir::ExtendedValue
2562 IntrinsicLibrary::genTransfer(mlir::Type resultType,
2563                               llvm::ArrayRef<fir::ExtendedValue> args) {
2564 
2565   assert(args.size() >= 2); // args.size() == 2 when size argument is omitted.
2566 
2567   // Handle source argument
2568   mlir::Value source = builder.createBox(loc, args[0]);
2569 
2570   // Handle mold argument
2571   mlir::Value mold = builder.createBox(loc, args[1]);
2572   fir::BoxValue moldTmp = mold;
2573   unsigned moldRank = moldTmp.rank();
2574 
2575   bool absentSize = (args.size() == 2);
2576 
2577   // Create mutable fir.box to be passed to the runtime for the result.
2578   mlir::Type type = (moldRank == 0 && absentSize)
2579                         ? resultType
2580                         : builder.getVarLenSeqTy(resultType, 1);
2581   fir::MutableBoxValue resultMutableBox =
2582       fir::factory::createTempMutableBox(builder, loc, type);
2583 
2584   if (moldRank == 0 && absentSize) {
2585     // This result is a scalar in this case.
2586     mlir::Value resultIrBox =
2587         fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2588 
2589     Fortran::lower::genTransfer(builder, loc, resultIrBox, source, mold);
2590   } else {
2591     // The result is a rank one array in this case.
2592     mlir::Value resultIrBox =
2593         fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2594 
2595     if (absentSize) {
2596       Fortran::lower::genTransfer(builder, loc, resultIrBox, source, mold);
2597     } else {
2598       mlir::Value sizeArg = fir::getBase(args[2]);
2599       Fortran::lower::genTransferSize(builder, loc, resultIrBox, source, mold,
2600                                       sizeArg);
2601     }
2602   }
2603   return readAndAddCleanUp(resultMutableBox, resultType,
2604                            "unexpected result for TRANSFER");
2605 }
2606 
2607 // LBOUND
2608 fir::ExtendedValue
2609 IntrinsicLibrary::genLbound(mlir::Type resultType,
2610                             llvm::ArrayRef<fir::ExtendedValue> args) {
2611   // Calls to LBOUND that don't have the DIM argument, or for which
2612   // the DIM is a compile time constant, are folded to descriptor inquiries by
2613   // semantics.  This function covers the situations where a call to the
2614   // runtime is required.
2615   assert(args.size() == 3);
2616   assert(!isAbsent(args[1]));
2617   if (const auto *boxValue = args[0].getBoxOf<fir::BoxValue>())
2618     if (boxValue->hasAssumedRank())
2619       TODO(loc, "LBOUND intrinsic with assumed rank argument");
2620 
2621   const fir::ExtendedValue &array = args[0];
2622   mlir::Value box = array.match(
2623       [&](const fir::BoxValue &boxValue) -> mlir::Value {
2624         // This entity is mapped to a fir.box that may not contain the local
2625         // lower bound information if it is a dummy. Rebox it with the local
2626         // shape information.
2627         mlir::Value localShape = builder.createShape(loc, array);
2628         mlir::Value oldBox = boxValue.getAddr();
2629         return builder.create<fir::ReboxOp>(
2630             loc, oldBox.getType(), oldBox, localShape, /*slice=*/mlir::Value{});
2631       },
2632       [&](const auto &) -> mlir::Value {
2633         // This a pointer/allocatable, or an entity not yet tracked with a
2634         // fir.box. For pointer/allocatable, createBox will forward the
2635         // descriptor that contains the correct lower bound information. For
2636         // other entities, a new fir.box will be made with the local lower
2637         // bounds.
2638         return builder.createBox(loc, array);
2639       });
2640 
2641   mlir::Value dim = fir::getBase(args[1]);
2642   return builder.createConvert(
2643       loc, resultType,
2644       fir::runtime::genLboundDim(builder, loc, fir::getBase(box), dim));
2645 }
2646 
2647 // UBOUND
2648 fir::ExtendedValue
2649 IntrinsicLibrary::genUbound(mlir::Type resultType,
2650                             llvm::ArrayRef<fir::ExtendedValue> args) {
2651   assert(args.size() == 3 || args.size() == 2);
2652   if (args.size() == 3) {
2653     // Handle calls to UBOUND with the DIM argument, which return a scalar
2654     mlir::Value extent = fir::getBase(genSize(resultType, args));
2655     mlir::Value lbound = fir::getBase(genLbound(resultType, args));
2656 
2657     mlir::Value one = builder.createIntegerConstant(loc, resultType, 1);
2658     mlir::Value ubound = builder.create<mlir::arith::SubIOp>(loc, lbound, one);
2659     return builder.create<mlir::arith::AddIOp>(loc, ubound, extent);
2660   } else {
2661     // Handle calls to UBOUND without the DIM argument, which return an array
2662     mlir::Value kind = isAbsent(args[1])
2663                            ? builder.createIntegerConstant(
2664                                  loc, builder.getIndexType(),
2665                                  builder.getKindMap().defaultIntegerKind())
2666                            : fir::getBase(args[1]);
2667 
2668     // Create mutable fir.box to be passed to the runtime for the result.
2669     mlir::Type type = builder.getVarLenSeqTy(resultType, /*rank=*/1);
2670     fir::MutableBoxValue resultMutableBox =
2671         fir::factory::createTempMutableBox(builder, loc, type);
2672     mlir::Value resultIrBox =
2673         fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2674 
2675     fir::runtime::genUbound(builder, loc, resultIrBox, fir::getBase(args[0]),
2676                             kind);
2677 
2678     return readAndAddCleanUp(resultMutableBox, resultType, "UBOUND");
2679   }
2680   return mlir::Value();
2681 }
2682 
2683 // UNPACK
2684 fir::ExtendedValue
2685 IntrinsicLibrary::genUnpack(mlir::Type resultType,
2686                             llvm::ArrayRef<fir::ExtendedValue> args) {
2687   assert(args.size() == 3);
2688 
2689   // Handle required vector argument
2690   mlir::Value vector = builder.createBox(loc, args[0]);
2691 
2692   // Handle required mask argument
2693   fir::BoxValue maskBox = builder.createBox(loc, args[1]);
2694   mlir::Value mask = fir::getBase(maskBox);
2695   unsigned maskRank = maskBox.rank();
2696 
2697   // Handle required field argument
2698   mlir::Value field = builder.createBox(loc, args[2]);
2699 
2700   // Create mutable fir.box to be passed to the runtime for the result.
2701   mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, maskRank);
2702   fir::MutableBoxValue resultMutableBox =
2703       fir::factory::createTempMutableBox(builder, loc, resultArrayType);
2704   mlir::Value resultIrBox =
2705       fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
2706 
2707   fir::runtime::genUnpack(builder, loc, resultIrBox, vector, mask, field);
2708 
2709   return readAndAddCleanUp(resultMutableBox, resultType,
2710                            "unexpected result for UNPACK");
2711 }
2712 
2713 //===----------------------------------------------------------------------===//
2714 // Argument lowering rules interface
2715 //===----------------------------------------------------------------------===//
2716 
2717 const Fortran::lower::IntrinsicArgumentLoweringRules *
2718 Fortran::lower::getIntrinsicArgumentLowering(llvm::StringRef intrinsicName) {
2719   if (const IntrinsicHandler *handler = findIntrinsicHandler(intrinsicName))
2720     if (!handler->argLoweringRules.hasDefaultRules())
2721       return &handler->argLoweringRules;
2722   return nullptr;
2723 }
2724 
2725 /// Return how argument \p argName should be lowered given the rules for the
2726 /// intrinsic function.
2727 Fortran::lower::ArgLoweringRule Fortran::lower::lowerIntrinsicArgumentAs(
2728     mlir::Location loc, const IntrinsicArgumentLoweringRules &rules,
2729     llvm::StringRef argName) {
2730   for (const IntrinsicDummyArgument &arg : rules.args) {
2731     if (arg.name && arg.name == argName)
2732       return {arg.lowerAs, arg.handleDynamicOptional};
2733   }
2734   fir::emitFatalError(
2735       loc, "internal: unknown intrinsic argument name in lowering '" + argName +
2736                "'");
2737 }
2738 
2739 //===----------------------------------------------------------------------===//
2740 // Public intrinsic call helpers
2741 //===----------------------------------------------------------------------===//
2742 
2743 fir::ExtendedValue
2744 Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
2745                                  llvm::StringRef name,
2746                                  llvm::Optional<mlir::Type> resultType,
2747                                  llvm::ArrayRef<fir::ExtendedValue> args,
2748                                  Fortran::lower::StatementContext &stmtCtx) {
2749   return IntrinsicLibrary{builder, loc, &stmtCtx}.genIntrinsicCall(
2750       name, resultType, args);
2751 }
2752 
2753 mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder,
2754                                    mlir::Location loc,
2755                                    llvm::ArrayRef<mlir::Value> args) {
2756   assert(args.size() > 0 && "max requires at least one argument");
2757   return IntrinsicLibrary{builder, loc}
2758       .genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>(args[0].getType(),
2759                                                               args);
2760 }
2761 
2762 mlir::Value Fortran::lower::genPow(fir::FirOpBuilder &builder,
2763                                    mlir::Location loc, mlir::Type type,
2764                                    mlir::Value x, mlir::Value y) {
2765   return IntrinsicLibrary{builder, loc}.genRuntimeCall("pow", type, {x, y});
2766 }
2767