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