//===-- IO.cpp -- IO statement lowering -----------------------------------===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // //===----------------------------------------------------------------------===// // // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ // //===----------------------------------------------------------------------===// #include "flang/Lower/IO.h" #include "flang/Common/uint128.h" #include "flang/Lower/Allocatable.h" #include "flang/Lower/Bridge.h" #include "flang/Lower/ConvertExpr.h" #include "flang/Lower/ConvertVariable.h" #include "flang/Lower/PFTBuilder.h" #include "flang/Lower/Runtime.h" #include "flang/Lower/StatementContext.h" #include "flang/Lower/Support/Utils.h" #include "flang/Lower/Todo.h" #include "flang/Lower/VectorSubscripts.h" #include "flang/Optimizer/Builder/Character.h" #include "flang/Optimizer/Builder/Complex.h" #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" #include "flang/Optimizer/Support/FIRContext.h" #include "flang/Parser/parse-tree.h" #include "flang/Runtime/io-api.h" #include "flang/Semantics/tools.h" #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" #define DEBUG_TYPE "flang-lower-io" // Define additional runtime type models specific to IO. namespace fir::runtime { template <> constexpr TypeBuilderFunc getModel() { return getModel(); } template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return fir::ReferenceType::get(mlir::TupleType::get(context)); }; } template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return mlir::IntegerType::get(context, 8 * sizeof(Fortran::runtime::io::Iostat)); }; } } // namespace fir::runtime using namespace Fortran::runtime::io; #define mkIOKey(X) FirmkKey(IONAME(X)) namespace Fortran::lower { /// Static table of IO runtime calls /// /// This logical map contains the name and type builder function for each IO /// runtime function listed in the tuple. This table is fully constructed at /// compile-time. Use the `mkIOKey` macro to access the table. static constexpr std::tuple< mkIOKey(BeginInternalArrayListOutput), mkIOKey(BeginInternalArrayListInput), mkIOKey(BeginInternalArrayFormattedOutput), mkIOKey(BeginInternalArrayFormattedInput), mkIOKey(BeginInternalListOutput), mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalFormattedOutput), mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginExternalListOutput), mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalFormattedOutput), mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginUnformattedOutput), mkIOKey(BeginUnformattedInput), mkIOKey(BeginAsynchronousOutput), mkIOKey(BeginAsynchronousInput), mkIOKey(BeginWait), mkIOKey(BeginWaitAll), mkIOKey(BeginClose), mkIOKey(BeginFlush), mkIOKey(BeginBackspace), mkIOKey(BeginEndfile), mkIOKey(BeginRewind), mkIOKey(BeginOpenUnit), mkIOKey(BeginOpenNewUnit), mkIOKey(BeginInquireUnit), mkIOKey(BeginInquireFile), mkIOKey(BeginInquireIoLength), mkIOKey(EnableHandlers), mkIOKey(SetAdvance), mkIOKey(SetBlank), mkIOKey(SetDecimal), mkIOKey(SetDelim), mkIOKey(SetPad), mkIOKey(SetPos), mkIOKey(SetRec), mkIOKey(SetRound), mkIOKey(SetSign), mkIOKey(OutputNamelist), mkIOKey(InputNamelist), mkIOKey(OutputDescriptor), mkIOKey(InputDescriptor), mkIOKey(OutputUnformattedBlock), mkIOKey(InputUnformattedBlock), mkIOKey(OutputInteger8), mkIOKey(OutputInteger16), mkIOKey(OutputInteger32), mkIOKey(OutputInteger64), #ifdef __SIZEOF_INT128__ mkIOKey(OutputInteger128), #endif mkIOKey(InputInteger), mkIOKey(OutputReal32), mkIOKey(InputReal32), mkIOKey(OutputReal64), mkIOKey(InputReal64), mkIOKey(OutputComplex32), mkIOKey(InputComplex32), mkIOKey(OutputComplex64), mkIOKey(InputComplex64), mkIOKey(OutputAscii), mkIOKey(InputAscii), mkIOKey(OutputLogical), mkIOKey(InputLogical), mkIOKey(SetAccess), mkIOKey(SetAction), mkIOKey(SetAsynchronous), mkIOKey(SetCarriagecontrol), mkIOKey(SetEncoding), mkIOKey(SetForm), mkIOKey(SetPosition), mkIOKey(SetRecl), mkIOKey(SetStatus), mkIOKey(SetFile), mkIOKey(GetNewUnit), mkIOKey(GetSize), mkIOKey(GetIoLength), mkIOKey(GetIoMsg), mkIOKey(InquireCharacter), mkIOKey(InquireLogical), mkIOKey(InquirePendingId), mkIOKey(InquireInteger64), mkIOKey(EndIoStatement)> newIOTable; } // namespace Fortran::lower namespace { /// IO statements may require exceptional condition handling. A statement that /// encounters an exceptional condition may branch to a label given on an ERR /// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT /// specifier variable may be set to a value that indicates some condition, /// and an IOMSG specifier variable may be set to a description of a condition. struct ConditionSpecInfo { const Fortran::lower::SomeExpr *ioStatExpr{}; const Fortran::lower::SomeExpr *ioMsgExpr{}; bool hasErr{}; bool hasEnd{}; bool hasEor{}; /// Check for any condition specifier that applies to specifier processing. bool hasErrorConditionSpec() const { return ioStatExpr != nullptr || hasErr; } /// Check for any condition specifier that applies to data transfer items /// in a PRINT, READ, WRITE, or WAIT statement. (WAIT may be irrelevant.) bool hasTransferConditionSpec() const { return hasErrorConditionSpec() || hasEnd || hasEor; } /// Check for any condition specifier, including IOMSG. bool hasAnyConditionSpec() const { return hasTransferConditionSpec() || ioMsgExpr != nullptr; } }; } // namespace template static void genIoLoop(Fortran::lower::AbstractConverter &converter, mlir::Value cookie, const D &ioImpliedDo, bool isFormatted, bool checkResult, mlir::Value &ok, bool inLoop, Fortran::lower::StatementContext &stmtCtx); /// Helper function to retrieve the name of the IO function given the key `A` template static constexpr const char *getName() { return std::get(Fortran::lower::newIOTable).name; } /// Helper function to retrieve the type model signature builder of the IO /// function as defined by the key `A` template static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() { return std::get(Fortran::lower::newIOTable).getTypeModel(); } inline int64_t getLength(mlir::Type argTy) { return argTy.cast().getShape()[0]; } /// Get (or generate) the MLIR FuncOp for a given IO runtime function. template static mlir::func::FuncOp getIORuntimeFunc(mlir::Location loc, fir::FirOpBuilder &builder) { llvm::StringRef name = getName(); mlir::func::FuncOp func = builder.getNamedFunction(name); if (func) return func; auto funTy = getTypeModel()(builder.getContext()); func = builder.createFunction(loc, name, funTy); func->setAttr("fir.runtime", builder.getUnitAttr()); func->setAttr("fir.io", builder.getUnitAttr()); return func; } /// Generate calls to end an IO statement. Return the IOSTAT value, if any. /// It is the caller's responsibility to generate branches on that value. static mlir::Value genEndIO(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const ConditionSpecInfo &csi, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (csi.ioMsgExpr) { mlir::func::FuncOp getIoMsg = getIORuntimeFunc(loc, builder); fir::ExtendedValue ioMsgVar = converter.genExprAddr(csi.ioMsgExpr, stmtCtx, loc); builder.create( loc, getIoMsg, mlir::ValueRange{ cookie, builder.createConvert(loc, getIoMsg.getFunctionType().getInput(1), fir::getBase(ioMsgVar)), builder.createConvert(loc, getIoMsg.getFunctionType().getInput(2), fir::getLen(ioMsgVar))}); } mlir::func::FuncOp endIoStatement = getIORuntimeFunc(loc, builder); auto call = builder.create(loc, endIoStatement, mlir::ValueRange{cookie}); if (csi.ioStatExpr) { mlir::Value ioStatVar = fir::getBase(converter.genExprAddr(csi.ioStatExpr, stmtCtx, loc)); mlir::Value ioStatResult = builder.createConvert( loc, converter.genType(*csi.ioStatExpr), call.getResult(0)); builder.create(loc, ioStatResult, ioStatVar); } return csi.hasTransferConditionSpec() ? call.getResult(0) : mlir::Value{}; } /// Make the next call in the IO statement conditional on runtime result `ok`. /// If a call returns `ok==false`, further suboperation calls for an IO /// statement will be skipped. This may generate branch heavy, deeply nested /// conditionals for IO statements with a large number of suboperations. static void makeNextConditionalOn(fir::FirOpBuilder &builder, mlir::Location loc, bool checkResult, mlir::Value ok, bool inLoop = false) { if (!checkResult || !ok) // Either no IO calls need to be checked, or this will be the first call. return; // A previous IO call for a statement returned the bool `ok`. If this call // is in a fir.iterate_while loop, the result must be propagated up to the // loop scope as an extra ifOp result. (The propagation is done in genIoLoop.) mlir::TypeRange resTy; if (inLoop) resTy = builder.getI1Type(); auto ifOp = builder.create(loc, resTy, ok, /*withElseRegion=*/inLoop); builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); } /// Retrieve or generate a runtime description of NAMELIST group `symbol`. /// The form of the description is defined in runtime header file namelist.h. /// Static descriptors are generated for global objects; local descriptors for /// local objects. If all descriptors are static, the NamelistGroup is static. static mlir::Value getNamelistGroup(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &symbol, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); std::string groupMangleName = converter.mangleName(symbol); if (auto group = builder.getNamedGlobal(groupMangleName)) return builder.create(loc, group.resultType(), group.getSymbol()); const auto &details = symbol.GetUltimate().get(); mlir::MLIRContext *context = builder.getContext(); mlir::StringAttr linkOnce = builder.createLinkOnceLinkage(); mlir::IndexType idxTy = builder.getIndexType(); mlir::IntegerType sizeTy = builder.getIntegerType(8 * sizeof(std::size_t)); fir::ReferenceType charRefTy = fir::ReferenceType::get(builder.getIntegerType(8)); fir::ReferenceType descRefTy = fir::ReferenceType::get(fir::BoxType::get(mlir::NoneType::get(context))); fir::SequenceType listTy = fir::SequenceType::get( details.objects().size(), mlir::TupleType::get(context, {charRefTy, descRefTy})); mlir::TupleType groupTy = mlir::TupleType::get( context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy)}); auto stringAddress = [&](const Fortran::semantics::Symbol &symbol) { return fir::factory::createStringLiteral(builder, loc, symbol.name().ToString() + '\0'); }; // Define object names, and static descriptors for global objects. bool groupIsLocal = false; stringAddress(symbol); for (const Fortran::semantics::Symbol &s : details.objects()) { stringAddress(s); if (!Fortran::lower::symbolIsGlobal(s)) { groupIsLocal = true; continue; } // We know we have a global item. It it's not a pointer or allocatable, // create a static pointer to it. if (!IsAllocatableOrPointer(s)) { std::string mangleName = converter.mangleName(s) + ".desc"; if (builder.getNamedGlobal(mangleName)) continue; const auto expr = Fortran::evaluate::AsGenericExpr(s); fir::BoxType boxTy = fir::BoxType::get(fir::PointerType::get(converter.genType(s))); auto descFunc = [&](fir::FirOpBuilder &b) { auto box = Fortran::lower::genInitialDataTarget(converter, loc, boxTy, *expr); b.create(loc, box); }; builder.createGlobalConstant(loc, boxTy, mangleName, descFunc, linkOnce); } } // Define the list of Items. mlir::Value listAddr = groupIsLocal ? builder.create(loc, listTy) : mlir::Value{}; std::string listMangleName = groupMangleName + ".list"; auto listFunc = [&](fir::FirOpBuilder &builder) { mlir::Value list = builder.create(loc, listTy); mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0); mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1); llvm::SmallVector idx = {mlir::Attribute{}, mlir::Attribute{}}; size_t n = 0; for (const Fortran::semantics::Symbol &s : details.objects()) { idx[0] = builder.getIntegerAttr(idxTy, n); idx[1] = zero; mlir::Value nameAddr = builder.createConvert(loc, charRefTy, fir::getBase(stringAddress(s))); list = builder.create(loc, listTy, list, nameAddr, builder.getArrayAttr(idx)); idx[1] = one; mlir::Value descAddr; // Items that we created end in ".desc". std::string suffix = IsAllocatableOrPointer(s) ? "" : ".desc"; if (auto desc = builder.getNamedGlobal(converter.mangleName(s) + suffix)) { descAddr = builder.create(loc, desc.resultType(), desc.getSymbol()); } else { const auto expr = Fortran::evaluate::AsGenericExpr(s); fir::ExtendedValue exv = converter.genExprAddr(*expr, stmtCtx); mlir::Type type = fir::getBase(exv).getType(); if (mlir::Type baseTy = fir::dyn_cast_ptrOrBoxEleTy(type)) type = baseTy; fir::BoxType boxType = fir::BoxType::get(fir::PointerType::get(type)); descAddr = builder.createTemporary(loc, boxType); fir::MutableBoxValue box = fir::MutableBoxValue(descAddr, {}, {}); fir::factory::associateMutableBox(builder, loc, box, exv, /*lbounds=*/llvm::None); } descAddr = builder.createConvert(loc, descRefTy, descAddr); list = builder.create(loc, listTy, list, descAddr, builder.getArrayAttr(idx)); ++n; } if (groupIsLocal) builder.create(loc, list, listAddr); else builder.create(loc, list); }; if (groupIsLocal) listFunc(builder); else builder.createGlobalConstant(loc, listTy, listMangleName, listFunc, linkOnce); // Define the group. mlir::Value groupAddr = groupIsLocal ? builder.create(loc, groupTy) : mlir::Value{}; auto groupFunc = [&](fir::FirOpBuilder &builder) { mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0); mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1); mlir::IntegerAttr two = builder.getIntegerAttr(idxTy, 2); mlir::Value group = builder.create(loc, groupTy); mlir::Value nameAddr = builder.createConvert( loc, charRefTy, fir::getBase(stringAddress(symbol))); group = builder.create(loc, groupTy, group, nameAddr, builder.getArrayAttr(zero)); mlir::Value itemCount = builder.createIntegerConstant(loc, sizeTy, details.objects().size()); group = builder.create(loc, groupTy, group, itemCount, builder.getArrayAttr(one)); if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName)) listAddr = builder.create(loc, list.resultType(), list.getSymbol()); assert(listAddr && "missing namelist object list"); group = builder.create(loc, groupTy, group, listAddr, builder.getArrayAttr(two)); if (groupIsLocal) builder.create(loc, group, groupAddr); else builder.create(loc, group); }; if (groupIsLocal) { groupFunc(builder); } else { fir::GlobalOp group = builder.createGlobal(loc, groupTy, groupMangleName, /*isConst=*/true, groupFunc, linkOnce); groupAddr = builder.create(loc, group.resultType(), group.getSymbol()); } assert(groupAddr && "missing namelist group result"); return groupAddr; } /// Generate a namelist IO call. static void genNamelistIO(Fortran::lower::AbstractConverter &converter, mlir::Value cookie, mlir::func::FuncOp funcOp, Fortran::semantics::Symbol &symbol, bool checkResult, mlir::Value &ok, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); makeNextConditionalOn(builder, loc, checkResult, ok); mlir::Type argType = funcOp.getFunctionType().getInput(1); mlir::Value groupAddr = getNamelistGroup(converter, symbol, stmtCtx); groupAddr = builder.createConvert(loc, argType, groupAddr); llvm::SmallVector args = {cookie, groupAddr}; ok = builder.create(loc, funcOp, args).getResult(0); } /// Get the output function to call for a value of the given type. static mlir::func::FuncOp getOutputFunc(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Type type, bool isFormatted) { if (!isFormatted) return getIORuntimeFunc(loc, builder); if (auto ty = type.dyn_cast()) { switch (ty.getWidth()) { case 1: return getIORuntimeFunc(loc, builder); case 8: return getIORuntimeFunc(loc, builder); case 16: return getIORuntimeFunc(loc, builder); case 32: return getIORuntimeFunc(loc, builder); case 64: return getIORuntimeFunc(loc, builder); #ifdef __SIZEOF_INT128__ case 128: return getIORuntimeFunc(loc, builder); #endif } llvm_unreachable("unknown OutputInteger kind"); } if (auto ty = type.dyn_cast()) { if (auto width = ty.getWidth(); width == 32) return getIORuntimeFunc(loc, builder); else if (width == 64) return getIORuntimeFunc(loc, builder); } auto kindMap = fir::getKindMapping(builder.getModule()); if (auto ty = type.dyn_cast()) { // COMPLEX(KIND=k) corresponds to a pair of REAL(KIND=k). auto width = kindMap.getRealBitsize(ty.getFKind()); if (width == 32) return getIORuntimeFunc(loc, builder); else if (width == 64) return getIORuntimeFunc(loc, builder); } if (type.isa()) return getIORuntimeFunc(loc, builder); if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) { // TODO: What would it mean if the default CHARACTER KIND is set to a wide // character encoding scheme? How do we handle UTF-8? Is it a distinct KIND // value? For now, assume that if the default CHARACTER KIND is 8 bit, // then it is an ASCII string and UTF-8 is unsupported. auto asciiKind = kindMap.defaultCharacterKind(); if (kindMap.getCharacterBitsize(asciiKind) == 8 && fir::factory::CharacterExprHelper::getCharacterKind(type) == asciiKind) return getIORuntimeFunc(loc, builder); } return getIORuntimeFunc(loc, builder); } /// Generate a sequence of output data transfer calls. static void genOutputItemList(Fortran::lower::AbstractConverter &converter, mlir::Value cookie, const std::list &items, bool isFormatted, bool checkResult, mlir::Value &ok, bool inLoop, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); for (const Fortran::parser::OutputItem &item : items) { if (const auto &impliedDo = std::get_if<1>(&item.u)) { genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult, ok, inLoop, stmtCtx); continue; } auto &pExpr = std::get(item.u); mlir::Location loc = converter.genLocation(pExpr.source); makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); const auto *expr = Fortran::semantics::GetExpr(pExpr); if (!expr) fir::emitFatalError(loc, "internal error: could not get evaluate::Expr"); mlir::Type itemTy = converter.genType(*expr); mlir::func::FuncOp outputFunc = getOutputFunc(loc, builder, itemTy, isFormatted); mlir::Type argType = outputFunc.getFunctionType().getInput(1); assert((isFormatted || argType.isa()) && "expect descriptor for unformatted IO runtime"); llvm::SmallVector outputFuncArgs = {cookie}; fir::factory::CharacterExprHelper helper{builder, loc}; if (argType.isa()) { mlir::Value box = fir::getBase(converter.genExprBox(*expr, stmtCtx, loc)); outputFuncArgs.push_back(builder.createConvert(loc, argType, box)); } else if (helper.isCharacterScalar(itemTy)) { fir::ExtendedValue exv = converter.genExprAddr(expr, stmtCtx, loc); // scalar allocatable/pointer may also get here, not clear if // genExprAddr will lower them as CharBoxValue or BoxValue. if (!exv.getCharBox()) llvm::report_fatal_error( "internal error: scalar character not in CharBox"); outputFuncArgs.push_back(builder.createConvert( loc, outputFunc.getFunctionType().getInput(1), fir::getBase(exv))); outputFuncArgs.push_back(builder.createConvert( loc, outputFunc.getFunctionType().getInput(2), fir::getLen(exv))); } else { fir::ExtendedValue itemBox = converter.genExprValue(expr, stmtCtx, loc); mlir::Value itemValue = fir::getBase(itemBox); if (fir::isa_complex(itemTy)) { auto parts = fir::factory::Complex{builder, loc}.extractParts(itemValue); outputFuncArgs.push_back(parts.first); outputFuncArgs.push_back(parts.second); } else { itemValue = builder.createConvert(loc, argType, itemValue); outputFuncArgs.push_back(itemValue); } } ok = builder.create(loc, outputFunc, outputFuncArgs) .getResult(0); } } /// Get the input function to call for a value of the given type. static mlir::func::FuncOp getInputFunc(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Type type, bool isFormatted) { if (!isFormatted) return getIORuntimeFunc(loc, builder); if (auto ty = type.dyn_cast()) return ty.getWidth() == 1 ? getIORuntimeFunc(loc, builder) : getIORuntimeFunc(loc, builder); if (auto ty = type.dyn_cast()) { if (auto width = ty.getWidth(); width <= 32) return getIORuntimeFunc(loc, builder); else if (width <= 64) return getIORuntimeFunc(loc, builder); } auto kindMap = fir::getKindMapping(builder.getModule()); if (auto ty = type.dyn_cast()) { auto width = kindMap.getRealBitsize(ty.getFKind()); if (width <= 32) return getIORuntimeFunc(loc, builder); else if (width <= 64) return getIORuntimeFunc(loc, builder); } if (type.isa()) return getIORuntimeFunc(loc, builder); if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) { auto asciiKind = kindMap.defaultCharacterKind(); if (kindMap.getCharacterBitsize(asciiKind) == 8 && fir::factory::CharacterExprHelper::getCharacterKind(type) == asciiKind) return getIORuntimeFunc(loc, builder); } return getIORuntimeFunc(loc, builder); } /// Interpret the lowest byte of a LOGICAL and store that value into the full /// storage of the LOGICAL. The load, convert, and store effectively (sign or /// zero) extends the lowest byte into the full LOGICAL value storage, as the /// runtime is unaware of the LOGICAL value's actual bit width (it was passed /// as a `bool&` to the runtime in order to be set). static void boolRefToLogical(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value addr) { auto boolType = builder.getRefType(builder.getI1Type()); auto boolAddr = builder.createConvert(loc, boolType, addr); auto boolValue = builder.create(loc, boolAddr); auto logicalType = fir::unwrapPassByRefType(addr.getType()); // The convert avoid making any assumptions about how LOGICALs are actually // represented (it might end-up being either a signed or zero extension). auto logicalValue = builder.createConvert(loc, logicalType, boolValue); builder.create(loc, logicalValue, addr); } static mlir::Value createIoRuntimeCallForItem(mlir::Location loc, fir::FirOpBuilder &builder, mlir::func::FuncOp inputFunc, mlir::Value cookie, const fir::ExtendedValue &item) { mlir::Type argType = inputFunc.getFunctionType().getInput(1); llvm::SmallVector inputFuncArgs = {cookie}; if (argType.isa()) { mlir::Value box = fir::getBase(item); assert(box.getType().isa() && "must be previously emboxed"); inputFuncArgs.push_back(builder.createConvert(loc, argType, box)); } else { mlir::Value itemAddr = fir::getBase(item); mlir::Type itemTy = fir::unwrapPassByRefType(itemAddr.getType()); inputFuncArgs.push_back(builder.createConvert(loc, argType, itemAddr)); fir::factory::CharacterExprHelper charHelper{builder, loc}; if (charHelper.isCharacterScalar(itemTy)) { mlir::Value len = fir::getLen(item); inputFuncArgs.push_back(builder.createConvert( loc, inputFunc.getFunctionType().getInput(2), len)); } else if (itemTy.isa()) { inputFuncArgs.push_back(builder.create( loc, builder.getI32IntegerAttr( itemTy.cast().getWidth() / 8))); } } auto call = builder.create(loc, inputFunc, inputFuncArgs); auto itemAddr = fir::getBase(item); auto itemTy = fir::unwrapRefType(itemAddr.getType()); if (itemTy.isa()) boolRefToLogical(loc, builder, itemAddr); return call.getResult(0); } /// Generate a sequence of input data transfer calls. static void genInputItemList(Fortran::lower::AbstractConverter &converter, mlir::Value cookie, const std::list &items, bool isFormatted, bool checkResult, mlir::Value &ok, bool inLoop, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); for (const Fortran::parser::InputItem &item : items) { if (const auto &impliedDo = std::get_if<1>(&item.u)) { genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult, ok, inLoop, stmtCtx); continue; } auto &pVar = std::get(item.u); mlir::Location loc = converter.genLocation(pVar.GetSource()); makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); const auto *expr = Fortran::semantics::GetExpr(pVar); if (!expr) fir::emitFatalError(loc, "internal error: could not get evaluate::Expr"); if (Fortran::evaluate::HasVectorSubscript(*expr)) { auto vectorSubscriptBox = Fortran::lower::genVectorSubscriptBox(loc, converter, stmtCtx, *expr); mlir::func::FuncOp inputFunc = getInputFunc( loc, builder, vectorSubscriptBox.getElementType(), isFormatted); const bool mustBox = inputFunc.getFunctionType().getInput(1).isa(); if (!checkResult) { auto elementalGenerator = [&](const fir::ExtendedValue &element) { createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, mustBox ? builder.createBox(loc, element) : element); }; vectorSubscriptBox.loopOverElements(builder, loc, elementalGenerator); } else { auto elementalGenerator = [&](const fir::ExtendedValue &element) -> mlir::Value { return createIoRuntimeCallForItem( loc, builder, inputFunc, cookie, mustBox ? builder.createBox(loc, element) : element); }; if (!ok) ok = builder.createBool(loc, true); ok = vectorSubscriptBox.loopOverElementsWhile(builder, loc, elementalGenerator, ok); } continue; } mlir::Type itemTy = converter.genType(*expr); mlir::func::FuncOp inputFunc = getInputFunc(loc, builder, itemTy, isFormatted); auto itemExv = inputFunc.getFunctionType().getInput(1).isa() ? converter.genExprBox(*expr, stmtCtx, loc) : converter.genExprAddr(expr, stmtCtx, loc); ok = createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, itemExv); } } /// Generate an io-implied-do loop. template static void genIoLoop(Fortran::lower::AbstractConverter &converter, mlir::Value cookie, const D &ioImpliedDo, bool isFormatted, bool checkResult, mlir::Value &ok, bool inLoop, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); const auto &itemList = std::get<0>(ioImpliedDo.t); const auto &control = std::get<1>(ioImpliedDo.t); const auto &loopSym = *control.name.thing.thing.symbol; mlir::Value loopVar = converter.getSymbolAddress(loopSym); auto genControlValue = [&](const Fortran::parser::ScalarIntExpr &expr) { mlir::Value v = fir::getBase( converter.genExprValue(*Fortran::semantics::GetExpr(expr), stmtCtx)); return builder.createConvert(loc, builder.getIndexType(), v); }; mlir::Value lowerValue = genControlValue(control.lower); mlir::Value upperValue = genControlValue(control.upper); mlir::Value stepValue = control.step.has_value() ? genControlValue(*control.step) : builder.create(loc, 1); auto genItemList = [&](const D &ioImpliedDo) { Fortran::lower::StatementContext loopCtx; if constexpr (std::is_same_v) genInputItemList(converter, cookie, itemList, isFormatted, checkResult, ok, /*inLoop=*/true, loopCtx); else genOutputItemList(converter, cookie, itemList, isFormatted, checkResult, ok, /*inLoop=*/true, loopCtx); }; if (!checkResult) { // No IO call result checks - the loop is a fir.do_loop op. auto doLoopOp = builder.create( loc, lowerValue, upperValue, stepValue, /*unordered=*/false, /*finalCountValue=*/true); builder.setInsertionPointToStart(doLoopOp.getBody()); mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym), doLoopOp.getInductionVar()); builder.create(loc, lcv, loopVar); genItemList(ioImpliedDo); builder.setInsertionPointToEnd(doLoopOp.getBody()); mlir::Value result = builder.create( loc, doLoopOp.getInductionVar(), doLoopOp.getStep()); builder.create(loc, result); builder.setInsertionPointAfter(doLoopOp); // The loop control variable may be used after the loop. lcv = builder.createConvert(loc, converter.genType(loopSym), doLoopOp.getResult(0)); builder.create(loc, lcv, loopVar); return; } // Check IO call results - the loop is a fir.iterate_while op. if (!ok) ok = builder.createBool(loc, true); auto iterWhileOp = builder.create( loc, lowerValue, upperValue, stepValue, ok, /*finalCountValue*/ true); builder.setInsertionPointToStart(iterWhileOp.getBody()); mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym), iterWhileOp.getInductionVar()); builder.create(loc, lcv, loopVar); ok = iterWhileOp.getIterateVar(); mlir::Value falseValue = builder.createIntegerConstant(loc, builder.getI1Type(), 0); genItemList(ioImpliedDo); // Unwind nested IO call scopes, filling in true and false ResultOp's. for (mlir::Operation *op = builder.getBlock()->getParentOp(); mlir::isa(op); op = op->getBlock()->getParentOp()) { auto ifOp = mlir::dyn_cast(op); mlir::Operation *lastOp = &ifOp.getThenRegion().front().back(); builder.setInsertionPointAfter(lastOp); // The primary ifOp result is the result of an IO call or loop. if (mlir::isa(*lastOp)) builder.create(loc, lastOp->getResult(0)); else builder.create(loc, ok); // loop result // The else branch propagates an early exit false result. builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); builder.create(loc, falseValue); } builder.setInsertionPointToEnd(iterWhileOp.getBody()); mlir::OpResult iterateResult = builder.getBlock()->back().getResult(0); mlir::Value inductionResult0 = iterWhileOp.getInductionVar(); auto inductionResult1 = builder.create( loc, inductionResult0, iterWhileOp.getStep()); auto inductionResult = builder.create( loc, iterateResult, inductionResult1, inductionResult0); llvm::SmallVector results = {inductionResult, iterateResult}; builder.create(loc, results); ok = iterWhileOp.getResult(1); builder.setInsertionPointAfter(iterWhileOp); // The loop control variable may be used after the loop. lcv = builder.createConvert(loc, converter.genType(loopSym), iterWhileOp.getResult(0)); builder.create(loc, lcv, loopVar); } //===----------------------------------------------------------------------===// // Default argument generation. //===----------------------------------------------------------------------===// static mlir::Value locToFilename(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Type toType) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); return builder.createConvert(loc, toType, fir::factory::locationToFilename(builder, loc)); } static mlir::Value locToLineNo(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Type toType) { return fir::factory::locationToLineNo(converter.getFirOpBuilder(), loc, toType); } static mlir::Value getDefaultScratch(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type toType) { mlir::Value null = builder.create( loc, builder.getI64IntegerAttr(0)); return builder.createConvert(loc, toType, null); } static mlir::Value getDefaultScratchLen(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type toType) { return builder.create( loc, builder.getIntegerAttr(toType, 0)); } /// Generate a reference to a buffer and the length of buffer given /// a character expression. An array expression will be cast to scalar /// character as long as they are contiguous. static std::tuple genBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::SomeExpr &expr, mlir::Type strTy, mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); fir::ExtendedValue exprAddr = converter.genExprAddr(expr, stmtCtx); fir::factory::CharacterExprHelper helper(builder, loc); using ValuePair = std::pair; auto [buff, len] = exprAddr.match( [&](const fir::CharBoxValue &x) -> ValuePair { return {x.getBuffer(), x.getLen()}; }, [&](const fir::CharArrayBoxValue &x) -> ValuePair { fir::CharBoxValue scalar = helper.toScalarCharacter(x); return {scalar.getBuffer(), scalar.getLen()}; }, [&](const fir::BoxValue &) -> ValuePair { // May need to copy before after IO to handle contiguous // aspect. Not sure descriptor can get here though. TODO(loc, "character descriptor to contiguous buffer"); }, [&](const auto &) -> ValuePair { llvm::report_fatal_error( "internal error: IO buffer is not a character"); }); buff = builder.createConvert(loc, strTy, buff); len = builder.createConvert(loc, lenTy, len); return {buff, len}; } /// Lower a string literal. Many arguments to the runtime are conveyed as /// Fortran CHARACTER literals. template static std::tuple lowerStringLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc, Fortran::lower::StatementContext &stmtCtx, const A &syntax, mlir::Type strTy, mlir::Type lenTy, mlir::Type ty2 = {}) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); auto *expr = Fortran::semantics::GetExpr(syntax); if (!expr) fir::emitFatalError(loc, "internal error: null semantic expr in IO"); auto [buff, len] = genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx); mlir::Value kind; if (ty2) { auto kindVal = expr->GetType().value().kind(); kind = builder.create( loc, builder.getIntegerAttr(ty2, kindVal)); } return {buff, len, kind}; } /// Pass the body of the FORMAT statement in as if it were a CHARACTER literal /// constant. NB: This is the prescribed manner in which the front-end passes /// this information to lowering. static std::tuple lowerSourceTextAsStringLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc, llvm::StringRef text, mlir::Type strTy, mlir::Type lenTy) { text = text.drop_front(text.find('(')); text = text.take_front(text.rfind(')') + 1); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Value addrGlobalStringLit = fir::getBase(fir::factory::createStringLiteral(builder, loc, text)); mlir::Value buff = builder.createConvert(loc, strTy, addrGlobalStringLit); mlir::Value len = builder.createIntegerConstant(loc, lenTy, text.size()); return {buff, len, mlir::Value{}}; } //===----------------------------------------------------------------------===// // Handle IO statement specifiers. // These are threaded together for a single statement via the passed cookie. //===----------------------------------------------------------------------===// /// Generic to build an integral argument to the runtime. template mlir::Value genIntIOOption(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const B &spec) { Fortran::lower::StatementContext localStatementCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); mlir::Value expr = fir::getBase(converter.genExprValue( Fortran::semantics::GetExpr(spec.v), localStatementCtx, loc)); mlir::Value val = builder.createConvert(loc, ioFuncTy.getInput(1), expr); llvm::SmallVector ioArgs = {cookie, val}; return builder.create(loc, ioFunc, ioArgs).getResult(0); } /// Generic to build a string argument to the runtime. This passes a CHARACTER /// as a pointer to the buffer and a LEN parameter. template mlir::Value genCharIOOption(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const B &spec) { Fortran::lower::StatementContext localStatementCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); std::tuple tup = lowerStringLit(converter, loc, localStatementCtx, spec, ioFuncTy.getInput(1), ioFuncTy.getInput(2)); llvm::SmallVector ioArgs = {cookie, std::get<0>(tup), std::get<1>(tup)}; return builder.create(loc, ioFunc, ioArgs).getResult(0); } template mlir::Value genIOOption(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const A &spec) { // These specifiers are processed in advance elsewhere - skip them here. using PreprocessedSpecs = std::tuple; static_assert(Fortran::common::HasMember, "missing genIOOPtion specialization"); return {}; } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::FileNameExpr &spec) { Fortran::lower::StatementContext localStatementCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); // has an extra KIND argument mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); std::tuple tup = lowerStringLit(converter, loc, localStatementCtx, spec, ioFuncTy.getInput(1), ioFuncTy.getInput(2)); llvm::SmallVector ioArgs{cookie, std::get<0>(tup), std::get<1>(tup)}; return builder.create(loc, ioFunc, ioArgs).getResult(0); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::ConnectSpec::CharExpr &spec) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp ioFunc; switch (std::get(spec.t)) { case Fortran::parser::ConnectSpec::CharExpr::Kind::Access: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Action: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Asynchronous: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Blank: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Decimal: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Delim: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Encoding: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Form: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Pad: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Position: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Round: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Sign: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Carriagecontrol: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::ConnectSpec::CharExpr::Kind::Convert: TODO(loc, "CONVERT not part of the runtime::io interface"); case Fortran::parser::ConnectSpec::CharExpr::Kind::Dispose: TODO(loc, "DISPOSE not part of the runtime::io interface"); } Fortran::lower::StatementContext localStatementCtx; mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); std::tuple tup = lowerStringLit(converter, loc, localStatementCtx, std::get(spec.t), ioFuncTy.getInput(1), ioFuncTy.getInput(2)); llvm::SmallVector ioArgs = {cookie, std::get<0>(tup), std::get<1>(tup)}; return builder.create(loc, ioFunc, ioArgs).getResult(0); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::ConnectSpec::Recl &spec) { return genIntIOOption(converter, loc, cookie, spec); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::StatusExpr &spec) { return genCharIOOption(converter, loc, cookie, spec.v); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::IoControlSpec::CharExpr &spec) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp ioFunc; switch (std::get(spec.t)) { case Fortran::parser::IoControlSpec::CharExpr::Kind::Advance: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::IoControlSpec::CharExpr::Kind::Blank: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::IoControlSpec::CharExpr::Kind::Decimal: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::IoControlSpec::CharExpr::Kind::Delim: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::IoControlSpec::CharExpr::Kind::Pad: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::IoControlSpec::CharExpr::Kind::Round: ioFunc = getIORuntimeFunc(loc, builder); break; case Fortran::parser::IoControlSpec::CharExpr::Kind::Sign: ioFunc = getIORuntimeFunc(loc, builder); break; } Fortran::lower::StatementContext localStatementCtx; mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); std::tuple tup = lowerStringLit(converter, loc, localStatementCtx, std::get(spec.t), ioFuncTy.getInput(1), ioFuncTy.getInput(2)); llvm::SmallVector ioArgs = {cookie, std::get<0>(tup), std::get<1>(tup)}; return builder.create(loc, ioFunc, ioArgs).getResult(0); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::IoControlSpec::Asynchronous &spec) { return genCharIOOption(converter, loc, cookie, spec.v); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::IdVariable &spec) { TODO(loc, "asynchronous ID not implemented"); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::IoControlSpec::Pos &spec) { return genIntIOOption(converter, loc, cookie, spec); } template <> mlir::Value genIOOption( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const Fortran::parser::IoControlSpec::Rec &spec) { return genIntIOOption(converter, loc, cookie, spec); } /// Generate runtime call to query the read size after an input statement if /// the statement has SIZE control-spec. template static void genIOReadSize(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const A &specList, bool checkResult) { // This call is not conditional on the current IO status (ok) because the size // needs to be filled even if some error condition (end-of-file...) was met // during the input statement (in which case the runtime may return zero for // the size read). for (const auto &spec : specList) if (const auto *size = std::get_if(&spec.u)) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); auto sizeValue = builder.create(loc, ioFunc, mlir::ValueRange{cookie}) .getResult(0); Fortran::lower::StatementContext localStatementCtx; fir::ExtendedValue var = converter.genExprAddr( Fortran::semantics::GetExpr(size->v), localStatementCtx, loc); mlir::Value varAddr = fir::getBase(var); mlir::Type varType = fir::unwrapPassByRefType(varAddr.getType()); mlir::Value sizeCast = builder.createConvert(loc, varType, sizeValue); builder.create(loc, sizeCast, varAddr); break; } } //===----------------------------------------------------------------------===// // Gather IO statement condition specifier information (if any). //===----------------------------------------------------------------------===// template static bool hasX(const A &list) { for (const auto &spec : list) if (std::holds_alternative(spec.u)) return true; return false; } template static bool hasSpec(const A &stmt) { return hasX(stmt.v); } /// Get the sought expression from the specifier list. template static const Fortran::lower::SomeExpr *getExpr(const A &stmt) { for (const auto &spec : stmt.v) if (auto *f = std::get_if(&spec.u)) return Fortran::semantics::GetExpr(f->v); llvm::report_fatal_error("must have a file unit"); } /// For each specifier, build the appropriate call, threading the cookie. template static void threadSpecs(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const A &specList, bool checkResult, mlir::Value &ok) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); for (const auto &spec : specList) { makeNextConditionalOn(builder, loc, checkResult, ok); ok = std::visit( Fortran::common::visitors{ [&](const Fortran::parser::IoControlSpec::Size &x) -> mlir::Value { // Size must be queried after the related READ runtime calls, not // before. return ok; }, [&](const Fortran::parser::ConnectSpec::Newunit &x) -> mlir::Value { // Newunit must be queried after OPEN specifier runtime calls // that may fail to avoid modifying the newunit variable if // there is an error. return ok; }, [&](const auto &x) { return genIOOption(converter, loc, cookie, x); }}, spec.u); } } /// Most IO statements allow one or more of five optional exception condition /// handling specifiers: ERR, EOR, END, IOSTAT, and IOMSG. The first three /// cause control flow to transfer to another statement. The final two return /// information from the runtime, via a variable, about the nature of the /// condition that occurred. These condition specifiers are handled here. template static void genConditionHandlerCall(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const A &specList, ConditionSpecInfo &csi) { for (const auto &spec : specList) { std::visit( Fortran::common::visitors{ [&](const Fortran::parser::StatVariable &var) { csi.ioStatExpr = Fortran::semantics::GetExpr(var); }, [&](const Fortran::parser::InquireSpec::IntVar &var) { if (std::get(var.t) == Fortran::parser::InquireSpec::IntVar::Kind::Iostat) csi.ioStatExpr = Fortran::semantics::GetExpr( std::get(var.t)); }, [&](const Fortran::parser::MsgVariable &var) { csi.ioMsgExpr = Fortran::semantics::GetExpr(var); }, [&](const Fortran::parser::InquireSpec::CharVar &var) { if (std::get( var.t) == Fortran::parser::InquireSpec::CharVar::Kind::Iomsg) csi.ioMsgExpr = Fortran::semantics::GetExpr( std::get( var.t)); }, [&](const Fortran::parser::EndLabel &) { csi.hasEnd = true; }, [&](const Fortran::parser::EorLabel &) { csi.hasEor = true; }, [&](const Fortran::parser::ErrLabel &) { csi.hasErr = true; }, [](const auto &) {}}, spec.u); } if (!csi.hasAnyConditionSpec()) return; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp enableHandlers = getIORuntimeFunc(loc, builder); mlir::Type boolType = enableHandlers.getFunctionType().getInput(1); auto boolValue = [&](bool specifierIsPresent) { return builder.create( loc, builder.getIntegerAttr(boolType, specifierIsPresent)); }; llvm::SmallVector ioArgs = {cookie, boolValue(csi.ioStatExpr != nullptr), boolValue(csi.hasErr), boolValue(csi.hasEnd), boolValue(csi.hasEor), boolValue(csi.ioMsgExpr != nullptr)}; builder.create(loc, enableHandlers, ioArgs); } //===----------------------------------------------------------------------===// // Data transfer helpers //===----------------------------------------------------------------------===// template static bool hasIOControl(const A &stmt) { return hasX(stmt.controls); } template static const auto *getIOControl(const A &stmt) { for (const auto &spec : stmt.controls) if (const auto *result = std::get_if(&spec.u)) return result; return static_cast(nullptr); } /// Returns true iff the expression in the parse tree is not really a format but /// rather a namelist group. template static bool formatIsActuallyNamelist(const A &format) { if (auto *e = std::get_if(&format.u)) { auto *expr = Fortran::semantics::GetExpr(*e); if (const Fortran::semantics::Symbol *y = Fortran::evaluate::UnwrapWholeSymbolDataRef(*expr)) return y->has(); } return false; } template static bool isDataTransferFormatted(const A &stmt) { if (stmt.format) return !formatIsActuallyNamelist(*stmt.format); return hasIOControl(stmt); } template <> constexpr bool isDataTransferFormatted( const Fortran::parser::PrintStmt &) { return true; // PRINT is always formatted } template static bool isDataTransferList(const A &stmt) { if (stmt.format) return std::holds_alternative(stmt.format->u); if (auto *mem = getIOControl(stmt)) return std::holds_alternative(mem->u); return false; } template <> bool isDataTransferList( const Fortran::parser::PrintStmt &stmt) { return std::holds_alternative( std::get(stmt.t).u); } template static bool isDataTransferInternal(const A &stmt) { if (stmt.iounit.has_value()) return std::holds_alternative(stmt.iounit->u); if (auto *unit = getIOControl(stmt)) return std::holds_alternative(unit->u); return false; } template <> constexpr bool isDataTransferInternal( const Fortran::parser::PrintStmt &) { return false; } /// If the variable `var` is an array or of a KIND other than the default /// (normally 1), then a descriptor is required by the runtime IO API. This /// condition holds even in F77 sources. static llvm::Optional getVariableBufferRequiredDescriptor( Fortran::lower::AbstractConverter &converter, const Fortran::parser::Variable &var, Fortran::lower::StatementContext &stmtCtx) { fir::ExtendedValue varBox = converter.genExprAddr(var.typedExpr->v.value(), stmtCtx); fir::KindTy defCharKind = converter.getKindMap().defaultCharacterKind(); mlir::Value varAddr = fir::getBase(varBox); if (fir::factory::CharacterExprHelper::getCharacterOrSequenceKind( varAddr.getType()) != defCharKind) return varBox; if (fir::factory::CharacterExprHelper::isArray(varAddr.getType())) return varBox; return llvm::None; } template static llvm::Optional maybeGetInternalIODescriptor(Fortran::lower::AbstractConverter &converter, const A &stmt, Fortran::lower::StatementContext &stmtCtx) { if (stmt.iounit.has_value()) if (auto *var = std::get_if(&stmt.iounit->u)) return getVariableBufferRequiredDescriptor(converter, *var, stmtCtx); if (auto *unit = getIOControl(stmt)) if (auto *var = std::get_if(&unit->u)) return getVariableBufferRequiredDescriptor(converter, *var, stmtCtx); return llvm::None; } template <> inline llvm::Optional maybeGetInternalIODescriptor( Fortran::lower::AbstractConverter &, const Fortran::parser::PrintStmt &, Fortran::lower::StatementContext &) { return llvm::None; } template static bool isDataTransferAsynchronous(mlir::Location loc, const A &stmt) { if (auto *asynch = getIOControl(stmt)) { // FIXME: should contain a string of YES or NO TODO(loc, "asynchronous transfers not implemented in runtime"); } return false; } template <> bool isDataTransferAsynchronous( mlir::Location, const Fortran::parser::PrintStmt &) { return false; } template static bool isDataTransferNamelist(const A &stmt) { if (stmt.format) return formatIsActuallyNamelist(*stmt.format); return hasIOControl(stmt); } template <> constexpr bool isDataTransferNamelist( const Fortran::parser::PrintStmt &) { return false; } /// Lowers a format statment that uses an assigned variable label reference as /// a select operation to allow for run-time selection of the format statement. static std::tuple lowerReferenceAsStringSelect(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::SomeExpr &expr, mlir::Type strTy, mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) { // Possible optimization TODO: Instead of inlining a selectOp every time there // is a variable reference to a format statement, a function with the selectOp // could be generated to reduce code size. It is not clear if such an // optimization would be deployed very often or improve the object code // beyond, say, what GVN/GCM might produce. // Create the requisite blocks to inline a selectOp. fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Block *startBlock = builder.getBlock(); mlir::Block *endBlock = startBlock->splitBlock(builder.getInsertionPoint()); mlir::Block *block = startBlock->splitBlock(builder.getInsertionPoint()); builder.setInsertionPointToEnd(block); llvm::SmallVector indexList; llvm::SmallVector blockList; auto symbol = GetLastSymbol(&expr); Fortran::lower::pft::LabelSet labels; [[maybe_unused]] auto foundLabelSet = converter.lookupLabelSet(*symbol, labels); assert(foundLabelSet && "Label not found in map"); for (auto label : labels) { indexList.push_back(label); auto *eval = converter.lookupLabel(label); assert(eval && "Label is missing from the table"); llvm::StringRef text = toStringRef(eval->position); mlir::Value stringRef; mlir::Value stringLen; if (eval->isA()) { assert(text.find('(') != llvm::StringRef::npos && "FORMAT is unexpectedly ill-formed"); // This is a format statement, so extract the spec from the text. std::tuple stringLit = lowerSourceTextAsStringLit(converter, loc, text, strTy, lenTy); stringRef = std::get<0>(stringLit); stringLen = std::get<1>(stringLit); } else { // This is not a format statement, so use null. stringRef = builder.createConvert( loc, strTy, builder.createIntegerConstant(loc, builder.getIndexType(), 0)); stringLen = builder.createIntegerConstant(loc, lenTy, 0); } // Pass the format string reference and the string length out of the select // statement. llvm::SmallVector args = {stringRef, stringLen}; builder.create(loc, endBlock, args); // Add block to the list of cases and make a new one. blockList.push_back(block); block = block->splitBlock(builder.getInsertionPoint()); builder.setInsertionPointToEnd(block); } // Create the unit case which should result in an error. auto *unitBlock = block->splitBlock(builder.getInsertionPoint()); builder.setInsertionPointToEnd(unitBlock); // Crash the program. builder.create(loc); // Add unit case to the select statement. blockList.push_back(unitBlock); // Lower the selectOp. builder.setInsertionPointToEnd(startBlock); auto label = fir::getBase(converter.genExprValue(&expr, stmtCtx, loc)); builder.create(loc, label, indexList, blockList); builder.setInsertionPointToEnd(endBlock); endBlock->addArgument(strTy, loc); endBlock->addArgument(lenTy, loc); // Handle and return the string reference and length selected by the selectOp. auto buff = endBlock->getArgument(0); auto len = endBlock->getArgument(1); return {buff, len, mlir::Value{}}; } /// Generate a reference to a format string. There are four cases - a format /// statement label, a character format expression, an integer that holds the /// label of a format statement, and the * case. The first three are done here. /// The * case is done elsewhere. static std::tuple genFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::parser::Format &format, mlir::Type strTy, mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) { if (const auto *label = std::get_if(&format.u)) { // format statement label auto eval = converter.lookupLabel(*label); assert(eval && "FORMAT not found in PROCEDURE"); return lowerSourceTextAsStringLit( converter, loc, toStringRef(eval->position), strTy, lenTy); } const auto *pExpr = std::get_if(&format.u); assert(pExpr && "missing format expression"); auto e = Fortran::semantics::GetExpr(*pExpr); if (Fortran::semantics::ExprHasTypeCategory( *e, Fortran::common::TypeCategory::Character)) // character expression return lowerStringLit(converter, loc, stmtCtx, *pExpr, strTy, lenTy); if (Fortran::semantics::ExprHasTypeCategory( *e, Fortran::common::TypeCategory::Integer) && e->Rank() == 0 && Fortran::evaluate::UnwrapWholeSymbolDataRef(*e)) { // Treat as a scalar integer variable containing an ASSIGN label. return lowerReferenceAsStringSelect(converter, loc, *e, strTy, lenTy, stmtCtx); } // Legacy extension: it is possible that `*e` is not a scalar INTEGER // variable containing a label value. The output appears to be the source text // that initialized the variable? Needs more investigatation. TODO(loc, "io-control-spec contains a reference to a non-integer, " "non-scalar, or non-variable"); } template std::tuple getFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const A &stmt, mlir::Type strTy, mlir::Type lenTy, Fortran ::lower::StatementContext &stmtCtx) { if (stmt.format && !formatIsActuallyNamelist(*stmt.format)) return genFormat(converter, loc, *stmt.format, strTy, lenTy, stmtCtx); return genFormat(converter, loc, *getIOControl(stmt), strTy, lenTy, stmtCtx); } template <> std::tuple getFormat( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::parser::PrintStmt &stmt, mlir::Type strTy, mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) { return genFormat(converter, loc, std::get(stmt.t), strTy, lenTy, stmtCtx); } /// Get a buffer for an internal file data transfer. template std::tuple getBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const A &stmt, mlir::Type strTy, mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) { const Fortran::parser::IoUnit *iounit = stmt.iounit ? &*stmt.iounit : getIOControl(stmt); if (iounit) if (auto *var = std::get_if(&iounit->u)) if (auto *expr = Fortran::semantics::GetExpr(*var)) return genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx); llvm::report_fatal_error("failed to get IoUnit expr in lowering"); } static mlir::Value genIOUnit(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::parser::IoUnit &iounit, mlir::Type ty, Fortran::lower::StatementContext &stmtCtx) { auto &builder = converter.getFirOpBuilder(); if (auto *e = std::get_if(&iounit.u)) { auto ex = fir::getBase( converter.genExprValue(Fortran::semantics::GetExpr(*e), stmtCtx, loc)); return builder.createConvert(loc, ty, ex); } return builder.create( loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit)); } template mlir::Value getIOUnit(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const A &stmt, mlir::Type ty, Fortran::lower::StatementContext &stmtCtx) { if (stmt.iounit) return genIOUnit(converter, loc, *stmt.iounit, ty, stmtCtx); if (auto *iounit = getIOControl(stmt)) return genIOUnit(converter, loc, *iounit, ty, stmtCtx); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); return builder.create( loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit)); } //===----------------------------------------------------------------------===// // Generators for each IO statement type. //===----------------------------------------------------------------------===// template static mlir::Value genBasicIOStmt(Fortran::lower::AbstractConverter &converter, const S &stmt) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); Fortran::lower::StatementContext stmtCtx; mlir::Location loc = converter.getCurrentLocation(); mlir::func::FuncOp beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); mlir::Value unit = fir::getBase(converter.genExprValue( getExpr(stmt), stmtCtx, loc)); mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit); mlir::Value file = locToFilename(converter, loc, beginFuncTy.getInput(1)); mlir::Value line = locToLineNo(converter, loc, beginFuncTy.getInput(2)); auto call = builder.create(loc, beginFunc, mlir::ValueRange{un, file, line}); mlir::Value cookie = call.getResult(0); ConditionSpecInfo csi; genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); mlir::Value ok; auto insertPt = builder.saveInsertionPoint(); threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok); builder.restoreInsertionPoint(insertPt); return genEndIO(converter, converter.getCurrentLocation(), cookie, csi, stmtCtx); } mlir::Value Fortran::lower::genBackspaceStatement( Fortran::lower::AbstractConverter &converter, const Fortran::parser::BackspaceStmt &stmt) { return genBasicIOStmt(converter, stmt); } mlir::Value Fortran::lower::genEndfileStatement( Fortran::lower::AbstractConverter &converter, const Fortran::parser::EndfileStmt &stmt) { return genBasicIOStmt(converter, stmt); } mlir::Value Fortran::lower::genFlushStatement(Fortran::lower::AbstractConverter &converter, const Fortran::parser::FlushStmt &stmt) { return genBasicIOStmt(converter, stmt); } mlir::Value Fortran::lower::genRewindStatement(Fortran::lower::AbstractConverter &converter, const Fortran::parser::RewindStmt &stmt) { return genBasicIOStmt(converter, stmt); } static mlir::Value genNewunitSpec(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const std::list &specList) { for (const auto &spec : specList) if (auto *newunit = std::get_if(&spec.u)) { Fortran::lower::StatementContext stmtCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); const auto *var = Fortran::semantics::GetExpr(newunit->v); mlir::Value addr = builder.createConvert( loc, ioFuncTy.getInput(1), fir::getBase(converter.genExprAddr(var, stmtCtx, loc))); auto kind = builder.createIntegerConstant(loc, ioFuncTy.getInput(2), var->GetType().value().kind()); llvm::SmallVector ioArgs = {cookie, addr, kind}; return builder.create(loc, ioFunc, ioArgs).getResult(0); } llvm_unreachable("missing Newunit spec"); } mlir::Value Fortran::lower::genOpenStatement(Fortran::lower::AbstractConverter &converter, const Fortran::parser::OpenStmt &stmt) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); Fortran::lower::StatementContext stmtCtx; mlir::func::FuncOp beginFunc; llvm::SmallVector beginArgs; mlir::Location loc = converter.getCurrentLocation(); bool hasNewunitSpec = false; if (hasSpec(stmt)) { beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); mlir::Value unit = fir::getBase(converter.genExprValue( getExpr(stmt), stmtCtx, loc)); beginArgs.push_back( builder.createConvert(loc, beginFuncTy.getInput(0), unit)); beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(1))); beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(2))); } else { hasNewunitSpec = hasSpec(stmt); assert(hasNewunitSpec && "missing unit specifier"); beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(0))); beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(1))); } auto cookie = builder.create(loc, beginFunc, beginArgs).getResult(0); ConditionSpecInfo csi; genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); mlir::Value ok; auto insertPt = builder.saveInsertionPoint(); threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok); if (hasNewunitSpec) genNewunitSpec(converter, loc, cookie, stmt.v); builder.restoreInsertionPoint(insertPt); return genEndIO(converter, loc, cookie, csi, stmtCtx); } mlir::Value Fortran::lower::genCloseStatement(Fortran::lower::AbstractConverter &converter, const Fortran::parser::CloseStmt &stmt) { return genBasicIOStmt(converter, stmt); } mlir::Value Fortran::lower::genWaitStatement(Fortran::lower::AbstractConverter &converter, const Fortran::parser::WaitStmt &stmt) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); Fortran::lower::StatementContext stmtCtx; mlir::Location loc = converter.getCurrentLocation(); bool hasId = hasSpec(stmt); mlir::func::FuncOp beginFunc = hasId ? getIORuntimeFunc(loc, builder) : getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); mlir::Value unit = fir::getBase(converter.genExprValue( getExpr(stmt), stmtCtx, loc)); mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit); llvm::SmallVector args{un}; if (hasId) { mlir::Value id = fir::getBase(converter.genExprValue( getExpr(stmt), stmtCtx, loc)); args.push_back(builder.createConvert(loc, beginFuncTy.getInput(1), id)); } auto cookie = builder.create(loc, beginFunc, args).getResult(0); ConditionSpecInfo csi; genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); return genEndIO(converter, converter.getCurrentLocation(), cookie, csi, stmtCtx); } //===----------------------------------------------------------------------===// // Data transfer statements. // // There are several dimensions to the API with regard to data transfer // statements that need to be considered. // // - input (READ) vs. output (WRITE, PRINT) // - unformatted vs. formatted vs. list vs. namelist // - synchronous vs. asynchronous // - external vs. internal //===----------------------------------------------------------------------===// // Get the begin data transfer IO function to call for the given values. template mlir::func::FuncOp getBeginDataTransferFunc(mlir::Location loc, fir::FirOpBuilder &builder, bool isFormatted, bool isListOrNml, bool isInternal, bool isInternalWithDesc, bool isAsync) { if constexpr (isInput) { if (isAsync) return getIORuntimeFunc(loc, builder); if (isFormatted || isListOrNml) { if (isInternal) { if (isInternalWithDesc) { if (isListOrNml) return getIORuntimeFunc( loc, builder); return getIORuntimeFunc( loc, builder); } if (isListOrNml) return getIORuntimeFunc(loc, builder); return getIORuntimeFunc(loc, builder); } if (isListOrNml) return getIORuntimeFunc(loc, builder); return getIORuntimeFunc(loc, builder); } return getIORuntimeFunc(loc, builder); } else { if (isAsync) return getIORuntimeFunc(loc, builder); if (isFormatted || isListOrNml) { if (isInternal) { if (isInternalWithDesc) { if (isListOrNml) return getIORuntimeFunc( loc, builder); return getIORuntimeFunc( loc, builder); } if (isListOrNml) return getIORuntimeFunc(loc, builder); return getIORuntimeFunc(loc, builder); } if (isListOrNml) return getIORuntimeFunc(loc, builder); return getIORuntimeFunc(loc, builder); } return getIORuntimeFunc(loc, builder); } } /// Generate the arguments of a begin data transfer statement call. template void genBeginDataTransferCallArgs( llvm::SmallVectorImpl &ioArgs, Fortran::lower::AbstractConverter &converter, mlir::Location loc, const A &stmt, mlir::FunctionType ioFuncTy, bool isFormatted, bool isListOrNml, [[maybe_unused]] bool isInternal, [[maybe_unused]] bool isAsync, const llvm::Optional &descRef, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); auto maybeGetFormatArgs = [&]() { if (!isFormatted || isListOrNml) return; auto pair = getFormat(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()), ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx); ioArgs.push_back(std::get<0>(pair)); // format character string ioArgs.push_back(std::get<1>(pair)); // format length }; if constexpr (hasIOCtrl) { // READ or WRITE if (isInternal) { // descriptor or scalar variable; maybe explicit format; scratch area if (descRef.hasValue()) { mlir::Value desc = builder.createBox(loc, *descRef); ioArgs.push_back( builder.createConvert(loc, ioFuncTy.getInput(ioArgs.size()), desc)); } else { std::tuple pair = getBuffer(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()), ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx); ioArgs.push_back(std::get<0>(pair)); // scalar character variable ioArgs.push_back(std::get<1>(pair)); // character length } maybeGetFormatArgs(); ioArgs.push_back( // internal scratch area buffer getDefaultScratch(builder, loc, ioFuncTy.getInput(ioArgs.size()))); ioArgs.push_back( // buffer length getDefaultScratchLen(builder, loc, ioFuncTy.getInput(ioArgs.size()))); } else if (isAsync) { // unit; REC; buffer and length ioArgs.push_back(getIOUnit(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()), stmtCtx)); TODO(loc, "asynchronous"); } else { // external IO - maybe explicit format; unit maybeGetFormatArgs(); ioArgs.push_back(getIOUnit(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()), stmtCtx)); } } else { // PRINT - maybe explicit format; default unit maybeGetFormatArgs(); ioArgs.push_back(builder.create( loc, builder.getIntegerAttr(ioFuncTy.getInput(ioArgs.size()), Fortran::runtime::io::DefaultUnit))); } // File name and line number are always the last two arguments. ioArgs.push_back( locToFilename(converter, loc, ioFuncTy.getInput(ioArgs.size()))); ioArgs.push_back( locToLineNo(converter, loc, ioFuncTy.getInput(ioArgs.size()))); } template static mlir::Value genDataTransferStmt(Fortran::lower::AbstractConverter &converter, const A &stmt) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); Fortran::lower::StatementContext stmtCtx; mlir::Location loc = converter.getCurrentLocation(); const bool isFormatted = isDataTransferFormatted(stmt); const bool isList = isFormatted ? isDataTransferList(stmt) : false; const bool isInternal = isDataTransferInternal(stmt); llvm::Optional descRef = isInternal ? maybeGetInternalIODescriptor(converter, stmt, stmtCtx) : llvm::None; const bool isInternalWithDesc = descRef.hasValue(); const bool isAsync = isDataTransferAsynchronous(loc, stmt); const bool isNml = isDataTransferNamelist(stmt); // Generate the begin data transfer function call. mlir::func::FuncOp ioFunc = getBeginDataTransferFunc( loc, builder, isFormatted, isList || isNml, isInternal, isInternalWithDesc, isAsync); llvm::SmallVector ioArgs; genBeginDataTransferCallArgs( ioArgs, converter, loc, stmt, ioFunc.getFunctionType(), isFormatted, isList || isNml, isInternal, isAsync, descRef, stmtCtx); mlir::Value cookie = builder.create(loc, ioFunc, ioArgs).getResult(0); // Generate an EnableHandlers call and remaining specifier calls. ConditionSpecInfo csi; auto insertPt = builder.saveInsertionPoint(); mlir::Value ok; if constexpr (hasIOCtrl) { genConditionHandlerCall(converter, loc, cookie, stmt.controls, csi); threadSpecs(converter, loc, cookie, stmt.controls, csi.hasErrorConditionSpec(), ok); } // Generate data transfer list calls. if constexpr (isInput) { // READ if (isNml) genNamelistIO(converter, cookie, getIORuntimeFunc(loc, builder), *getIOControl(stmt)->symbol, csi.hasTransferConditionSpec(), ok, stmtCtx); else genInputItemList(converter, cookie, stmt.items, isFormatted, csi.hasTransferConditionSpec(), ok, /*inLoop=*/false, stmtCtx); } else if constexpr (std::is_same_v) { if (isNml) genNamelistIO(converter, cookie, getIORuntimeFunc(loc, builder), *getIOControl(stmt)->symbol, csi.hasTransferConditionSpec(), ok, stmtCtx); else genOutputItemList(converter, cookie, stmt.items, isFormatted, csi.hasTransferConditionSpec(), ok, /*inLoop=*/false, stmtCtx); } else { // PRINT genOutputItemList(converter, cookie, std::get<1>(stmt.t), isFormatted, csi.hasTransferConditionSpec(), ok, /*inLoop=*/false, stmtCtx); } stmtCtx.finalize(); builder.restoreInsertionPoint(insertPt); if constexpr (hasIOCtrl) { genIOReadSize(converter, loc, cookie, stmt.controls, csi.hasErrorConditionSpec()); } // Generate end statement call/s. return genEndIO(converter, loc, cookie, csi, stmtCtx); } void Fortran::lower::genPrintStatement( Fortran::lower::AbstractConverter &converter, const Fortran::parser::PrintStmt &stmt) { // PRINT does not take an io-control-spec. It only has a format specifier, so // it is a simplified case of WRITE. genDataTransferStmt(converter, stmt); } mlir::Value Fortran::lower::genWriteStatement(Fortran::lower::AbstractConverter &converter, const Fortran::parser::WriteStmt &stmt) { return genDataTransferStmt(converter, stmt); } mlir::Value Fortran::lower::genReadStatement(Fortran::lower::AbstractConverter &converter, const Fortran::parser::ReadStmt &stmt) { return genDataTransferStmt(converter, stmt); } /// Get the file expression from the inquire spec list. Also return if the /// expression is a file name. static std::pair getInquireFileExpr(const std::list *stmt) { if (!stmt) return {nullptr, /*filename?=*/false}; for (const Fortran::parser::InquireSpec &spec : *stmt) { if (auto *f = std::get_if(&spec.u)) return {Fortran::semantics::GetExpr(*f), /*filename?=*/false}; if (auto *f = std::get_if(&spec.u)) return {Fortran::semantics::GetExpr(*f), /*filename?=*/true}; } // semantics should have already caught this condition llvm::report_fatal_error("inquire spec must have a file"); } /// Generate calls to the four distinct INQUIRE subhandlers. An INQUIRE may /// return values of type CHARACTER, INTEGER, or LOGICAL. There is one /// additional special case for INQUIRE with both PENDING and ID specifiers. template static mlir::Value genInquireSpec(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, mlir::Value idExpr, const A &var, Fortran::lower::StatementContext &stmtCtx) { // default case: do nothing return {}; } /// Specialization for CHARACTER. template <> mlir::Value genInquireSpec( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, mlir::Value idExpr, const Fortran::parser::InquireSpec::CharVar &var, Fortran::lower::StatementContext &stmtCtx) { // IOMSG is handled with exception conditions if (std::get(var.t) == Fortran::parser::InquireSpec::CharVar::Kind::Iomsg) return {}; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp specFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType specFuncTy = specFunc.getFunctionType(); const auto *varExpr = Fortran::semantics::GetExpr( std::get(var.t)); fir::ExtendedValue str = converter.genExprAddr(varExpr, stmtCtx, loc); llvm::SmallVector args = { builder.createConvert(loc, specFuncTy.getInput(0), cookie), builder.createIntegerConstant( loc, specFuncTy.getInput(1), Fortran::runtime::io::HashInquiryKeyword( Fortran::parser::InquireSpec::CharVar::EnumToString( std::get(var.t)) .c_str())), builder.createConvert(loc, specFuncTy.getInput(2), fir::getBase(str)), builder.createConvert(loc, specFuncTy.getInput(3), fir::getLen(str))}; return builder.create(loc, specFunc, args).getResult(0); } /// Specialization for INTEGER. template <> mlir::Value genInquireSpec( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, mlir::Value idExpr, const Fortran::parser::InquireSpec::IntVar &var, Fortran::lower::StatementContext &stmtCtx) { // IOSTAT is handled with exception conditions if (std::get(var.t) == Fortran::parser::InquireSpec::IntVar::Kind::Iostat) return {}; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::func::FuncOp specFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType specFuncTy = specFunc.getFunctionType(); const auto *varExpr = Fortran::semantics::GetExpr( std::get(var.t)); mlir::Value addr = fir::getBase(converter.genExprAddr(varExpr, stmtCtx, loc)); mlir::Type eleTy = fir::dyn_cast_ptrEleTy(addr.getType()); if (!eleTy) fir::emitFatalError(loc, "internal error: expected a memory reference type"); auto width = eleTy.cast().getWidth(); mlir::IndexType idxTy = builder.getIndexType(); mlir::Value kind = builder.createIntegerConstant(loc, idxTy, width / 8); llvm::SmallVector args = { builder.createConvert(loc, specFuncTy.getInput(0), cookie), builder.createIntegerConstant( loc, specFuncTy.getInput(1), Fortran::runtime::io::HashInquiryKeyword( Fortran::parser::InquireSpec::IntVar::EnumToString( std::get(var.t)) .c_str())), builder.createConvert(loc, specFuncTy.getInput(2), addr), builder.createConvert(loc, specFuncTy.getInput(3), kind)}; return builder.create(loc, specFunc, args).getResult(0); } /// Specialization for LOGICAL and (PENDING + ID). template <> mlir::Value genInquireSpec( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, mlir::Value idExpr, const Fortran::parser::InquireSpec::LogVar &var, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); auto logVarKind = std::get(var.t); bool pendId = idExpr && logVarKind == Fortran::parser::InquireSpec::LogVar::Kind::Pending; mlir::func::FuncOp specFunc = pendId ? getIORuntimeFunc(loc, builder) : getIORuntimeFunc(loc, builder); mlir::FunctionType specFuncTy = specFunc.getFunctionType(); mlir::Value addr = fir::getBase(converter.genExprAddr( Fortran::semantics::GetExpr( std::get>>(var.t)), stmtCtx, loc)); llvm::SmallVector args = { builder.createConvert(loc, specFuncTy.getInput(0), cookie)}; if (pendId) args.push_back(builder.createConvert(loc, specFuncTy.getInput(1), idExpr)); else args.push_back(builder.createIntegerConstant( loc, specFuncTy.getInput(1), Fortran::runtime::io::HashInquiryKeyword( Fortran::parser::InquireSpec::LogVar::EnumToString(logVarKind) .c_str()))); args.push_back(builder.createConvert(loc, specFuncTy.getInput(2), addr)); auto call = builder.create(loc, specFunc, args); boolRefToLogical(loc, builder, addr); return call.getResult(0); } /// If there is an IdExpr in the list of inquire-specs, then lower it and return /// the resulting Value. Otherwise, return null. static mlir::Value lowerIdExpr(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const std::list &ispecs, Fortran::lower::StatementContext &stmtCtx) { for (const Fortran::parser::InquireSpec &spec : ispecs) if (mlir::Value v = std::visit( Fortran::common::visitors{ [&](const Fortran::parser::IdExpr &idExpr) { return fir::getBase(converter.genExprValue( Fortran::semantics::GetExpr(idExpr), stmtCtx, loc)); }, [](const auto &) { return mlir::Value{}; }}, spec.u)) return v; return {}; } /// For each inquire-spec, build the appropriate call, threading the cookie. static void threadInquire(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, const std::list &ispecs, bool checkResult, mlir::Value &ok, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Value idExpr = lowerIdExpr(converter, loc, ispecs, stmtCtx); for (const Fortran::parser::InquireSpec &spec : ispecs) { makeNextConditionalOn(builder, loc, checkResult, ok); ok = std::visit(Fortran::common::visitors{[&](const auto &x) { return genInquireSpec(converter, loc, cookie, idExpr, x, stmtCtx); }}, spec.u); } } mlir::Value Fortran::lower::genInquireStatement( Fortran::lower::AbstractConverter &converter, const Fortran::parser::InquireStmt &stmt) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); Fortran::lower::StatementContext stmtCtx; mlir::Location loc = converter.getCurrentLocation(); mlir::func::FuncOp beginFunc; ConditionSpecInfo csi; llvm::SmallVector beginArgs; const auto *list = std::get_if>(&stmt.u); auto exprPair = getInquireFileExpr(list); auto inquireFileUnit = [&]() -> bool { return exprPair.first && !exprPair.second; }; auto inquireFileName = [&]() -> bool { return exprPair.first && exprPair.second; }; // Make one of three BeginInquire calls. if (inquireFileUnit()) { // Inquire by unit -- [UNIT=]file-unit-number. beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); beginArgs = {builder.createConvert(loc, beginFuncTy.getInput(0), fir::getBase(converter.genExprValue( exprPair.first, stmtCtx, loc))), locToFilename(converter, loc, beginFuncTy.getInput(1)), locToLineNo(converter, loc, beginFuncTy.getInput(2))}; } else if (inquireFileName()) { // Inquire by file -- FILE=file-name-expr. beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); fir::ExtendedValue file = converter.genExprAddr(exprPair.first, stmtCtx, loc); beginArgs = { builder.createConvert(loc, beginFuncTy.getInput(0), fir::getBase(file)), builder.createConvert(loc, beginFuncTy.getInput(1), fir::getLen(file)), locToFilename(converter, loc, beginFuncTy.getInput(2)), locToLineNo(converter, loc, beginFuncTy.getInput(3))}; } else { // Inquire by output list -- IOLENGTH=scalar-int-variable. const auto *ioLength = std::get_if(&stmt.u); assert(ioLength && "must have an IOLENGTH specifier"); beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); beginArgs = {locToFilename(converter, loc, beginFuncTy.getInput(0)), locToLineNo(converter, loc, beginFuncTy.getInput(1))}; auto cookie = builder.create(loc, beginFunc, beginArgs).getResult(0); mlir::Value ok; genOutputItemList( converter, cookie, std::get>(ioLength->t), /*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false, stmtCtx); auto *ioLengthVar = Fortran::semantics::GetExpr( std::get(ioLength->t)); mlir::Value ioLengthVarAddr = fir::getBase(converter.genExprAddr(ioLengthVar, stmtCtx, loc)); llvm::SmallVector args = {cookie}; mlir::Value length = builder .create( loc, getIORuntimeFunc(loc, builder), args) .getResult(0); mlir::Value length1 = builder.createConvert(loc, converter.genType(*ioLengthVar), length); builder.create(loc, length1, ioLengthVarAddr); return genEndIO(converter, loc, cookie, csi, stmtCtx); } // Common handling for inquire by unit or file. assert(list && "inquire-spec list must be present"); auto cookie = builder.create(loc, beginFunc, beginArgs).getResult(0); genConditionHandlerCall(converter, loc, cookie, *list, csi); // Handle remaining arguments in specifier list. mlir::Value ok; auto insertPt = builder.saveInsertionPoint(); threadInquire(converter, loc, cookie, *list, csi.hasErrorConditionSpec(), ok, stmtCtx); builder.restoreInsertionPoint(insertPt); // Generate end statement call. return genEndIO(converter, loc, cookie, csi, stmtCtx); }