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.getValue();
93   mlir::Location loc = converter.getCurrentLocation();
94   if (fir::isa_char(resultType))
95     TODO(loc,
96          "CHARACTER MIN and MAX lowering with dynamically optional arguments");
97   for (auto arg : llvm::enumerate(procRef.arguments())) {
98     const auto *expr =
99         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
100     if (!expr)
101       continue;
102     if (arg.index() <= 1 || !Fortran::evaluate::MayBePassedAsAbsentOptional(
103                                 *expr, converter.getFoldingContext())) {
104       // Non optional arguments.
105       prepareOtherArgument(*expr);
106     } else {
107       // Dynamically optional arguments.
108       // Subtle: even for scalar the if-then-else will be generated in the loop
109       // nest because the then part will require the current extremum value that
110       // may depend on previous array element argument and cannot be outlined.
111       prepareOptionalArgument(*expr);
112     }
113   }
114 }
115 
116 static fir::ExtendedValue
117 lowerMinOrMax(fir::FirOpBuilder &builder, mlir::Location loc,
118               llvm::StringRef name, llvm::Optional<mlir::Type> retTy,
119               const Fortran::lower::OperandPresent &isPresentCheck,
120               const Fortran::lower::OperandGetter &getOperand,
121               std::size_t numOperands,
122               Fortran::lower::StatementContext &stmtCtx) {
123   assert(numOperands >= 2 && !isPresentCheck(0) && !isPresentCheck(1) &&
124          "min/max must have at least two non-optional args");
125   assert(retTy && "MIN and MAX must have a return type");
126   mlir::Type resultType = retTy.getValue();
127   llvm::SmallVector<fir::ExtendedValue> args;
128   args.push_back(getOperand(0));
129   args.push_back(getOperand(1));
130   mlir::Value extremum = fir::getBase(Fortran::lower::genIntrinsicCall(
131       builder, loc, name, resultType, args, stmtCtx));
132 
133   for (std::size_t opIndex = 2; opIndex < numOperands; ++opIndex) {
134     if (llvm::Optional<mlir::Value> isPresentRuntimeCheck =
135             isPresentCheck(opIndex)) {
136       // Argument is dynamically optional.
137       extremum =
138           builder
139               .genIfOp(loc, {resultType}, isPresentRuntimeCheck.getValue(),
140                        /*withElseRegion=*/true)
141               .genThen([&]() {
142                 llvm::SmallVector<fir::ExtendedValue> args;
143                 args.emplace_back(extremum);
144                 args.emplace_back(getOperand(opIndex));
145                 fir::ExtendedValue newExtremum =
146                     Fortran::lower::genIntrinsicCall(builder, loc, name,
147                                                      resultType, args, stmtCtx);
148                 builder.create<fir::ResultOp>(loc, fir::getBase(newExtremum));
149               })
150               .genElse([&]() { builder.create<fir::ResultOp>(loc, extremum); })
151               .getResults()[0];
152     } else {
153       // Argument is know to be present at compile time.
154       llvm::SmallVector<fir::ExtendedValue> args;
155       args.emplace_back(extremum);
156       args.emplace_back(getOperand(opIndex));
157       extremum = fir::getBase(Fortran::lower::genIntrinsicCall(
158           builder, loc, name, resultType, args, stmtCtx));
159     }
160   }
161   return extremum;
162 }
163 
164 static void prepareIshftcArguments(
165     const Fortran::evaluate::ProcedureRef &procRef,
166     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
167     llvm::Optional<mlir::Type> retTy,
168     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
169     const Fortran::lower::OperandPrepare &prepareOtherArgument,
170     Fortran::lower::AbstractConverter &converter) {
171   for (auto arg : llvm::enumerate(procRef.arguments())) {
172     const auto *expr =
173         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
174     assert(expr && "expected all ISHFTC argument to be textually present here");
175     if (arg.index() == 2) {
176       assert(Fortran::evaluate::MayBePassedAsAbsentOptional(
177                  *expr, converter.getFoldingContext()) &&
178              "expected ISHFTC SIZE arg to be dynamically optional");
179       prepareOptionalArgument(*expr);
180     } else {
181       // Non optional arguments.
182       prepareOtherArgument(*expr);
183     }
184   }
185 }
186 
187 static fir::ExtendedValue
188 lowerIshftc(fir::FirOpBuilder &builder, mlir::Location loc,
189             llvm::StringRef name, llvm::Optional<mlir::Type> retTy,
190             const Fortran::lower::OperandPresent &isPresentCheck,
191             const Fortran::lower::OperandGetter &getOperand,
192             std::size_t numOperands,
193             Fortran::lower::StatementContext &stmtCtx) {
194   assert(numOperands == 3 && !isPresentCheck(0) && !isPresentCheck(1) &&
195          isPresentCheck(2) &&
196          "only ISHFTC SIZE arg is expected to be dynamically optional here");
197   assert(retTy && "ISFHTC must have a return type");
198   mlir::Type resultType = retTy.getValue();
199   llvm::SmallVector<fir::ExtendedValue> args;
200   args.push_back(getOperand(0));
201   args.push_back(getOperand(1));
202   args.push_back(builder
203                      .genIfOp(loc, {resultType}, isPresentCheck(2).getValue(),
204                               /*withElseRegion=*/true)
205                      .genThen([&]() {
206                        fir::ExtendedValue sizeExv = getOperand(2);
207                        mlir::Value size = builder.createConvert(
208                            loc, resultType, fir::getBase(sizeExv));
209                        builder.create<fir::ResultOp>(loc, size);
210                      })
211                      .genElse([&]() {
212                        mlir::Value bitSize = builder.createIntegerConstant(
213                            loc, resultType,
214                            resultType.cast<mlir::IntegerType>().getWidth());
215                        builder.create<fir::ResultOp>(loc, bitSize);
216                      })
217                      .getResults()[0]);
218   return Fortran::lower::genIntrinsicCall(builder, loc, name, resultType, args,
219                                           stmtCtx);
220 }
221 
222 void Fortran::lower::prepareCustomIntrinsicArgument(
223     const Fortran::evaluate::ProcedureRef &procRef,
224     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
225     llvm::Optional<mlir::Type> retTy,
226     const OperandPrepare &prepareOptionalArgument,
227     const OperandPrepare &prepareOtherArgument, AbstractConverter &converter) {
228   llvm::StringRef name = intrinsic.name;
229   if (name == "min" || name == "max")
230     return prepareMinOrMaxArguments(procRef, intrinsic, retTy,
231                                     prepareOptionalArgument,
232                                     prepareOtherArgument, converter);
233   if (name == "ishftc")
234     return prepareIshftcArguments(procRef, intrinsic, retTy,
235                                   prepareOptionalArgument, prepareOtherArgument,
236                                   converter);
237   TODO(converter.getCurrentLocation(),
238        "unhandled dynamically optional arguments in SYSTEM_CLOCK or "
239        "RANDOM_SEED");
240 }
241 
242 fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic(
243     fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
244     llvm::Optional<mlir::Type> retTy, const OperandPresent &isPresentCheck,
245     const OperandGetter &getOperand, std::size_t numOperands,
246     Fortran::lower::StatementContext &stmtCtx) {
247   if (name == "min" || name == "max")
248     return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand,
249                          numOperands, stmtCtx);
250   if (name == "ishftc")
251     return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand,
252                        numOperands, stmtCtx);
253   TODO(loc, "unhandled dynamically optional arguments in SYSTEM_CLOCK or "
254             "RANDOM_SEED");
255 }
256