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