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