1 //===-- Runtime.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 #include "flang/Lower/Runtime.h"
10 #include "flang/Lower/Bridge.h"
11 #include "flang/Lower/StatementContext.h"
12 #include "flang/Lower/Todo.h"
13 #include "flang/Optimizer/Builder/FIRBuilder.h"
14 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
15 #include "flang/Parser/parse-tree.h"
16 #include "flang/Runtime/misc-intrinsic.h"
17 #include "flang/Runtime/pointer.h"
18 #include "flang/Runtime/random.h"
19 #include "flang/Runtime/stop.h"
20 #include "flang/Runtime/time-intrinsic.h"
21 #include "flang/Semantics/tools.h"
22 #include "llvm/Support/Debug.h"
23 
24 #define DEBUG_TYPE "flang-lower-runtime"
25 
26 using namespace Fortran::runtime;
27 
28 /// Runtime calls that do not return to the caller indicate this condition by
29 /// terminating the current basic block with an unreachable op.
30 static void genUnreachable(fir::FirOpBuilder &builder, mlir::Location loc) {
31   builder.create<fir::UnreachableOp>(loc);
32   mlir::Block *newBlock =
33       builder.getBlock()->splitBlock(builder.getInsertionPoint());
34   builder.setInsertionPointToStart(newBlock);
35 }
36 
37 //===----------------------------------------------------------------------===//
38 // Misc. Fortran statements that lower to runtime calls
39 //===----------------------------------------------------------------------===//
40 
41 void Fortran::lower::genStopStatement(
42     Fortran::lower::AbstractConverter &converter,
43     const Fortran::parser::StopStmt &stmt) {
44   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
45   mlir::Location loc = converter.getCurrentLocation();
46   Fortran::lower::StatementContext stmtCtx;
47   llvm::SmallVector<mlir::Value> operands;
48   mlir::FuncOp callee;
49   mlir::FunctionType calleeType;
50   // First operand is stop code (zero if absent)
51   if (const auto &code =
52           std::get<std::optional<Fortran::parser::StopCode>>(stmt.t)) {
53     auto expr =
54         converter.genExprValue(*Fortran::semantics::GetExpr(*code), stmtCtx);
55     LLVM_DEBUG(llvm::dbgs() << "stop expression: "; expr.dump();
56                llvm::dbgs() << '\n');
57     expr.match(
58         [&](const fir::CharBoxValue &x) {
59           callee = fir::runtime::getRuntimeFunc<mkRTKey(StopStatementText)>(
60               loc, builder);
61           calleeType = callee.getType();
62           // Creates a pair of operands for the CHARACTER and its LEN.
63           operands.push_back(
64               builder.createConvert(loc, calleeType.getInput(0), x.getAddr()));
65           operands.push_back(
66               builder.createConvert(loc, calleeType.getInput(1), x.getLen()));
67         },
68         [&](fir::UnboxedValue x) {
69           callee = fir::runtime::getRuntimeFunc<mkRTKey(StopStatement)>(
70               loc, builder);
71           calleeType = callee.getType();
72           mlir::Value cast =
73               builder.createConvert(loc, calleeType.getInput(0), x);
74           operands.push_back(cast);
75         },
76         [&](auto) {
77           mlir::emitError(loc, "unhandled expression in STOP");
78           std::exit(1);
79         });
80   } else {
81     callee = fir::runtime::getRuntimeFunc<mkRTKey(StopStatement)>(loc, builder);
82     calleeType = callee.getType();
83     operands.push_back(
84         builder.createIntegerConstant(loc, calleeType.getInput(0), 0));
85   }
86 
87   // Second operand indicates ERROR STOP
88   bool isError = std::get<Fortran::parser::StopStmt::Kind>(stmt.t) ==
89                  Fortran::parser::StopStmt::Kind::ErrorStop;
90   operands.push_back(builder.createIntegerConstant(
91       loc, calleeType.getInput(operands.size()), isError));
92 
93   // Third operand indicates QUIET (default to false).
94   if (const auto &quiet =
95           std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(stmt.t)) {
96     const SomeExpr *expr = Fortran::semantics::GetExpr(*quiet);
97     assert(expr && "failed getting typed expression");
98     mlir::Value q = fir::getBase(converter.genExprValue(*expr, stmtCtx));
99     operands.push_back(
100         builder.createConvert(loc, calleeType.getInput(operands.size()), q));
101   } else {
102     operands.push_back(builder.createIntegerConstant(
103         loc, calleeType.getInput(operands.size()), 0));
104   }
105 
106   builder.create<fir::CallOp>(loc, callee, operands);
107   genUnreachable(builder, loc);
108 }
109 
110 void Fortran::lower::genPauseStatement(
111     Fortran::lower::AbstractConverter &converter,
112     const Fortran::parser::PauseStmt &) {
113   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
114   mlir::Location loc = converter.getCurrentLocation();
115   mlir::FuncOp callee =
116       fir::runtime::getRuntimeFunc<mkRTKey(PauseStatement)>(loc, builder);
117   builder.create<fir::CallOp>(loc, callee, llvm::None);
118 }
119 
120 mlir::Value Fortran::lower::genAssociated(fir::FirOpBuilder &builder,
121                                           mlir::Location loc,
122                                           mlir::Value pointer,
123                                           mlir::Value target) {
124   mlir::FuncOp func =
125       fir::runtime::getRuntimeFunc<mkRTKey(PointerIsAssociatedWith)>(loc,
126                                                                      builder);
127   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
128       builder, loc, func.getType(), pointer, target);
129   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
130 }
131 
132 mlir::Value Fortran::lower::genCpuTime(fir::FirOpBuilder &builder,
133                                        mlir::Location loc) {
134   mlir::FuncOp func =
135       fir::runtime::getRuntimeFunc<mkRTKey(CpuTime)>(loc, builder);
136   return builder.create<fir::CallOp>(loc, func, llvm::None).getResult(0);
137 }
138 
139 void Fortran::lower::genDateAndTime(fir::FirOpBuilder &builder,
140                                     mlir::Location loc,
141                                     llvm::Optional<fir::CharBoxValue> date,
142                                     llvm::Optional<fir::CharBoxValue> time,
143                                     llvm::Optional<fir::CharBoxValue> zone,
144                                     mlir::Value values) {
145   mlir::FuncOp callee =
146       fir::runtime::getRuntimeFunc<mkRTKey(DateAndTime)>(loc, builder);
147   mlir::FunctionType funcTy = callee.getType();
148   mlir::Type idxTy = builder.getIndexType();
149   mlir::Value zero;
150   auto splitArg = [&](llvm::Optional<fir::CharBoxValue> arg,
151                       mlir::Value &buffer, mlir::Value &len) {
152     if (arg) {
153       buffer = arg->getBuffer();
154       len = arg->getLen();
155     } else {
156       if (!zero)
157         zero = builder.createIntegerConstant(loc, idxTy, 0);
158       buffer = zero;
159       len = zero;
160     }
161   };
162   mlir::Value dateBuffer;
163   mlir::Value dateLen;
164   splitArg(date, dateBuffer, dateLen);
165   mlir::Value timeBuffer;
166   mlir::Value timeLen;
167   splitArg(time, timeBuffer, timeLen);
168   mlir::Value zoneBuffer;
169   mlir::Value zoneLen;
170   splitArg(zone, zoneBuffer, zoneLen);
171 
172   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
173   mlir::Value sourceLine =
174       fir::factory::locationToLineNo(builder, loc, funcTy.getInput(7));
175 
176   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
177       builder, loc, funcTy, dateBuffer, dateLen, timeBuffer, timeLen,
178       zoneBuffer, zoneLen, sourceFile, sourceLine, values);
179   builder.create<fir::CallOp>(loc, callee, args);
180 }
181 
182 void Fortran::lower::genRandomInit(fir::FirOpBuilder &builder,
183                                    mlir::Location loc, mlir::Value repeatable,
184                                    mlir::Value imageDistinct) {
185   mlir::FuncOp func =
186       fir::runtime::getRuntimeFunc<mkRTKey(RandomInit)>(loc, builder);
187   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
188       builder, loc, func.getType(), repeatable, imageDistinct);
189   builder.create<fir::CallOp>(loc, func, args);
190 }
191 
192 void Fortran::lower::genRandomNumber(fir::FirOpBuilder &builder,
193                                      mlir::Location loc, mlir::Value harvest) {
194   mlir::FuncOp func =
195       fir::runtime::getRuntimeFunc<mkRTKey(RandomNumber)>(loc, builder);
196   mlir::FunctionType funcTy = func.getType();
197   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
198   mlir::Value sourceLine =
199       fir::factory::locationToLineNo(builder, loc, funcTy.getInput(2));
200   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
201       builder, loc, funcTy, harvest, sourceFile, sourceLine);
202   builder.create<fir::CallOp>(loc, func, args);
203 }
204 
205 void Fortran::lower::genRandomSeed(fir::FirOpBuilder &builder,
206                                    mlir::Location loc, int argIndex,
207                                    mlir::Value argBox) {
208   mlir::FuncOp func;
209   // argIndex is the nth (0-origin) argument in declaration order,
210   // or -1 if no argument is present.
211   switch (argIndex) {
212   case -1:
213     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedDefaultPut)>(loc,
214                                                                        builder);
215     builder.create<fir::CallOp>(loc, func);
216     return;
217   case 0:
218     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedSize)>(loc, builder);
219     break;
220   case 1:
221     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedPut)>(loc, builder);
222     break;
223   case 2:
224     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedGet)>(loc, builder);
225     break;
226   default:
227     llvm::report_fatal_error("invalid RANDOM_SEED argument index");
228   }
229   mlir::FunctionType funcTy = func.getType();
230   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
231   mlir::Value sourceLine =
232       fir::factory::locationToLineNo(builder, loc, funcTy.getInput(2));
233   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
234       builder, loc, funcTy, argBox, sourceFile, sourceLine);
235   builder.create<fir::CallOp>(loc, func, args);
236 }
237 
238 /// generate runtime call to transfer intrinsic with no size argument
239 void Fortran::lower::genTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
240                                  mlir::Value resultBox, mlir::Value sourceBox,
241                                  mlir::Value moldBox) {
242 
243   mlir::FuncOp func =
244       fir::runtime::getRuntimeFunc<mkRTKey(Transfer)>(loc, builder);
245   mlir::FunctionType fTy = func.getType();
246   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
247   mlir::Value sourceLine =
248       fir::factory::locationToLineNo(builder, loc, fTy.getInput(4));
249   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
250       builder, loc, fTy, resultBox, sourceBox, moldBox, sourceFile, sourceLine);
251   builder.create<fir::CallOp>(loc, func, args);
252 }
253 
254 /// generate runtime call to transfer intrinsic with size argument
255 void Fortran::lower::genTransferSize(fir::FirOpBuilder &builder,
256                                      mlir::Location loc, mlir::Value resultBox,
257                                      mlir::Value sourceBox, mlir::Value moldBox,
258                                      mlir::Value size) {
259   mlir::FuncOp func =
260       fir::runtime::getRuntimeFunc<mkRTKey(TransferSize)>(loc, builder);
261   mlir::FunctionType fTy = func.getType();
262   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
263   mlir::Value sourceLine =
264       fir::factory::locationToLineNo(builder, loc, fTy.getInput(4));
265   llvm::SmallVector<mlir::Value> args =
266       fir::runtime::createArguments(builder, loc, fTy, resultBox, sourceBox,
267                                     moldBox, sourceFile, sourceLine, size);
268   builder.create<fir::CallOp>(loc, func, args);
269 }
270 
271 /// generate system_clock runtime call/s
272 /// all intrinsic arguments are optional and may appear here as mlir::Value{}
273 void Fortran::lower::genSystemClock(fir::FirOpBuilder &builder,
274                                     mlir::Location loc, mlir::Value count,
275                                     mlir::Value rate, mlir::Value max) {
276   auto makeCall = [&](mlir::FuncOp func, mlir::Value arg) {
277     mlir::Type kindTy = func.getType().getInput(0);
278     int integerKind = 8;
279     if (auto intType =
280             fir::unwrapRefType(arg.getType()).dyn_cast<mlir::IntegerType>())
281       integerKind = intType.getWidth() / 8;
282     mlir::Value kind = builder.createIntegerConstant(loc, kindTy, integerKind);
283     mlir::Value res =
284         builder.create<fir::CallOp>(loc, func, mlir::ValueRange{kind})
285             .getResult(0);
286     mlir::Value castRes =
287         builder.createConvert(loc, fir::dyn_cast_ptrEleTy(arg.getType()), res);
288     builder.create<fir::StoreOp>(loc, castRes, arg);
289   };
290   using fir::runtime::getRuntimeFunc;
291   if (count)
292     makeCall(getRuntimeFunc<mkRTKey(SystemClockCount)>(loc, builder), count);
293   if (rate)
294     makeCall(getRuntimeFunc<mkRTKey(SystemClockCountRate)>(loc, builder), rate);
295   if (max)
296     makeCall(getRuntimeFunc<mkRTKey(SystemClockCountMax)>(loc, builder), max);
297 }
298