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/IntrinsicCall.h"
18 #include "flang/Optimizer/Builder/Todo.h"
19 
20 /// Is this a call to MIN or MAX intrinsic with arguments that may be absent at
21 /// runtime? This is a special case because MIN and MAX can have any number of
22 /// arguments.
23 static bool isMinOrMaxWithDynamicallyOptionalArg(
24     llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
25     Fortran::evaluate::FoldingContext &foldingContex) {
26   if (name != "min" && name != "max")
27     return false;
28   const auto &args = procRef.arguments();
29   std::size_t argSize = args.size();
30   if (argSize <= 2)
31     return false;
32   for (std::size_t i = 2; i < argSize; ++i) {
33     if (auto *expr =
34             Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(args[i]))
35       if (Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex))
36         return true;
37   }
38   return false;
39 }
40 
41 /// Is this a call to ISHFTC intrinsic with a SIZE argument that may be absent
42 /// at runtime? This is a special case because the SIZE value to be applied
43 /// when absent is not zero.
44 static bool isIshftcWithDynamicallyOptionalArg(
45     llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
46     Fortran::evaluate::FoldingContext &foldingContex) {
47   if (name != "ishftc" || procRef.arguments().size() < 3)
48     return false;
49   auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
50       procRef.arguments()[2]);
51   return expr &&
52          Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex);
53 }
54 
55 /// Is this a call to the RANDOM_SEED intrinsic with arguments that may be
56 /// absent at runtime? This is a special case because that aspect cannot
57 /// be delegated to the runtime via a null fir.box or address given the current
58 /// runtime entry point.
59 static bool isRandomSeedWithDynamicallyOptionalArg(
60     llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
61     Fortran::evaluate::FoldingContext &foldingContex) {
62   if (name != "random_seed")
63     return false;
64   for (const auto &arg : procRef.arguments()) {
65     auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg);
66     if (expr &&
67         Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex))
68       return true;
69   }
70   return false;
71 }
72 
73 bool Fortran::lower::intrinsicRequiresCustomOptionalHandling(
74     const Fortran::evaluate::ProcedureRef &procRef,
75     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
76     AbstractConverter &converter) {
77   llvm::StringRef name = intrinsic.name;
78   Fortran::evaluate::FoldingContext &fldCtx = converter.getFoldingContext();
79   return isMinOrMaxWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
80          isIshftcWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
81          isRandomSeedWithDynamicallyOptionalArg(name, procRef, fldCtx);
82 }
83 
84 static void prepareMinOrMaxArguments(
85     const Fortran::evaluate::ProcedureRef &procRef,
86     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
87     llvm::Optional<mlir::Type> retTy,
88     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
89     const Fortran::lower::OperandPrepare &prepareOtherArgument,
90     Fortran::lower::AbstractConverter &converter) {
91   assert(retTy && "MIN and MAX must have a return type");
92   mlir::Type resultType = *retTy;
93   mlir::Location loc = converter.getCurrentLocation();
94   if (fir::isa_char(resultType))
95     TODO(loc, "CHARACTER MIN and MAX with dynamically optional arguments");
96   for (auto arg : llvm::enumerate(procRef.arguments())) {
97     const auto *expr =
98         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
99     if (!expr)
100       continue;
101     if (arg.index() <= 1 || !Fortran::evaluate::MayBePassedAsAbsentOptional(
102                                 *expr, converter.getFoldingContext())) {
103       // Non optional arguments.
104       prepareOtherArgument(*expr);
105     } else {
106       // Dynamically optional arguments.
107       // Subtle: even for scalar the if-then-else will be generated in the loop
108       // nest because the then part will require the current extremum value that
109       // may depend on previous array element argument and cannot be outlined.
110       prepareOptionalArgument(*expr);
111     }
112   }
113 }
114 
115 static fir::ExtendedValue
116 lowerMinOrMax(fir::FirOpBuilder &builder, mlir::Location loc,
117               llvm::StringRef name, llvm::Optional<mlir::Type> retTy,
118               const Fortran::lower::OperandPresent &isPresentCheck,
119               const Fortran::lower::OperandGetter &getOperand,
120               std::size_t numOperands,
121               Fortran::lower::StatementContext &stmtCtx) {
122   assert(numOperands >= 2 && !isPresentCheck(0) && !isPresentCheck(1) &&
123          "min/max must have at least two non-optional args");
124   assert(retTy && "MIN and MAX must have a return type");
125   mlir::Type resultType = *retTy;
126   llvm::SmallVector<fir::ExtendedValue> args;
127   args.push_back(getOperand(0));
128   args.push_back(getOperand(1));
129   mlir::Value extremum = fir::getBase(Fortran::lower::genIntrinsicCall(
130       builder, loc, name, resultType, args, stmtCtx));
131 
132   for (std::size_t opIndex = 2; opIndex < numOperands; ++opIndex) {
133     if (llvm::Optional<mlir::Value> isPresentRuntimeCheck =
134             isPresentCheck(opIndex)) {
135       // Argument is dynamically optional.
136       extremum =
137           builder
138               .genIfOp(loc, {resultType}, *isPresentRuntimeCheck,
139                        /*withElseRegion=*/true)
140               .genThen([&]() {
141                 llvm::SmallVector<fir::ExtendedValue> args;
142                 args.emplace_back(extremum);
143                 args.emplace_back(getOperand(opIndex));
144                 fir::ExtendedValue newExtremum =
145                     Fortran::lower::genIntrinsicCall(builder, loc, name,
146                                                      resultType, args, stmtCtx);
147                 builder.create<fir::ResultOp>(loc, fir::getBase(newExtremum));
148               })
149               .genElse([&]() { builder.create<fir::ResultOp>(loc, extremum); })
150               .getResults()[0];
151     } else {
152       // Argument is know to be present at compile time.
153       llvm::SmallVector<fir::ExtendedValue> args;
154       args.emplace_back(extremum);
155       args.emplace_back(getOperand(opIndex));
156       extremum = fir::getBase(Fortran::lower::genIntrinsicCall(
157           builder, loc, name, resultType, args, stmtCtx));
158     }
159   }
160   return extremum;
161 }
162 
163 static void prepareIshftcArguments(
164     const Fortran::evaluate::ProcedureRef &procRef,
165     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
166     llvm::Optional<mlir::Type> retTy,
167     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
168     const Fortran::lower::OperandPrepare &prepareOtherArgument,
169     Fortran::lower::AbstractConverter &converter) {
170   for (auto arg : llvm::enumerate(procRef.arguments())) {
171     const auto *expr =
172         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
173     assert(expr && "expected all ISHFTC argument to be textually present here");
174     if (arg.index() == 2) {
175       assert(Fortran::evaluate::MayBePassedAsAbsentOptional(
176                  *expr, converter.getFoldingContext()) &&
177              "expected ISHFTC SIZE arg to be dynamically optional");
178       prepareOptionalArgument(*expr);
179     } else {
180       // Non optional arguments.
181       prepareOtherArgument(*expr);
182     }
183   }
184 }
185 
186 static fir::ExtendedValue
187 lowerIshftc(fir::FirOpBuilder &builder, mlir::Location loc,
188             llvm::StringRef name, llvm::Optional<mlir::Type> retTy,
189             const Fortran::lower::OperandPresent &isPresentCheck,
190             const Fortran::lower::OperandGetter &getOperand,
191             std::size_t numOperands,
192             Fortran::lower::StatementContext &stmtCtx) {
193   assert(numOperands == 3 && !isPresentCheck(0) && !isPresentCheck(1) &&
194          isPresentCheck(2) &&
195          "only ISHFTC SIZE arg is expected to be dynamically optional here");
196   assert(retTy && "ISFHTC must have a return type");
197   mlir::Type resultType = retTy.value();
198   llvm::SmallVector<fir::ExtendedValue> args;
199   args.push_back(getOperand(0));
200   args.push_back(getOperand(1));
201   args.push_back(builder
202                      .genIfOp(loc, {resultType}, isPresentCheck(2).value(),
203                               /*withElseRegion=*/true)
204                      .genThen([&]() {
205                        fir::ExtendedValue sizeExv = getOperand(2);
206                        mlir::Value size = builder.createConvert(
207                            loc, resultType, fir::getBase(sizeExv));
208                        builder.create<fir::ResultOp>(loc, size);
209                      })
210                      .genElse([&]() {
211                        mlir::Value bitSize = builder.createIntegerConstant(
212                            loc, resultType,
213                            resultType.cast<mlir::IntegerType>().getWidth());
214                        builder.create<fir::ResultOp>(loc, bitSize);
215                      })
216                      .getResults()[0]);
217   return Fortran::lower::genIntrinsicCall(builder, loc, name, resultType, args,
218                                           stmtCtx);
219 }
220 
221 void Fortran::lower::prepareCustomIntrinsicArgument(
222     const Fortran::evaluate::ProcedureRef &procRef,
223     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
224     llvm::Optional<mlir::Type> retTy,
225     const OperandPrepare &prepareOptionalArgument,
226     const OperandPrepare &prepareOtherArgument, AbstractConverter &converter) {
227   llvm::StringRef name = intrinsic.name;
228   if (name == "min" || name == "max")
229     return prepareMinOrMaxArguments(procRef, intrinsic, retTy,
230                                     prepareOptionalArgument,
231                                     prepareOtherArgument, converter);
232   if (name == "ishftc")
233     return prepareIshftcArguments(procRef, intrinsic, retTy,
234                                   prepareOptionalArgument, prepareOtherArgument,
235                                   converter);
236   TODO(converter.getCurrentLocation(),
237        "unhandled dynamically optional arguments in SYSTEM_CLOCK or "
238        "RANDOM_SEED");
239 }
240 
241 fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic(
242     fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
243     llvm::Optional<mlir::Type> retTy, const OperandPresent &isPresentCheck,
244     const OperandGetter &getOperand, std::size_t numOperands,
245     Fortran::lower::StatementContext &stmtCtx) {
246   if (name == "min" || name == "max")
247     return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand,
248                          numOperands, stmtCtx);
249   if (name == "ishftc")
250     return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand,
251                        numOperands, stmtCtx);
252   TODO(loc, "unhandled dynamically optional arguments in SYSTEM_CLOCK or "
253             "RANDOM_SEED");
254 }
255