flang/lib/Lower/CustomIntrinsicCall.cpp

   1 //===-- CustomIntrinsicCall.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 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
  10 //
  11 //===----------------------------------------------------------------------===//
  12
  13 #include "flang/Lower/CustomIntrinsicCall.h"
  14 #include "flang/Evaluate/expression.h"
  15 #include "flang/Evaluate/fold.h"
  16 #include "flang/Evaluate/tools.h"
  17 #include "flang/Lower/StatementContext.h"
  18 #include "flang/Optimizer/Builder/IntrinsicCall.h"
  19 #include "flang/Optimizer/Builder/Todo.h"
  20 #include "flang/Semantics/tools.h"
  21 #include <optional>
  22
  23 /// Is this a call to MIN or MAX intrinsic with arguments that may be absent at
  24 /// runtime? This is a special case because MIN and MAX can have any number of
  25 /// arguments.
  26 static bool isMinOrMaxWithDynamicallyOptionalArg(
  27     llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
  28   if (name != "min" && name != "max")
  29     return false;
  30   const auto &args = procRef.arguments();
  31   std::size_t argSize = args.size();
  32   if (argSize <= 2)
  33     return false;
  34   for (std::size_t i = 2; i < argSize; ++i) {
  35     if (auto *expr =
  36             Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(args[i]))
  37       if (Fortran::evaluate::MayBePassedAsAbsentOptional(*expr))
  38         return true;
  39   }
  40   return false;
  41 }
  42
  43 /// Is this a call to ISHFTC intrinsic with a SIZE argument that may be absent
  44 /// at runtime? This is a special case because the SIZE value to be applied
  45 /// when absent is not zero.
  46 static bool isIshftcWithDynamicallyOptionalArg(
  47     llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
  48   if (name != "ishftc" || procRef.arguments().size() < 3)
  49     return false;
  50   auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
  51       procRef.arguments()[2]);
  52   return expr && Fortran::evaluate::MayBePassedAsAbsentOptional(*expr);
  53 }
  54
  55 /// Is this a call to ASSOCIATED where the TARGET is an OPTIONAL (but not a
  56 /// deallocated allocatable or disassociated pointer)?
  57 /// Subtle: contrary to other intrinsic optional arguments, disassociated
  58 /// POINTER and unallocated ALLOCATABLE actual argument are not considered
  59 /// absent here. This is because ASSOCIATED has special requirements for TARGET
  60 /// actual arguments that are POINTERs. There is no precise requirements for
  61 /// ALLOCATABLEs, but all existing Fortran compilers treat them similarly to
  62 /// POINTERs. That is: unallocated TARGETs cause ASSOCIATED to rerun false.  The
  63 /// runtime deals with the disassociated/unallocated case. Simply ensures that
  64 /// TARGET that are OPTIONAL get conditionally emboxed here to convey the
  65 /// optional aspect to the runtime.
  66 static bool isAssociatedWithDynamicallyOptionalArg(
  67     llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef) {
  68   if (name != "associated" || procRef.arguments().size() < 2)
  69     return false;
  70   auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
  71       procRef.arguments()[1]);
  72   const Fortran::semantics::Symbol *sym{
  73       expr ? Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)
  74            : nullptr};
  75   return (sym && Fortran::semantics::IsOptional(*sym));
  76 }
  77
  78 bool Fortran::lower::intrinsicRequiresCustomOptionalHandling(
  79     const Fortran::evaluate::ProcedureRef &procRef,
  80     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
  81     AbstractConverter &converter) {
  82   llvm::StringRef name = intrinsic.name;
  83   return isMinOrMaxWithDynamicallyOptionalArg(name, procRef) ||
  84          isIshftcWithDynamicallyOptionalArg(name, procRef) ||
  85          isAssociatedWithDynamicallyOptionalArg(name, procRef);
  86 }
  87
  88 /// Generate the FIR+MLIR operations for the generic intrinsic \p name
  89 /// with arguments \p args and the expected result type \p resultType.
  90 /// Returned fir::ExtendedValue is the returned Fortran intrinsic value.
  91 fir::ExtendedValue
  92 Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
  93                                  llvm::StringRef name,
  94                                  std::optional<mlir::Type> resultType,
  95                                  llvm::ArrayRef<fir::ExtendedValue> args,
  96                                  Fortran::lower::StatementContext &stmtCtx,
  97                                  Fortran::lower::AbstractConverter *converter) {
  98   auto [result, mustBeFreed] =
  99       fir::genIntrinsicCall(builder, loc, name, resultType, args, converter);
 100   if (mustBeFreed) {
 101     mlir::Value addr = fir::getBase(result);
 102     if (auto *box = result.getBoxOf<fir::BoxValue>())
 103       addr =
 104           builder.create<fir::BoxAddrOp>(loc, box->getMemTy(), box->getAddr());
 105     fir::FirOpBuilder *bldr = &builder;
 106     stmtCtx.attachCleanup([=]() { bldr->create<fir::FreeMemOp>(loc, addr); });
 107   }
 108   return result;
 109 }
 110
 111 static void prepareMinOrMaxArguments(
 112     const Fortran::evaluate::ProcedureRef &procRef,
 113     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
 114     std::optional<mlir::Type> retTy,
 115     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
 116     const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
 117     Fortran::lower::AbstractConverter &converter) {
 118   assert(retTy && "MIN and MAX must have a return type");
 119   mlir::Type resultType = *retTy;
 120   mlir::Location loc = converter.getCurrentLocation();
 121   if (fir::isa_char(resultType))
 122     TODO(loc, "CHARACTER MIN and MAX with dynamically optional arguments");
 123   for (auto arg : llvm::enumerate(procRef.arguments())) {
 124     const auto *expr =
 125         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
 126     if (!expr)
 127       continue;
 128     if (arg.index() <= 1 ||
 129         !Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
 130       // Non optional arguments.
 131       prepareOtherArgument(*expr, fir::LowerIntrinsicArgAs::Value);
 132     } else {
 133       // Dynamically optional arguments.
 134       // Subtle: even for scalar the if-then-else will be generated in the loop
 135       // nest because the then part will require the current extremum value that
 136       // may depend on previous array element argument and cannot be outlined.
 137       prepareOptionalArgument(*expr);
 138     }
 139   }
 140 }
 141
 142 static fir::ExtendedValue
 143 lowerMinOrMax(fir::FirOpBuilder &builder, mlir::Location loc,
 144               llvm::StringRef name, std::optional<mlir::Type> retTy,
 145               const Fortran::lower::OperandPresent &isPresentCheck,
 146               const Fortran::lower::OperandGetter &getOperand,
 147               std::size_t numOperands,
 148               Fortran::lower::StatementContext &stmtCtx) {
 149   assert(numOperands >= 2 && !isPresentCheck(0) && !isPresentCheck(1) &&
 150          "min/max must have at least two non-optional args");
 151   assert(retTy && "MIN and MAX must have a return type");
 152   mlir::Type resultType = *retTy;
 153   llvm::SmallVector<fir::ExtendedValue> args;
 154   const bool loadOperand = true;
 155   args.push_back(getOperand(0, loadOperand));
 156   args.push_back(getOperand(1, loadOperand));
 157   mlir::Value extremum = fir::getBase(
 158       genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx));
 159
 160   for (std::size_t opIndex = 2; opIndex < numOperands; ++opIndex) {
 161     if (std::optional<mlir::Value> isPresentRuntimeCheck =
 162             isPresentCheck(opIndex)) {
 163       // Argument is dynamically optional.
 164       extremum =
 165           builder
 166               .genIfOp(loc, {resultType}, *isPresentRuntimeCheck,
 167                        /*withElseRegion=*/true)
 168               .genThen([&]() {
 169                 llvm::SmallVector<fir::ExtendedValue> args;
 170                 args.emplace_back(extremum);
 171                 args.emplace_back(getOperand(opIndex, loadOperand));
 172                 fir::ExtendedValue newExtremum = genIntrinsicCall(
 173                     builder, loc, name, resultType, args, stmtCtx);
 174                 builder.create<fir::ResultOp>(loc, fir::getBase(newExtremum));
 175               })
 176               .genElse([&]() { builder.create<fir::ResultOp>(loc, extremum); })
 177               .getResults()[0];
 178     } else {
 179       // Argument is know to be present at compile time.
 180       llvm::SmallVector<fir::ExtendedValue> args;
 181       args.emplace_back(extremum);
 182       args.emplace_back(getOperand(opIndex, loadOperand));
 183       extremum = fir::getBase(
 184           genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx));
 185     }
 186   }
 187   return extremum;
 188 }
 189
 190 static void prepareIshftcArguments(
 191     const Fortran::evaluate::ProcedureRef &procRef,
 192     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
 193     std::optional<mlir::Type> retTy,
 194     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
 195     const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
 196     Fortran::lower::AbstractConverter &converter) {
 197   for (auto arg : llvm::enumerate(procRef.arguments())) {
 198     const auto *expr =
 199         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
 200     assert(expr && "expected all ISHFTC argument to be textually present here");
 201     if (arg.index() == 2) {
 202       assert(Fortran::evaluate::MayBePassedAsAbsentOptional(*expr) &&
 203              "expected ISHFTC SIZE arg to be dynamically optional");
 204       prepareOptionalArgument(*expr);
 205     } else {
 206       // Non optional arguments.
 207       prepareOtherArgument(*expr, fir::LowerIntrinsicArgAs::Value);
 208     }
 209   }
 210 }
 211
 212 static fir::ExtendedValue
 213 lowerIshftc(fir::FirOpBuilder &builder, mlir::Location loc,
 214             llvm::StringRef name, std::optional<mlir::Type> retTy,
 215             const Fortran::lower::OperandPresent &isPresentCheck,
 216             const Fortran::lower::OperandGetter &getOperand,
 217             std::size_t numOperands,
 218             Fortran::lower::StatementContext &stmtCtx) {
 219   assert(numOperands == 3 && !isPresentCheck(0) && !isPresentCheck(1) &&
 220          isPresentCheck(2) &&
 221          "only ISHFTC SIZE arg is expected to be dynamically optional here");
 222   assert(retTy && "ISFHTC must have a return type");
 223   mlir::Type resultType = *retTy;
 224   llvm::SmallVector<fir::ExtendedValue> args;
 225   const bool loadOperand = true;
 226   args.push_back(getOperand(0, loadOperand));
 227   args.push_back(getOperand(1, loadOperand));
 228   auto iPC = isPresentCheck(2);
 229   assert(iPC.has_value());
 230   args.push_back(
 231       builder
 232           .genIfOp(loc, {resultType}, *iPC,
 233                    /*withElseRegion=*/true)
 234           .genThen([&]() {
 235             fir::ExtendedValue sizeExv = getOperand(2, loadOperand);
 236             mlir::Value size =
 237                 builder.createConvert(loc, resultType, fir::getBase(sizeExv));
 238             builder.create<fir::ResultOp>(loc, size);
 239           })
 240           .genElse([&]() {
 241             mlir::Value bitSize = builder.createIntegerConstant(
 242                 loc, resultType,
 243                 mlir::cast<mlir::IntegerType>(resultType).getWidth());
 244             builder.create<fir::ResultOp>(loc, bitSize);
 245           })
 246           .getResults()[0]);
 247   return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
 248 }
 249
 250 static void prepareAssociatedArguments(
 251     const Fortran::evaluate::ProcedureRef &procRef,
 252     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
 253     std::optional<mlir::Type> retTy,
 254     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
 255     const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
 256     Fortran::lower::AbstractConverter &converter) {
 257   const auto *pointer = procRef.UnwrapArgExpr(0);
 258   const auto *optionalTarget = procRef.UnwrapArgExpr(1);
 259   assert(pointer && optionalTarget &&
 260          "expected call to associated with a target");
 261   prepareOtherArgument(*pointer, fir::LowerIntrinsicArgAs::Inquired);
 262   prepareOptionalArgument(*optionalTarget);
 263 }
 264
 265 static fir::ExtendedValue
 266 lowerAssociated(fir::FirOpBuilder &builder, mlir::Location loc,
 267                 llvm::StringRef name, std::optional<mlir::Type> resultType,
 268                 const Fortran::lower::OperandPresent &isPresentCheck,
 269                 const Fortran::lower::OperandGetter &getOperand,
 270                 std::size_t numOperands,
 271                 Fortran::lower::StatementContext &stmtCtx) {
 272   assert(numOperands == 2 && "expect two arguments when TARGET is OPTIONAL");
 273   llvm::SmallVector<fir::ExtendedValue> args;
 274   args.push_back(getOperand(0, /*loadOperand=*/false));
 275   // Ensure a null descriptor is passed to the code lowering Associated if
 276   // TARGET is absent.
 277   fir::ExtendedValue targetExv = getOperand(1, /*loadOperand=*/false);
 278   mlir::Value targetBase = fir::getBase(targetExv);
 279   // subtle: isPresentCheck would test for an unallocated/disassociated target,
 280   // while the optionality of the target pointer/allocatable is what must be
 281   // checked here.
 282   mlir::Value isPresent =
 283       builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), targetBase);
 284   mlir::Type targetType = fir::unwrapRefType(targetBase.getType());
 285   mlir::Type targetValueType = fir::unwrapPassByRefType(targetType);
 286   mlir::Type boxType = mlir::isa<fir::BaseBoxType>(targetType)
 287                            ? targetType
 288                            : fir::BoxType::get(targetValueType);
 289   fir::BoxValue targetBox =
 290       builder
 291           .genIfOp(loc, {boxType}, isPresent,
 292                    /*withElseRegion=*/true)
 293           .genThen([&]() {
 294             mlir::Value box = builder.createBox(loc, targetExv);
 295             mlir::Value cast = builder.createConvert(loc, boxType, box);
 296             builder.create<fir::ResultOp>(loc, cast);
 297           })
 298           .genElse([&]() {
 299             mlir::Value absentBox = builder.create<fir::AbsentOp>(loc, boxType);
 300             builder.create<fir::ResultOp>(loc, absentBox);
 301           })
 302           .getResults()[0];
 303   args.emplace_back(std::move(targetBox));
 304   return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
 305 }
 306
 307 void Fortran::lower::prepareCustomIntrinsicArgument(
 308     const Fortran::evaluate::ProcedureRef &procRef,
 309     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
 310     std::optional<mlir::Type> retTy,
 311     const OperandPrepare &prepareOptionalArgument,
 312     const OperandPrepareAs &prepareOtherArgument,
 313     AbstractConverter &converter) {
 314   llvm::StringRef name = intrinsic.name;
 315   if (name == "min" || name == "max")
 316     return prepareMinOrMaxArguments(procRef, intrinsic, retTy,
 317                                     prepareOptionalArgument,
 318                                     prepareOtherArgument, converter);
 319   if (name == "associated")
 320     return prepareAssociatedArguments(procRef, intrinsic, retTy,
 321                                       prepareOptionalArgument,
 322                                       prepareOtherArgument, converter);
 323   assert(name == "ishftc" && "unexpected custom intrinsic argument call");
 324   return prepareIshftcArguments(procRef, intrinsic, retTy,
 325                                 prepareOptionalArgument, prepareOtherArgument,
 326                                 converter);
 327 }
 328
 329 fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic(
 330     fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
 331     std::optional<mlir::Type> retTy, const OperandPresent &isPresentCheck,
 332     const OperandGetter &getOperand, std::size_t numOperands,
 333     Fortran::lower::StatementContext &stmtCtx) {
 334   if (name == "min" || name == "max")
 335     return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand,
 336                          numOperands, stmtCtx);
 337   if (name == "associated")
 338     return lowerAssociated(builder, loc, name, retTy, isPresentCheck,
 339                            getOperand, numOperands, stmtCtx);
 340   assert(name == "ishftc" && "unexpected custom intrinsic call");
 341   return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand,
 342                      numOperands, stmtCtx);
 343 }