1//===-- IO.cpp -- IO statement lowering -----------------------------------===//
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/IO.h"
14#include "flang/Common/uint128.h"
15#include "flang/Evaluate/tools.h"
16#include "flang/Lower/Allocatable.h"
17#include "flang/Lower/Bridge.h"
18#include "flang/Lower/CallInterface.h"
19#include "flang/Lower/ConvertExpr.h"
20#include "flang/Lower/ConvertVariable.h"
21#include "flang/Lower/Mangler.h"
22#include "flang/Lower/PFTBuilder.h"
23#include "flang/Lower/Runtime.h"
24#include "flang/Lower/StatementContext.h"
25#include "flang/Lower/Support/Utils.h"
26#include "flang/Lower/VectorSubscripts.h"
27#include "flang/Optimizer/Builder/Character.h"
28#include "flang/Optimizer/Builder/Complex.h"
29#include "flang/Optimizer/Builder/FIRBuilder.h"
30#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
31#include "flang/Optimizer/Builder/Runtime/Stop.h"
32#include "flang/Optimizer/Builder/Todo.h"
33#include "flang/Optimizer/Dialect/FIRDialect.h"
34#include "flang/Optimizer/Dialect/Support/FIRContext.h"
35#include "flang/Optimizer/Support/InternalNames.h"
36#include "flang/Parser/parse-tree.h"
37#include "flang/Runtime/io-api.h"
38#include "flang/Semantics/runtime-type-info.h"
39#include "flang/Semantics/tools.h"
40#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
41#include "llvm/Support/Debug.h"
42#include <optional>
43
44#define DEBUG_TYPE "flang-lower-io"
45
46using namespace Fortran::runtime::io;
47
48#define mkIOKey(X) FirmkKey(IONAME(X))
49
50namespace Fortran::lower {
51/// Static table of IO runtime calls
52///
53/// This logical map contains the name and type builder function for each IO
54/// runtime function listed in the tuple. This table is fully constructed at
55/// compile-time. Use the `mkIOKey` macro to access the table.
56static constexpr std::tuple<
57 mkIOKey(BeginBackspace), mkIOKey(BeginClose), mkIOKey(BeginEndfile),
58 mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginExternalFormattedOutput),
59 mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalListOutput),
60 mkIOKey(BeginFlush), mkIOKey(BeginInquireFile),
61 mkIOKey(BeginInquireIoLength), mkIOKey(BeginInquireUnit),
62 mkIOKey(BeginInternalArrayFormattedInput),
63 mkIOKey(BeginInternalArrayFormattedOutput),
64 mkIOKey(BeginInternalArrayListInput), mkIOKey(BeginInternalArrayListOutput),
65 mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginInternalFormattedOutput),
66 mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalListOutput),
67 mkIOKey(BeginOpenNewUnit), mkIOKey(BeginOpenUnit), mkIOKey(BeginRewind),
68 mkIOKey(BeginUnformattedInput), mkIOKey(BeginUnformattedOutput),
69 mkIOKey(BeginWait), mkIOKey(BeginWaitAll),
70 mkIOKey(CheckUnitNumberInRange64), mkIOKey(CheckUnitNumberInRange128),
71 mkIOKey(EnableHandlers), mkIOKey(EndIoStatement),
72 mkIOKey(GetAsynchronousId), mkIOKey(GetIoLength), mkIOKey(GetIoMsg),
73 mkIOKey(GetNewUnit), mkIOKey(GetSize), mkIOKey(InputAscii),
74 mkIOKey(InputComplex32), mkIOKey(InputComplex64), mkIOKey(InputDerivedType),
75 mkIOKey(InputDescriptor), mkIOKey(InputInteger), mkIOKey(InputLogical),
76 mkIOKey(InputNamelist), mkIOKey(InputReal32), mkIOKey(InputReal64),
77 mkIOKey(InquireCharacter), mkIOKey(InquireInteger64),
78 mkIOKey(InquireLogical), mkIOKey(InquirePendingId), mkIOKey(OutputAscii),
79 mkIOKey(OutputComplex32), mkIOKey(OutputComplex64),
80 mkIOKey(OutputDerivedType), mkIOKey(OutputDescriptor),
81 mkIOKey(OutputInteger8), mkIOKey(OutputInteger16), mkIOKey(OutputInteger32),
82 mkIOKey(OutputInteger64), mkIOKey(OutputInteger128), mkIOKey(OutputLogical),
83 mkIOKey(OutputNamelist), mkIOKey(OutputReal32), mkIOKey(OutputReal64),
84 mkIOKey(SetAccess), mkIOKey(SetAction), mkIOKey(SetAdvance),
85 mkIOKey(SetAsynchronous), mkIOKey(SetBlank), mkIOKey(SetCarriagecontrol),
86 mkIOKey(SetConvert), mkIOKey(SetDecimal), mkIOKey(SetDelim),
87 mkIOKey(SetEncoding), mkIOKey(SetFile), mkIOKey(SetForm), mkIOKey(SetPad),
88 mkIOKey(SetPos), mkIOKey(SetPosition), mkIOKey(SetRec), mkIOKey(SetRecl),
89 mkIOKey(SetRound), mkIOKey(SetSign), mkIOKey(SetStatus)>
90 newIOTable;
91} // namespace Fortran::lower
92
93namespace {
94/// IO statements may require exceptional condition handling. A statement that
95/// encounters an exceptional condition may branch to a label given on an ERR
96/// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT
97/// specifier variable may be set to a value that indicates some condition,
98/// and an IOMSG specifier variable may be set to a description of a condition.
99struct ConditionSpecInfo {
100 const Fortran::lower::SomeExpr *ioStatExpr{};
101 std::optional<fir::ExtendedValue> ioMsg;
102 bool hasErr{};
103 bool hasEnd{};
104 bool hasEor{};
105 fir::IfOp bigUnitIfOp;
106
107 /// Check for any condition specifier that applies to specifier processing.
108 bool hasErrorConditionSpec() const { return ioStatExpr != nullptr || hasErr; }
109
110 /// Check for any condition specifier that applies to data transfer items
111 /// in a PRINT, READ, WRITE, or WAIT statement. (WAIT may be irrelevant.)
112 bool hasTransferConditionSpec() const {
113 return hasErrorConditionSpec() || hasEnd || hasEor;
114 }
115
116 /// Check for any condition specifier, including IOMSG.
117 bool hasAnyConditionSpec() const {
118 return hasTransferConditionSpec() || ioMsg;
119 }
120};
121} // namespace
122
123template <typename D>
124static void genIoLoop(Fortran::lower::AbstractConverter &converter,
125 mlir::Value cookie, const D &ioImpliedDo,
126 bool isFormatted, bool checkResult, mlir::Value &ok,
127 bool inLoop);
128
129/// Helper function to retrieve the name of the IO function given the key `A`
130template <typename A>
131static constexpr const char *getName() {
132 return std::get<A>(Fortran::lower::newIOTable).name;
133}
134
135/// Helper function to retrieve the type model signature builder of the IO
136/// function as defined by the key `A`
137template <typename A>
138static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
139 return std::get<A>(Fortran::lower::newIOTable).getTypeModel();
140}
141
142inline int64_t getLength(mlir::Type argTy) {
143 return mlir::cast<fir::SequenceType>(argTy).getShape()[0];
144}
145
146/// Generate calls to end an IO statement. Return the IOSTAT value, if any.
147/// It is the caller's responsibility to generate branches on that value.
148static mlir::Value genEndIO(Fortran::lower::AbstractConverter &converter,
149 mlir::Location loc, mlir::Value cookie,
150 ConditionSpecInfo &csi,
151 Fortran::lower::StatementContext &stmtCtx) {
152 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
153 if (csi.ioMsg) {
154 mlir::func::FuncOp getIoMsg =
155 fir::runtime::getIORuntimeFunc<mkIOKey(GetIoMsg)>(loc, builder);
156 builder.create<fir::CallOp>(
157 loc, getIoMsg,
158 mlir::ValueRange{
159 cookie,
160 builder.createConvert(loc, getIoMsg.getFunctionType().getInput(1),
161 fir::getBase(*csi.ioMsg)),
162 builder.createConvert(loc, getIoMsg.getFunctionType().getInput(2),
163 fir::getLen(*csi.ioMsg))});
164 }
165 mlir::func::FuncOp endIoStatement =
166 fir::runtime::getIORuntimeFunc<mkIOKey(EndIoStatement)>(loc, builder);
167 auto call = builder.create<fir::CallOp>(loc, endIoStatement,
168 mlir::ValueRange{cookie});
169 mlir::Value iostat = call.getResult(0);
170 if (csi.bigUnitIfOp) {
171 stmtCtx.finalizeAndPop();
172 builder.create<fir::ResultOp>(loc, iostat);
173 builder.setInsertionPointAfter(csi.bigUnitIfOp);
174 iostat = csi.bigUnitIfOp.getResult(0);
175 }
176 if (csi.ioStatExpr) {
177 mlir::Value ioStatVar =
178 fir::getBase(converter.genExprAddr(loc, csi.ioStatExpr, stmtCtx));
179 mlir::Value ioStatResult =
180 builder.createConvert(loc, converter.genType(*csi.ioStatExpr), iostat);
181 builder.create<fir::StoreOp>(loc, ioStatResult, ioStatVar);
182 }
183 return csi.hasTransferConditionSpec() ? iostat : mlir::Value{};
184}
185
186/// Make the next call in the IO statement conditional on runtime result `ok`.
187/// If a call returns `ok==false`, further suboperation calls for an IO
188/// statement will be skipped. This may generate branch heavy, deeply nested
189/// conditionals for IO statements with a large number of suboperations.
190static void makeNextConditionalOn(fir::FirOpBuilder &builder,
191 mlir::Location loc, bool checkResult,
192 mlir::Value ok, bool inLoop = false) {
193 if (!checkResult || !ok)
194 // Either no IO calls need to be checked, or this will be the first call.
195 return;
196
197 // A previous IO call for a statement returned the bool `ok`. If this call
198 // is in a fir.iterate_while loop, the result must be propagated up to the
199 // loop scope as an extra ifOp result. (The propagation is done in genIoLoop.)
200 mlir::TypeRange resTy;
201 // TypeRange does not own its contents, so make sure the the type object
202 // is live until the end of the function.
203 mlir::IntegerType boolTy = builder.getI1Type();
204 if (inLoop)
205 resTy = boolTy;
206 auto ifOp = builder.create<fir::IfOp>(loc, resTy, ok,
207 /*withElseRegion=*/inLoop);
208 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
209}
210
211// Derived type symbols may each be mapped to up to 4 defined IO procedures.
212using DefinedIoProcMap = std::multimap<const Fortran::semantics::Symbol *,
213 Fortran::semantics::NonTbpDefinedIo>;
214
215/// Get the current scope's non-type-bound defined IO procedures.
216static DefinedIoProcMap
217getDefinedIoProcMap(Fortran::lower::AbstractConverter &converter) {
218 const Fortran::semantics::Scope *scope = &converter.getCurrentScope();
219 for (; !scope->IsGlobal(); scope = &scope->parent())
220 if (scope->kind() == Fortran::semantics::Scope::Kind::MainProgram ||
221 scope->kind() == Fortran::semantics::Scope::Kind::Subprogram ||
222 scope->kind() == Fortran::semantics::Scope::Kind::BlockConstruct)
223 break;
224 return Fortran::semantics::CollectNonTbpDefinedIoGenericInterfaces(*scope,
225 false);
226}
227
228/// Check a set of defined IO procedures for any procedure pointer or dummy
229/// procedures.
230static bool hasLocalDefinedIoProc(DefinedIoProcMap &definedIoProcMap) {
231 for (auto &iface : definedIoProcMap) {
232 const Fortran::semantics::Symbol *procSym = iface.second.subroutine;
233 if (!procSym)
234 continue;
235 procSym = &procSym->GetUltimate();
236 if (Fortran::semantics::IsProcedurePointer(*procSym) ||
237 Fortran::semantics::IsDummy(*procSym))
238 return true;
239 }
240 return false;
241}
242
243/// Retrieve or generate a runtime description of the non-type-bound defined
244/// IO procedures in the current scope. If any procedure is a dummy or a
245/// procedure pointer, the result is local. Otherwise the result is static.
246/// If there are no procedures, return a scope-independent default table with
247/// an empty procedure list, but with the `ignoreNonTbpEntries` flag set. The
248/// form of the description is defined in runtime header file non-tbp-dio.h.
249static mlir::Value
250getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter,
251 DefinedIoProcMap &definedIoProcMap) {
252 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
253 mlir::MLIRContext *context = builder.getContext();
254 mlir::Location loc = converter.getCurrentLocation();
255 mlir::Type refTy = fir::ReferenceType::get(mlir::NoneType::get(context));
256 std::string suffix = ".nonTbpDefinedIoTable";
257 std::string tableMangleName =
258 definedIoProcMap.empty()
259 ? fir::NameUniquer::doGenerated("default" + suffix)
260 : converter.mangleName(suffix);
261 if (auto table = builder.getNamedGlobal(tableMangleName))
262 return builder.createConvert(
263 loc, refTy,
264 builder.create<fir::AddrOfOp>(loc, table.resultType(),
265 table.getSymbol()));
266
267 mlir::StringAttr linkOnce = builder.createLinkOnceLinkage();
268 mlir::Type idxTy = builder.getIndexType();
269 mlir::Type sizeTy =
270 fir::runtime::getModel<std::size_t>()(builder.getContext());
271 mlir::Type intTy = fir::runtime::getModel<int>()(builder.getContext());
272 mlir::Type boolTy = fir::runtime::getModel<bool>()(builder.getContext());
273 mlir::Type listTy = fir::SequenceType::get(
274 definedIoProcMap.size(),
275 mlir::TupleType::get(context, {refTy, refTy, intTy, boolTy}));
276 mlir::Type tableTy = mlir::TupleType::get(
277 context, {sizeTy, fir::ReferenceType::get(listTy), boolTy});
278
279 // Define the list of NonTbpDefinedIo procedures.
280 bool tableIsLocal =
281 !definedIoProcMap.empty() && hasLocalDefinedIoProc(definedIoProcMap);
282 mlir::Value listAddr =
283 tableIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{};
284 std::string listMangleName = tableMangleName + ".list";
285 auto listFunc = [&](fir::FirOpBuilder &builder) {
286 mlir::Value list = builder.create<fir::UndefOp>(loc, listTy);
287 mlir::IntegerAttr intAttr[4];
288 for (int i = 0; i < 4; ++i)
289 intAttr[i] = builder.getIntegerAttr(idxTy, i);
290 llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{},
291 mlir::Attribute{}};
292 int n0 = 0, n1;
293 auto insert = [&](mlir::Value val) {
294 idx[1] = intAttr[n1++];
295 list = builder.create<fir::InsertValueOp>(loc, listTy, list, val,
296 builder.getArrayAttr(idx));
297 };
298 for (auto &iface : definedIoProcMap) {
299 idx[0] = builder.getIntegerAttr(idxTy, n0++);
300 n1 = 0;
301 // derived type description [const typeInfo::DerivedType &derivedType]
302 const Fortran::semantics::Symbol &dtSym = iface.first->GetUltimate();
303 std::string dtName = converter.mangleName(dtSym);
304 insert(builder.createConvert(
305 loc, refTy,
306 builder.create<fir::AddrOfOp>(
307 loc, fir::ReferenceType::get(converter.genType(dtSym)),
308 builder.getSymbolRefAttr(dtName))));
309 // defined IO procedure [void (*subroutine)()], may be null
310 const Fortran::semantics::Symbol *procSym = iface.second.subroutine;
311 if (procSym) {
312 procSym = &procSym->GetUltimate();
313 if (Fortran::semantics::IsProcedurePointer(*procSym)) {
314 TODO(loc, "defined IO procedure pointers");
315 } else if (Fortran::semantics::IsDummy(*procSym)) {
316 Fortran::lower::StatementContext stmtCtx;
317 insert(builder.create<fir::BoxAddrOp>(
318 loc, refTy,
319 fir::getBase(converter.genExprAddr(
320 loc,
321 Fortran::lower::SomeExpr{
322 Fortran::evaluate::ProcedureDesignator{*procSym}},
323 stmtCtx))));
324 } else {
325 mlir::func::FuncOp procDef = Fortran::lower::getOrDeclareFunction(
326 Fortran::evaluate::ProcedureDesignator{*procSym}, converter);
327 mlir::SymbolRefAttr nameAttr =
328 builder.getSymbolRefAttr(procDef.getSymName());
329 insert(builder.createConvert(
330 loc, refTy,
331 builder.create<fir::AddrOfOp>(loc, procDef.getFunctionType(),
332 nameAttr)));
333 }
334 } else {
335 insert(builder.createNullConstant(loc, refTy));
336 }
337 // defined IO variant, one of (read/write, formatted/unformatted)
338 // [common::DefinedIo definedIo]
339 insert(builder.createIntegerConstant(
340 loc, intTy, static_cast<int>(iface.second.definedIo)));
341 // polymorphic flag is set if first defined IO dummy arg is CLASS(T)
342 // [bool isDtvArgPolymorphic]
343 insert(builder.createIntegerConstant(loc, boolTy,
344 iface.second.isDtvArgPolymorphic));
345 }
346 if (tableIsLocal)
347 builder.create<fir::StoreOp>(loc, list, listAddr);
348 else
349 builder.create<fir::HasValueOp>(loc, list);
350 };
351 if (!definedIoProcMap.empty()) {
352 if (tableIsLocal)
353 listFunc(builder);
354 else
355 builder.createGlobalConstant(loc, listTy, listMangleName, listFunc,
356 linkOnce);
357 }
358
359 // Define the NonTbpDefinedIoTable.
360 mlir::Value tableAddr = tableIsLocal
361 ? builder.create<fir::AllocaOp>(loc, tableTy)
362 : mlir::Value{};
363 auto tableFunc = [&](fir::FirOpBuilder &builder) {
364 mlir::Value table = builder.create<fir::UndefOp>(loc, tableTy);
365 // list item count [std::size_t items]
366 table = builder.create<fir::InsertValueOp>(
367 loc, tableTy, table,
368 builder.createIntegerConstant(loc, sizeTy, definedIoProcMap.size()),
369 builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0)));
370 // item list [const NonTbpDefinedIo *item]
371 if (definedIoProcMap.empty())
372 listAddr = builder.createNullConstant(loc, builder.getRefType(listTy));
373 else if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName))
374 listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(),
375 list.getSymbol());
376 assert(listAddr && "missing namelist object list");
377 table = builder.create<fir::InsertValueOp>(
378 loc, tableTy, table, listAddr,
379 builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1)));
380 // [bool ignoreNonTbpEntries] conservatively set to true
381 table = builder.create<fir::InsertValueOp>(
382 loc, tableTy, table, builder.createIntegerConstant(loc, boolTy, true),
383 builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2)));
384 if (tableIsLocal)
385 builder.create<fir::StoreOp>(loc, table, tableAddr);
386 else
387 builder.create<fir::HasValueOp>(loc, table);
388 };
389 if (tableIsLocal) {
390 tableFunc(builder);
391 } else {
392 fir::GlobalOp table = builder.createGlobal(
393 loc, tableTy, tableMangleName,
394 /*isConst=*/true, /*isTarget=*/false, tableFunc, linkOnce);
395 tableAddr = builder.create<fir::AddrOfOp>(
396 loc, fir::ReferenceType::get(tableTy), table.getSymbol());
397 }
398 assert(tableAddr && "missing NonTbpDefinedIo table result");
399 return builder.createConvert(loc, refTy, tableAddr);
400}
401
402static mlir::Value
403getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter) {
404 DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter);
405 return getNonTbpDefinedIoTableAddr(converter, definedIoProcMap);
406}
407
408/// Retrieve or generate a runtime description of NAMELIST group \p symbol.
409/// The form of the description is defined in runtime header file namelist.h.
410/// Static descriptors are generated for global objects; local descriptors for
411/// local objects. If all descriptors and defined IO procedures are static,
412/// the NamelistGroup is static.
413static mlir::Value
414getNamelistGroup(Fortran::lower::AbstractConverter &converter,
415 const Fortran::semantics::Symbol &symbol,
416 Fortran::lower::StatementContext &stmtCtx) {
417 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
418 mlir::Location loc = converter.getCurrentLocation();
419 std::string groupMangleName = converter.mangleName(symbol);
420 if (auto group = builder.getNamedGlobal(groupMangleName))
421 return builder.create<fir::AddrOfOp>(loc, group.resultType(),
422 group.getSymbol());
423
424 const auto &details =
425 symbol.GetUltimate().get<Fortran::semantics::NamelistDetails>();
426 mlir::MLIRContext *context = builder.getContext();
427 mlir::StringAttr linkOnce = builder.createLinkOnceLinkage();
428 mlir::Type idxTy = builder.getIndexType();
429 mlir::Type sizeTy =
430 fir::runtime::getModel<std::size_t>()(builder.getContext());
431 mlir::Type charRefTy = fir::ReferenceType::get(builder.getIntegerType(8));
432 mlir::Type descRefTy =
433 fir::ReferenceType::get(fir::BoxType::get(mlir::NoneType::get(context)));
434 mlir::Type listTy = fir::SequenceType::get(
435 details.objects().size(),
436 mlir::TupleType::get(context, {charRefTy, descRefTy}));
437 mlir::Type groupTy = mlir::TupleType::get(
438 context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy),
439 fir::ReferenceType::get(mlir::NoneType::get(context))});
440 auto stringAddress = [&](const Fortran::semantics::Symbol &symbol) {
441 return fir::factory::createStringLiteral(builder, loc,
442 symbol.name().ToString() + '\0');
443 };
444
445 // Define variable names, and static descriptors for global variables.
446 DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter);
447 bool groupIsLocal = hasLocalDefinedIoProc(definedIoProcMap);
448 stringAddress(symbol);
449 for (const Fortran::semantics::Symbol &s : details.objects()) {
450 stringAddress(s);
451 if (!Fortran::lower::symbolIsGlobal(s)) {
452 groupIsLocal = true;
453 continue;
454 }
455 // A global pointer or allocatable variable has a descriptor for typical
456 // accesses. Variables in multiple namelist groups may already have one.
457 // Create descriptors for other cases.
458 if (!IsAllocatableOrObjectPointer(&s)) {
459 std::string mangleName =
460 Fortran::lower::mangle::globalNamelistDescriptorName(s);
461 if (builder.getNamedGlobal(mangleName))
462 continue;
463 const auto expr = Fortran::evaluate::AsGenericExpr(s);
464 fir::BoxType boxTy =
465 fir::BoxType::get(fir::PointerType::get(converter.genType(s)));
466 auto descFunc = [&](fir::FirOpBuilder &b) {
467 bool couldBeInEquivalence =
468 Fortran::semantics::FindEquivalenceSet(s) != nullptr;
469 auto box = Fortran::lower::genInitialDataTarget(
470 converter, loc, boxTy, *expr, couldBeInEquivalence);
471 b.create<fir::HasValueOp>(loc, box);
472 };
473 builder.createGlobalConstant(loc, boxTy, mangleName, descFunc, linkOnce);
474 }
475 }
476
477 // Define the list of Items.
478 mlir::Value listAddr =
479 groupIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{};
480 std::string listMangleName = groupMangleName + ".list";
481 auto listFunc = [&](fir::FirOpBuilder &builder) {
482 mlir::Value list = builder.create<fir::UndefOp>(loc, listTy);
483 mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0);
484 mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1);
485 llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{},
486 mlir::Attribute{}};
487 int n = 0;
488 for (const Fortran::semantics::Symbol &s : details.objects()) {
489 idx[0] = builder.getIntegerAttr(idxTy, n++);
490 idx[1] = zero;
491 mlir::Value nameAddr =
492 builder.createConvert(loc, charRefTy, fir::getBase(stringAddress(s)));
493 list = builder.create<fir::InsertValueOp>(loc, listTy, list, nameAddr,
494 builder.getArrayAttr(idx));
495 idx[1] = one;
496 mlir::Value descAddr;
497 if (auto desc = builder.getNamedGlobal(
498 Fortran::lower::mangle::globalNamelistDescriptorName(s))) {
499 descAddr = builder.create<fir::AddrOfOp>(loc, desc.resultType(),
500 desc.getSymbol());
501 } else if (Fortran::semantics::FindCommonBlockContaining(s) &&
502 IsAllocatableOrPointer(s)) {
503 mlir::Type symType = converter.genType(s);
504 const Fortran::semantics::Symbol *commonBlockSym =
505 Fortran::semantics::FindCommonBlockContaining(s);
506 std::string commonBlockName = converter.mangleName(*commonBlockSym);
507 fir::GlobalOp commonGlobal = builder.getNamedGlobal(commonBlockName);
508 mlir::Value commonBlockAddr = builder.create<fir::AddrOfOp>(
509 loc, commonGlobal.resultType(), commonGlobal.getSymbol());
510 mlir::IntegerType i8Ty = builder.getIntegerType(8);
511 mlir::Type i8Ptr = builder.getRefType(i8Ty);
512 mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(i8Ty));
513 mlir::Value base = builder.createConvert(loc, seqTy, commonBlockAddr);
514 std::size_t byteOffset = s.GetUltimate().offset();
515 mlir::Value offs = builder.createIntegerConstant(
516 loc, builder.getIndexType(), byteOffset);
517 mlir::Value varAddr = builder.create<fir::CoordinateOp>(
518 loc, i8Ptr, base, mlir::ValueRange{offs});
519 descAddr =
520 builder.createConvert(loc, builder.getRefType(symType), varAddr);
521 } else {
522 const auto expr = Fortran::evaluate::AsGenericExpr(s);
523 fir::ExtendedValue exv = converter.genExprAddr(*expr, stmtCtx);
524 mlir::Type type = fir::getBase(exv).getType();
525 if (mlir::Type baseTy = fir::dyn_cast_ptrOrBoxEleTy(type))
526 type = baseTy;
527 fir::BoxType boxType = fir::BoxType::get(fir::PointerType::get(type));
528 descAddr = builder.createTemporary(loc, boxType);
529 fir::MutableBoxValue box = fir::MutableBoxValue(descAddr, {}, {});
530 fir::factory::associateMutableBox(builder, loc, box, exv,
531 /*lbounds=*/std::nullopt);
532 }
533 descAddr = builder.createConvert(loc, descRefTy, descAddr);
534 list = builder.create<fir::InsertValueOp>(loc, listTy, list, descAddr,
535 builder.getArrayAttr(idx));
536 }
537 if (groupIsLocal)
538 builder.create<fir::StoreOp>(loc, list, listAddr);
539 else
540 builder.create<fir::HasValueOp>(loc, list);
541 };
542 if (groupIsLocal)
543 listFunc(builder);
544 else
545 builder.createGlobalConstant(loc, listTy, listMangleName, listFunc,
546 linkOnce);
547
548 // Define the group.
549 mlir::Value groupAddr = groupIsLocal
550 ? builder.create<fir::AllocaOp>(loc, groupTy)
551 : mlir::Value{};
552 auto groupFunc = [&](fir::FirOpBuilder &builder) {
553 mlir::Value group = builder.create<fir::UndefOp>(loc, groupTy);
554 // group name [const char *groupName]
555 group = builder.create<fir::InsertValueOp>(
556 loc, groupTy, group,
557 builder.createConvert(loc, charRefTy,
558 fir::getBase(stringAddress(symbol))),
559 builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0)));
560 // list item count [std::size_t items]
561 group = builder.create<fir::InsertValueOp>(
562 loc, groupTy, group,
563 builder.createIntegerConstant(loc, sizeTy, details.objects().size()),
564 builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1)));
565 // item list [const Item *item]
566 if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName))
567 listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(),
568 list.getSymbol());
569 assert(listAddr && "missing namelist object list");
570 group = builder.create<fir::InsertValueOp>(
571 loc, groupTy, group, listAddr,
572 builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2)));
573 // non-type-bound defined IO procedures
574 // [const NonTbpDefinedIoTable *nonTbpDefinedIo]
575 group = builder.create<fir::InsertValueOp>(
576 loc, groupTy, group,
577 getNonTbpDefinedIoTableAddr(converter, definedIoProcMap),
578 builder.getArrayAttr(builder.getIntegerAttr(idxTy, 3)));
579 if (groupIsLocal)
580 builder.create<fir::StoreOp>(loc, group, groupAddr);
581 else
582 builder.create<fir::HasValueOp>(loc, group);
583 };
584 if (groupIsLocal) {
585 groupFunc(builder);
586 } else {
587 fir::GlobalOp group = builder.createGlobal(
588 loc, groupTy, groupMangleName,
589 /*isConst=*/true, /*isTarget=*/false, groupFunc, linkOnce);
590 groupAddr = builder.create<fir::AddrOfOp>(loc, group.resultType(),
591 group.getSymbol());
592 }
593 assert(groupAddr && "missing namelist group result");
594 return groupAddr;
595}
596
597/// Generate a namelist IO call.
598static void genNamelistIO(Fortran::lower::AbstractConverter &converter,
599 mlir::Value cookie, mlir::func::FuncOp funcOp,
600 Fortran::semantics::Symbol &symbol, bool checkResult,
601 mlir::Value &ok,
602 Fortran::lower::StatementContext &stmtCtx) {
603 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
604 mlir::Location loc = converter.getCurrentLocation();
605 makeNextConditionalOn(builder, loc, checkResult, ok);
606 mlir::Type argType = funcOp.getFunctionType().getInput(1);
607 mlir::Value groupAddr =
608 getNamelistGroup(converter, symbol.GetUltimate(), stmtCtx);
609 groupAddr = builder.createConvert(loc, argType, groupAddr);
610 llvm::SmallVector<mlir::Value> args = {cookie, groupAddr};
611 ok = builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
612}
613
614/// Is \p type a derived type or an array of derived type?
615static bool containsDerivedType(mlir::Type type) {
616 mlir::Type argTy = fir::unwrapPassByRefType(fir::unwrapRefType(type));
617 if (mlir::isa<fir::RecordType>(argTy))
618 return true;
619 if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(argTy))
620 if (mlir::isa<fir::RecordType>(seqTy.getEleTy()))
621 return true;
622 return false;
623}
624
625/// Get the output function to call for a value of the given type.
626static mlir::func::FuncOp getOutputFunc(mlir::Location loc,
627 fir::FirOpBuilder &builder,
628 mlir::Type type, bool isFormatted) {
629 if (containsDerivedType(type))
630 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputDerivedType)>(loc,
631 builder);
632 if (!isFormatted)
633 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc,
634 builder);
635 if (auto ty = mlir::dyn_cast<mlir::IntegerType>(type)) {
636 if (!ty.isUnsigned()) {
637 switch (ty.getWidth()) {
638 case 1:
639 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputLogical)>(loc,
640 builder);
641 case 8:
642 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputInteger8)>(loc,
643 builder);
644 case 16:
645 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputInteger16)>(
646 loc, builder);
647 case 32:
648 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputInteger32)>(
649 loc, builder);
650 case 64:
651 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputInteger64)>(
652 loc, builder);
653 case 128:
654 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputInteger128)>(
655 loc, builder);
656 }
657 llvm_unreachable("unknown OutputInteger kind");
658 }
659 }
660 if (auto ty = mlir::dyn_cast<mlir::FloatType>(type)) {
661 if (auto width = ty.getWidth(); width == 32)
662 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputReal32)>(loc,
663 builder);
664 else if (width == 64)
665 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputReal64)>(loc,
666 builder);
667 }
668 auto kindMap = fir::getKindMapping(builder.getModule());
669 if (auto ty = mlir::dyn_cast<mlir::ComplexType>(type)) {
670 // COMPLEX(KIND=k) corresponds to a pair of REAL(KIND=k).
671 auto width = mlir::cast<mlir::FloatType>(ty.getElementType()).getWidth();
672 if (width == 32)
673 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputComplex32)>(loc,
674 builder);
675 else if (width == 64)
676 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputComplex64)>(loc,
677 builder);
678 }
679 if (mlir::isa<fir::LogicalType>(type))
680 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder);
681 if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) {
682 // TODO: What would it mean if the default CHARACTER KIND is set to a wide
683 // character encoding scheme? How do we handle UTF-8? Is it a distinct KIND
684 // value? For now, assume that if the default CHARACTER KIND is 8 bit,
685 // then it is an ASCII string and UTF-8 is unsupported.
686 auto asciiKind = kindMap.defaultCharacterKind();
687 if (kindMap.getCharacterBitsize(asciiKind) == 8 &&
688 fir::factory::CharacterExprHelper::getCharacterKind(type) == asciiKind)
689 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputAscii)>(loc, builder);
690 }
691 return fir::runtime::getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc,
692 builder);
693}
694
695/// Generate a sequence of output data transfer calls.
696static void genOutputItemList(
697 Fortran::lower::AbstractConverter &converter, mlir::Value cookie,
698 const std::list<Fortran::parser::OutputItem> &items, bool isFormatted,
699 bool checkResult, mlir::Value &ok, bool inLoop) {
700 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
701 for (const Fortran::parser::OutputItem &item : items) {
702 if (const auto &impliedDo = std::get_if<1>(&item.u)) {
703 genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult,
704 ok, inLoop);
705 continue;
706 }
707 auto &pExpr = std::get<Fortran::parser::Expr>(item.u);
708 mlir::Location loc = converter.genLocation(pExpr.source);
709 makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
710 Fortran::lower::StatementContext stmtCtx;
711
712 const auto *expr = Fortran::semantics::GetExpr(pExpr);
713 if (!expr)
714 fir::emitFatalError(loc, "internal error: could not get evaluate::Expr");
715 mlir::Type itemTy = converter.genType(*expr);
716 mlir::func::FuncOp outputFunc =
717 getOutputFunc(loc, builder, itemTy, isFormatted);
718 mlir::Type argType = outputFunc.getFunctionType().getInput(1);
719 assert((isFormatted || mlir::isa<fir::BoxType>(argType)) &&
720 "expect descriptor for unformatted IO runtime");
721 llvm::SmallVector<mlir::Value> outputFuncArgs = {cookie};
722 fir::factory::CharacterExprHelper helper{builder, loc};
723 if (mlir::isa<fir::BoxType>(argType)) {
724 mlir::Value box = fir::getBase(converter.genExprBox(loc, *expr, stmtCtx));
725 outputFuncArgs.push_back(
726 builder.createConvertWithVolatileCast(loc, argType, box));
727 if (containsDerivedType(itemTy))
728 outputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter));
729 } else if (helper.isCharacterScalar(itemTy)) {
730 fir::ExtendedValue exv = converter.genExprAddr(loc, expr, stmtCtx);
731 // scalar allocatable/pointer may also get here, not clear if
732 // genExprAddr will lower them as CharBoxValue or BoxValue.
733 if (!exv.getCharBox())
734 llvm::report_fatal_error(
735 "internal error: scalar character not in CharBox");
736 outputFuncArgs.push_back(builder.createConvertWithVolatileCast(
737 loc, outputFunc.getFunctionType().getInput(1), fir::getBase(exv)));
738 outputFuncArgs.push_back(builder.createConvertWithVolatileCast(
739 loc, outputFunc.getFunctionType().getInput(2), fir::getLen(exv)));
740 } else {
741 fir::ExtendedValue itemBox = converter.genExprValue(loc, expr, stmtCtx);
742 mlir::Value itemValue = fir::getBase(itemBox);
743 if (fir::isa_complex(itemTy)) {
744 auto parts =
745 fir::factory::Complex{builder, loc}.extractParts(itemValue);
746 outputFuncArgs.push_back(parts.first);
747 outputFuncArgs.push_back(parts.second);
748 } else {
749 itemValue =
750 builder.createConvertWithVolatileCast(loc, argType, itemValue);
751 outputFuncArgs.push_back(itemValue);
752 }
753 }
754 ok = builder.create<fir::CallOp>(loc, outputFunc, outputFuncArgs)
755 .getResult(0);
756 }
757}
758
759/// Get the input function to call for a value of the given type.
760static mlir::func::FuncOp getInputFunc(mlir::Location loc,
761 fir::FirOpBuilder &builder,
762 mlir::Type type, bool isFormatted) {
763 if (containsDerivedType(type))
764 return fir::runtime::getIORuntimeFunc<mkIOKey(InputDerivedType)>(loc,
765 builder);
766 if (!isFormatted)
767 return fir::runtime::getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc,
768 builder);
769 if (auto ty = mlir::dyn_cast<mlir::IntegerType>(type)) {
770 if (type.isUnsignedInteger())
771 return fir::runtime::getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc,
772 builder);
773 return ty.getWidth() == 1
774 ? fir::runtime::getIORuntimeFunc<mkIOKey(InputLogical)>(loc,
775 builder)
776 : fir::runtime::getIORuntimeFunc<mkIOKey(InputInteger)>(loc,
777 builder);
778 }
779 if (auto ty = mlir::dyn_cast<mlir::FloatType>(type)) {
780 if (auto width = ty.getWidth(); width == 32)
781 return fir::runtime::getIORuntimeFunc<mkIOKey(InputReal32)>(loc, builder);
782 else if (width == 64)
783 return fir::runtime::getIORuntimeFunc<mkIOKey(InputReal64)>(loc, builder);
784 }
785 auto kindMap = fir::getKindMapping(builder.getModule());
786 if (auto ty = mlir::dyn_cast<mlir::ComplexType>(type)) {
787 auto width = mlir::cast<mlir::FloatType>(ty.getElementType()).getWidth();
788 if (width == 32)
789 return fir::runtime::getIORuntimeFunc<mkIOKey(InputComplex32)>(loc,
790 builder);
791 else if (width == 64)
792 return fir::runtime::getIORuntimeFunc<mkIOKey(InputComplex64)>(loc,
793 builder);
794 }
795 if (mlir::isa<fir::LogicalType>(type))
796 return fir::runtime::getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder);
797 if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) {
798 auto asciiKind = kindMap.defaultCharacterKind();
799 if (kindMap.getCharacterBitsize(asciiKind) == 8 &&
800 fir::factory::CharacterExprHelper::getCharacterKind(type) == asciiKind)
801 return fir::runtime::getIORuntimeFunc<mkIOKey(InputAscii)>(loc, builder);
802 }
803 return fir::runtime::getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder);
804}
805
806/// Interpret the lowest byte of a LOGICAL and store that value into the full
807/// storage of the LOGICAL. The load, convert, and store effectively (sign or
808/// zero) extends the lowest byte into the full LOGICAL value storage, as the
809/// runtime is unaware of the LOGICAL value's actual bit width (it was passed
810/// as a `bool&` to the runtime in order to be set).
811static void boolRefToLogical(mlir::Location loc, fir::FirOpBuilder &builder,
812 mlir::Value addr) {
813 auto boolType = builder.getRefType(builder.getI1Type());
814 auto boolAddr = builder.createConvert(loc, boolType, addr);
815 auto boolValue = builder.create<fir::LoadOp>(loc, boolAddr);
816 auto logicalType = fir::unwrapPassByRefType(addr.getType());
817 // The convert avoid making any assumptions about how LOGICALs are actually
818 // represented (it might end-up being either a signed or zero extension).
819 auto logicalValue = builder.createConvert(loc, logicalType, boolValue);
820 builder.create<fir::StoreOp>(loc, logicalValue, addr);
821}
822
823static mlir::Value
824createIoRuntimeCallForItem(Fortran::lower::AbstractConverter &converter,
825 mlir::Location loc, mlir::func::FuncOp inputFunc,
826 mlir::Value cookie, const fir::ExtendedValue &item) {
827 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
828 mlir::Type argType = inputFunc.getFunctionType().getInput(1);
829 llvm::SmallVector<mlir::Value> inputFuncArgs = {cookie};
830 if (mlir::isa<fir::BaseBoxType>(argType)) {
831 mlir::Value box = fir::getBase(item);
832 auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(box.getType());
833 assert(boxTy && "must be previously emboxed");
834 auto casted = builder.createConvertWithVolatileCast(loc, argType, box);
835 inputFuncArgs.push_back(casted);
836 if (containsDerivedType(boxTy))
837 inputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter));
838 } else {
839 mlir::Value itemAddr = fir::getBase(item);
840 mlir::Type itemTy = fir::unwrapPassByRefType(itemAddr.getType());
841
842 // Handle conversion between volatile and non-volatile reference types
843 // Need to explicitly cast when volatility qualification differs
844 inputFuncArgs.push_back(
845 builder.createConvertWithVolatileCast(loc, argType, itemAddr));
846 fir::factory::CharacterExprHelper charHelper{builder, loc};
847 if (charHelper.isCharacterScalar(itemTy)) {
848 mlir::Value len = fir::getLen(item);
849 inputFuncArgs.push_back(builder.createConvert(
850 loc, inputFunc.getFunctionType().getInput(2), len));
851 } else if (mlir::isa<mlir::IntegerType>(itemTy)) {
852 inputFuncArgs.push_back(builder.create<mlir::arith::ConstantOp>(
853 loc, builder.getI32IntegerAttr(
854 mlir::cast<mlir::IntegerType>(itemTy).getWidth() / 8)));
855 }
856 }
857 auto call = builder.create<fir::CallOp>(loc, inputFunc, inputFuncArgs);
858 auto itemAddr = fir::getBase(item);
859 auto itemTy = fir::unwrapRefType(itemAddr.getType());
860 if (mlir::isa<fir::LogicalType>(itemTy))
861 boolRefToLogical(loc, builder, itemAddr);
862 return call.getResult(0);
863}
864
865/// Generate a sequence of input data transfer calls.
866static void genInputItemList(Fortran::lower::AbstractConverter &converter,
867 mlir::Value cookie,
868 const std::list<Fortran::parser::InputItem> &items,
869 bool isFormatted, bool checkResult,
870 mlir::Value &ok, bool inLoop) {
871 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
872 for (const Fortran::parser::InputItem &item : items) {
873 if (const auto &impliedDo = std::get_if<1>(&item.u)) {
874 genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult,
875 ok, inLoop);
876 continue;
877 }
878 auto &pVar = std::get<Fortran::parser::Variable>(item.u);
879 mlir::Location loc = converter.genLocation(pVar.GetSource());
880 makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
881 Fortran::lower::StatementContext stmtCtx;
882 const auto *expr = Fortran::semantics::GetExpr(pVar);
883 if (!expr)
884 fir::emitFatalError(loc, "internal error: could not get evaluate::Expr");
885 if (Fortran::evaluate::HasVectorSubscript(*expr)) {
886 auto vectorSubscriptBox =
887 Fortran::lower::genVectorSubscriptBox(loc, converter, stmtCtx, *expr);
888 mlir::func::FuncOp inputFunc = getInputFunc(
889 loc, builder, vectorSubscriptBox.getElementType(), isFormatted);
890 const bool mustBox =
891 mlir::isa<fir::BoxType>(inputFunc.getFunctionType().getInput(1));
892 if (!checkResult) {
893 auto elementalGenerator = [&](const fir::ExtendedValue &element) {
894 createIoRuntimeCallForItem(converter, loc, inputFunc, cookie,
895 mustBox ? builder.createBox(loc, element)
896 : element);
897 };
898 vectorSubscriptBox.loopOverElements(builder, loc, elementalGenerator);
899 } else {
900 auto elementalGenerator =
901 [&](const fir::ExtendedValue &element) -> mlir::Value {
902 return createIoRuntimeCallForItem(
903 converter, loc, inputFunc, cookie,
904 mustBox ? builder.createBox(loc, element) : element);
905 };
906 if (!ok)
907 ok = builder.createBool(loc, true);
908 ok = vectorSubscriptBox.loopOverElementsWhile(builder, loc,
909 elementalGenerator, ok);
910 }
911 continue;
912 }
913 mlir::Type itemTy = converter.genType(*expr);
914 mlir::func::FuncOp inputFunc =
915 getInputFunc(loc, builder, itemTy, isFormatted);
916 auto itemExv =
917 mlir::isa<fir::BoxType>(inputFunc.getFunctionType().getInput(1))
918 ? converter.genExprBox(loc, *expr, stmtCtx)
919 : converter.genExprAddr(loc, expr, stmtCtx);
920 ok = createIoRuntimeCallForItem(converter, loc, inputFunc, cookie, itemExv);
921 }
922}
923
924/// Generate an io-implied-do loop.
925template <typename D>
926static void genIoLoop(Fortran::lower::AbstractConverter &converter,
927 mlir::Value cookie, const D &ioImpliedDo,
928 bool isFormatted, bool checkResult, mlir::Value &ok,
929 bool inLoop) {
930 Fortran::lower::StatementContext stmtCtx;
931 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
932 mlir::Location loc = converter.getCurrentLocation();
933 mlir::arith::IntegerOverflowFlags flags{};
934 if (!converter.getLoweringOptions().getIntegerWrapAround())
935 flags = bitEnumSet(flags, mlir::arith::IntegerOverflowFlags::nsw);
936 auto iofAttr =
937 mlir::arith::IntegerOverflowFlagsAttr::get(builder.getContext(), flags);
938 makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
939 const auto &itemList = std::get<0>(ioImpliedDo.t);
940 const auto &control = std::get<1>(ioImpliedDo.t);
941 const auto &loopSym = *control.name.thing.thing.symbol;
942 mlir::Value loopVar = fir::getBase(converter.genExprAddr(
943 Fortran::evaluate::AsGenericExpr(loopSym).value(), stmtCtx));
944 auto genControlValue = [&](const Fortran::parser::ScalarIntExpr &expr) {
945 mlir::Value v = fir::getBase(
946 converter.genExprValue(*Fortran::semantics::GetExpr(expr), stmtCtx));
947 return builder.createConvert(loc, builder.getIndexType(), v);
948 };
949 mlir::Value lowerValue = genControlValue(control.lower);
950 mlir::Value upperValue = genControlValue(control.upper);
951 mlir::Value stepValue =
952 control.step.has_value()
953 ? genControlValue(*control.step)
954 : builder.create<mlir::arith::ConstantIndexOp>(loc, 1);
955 auto genItemList = [&](const D &ioImpliedDo) {
956 if constexpr (std::is_same_v<D, Fortran::parser::InputImpliedDo>)
957 genInputItemList(converter, cookie, itemList, isFormatted, checkResult,
958 ok, /*inLoop=*/true);
959 else
960 genOutputItemList(converter, cookie, itemList, isFormatted, checkResult,
961 ok, /*inLoop=*/true);
962 };
963 if (!checkResult) {
964 // No IO call result checks - the loop is a fir.do_loop op.
965 auto doLoopOp = builder.create<fir::DoLoopOp>(
966 loc, lowerValue, upperValue, stepValue, /*unordered=*/false,
967 /*finalCountValue=*/true);
968 builder.setInsertionPointToStart(doLoopOp.getBody());
969 mlir::Value lcv = builder.createConvert(
970 loc, fir::unwrapRefType(loopVar.getType()), doLoopOp.getInductionVar());
971 builder.create<fir::StoreOp>(loc, lcv, loopVar);
972 genItemList(ioImpliedDo);
973 builder.setInsertionPointToEnd(doLoopOp.getBody());
974 mlir::Value result = builder.create<mlir::arith::AddIOp>(
975 loc, doLoopOp.getInductionVar(), doLoopOp.getStep(), iofAttr);
976 builder.create<fir::ResultOp>(loc, result);
977 builder.setInsertionPointAfter(doLoopOp);
978 // The loop control variable may be used after the loop.
979 lcv = builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()),
980 doLoopOp.getResult(0));
981 builder.create<fir::StoreOp>(loc, lcv, loopVar);
982 return;
983 }
984 // Check IO call results - the loop is a fir.iterate_while op.
985 if (!ok)
986 ok = builder.createBool(loc, true);
987 auto iterWhileOp = builder.create<fir::IterWhileOp>(
988 loc, lowerValue, upperValue, stepValue, ok, /*finalCountValue*/ true);
989 builder.setInsertionPointToStart(iterWhileOp.getBody());
990 mlir::Value lcv =
991 builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()),
992 iterWhileOp.getInductionVar());
993 builder.create<fir::StoreOp>(loc, lcv, loopVar);
994 ok = iterWhileOp.getIterateVar();
995 mlir::Value falseValue =
996 builder.createIntegerConstant(loc, builder.getI1Type(), 0);
997 genItemList(ioImpliedDo);
998 // Unwind nested IO call scopes, filling in true and false ResultOp's.
999 for (mlir::Operation *op = builder.getBlock()->getParentOp();
1000 mlir::isa<fir::IfOp>(op); op = op->getBlock()->getParentOp()) {
1001 auto ifOp = mlir::dyn_cast<fir::IfOp>(op);
1002 mlir::Operation *lastOp = &ifOp.getThenRegion().front().back();
1003 builder.setInsertionPointAfter(lastOp);
1004 // The primary ifOp result is the result of an IO call or loop.
1005 if (mlir::isa<fir::CallOp, fir::IfOp>(*lastOp))
1006 builder.create<fir::ResultOp>(loc, lastOp->getResult(0));
1007 else
1008 builder.create<fir::ResultOp>(loc, ok); // loop result
1009 // The else branch propagates an early exit false result.
1010 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
1011 builder.create<fir::ResultOp>(loc, falseValue);
1012 }
1013 builder.setInsertionPointToEnd(iterWhileOp.getBody());
1014 mlir::OpResult iterateResult = builder.getBlock()->back().getResult(0);
1015 mlir::Value inductionResult0 = iterWhileOp.getInductionVar();
1016 auto inductionResult1 = builder.create<mlir::arith::AddIOp>(
1017 loc, inductionResult0, iterWhileOp.getStep(), iofAttr);
1018 auto inductionResult = builder.create<mlir::arith::SelectOp>(
1019 loc, iterateResult, inductionResult1, inductionResult0);
1020 llvm::SmallVector<mlir::Value> results = {inductionResult, iterateResult};
1021 builder.create<fir::ResultOp>(loc, results);
1022 ok = iterWhileOp.getResult(1);
1023 builder.setInsertionPointAfter(iterWhileOp);
1024 // The loop control variable may be used after the loop.
1025 lcv = builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()),
1026 iterWhileOp.getResult(0));
1027 builder.create<fir::StoreOp>(loc, lcv, loopVar);
1028}
1029
1030//===----------------------------------------------------------------------===//
1031// Default argument generation.
1032//===----------------------------------------------------------------------===//
1033
1034static mlir::Value locToFilename(Fortran::lower::AbstractConverter &converter,
1035 mlir::Location loc, mlir::Type toType) {
1036 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1037 return builder.createConvert(loc, toType,
1038 fir::factory::locationToFilename(builder, loc));
1039}
1040
1041static mlir::Value locToLineNo(Fortran::lower::AbstractConverter &converter,
1042 mlir::Location loc, mlir::Type toType) {
1043 return fir::factory::locationToLineNo(converter.getFirOpBuilder(), loc,
1044 toType);
1045}
1046
1047static mlir::Value getDefaultScratch(fir::FirOpBuilder &builder,
1048 mlir::Location loc, mlir::Type toType) {
1049 mlir::Value null = builder.create<mlir::arith::ConstantOp>(
1050 loc, builder.getI64IntegerAttr(0));
1051 return builder.createConvert(loc, toType, null);
1052}
1053
1054static mlir::Value getDefaultScratchLen(fir::FirOpBuilder &builder,
1055 mlir::Location loc, mlir::Type toType) {
1056 return builder.create<mlir::arith::ConstantOp>(
1057 loc, builder.getIntegerAttr(toType, 0));
1058}
1059
1060/// Generate a reference to a buffer and the length of buffer given
1061/// a character expression. An array expression will be cast to scalar
1062/// character as long as they are contiguous.
1063static std::tuple<mlir::Value, mlir::Value>
1064genBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1065 const Fortran::lower::SomeExpr &expr, mlir::Type strTy,
1066 mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) {
1067 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1068 fir::ExtendedValue exprAddr = converter.genExprAddr(expr, stmtCtx);
1069 fir::factory::CharacterExprHelper helper(builder, loc);
1070 using ValuePair = std::pair<mlir::Value, mlir::Value>;
1071 auto [buff, len] = exprAddr.match(
1072 [&](const fir::CharBoxValue &x) -> ValuePair {
1073 return {x.getBuffer(), x.getLen()};
1074 },
1075 [&](const fir::CharArrayBoxValue &x) -> ValuePair {
1076 fir::CharBoxValue scalar = helper.toScalarCharacter(x);
1077 return {scalar.getBuffer(), scalar.getLen()};
1078 },
1079 [&](const fir::BoxValue &) -> ValuePair {
1080 // May need to copy before after IO to handle contiguous
1081 // aspect. Not sure descriptor can get here though.
1082 TODO(loc, "character descriptor to contiguous buffer");
1083 },
1084 [&](const auto &) -> ValuePair {
1085 llvm::report_fatal_error(
1086 "internal error: IO buffer is not a character");
1087 });
1088 buff = builder.createConvert(loc, strTy, buff);
1089 len = builder.createConvert(loc, lenTy, len);
1090 return {buff, len};
1091}
1092
1093/// Lower a string literal. Many arguments to the runtime are conveyed as
1094/// Fortran CHARACTER literals.
1095template <typename A>
1096static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1097lowerStringLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1098 Fortran::lower::StatementContext &stmtCtx, const A &syntax,
1099 mlir::Type strTy, mlir::Type lenTy, mlir::Type ty2 = {}) {
1100 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1101 auto *expr = Fortran::semantics::GetExpr(syntax);
1102 if (!expr)
1103 fir::emitFatalError(loc, "internal error: null semantic expr in IO");
1104 auto [buff, len] = genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx);
1105 mlir::Value kind;
1106 if (ty2) {
1107 auto kindVal = expr->GetType().value().kind();
1108 kind = builder.create<mlir::arith::ConstantOp>(
1109 loc, builder.getIntegerAttr(ty2, kindVal));
1110 }
1111 return {buff, len, kind};
1112}
1113
1114/// Pass the body of the FORMAT statement in as if it were a CHARACTER literal
1115/// constant. NB: This is the prescribed manner in which the front-end passes
1116/// this information to lowering.
1117static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1118lowerSourceTextAsStringLit(Fortran::lower::AbstractConverter &converter,
1119 mlir::Location loc, llvm::StringRef text,
1120 mlir::Type strTy, mlir::Type lenTy) {
1121 text = text.drop_front(text.find('('));
1122 text = text.take_front(text.rfind(')') + 1);
1123 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1124 mlir::Value addrGlobalStringLit =
1125 fir::getBase(fir::factory::createStringLiteral(builder, loc, text));
1126 mlir::Value buff = builder.createConvert(loc, strTy, addrGlobalStringLit);
1127 mlir::Value len = builder.createIntegerConstant(loc, lenTy, text.size());
1128 return {buff, len, mlir::Value{}};
1129}
1130
1131//===----------------------------------------------------------------------===//
1132// Handle IO statement specifiers.
1133// These are threaded together for a single statement via the passed cookie.
1134//===----------------------------------------------------------------------===//
1135
1136/// Generic to build an integral argument to the runtime.
1137template <typename A, typename B>
1138mlir::Value genIntIOOption(Fortran::lower::AbstractConverter &converter,
1139 mlir::Location loc, mlir::Value cookie,
1140 const B &spec) {
1141 Fortran::lower::StatementContext localStatementCtx;
1142 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1143 mlir::func::FuncOp ioFunc = fir::runtime::getIORuntimeFunc<A>(loc, builder);
1144 mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1145 mlir::Value expr = fir::getBase(converter.genExprValue(
1146 loc, Fortran::semantics::GetExpr(spec.v), localStatementCtx));
1147 mlir::Value val = builder.createConvert(loc, ioFuncTy.getInput(1), expr);
1148 llvm::SmallVector<mlir::Value> ioArgs = {cookie, val};
1149 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1150}
1151
1152/// Generic to build a string argument to the runtime. This passes a CHARACTER
1153/// as a pointer to the buffer and a LEN parameter.
1154template <typename A, typename B>
1155mlir::Value genCharIOOption(Fortran::lower::AbstractConverter &converter,
1156 mlir::Location loc, mlir::Value cookie,
1157 const B &spec) {
1158 Fortran::lower::StatementContext localStatementCtx;
1159 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1160 mlir::func::FuncOp ioFunc = fir::runtime::getIORuntimeFunc<A>(loc, builder);
1161 mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1162 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1163 lowerStringLit(converter, loc, localStatementCtx, spec,
1164 ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1165 llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
1166 std::get<1>(tup)};
1167 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1168}
1169
1170template <typename A>
1171mlir::Value genIOOption(Fortran::lower::AbstractConverter &converter,
1172 mlir::Location loc, mlir::Value cookie, const A &spec) {
1173 // These specifiers are processed in advance elsewhere - skip them here.
1174 using PreprocessedSpecs =
1175 std::tuple<Fortran::parser::EndLabel, Fortran::parser::EorLabel,
1176 Fortran::parser::ErrLabel, Fortran::parser::FileUnitNumber,
1177 Fortran::parser::Format, Fortran::parser::IoUnit,
1178 Fortran::parser::MsgVariable, Fortran::parser::Name,
1179 Fortran::parser::StatVariable>;
1180 static_assert(Fortran::common::HasMember<A, PreprocessedSpecs>,
1181 "missing genIOOPtion specialization");
1182 return {};
1183}
1184
1185template <>
1186mlir::Value genIOOption<Fortran::parser::FileNameExpr>(
1187 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1188 mlir::Value cookie, const Fortran::parser::FileNameExpr &spec) {
1189 Fortran::lower::StatementContext localStatementCtx;
1190 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1191 // has an extra KIND argument
1192 mlir::func::FuncOp ioFunc =
1193 fir::runtime::getIORuntimeFunc<mkIOKey(SetFile)>(loc, builder);
1194 mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1195 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1196 lowerStringLit(converter, loc, localStatementCtx, spec,
1197 ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1198 llvm::SmallVector<mlir::Value> ioArgs{cookie, std::get<0>(tup),
1199 std::get<1>(tup)};
1200 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1201}
1202
1203template <>
1204mlir::Value genIOOption<Fortran::parser::ConnectSpec::CharExpr>(
1205 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1206 mlir::Value cookie, const Fortran::parser::ConnectSpec::CharExpr &spec) {
1207 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1208 mlir::func::FuncOp ioFunc;
1209 switch (std::get<Fortran::parser::ConnectSpec::CharExpr::Kind>(spec.t)) {
1210 case Fortran::parser::ConnectSpec::CharExpr::Kind::Access:
1211 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetAccess)>(loc, builder);
1212 break;
1213 case Fortran::parser::ConnectSpec::CharExpr::Kind::Action:
1214 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetAction)>(loc, builder);
1215 break;
1216 case Fortran::parser::ConnectSpec::CharExpr::Kind::Asynchronous:
1217 ioFunc =
1218 fir::runtime::getIORuntimeFunc<mkIOKey(SetAsynchronous)>(loc, builder);
1219 break;
1220 case Fortran::parser::ConnectSpec::CharExpr::Kind::Blank:
1221 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder);
1222 break;
1223 case Fortran::parser::ConnectSpec::CharExpr::Kind::Decimal:
1224 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder);
1225 break;
1226 case Fortran::parser::ConnectSpec::CharExpr::Kind::Delim:
1227 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder);
1228 break;
1229 case Fortran::parser::ConnectSpec::CharExpr::Kind::Encoding:
1230 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetEncoding)>(loc, builder);
1231 break;
1232 case Fortran::parser::ConnectSpec::CharExpr::Kind::Form:
1233 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetForm)>(loc, builder);
1234 break;
1235 case Fortran::parser::ConnectSpec::CharExpr::Kind::Pad:
1236 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder);
1237 break;
1238 case Fortran::parser::ConnectSpec::CharExpr::Kind::Position:
1239 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetPosition)>(loc, builder);
1240 break;
1241 case Fortran::parser::ConnectSpec::CharExpr::Kind::Round:
1242 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder);
1243 break;
1244 case Fortran::parser::ConnectSpec::CharExpr::Kind::Sign:
1245 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder);
1246 break;
1247 case Fortran::parser::ConnectSpec::CharExpr::Kind::Carriagecontrol:
1248 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetCarriagecontrol)>(
1249 loc, builder);
1250 break;
1251 case Fortran::parser::ConnectSpec::CharExpr::Kind::Convert:
1252 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetConvert)>(loc, builder);
1253 break;
1254 case Fortran::parser::ConnectSpec::CharExpr::Kind::Dispose:
1255 TODO(loc, "DISPOSE not part of the runtime::io interface");
1256 }
1257 Fortran::lower::StatementContext localStatementCtx;
1258 mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1259 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1260 lowerStringLit(converter, loc, localStatementCtx,
1261 std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t),
1262 ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1263 llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
1264 std::get<1>(tup)};
1265 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1266}
1267
1268template <>
1269mlir::Value genIOOption<Fortran::parser::ConnectSpec::Recl>(
1270 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1271 mlir::Value cookie, const Fortran::parser::ConnectSpec::Recl &spec) {
1272 return genIntIOOption<mkIOKey(SetRecl)>(converter, loc, cookie, spec);
1273}
1274
1275template <>
1276mlir::Value genIOOption<Fortran::parser::StatusExpr>(
1277 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1278 mlir::Value cookie, const Fortran::parser::StatusExpr &spec) {
1279 return genCharIOOption<mkIOKey(SetStatus)>(converter, loc, cookie, spec.v);
1280}
1281
1282template <>
1283mlir::Value genIOOption<Fortran::parser::IoControlSpec::CharExpr>(
1284 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1285 mlir::Value cookie, const Fortran::parser::IoControlSpec::CharExpr &spec) {
1286 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1287 mlir::func::FuncOp ioFunc;
1288 switch (std::get<Fortran::parser::IoControlSpec::CharExpr::Kind>(spec.t)) {
1289 case Fortran::parser::IoControlSpec::CharExpr::Kind::Advance:
1290 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetAdvance)>(loc, builder);
1291 break;
1292 case Fortran::parser::IoControlSpec::CharExpr::Kind::Blank:
1293 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder);
1294 break;
1295 case Fortran::parser::IoControlSpec::CharExpr::Kind::Decimal:
1296 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder);
1297 break;
1298 case Fortran::parser::IoControlSpec::CharExpr::Kind::Delim:
1299 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder);
1300 break;
1301 case Fortran::parser::IoControlSpec::CharExpr::Kind::Pad:
1302 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder);
1303 break;
1304 case Fortran::parser::IoControlSpec::CharExpr::Kind::Round:
1305 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder);
1306 break;
1307 case Fortran::parser::IoControlSpec::CharExpr::Kind::Sign:
1308 ioFunc = fir::runtime::getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder);
1309 break;
1310 }
1311 Fortran::lower::StatementContext localStatementCtx;
1312 mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1313 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1314 lowerStringLit(converter, loc, localStatementCtx,
1315 std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t),
1316 ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1317 llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
1318 std::get<1>(tup)};
1319 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1320}
1321
1322template <>
1323mlir::Value genIOOption<Fortran::parser::IoControlSpec::Asynchronous>(
1324 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1325 mlir::Value cookie,
1326 const Fortran::parser::IoControlSpec::Asynchronous &spec) {
1327 return genCharIOOption<mkIOKey(SetAsynchronous)>(converter, loc, cookie,
1328 spec.v);
1329}
1330
1331template <>
1332mlir::Value genIOOption<Fortran::parser::IoControlSpec::Pos>(
1333 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1334 mlir::Value cookie, const Fortran::parser::IoControlSpec::Pos &spec) {
1335 return genIntIOOption<mkIOKey(SetPos)>(converter, loc, cookie, spec);
1336}
1337
1338template <>
1339mlir::Value genIOOption<Fortran::parser::IoControlSpec::Rec>(
1340 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1341 mlir::Value cookie, const Fortran::parser::IoControlSpec::Rec &spec) {
1342 return genIntIOOption<mkIOKey(SetRec)>(converter, loc, cookie, spec);
1343}
1344
1345/// Generate runtime call to set some control variable.
1346/// Generates "VAR = IoRuntimeKey(cookie)".
1347template <typename IoRuntimeKey, typename VAR>
1348static void genIOGetVar(Fortran::lower::AbstractConverter &converter,
1349 mlir::Location loc, mlir::Value cookie,
1350 const VAR &parserVar) {
1351 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1352 mlir::func::FuncOp ioFunc =
1353 fir::runtime::getIORuntimeFunc<IoRuntimeKey>(loc, builder);
1354 mlir::Value value =
1355 builder.create<fir::CallOp>(loc, ioFunc, mlir::ValueRange{cookie})
1356 .getResult(0);
1357 Fortran::lower::StatementContext localStatementCtx;
1358 fir::ExtendedValue var = converter.genExprAddr(
1359 loc, Fortran::semantics::GetExpr(parserVar.v), localStatementCtx);
1360 builder.createStoreWithConvert(loc, value, fir::getBase(var));
1361}
1362
1363//===----------------------------------------------------------------------===//
1364// Gather IO statement condition specifier information (if any).
1365//===----------------------------------------------------------------------===//
1366
1367template <typename SEEK, typename A>
1368static bool hasX(const A &list) {
1369 for (const auto &spec : list)
1370 if (std::holds_alternative<SEEK>(spec.u))
1371 return true;
1372 return false;
1373}
1374
1375template <typename SEEK, typename A>
1376static bool hasSpec(const A &stmt) {
1377 return hasX<SEEK>(stmt.v);
1378}
1379
1380/// Get the sought expression from the specifier list.
1381template <typename SEEK, typename A>
1382static const Fortran::lower::SomeExpr *getExpr(const A &stmt) {
1383 for (const auto &spec : stmt.v)
1384 if (auto *f = std::get_if<SEEK>(&spec.u))
1385 return Fortran::semantics::GetExpr(f->v);
1386 llvm::report_fatal_error("must have a file unit");
1387}
1388
1389/// For each specifier, build the appropriate call, threading the cookie.
1390template <typename A>
1391static void threadSpecs(Fortran::lower::AbstractConverter &converter,
1392 mlir::Location loc, mlir::Value cookie,
1393 const A &specList, bool checkResult, mlir::Value &ok) {
1394 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1395 for (const auto &spec : specList) {
1396 makeNextConditionalOn(builder, loc, checkResult, ok);
1397 ok = Fortran::common::visit(
1398 Fortran::common::visitors{
1399 [&](const Fortran::parser::IoControlSpec::Size &x) -> mlir::Value {
1400 // Size must be queried after the related READ runtime calls, not
1401 // before.
1402 return ok;
1403 },
1404 [&](const Fortran::parser::ConnectSpec::Newunit &x) -> mlir::Value {
1405 // Newunit must be queried after OPEN specifier runtime calls
1406 // that may fail to avoid modifying the newunit variable if
1407 // there is an error.
1408 return ok;
1409 },
1410 [&](const Fortran::parser::IdVariable &) -> mlir::Value {
1411 // ID is queried after the transfer so that ASYNCHROUNOUS= has
1412 // been processed and also to set it to zero if the transfer is
1413 // already finished.
1414 return ok;
1415 },
1416 [&](const auto &x) {
1417 return genIOOption(converter, loc, cookie, x);
1418 }},
1419 spec.u);
1420 }
1421}
1422
1423/// Most IO statements allow one or more of five optional exception condition
1424/// handling specifiers: ERR, EOR, END, IOSTAT, and IOMSG. The first three
1425/// cause control flow to transfer to another statement. The final two return
1426/// information from the runtime, via a variable, about the nature of the
1427/// condition that occurred. These condition specifiers are handled here.
1428template <typename A>
1429ConditionSpecInfo lowerErrorSpec(Fortran::lower::AbstractConverter &converter,
1430 mlir::Location loc, const A &specList) {
1431 ConditionSpecInfo csi;
1432 const Fortran::lower::SomeExpr *ioMsgExpr = nullptr;
1433 for (const auto &spec : specList) {
1434 Fortran::common::visit(
1435 Fortran::common::visitors{
1436 [&](const Fortran::parser::StatVariable &var) {
1437 csi.ioStatExpr = Fortran::semantics::GetExpr(var);
1438 },
1439 [&](const Fortran::parser::InquireSpec::IntVar &var) {
1440 if (std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t) ==
1441 Fortran::parser::InquireSpec::IntVar::Kind::Iostat)
1442 csi.ioStatExpr = Fortran::semantics::GetExpr(
1443 std::get<Fortran::parser::ScalarIntVariable>(var.t));
1444 },
1445 [&](const Fortran::parser::MsgVariable &var) {
1446 ioMsgExpr = Fortran::semantics::GetExpr(var);
1447 },
1448 [&](const Fortran::parser::InquireSpec::CharVar &var) {
1449 if (std::get<Fortran::parser::InquireSpec::CharVar::Kind>(
1450 var.t) ==
1451 Fortran::parser::InquireSpec::CharVar::Kind::Iomsg)
1452 ioMsgExpr = Fortran::semantics::GetExpr(
1453 std::get<Fortran::parser::ScalarDefaultCharVariable>(
1454 var.t));
1455 },
1456 [&](const Fortran::parser::EndLabel &) { csi.hasEnd = true; },
1457 [&](const Fortran::parser::EorLabel &) { csi.hasEor = true; },
1458 [&](const Fortran::parser::ErrLabel &) { csi.hasErr = true; },
1459 [](const auto &) {}},
1460 spec.u);
1461 }
1462 if (ioMsgExpr) {
1463 // iomsg is a variable, its evaluation may require temps, but it cannot
1464 // itself be a temp, and it is ok to us a local statement context here.
1465 Fortran::lower::StatementContext stmtCtx;
1466 csi.ioMsg = converter.genExprAddr(loc, ioMsgExpr, stmtCtx);
1467 }
1468
1469 return csi;
1470}
1471template <typename A>
1472static void
1473genConditionHandlerCall(Fortran::lower::AbstractConverter &converter,
1474 mlir::Location loc, mlir::Value cookie,
1475 const A &specList, ConditionSpecInfo &csi) {
1476 if (!csi.hasAnyConditionSpec())
1477 return;
1478 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1479 mlir::func::FuncOp enableHandlers =
1480 fir::runtime::getIORuntimeFunc<mkIOKey(EnableHandlers)>(loc, builder);
1481 mlir::Type boolType = enableHandlers.getFunctionType().getInput(1);
1482 auto boolValue = [&](bool specifierIsPresent) {
1483 return builder.create<mlir::arith::ConstantOp>(
1484 loc, builder.getIntegerAttr(boolType, specifierIsPresent));
1485 };
1486 llvm::SmallVector<mlir::Value> ioArgs = {cookie,
1487 boolValue(csi.ioStatExpr != nullptr),
1488 boolValue(csi.hasErr),
1489 boolValue(csi.hasEnd),
1490 boolValue(csi.hasEor),
1491 boolValue(csi.ioMsg.has_value())};
1492 builder.create<fir::CallOp>(loc, enableHandlers, ioArgs);
1493}
1494
1495//===----------------------------------------------------------------------===//
1496// Data transfer helpers
1497//===----------------------------------------------------------------------===//
1498
1499template <typename SEEK, typename A>
1500static bool hasIOControl(const A &stmt) {
1501 return hasX<SEEK>(stmt.controls);
1502}
1503
1504template <typename SEEK, typename A>
1505static const auto *getIOControl(const A &stmt) {
1506 for (const auto &spec : stmt.controls)
1507 if (const auto *result = std::get_if<SEEK>(&spec.u))
1508 return result;
1509 return static_cast<const SEEK *>(nullptr);
1510}
1511
1512/// Returns true iff the expression in the parse tree is not really a format but
1513/// rather a namelist group.
1514template <typename A>
1515static bool formatIsActuallyNamelist(const A &format) {
1516 if (auto *e = std::get_if<Fortran::parser::Expr>(&format.u)) {
1517 auto *expr = Fortran::semantics::GetExpr(*e);
1518 if (const Fortran::semantics::Symbol *y =
1519 Fortran::evaluate::UnwrapWholeSymbolDataRef(*expr))
1520 return y->has<Fortran::semantics::NamelistDetails>();
1521 }
1522 return false;
1523}
1524
1525template <typename A>
1526static bool isDataTransferFormatted(const A &stmt) {
1527 if (stmt.format)
1528 return !formatIsActuallyNamelist(*stmt.format);
1529 return hasIOControl<Fortran::parser::Format>(stmt);
1530}
1531template <>
1532constexpr bool isDataTransferFormatted<Fortran::parser::PrintStmt>(
1533 const Fortran::parser::PrintStmt &) {
1534 return true; // PRINT is always formatted
1535}
1536
1537template <typename A>
1538static bool isDataTransferList(const A &stmt) {
1539 if (stmt.format)
1540 return std::holds_alternative<Fortran::parser::Star>(stmt.format->u);
1541 if (auto *mem = getIOControl<Fortran::parser::Format>(stmt))
1542 return std::holds_alternative<Fortran::parser::Star>(mem->u);
1543 return false;
1544}
1545template <>
1546bool isDataTransferList<Fortran::parser::PrintStmt>(
1547 const Fortran::parser::PrintStmt &stmt) {
1548 return std::holds_alternative<Fortran::parser::Star>(
1549 std::get<Fortran::parser::Format>(stmt.t).u);
1550}
1551
1552template <typename A>
1553static bool isDataTransferInternal(const A &stmt) {
1554 if (stmt.iounit.has_value())
1555 return std::holds_alternative<Fortran::parser::Variable>(stmt.iounit->u);
1556 if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt))
1557 return std::holds_alternative<Fortran::parser::Variable>(unit->u);
1558 return false;
1559}
1560template <>
1561constexpr bool isDataTransferInternal<Fortran::parser::PrintStmt>(
1562 const Fortran::parser::PrintStmt &) {
1563 return false;
1564}
1565
1566/// If the variable `var` is an array or of a KIND other than the default
1567/// (normally 1), then a descriptor is required by the runtime IO API. This
1568/// condition holds even in F77 sources.
1569static std::optional<fir::ExtendedValue> getVariableBufferRequiredDescriptor(
1570 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1571 const Fortran::parser::Variable &var,
1572 Fortran::lower::StatementContext &stmtCtx) {
1573 fir::ExtendedValue varBox =
1574 converter.genExprBox(loc, var.typedExpr->v.value(), stmtCtx);
1575 fir::KindTy defCharKind = converter.getKindMap().defaultCharacterKind();
1576 mlir::Value varAddr = fir::getBase(varBox);
1577 if (fir::factory::CharacterExprHelper::getCharacterOrSequenceKind(
1578 varAddr.getType()) != defCharKind)
1579 return varBox;
1580 if (fir::factory::CharacterExprHelper::isArray(varAddr.getType()))
1581 return varBox;
1582 return std::nullopt;
1583}
1584
1585template <typename A>
1586static std::optional<fir::ExtendedValue>
1587maybeGetInternalIODescriptor(Fortran::lower::AbstractConverter &converter,
1588 mlir::Location loc, const A &stmt,
1589 Fortran::lower::StatementContext &stmtCtx) {
1590 if (stmt.iounit.has_value())
1591 if (auto *var = std::get_if<Fortran::parser::Variable>(&stmt.iounit->u))
1592 return getVariableBufferRequiredDescriptor(converter, loc, *var, stmtCtx);
1593 if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt))
1594 if (auto *var = std::get_if<Fortran::parser::Variable>(&unit->u))
1595 return getVariableBufferRequiredDescriptor(converter, loc, *var, stmtCtx);
1596 return std::nullopt;
1597}
1598template <>
1599inline std::optional<fir::ExtendedValue>
1600maybeGetInternalIODescriptor<Fortran::parser::PrintStmt>(
1601 Fortran::lower::AbstractConverter &, mlir::Location loc,
1602 const Fortran::parser::PrintStmt &, Fortran::lower::StatementContext &) {
1603 return std::nullopt;
1604}
1605
1606template <typename A>
1607static bool isDataTransferNamelist(const A &stmt) {
1608 if (stmt.format)
1609 return formatIsActuallyNamelist(*stmt.format);
1610 return hasIOControl<Fortran::parser::Name>(stmt);
1611}
1612template <>
1613constexpr bool isDataTransferNamelist<Fortran::parser::PrintStmt>(
1614 const Fortran::parser::PrintStmt &) {
1615 return false;
1616}
1617
1618/// Lowers a format statment that uses an assigned variable label reference as
1619/// a select operation to allow for run-time selection of the format statement.
1620static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1621lowerReferenceAsStringSelect(Fortran::lower::AbstractConverter &converter,
1622 mlir::Location loc,
1623 const Fortran::lower::SomeExpr &expr,
1624 mlir::Type strTy, mlir::Type lenTy,
1625 Fortran::lower::StatementContext &stmtCtx) {
1626 // Create the requisite blocks to inline a selectOp.
1627 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1628 mlir::Block *startBlock = builder.getBlock();
1629 mlir::Block *endBlock = startBlock->splitBlock(builder.getInsertionPoint());
1630 mlir::Block *block = startBlock->splitBlock(builder.getInsertionPoint());
1631 builder.setInsertionPointToEnd(block);
1632
1633 llvm::SmallVector<int64_t> indexList;
1634 llvm::SmallVector<mlir::Block *> blockList;
1635
1636 auto symbol = GetLastSymbol(&expr);
1637 Fortran::lower::pft::LabelSet labels;
1638 converter.lookupLabelSet(*symbol, labels);
1639
1640 for (auto label : labels) {
1641 indexList.push_back(label);
1642 auto *eval = converter.lookupLabel(label);
1643 assert(eval && "Label is missing from the table");
1644
1645 llvm::StringRef text = toStringRef(eval->position);
1646 mlir::Value stringRef;
1647 mlir::Value stringLen;
1648 if (eval->isA<Fortran::parser::FormatStmt>()) {
1649 assert(text.contains('(') && "FORMAT is unexpectedly ill-formed");
1650 // This is a format statement, so extract the spec from the text.
1651 std::tuple<mlir::Value, mlir::Value, mlir::Value> stringLit =
1652 lowerSourceTextAsStringLit(converter, loc, text, strTy, lenTy);
1653 stringRef = std::get<0>(stringLit);
1654 stringLen = std::get<1>(stringLit);
1655 } else {
1656 // This is not a format statement, so use null.
1657 stringRef = builder.createConvert(
1658 loc, strTy,
1659 builder.createIntegerConstant(loc, builder.getIndexType(), 0));
1660 stringLen = builder.createIntegerConstant(loc, lenTy, 0);
1661 }
1662
1663 // Pass the format string reference and the string length out of the select
1664 // statement.
1665 llvm::SmallVector<mlir::Value> args = {stringRef, stringLen};
1666 builder.create<mlir::cf::BranchOp>(loc, endBlock, args);
1667
1668 // Add block to the list of cases and make a new one.
1669 blockList.push_back(block);
1670 block = block->splitBlock(builder.getInsertionPoint());
1671 builder.setInsertionPointToEnd(block);
1672 }
1673
1674 // Create the unit case which should result in an error.
1675 auto *unitBlock = block->splitBlock(builder.getInsertionPoint());
1676 builder.setInsertionPointToEnd(unitBlock);
1677 fir::runtime::genReportFatalUserError(
1678 builder, loc,
1679 "Assigned format variable '" + symbol->name().ToString() +
1680 "' has not been assigned a valid format label");
1681 builder.create<fir::UnreachableOp>(loc);
1682 blockList.push_back(unitBlock);
1683
1684 // Lower the selectOp.
1685 builder.setInsertionPointToEnd(startBlock);
1686 auto label = fir::getBase(converter.genExprValue(loc, &expr, stmtCtx));
1687 builder.create<fir::SelectOp>(loc, label, indexList, blockList);
1688
1689 builder.setInsertionPointToEnd(endBlock);
1690 endBlock->addArgument(strTy, loc);
1691 endBlock->addArgument(lenTy, loc);
1692
1693 // Handle and return the string reference and length selected by the selectOp.
1694 auto buff = endBlock->getArgument(0);
1695 auto len = endBlock->getArgument(1);
1696
1697 return {buff, len, mlir::Value{}};
1698}
1699
1700/// Generate a reference to a format string. There are four cases - a format
1701/// statement label, a character format expression, an integer that holds the
1702/// label of a format statement, and the * case. The first three are done here.
1703/// The * case is done elsewhere.
1704static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1705genFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1706 const Fortran::parser::Format &format, mlir::Type strTy,
1707 mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) {
1708 if (const auto *label = std::get_if<Fortran::parser::Label>(&format.u)) {
1709 // format statement label
1710 auto eval = converter.lookupLabel(*label);
1711 assert(eval && "FORMAT not found in PROCEDURE");
1712 return lowerSourceTextAsStringLit(
1713 converter, loc, toStringRef(eval->position), strTy, lenTy);
1714 }
1715 const auto *pExpr = std::get_if<Fortran::parser::Expr>(&format.u);
1716 assert(pExpr && "missing format expression");
1717 auto e = Fortran::semantics::GetExpr(*pExpr);
1718 if (Fortran::semantics::ExprHasTypeCategory(
1719 *e, Fortran::common::TypeCategory::Character)) {
1720 // character expression
1721 if (e->Rank())
1722 // Array: return address(descriptor) and no length (and no kind value).
1723 return {fir::getBase(converter.genExprBox(loc, *e, stmtCtx)),
1724 mlir::Value{}, mlir::Value{}};
1725 // Scalar: return address(format) and format length (and no kind value).
1726 return lowerStringLit(converter, loc, stmtCtx, *pExpr, strTy, lenTy);
1727 }
1728
1729 if (Fortran::semantics::ExprHasTypeCategory(
1730 *e, Fortran::common::TypeCategory::Integer) &&
1731 e->Rank() == 0 && Fortran::evaluate::UnwrapWholeSymbolDataRef(*e)) {
1732 // Treat as a scalar integer variable containing an ASSIGN label.
1733 return lowerReferenceAsStringSelect(converter, loc, *e, strTy, lenTy,
1734 stmtCtx);
1735 }
1736
1737 // Legacy extension: it is possible that `*e` is not a scalar INTEGER
1738 // variable containing a label value. The output appears to be the source text
1739 // that initialized the variable? Needs more investigatation.
1740 TODO(loc, "io-control-spec contains a reference to a non-integer, "
1741 "non-scalar, or non-variable");
1742}
1743
1744template <typename A>
1745std::tuple<mlir::Value, mlir::Value, mlir::Value>
1746getFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1747 const A &stmt, mlir::Type strTy, mlir::Type lenTy,
1748 Fortran ::lower::StatementContext &stmtCtx) {
1749 if (stmt.format && !formatIsActuallyNamelist(*stmt.format))
1750 return genFormat(converter, loc, *stmt.format, strTy, lenTy, stmtCtx);
1751 return genFormat(converter, loc, *getIOControl<Fortran::parser::Format>(stmt),
1752 strTy, lenTy, stmtCtx);
1753}
1754template <>
1755std::tuple<mlir::Value, mlir::Value, mlir::Value>
1756getFormat<Fortran::parser::PrintStmt>(
1757 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1758 const Fortran::parser::PrintStmt &stmt, mlir::Type strTy, mlir::Type lenTy,
1759 Fortran::lower::StatementContext &stmtCtx) {
1760 return genFormat(converter, loc, std::get<Fortran::parser::Format>(stmt.t),
1761 strTy, lenTy, stmtCtx);
1762}
1763
1764/// Get a buffer for an internal file data transfer.
1765template <typename A>
1766std::tuple<mlir::Value, mlir::Value>
1767getBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1768 const A &stmt, mlir::Type strTy, mlir::Type lenTy,
1769 Fortran::lower::StatementContext &stmtCtx) {
1770 const Fortran::parser::IoUnit *iounit =
1771 stmt.iounit ? &*stmt.iounit : getIOControl<Fortran::parser::IoUnit>(stmt);
1772 if (iounit)
1773 if (auto *var = std::get_if<Fortran::parser::Variable>(&iounit->u))
1774 if (auto *expr = Fortran::semantics::GetExpr(*var))
1775 return genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx);
1776 llvm::report_fatal_error("failed to get IoUnit expr");
1777}
1778
1779static mlir::Value genIOUnitNumber(Fortran::lower::AbstractConverter &converter,
1780 mlir::Location loc,
1781 const Fortran::lower::SomeExpr *iounit,
1782 mlir::Type ty, ConditionSpecInfo &csi,
1783 Fortran::lower::StatementContext &stmtCtx) {
1784 auto &builder = converter.getFirOpBuilder();
1785 auto rawUnit = fir::getBase(converter.genExprValue(loc, iounit, stmtCtx));
1786 unsigned rawUnitWidth =
1787 mlir::cast<mlir::IntegerType>(rawUnit.getType()).getWidth();
1788 unsigned runtimeArgWidth = mlir::cast<mlir::IntegerType>(ty).getWidth();
1789 // The IO runtime supports `int` unit numbers, if the unit number may
1790 // overflow when passed to the IO runtime, check that the unit number is
1791 // in range before calling the BeginXXX.
1792 if (rawUnitWidth > runtimeArgWidth) {
1793 mlir::func::FuncOp check =
1794 rawUnitWidth <= 64
1795 ? fir::runtime::getIORuntimeFunc<mkIOKey(CheckUnitNumberInRange64)>(
1796 loc, builder)
1797 : fir::runtime::getIORuntimeFunc<mkIOKey(
1798 CheckUnitNumberInRange128)>(loc, builder);
1799 mlir::FunctionType funcTy = check.getFunctionType();
1800 llvm::SmallVector<mlir::Value> args;
1801 args.push_back(builder.createConvert(loc, funcTy.getInput(0), rawUnit));
1802 args.push_back(builder.createBool(loc, csi.hasErrorConditionSpec()));
1803 if (csi.ioMsg) {
1804 args.push_back(builder.createConvert(loc, funcTy.getInput(2),
1805 fir::getBase(*csi.ioMsg)));
1806 args.push_back(builder.createConvert(loc, funcTy.getInput(3),
1807 fir::getLen(*csi.ioMsg)));
1808 } else {
1809 args.push_back(builder.createNullConstant(loc, funcTy.getInput(2)));
1810 args.push_back(
1811 fir::factory::createZeroValue(builder, loc, funcTy.getInput(3)));
1812 }
1813 mlir::Value file = locToFilename(converter, loc, funcTy.getInput(4));
1814 mlir::Value line = locToLineNo(converter, loc, funcTy.getInput(5));
1815 args.push_back(file);
1816 args.push_back(line);
1817 auto checkCall = builder.create<fir::CallOp>(loc, check, args);
1818 if (csi.hasErrorConditionSpec()) {
1819 mlir::Value iostat = checkCall.getResult(0);
1820 mlir::Type iostatTy = iostat.getType();
1821 mlir::Value zero = fir::factory::createZeroValue(builder, loc, iostatTy);
1822 mlir::Value unitIsOK = builder.create<mlir::arith::CmpIOp>(
1823 loc, mlir::arith::CmpIPredicate::eq, iostat, zero);
1824 auto ifOp = builder.create<fir::IfOp>(loc, iostatTy, unitIsOK,
1825 /*withElseRegion=*/true);
1826 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
1827 builder.create<fir::ResultOp>(loc, iostat);
1828 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
1829 stmtCtx.pushScope();
1830 csi.bigUnitIfOp = ifOp;
1831 }
1832 }
1833 return builder.createConvert(loc, ty, rawUnit);
1834}
1835
1836static mlir::Value genIOUnit(Fortran::lower::AbstractConverter &converter,
1837 mlir::Location loc,
1838 const Fortran::parser::IoUnit *iounit,
1839 mlir::Type ty, ConditionSpecInfo &csi,
1840 Fortran::lower::StatementContext &stmtCtx,
1841 int defaultUnitNumber) {
1842 auto &builder = converter.getFirOpBuilder();
1843 if (iounit)
1844 if (auto *e =
1845 std::get_if<Fortran::common::Indirection<Fortran::parser::Expr>>(
1846 &iounit->u))
1847 return genIOUnitNumber(converter, loc, Fortran::semantics::GetExpr(*e),
1848 ty, csi, stmtCtx);
1849 return builder.create<mlir::arith::ConstantOp>(
1850 loc, builder.getIntegerAttr(ty, defaultUnitNumber));
1851}
1852
1853template <typename A>
1854static mlir::Value
1855getIOUnit(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1856 const A &stmt, mlir::Type ty, ConditionSpecInfo &csi,
1857 Fortran::lower::StatementContext &stmtCtx, int defaultUnitNumber) {
1858 const Fortran::parser::IoUnit *iounit =
1859 stmt.iounit ? &*stmt.iounit : getIOControl<Fortran::parser::IoUnit>(stmt);
1860 return genIOUnit(converter, loc, iounit, ty, csi, stmtCtx, defaultUnitNumber);
1861}
1862//===----------------------------------------------------------------------===//
1863// Generators for each IO statement type.
1864//===----------------------------------------------------------------------===//
1865
1866template <typename K, typename S>
1867static mlir::Value genBasicIOStmt(Fortran::lower::AbstractConverter &converter,
1868 const S &stmt) {
1869 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1870 Fortran::lower::StatementContext stmtCtx;
1871 mlir::Location loc = converter.getCurrentLocation();
1872 ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
1873 mlir::func::FuncOp beginFunc =
1874 fir::runtime::getIORuntimeFunc<K>(loc, builder);
1875 mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
1876 mlir::Value unit = genIOUnitNumber(
1877 converter, loc, getExpr<Fortran::parser::FileUnitNumber>(stmt),
1878 beginFuncTy.getInput(0), csi, stmtCtx);
1879 mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit);
1880 mlir::Value file = locToFilename(converter, loc, beginFuncTy.getInput(1));
1881 mlir::Value line = locToLineNo(converter, loc, beginFuncTy.getInput(2));
1882 auto call = builder.create<fir::CallOp>(loc, beginFunc,
1883 mlir::ValueRange{un, file, line});
1884 mlir::Value cookie = call.getResult(0);
1885 genConditionHandlerCall(converter, loc, cookie, stmt.v, csi);
1886 mlir::Value ok;
1887 auto insertPt = builder.saveInsertionPoint();
1888 threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok);
1889 builder.restoreInsertionPoint(insertPt);
1890 return genEndIO(converter, converter.getCurrentLocation(), cookie, csi,
1891 stmtCtx);
1892}
1893
1894mlir::Value Fortran::lower::genBackspaceStatement(
1895 Fortran::lower::AbstractConverter &converter,
1896 const Fortran::parser::BackspaceStmt &stmt) {
1897 return genBasicIOStmt<mkIOKey(BeginBackspace)>(converter, stmt);
1898}
1899
1900mlir::Value Fortran::lower::genEndfileStatement(
1901 Fortran::lower::AbstractConverter &converter,
1902 const Fortran::parser::EndfileStmt &stmt) {
1903 return genBasicIOStmt<mkIOKey(BeginEndfile)>(converter, stmt);
1904}
1905
1906mlir::Value
1907Fortran::lower::genFlushStatement(Fortran::lower::AbstractConverter &converter,
1908 const Fortran::parser::FlushStmt &stmt) {
1909 return genBasicIOStmt<mkIOKey(BeginFlush)>(converter, stmt);
1910}
1911
1912mlir::Value
1913Fortran::lower::genRewindStatement(Fortran::lower::AbstractConverter &converter,
1914 const Fortran::parser::RewindStmt &stmt) {
1915 return genBasicIOStmt<mkIOKey(BeginRewind)>(converter, stmt);
1916}
1917
1918static mlir::Value
1919genNewunitSpec(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1920 mlir::Value cookie,
1921 const std::list<Fortran::parser::ConnectSpec> &specList) {
1922 for (const auto &spec : specList)
1923 if (auto *newunit =
1924 std::get_if<Fortran::parser::ConnectSpec::Newunit>(&spec.u)) {
1925 Fortran::lower::StatementContext stmtCtx;
1926 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1927 mlir::func::FuncOp ioFunc =
1928 fir::runtime::getIORuntimeFunc<mkIOKey(GetNewUnit)>(loc, builder);
1929 mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1930 const auto *var = Fortran::semantics::GetExpr(newunit->v);
1931 mlir::Value addr = builder.createConvert(
1932 loc, ioFuncTy.getInput(1),
1933 fir::getBase(converter.genExprAddr(loc, var, stmtCtx)));
1934 auto kind = builder.createIntegerConstant(loc, ioFuncTy.getInput(2),
1935 var->GetType().value().kind());
1936 llvm::SmallVector<mlir::Value> ioArgs = {cookie, addr, kind};
1937 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1938 }
1939 llvm_unreachable("missing Newunit spec");
1940}
1941
1942mlir::Value
1943Fortran::lower::genOpenStatement(Fortran::lower::AbstractConverter &converter,
1944 const Fortran::parser::OpenStmt &stmt) {
1945 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1946 Fortran::lower::StatementContext stmtCtx;
1947 mlir::func::FuncOp beginFunc;
1948 llvm::SmallVector<mlir::Value> beginArgs;
1949 mlir::Location loc = converter.getCurrentLocation();
1950 ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
1951 bool hasNewunitSpec = false;
1952 if (hasSpec<Fortran::parser::FileUnitNumber>(stmt)) {
1953 beginFunc =
1954 fir::runtime::getIORuntimeFunc<mkIOKey(BeginOpenUnit)>(loc, builder);
1955 mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
1956 mlir::Value unit = genIOUnitNumber(
1957 converter, loc, getExpr<Fortran::parser::FileUnitNumber>(stmt),
1958 beginFuncTy.getInput(0), csi, stmtCtx);
1959 beginArgs.push_back(unit);
1960 beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(1)));
1961 beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(2)));
1962 } else {
1963 hasNewunitSpec = hasSpec<Fortran::parser::ConnectSpec::Newunit>(stmt);
1964 assert(hasNewunitSpec && "missing unit specifier");
1965 beginFunc =
1966 fir::runtime::getIORuntimeFunc<mkIOKey(BeginOpenNewUnit)>(loc, builder);
1967 mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
1968 beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(0)));
1969 beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(1)));
1970 }
1971 auto cookie =
1972 builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0);
1973 genConditionHandlerCall(converter, loc, cookie, stmt.v, csi);
1974 mlir::Value ok;
1975 auto insertPt = builder.saveInsertionPoint();
1976 threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok);
1977 if (hasNewunitSpec)
1978 genNewunitSpec(converter, loc, cookie, stmt.v);
1979 builder.restoreInsertionPoint(insertPt);
1980 return genEndIO(converter, loc, cookie, csi, stmtCtx);
1981}
1982
1983mlir::Value
1984Fortran::lower::genCloseStatement(Fortran::lower::AbstractConverter &converter,
1985 const Fortran::parser::CloseStmt &stmt) {
1986 return genBasicIOStmt<mkIOKey(BeginClose)>(converter, stmt);
1987}
1988
1989mlir::Value
1990Fortran::lower::genWaitStatement(Fortran::lower::AbstractConverter &converter,
1991 const Fortran::parser::WaitStmt &stmt) {
1992 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1993 Fortran::lower::StatementContext stmtCtx;
1994 mlir::Location loc = converter.getCurrentLocation();
1995 ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
1996 bool hasId = hasSpec<Fortran::parser::IdExpr>(stmt);
1997 mlir::func::FuncOp beginFunc =
1998 hasId
1999 ? fir::runtime::getIORuntimeFunc<mkIOKey(BeginWait)>(loc, builder)
2000 : fir::runtime::getIORuntimeFunc<mkIOKey(BeginWaitAll)>(loc, builder);
2001 mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
2002 mlir::Value unit = genIOUnitNumber(
2003 converter, loc, getExpr<Fortran::parser::FileUnitNumber>(stmt),
2004 beginFuncTy.getInput(0), csi, stmtCtx);
2005 llvm::SmallVector<mlir::Value> args{unit};
2006 if (hasId) {
2007 mlir::Value id = fir::getBase(converter.genExprValue(
2008 loc, getExpr<Fortran::parser::IdExpr>(stmt), stmtCtx));
2009 args.push_back(builder.createConvert(loc, beginFuncTy.getInput(1), id));
2010 args.push_back(locToFilename(converter, loc, beginFuncTy.getInput(2)));
2011 args.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(3)));
2012 } else {
2013 args.push_back(locToFilename(converter, loc, beginFuncTy.getInput(1)));
2014 args.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(2)));
2015 }
2016 auto cookie = builder.create<fir::CallOp>(loc, beginFunc, args).getResult(0);
2017 genConditionHandlerCall(converter, loc, cookie, stmt.v, csi);
2018 return genEndIO(converter, converter.getCurrentLocation(), cookie, csi,
2019 stmtCtx);
2020}
2021
2022//===----------------------------------------------------------------------===//
2023// Data transfer statements.
2024//
2025// There are several dimensions to the API with regard to data transfer
2026// statements that need to be considered.
2027//
2028// - input (READ) vs. output (WRITE, PRINT)
2029// - unformatted vs. formatted vs. list vs. namelist
2030// - synchronous vs. asynchronous
2031// - external vs. internal
2032//===----------------------------------------------------------------------===//
2033
2034// Get the begin data transfer IO function to call for the given values.
2035template <bool isInput>
2036mlir::func::FuncOp
2037getBeginDataTransferFunc(mlir::Location loc, fir::FirOpBuilder &builder,
2038 bool isFormatted, bool isListOrNml, bool isInternal,
2039 bool isInternalWithDesc) {
2040 if constexpr (isInput) {
2041 if (isFormatted || isListOrNml) {
2042 if (isInternal) {
2043 if (isInternalWithDesc) {
2044 if (isListOrNml)
2045 return fir::runtime::getIORuntimeFunc<mkIOKey(
2046 BeginInternalArrayListInput)>(loc, builder);
2047 return fir::runtime::getIORuntimeFunc<mkIOKey(
2048 BeginInternalArrayFormattedInput)>(loc, builder);
2049 }
2050 if (isListOrNml)
2051 return fir::runtime::getIORuntimeFunc<mkIOKey(
2052 BeginInternalListInput)>(loc, builder);
2053 return fir::runtime::getIORuntimeFunc<mkIOKey(
2054 BeginInternalFormattedInput)>(loc, builder);
2055 }
2056 if (isListOrNml)
2057 return fir::runtime::getIORuntimeFunc<mkIOKey(BeginExternalListInput)>(
2058 loc, builder);
2059 return fir::runtime::getIORuntimeFunc<mkIOKey(
2060 BeginExternalFormattedInput)>(loc, builder);
2061 }
2062 return fir::runtime::getIORuntimeFunc<mkIOKey(BeginUnformattedInput)>(
2063 loc, builder);
2064 } else {
2065 if (isFormatted || isListOrNml) {
2066 if (isInternal) {
2067 if (isInternalWithDesc) {
2068 if (isListOrNml)
2069 return fir::runtime::getIORuntimeFunc<mkIOKey(
2070 BeginInternalArrayListOutput)>(loc, builder);
2071 return fir::runtime::getIORuntimeFunc<mkIOKey(
2072 BeginInternalArrayFormattedOutput)>(loc, builder);
2073 }
2074 if (isListOrNml)
2075 return fir::runtime::getIORuntimeFunc<mkIOKey(
2076 BeginInternalListOutput)>(loc, builder);
2077 return fir::runtime::getIORuntimeFunc<mkIOKey(
2078 BeginInternalFormattedOutput)>(loc, builder);
2079 }
2080 if (isListOrNml)
2081 return fir::runtime::getIORuntimeFunc<mkIOKey(BeginExternalListOutput)>(
2082 loc, builder);
2083 return fir::runtime::getIORuntimeFunc<mkIOKey(
2084 BeginExternalFormattedOutput)>(loc, builder);
2085 }
2086 return fir::runtime::getIORuntimeFunc<mkIOKey(BeginUnformattedOutput)>(
2087 loc, builder);
2088 }
2089}
2090
2091/// Generate the arguments of a begin data transfer statement call.
2092template <bool hasIOCtrl, int defaultUnitNumber, typename A>
2093void genBeginDataTransferCallArgs(
2094 llvm::SmallVectorImpl<mlir::Value> &ioArgs,
2095 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2096 const A &stmt, mlir::FunctionType ioFuncTy, bool isFormatted,
2097 bool isListOrNml, [[maybe_unused]] bool isInternal,
2098 const std::optional<fir::ExtendedValue> &descRef, ConditionSpecInfo &csi,
2099 Fortran::lower::StatementContext &stmtCtx) {
2100 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2101 auto maybeGetFormatArgs = [&]() {
2102 if (!isFormatted || isListOrNml)
2103 return;
2104 std::tuple triple =
2105 getFormat(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()),
2106 ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx);
2107 mlir::Value address = std::get<0>(triple);
2108 mlir::Value length = std::get<1>(triple);
2109 if (length) {
2110 // Scalar format: string arg + length arg; no format descriptor arg
2111 ioArgs.push_back(address); // format string
2112 ioArgs.push_back(length); // format length
2113 ioArgs.push_back(
2114 builder.createNullConstant(loc, ioFuncTy.getInput(ioArgs.size())));
2115 return;
2116 }
2117 // Array format: no string arg, no length arg; format descriptor arg
2118 ioArgs.push_back(
2119 builder.createNullConstant(loc, ioFuncTy.getInput(ioArgs.size())));
2120 ioArgs.push_back(
2121 builder.createNullConstant(loc, ioFuncTy.getInput(ioArgs.size())));
2122 ioArgs.push_back( // format descriptor
2123 builder.createConvert(loc, ioFuncTy.getInput(ioArgs.size()), address));
2124 };
2125 if constexpr (hasIOCtrl) { // READ or WRITE
2126 if (isInternal) {
2127 // descriptor or scalar variable; maybe explicit format; scratch area
2128 if (descRef) {
2129 mlir::Value desc = builder.createBox(loc, *descRef);
2130 ioArgs.push_back(
2131 builder.createConvert(loc, ioFuncTy.getInput(ioArgs.size()), desc));
2132 } else {
2133 std::tuple<mlir::Value, mlir::Value> pair =
2134 getBuffer(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()),
2135 ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx);
2136 ioArgs.push_back(std::get<0>(pair)); // scalar character variable
2137 ioArgs.push_back(std::get<1>(pair)); // character length
2138 }
2139 maybeGetFormatArgs();
2140 ioArgs.push_back( // internal scratch area buffer
2141 getDefaultScratch(builder, loc, ioFuncTy.getInput(ioArgs.size())));
2142 ioArgs.push_back( // buffer length
2143 getDefaultScratchLen(builder, loc, ioFuncTy.getInput(ioArgs.size())));
2144 } else { // external IO - maybe explicit format; unit
2145 maybeGetFormatArgs();
2146 ioArgs.push_back(getIOUnit(converter, loc, stmt,
2147 ioFuncTy.getInput(ioArgs.size()), csi, stmtCtx,
2148 defaultUnitNumber));
2149 }
2150 } else { // PRINT - maybe explicit format; default unit
2151 maybeGetFormatArgs();
2152 ioArgs.push_back(builder.create<mlir::arith::ConstantOp>(
2153 loc, builder.getIntegerAttr(ioFuncTy.getInput(ioArgs.size()),
2154 defaultUnitNumber)));
2155 }
2156 // File name and line number are always the last two arguments.
2157 ioArgs.push_back(
2158 locToFilename(converter, loc, ioFuncTy.getInput(ioArgs.size())));
2159 ioArgs.push_back(
2160 locToLineNo(converter, loc, ioFuncTy.getInput(ioArgs.size())));
2161}
2162
2163template <bool isInput, bool hasIOCtrl = true, typename A>
2164static mlir::Value
2165genDataTransferStmt(Fortran::lower::AbstractConverter &converter,
2166 const A &stmt) {
2167 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2168 Fortran::lower::StatementContext stmtCtx;
2169 mlir::Location loc = converter.getCurrentLocation();
2170 const bool isFormatted = isDataTransferFormatted(stmt);
2171 const bool isList = isFormatted ? isDataTransferList(stmt) : false;
2172 const bool isInternal = isDataTransferInternal(stmt);
2173 std::optional<fir::ExtendedValue> descRef =
2174 isInternal ? maybeGetInternalIODescriptor(converter, loc, stmt, stmtCtx)
2175 : std::nullopt;
2176 const bool isInternalWithDesc = descRef.has_value();
2177 const bool isNml = isDataTransferNamelist(stmt);
2178 // Flang runtime currently implement asynchronous IO synchronously, so
2179 // asynchronous IO statements are lowered as regular IO statements
2180 // (except that GetAsynchronousId may be called to set the ID variable
2181 // and SetAsynchronous will be call to tell the runtime that this is supposed
2182 // to be (or not) an asynchronous IO statements).
2183
2184 // Generate an EnableHandlers call and remaining specifier calls.
2185 ConditionSpecInfo csi;
2186 if constexpr (hasIOCtrl) {
2187 csi = lowerErrorSpec(converter, loc, stmt.controls);
2188 }
2189
2190 // Generate the begin data transfer function call.
2191 mlir::func::FuncOp ioFunc = getBeginDataTransferFunc<isInput>(
2192 loc, builder, isFormatted, isList || isNml, isInternal,
2193 isInternalWithDesc);
2194 llvm::SmallVector<mlir::Value> ioArgs;
2195 genBeginDataTransferCallArgs<
2196 hasIOCtrl, isInput ? Fortran::runtime::io::DefaultInputUnit
2197 : Fortran::runtime::io::DefaultOutputUnit>(
2198 ioArgs, converter, loc, stmt, ioFunc.getFunctionType(), isFormatted,
2199 isList || isNml, isInternal, descRef, csi, stmtCtx);
2200 mlir::Value cookie =
2201 builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
2202
2203 auto insertPt = builder.saveInsertionPoint();
2204 mlir::Value ok;
2205 if constexpr (hasIOCtrl) {
2206 genConditionHandlerCall(converter, loc, cookie, stmt.controls, csi);
2207 threadSpecs(converter, loc, cookie, stmt.controls,
2208 csi.hasErrorConditionSpec(), ok);
2209 }
2210
2211 // Generate data transfer list calls.
2212 if constexpr (isInput) { // READ
2213 if (isNml)
2214 genNamelistIO(
2215 converter, cookie,
2216 fir::runtime::getIORuntimeFunc<mkIOKey(InputNamelist)>(loc, builder),
2217 *getIOControl<Fortran::parser::Name>(stmt)->symbol,
2218 csi.hasTransferConditionSpec(), ok, stmtCtx);
2219 else
2220 genInputItemList(converter, cookie, stmt.items, isFormatted,
2221 csi.hasTransferConditionSpec(), ok, /*inLoop=*/false);
2222 } else if constexpr (std::is_same_v<A, Fortran::parser::WriteStmt>) {
2223 if (isNml)
2224 genNamelistIO(
2225 converter, cookie,
2226 fir::runtime::getIORuntimeFunc<mkIOKey(OutputNamelist)>(loc, builder),
2227 *getIOControl<Fortran::parser::Name>(stmt)->symbol,
2228 csi.hasTransferConditionSpec(), ok, stmtCtx);
2229 else
2230 genOutputItemList(converter, cookie, stmt.items, isFormatted,
2231 csi.hasTransferConditionSpec(), ok,
2232 /*inLoop=*/false);
2233 } else { // PRINT
2234 genOutputItemList(converter, cookie, std::get<1>(stmt.t), isFormatted,
2235 csi.hasTransferConditionSpec(), ok,
2236 /*inLoop=*/false);
2237 }
2238
2239 builder.restoreInsertionPoint(insertPt);
2240 if constexpr (hasIOCtrl) {
2241 for (const auto &spec : stmt.controls)
2242 if (const auto *size =
2243 std::get_if<Fortran::parser::IoControlSpec::Size>(&spec.u)) {
2244 // This call is not conditional on the current IO status (ok) because
2245 // the size needs to be filled even if some error condition
2246 // (end-of-file...) was met during the input statement (in which case
2247 // the runtime may return zero for the size read).
2248 genIOGetVar<mkIOKey(GetSize)>(converter, loc, cookie, *size);
2249 } else if (const auto *idVar =
2250 std::get_if<Fortran::parser::IdVariable>(&spec.u)) {
2251 genIOGetVar<mkIOKey(GetAsynchronousId)>(converter, loc, cookie, *idVar);
2252 }
2253 }
2254 // Generate end statement call/s.
2255 mlir::Value result = genEndIO(converter, loc, cookie, csi, stmtCtx);
2256 stmtCtx.finalizeAndReset();
2257 return result;
2258}
2259
2260void Fortran::lower::genPrintStatement(
2261 Fortran::lower::AbstractConverter &converter,
2262 const Fortran::parser::PrintStmt &stmt) {
2263 // PRINT does not take an io-control-spec. It only has a format specifier, so
2264 // it is a simplified case of WRITE.
2265 genDataTransferStmt</*isInput=*/false, /*ioCtrl=*/false>(converter, stmt);
2266}
2267
2268mlir::Value
2269Fortran::lower::genWriteStatement(Fortran::lower::AbstractConverter &converter,
2270 const Fortran::parser::WriteStmt &stmt) {
2271 return genDataTransferStmt</*isInput=*/false>(converter, stmt);
2272}
2273
2274mlir::Value
2275Fortran::lower::genReadStatement(Fortran::lower::AbstractConverter &converter,
2276 const Fortran::parser::ReadStmt &stmt) {
2277 return genDataTransferStmt</*isInput=*/true>(converter, stmt);
2278}
2279
2280/// Get the file expression from the inquire spec list. Also return if the
2281/// expression is a file name.
2282static std::pair<const Fortran::lower::SomeExpr *, bool>
2283getInquireFileExpr(const std::list<Fortran::parser::InquireSpec> *stmt) {
2284 if (!stmt)
2285 return {nullptr, /*filename?=*/false};
2286 for (const Fortran::parser::InquireSpec &spec : *stmt) {
2287 if (auto *f = std::get_if<Fortran::parser::FileUnitNumber>(&spec.u))
2288 return {Fortran::semantics::GetExpr(*f), /*filename?=*/false};
2289 if (auto *f = std::get_if<Fortran::parser::FileNameExpr>(&spec.u))
2290 return {Fortran::semantics::GetExpr(*f), /*filename?=*/true};
2291 }
2292 // semantics should have already caught this condition
2293 llvm::report_fatal_error("inquire spec must have a file");
2294}
2295
2296/// Generate calls to the four distinct INQUIRE subhandlers. An INQUIRE may
2297/// return values of type CHARACTER, INTEGER, or LOGICAL. There is one
2298/// additional special case for INQUIRE with both PENDING and ID specifiers.
2299template <typename A>
2300static mlir::Value genInquireSpec(Fortran::lower::AbstractConverter &converter,
2301 mlir::Location loc, mlir::Value cookie,
2302 mlir::Value idExpr, const A &var,
2303 Fortran::lower::StatementContext &stmtCtx) {
2304 // default case: do nothing
2305 return {};
2306}
2307/// Specialization for CHARACTER.
2308template <>
2309mlir::Value genInquireSpec<Fortran::parser::InquireSpec::CharVar>(
2310 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2311 mlir::Value cookie, mlir::Value idExpr,
2312 const Fortran::parser::InquireSpec::CharVar &var,
2313 Fortran::lower::StatementContext &stmtCtx) {
2314 // IOMSG is handled with exception conditions
2315 if (std::get<Fortran::parser::InquireSpec::CharVar::Kind>(var.t) ==
2316 Fortran::parser::InquireSpec::CharVar::Kind::Iomsg)
2317 return {};
2318 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2319 mlir::func::FuncOp specFunc =
2320 fir::runtime::getIORuntimeFunc<mkIOKey(InquireCharacter)>(loc, builder);
2321 mlir::FunctionType specFuncTy = specFunc.getFunctionType();
2322 const auto *varExpr = Fortran::semantics::GetExpr(
2323 std::get<Fortran::parser::ScalarDefaultCharVariable>(var.t));
2324 fir::ExtendedValue str = converter.genExprAddr(loc, varExpr, stmtCtx);
2325 llvm::SmallVector<mlir::Value> args = {
2326 builder.createConvert(loc, specFuncTy.getInput(0), cookie),
2327 builder.createIntegerConstant(
2328 loc, specFuncTy.getInput(1),
2329 Fortran::runtime::io::HashInquiryKeyword(std::string{
2330 Fortran::parser::InquireSpec::CharVar::EnumToString(
2331 std::get<Fortran::parser::InquireSpec::CharVar::Kind>(var.t))}
2332 .c_str())),
2333 builder.createConvert(loc, specFuncTy.getInput(2), fir::getBase(str)),
2334 builder.createConvert(loc, specFuncTy.getInput(3), fir::getLen(str))};
2335 return builder.create<fir::CallOp>(loc, specFunc, args).getResult(0);
2336}
2337/// Specialization for INTEGER.
2338template <>
2339mlir::Value genInquireSpec<Fortran::parser::InquireSpec::IntVar>(
2340 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2341 mlir::Value cookie, mlir::Value idExpr,
2342 const Fortran::parser::InquireSpec::IntVar &var,
2343 Fortran::lower::StatementContext &stmtCtx) {
2344 // IOSTAT is handled with exception conditions
2345 if (std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t) ==
2346 Fortran::parser::InquireSpec::IntVar::Kind::Iostat)
2347 return {};
2348 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2349 mlir::func::FuncOp specFunc =
2350 fir::runtime::getIORuntimeFunc<mkIOKey(InquireInteger64)>(loc, builder);
2351 mlir::FunctionType specFuncTy = specFunc.getFunctionType();
2352 const auto *varExpr = Fortran::semantics::GetExpr(
2353 std::get<Fortran::parser::ScalarIntVariable>(var.t));
2354 mlir::Value addr = fir::getBase(converter.genExprAddr(loc, varExpr, stmtCtx));
2355 mlir::Type eleTy = fir::dyn_cast_ptrEleTy(addr.getType());
2356 if (!eleTy)
2357 fir::emitFatalError(loc,
2358 "internal error: expected a memory reference type");
2359 auto width = mlir::cast<mlir::IntegerType>(eleTy).getWidth();
2360 mlir::IndexType idxTy = builder.getIndexType();
2361 mlir::Value kind = builder.createIntegerConstant(loc, idxTy, width / 8);
2362 llvm::SmallVector<mlir::Value> args = {
2363 builder.createConvert(loc, specFuncTy.getInput(0), cookie),
2364 builder.createIntegerConstant(
2365 loc, specFuncTy.getInput(1),
2366 Fortran::runtime::io::HashInquiryKeyword(std::string{
2367 Fortran::parser::InquireSpec::IntVar::EnumToString(
2368 std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t))}
2369 .c_str())),
2370 builder.createConvert(loc, specFuncTy.getInput(2), addr),
2371 builder.createConvert(loc, specFuncTy.getInput(3), kind)};
2372 return builder.create<fir::CallOp>(loc, specFunc, args).getResult(0);
2373}
2374/// Specialization for LOGICAL and (PENDING + ID).
2375template <>
2376mlir::Value genInquireSpec<Fortran::parser::InquireSpec::LogVar>(
2377 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2378 mlir::Value cookie, mlir::Value idExpr,
2379 const Fortran::parser::InquireSpec::LogVar &var,
2380 Fortran::lower::StatementContext &stmtCtx) {
2381 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2382 auto logVarKind = std::get<Fortran::parser::InquireSpec::LogVar::Kind>(var.t);
2383 bool pendId =
2384 idExpr &&
2385 logVarKind == Fortran::parser::InquireSpec::LogVar::Kind::Pending;
2386 mlir::func::FuncOp specFunc =
2387 pendId ? fir::runtime::getIORuntimeFunc<mkIOKey(InquirePendingId)>(
2388 loc, builder)
2389 : fir::runtime::getIORuntimeFunc<mkIOKey(InquireLogical)>(loc,
2390 builder);
2391 mlir::FunctionType specFuncTy = specFunc.getFunctionType();
2392 mlir::Value addr = fir::getBase(converter.genExprAddr(
2393 loc,
2394 Fortran::semantics::GetExpr(
2395 std::get<Fortran::parser::Scalar<
2396 Fortran::parser::Logical<Fortran::parser::Variable>>>(var.t)),
2397 stmtCtx));
2398 llvm::SmallVector<mlir::Value> args = {
2399 builder.createConvert(loc, specFuncTy.getInput(0), cookie)};
2400 if (pendId)
2401 args.push_back(builder.createConvert(loc, specFuncTy.getInput(1), idExpr));
2402 else
2403 args.push_back(builder.createIntegerConstant(
2404 loc, specFuncTy.getInput(1),
2405 Fortran::runtime::io::HashInquiryKeyword(std::string{
2406 Fortran::parser::InquireSpec::LogVar::EnumToString(logVarKind)}
2407 .c_str())));
2408 args.push_back(builder.createConvert(loc, specFuncTy.getInput(2), addr));
2409 auto call = builder.create<fir::CallOp>(loc, specFunc, args);
2410 boolRefToLogical(loc, builder, addr);
2411 return call.getResult(0);
2412}
2413
2414/// If there is an IdExpr in the list of inquire-specs, then lower it and return
2415/// the resulting Value. Otherwise, return null.
2416static mlir::Value
2417lowerIdExpr(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2418 const std::list<Fortran::parser::InquireSpec> &ispecs,
2419 Fortran::lower::StatementContext &stmtCtx) {
2420 for (const Fortran::parser::InquireSpec &spec : ispecs)
2421 if (mlir::Value v = Fortran::common::visit(
2422 Fortran::common::visitors{
2423 [&](const Fortran::parser::IdExpr &idExpr) {
2424 return fir::getBase(converter.genExprValue(
2425 loc, Fortran::semantics::GetExpr(idExpr), stmtCtx));
2426 },
2427 [](const auto &) { return mlir::Value{}; }},
2428 spec.u))
2429 return v;
2430 return {};
2431}
2432
2433/// For each inquire-spec, build the appropriate call, threading the cookie.
2434static void threadInquire(Fortran::lower::AbstractConverter &converter,
2435 mlir::Location loc, mlir::Value cookie,
2436 const std::list<Fortran::parser::InquireSpec> &ispecs,
2437 bool checkResult, mlir::Value &ok,
2438 Fortran::lower::StatementContext &stmtCtx) {
2439 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2440 mlir::Value idExpr = lowerIdExpr(converter, loc, ispecs, stmtCtx);
2441 for (const Fortran::parser::InquireSpec &spec : ispecs) {
2442 makeNextConditionalOn(builder, loc, checkResult, ok);
2443 ok = Fortran::common::visit(Fortran::common::visitors{[&](const auto &x) {
2444 return genInquireSpec(converter, loc, cookie,
2445 idExpr, x, stmtCtx);
2446 }},
2447 spec.u);
2448 }
2449}
2450
2451mlir::Value Fortran::lower::genInquireStatement(
2452 Fortran::lower::AbstractConverter &converter,
2453 const Fortran::parser::InquireStmt &stmt) {
2454 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2455 Fortran::lower::StatementContext stmtCtx;
2456 mlir::Location loc = converter.getCurrentLocation();
2457 mlir::func::FuncOp beginFunc;
2458 llvm::SmallVector<mlir::Value> beginArgs;
2459 const auto *list =
2460 std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u);
2461 auto exprPair = getInquireFileExpr(list);
2462 auto inquireFileUnit = [&]() -> bool {
2463 return exprPair.first && !exprPair.second;
2464 };
2465 auto inquireFileName = [&]() -> bool {
2466 return exprPair.first && exprPair.second;
2467 };
2468
2469 ConditionSpecInfo csi =
2470 list ? lowerErrorSpec(converter, loc, *list) : ConditionSpecInfo{};
2471
2472 // Make one of three BeginInquire calls.
2473 if (inquireFileUnit()) {
2474 // Inquire by unit -- [UNIT=]file-unit-number.
2475 beginFunc =
2476 fir::runtime::getIORuntimeFunc<mkIOKey(BeginInquireUnit)>(loc, builder);
2477 mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
2478 mlir::Value unit = genIOUnitNumber(converter, loc, exprPair.first,
2479 beginFuncTy.getInput(0), csi, stmtCtx);
2480 beginArgs = {unit, locToFilename(converter, loc, beginFuncTy.getInput(1)),
2481 locToLineNo(converter, loc, beginFuncTy.getInput(2))};
2482 } else if (inquireFileName()) {
2483 // Inquire by file -- FILE=file-name-expr.
2484 beginFunc =
2485 fir::runtime::getIORuntimeFunc<mkIOKey(BeginInquireFile)>(loc, builder);
2486 mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
2487 fir::ExtendedValue file =
2488 converter.genExprAddr(loc, exprPair.first, stmtCtx);
2489 beginArgs = {
2490 builder.createConvert(loc, beginFuncTy.getInput(0), fir::getBase(file)),
2491 builder.createConvert(loc, beginFuncTy.getInput(1), fir::getLen(file)),
2492 locToFilename(converter, loc, beginFuncTy.getInput(2)),
2493 locToLineNo(converter, loc, beginFuncTy.getInput(3))};
2494 } else {
2495 // Inquire by output list -- IOLENGTH=scalar-int-variable.
2496 const auto *ioLength =
2497 std::get_if<Fortran::parser::InquireStmt::Iolength>(&stmt.u);
2498 assert(ioLength && "must have an IOLENGTH specifier");
2499 beginFunc = fir::runtime::getIORuntimeFunc<mkIOKey(BeginInquireIoLength)>(
2500 loc, builder);
2501 mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
2502 beginArgs = {locToFilename(converter, loc, beginFuncTy.getInput(0)),
2503 locToLineNo(converter, loc, beginFuncTy.getInput(1))};
2504 auto cookie =
2505 builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0);
2506 mlir::Value ok;
2507 genOutputItemList(
2508 converter, cookie,
2509 std::get<std::list<Fortran::parser::OutputItem>>(ioLength->t),
2510 /*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false);
2511 auto *ioLengthVar = Fortran::semantics::GetExpr(
2512 std::get<Fortran::parser::ScalarIntVariable>(ioLength->t));
2513 mlir::Value ioLengthVarAddr =
2514 fir::getBase(converter.genExprAddr(loc, ioLengthVar, stmtCtx));
2515 llvm::SmallVector<mlir::Value> args = {cookie};
2516 mlir::Value length =
2517 builder
2518 .create<fir::CallOp>(
2519 loc,
2520 fir::runtime::getIORuntimeFunc<mkIOKey(GetIoLength)>(loc,
2521 builder),
2522 args)
2523 .getResult(0);
2524 mlir::Value length1 =
2525 builder.createConvert(loc, converter.genType(*ioLengthVar), length);
2526 builder.create<fir::StoreOp>(loc, length1, ioLengthVarAddr);
2527 return genEndIO(converter, loc, cookie, csi, stmtCtx);
2528 }
2529
2530 // Common handling for inquire by unit or file.
2531 assert(list && "inquire-spec list must be present");
2532 auto cookie =
2533 builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0);
2534 genConditionHandlerCall(converter, loc, cookie, *list, csi);
2535 // Handle remaining arguments in specifier list.
2536 mlir::Value ok;
2537 auto insertPt = builder.saveInsertionPoint();
2538 threadInquire(converter, loc, cookie, *list, csi.hasErrorConditionSpec(), ok,
2539 stmtCtx);
2540 builder.restoreInsertionPoint(insertPt);
2541 // Generate end statement call.
2542 return genEndIO(converter, loc, cookie, csi, stmtCtx);
2543}
2544

source code of flang/lib/Lower/IO.cpp