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