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