diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h index 1b38bfb973d7c..657c584d8d0a5 100644 --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -14,6 +14,7 @@ #define FORTRAN_LOWER_ABSTRACTCONVERTER_H #include "flang/Common/Fortran.h" +#include "flang/Lower/PFTDefs.h" #include "flang/Optimizer/Builder/BoxValue.h" #include "mlir/IR/BuiltinOps.h" #include "llvm/ADT/ArrayRef.h" @@ -75,6 +76,12 @@ class AbstractConverter { /// Get the mlir instance of a symbol. virtual mlir::Value getSymbolAddress(SymbolRef sym) = 0; + /// Get the label set associated with a symbol. + virtual bool lookupLabelSet(SymbolRef sym, pft::LabelSet &labelSet) = 0; + + /// Get the code defined by a label + virtual pft::Evaluation *lookupLabel(pft::Label label) = 0; + //===--------------------------------------------------------------------===// // Expressions //===--------------------------------------------------------------------===// @@ -99,6 +106,12 @@ class AbstractConverter { return genExprValue(*someExpr, stmtCtx, &loc); } + /// Generate or get a fir.box describing the expression. If SomeExpr is + /// a Designator, the fir.box describes an entity over the Designator base + /// storage without making a temporary. + virtual fir::ExtendedValue genExprBox(const SomeExpr &, StatementContext &, + mlir::Location) = 0; + /// Generate the address of the box describing the variable designated /// by the expression. The expression must be an allocatable or pointer /// designator. @@ -125,8 +138,10 @@ class AbstractConverter { virtual mlir::Type genType(SymbolRef) = 0; /// Generate the type from a category virtual mlir::Type genType(Fortran::common::TypeCategory tc) = 0; - /// Generate the type from a category and kind - virtual mlir::Type genType(Fortran::common::TypeCategory tc, int kind) = 0; + /// Generate the type from a category and kind and length parameters. + virtual mlir::Type + genType(Fortran::common::TypeCategory tc, int kind, + llvm::ArrayRef lenParameters = llvm::None) = 0; /// Generate the type from a Variable virtual mlir::Type genType(const pft::Variable &) = 0; diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h index 47d4fd2e136a7..cb4a86945c726 100644 --- a/flang/include/flang/Lower/ConvertExpr.h +++ b/flang/include/flang/Lower/ConvertExpr.h @@ -49,6 +49,22 @@ fir::ExtendedValue createSomeExtendedExpression(mlir::Location loc, SymMap &symMap, StatementContext &stmtCtx); +/// Create a global array symbol with the Dense attribute +fir::GlobalOp createDenseGlobal(mlir::Location loc, mlir::Type symTy, + llvm::StringRef globalName, + mlir::StringAttr linkage, bool isConst, + const SomeExpr &expr, + Fortran::lower::AbstractConverter &converter); + +/// Create the IR for the expression \p expr in an initialization context. +/// Expressions that appear in initializers may not allocate temporaries, do not +/// have a stack, etc. +fir::ExtendedValue createSomeInitializerExpression(mlir::Location loc, + AbstractConverter &converter, + const SomeExpr &expr, + SymMap &symMap, + StatementContext &stmtCtx); + /// Create an extended expression address. fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc, AbstractConverter &converter, @@ -56,12 +72,27 @@ fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc, SymMap &symMap, StatementContext &stmtCtx); +/// Create an address in an initializer context. Must be a constant or a symbol +/// to be resolved at link-time. Expressions that appear in initializers may not +/// allocate temporaries, do not have a stack, etc. +fir::ExtendedValue createInitializerAddress(mlir::Location loc, + AbstractConverter &converter, + const SomeExpr &expr, + SymMap &symMap, + StatementContext &stmtCtx); + /// Create the address of the box. /// \p expr must be the designator of an allocatable/pointer entity. fir::MutableBoxValue createMutableBox(mlir::Location loc, AbstractConverter &converter, const SomeExpr &expr, SymMap &symMap); +/// Lower an array expression to a value of type box. The expression must be a +/// variable. +fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter, + const SomeExpr &expr, SymMap &symMap, + StatementContext &stmtCtx); + /// Lower a subroutine call. This handles both elemental and non elemental /// subroutines. \p isUserDefAssignment must be set if this is called in the /// context of a user defined assignment. For subroutines with alternate diff --git a/flang/include/flang/Lower/ConvertType.h b/flang/include/flang/Lower/ConvertType.h index fccddc7dbf0ff..430f5f1bd36f6 100644 --- a/flang/include/flang/Lower/ConvertType.h +++ b/flang/include/flang/Lower/ConvertType.h @@ -60,7 +60,7 @@ using LenParameterTy = std::int64_t; /// Get a FIR type based on a category and kind. mlir::Type getFIRType(mlir::MLIRContext *ctxt, common::TypeCategory tc, - int kind); + int kind, llvm::ArrayRef); /// Translate a SomeExpr to an mlir::Type. mlir::Type translateSomeExprToFIRType(Fortran::lower::AbstractConverter &, diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h index a4222f2478aa7..f01b52a1873d0 100644 --- a/flang/include/flang/Lower/ConvertVariable.h +++ b/flang/include/flang/Lower/ConvertVariable.h @@ -17,7 +17,9 @@ #ifndef FORTRAN_LOWER_CONVERT_VARIABLE_H #define FORTRAN_LOWER_CONVERT_VARIABLE_H +#include "flang/Lower/Support/Utils.h" #include "mlir/IR/Value.h" +#include "llvm/ADT/DenseMap.h" namespace Fortran ::lower { class AbstractConverter; @@ -28,12 +30,19 @@ namespace pft { struct Variable; } +/// AggregateStoreMap is used to keep track of instantiated aggregate stores +/// when lowering a scope containing equivalences (aliases). It must only be +/// owned by the code lowering a scope and provided to instantiateVariable. +using AggregateStoreKey = + std::tuple; +using AggregateStoreMap = llvm::DenseMap; + /// Instantiate variable \p var and add it to \p symMap. /// The AbstractConverter builder must be set. /// The AbstractConverter own symbol mapping is not used during the /// instantiation and can be different form \p symMap. void instantiateVariable(AbstractConverter &, const pft::Variable &var, - SymMap &symMap); + SymMap &symMap, AggregateStoreMap &storeMap); /// Lower a symbol attributes given an optional storage \p and add it to the /// provided symbol map. If \preAlloc is not provided, a temporary storage will @@ -49,5 +58,11 @@ void mapCallInterfaceSymbols(AbstractConverter &, const Fortran::lower::CallerInterface &caller, SymMap &symMap); +/// Create initial-data-target fir.box in a global initializer region. +/// This handles the local instantiation of the target variable. +mlir::Value genInitialDataTarget(Fortran::lower::AbstractConverter &, + mlir::Location, mlir::Type boxType, + const SomeExpr &initialTarget); + } // namespace Fortran::lower #endif // FORTRAN_LOWER_CONVERT_VARIABLE_H diff --git a/flang/include/flang/Lower/IO.h b/flang/include/flang/Lower/IO.h new file mode 100644 index 0000000000000..9d5c007cbc35e --- /dev/null +++ b/flang/include/flang/Lower/IO.h @@ -0,0 +1,46 @@ +//===-- Lower/IO.h -- lower IO statements -----------------------*- C++ -*-===// +// +// 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/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_IO_H +#define FORTRAN_LOWER_IO_H + +namespace mlir { +class Value; +} // namespace mlir + +namespace Fortran { +namespace parser { +struct ReadStmt; +struct PrintStmt; +struct WriteStmt; +} // namespace parser + +namespace lower { + +class AbstractConverter; + +/// Generate IO call(s) for READ; return the IOSTAT code +mlir::Value genReadStatement(AbstractConverter &converter, + const parser::ReadStmt &stmt); + +/// Generate IO call(s) for PRINT +void genPrintStatement(AbstractConverter &converter, + const parser::PrintStmt &stmt); + +/// Generate IO call(s) for WRITE; return the IOSTAT code +mlir::Value genWriteStatement(AbstractConverter &converter, + const parser::WriteStmt &stmt); + +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_IO_H diff --git a/flang/include/flang/Lower/StatementContext.h b/flang/include/flang/Lower/StatementContext.h index b4df75026e1d4..58cb9e9271596 100644 --- a/flang/include/flang/Lower/StatementContext.h +++ b/flang/include/flang/Lower/StatementContext.h @@ -13,6 +13,8 @@ #ifndef FORTRAN_LOWER_STATEMENTCONTEXT_H #define FORTRAN_LOWER_STATEMENTCONTEXT_H +#include "llvm/ADT/Optional.h" +#include "llvm/ADT/SmallVector.h" #include namespace Fortran::lower { diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td index dd285032df095..8f2d6d48230a3 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -1805,6 +1805,7 @@ def fir_FieldIndexOp : fir_OneResultOp<"field_index", [NoSideEffect]> { static constexpr llvm::StringRef fieldAttrName() { return "field_id"; } static constexpr llvm::StringRef typeAttrName() { return "on_type"; } llvm::StringRef getFieldName() { return getFieldId(); } + llvm::SmallVector getAttributes(); }]; } diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 6e50e1c35e058..f7e142ef451e6 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -16,6 +16,7 @@ #include "flang/Lower/ConvertExpr.h" #include "flang/Lower/ConvertType.h" #include "flang/Lower/ConvertVariable.h" +#include "flang/Lower/IO.h" #include "flang/Lower/IterationSpace.h" #include "flang/Lower/Mangler.h" #include "flang/Lower/PFTBuilder.h" @@ -27,6 +28,7 @@ #include "flang/Optimizer/Builder/Character.h" #include "flang/Optimizer/Builder/MutableBox.h" #include "flang/Optimizer/Support/FIRContext.h" +#include "flang/Runtime/iostat.h" #include "flang/Semantics/tools.h" #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" #include "mlir/IR/PatternMatch.h" @@ -81,6 +83,27 @@ class FirConverter : public Fortran::lower::AbstractConverter { return lookupSymbol(sym).getAddr(); } + bool lookupLabelSet(Fortran::lower::SymbolRef sym, + Fortran::lower::pft::LabelSet &labelSet) override final { + Fortran::lower::pft::FunctionLikeUnit &owningProc = + *getEval().getOwningProcedure(); + auto iter = owningProc.assignSymbolLabelMap.find(sym); + if (iter == owningProc.assignSymbolLabelMap.end()) + return false; + labelSet = iter->second; + return true; + } + + Fortran::lower::pft::Evaluation * + lookupLabel(Fortran::lower::pft::Label label) override final { + Fortran::lower::pft::FunctionLikeUnit &owningProc = + *getEval().getOwningProcedure(); + auto iter = owningProc.labelEvaluationMap.find(label); + if (iter == owningProc.labelEvaluationMap.end()) + return nullptr; + return iter->second; + } + fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr, Fortran::lower::StatementContext &context, mlir::Location *loc = nullptr) override final { @@ -99,6 +122,16 @@ class FirConverter : public Fortran::lower::AbstractConverter { const Fortran::lower::SomeExpr &expr) override final { return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols); } + fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &context, + mlir::Location loc) override final { + if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && + !Fortran::evaluate::HasVectorSubscript(expr)) + return Fortran::lower::createSomeArrayBox(*this, expr, localSymbols, + context); + return fir::BoxValue( + builder->createBox(loc, genExprAddr(expr, context, &loc))); + } Fortran::evaluate::FoldingContext &getFoldingContext() override final { return foldingContext; @@ -118,9 +151,11 @@ class FirConverter : public Fortran::lower::AbstractConverter { TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex " "expression lowering"); } - mlir::Type genType(Fortran::common::TypeCategory tc, - int kind) override final { - return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind); + mlir::Type + genType(Fortran::common::TypeCategory tc, int kind, + llvm::ArrayRef lenParameters) override final { + return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind, + lenParameters); } mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { return Fortran::lower::translateVariableToFIRType(*this, var); @@ -295,8 +330,9 @@ class FirConverter : public Fortran::lower::AbstractConverter { /// Instantiate variable \p var and add it to the symbol map. /// See ConvertVariable.cpp. - void instantiateVar(const Fortran::lower::pft::Variable &var) { - Fortran::lower::instantiateVariable(*this, var, localSymbols); + void instantiateVar(const Fortran::lower::pft::Variable &var, + Fortran::lower::AggregateStoreMap &storeMap) { + Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap); } /// Prepare to translate a new function @@ -311,13 +347,14 @@ class FirConverter : public Fortran::lower::AbstractConverter { mapDummiesAndResults(funit, callee); + Fortran::lower::AggregateStoreMap storeMap; for (const Fortran::lower::pft::Variable &var : funit.getOrderedSymbolTable()) { const Fortran::semantics::Symbol &sym = var.getSymbol(); if (!sym.IsFuncResult() || !funit.primaryResult) { - instantiateVar(var); + instantiateVar(var, storeMap); } else if (&sym == funit.primaryResult) { - instantiateVar(var); + instantiateVar(var, storeMap); } } @@ -413,6 +450,17 @@ class FirConverter : public Fortran::lower::AbstractConverter { return cat == Fortran::common::TypeCategory::Derived; } + mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval, + Fortran::parser::Label label) { + const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = + eval.getOwningProcedure()->labelEvaluationMap; + const auto iter = labelEvaluationMap.find(label); + assert(iter != labelEvaluationMap.end() && "label missing from map"); + mlir::Block *block = iter->second->block; + assert(block && "missing labeled evaluation block"); + return block; + } + void genFIRBranch(mlir::Block *targetBlock) { assert(targetBlock && "missing unconditional target block"); builder->create(toLocation(), targetBlock); @@ -572,7 +620,9 @@ class FirConverter : public Fortran::lower::AbstractConverter { } builder->create(loc, cast, addr); } else if (isCharacterCategory(lhsType->category())) { - TODO(toLocation(), "Character assignment"); + // Fortran 2018 10.2.1.3 p10 and p11 + fir::factory::CharacterExprHelper{*builder, loc}.createAssign( + lhs, rhs); } else if (isDerivedCategory(lhsType->category())) { TODO(toLocation(), "Derived type assignment"); } else { @@ -785,11 +835,12 @@ class FirConverter : public Fortran::lower::AbstractConverter { } void genFIR(const Fortran::parser::PrintStmt &stmt) { - TODO(toLocation(), "PrintStmt lowering"); + genPrintStatement(*this, stmt); } void genFIR(const Fortran::parser::ReadStmt &stmt) { - TODO(toLocation(), "ReadStmt lowering"); + mlir::Value iostat = genReadStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.controls, iostat); } void genFIR(const Fortran::parser::RewindStmt &stmt) { @@ -801,7 +852,59 @@ class FirConverter : public Fortran::lower::AbstractConverter { } void genFIR(const Fortran::parser::WriteStmt &stmt) { - TODO(toLocation(), "WriteStmt lowering"); + mlir::Value iostat = genWriteStatement(*this, stmt); + genIoConditionBranches(getEval(), stmt.controls, iostat); + } + + template + void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval, + const A &specList, mlir::Value iostat) { + if (!iostat) + return; + + mlir::Block *endBlock = nullptr; + mlir::Block *eorBlock = nullptr; + mlir::Block *errBlock = nullptr; + for (const auto &spec : specList) { + std::visit(Fortran::common::visitors{ + [&](const Fortran::parser::EndLabel &label) { + endBlock = blockOfLabel(eval, label.v); + }, + [&](const Fortran::parser::EorLabel &label) { + eorBlock = blockOfLabel(eval, label.v); + }, + [&](const Fortran::parser::ErrLabel &label) { + errBlock = blockOfLabel(eval, label.v); + }, + [](const auto &) {}}, + spec.u); + } + if (!endBlock && !eorBlock && !errBlock) + return; + + mlir::Location loc = toLocation(); + mlir::Type indexType = builder->getIndexType(); + mlir::Value selector = builder->createConvert(loc, indexType, iostat); + llvm::SmallVector indexList; + llvm::SmallVector blockList; + if (eorBlock) { + indexList.push_back(Fortran::runtime::io::IostatEor); + blockList.push_back(eorBlock); + } + if (endBlock) { + indexList.push_back(Fortran::runtime::io::IostatEnd); + blockList.push_back(endBlock); + } + if (errBlock) { + indexList.push_back(0); + blockList.push_back(eval.nonNopSuccessor().block); + // ERR label statement is the default successor. + blockList.push_back(errBlock); + } else { + // Fallthrough successor statement is the default successor. + blockList.push_back(eval.nonNopSuccessor().block); + } + builder->create(loc, selector, indexList, blockList); } //===--------------------------------------------------------------------===// diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt index e60087e3fc17c..297cc9b1b247f 100644 --- a/flang/lib/Lower/CMakeLists.txt +++ b/flang/lib/Lower/CMakeLists.txt @@ -9,6 +9,7 @@ add_flang_library(FortranLower ConvertType.cpp ConvertVariable.cpp IntrinsicCall.cpp + IO.cpp ComponentPath.cpp DumpEvaluateExpr.cpp IterationSpace.cpp diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp index dd8c6ced3cbc5..85ea688ca4365 100644 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -250,6 +250,16 @@ bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) { return false; } +/// Some auxiliary data for processing initialization in ScalarExprLowering +/// below. This is currently used for generating dense attributed global +/// arrays. +struct InitializerData { + explicit InitializerData(bool getRawVals = false) : genRawVals{getRawVals} {} + llvm::SmallVector rawVals; // initialization raw values + mlir::Type rawType; // Type of elements processed for rawVals vector. + bool genRawVals; // generate the rawVals vector if set. +}; + /// If \p arg is the address of a function with a denoted host-association tuple /// argument, then return the host-associations tuple value of the current /// procedure. Otherwise, return nullptr. @@ -275,7 +285,8 @@ class ScalarExprLowering { explicit ScalarExprLowering(mlir::Location loc, Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, - Fortran::lower::StatementContext &stmtCtx) + Fortran::lower::StatementContext &stmtCtx, + InitializerData *initializer = nullptr) : location{loc}, converter{converter}, builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap} { } @@ -1762,6 +1773,30 @@ class ArrayExprLowering { takeLboundsIfRealloc, realloc); } + /// Entry point for when an array expression appears in a context where the + /// result must be boxed. (BoxValue semantics.) + static ExtValue + lowerBoxedArrayExpression(Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx, + const Fortran::lower::SomeExpr &expr) { + ArrayExprLowering ael{converter, stmtCtx, symMap, + ConstituentSemantics::BoxValue}; + return ael.lowerBoxedArrayExpr(expr); + } + + ExtValue lowerBoxedArrayExpr(const Fortran::lower::SomeExpr &exp) { + return std::visit( + [&](const auto &e) { + auto f = genarr(e); + ExtValue exv = f(IterationSpace{}); + if (fir::getBase(exv).getType().template isa()) + return exv; + fir::emitFatalError(getLoc(), "array must be emboxed"); + }, + exp.u); + } + /// Entry point into lowering an expression with rank. This entry point is for /// lowering a rhs expression, for example. (RefTransparent semantics.) static ExtValue @@ -2659,6 +2694,43 @@ fir::ExtendedValue Fortran::lower::createSomeExtendedExpression( return ScalarExprLowering{loc, converter, symMap, stmtCtx}.genval(expr); } +fir::GlobalOp Fortran::lower::createDenseGlobal( + mlir::Location loc, mlir::Type symTy, llvm::StringRef globalName, + mlir::StringAttr linkage, bool isConst, + const Fortran::lower::SomeExpr &expr, + Fortran::lower::AbstractConverter &converter) { + + Fortran::lower::StatementContext stmtCtx(/*prohibited=*/true); + Fortran::lower::SymMap emptyMap; + InitializerData initData(/*genRawVals=*/true); + ScalarExprLowering sel(loc, converter, emptyMap, stmtCtx, + /*initializer=*/&initData); + sel.genval(expr); + + size_t sz = initData.rawVals.size(); + llvm::ArrayRef ar = {initData.rawVals.data(), sz}; + + mlir::RankedTensorType tensorTy; + auto &builder = converter.getFirOpBuilder(); + mlir::Type iTy = initData.rawType; + if (!iTy) + return 0; // array extent is probably 0 in this case, so just return 0. + tensorTy = mlir::RankedTensorType::get(sz, iTy); + auto init = mlir::DenseElementsAttr::get(tensorTy, ar); + return builder.createGlobal(loc, symTy, globalName, linkage, init, isConst); +} + +fir::ExtendedValue Fortran::lower::createSomeInitializerExpression( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n'); + InitializerData initData; // needed for initializations + return ScalarExprLowering{loc, converter, symMap, stmtCtx, + /*initializer=*/&initData} + .genval(expr); +} + fir::ExtendedValue Fortran::lower::createSomeExtendedAddress( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, @@ -2667,6 +2739,25 @@ fir::ExtendedValue Fortran::lower::createSomeExtendedAddress( return ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(expr); } +fir::ExtendedValue Fortran::lower::createInitializerAddress( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n'); + InitializerData init; + return ScalarExprLowering(loc, converter, symMap, stmtCtx, &init).gen(expr); +} + +fir::ExtendedValue +Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n'); + return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap, + stmtCtx, expr); +} + fir::MutableBoxValue Fortran::lower::createMutableBox( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) { diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp index 19556fc3afb27..f028df58e0e8a 100644 --- a/flang/lib/Lower/ConvertType.cpp +++ b/flang/lib/Lower/ConvertType.cpp @@ -75,6 +75,15 @@ static mlir::Type genLogicalType(mlir::MLIRContext *context, int KIND) { return {}; } +static mlir::Type genCharacterType( + mlir::MLIRContext *context, int KIND, + Fortran::lower::LenParameterTy len = fir::CharacterType::unknownLen()) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Character, KIND)) + return fir::CharacterType::get(context, KIND, len); + return {}; +} + static mlir::Type genComplexType(mlir::MLIRContext *context, int KIND) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Complex, KIND)) @@ -82,8 +91,10 @@ static mlir::Type genComplexType(mlir::MLIRContext *context, int KIND) { return {}; } -static mlir::Type genFIRType(mlir::MLIRContext *context, - Fortran::common::TypeCategory tc, int kind) { +static mlir::Type +genFIRType(mlir::MLIRContext *context, Fortran::common::TypeCategory tc, + int kind, + llvm::ArrayRef lenParameters) { switch (tc) { case Fortran::common::TypeCategory::Real: return genRealType(context, kind); @@ -94,7 +105,9 @@ static mlir::Type genFIRType(mlir::MLIRContext *context, case Fortran::common::TypeCategory::Logical: return genLogicalType(context, kind); case Fortran::common::TypeCategory::Character: - TODO_NOLOC("genFIRType Character"); + if (!lenParameters.empty()) + return genCharacterType(context, kind, lenParameters[0]); + return genCharacterType(context, kind); default: break; } @@ -129,7 +142,9 @@ class TypeBuilder { TODO(converter.getCurrentLocation(), "genExprType derived"); } else { // LOGICAL, INTEGER, REAL, COMPLEX, CHARACTER - baseType = genFIRType(context, category, dynamicType->kind()); + llvm::SmallVector params; + translateLenParameters(params, category, expr); + baseType = genFIRType(context, category, dynamicType->kind(), params); } std::optional shapeExpr = Fortran::evaluate::GetShape(converter.getFoldingContext(), expr); @@ -211,7 +226,9 @@ class TypeBuilder { if (const Fortran::semantics::IntrinsicTypeSpec *tySpec = type->AsIntrinsic()) { int kind = toInt64(Fortran::common::Clone(tySpec->kind())).value(); - ty = genFIRType(context, tySpec->category(), kind); + llvm::SmallVector params; + translateLenParameters(params, tySpec->category(), ultimate); + ty = genFIRType(context, tySpec->category(), kind, params); } else if (type->IsPolymorphic()) { TODO(loc, "genSymbolType polymorphic types"); } else if (type->AsDerived()) { @@ -246,6 +263,65 @@ class TypeBuilder { return ty; } + // To get the character length from a symbol, make an fold a designator for + // the symbol to cover the case where the symbol is an assumed length named + // constant and its length comes from its init expression length. + template + fir::SequenceType::Extent + getCharacterLengthHelper(const Fortran::semantics::Symbol &symbol) { + using TC = + Fortran::evaluate::Type; + auto designator = Fortran::evaluate::Fold( + converter.getFoldingContext(), + Fortran::evaluate::Expr{Fortran::evaluate::Designator{symbol}}); + if (auto len = toInt64(std::move(designator.LEN()))) + return *len; + return fir::SequenceType::getUnknownExtent(); + } + + template + void translateLenParameters( + llvm::SmallVectorImpl ¶ms, + Fortran::common::TypeCategory category, const T &exprOrSym) { + if (category == Fortran::common::TypeCategory::Character) + params.push_back(getCharacterLength(exprOrSym)); + else if (category == Fortran::common::TypeCategory::Derived) + TODO(converter.getCurrentLocation(), + "lowering derived type length parameters"); + return; + } + Fortran::lower::LenParameterTy + getCharacterLength(const Fortran::semantics::Symbol &symbol) { + const Fortran::semantics::DeclTypeSpec *type = symbol.GetType(); + if (!type || + type->category() != Fortran::semantics::DeclTypeSpec::Character || + !type->AsIntrinsic()) + llvm::report_fatal_error("not a character symbol"); + int kind = + toInt64(Fortran::common::Clone(type->AsIntrinsic()->kind())).value(); + switch (kind) { + case 1: + return getCharacterLengthHelper<1>(symbol); + case 2: + return getCharacterLengthHelper<2>(symbol); + case 4: + return getCharacterLengthHelper<4>(symbol); + } + llvm_unreachable("unknown character kind"); + } + Fortran::lower::LenParameterTy + getCharacterLength(const Fortran::lower::SomeExpr &expr) { + // Do not use dynamic type length here. We would miss constant + // lengths opportunities because dynamic type only has the length + // if it comes from a declaration. + auto charExpr = + std::get>( + expr.u); + if (auto constantLen = toInt64(charExpr.LEN())) + return *constantLen; + return fir::SequenceType::getUnknownExtent(); + } + mlir::Type genVariableType(const Fortran::lower::pft::Variable &var) { return genSymbolType(var.getSymbol(), var.isHeapAlloc(), var.isPointer()); } @@ -259,8 +335,9 @@ class TypeBuilder { mlir::Type Fortran::lower::getFIRType(mlir::MLIRContext *context, Fortran::common::TypeCategory tc, - int kind) { - return genFIRType(context, tc, kind); + int kind, + llvm::ArrayRef params) { + return genFIRType(context, tc, kind, params); } mlir::Type Fortran::lower::translateSomeExprToFIRType( diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp index f11e031bee3d6..593e9c7e6e3e8 100644 --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -35,6 +35,45 @@ #define DEBUG_TYPE "flang-lower-variable" +/// Helper to retrieve a copy of a character literal string from a SomeExpr. +/// Required to build character global initializers. +template +static llvm::Optional> +getCharacterLiteralCopy( + const Fortran::evaluate::Expr< + Fortran::evaluate::Type> + &x) { + if (const auto *con = + Fortran::evaluate::UnwrapConstantValue>(x)) + if (auto val = con->GetScalarValue()) + return std::tuple{ + std::string{(const char *)val->c_str(), + KIND * (std::size_t)con->LEN()}, + (std::size_t)con->LEN()}; + return llvm::None; +} +static llvm::Optional> +getCharacterLiteralCopy( + const Fortran::evaluate::Expr &x) { + return std::visit([](const auto &e) { return getCharacterLiteralCopy(e); }, + x.u); +} +static llvm::Optional> +getCharacterLiteralCopy(const Fortran::lower::SomeExpr &x) { + if (const auto *e = Fortran::evaluate::UnwrapExpr< + Fortran::evaluate::Expr>(x)) + return getCharacterLiteralCopy(*e); + return llvm::None; +} +template +static llvm::Optional> +getCharacterLiteralCopy(const std::optional &x) { + if (x) + return getCharacterLiteralCopy(*x); + return llvm::None; +} + /// Helper to lower a scalar expression using a specific symbol mapping. static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter, mlir::Location loc, @@ -47,6 +86,430 @@ static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter, loc, converter, expr, symMap, context)); } +/// Does this variable have a default initialization? +static bool hasDefaultInitialization(const Fortran::semantics::Symbol &sym) { + if (sym.has() && sym.size()) + if (!Fortran::semantics::IsAllocatableOrPointer(sym)) + if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType()) + if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = + declTypeSpec->AsDerived()) + return derivedTypeSpec->HasDefaultInitialization(); + return false; +} + +//===----------------------------------------------------------------===// +// Global variables instantiation (not for alias and common) +//===----------------------------------------------------------------===// + +/// Helper to generate expression value inside global initializer. +static fir::ExtendedValue +genInitializerExprValue(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, + const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &stmtCtx) { + // Data initializer are constant value and should not depend on other symbols + // given the front-end fold parameter references. In any case, the "current" + // map of the converter should not be used since it holds mapping to + // mlir::Value from another mlir region. If these value are used by accident + // in the initializer, this will lead to segfaults in mlir code. + Fortran::lower::SymMap emptyMap; + return Fortran::lower::createSomeInitializerExpression(loc, converter, expr, + emptyMap, stmtCtx); +} + +/// Can this symbol constant be placed in read-only memory? +static bool isConstant(const Fortran::semantics::Symbol &sym) { + return sym.attrs().test(Fortran::semantics::Attr::PARAMETER) || + sym.test(Fortran::semantics::Symbol::Flag::ReadOnly); +} + +/// Create the global op declaration without any initializer +static fir::GlobalOp declareGlobal(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable &var, + llvm::StringRef globalName, + mlir::StringAttr linkage) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + if (fir::GlobalOp global = builder.getNamedGlobal(globalName)) + return global; + const Fortran::semantics::Symbol &sym = var.getSymbol(); + mlir::Location loc = converter.genLocation(sym.name()); + // Resolve potential host and module association before checking that this + // symbol is an object of a function pointer. + const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); + if (!ultimate.has() && + !ultimate.has()) + mlir::emitError(loc, "lowering global declaration: symbol '") + << toStringRef(sym.name()) << "' has unexpected details\n"; + return builder.createGlobal(loc, converter.genType(var), globalName, linkage, + mlir::Attribute{}, isConstant(ultimate)); +} + +/// Temporary helper to catch todos in initial data target lowering. +static bool +hasDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) { + if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) + if (const Fortran::semantics::DerivedTypeSpec *derived = + declTy->AsDerived()) + return Fortran::semantics::CountLenParameters(*derived) > 0; + return false; +} + +static mlir::Type unwrapElementType(mlir::Type type) { + if (mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(type)) + type = ty; + if (auto seqType = type.dyn_cast()) + type = seqType.getEleTy(); + return type; +} + +/// create initial-data-target fir.box in a global initializer region. +mlir::Value Fortran::lower::genInitialDataTarget( + Fortran::lower::AbstractConverter &converter, mlir::Location loc, + mlir::Type boxType, const Fortran::lower::SomeExpr &initialTarget) { + Fortran::lower::SymMap globalOpSymMap; + Fortran::lower::AggregateStoreMap storeMap; + Fortran::lower::StatementContext stmtCtx; + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + if (Fortran::evaluate::UnwrapExpr( + initialTarget)) + return fir::factory::createUnallocatedBox(builder, loc, boxType, + /*nonDeferredParams=*/llvm::None); + // Pointer initial data target, and NULL(mold). + if (const Fortran::semantics::Symbol *sym = + Fortran::evaluate::GetFirstSymbol(initialTarget)) { + // Length parameters processing will need care in global initializer + // context. + if (hasDerivedTypeWithLengthParameters(*sym)) + TODO(loc, "initial-data-target with derived type length parameters"); + + auto var = Fortran::lower::pft::Variable(*sym, /*global=*/true); + Fortran::lower::instantiateVariable(converter, var, globalOpSymMap, + storeMap); + } + mlir::Value box; + if (initialTarget.Rank() > 0) { + box = fir::getBase(Fortran::lower::createSomeArrayBox( + converter, initialTarget, globalOpSymMap, stmtCtx)); + } else { + fir::ExtendedValue addr = Fortran::lower::createInitializerAddress( + loc, converter, initialTarget, globalOpSymMap, stmtCtx); + box = builder.createBox(loc, addr); + } + // box is a fir.box, not a fir.box> as it should to be used + // for pointers. A fir.convert should not be used here, because it would + // not actually set the pointer attribute in the descriptor. + // In a normal context, fir.rebox would be used to set the pointer attribute + // while copying the projection from another fir.box. But fir.rebox cannot be + // used in initializer because its current codegen expects that the input + // fir.box is in memory, which is not the case in initializers. + // So, just replace the fir.embox that created addr with one with + // fir.box> result type. + // Note that the descriptor cannot have been created with fir.rebox because + // the initial-data-target cannot be a fir.box itself (it cannot be + // assumed-shape, deferred-shape, or polymorphic as per C765). However the + // case where the initial data target is a derived type with length parameters + // will most likely be a bit trickier, hence the TODO above. + + mlir::Operation *op = box.getDefiningOp(); + if (!op || !mlir::isa(*op)) + fir::emitFatalError( + loc, "fir.box must be created with embox in global initializers"); + mlir::Type targetEleTy = unwrapElementType(box.getType()); + if (!fir::isa_char(targetEleTy)) + return builder.create(loc, boxType, op->getOperands(), + op->getAttrs()); + + // Handle the character case length particularities: embox takes a length + // value argument when the result type has unknown length, but not when the + // result type has constant length. The type of the initial target must be + // constant length, but the one of the pointer may not be. In this case, a + // length operand must be added. + auto targetLen = targetEleTy.cast().getLen(); + auto ptrLen = unwrapElementType(boxType).cast().getLen(); + if (ptrLen == targetLen) + // Nothing to do + return builder.create(loc, boxType, op->getOperands(), + op->getAttrs()); + auto embox = mlir::cast(*op); + auto ptrType = boxType.cast().getEleTy(); + mlir::Value memref = builder.createConvert(loc, ptrType, embox.getMemref()); + if (targetLen == fir::CharacterType::unknownLen()) + // Drop the length argument. + return builder.create(loc, boxType, memref, embox.getShape(), + embox.getSlice()); + // targetLen is constant and ptrLen is unknown. Add a length argument. + mlir::Value targetLenValue = + builder.createIntegerConstant(loc, builder.getIndexType(), targetLen); + return builder.create(loc, boxType, memref, embox.getShape(), + embox.getSlice(), + mlir::ValueRange{targetLenValue}); +} + +static mlir::Value genDefaultInitializerValue( + Fortran::lower::AbstractConverter &converter, mlir::Location loc, + const Fortran::semantics::Symbol &sym, mlir::Type symTy, + Fortran::lower::StatementContext &stmtCtx) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::Type scalarType = symTy; + fir::SequenceType sequenceType; + if (auto ty = symTy.dyn_cast()) { + sequenceType = ty; + scalarType = ty.getEleTy(); + } + // Build a scalar default value of the symbol type, looping through the + // components to build each component initial value. + auto recTy = scalarType.cast(); + auto fieldTy = fir::FieldType::get(scalarType.getContext()); + mlir::Value initialValue = builder.create(loc, scalarType); + const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType(); + assert(declTy && "var with default initialization must have a type"); + Fortran::semantics::OrderedComponentIterator components( + declTy->derivedTypeSpec()); + for (const auto &component : components) { + // Skip parent components, the sub-components of parent types are part of + // components and will be looped through right after. + if (component.test(Fortran::semantics::Symbol::Flag::ParentComp)) + continue; + mlir::Value componentValue; + llvm::StringRef name = toStringRef(component.name()); + mlir::Type componentTy = recTy.getType(name); + assert(componentTy && "component not found in type"); + if (const auto *object{ + component.detailsIf()}) { + if (const auto &init = object->init()) { + // Component has explicit initialization. + if (Fortran::semantics::IsPointer(component)) + // Initial data target. + componentValue = + genInitialDataTarget(converter, loc, componentTy, *init); + else + // Initial value. + componentValue = fir::getBase( + genInitializerExprValue(converter, loc, *init, stmtCtx)); + } else if (Fortran::semantics::IsAllocatableOrPointer(component)) { + // Pointer or allocatable without initialization. + // Create deallocated/disassociated value. + // From a standard point of view, pointer without initialization do not + // need to be disassociated, but for sanity and simplicity, do it in + // global constructor since this has no runtime cost. + componentValue = fir::factory::createUnallocatedBox( + builder, loc, componentTy, llvm::None); + } else if (hasDefaultInitialization(component)) { + // Component type has default initialization. + componentValue = genDefaultInitializerValue(converter, loc, component, + componentTy, stmtCtx); + } else { + // Component has no initial value. + componentValue = builder.create(loc, componentTy); + } + } else if (const auto *proc{ + component + .detailsIf()}) { + if (proc->init().has_value()) + TODO(loc, "procedure pointer component default initialization"); + else + componentValue = builder.create(loc, componentTy); + } + assert(componentValue && "must have been computed"); + componentValue = builder.createConvert(loc, componentTy, componentValue); + // FIXME: type parameters must come from the derived-type-spec + auto field = builder.create( + loc, fieldTy, name, scalarType, + /*typeParams=*/mlir::ValueRange{} /*TODO*/); + initialValue = builder.create( + loc, recTy, initialValue, componentValue, + builder.getArrayAttr(field.getAttributes())); + } + + if (sequenceType) { + // For arrays, duplicate the scalar value to all elements with an + // fir.insert_range covering the whole array. + auto arrayInitialValue = builder.create(loc, sequenceType); + llvm::SmallVector rangeBounds; + for (int64_t extent : sequenceType.getShape()) { + if (extent == fir::SequenceType::getUnknownExtent()) + TODO(loc, + "default initial value of array component with length parameters"); + rangeBounds.push_back(0); + rangeBounds.push_back(extent - 1); + } + return builder.create( + loc, sequenceType, arrayInitialValue, initialValue, + builder.getIndexVectorAttr(rangeBounds)); + } + return initialValue; +} + +/// Does this global already have an initializer ? +static bool globalIsInitialized(fir::GlobalOp global) { + return !global.getRegion().empty() || global.getInitVal(); +} + +/// Call \p genInit to generate code inside \p global initializer region. +static void +createGlobalInitialization(fir::FirOpBuilder &builder, fir::GlobalOp global, + std::function genInit) { + mlir::Region ®ion = global.getRegion(); + region.push_back(new mlir::Block); + mlir::Block &block = region.back(); + auto insertPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(&block); + genInit(builder); + builder.restoreInsertionPoint(insertPt); +} + +/// Create the global op and its init if it has one +static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable &var, + llvm::StringRef globalName, + mlir::StringAttr linkage) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + const Fortran::semantics::Symbol &sym = var.getSymbol(); + mlir::Location loc = converter.genLocation(sym.name()); + bool isConst = isConstant(sym); + fir::GlobalOp global = builder.getNamedGlobal(globalName); + mlir::Type symTy = converter.genType(var); + + if (global && globalIsInitialized(global)) + return global; + // If this is an array, check to see if we can use a dense attribute + // with a tensor mlir type. This optimization currently only supports + // rank-1 Fortran arrays of integer, real, or logical. The tensor + // type does not support nested structures which are needed for + // complex numbers. + // To get multidimensional arrays to work, we will have to use column major + // array ordering with the tensor type (so it matches column major ordering + // with the Fortran fir.array). By default, tensor types assume row major + // ordering. How to create this tensor type is to be determined. + if (symTy.isa() && sym.Rank() == 1 && + !Fortran::semantics::IsAllocatableOrPointer(sym)) { + mlir::Type eleTy = symTy.cast().getEleTy(); + if (eleTy.isa()) { + const auto *details = + sym.detailsIf(); + if (details->init()) { + global = Fortran::lower::createDenseGlobal( + loc, symTy, globalName, linkage, isConst, details->init().value(), + converter); + if (global) { + global.setVisibility(mlir::SymbolTable::Visibility::Public); + return global; + } + } + } + } + if (!global) + global = builder.createGlobal(loc, symTy, globalName, linkage, + mlir::Attribute{}, isConst); + if (Fortran::semantics::IsAllocatableOrPointer(sym)) { + const auto *details = + sym.detailsIf(); + if (details && details->init()) { + auto expr = *details->init(); + createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) { + mlir::Value box = + Fortran::lower::genInitialDataTarget(converter, loc, symTy, expr); + b.create(loc, box); + }); + } else { + // Create unallocated/disassociated descriptor if no explicit init + createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) { + mlir::Value box = + fir::factory::createUnallocatedBox(b, loc, symTy, llvm::None); + b.create(loc, box); + }); + } + + } else if (const auto *details = + sym.detailsIf()) { + if (details->init()) { + if (fir::isa_char(symTy)) { + // CHARACTER literal + if (auto chLit = getCharacterLiteralCopy(details->init().value())) { + mlir::StringAttr init = + builder.getStringAttr(std::get(*chLit)); + global->setAttr(global.getInitValAttrName(), init); + } else { + fir::emitFatalError(loc, "CHARACTER has unexpected initial value"); + } + } else { + createGlobalInitialization( + builder, global, [&](fir::FirOpBuilder &builder) { + Fortran::lower::StatementContext stmtCtx( + /*cleanupProhibited=*/true); + fir::ExtendedValue initVal = genInitializerExprValue( + converter, loc, details->init().value(), stmtCtx); + mlir::Value castTo = + builder.createConvert(loc, symTy, fir::getBase(initVal)); + builder.create(loc, castTo); + }); + } + } else if (hasDefaultInitialization(sym)) { + createGlobalInitialization( + builder, global, [&](fir::FirOpBuilder &builder) { + Fortran::lower::StatementContext stmtCtx( + /*cleanupProhibited=*/true); + mlir::Value initVal = + genDefaultInitializerValue(converter, loc, sym, symTy, stmtCtx); + mlir::Value castTo = builder.createConvert(loc, symTy, initVal); + builder.create(loc, castTo); + }); + } + } else if (sym.has()) { + mlir::emitError(loc, "COMMON symbol processed elsewhere"); + } else { + TODO(loc, "global"); // Procedure pointer or something else + } + // Creates undefined initializer for globals without initializers + if (!globalIsInitialized(global)) + createGlobalInitialization( + builder, global, [&](fir::FirOpBuilder &builder) { + builder.create( + loc, builder.create(loc, symTy)); + }); + // Set public visibility to prevent global definition to be optimized out + // even if they have no initializer and are unused in this compilation unit. + global.setVisibility(mlir::SymbolTable::Visibility::Public); + return global; +} + +/// Return linkage attribute for \p var. +static mlir::StringAttr +getLinkageAttribute(fir::FirOpBuilder &builder, + const Fortran::lower::pft::Variable &var) { + if (var.isModuleVariable()) + return {}; // external linkage + // Otherwise, the variable is owned by a procedure and must not be visible in + // other compilation units. + return builder.createInternalLinkage(); +} + +/// Instantiate a global variable. If it hasn't already been processed, add +/// the global to the ModuleOp as a new uniqued symbol and initialize it with +/// the correct value. It will be referenced on demand using `fir.addr_of`. +static void instantiateGlobal(Fortran::lower::AbstractConverter &converter, + const Fortran::lower::pft::Variable &var, + Fortran::lower::SymMap &symMap) { + const Fortran::semantics::Symbol &sym = var.getSymbol(); + assert(!var.isAlias() && "must be handled in instantiateAlias"); + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + std::string globalName = Fortran::lower::mangle::mangleName(sym); + mlir::Location loc = converter.genLocation(sym.name()); + fir::GlobalOp global = builder.getNamedGlobal(globalName); + mlir::StringAttr linkage = getLinkageAttribute(builder, var); + if (var.isModuleVariable()) { + // A module global was or will be defined when lowering the module. Emit + // only a declaration if the global does not exist at that point. + global = declareGlobal(converter, var, globalName, linkage); + } else { + global = defineGlobal(converter, var, globalName, linkage); + } + auto addrOf = builder.create(loc, global.resultType(), + global.getSymbol()); + Fortran::lower::StatementContext stmtCtx; + mapSymbolAttributes(converter, var, symMap, stmtCtx, addrOf); +} + //===----------------------------------------------------------------===// // Local variables instantiation (not for alias) //===----------------------------------------------------------------===// @@ -401,7 +864,8 @@ void Fortran::lower::mapSymbolAttributes( void Fortran::lower::instantiateVariable(AbstractConverter &converter, const pft::Variable &var, - SymMap &symMap) { + SymMap &symMap, + AggregateStoreMap &storeMap) { const Fortran::semantics::Symbol &sym = var.getSymbol(); const mlir::Location loc = converter.genLocation(sym.name()); if (var.isAggregateStore()) { @@ -412,7 +876,7 @@ void Fortran::lower::instantiateVariable(AbstractConverter &converter, } else if (var.isAlias()) { TODO(loc, "instantiateVariable Alias"); } else if (var.isGlobal()) { - TODO(loc, "instantiateVariable Global"); + instantiateGlobal(converter, var, symMap); } else { instantiateLocal(converter, var, symMap); } @@ -421,11 +885,12 @@ void Fortran::lower::instantiateVariable(AbstractConverter &converter, void Fortran::lower::mapCallInterfaceSymbols( AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, SymMap &symMap) { + Fortran::lower::AggregateStoreMap storeMap; const Fortran::semantics::Symbol &result = caller.getResultSymbol(); for (Fortran::lower::pft::Variable var : Fortran::lower::pft::buildFuncResultDependencyList(result)) { if (var.isAggregateStore()) { - instantiateVariable(converter, var, symMap); + instantiateVariable(converter, var, symMap, storeMap); } else { const Fortran::semantics::Symbol &sym = var.getSymbol(); const auto *hostDetails = @@ -460,7 +925,7 @@ void Fortran::lower::mapCallInterfaceSymbols( // module or common block variable to satisfy specification expression // requirements in 10.1.11, instantiateVariable will get its address and // properties. - instantiateVariable(converter, var, symMap); + instantiateVariable(converter, var, symMap, storeMap); } } } diff --git a/flang/lib/Lower/IO.cpp b/flang/lib/Lower/IO.cpp new file mode 100644 index 0000000000000..7b396e6e305b0 --- /dev/null +++ b/flang/lib/Lower/IO.cpp @@ -0,0 +1,1695 @@ +//===-- 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/Bridge.h" +#include "flang/Lower/ConvertVariable.h" +#include "flang/Lower/PFTBuilder.h" +#include "flang/Lower/StatementContext.h" +#include "flang/Lower/Support/Utils.h" +#include "flang/Lower/Todo.h" +#include "flang/Optimizer/Builder/BoxValue.h" +#include "flang/Optimizer/Builder/Character.h" +#include "flang/Optimizer/Builder/Complex.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "flang/Optimizer/Builder/MutableBox.h" +#include "flang/Optimizer/Builder/Runtime/RTBuilder.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(); +} + +/// Get (or generate) the MLIR FuncOp for a given IO runtime function. +template +static mlir::FuncOp getIORuntimeFunc(mlir::Location loc, + fir::FirOpBuilder &builder) { + llvm::StringRef name = getName(); + mlir::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::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.getType().getInput(1), + fir::getBase(ioMsgVar)), + builder.createConvert(loc, getIoMsg.getType().getInput(2), + fir::getLen(ioMsgVar))}); + } + mlir::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; + } + 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; + if (auto desc = + builder.getNamedGlobal(converter.mangleName(s) + ".desc")) { + 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::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.getType().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::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); + } + if (auto ty = type.dyn_cast()) { + if (auto kind = ty.getFKind(); kind == 4) + return getIORuntimeFunc(loc, builder); + else if (kind == 8) + return getIORuntimeFunc(loc, builder); + } + if (type.isa()) + return getIORuntimeFunc(loc, builder); + if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) + 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::FuncOp outputFunc = getOutputFunc(loc, builder, itemTy, isFormatted); + mlir::Type argType = outputFunc.getType().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.getType().getInput(1), fir::getBase(exv))); + outputFuncArgs.push_back(builder.createConvert( + loc, outputFunc.getType().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::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); + } + if (auto ty = type.dyn_cast()) { + if (auto kind = ty.getFKind(); kind <= 4) + return getIORuntimeFunc(loc, builder); + else if (kind <= 8) + return getIORuntimeFunc(loc, builder); + } + if (type.isa()) + return getIORuntimeFunc(loc, builder); + if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) + return getIORuntimeFunc(loc, builder); + return getIORuntimeFunc(loc, builder); +} + +static mlir::Value createIoRuntimeCallForItem(mlir::Location loc, + fir::FirOpBuilder &builder, + mlir::FuncOp inputFunc, + mlir::Value cookie, + const fir::ExtendedValue &item) { + mlir::Type argType = inputFunc.getType().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.getType().getInput(2), len)); + } else if (itemTy.isa()) { + inputFuncArgs.push_back(builder.create( + loc, builder.getI32IntegerAttr( + itemTy.cast().getWidth() / 8))); + } + } + return builder.create(loc, inputFunc, inputFuncArgs) + .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)) { + TODO(loc, "genInputItemList with VectorSubscript"); + } + mlir::Type itemTy = converter.genType(*expr); + mlir::FuncOp inputFunc = getInputFunc(loc, builder, itemTy, isFormatted); + auto itemExv = inputFunc.getType().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(); + isa(op); op = op->getBlock()->getParentOp()) { + auto ifOp = 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::FuncOp ioFunc = getIORuntimeFunc(loc, builder); + mlir::FunctionType ioFuncTy = ioFunc.getType(); + 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::FuncOp ioFunc = getIORuntimeFunc(loc, builder); + mlir::FunctionType ioFuncTy = ioFunc.getType(); + 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::FuncOp ioFunc = getIORuntimeFunc(loc, builder); + mlir::FunctionType ioFuncTy = ioFunc.getType(); + 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::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.getType(); + 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::ConnectSpec::Newunit &spec) { + Fortran::lower::StatementContext stmtCtx; + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::FuncOp ioFunc = getIORuntimeFunc(loc, builder); + mlir::FunctionType ioFuncTy = ioFunc.getType(); + const auto *var = Fortran::semantics::GetExpr(spec); + 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); +} + +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::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.getType(); + 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::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; +} + +/// 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 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::FuncOp enableHandlers = + getIORuntimeFunc(loc, builder); + mlir::Type boolType = enableHandlers.getType().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)); +} + +//===----------------------------------------------------------------------===// +// 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::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::FuncOp ioFunc = getBeginDataTransferFunc( + loc, builder, isFormatted, isList || isNml, isInternal, + isInternalWithDesc, isAsync); + llvm::SmallVector ioArgs; + genBeginDataTransferCallArgs( + ioArgs, converter, loc, stmt, ioFunc.getType(), 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); +} diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp index 9a9a31e5d53fe..f2b45e6a82f2f 100644 --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -1416,6 +1416,13 @@ void fir::FieldIndexOp::build(mlir::OpBuilder &builder, result.addOperands(operands); } +llvm::SmallVector fir::FieldIndexOp::getAttributes() { + llvm::SmallVector attrs; + attrs.push_back(getFieldIdAttr()); + attrs.push_back(getOnTypeAttr()); + return attrs; +} + //===----------------------------------------------------------------------===// // InsertOnRangeOp //===----------------------------------------------------------------------===// diff --git a/flang/test/Lower/io-statement-1.f90 b/flang/test/Lower/io-statement-1.f90 new file mode 100644 index 0000000000000..1f9f51a6993e4 --- /dev/null +++ b/flang/test/Lower/io-statement-1.f90 @@ -0,0 +1,55 @@ +! RUN: bbc %s -o - | FileCheck %s +! UNSUPPORTED: system-windows + + logical :: existsvar + integer :: length + real :: a(100) + + ! CHECK-LABEL: _QQmain + ! CHECK: call {{.*}}BeginExternalListInput + ! CHECK: call {{.*}}InputInteger + ! CHECK: call {{.*}}InputReal32 + ! CHECK: call {{.*}}EndIoStatement + read (8,*) i, f + + ! CHECK: call {{.*}}BeginExternalListOutput + ! CHECK: call {{.*}}OutputInteger32 + ! CHECK: call {{.*}}OutputReal32 + ! CHECK: call {{.*}}EndIoStatement + write (8,*) i, f + + ! CHECK: call {{.*}}BeginExternalListOutput + ! CHECK: call {{.*}}OutputAscii + ! CHECK: call {{.*}}EndIoStatement + print *, "A literal string" +end + +! CHECK-LABEL: @_QPboz +subroutine boz + ! CHECK: fir.call @_FortranAioOutputInteger8(%{{.*}}, %{{.*}}) : (!fir.ref, i8) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger16(%{{.*}}, %{{.*}}) : (!fir.ref, i16) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref, i32) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger128(%{{.*}}, %{{.*}}) : (!fir.ref, i128) -> i1 + print '(*(Z3))', 96_1, 96_2, 96_4, 96_8, 96_16 + + ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref, i32) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + print '(I3,2Z44)', 40, 2**40_8, 2**40_8+1 + + ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref, i32) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + print '(I3,2I44)', 40, 1099511627776, 1099511627777 + + ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref, i32) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + print '(I3,2O44)', 40, 2**40_8, 2**40_8+1 + + ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref, i32) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref, i64) -> i1 + print '(I3,2B44)', 40, 2**40_8, 2**40_8+1 +end diff --git a/flang/test/Lower/io-statement-2.f90 b/flang/test/Lower/io-statement-2.f90 new file mode 100644 index 0000000000000..b6e3603707089 --- /dev/null +++ b/flang/test/Lower/io-statement-2.f90 @@ -0,0 +1,35 @@ +! RUN: bbc -emit-fir -o - %s | FileCheck %s + + character*10 :: exx + character*30 :: m + integer*2 :: s + exx = 'AA' + m = 'CCCCCC' + s = -13 + ! CHECK: call {{.*}}BeginExternalFormattedInput + ! CHECK: call {{.*}}EnableHandlers + ! CHECK: call {{.*}}SetAdvance + ! CHECK: call {{.*}}InputReal + ! CHECK: call {{.*}}GetIoMsg + ! CHECK: call {{.*}}EndIoStatement + ! CHECK: fir.select %{{.*}} : index [-2, ^bb4, -1, ^bb3, 0, ^bb1, unit, ^bb2] + read(*, '(A)', ADVANCE='NO', ERR=10, END=20, EOR=30, IOSTAT=s, IOMSG=m) f + ! CHECK-LABEL: ^bb1: + exx = 'Zip'; goto 90 +10 exx = 'Err'; goto 90 +20 exx = 'End'; goto 90 +30 exx = 'Eor'; goto 90 +90 print*, exx, c, m, s +end + +! CHECK-LABEL: func @_QPimpliedformat +subroutine impliedformat + ! CHECK: BeginExternalListInput(%c-1 + ! CHECK: InputReal32 + ! CHECK: EndIoStatement(%3) : (!fir.ref) -> i32 + read*, x + ! CHECK: BeginExternalListOutput(%c-1 + ! CHECK: OutputReal32 + ! CHECK: EndIoStatement + print*, x +end