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.
genUnreachable(fir::FirOpBuilder & builder,mlir::Location loc)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
genStopStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::StopStmt & stmt)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
genFailImageStatement(Fortran::lower::AbstractConverter & converter)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
genEventPostStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::EventPostStmt &)121 void Fortran::lower::genEventPostStatement(
122 Fortran::lower::AbstractConverter &converter,
123 const Fortran::parser::EventPostStmt &) {
124 TODO(converter.getCurrentLocation(), "EVENT POST runtime");
125 }
126
genEventWaitStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::EventWaitStmt &)127 void Fortran::lower::genEventWaitStatement(
128 Fortran::lower::AbstractConverter &converter,
129 const Fortran::parser::EventWaitStmt &) {
130 TODO(converter.getCurrentLocation(), "EVENT WAIT runtime");
131 }
132
genLockStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::LockStmt &)133 void Fortran::lower::genLockStatement(
134 Fortran::lower::AbstractConverter &converter,
135 const Fortran::parser::LockStmt &) {
136 TODO(converter.getCurrentLocation(), "LOCK runtime");
137 }
138
genUnlockStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::UnlockStmt &)139 void Fortran::lower::genUnlockStatement(
140 Fortran::lower::AbstractConverter &converter,
141 const Fortran::parser::UnlockStmt &) {
142 TODO(converter.getCurrentLocation(), "UNLOCK runtime");
143 }
144
genSyncAllStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::SyncAllStmt &)145 void Fortran::lower::genSyncAllStatement(
146 Fortran::lower::AbstractConverter &converter,
147 const Fortran::parser::SyncAllStmt &) {
148 TODO(converter.getCurrentLocation(), "SYNC ALL runtime");
149 }
150
genSyncImagesStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::SyncImagesStmt &)151 void Fortran::lower::genSyncImagesStatement(
152 Fortran::lower::AbstractConverter &converter,
153 const Fortran::parser::SyncImagesStmt &) {
154 TODO(converter.getCurrentLocation(), "SYNC IMAGES runtime");
155 }
156
genSyncMemoryStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::SyncMemoryStmt &)157 void Fortran::lower::genSyncMemoryStatement(
158 Fortran::lower::AbstractConverter &converter,
159 const Fortran::parser::SyncMemoryStmt &) {
160 TODO(converter.getCurrentLocation(), "SYNC MEMORY runtime");
161 }
162
genSyncTeamStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::SyncTeamStmt &)163 void Fortran::lower::genSyncTeamStatement(
164 Fortran::lower::AbstractConverter &converter,
165 const Fortran::parser::SyncTeamStmt &) {
166 TODO(converter.getCurrentLocation(), "SYNC TEAM runtime");
167 }
168
genPauseStatement(Fortran::lower::AbstractConverter & converter,const Fortran::parser::PauseStmt &)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
genAssociated(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value pointer,mlir::Value target)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
genCpuTime(fir::FirOpBuilder & builder,mlir::Location loc)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
genDateAndTime(fir::FirOpBuilder & builder,mlir::Location loc,llvm::Optional<fir::CharBoxValue> date,llvm::Optional<fir::CharBoxValue> time,llvm::Optional<fir::CharBoxValue> zone,mlir::Value values)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
genRandomInit(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value repeatable,mlir::Value imageDistinct)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
genRandomNumber(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value harvest)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
genRandomSeed(fir::FirOpBuilder & builder,mlir::Location loc,int argIndex,mlir::Value argBox)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
genTransfer(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value resultBox,mlir::Value sourceBox,mlir::Value moldBox)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
genTransferSize(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value resultBox,mlir::Value sourceBox,mlir::Value moldBox,mlir::Value size)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{}
genSystemClock(fir::FirOpBuilder & builder,mlir::Location loc,mlir::Value count,mlir::Value rate,mlir::Value max)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