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::func::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.getFunctionType();
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.getFunctionType();
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.getFunctionType();
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::genFailImageStatement(
111     Fortran::lower::AbstractConverter &converter) {
112   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
113   mlir::Location loc = converter.getCurrentLocation();
114   mlir::func::FuncOp callee =
115       fir::runtime::getRuntimeFunc<mkRTKey(FailImageStatement)>(loc, builder);
116   builder.create<fir::CallOp>(loc, callee, llvm::None);
117   genUnreachable(builder, loc);
118 }
119 
120 void Fortran::lower::genEventPostStatement(
121     Fortran::lower::AbstractConverter &converter,
122     const Fortran::parser::EventPostStmt &) {
123   TODO(converter.getCurrentLocation(), "EVENT POST runtime");
124 }
125 
126 void Fortran::lower::genEventWaitStatement(
127     Fortran::lower::AbstractConverter &converter,
128     const Fortran::parser::EventWaitStmt &) {
129   TODO(converter.getCurrentLocation(), "EVENT WAIT runtime");
130 }
131 
132 void Fortran::lower::genLockStatement(
133     Fortran::lower::AbstractConverter &converter,
134     const Fortran::parser::LockStmt &) {
135   TODO(converter.getCurrentLocation(), "LOCK runtime");
136 }
137 
138 void Fortran::lower::genUnlockStatement(
139     Fortran::lower::AbstractConverter &converter,
140     const Fortran::parser::UnlockStmt &) {
141   TODO(converter.getCurrentLocation(), "UNLOCK runtime");
142 }
143 
144 void Fortran::lower::genSyncAllStatement(
145     Fortran::lower::AbstractConverter &converter,
146     const Fortran::parser::SyncAllStmt &) {
147   TODO(converter.getCurrentLocation(), "SYNC ALL runtime");
148 }
149 
150 void Fortran::lower::genSyncImagesStatement(
151     Fortran::lower::AbstractConverter &converter,
152     const Fortran::parser::SyncImagesStmt &) {
153   TODO(converter.getCurrentLocation(), "SYNC IMAGES runtime");
154 }
155 
156 void Fortran::lower::genSyncMemoryStatement(
157     Fortran::lower::AbstractConverter &converter,
158     const Fortran::parser::SyncMemoryStmt &) {
159   TODO(converter.getCurrentLocation(), "SYNC MEMORY runtime");
160 }
161 
162 void Fortran::lower::genSyncTeamStatement(
163     Fortran::lower::AbstractConverter &converter,
164     const Fortran::parser::SyncTeamStmt &) {
165   TODO(converter.getCurrentLocation(), "SYNC TEAM runtime");
166 }
167 
168 void Fortran::lower::genPauseStatement(
169     Fortran::lower::AbstractConverter &converter,
170     const Fortran::parser::PauseStmt &) {
171   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
172   mlir::Location loc = converter.getCurrentLocation();
173   mlir::func::FuncOp callee =
174       fir::runtime::getRuntimeFunc<mkRTKey(PauseStatement)>(loc, builder);
175   builder.create<fir::CallOp>(loc, callee, llvm::None);
176 }
177 
178 mlir::Value Fortran::lower::genAssociated(fir::FirOpBuilder &builder,
179                                           mlir::Location loc,
180                                           mlir::Value pointer,
181                                           mlir::Value target) {
182   mlir::func::FuncOp func =
183       fir::runtime::getRuntimeFunc<mkRTKey(PointerIsAssociatedWith)>(loc,
184                                                                      builder);
185   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
186       builder, loc, func.getFunctionType(), pointer, target);
187   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
188 }
189 
190 mlir::Value Fortran::lower::genCpuTime(fir::FirOpBuilder &builder,
191                                        mlir::Location loc) {
192   mlir::func::FuncOp func =
193       fir::runtime::getRuntimeFunc<mkRTKey(CpuTime)>(loc, builder);
194   return builder.create<fir::CallOp>(loc, func, llvm::None).getResult(0);
195 }
196 
197 void Fortran::lower::genDateAndTime(fir::FirOpBuilder &builder,
198                                     mlir::Location loc,
199                                     llvm::Optional<fir::CharBoxValue> date,
200                                     llvm::Optional<fir::CharBoxValue> time,
201                                     llvm::Optional<fir::CharBoxValue> zone,
202                                     mlir::Value values) {
203   mlir::func::FuncOp callee =
204       fir::runtime::getRuntimeFunc<mkRTKey(DateAndTime)>(loc, builder);
205   mlir::FunctionType funcTy = callee.getFunctionType();
206   mlir::Type idxTy = builder.getIndexType();
207   mlir::Value zero;
208   auto splitArg = [&](llvm::Optional<fir::CharBoxValue> arg,
209                       mlir::Value &buffer, mlir::Value &len) {
210     if (arg) {
211       buffer = arg->getBuffer();
212       len = arg->getLen();
213     } else {
214       if (!zero)
215         zero = builder.createIntegerConstant(loc, idxTy, 0);
216       buffer = zero;
217       len = zero;
218     }
219   };
220   mlir::Value dateBuffer;
221   mlir::Value dateLen;
222   splitArg(date, dateBuffer, dateLen);
223   mlir::Value timeBuffer;
224   mlir::Value timeLen;
225   splitArg(time, timeBuffer, timeLen);
226   mlir::Value zoneBuffer;
227   mlir::Value zoneLen;
228   splitArg(zone, zoneBuffer, zoneLen);
229 
230   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
231   mlir::Value sourceLine =
232       fir::factory::locationToLineNo(builder, loc, funcTy.getInput(7));
233 
234   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
235       builder, loc, funcTy, dateBuffer, dateLen, timeBuffer, timeLen,
236       zoneBuffer, zoneLen, sourceFile, sourceLine, values);
237   builder.create<fir::CallOp>(loc, callee, args);
238 }
239 
240 void Fortran::lower::genRandomInit(fir::FirOpBuilder &builder,
241                                    mlir::Location loc, mlir::Value repeatable,
242                                    mlir::Value imageDistinct) {
243   mlir::func::FuncOp func =
244       fir::runtime::getRuntimeFunc<mkRTKey(RandomInit)>(loc, builder);
245   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
246       builder, loc, func.getFunctionType(), repeatable, imageDistinct);
247   builder.create<fir::CallOp>(loc, func, args);
248 }
249 
250 void Fortran::lower::genRandomNumber(fir::FirOpBuilder &builder,
251                                      mlir::Location loc, mlir::Value harvest) {
252   mlir::func::FuncOp func =
253       fir::runtime::getRuntimeFunc<mkRTKey(RandomNumber)>(loc, builder);
254   mlir::FunctionType funcTy = func.getFunctionType();
255   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
256   mlir::Value sourceLine =
257       fir::factory::locationToLineNo(builder, loc, funcTy.getInput(2));
258   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
259       builder, loc, funcTy, harvest, sourceFile, sourceLine);
260   builder.create<fir::CallOp>(loc, func, args);
261 }
262 
263 void Fortran::lower::genRandomSeed(fir::FirOpBuilder &builder,
264                                    mlir::Location loc, int argIndex,
265                                    mlir::Value argBox) {
266   mlir::func::FuncOp func;
267   // argIndex is the nth (0-origin) argument in declaration order,
268   // or -1 if no argument is present.
269   switch (argIndex) {
270   case -1:
271     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedDefaultPut)>(loc,
272                                                                        builder);
273     builder.create<fir::CallOp>(loc, func);
274     return;
275   case 0:
276     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedSize)>(loc, builder);
277     break;
278   case 1:
279     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedPut)>(loc, builder);
280     break;
281   case 2:
282     func = fir::runtime::getRuntimeFunc<mkRTKey(RandomSeedGet)>(loc, builder);
283     break;
284   default:
285     llvm::report_fatal_error("invalid RANDOM_SEED argument index");
286   }
287   mlir::FunctionType funcTy = func.getFunctionType();
288   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
289   mlir::Value sourceLine =
290       fir::factory::locationToLineNo(builder, loc, funcTy.getInput(2));
291   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
292       builder, loc, funcTy, argBox, sourceFile, sourceLine);
293   builder.create<fir::CallOp>(loc, func, args);
294 }
295 
296 /// generate runtime call to transfer intrinsic with no size argument
297 void Fortran::lower::genTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
298                                  mlir::Value resultBox, mlir::Value sourceBox,
299                                  mlir::Value moldBox) {
300 
301   mlir::func::FuncOp func =
302       fir::runtime::getRuntimeFunc<mkRTKey(Transfer)>(loc, builder);
303   mlir::FunctionType fTy = func.getFunctionType();
304   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
305   mlir::Value sourceLine =
306       fir::factory::locationToLineNo(builder, loc, fTy.getInput(4));
307   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
308       builder, loc, fTy, resultBox, sourceBox, moldBox, sourceFile, sourceLine);
309   builder.create<fir::CallOp>(loc, func, args);
310 }
311 
312 /// generate runtime call to transfer intrinsic with size argument
313 void Fortran::lower::genTransferSize(fir::FirOpBuilder &builder,
314                                      mlir::Location loc, mlir::Value resultBox,
315                                      mlir::Value sourceBox, mlir::Value moldBox,
316                                      mlir::Value size) {
317   mlir::func::FuncOp func =
318       fir::runtime::getRuntimeFunc<mkRTKey(TransferSize)>(loc, builder);
319   mlir::FunctionType fTy = func.getFunctionType();
320   mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
321   mlir::Value sourceLine =
322       fir::factory::locationToLineNo(builder, loc, fTy.getInput(4));
323   llvm::SmallVector<mlir::Value> args =
324       fir::runtime::createArguments(builder, loc, fTy, resultBox, sourceBox,
325                                     moldBox, sourceFile, sourceLine, size);
326   builder.create<fir::CallOp>(loc, func, args);
327 }
328 
329 /// generate system_clock runtime call/s
330 /// all intrinsic arguments are optional and may appear here as mlir::Value{}
331 void Fortran::lower::genSystemClock(fir::FirOpBuilder &builder,
332                                     mlir::Location loc, mlir::Value count,
333                                     mlir::Value rate, mlir::Value max) {
334   auto makeCall = [&](mlir::func::FuncOp func, mlir::Value arg) {
335     mlir::Type kindTy = func.getFunctionType().getInput(0);
336     int integerKind = 8;
337     if (auto intType =
338             fir::unwrapRefType(arg.getType()).dyn_cast<mlir::IntegerType>())
339       integerKind = intType.getWidth() / 8;
340     mlir::Value kind = builder.createIntegerConstant(loc, kindTy, integerKind);
341     mlir::Value res =
342         builder.create<fir::CallOp>(loc, func, mlir::ValueRange{kind})
343             .getResult(0);
344     mlir::Value castRes =
345         builder.createConvert(loc, fir::dyn_cast_ptrEleTy(arg.getType()), res);
346     builder.create<fir::StoreOp>(loc, castRes, arg);
347   };
348   using fir::runtime::getRuntimeFunc;
349   if (count)
350     makeCall(getRuntimeFunc<mkRTKey(SystemClockCount)>(loc, builder), count);
351   if (rate)
352     makeCall(getRuntimeFunc<mkRTKey(SystemClockCountRate)>(loc, builder), rate);
353   if (max)
354     makeCall(getRuntimeFunc<mkRTKey(SystemClockCountMax)>(loc, builder), max);
355 }
356