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