Index: flang/include/flang/Lower/AbstractConverter.h =================================================================== --- flang/include/flang/Lower/AbstractConverter.h +++ flang/include/flang/Lower/AbstractConverter.h @@ -227,6 +227,9 @@ /// Generate the location as converted from a CharBlock virtual mlir::Location genLocation(const Fortran::parser::CharBlock &) = 0; + /// Get the converter's current scope + virtual const Fortran::semantics::Scope &getCurrentScope() = 0; + //===--------------------------------------------------------------------===// // FIR/MLIR //===--------------------------------------------------------------------===// @@ -237,11 +240,13 @@ virtual mlir::ModuleOp &getModuleOp() = 0; /// Get the MLIRContext virtual mlir::MLIRContext &getMLIRContext() = 0; - /// Unique a symbol + /// Unique a symbol (add a containing scope specific prefix) virtual std::string mangleName(const Fortran::semantics::Symbol &) = 0; - /// Unique a derived type + /// Unique a derived type (add a containing scope specific prefix) virtual std::string mangleName(const Fortran::semantics::DerivedTypeSpec &) = 0; + /// Unique a compiler generated name (add a containing scope specific prefix) + virtual std::string mangleName(std::string &) = 0; /// Get the KindMap. virtual const fir::KindMapping &getKindMap() = 0; Index: flang/include/flang/Lower/Mangler.h =================================================================== --- flang/include/flang/Lower/Mangler.h +++ flang/include/flang/Lower/Mangler.h @@ -50,6 +50,10 @@ /// Convert a derived type instance to an internal name. std::string mangleName(const semantics::DerivedTypeSpec &, ScopeBlockIdMap &); +/// Add a scope specific mangling prefix to a compiler generated name. +std::string mangleName(std::string &, const Fortran::semantics::Scope &, + ScopeBlockIdMap &); + /// Recover the bare name of the original symbol from an internal name. std::string demangleName(llvm::StringRef name); Index: flang/include/flang/Optimizer/Support/InternalNames.h =================================================================== --- flang/include/flang/Optimizer/Support/InternalNames.h +++ flang/include/flang/Optimizer/Support/InternalNames.h @@ -80,8 +80,12 @@ std::int64_t block, llvm::StringRef name, llvm::ArrayRef kinds); - /// Unique a compiler generated name + /// Unique a compiler generated name without scope context. static std::string doGenerated(llvm::StringRef name); + /// Unique a compiler generated name with scope context. + static std::string doGenerated(llvm::ArrayRef modules, + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name); /// Unique an intrinsic type descriptor static std::string Index: flang/include/flang/Semantics/runtime-type-info.h =================================================================== --- flang/include/flang/Semantics/runtime-type-info.h +++ flang/include/flang/Semantics/runtime-type-info.h @@ -55,7 +55,15 @@ }; std::multimap -CollectNonTbpDefinedIoGenericInterfaces(const Scope &scope); +CollectNonTbpDefinedIoGenericInterfaces( + const Scope &, bool useRuntimeTypeInfoEntries); + +bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + const Scope &, const DerivedTypeSpec *); +bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + const Scope &, const DeclTypeSpec *); +bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + const Scope &, const Symbol *); } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_ Index: flang/lib/Lower/Bridge.cpp =================================================================== --- flang/lib/Lower/Bridge.cpp +++ flang/lib/Lower/Bridge.cpp @@ -742,6 +742,10 @@ return genUnknownLocation(); } + const Fortran::semantics::Scope &getCurrentScope() override final { + return bridge.getSemanticsContext().FindScope(currentPosition); + } + fir::FirOpBuilder &getFirOpBuilder() override final { return *builder; } mlir::ModuleOp &getModuleOp() override final { return bridge.getModule(); } @@ -757,7 +761,10 @@ const Fortran::semantics::DerivedTypeSpec &derivedType) override final { return Fortran::lower::mangle::mangleName(derivedType, scopeBlockIdMap); } - + std::string mangleName(std::string &name) override final { + return Fortran::lower::mangle::mangleName(name, getCurrentScope(), + scopeBlockIdMap); + } const fir::KindMapping &getKindMap() override final { return bridge.getKindMap(); } Index: flang/lib/Lower/IO.cpp =================================================================== --- flang/lib/Lower/IO.cpp +++ flang/lib/Lower/IO.cpp @@ -15,6 +15,7 @@ #include "flang/Evaluate/tools.h" #include "flang/Lower/Allocatable.h" #include "flang/Lower/Bridge.h" +#include "flang/Lower/CallInterface.h" #include "flang/Lower/ConvertExpr.h" #include "flang/Lower/ConvertVariable.h" #include "flang/Lower/Mangler.h" @@ -32,6 +33,7 @@ #include "flang/Optimizer/Dialect/Support/FIRContext.h" #include "flang/Parser/parse-tree.h" #include "flang/Runtime/io-api.h" +#include "flang/Semantics/runtime-type-info.h" #include "flang/Semantics/tools.h" #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" #include "llvm/Support/Debug.h" @@ -46,6 +48,13 @@ return getModel(); } template <> +constexpr TypeBuilderFunc getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return mlir::IntegerType::get(context, + 8 * sizeof(Fortran::runtime::io::Iostat)); + }; +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { @@ -53,10 +62,10 @@ }; } template <> -constexpr TypeBuilderFunc getModel() { +constexpr TypeBuilderFunc +getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { - return mlir::IntegerType::get(context, - 8 * sizeof(Fortran::runtime::io::Iostat)); + return fir::ReferenceType::get(mlir::TupleType::get(context)); }; } } // namespace fir::runtime @@ -72,38 +81,39 @@ /// 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(BeginBackspace), mkIOKey(BeginClose), mkIOKey(BeginEndfile), + mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginExternalFormattedOutput), + mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalListOutput), + mkIOKey(BeginFlush), mkIOKey(BeginInquireFile), + mkIOKey(BeginInquireIoLength), mkIOKey(BeginInquireUnit), + mkIOKey(BeginInternalArrayFormattedInput), 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(BeginWait), mkIOKey(BeginWaitAll), - mkIOKey(BeginClose), mkIOKey(BeginFlush), mkIOKey(BeginBackspace), - mkIOKey(BeginEndfile), mkIOKey(BeginRewind), mkIOKey(BeginOpenUnit), - mkIOKey(BeginOpenNewUnit), mkIOKey(BeginInquireUnit), - mkIOKey(BeginInquireFile), mkIOKey(BeginInquireIoLength), + mkIOKey(BeginInternalArrayListInput), mkIOKey(BeginInternalArrayListOutput), + mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginInternalFormattedOutput), + mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalListOutput), + mkIOKey(BeginOpenNewUnit), mkIOKey(BeginOpenUnit), mkIOKey(BeginRewind), + mkIOKey(BeginUnformattedInput), mkIOKey(BeginUnformattedOutput), + mkIOKey(BeginWait), mkIOKey(BeginWaitAll), mkIOKey(CheckUnitNumberInRange64), mkIOKey(CheckUnitNumberInRange128), - 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), mkIOKey(OutputInteger128), 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), mkIOKey(SetConvert)> + mkIOKey(EnableHandlers), mkIOKey(EndIoStatement), mkIOKey(GetIoLength), + mkIOKey(GetIoMsg), mkIOKey(GetNewUnit), mkIOKey(GetSize), + mkIOKey(InputAscii), mkIOKey(InputComplex32), mkIOKey(InputComplex64), + mkIOKey(InputDerivedType), mkIOKey(InputDescriptor), mkIOKey(InputInteger), + mkIOKey(InputLogical), mkIOKey(InputNamelist), mkIOKey(InputReal32), + mkIOKey(InputReal64), mkIOKey(InputUnformattedBlock), + mkIOKey(InquireCharacter), mkIOKey(InquireInteger64), + mkIOKey(InquireLogical), mkIOKey(InquirePendingId), mkIOKey(OutputAscii), + mkIOKey(OutputComplex32), mkIOKey(OutputComplex64), + mkIOKey(OutputDerivedType), mkIOKey(OutputDescriptor), + mkIOKey(OutputInteger8), mkIOKey(OutputInteger16), mkIOKey(OutputInteger32), + mkIOKey(OutputInteger64), mkIOKey(OutputInteger128), mkIOKey(OutputLogical), + mkIOKey(OutputNamelist), mkIOKey(OutputReal32), mkIOKey(OutputReal64), + mkIOKey(OutputUnformattedBlock), mkIOKey(SetAccess), mkIOKey(SetAction), + mkIOKey(SetAdvance), mkIOKey(SetAsynchronous), mkIOKey(SetBlank), + mkIOKey(SetCarriagecontrol), mkIOKey(SetConvert), mkIOKey(SetDecimal), + mkIOKey(SetDelim), mkIOKey(SetEncoding), mkIOKey(SetFile), mkIOKey(SetForm), + mkIOKey(SetPad), mkIOKey(SetPos), mkIOKey(SetPosition), mkIOKey(SetRec), + mkIOKey(SetRecl), mkIOKey(SetRound), mkIOKey(SetSign), mkIOKey(SetStatus)> newIOTable; } // namespace Fortran::lower @@ -238,10 +248,210 @@ builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); } -/// Retrieve or generate a runtime description of NAMELIST group `symbol`. +// Derived type symbols may each be mapped to up to 4 defined IO procedures. +using DefinedIoProcMap = std::multimap; + +/// Get the current scope's non-type-bound defined IO procedures. +static DefinedIoProcMap +getDefinedIoProcMap(Fortran::lower::AbstractConverter &converter) { + const Fortran::semantics::Scope *scope = &converter.getCurrentScope(); + for (; !scope->IsGlobal(); scope = &scope->parent()) + if (scope->kind() == Fortran::semantics::Scope::Kind::MainProgram || + scope->kind() == Fortran::semantics::Scope::Kind::Subprogram || + scope->kind() == Fortran::semantics::Scope::Kind::BlockConstruct) + break; + return Fortran::semantics::CollectNonTbpDefinedIoGenericInterfaces(*scope, + false); +} + +/// Check a set of defined IO procedures for any procedure pointer or dummy +/// procedures. +static bool hasLocalDefinedIoProc(DefinedIoProcMap &definedIoProcMap) { + for (auto &iface : definedIoProcMap) { + const Fortran::semantics::Symbol *procSym = iface.second.subroutine; + if (!procSym) + continue; + procSym = &procSym->GetUltimate(); + if (Fortran::semantics::IsProcedurePointer(*procSym) || + Fortran::semantics::IsDummy(*procSym)) + return true; + } + return false; +} + +/// Retrieve or generate a runtime description of the non-type-bound defined +/// IO procedures in the current scope. If any procedure is a dummy or a +/// procedure pointer, the result is local. Otherwise the result is static. +/// If there are no procedures, return a scope-independent default table with +/// an empty procedure list, but with the `ignoreNonTbpEntries` flag set. The +/// form of the description is defined in runtime header file non-tbp-dio.h. +static mlir::Value +getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter, + DefinedIoProcMap &definedIoProcMap) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::MLIRContext *context = builder.getContext(); + mlir::Location loc = converter.getCurrentLocation(); + mlir::Type refTy = fir::ReferenceType::get(mlir::NoneType::get(context)); + std::string suffix = ".nonTbpDefinedIoTable"; + std::string tableMangleName = definedIoProcMap.empty() + ? "default" + suffix + : converter.mangleName(suffix); + if (auto table = builder.getNamedGlobal(tableMangleName)) + return builder.createConvert( + loc, refTy, + builder.create(loc, table.resultType(), + table.getSymbol())); + + mlir::StringAttr linkOnce = builder.createLinkOnceLinkage(); + mlir::Type idxTy = builder.getIndexType(); + mlir::Type sizeTy = + fir::runtime::getModel()(builder.getContext()); + mlir::Type intTy = fir::runtime::getModel()(builder.getContext()); + mlir::Type boolTy = fir::runtime::getModel()(builder.getContext()); + mlir::Type listTy = fir::SequenceType::get( + definedIoProcMap.size(), + mlir::TupleType::get(context, {refTy, refTy, intTy, boolTy})); + mlir::Type tableTy = mlir::TupleType::get( + context, {sizeTy, fir::ReferenceType::get(listTy), boolTy}); + + // Define the list of NonTbpDefinedIo procedures. + bool tableIsLocal = + !definedIoProcMap.empty() && hasLocalDefinedIoProc(definedIoProcMap); + mlir::Value listAddr = + tableIsLocal ? builder.create(loc, listTy) : mlir::Value{}; + std::string listMangleName = tableMangleName + ".list"; + auto listFunc = [&](fir::FirOpBuilder &builder) { + mlir::Value list = builder.create(loc, listTy); + mlir::IntegerAttr intAttr[4]; + for (int i = 0; i < 4; ++i) + intAttr[i] = builder.getIntegerAttr(idxTy, i); + llvm::SmallVector idx = {mlir::Attribute{}, + mlir::Attribute{}}; + int n0 = 0, n1; + auto insert = [&](mlir::Value val) { + idx[1] = intAttr[n1++]; + list = builder.create(loc, listTy, list, val, + builder.getArrayAttr(idx)); + }; + for (auto &iface : definedIoProcMap) { + idx[0] = builder.getIntegerAttr(idxTy, n0++); + n1 = 0; + // derived type description [const typeInfo::DerivedType &derivedType] + const Fortran::semantics::Symbol &dtSym = iface.first->GetUltimate(); + std::string dtName = converter.mangleName(dtSym); + insert(builder.createConvert( + loc, refTy, + builder.create( + loc, fir::ReferenceType::get(converter.genType(dtSym)), + builder.getSymbolRefAttr(dtName)))); + // defined IO procedure [void (*subroutine)()], may be null + const Fortran::semantics::Symbol *procSym = iface.second.subroutine; + if (procSym) { + procSym = &procSym->GetUltimate(); + if (Fortran::semantics::IsProcedurePointer(*procSym)) { + TODO(loc, "defined IO procedure pointers"); + } else if (Fortran::semantics::IsDummy(*procSym)) { + Fortran::lower::StatementContext stmtCtx; + insert(builder.create( + loc, refTy, + fir::getBase(converter.genExprAddr( + loc, + Fortran::lower::SomeExpr{ + Fortran::evaluate::ProcedureDesignator{*procSym}}, + stmtCtx)))); + } else { + std::string procName = converter.mangleName(*procSym); + mlir::func::FuncOp procDef = builder.getNamedFunction(procName); + if (!procDef) + procDef = Fortran::lower::getOrDeclareFunction( + procName, Fortran::evaluate::ProcedureDesignator{*procSym}, + converter); + insert( + builder.createConvert(loc, refTy, + builder.create( + loc, procDef.getFunctionType(), + builder.getSymbolRefAttr(procName)))); + } + } else { + insert(builder.createNullConstant(loc, refTy)); + } + // defined IO variant, one of (read/write, formatted/unformatted) + // [common::DefinedIo definedIo] + insert(builder.createIntegerConstant( + loc, intTy, static_cast(iface.second.definedIo))); + // polymorphic flag is set if first defined IO dummy arg is CLASS(T) + // [bool isDtvArgPolymorphic] + insert(builder.createIntegerConstant(loc, boolTy, + iface.second.isDtvArgPolymorphic)); + } + if (tableIsLocal) + builder.create(loc, list, listAddr); + else + builder.create(loc, list); + }; + if (!definedIoProcMap.empty()) { + if (tableIsLocal) + listFunc(builder); + else + builder.createGlobalConstant(loc, listTy, listMangleName, listFunc, + linkOnce); + } + + // Define the NonTbpDefinedIoTable. + mlir::Value tableAddr = tableIsLocal + ? builder.create(loc, tableTy) + : mlir::Value{}; + auto tableFunc = [&](fir::FirOpBuilder &builder) { + mlir::Value table = builder.create(loc, tableTy); + // list item count [std::size_t items] + table = builder.create( + loc, tableTy, table, + builder.createIntegerConstant(loc, sizeTy, definedIoProcMap.size()), + builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0))); + // item list [const NonTbpDefinedIo *item] + if (definedIoProcMap.empty()) + listAddr = builder.createNullConstant(loc, builder.getRefType(listTy)); + else if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName)) + listAddr = builder.create(loc, list.resultType(), + list.getSymbol()); + assert(listAddr && "missing namelist object list"); + table = builder.create( + loc, tableTy, table, listAddr, + builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1))); + // [bool ignoreNonTbpEntries] conservatively set to true + table = builder.create( + loc, tableTy, table, builder.createIntegerConstant(loc, boolTy, true), + builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2))); + if (tableIsLocal) + builder.create(loc, table, tableAddr); + else + builder.create(loc, table); + }; + if (tableIsLocal) { + tableFunc(builder); + } else { + fir::GlobalOp table = builder.createGlobal( + loc, tableTy, tableMangleName, + /*isConst=*/true, /*isTarget=*/false, tableFunc, linkOnce); + tableAddr = builder.create( + loc, fir::ReferenceType::get(tableTy), table.getSymbol()); + } + assert(tableAddr && "missing NonTbpDefinedIo table result"); + return builder.createConvert(loc, refTy, tableAddr); +} + +static mlir::Value +getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter) { + DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter); + return getNonTbpDefinedIoTableAddr(converter, definedIoProcMap); +} + +/// Retrieve or generate a runtime description of NAMELIST group \p 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. +/// local objects. If all descriptors and defined IO procedures are static, +/// the NamelistGroup is static. static mlir::Value getNamelistGroup(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &symbol, @@ -257,24 +467,26 @@ 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 = + mlir::Type idxTy = builder.getIndexType(); + mlir::Type sizeTy = + fir::runtime::getModel()(builder.getContext()); + mlir::Type charRefTy = fir::ReferenceType::get(builder.getIntegerType(8)); + mlir::Type descRefTy = fir::ReferenceType::get(fir::BoxType::get(mlir::NoneType::get(context))); - fir::SequenceType listTy = fir::SequenceType::get( + mlir::Type 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)}); + mlir::Type groupTy = mlir::TupleType::get( + context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy), + fir::ReferenceType::get(mlir::NoneType::get(context))}); auto stringAddress = [&](const Fortran::semantics::Symbol &symbol) { return fir::factory::createStringLiteral(builder, loc, symbol.name().ToString() + '\0'); }; // Define variable names, and static descriptors for global variables. - bool groupIsLocal = false; + DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter); + bool groupIsLocal = hasLocalDefinedIoProc(definedIoProcMap); stringAddress(symbol); for (const Fortran::semantics::Symbol &s : details.objects()) { stringAddress(s); @@ -312,9 +524,9 @@ mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1); llvm::SmallVector idx = {mlir::Attribute{}, mlir::Attribute{}}; - size_t n = 0; + int n = 0; for (const Fortran::semantics::Symbol &s : details.objects()) { - idx[0] = builder.getIntegerAttr(idxTy, n); + idx[0] = builder.getIntegerAttr(idxTy, n++); idx[1] = zero; mlir::Value nameAddr = builder.createConvert(loc, charRefTy, fir::getBase(stringAddress(s))); @@ -361,7 +573,6 @@ descAddr = builder.createConvert(loc, descRefTy, descAddr); list = builder.create(loc, listTy, list, descAddr, builder.getArrayAttr(idx)); - ++n; } if (groupIsLocal) builder.create(loc, list, listAddr); @@ -379,24 +590,32 @@ ? 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)); + // group name [const char *groupName] + group = builder.create( + loc, groupTy, group, + builder.createConvert(loc, charRefTy, + fir::getBase(stringAddress(symbol))), + builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0))); + // list item count [std::size_t items] + group = builder.create( + loc, groupTy, group, + builder.createIntegerConstant(loc, sizeTy, details.objects().size()), + builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1))); + // item list [const Item *item] 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)); + group = builder.create( + loc, groupTy, group, listAddr, + builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2))); + // non-type-bound defined IO procedures + // [const NonTbpDefinedIoTable *nonTbpDefinedIo] + group = builder.create( + loc, groupTy, group, + getNonTbpDefinedIoTableAddr(converter, definedIoProcMap), + builder.getArrayAttr(builder.getIntegerAttr(idxTy, 3))); if (groupIsLocal) builder.create(loc, group, groupAddr); else @@ -435,6 +654,8 @@ static mlir::func::FuncOp getOutputFunc(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Type type, bool isFormatted) { + if (type.isa()) + return getIORuntimeFunc(loc, builder); if (!isFormatted) return getIORuntimeFunc(loc, builder); if (auto ty = type.dyn_cast()) { @@ -515,6 +736,8 @@ if (argType.isa()) { mlir::Value box = fir::getBase(converter.genExprBox(loc, *expr, stmtCtx)); outputFuncArgs.push_back(builder.createConvert(loc, argType, box)); + if (itemTy.isa()) + outputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter)); } else if (helper.isCharacterScalar(itemTy)) { fir::ExtendedValue exv = converter.genExprAddr(loc, expr, stmtCtx); // scalar allocatable/pointer may also get here, not clear if @@ -548,6 +771,8 @@ static mlir::func::FuncOp getInputFunc(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Type type, bool isFormatted) { + if (type.isa()) + return getIORuntimeFunc(loc, builder); if (!isFormatted) return getIORuntimeFunc(loc, builder); if (auto ty = type.dyn_cast()) @@ -596,18 +821,20 @@ builder.create(loc, logicalValue, addr); } -static mlir::Value createIoRuntimeCallForItem(mlir::Location loc, - fir::FirOpBuilder &builder, - mlir::func::FuncOp inputFunc, - mlir::Value cookie, - const fir::ExtendedValue &item) { +static mlir::Value +createIoRuntimeCallForItem(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, mlir::func::FuncOp inputFunc, + mlir::Value cookie, const fir::ExtendedValue &item) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Type argType = inputFunc.getFunctionType().getInput(1); llvm::SmallVector inputFuncArgs = {cookie}; if (argType.isa()) { mlir::Value box = fir::getBase(item); - assert(box.getType().isa() && - "must be previously emboxed"); + auto boxTy = box.getType().dyn_cast(); + assert(boxTy && "must be previously emboxed"); inputFuncArgs.push_back(builder.createConvert(loc, argType, box)); + if (boxTy.getEleTy().isa()) + inputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter)); } else { mlir::Value itemAddr = fir::getBase(item); mlir::Type itemTy = fir::unwrapPassByRefType(itemAddr.getType()); @@ -660,7 +887,7 @@ inputFunc.getFunctionType().getInput(1).isa(); if (!checkResult) { auto elementalGenerator = [&](const fir::ExtendedValue &element) { - createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, + createIoRuntimeCallForItem(converter, loc, inputFunc, cookie, mustBox ? builder.createBox(loc, element) : element); }; @@ -669,7 +896,7 @@ auto elementalGenerator = [&](const fir::ExtendedValue &element) -> mlir::Value { return createIoRuntimeCallForItem( - loc, builder, inputFunc, cookie, + converter, loc, inputFunc, cookie, mustBox ? builder.createBox(loc, element) : element); }; if (!ok) @@ -685,7 +912,7 @@ auto itemExv = inputFunc.getFunctionType().getInput(1).isa() ? converter.genExprBox(loc, *expr, stmtCtx) : converter.genExprAddr(loc, expr, stmtCtx); - ok = createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, itemExv); + ok = createIoRuntimeCallForItem(converter, loc, inputFunc, cookie, itemExv); } } Index: flang/lib/Lower/Mangler.cpp =================================================================== --- flang/lib/Lower/Mangler.cpp +++ flang/lib/Lower/Mangler.cpp @@ -20,13 +20,13 @@ /// Return all ancestor module and submodule scope names; all host procedure /// and statement function scope names; and the innermost blockId containing -/// \p symbol. +/// \p scope, including scope itself. static std::tuple, llvm::SmallVector, std::int64_t> -ancestors(const Fortran::semantics::Symbol &symbol, +ancestors(const Fortran::semantics::Scope &scope, Fortran::lower::mangle::ScopeBlockIdMap &scopeBlockIdMap) { llvm::SmallVector scopes; - for (auto *scp = &symbol.owner(); !scp->IsGlobal(); scp = &scp->parent()) + for (auto *scp = &scope; !scp->IsGlobal(); scp = &scp->parent()) scopes.push_back(scp); llvm::SmallVector modules; llvm::SmallVector procs; @@ -60,6 +60,28 @@ return {modules, procs, blockId}; } +/// Return all ancestor module and submodule scope names; all host procedure +/// and statement function scope names; and the innermost blockId containing +/// \p symbol. +static std::tuple, + llvm::SmallVector, std::int64_t> +ancestors(const Fortran::semantics::Symbol &symbol, + Fortran::lower::mangle::ScopeBlockIdMap &scopeBlockIdMap) { + return ancestors(symbol.owner(), scopeBlockIdMap); +} + +/// Return a globally unique string for a compiler generated \p name. +std::string +Fortran::lower::mangle::mangleName(std::string &name, + const Fortran::semantics::Scope &scope, + ScopeBlockIdMap &scopeBlockIdMap) { + llvm::SmallVector modules; + llvm::SmallVector procs; + std::int64_t blockId; + std::tie(modules, procs, blockId) = ancestors(scope, scopeBlockIdMap); + return fir::NameUniquer::doGenerated(modules, procs, blockId, name); +} + // Mangle the name of \p symbol to make it globally unique. std::string Fortran::lower::mangle::mangleName(const Fortran::semantics::Symbol &symbol, Index: flang/lib/Optimizer/Support/InternalNames.cpp =================================================================== --- flang/lib/Optimizer/Support/InternalNames.cpp +++ flang/lib/Optimizer/Support/InternalNames.cpp @@ -100,17 +100,17 @@ } std::string fir::NameUniquer::doCommonBlock(llvm::StringRef name) { - std::string result = prefix(); - return result.append("C").append(toLower(name)); + return prefix().append("C").append(toLower(name)); } std::string fir::NameUniquer::doConstant(llvm::ArrayRef modules, llvm::ArrayRef procs, std::int64_t blockId, llvm::StringRef name) { - std::string result = prefix(); - result.append(doAncestors(modules, procs, blockId)).append("EC"); - return result.append(toLower(name)); + return prefix() + .append(doAncestors(modules, procs, blockId)) + .append("EC") + .append(toLower(name)); } std::string @@ -118,14 +118,25 @@ llvm::ArrayRef procs, std::int64_t blockId, llvm::StringRef name, llvm::ArrayRef kinds) { - std::string result = prefix(); - result.append(doAncestors(modules, procs, blockId)).append("DT"); - return result.append(toLower(name)).append(doKinds(kinds)); + return prefix() + .append(doAncestors(modules, procs, blockId)) + .append("DT") + .append(toLower(name)) + .append(doKinds(kinds)); } std::string fir::NameUniquer::doGenerated(llvm::StringRef name) { - std::string result = prefix(); - return result.append("Q").append(name); + return prefix().append("Q").append(name); +} + +std::string +fir::NameUniquer::doGenerated(llvm::ArrayRef modules, + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name) { + return prefix() + .append("Q") + .append(doAncestors(modules, procs, blockId)) + .append(name); } std::string fir::NameUniquer::doIntrinsicTypeDescriptor( @@ -151,27 +162,32 @@ break; } assert(name && "unknown intrinsic type"); - std::string result = prefix(); - result.append(doAncestors(modules, procs, blockId)).append("YI"); - return result.append(name).append(doKind(kind)); + return prefix() + .append(doAncestors(modules, procs, blockId)) + .append("YI") + .append(name) + .append(doKind(kind)); } std::string fir::NameUniquer::doProcedure(llvm::ArrayRef modules, llvm::ArrayRef procs, llvm::StringRef name) { - std::string result = prefix(); - result.append(doAncestors(modules, procs)).append("P"); - return result.append(toLower(name)); + return prefix() + .append(doAncestors(modules, procs)) + .append("P") + .append(toLower(name)); } std::string fir::NameUniquer::doType(llvm::ArrayRef modules, llvm::ArrayRef procs, std::int64_t blockId, llvm::StringRef name, llvm::ArrayRef kinds) { - std::string result = prefix(); - result.append(doAncestors(modules, procs, blockId)).append("T"); - return result.append(toLower(name)).append(doKinds(kinds)); + return prefix() + .append(doAncestors(modules, procs, blockId)) + .append("T") + .append(toLower(name)) + .append(doKinds(kinds)); } std::string @@ -179,9 +195,11 @@ llvm::ArrayRef procs, std::int64_t blockId, llvm::StringRef name, llvm::ArrayRef kinds) { - std::string result = prefix(); - result.append(doAncestors(modules, procs, blockId)).append("CT"); - return result.append(toLower(name)).append(doKinds(kinds)); + return prefix() + .append(doAncestors(modules, procs, blockId)) + .append("CT") + .append(toLower(name)) + .append(doKinds(kinds)); } std::string @@ -198,18 +216,20 @@ fir::NameUniquer::doVariable(llvm::ArrayRef modules, llvm::ArrayRef procs, std::int64_t blockId, llvm::StringRef name) { - std::string result = prefix(); - result.append(doAncestors(modules, procs, blockId)).append("E"); - return result.append(toLower(name)); + return prefix() + .append(doAncestors(modules, procs, blockId)) + .append("E") + .append(toLower(name)); } std::string fir::NameUniquer::doNamelistGroup(llvm::ArrayRef modules, llvm::ArrayRef procs, llvm::StringRef name) { - std::string result = prefix(); - result.append(doAncestors(modules, procs)).append("N"); - return result.append(toLower(name)); + return prefix() + .append(doAncestors(modules, procs)) + .append("N") + .append(toLower(name)); } llvm::StringRef fir::NameUniquer::doProgramEntry() { Index: flang/lib/Semantics/runtime-type-info.cpp =================================================================== --- flang/lib/Semantics/runtime-type-info.cpp +++ flang/lib/Semantics/runtime-type-info.cpp @@ -1026,32 +1026,31 @@ void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic, std::map &specials, const Scope &dtScope, const DerivedTypeSpec *derivedTypeSpec) const { - common::visit(common::visitors{ - [&](const GenericKind::OtherKind &k) { - if (k == GenericKind::OtherKind::Assignment) { - for (auto ref : generic.specificProcs()) { - DescribeSpecialProc(specials, *ref, true, - false /*!final*/, std::nullopt, &dtScope, - derivedTypeSpec, true); - } - } - }, - [&](const common::DefinedIo &io) { - switch (io) { - case common::DefinedIo::ReadFormatted: - case common::DefinedIo::ReadUnformatted: - case common::DefinedIo::WriteFormatted: - case common::DefinedIo::WriteUnformatted: - for (auto ref : generic.specificProcs()) { - DescribeSpecialProc(specials, *ref, false, - false /*!final*/, io, &dtScope, derivedTypeSpec, - true); - } - break; - } - }, - [](const auto &) {}, - }, + common::visit( + common::visitors{ + [&](const GenericKind::OtherKind &k) { + if (k == GenericKind::OtherKind::Assignment) { + for (auto ref : generic.specificProcs()) { + DescribeSpecialProc(specials, *ref, true, false /*!final*/, + std::nullopt, &dtScope, derivedTypeSpec, true); + } + } + }, + [&](const common::DefinedIo &io) { + switch (io) { + case common::DefinedIo::ReadFormatted: + case common::DefinedIo::ReadUnformatted: + case common::DefinedIo::WriteFormatted: + case common::DefinedIo::WriteUnformatted: + for (auto ref : generic.specificProcs()) { + DescribeSpecialProc(specials, *ref, false, false /*!final*/, io, + &dtScope, derivedTypeSpec, true); + } + break; + } + }, + [](const auto &) {}, + }, generic.kind().u); } @@ -1208,68 +1207,93 @@ return result; } +// Find the type of a defined I/O procedure's interface's initial "dtv" +// dummy argument. Returns a non-null DeclTypeSpec pointer only if that +// dtv argument exists and is a derived type. +static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) { + const Symbol *interface { + &specific.GetUltimate() + }; + if (const auto *procEntity{specific.detailsIf()}) { + interface = procEntity->procInterface(); + } + if (interface) { + if (const SubprogramDetails * + subprogram{interface->detailsIf()}; + subprogram && !subprogram->dummyArgs().empty()) { + if (const Symbol * dtvArg{subprogram->dummyArgs().at(0)}) { + if (const DeclTypeSpec * declType{dtvArg->GetType()}) { + return declType->AsDerived() ? declType : nullptr; + } + } + } + } + return nullptr; +} + +// Locate a particular scope's generic interface for a specific kind of +// defined I/O. +static const Symbol *FindGenericDefinedIo( + const Scope &scope, common::DefinedIo which) { + if (const Symbol * symbol{scope.FindSymbol(GenericKind::AsFortran(which))}) { + const Symbol &generic{symbol->GetUltimate()}; + const auto &genericDetails{generic.get()}; + CHECK(std::holds_alternative(genericDetails.kind().u)); + CHECK(std::get(genericDetails.kind().u) == which); + return &generic; + } else { + return nullptr; + } +} + std::multimap -CollectNonTbpDefinedIoGenericInterfaces(const Scope &scope) { +CollectNonTbpDefinedIoGenericInterfaces( + const Scope &scope, bool useRuntimeTypeInfoEntries) { std::multimap result; if (!scope.IsTopLevel() && (scope.GetImportKind() == Scope::ImportKind::All || scope.GetImportKind() == Scope::ImportKind::Default)) { - result = CollectNonTbpDefinedIoGenericInterfaces(scope.parent()); + result = CollectNonTbpDefinedIoGenericInterfaces( + scope.parent(), useRuntimeTypeInfoEntries); } if (scope.kind() != Scope::Kind::DerivedType) { for (common::DefinedIo which : {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted, common::DefinedIo::WriteFormatted, common::DefinedIo::WriteUnformatted}) { - if (auto iter{scope.find(GenericKind::AsFortran(which))}; - iter != scope.end()) { - const Symbol &generic{iter->second->GetUltimate()}; - const auto *genericDetails{generic.detailsIf()}; - CHECK(genericDetails != nullptr); - CHECK(std::holds_alternative( - genericDetails->kind().u)); - CHECK(std::get(genericDetails->kind().u) == which); - for (auto specific : genericDetails->specificProcs()) { - const Symbol *interface { - &specific->GetUltimate() - }; - if (const auto *procEntity{ - specific->detailsIf()}) { - interface = procEntity->procInterface(); - } - const SubprogramDetails *subprogram{ - interface ? interface->detailsIf() : nullptr}; - const Symbol *dtvArg{subprogram && subprogram->dummyArgs().size() > 0 - ? subprogram->dummyArgs().at(0) - : nullptr}; - const DeclTypeSpec *declType{dtvArg ? dtvArg->GetType() : nullptr}; - const DerivedTypeSpec *derived{ - declType ? declType->AsDerived() : nullptr}; - if (const Symbol * - dtDesc{derived && derived->scope() - ? derived->scope()->runtimeDerivedTypeDescription() - : nullptr}) { - if (&derived->scope()->parent() == &generic.owner()) { - // This non-TBP defined I/O generic was defined in the - // same scope as the derived type, and it will be - // included in the derived type's special bindings - // by IncorporateDefinedIoGenericInterfaces(). - } else { - // Local scope's specific overrides host's for this type - bool updated{false}; - for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end; - ++iter) { - NonTbpDefinedIo &nonTbp{iter->second}; - if (nonTbp.definedIo == which) { - nonTbp.subroutine = &*specific; - nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic(); - updated = true; + auto name{GenericKind::AsFortran(which)}; + if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) { + for (auto specific : generic->get().specificProcs()) { + if (const DeclTypeSpec * + declType{GetDefinedIoSpecificArgType(*specific)}) { + const DerivedTypeSpec &derived{DEREF(declType->AsDerived())}; + if (const Symbol * + dtDesc{derived.scope() + ? derived.scope()->runtimeDerivedTypeDescription() + : nullptr}) { + if (useRuntimeTypeInfoEntries && + &derived.scope()->parent() == &generic->owner()) { + // This non-TBP defined I/O generic was defined in the + // same scope as the derived type, and it will be + // included in the derived type's special bindings + // by IncorporateDefinedIoGenericInterfaces(). + } else { + // Local scope's specific overrides host's for this type + bool updated{false}; + for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end; + ++iter) { + NonTbpDefinedIo &nonTbp{iter->second}; + if (nonTbp.definedIo == which) { + nonTbp.subroutine = &*specific; + nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic(); + updated = true; + } + } + if (!updated) { + result.emplace(dtDesc, + NonTbpDefinedIo{ + &*specific, which, declType->IsPolymorphic()}); } - } - if (!updated) { - result.emplace(dtDesc, - NonTbpDefinedIo{ - &*specific, which, declType->IsPolymorphic()}); } } } @@ -1280,4 +1304,96 @@ return result; } +// ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces() +// +// Returns a true result when a kind of defined I/O generic procedure +// has a type (from a symbol or a NAMELIST) such that +// (1) there is a specific procedure matching that type for a non-type-bound +// generic defined in the scope of the type, and +// (2) that specific procedure is unavailable or overridden in a particular +// local scope. +// Specific procedures of non-type-bound defined I/O generic interfaces +// declared in the scope of a derived type are identified as special bindings +// in the derived type's runtime type information, as if they had been +// type-bound. This predicate is meant to determine local situations in +// which those special bindings are not to be used. Its result is intended +// to be put into the "ignoreNonTbpEntries" flag of +// runtime::NonTbpDefinedIoTable and passed (negated) as the +// "useRuntimeTypeInfoEntries" argument of +// CollectNonTbpDefinedIoGenericInterfaces() above. + +static const Symbol *FindSpecificDefinedIo(const Scope &scope, + const evaluate::DynamicType &derived, common::DefinedIo which) { + if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) { + for (auto ref : generic->get().specificProcs()) { + const Symbol &specific{*ref}; + if (const DeclTypeSpec * + thisType{GetDefinedIoSpecificArgType(specific)}) { + if (evaluate::DynamicType{DEREF(thisType->AsDerived()), true} + .IsTkCompatibleWith(derived)) { + return &specific.GetUltimate(); + } + } + } + } + return nullptr; +} + +bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + const Scope &scope, const DerivedTypeSpec *derived) { + if (!derived) { + return false; + } + const Symbol &typeSymbol{derived->typeSymbol()}; + const Scope &typeScope{typeSymbol.GetUltimate().owner()}; + evaluate::DynamicType dyType{*derived}; + for (common::DefinedIo which : + {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted, + common::DefinedIo::WriteFormatted, + common::DefinedIo::WriteUnformatted}) { + if (const Symbol * + specific{FindSpecificDefinedIo(typeScope, dyType, which)}) { + // There's a non-TBP defined I/O procedure in the scope of the type's + // definition that applies to this type. It will appear in the type's + // runtime information. Determine whether it still applies in the + // scope of interest. + if (FindSpecificDefinedIo(scope, dyType, which) != specific) { + return true; + } + } + } + return false; +} + +bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + const Scope &scope, const DeclTypeSpec *type) { + return type && + ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + scope, type->AsDerived()); +} + +bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + const Scope &scope, const Symbol *symbol) { + if (!symbol) { + return false; + } + return common::visit( + common::visitors{ + [&](const NamelistDetails &x) { + for (auto ref : x.objects()) { + if (ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + scope, &*ref)) { + return true; + } + } + return false; + }, + [&](const auto &) { + return ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces( + scope, symbol->GetType()); + }, + }, + symbol->GetUltimate().details()); +} + } // namespace Fortran::semantics Index: flang/runtime/namelist.cpp =================================================================== --- flang/runtime/namelist.cpp +++ flang/runtime/namelist.cpp @@ -6,11 +6,6 @@ // //===----------------------------------------------------------------------===// -// TODO: When lowering has been updated to used the new pointer data member in -// the NamelistGroup structure, delete this definition and the two #ifndef -// directives below that test it. -#define DISABLE_NON_TBP_DIO 1 - #include "namelist.h" #include "descriptor-io.h" #include "emit-encoded.h" @@ -73,10 +68,7 @@ } if (const auto *addendum{item.descriptor.Addendum()}; addendum && addendum->derivedType()) { - NonTbpDefinedIoTable *table{nullptr}; -#ifndef DISABLE_NON_TBP_DIO - table = group.nonTbpDefinedIo; -#endif + const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo}; if (!IONAME(OutputDerivedType)(cookie, item.descriptor, table)) { return false; } @@ -533,10 +525,7 @@ listInput->ResetForNextNamelistItem(useDescriptor->rank() > 0); if (const auto *addendum{useDescriptor->Addendum()}; addendum && addendum->derivedType()) { - NonTbpDefinedIoTable *table{nullptr}; -#ifndef DISABLE_NON_TBP_DIO - table = group.nonTbpDefinedIo; -#endif + const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo}; if (!IONAME(InputDerivedType)(cookie, *useDescriptor, table)) { return false; } Index: flang/runtime/non-tbp-dio.h =================================================================== --- flang/runtime/non-tbp-dio.h +++ flang/runtime/non-tbp-dio.h @@ -46,7 +46,7 @@ // True when the only procedures to be used are the type-bound special // procedures in the type information tables and any non-null procedures // in this table. When false, the entries in this table override whatever - // non-type-bound specific procedures might be in the type inforamtion, + // non-type-bound specific procedures might be in the type information, // but the remaining specifics remain visible. bool ignoreNonTbpEntries{false}; }; Index: flang/test/Lower/derived-type-finalization.f90 =================================================================== --- flang/test/Lower/derived-type-finalization.f90 +++ flang/test/Lower/derived-type-finalization.f90 @@ -182,7 +182,7 @@ ! CHECK: %{{.*}} = fir.call @_FortranAioBeginExternalListOutput ! CHECK: %[[RES:.*]] = fir.call @_QMderived_type_finalizationPget_t1(%{{.*}}) {{.*}} : (!fir.ref) -> !fir.box>> ! CHECK: fir.save_result %[[RES]] to %[[TMP]] : !fir.box>>, !fir.ref>>> -! CHECK: %{{.*}} = fir.call @_FortranAioOutputDescriptor +! CHECK: %{{.*}} = fir.call @_FortranAioOutputDerivedType ! CHECK-NOT: %{{.*}} = fir.call @_FortranADestroy ! CHECK: %{{.*}} = fir.call @_FortranAioEndIoStatement ! CHECK: return Index: flang/test/Lower/io-derived-type.f90 =================================================================== --- /dev/null +++ flang/test/Lower/io-derived-type.f90 @@ -0,0 +1,136 @@ +! RUN: bbc -polymorphic-type -emit-fir -o - %s | FileCheck %s + +module m + type t + integer n + end type + interface write(formatted) + module procedure wft + end interface + contains + ! CHECK-LABEL: @_QMmPwft + subroutine wft(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + iostat = 0 + write(unit,*,iostat=iostat,iomsg=iomsg) 'wft was called: ', dtv%n + end subroutine + + ! CHECK-LABEL: @_QMmPwftd + subroutine wftd(dtv, unit, iotype, v_list, iostat, iomsg) + type(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + iostat = 0 + write(unit,*,iostat=iostat,iomsg=iomsg) 'wftd: ', dtv%n + end subroutine + + ! CHECK-LABEL: @_QMmPtest1 + subroutine test1 + import, all + ! CHECK: %[[V_14:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}> + ! CHECK: %[[V_15:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_14]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c1{{.*}} to %[[V_15]] : !fir.ref + ! CHECK: %[[V_16:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref>) -> !fir.box> + ! CHECK: %[[V_17:[0-9]+]] = fir.convert %[[V_16]] : (!fir.box>) -> !fir.box + ! CHECK: %[[V_18:[0-9]+]] = fir.address_of(@_QQMmFtest1.nonTbpDefinedIoTable) : !fir.ref, !fir.ref, i32, i1>>>, i1>> + ! CHECK: %[[V_19:[0-9]+]] = fir.convert %[[V_18]] : (!fir.ref, !fir.ref, i32, i1>>>, i1>>) -> !fir.ref + ! CHECK: %[[V_20:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_17]], %[[V_19]]) fastmath : (!fir.ref, !fir.box, !fir.ref) -> i1 + print *, 'test1 outer, should call wft: ', t(1) + block + import, only: t + ! CHECK: %[[V_35:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}> + ! CHECK: %[[V_36:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_35]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c2{{.*}} to %[[V_36]] : !fir.ref + ! CHECK: %[[V_37:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref>) -> !fir.box> + ! CHECK: %[[V_38:[0-9]+]] = fir.convert %[[V_37]] : (!fir.box>) -> !fir.box + ! CHECK: %[[V_39:[0-9]+]] = fir.address_of(@default.nonTbpDefinedIoTable) : !fir.ref, !fir.ref, i32, i1>>>, i1>> + ! CHECK: %[[V_40:[0-9]+]] = fir.convert %[[V_39]] : (!fir.ref, !fir.ref, i32, i1>>>, i1>>) -> !fir.ref + ! CHECK: %[[V_41:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_38]], %[[V_40]]) fastmath : (!fir.ref, !fir.box, !fir.ref) -> i1 + print *, 'test1 block, should not call wft: ', t(2) + end block + end subroutine + + ! CHECK-LABEL: @_QMmPtest2 + subroutine test2 + ! CHECK: %[[V_13:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}> + ! CHECK: %[[V_14:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_13]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c3{{.*}} to %[[V_14]] : !fir.ref + ! CHECK: %[[V_15:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref>) -> !fir.box> + ! CHECK: %[[V_16:[0-9]+]] = fir.convert %[[V_15]] : (!fir.box>) -> !fir.box + ! CHECK: %[[V_17:[0-9]+]] = fir.address_of(@default.nonTbpDefinedIoTable) : !fir.ref, !fir.ref, i32, i1>>>, i1>> + ! CHECK: %[[V_18:[0-9]+]] = fir.convert %[[V_17]] : (!fir.ref, !fir.ref, i32, i1>>>, i1>>) -> !fir.ref + ! CHECK: %[[V_19:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_16]], %[[V_18]]) fastmath : (!fir.ref, !fir.box, !fir.ref) -> i1 + + import, only: t + print *, 'test2, should not call wft: ', t(3) + end subroutine + + ! CHECK-LABEL: @_QMmPtest3 + subroutine test3(p, x) + procedure(wftd) p + type(t), intent(in) :: x + interface write(formatted) + procedure p + end interface + + ! CHECK: %[[V_3:[0-9]+]] = fir.embox %arg1 : (!fir.ref>) -> !fir.box> + ! CHECK: %[[V_4:[0-9]+]] = fir.convert %[[V_3]] : (!fir.box>) -> !fir.box + ! CHECK: %[[V_5:[0-9]+]] = fir.alloca !fir.array<1xtuple, !fir.ref, i32, i1>> + ! CHECK: %[[V_6:[0-9]+]] = fir.undefined !fir.array<1xtuple, !fir.ref, i32, i1>> + ! CHECK: %[[V_7:[0-9]+]] = fir.address_of(@_QMmE.dt.t) + ! CHECK: %[[V_8:[0-9]+]] = fir.convert %[[V_7]] : {{.*}} -> !fir.ref + ! CHECK: %[[V_9:[0-9]+]] = fir.insert_value %[[V_6]], %[[V_8]], [0 : index, 0 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, !fir.ref) -> !fir.array<1xtuple, !fir.ref, i32, i1>> + ! CHECK: %[[V_10:[0-9]+]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> !fir.ref + ! CHECK: %[[V_11:[0-9]+]] = fir.insert_value %[[V_9]], %[[V_10]], [0 : index, 1 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, !fir.ref) -> !fir.array<1xtuple, !fir.ref, i32, i1>> + ! CHECK: %[[V_12:[0-9]+]] = fir.insert_value %[[V_11]], %c2{{.*}}, [0 : index, 2 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, i32) -> !fir.array<1xtuple, !fir.ref, i32, i1>> + ! CHECK: %[[V_13:[0-9]+]] = fir.insert_value %[[V_12]], %false, [0 : index, 3 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, i1) -> !fir.array<1xtuple, !fir.ref, i32, i1>> + ! CHECK: fir.store %[[V_13]] to %[[V_5]] : !fir.ref, !fir.ref, i32, i1>>> + ! CHECK: %[[V_14:[0-9]+]] = fir.alloca tuple, !fir.ref, i32, i1>>>, i1> + ! CHECK: %[[V_15:[0-9]+]] = fir.undefined tuple, !fir.ref, i32, i1>>>, i1> + ! CHECK: %[[V_16:[0-9]+]] = fir.insert_value %[[V_15]], %c1{{.*}}, [0 : index] : (tuple, !fir.ref, i32, i1>>>, i1>, i64) -> tuple, !fir.ref, i32, i1>>>, i1> + ! CHECK: %[[V_17:[0-9]+]] = fir.insert_value %[[V_16]], %[[V_5]], [1 : index] : (tuple, !fir.ref, i32, i1>>>, i1>, !fir.ref, !fir.ref, i32, i1>>>) -> tuple, !fir.ref, i32, i1>>>, i1> + ! CHECK: %[[V_18:[0-9]+]] = fir.insert_value %[[V_17]], %true, [2 : index] : (tuple, !fir.ref, i32, i1>>>, i1>, i1) -> tuple, !fir.ref, i32, i1>>>, i1> + ! CHECK: fir.store %[[V_18]] to %[[V_14]] : !fir.ref, !fir.ref, i32, i1>>>, i1>> + ! CHECK: %[[V_19:[0-9]+]] = fir.convert %[[V_14]] : (!fir.ref, !fir.ref, i32, i1>>>, i1>>) -> !fir.ref + ! CHECK: %[[V_20:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_4]], %[[V_19]]) fastmath : (!fir.ref, !fir.box, !fir.ref) -> i1 + print *, x + end subroutine +end module + +! CHECK-LABEL: @_QQmain +program p + use m + character*3 ccc(4) + namelist /nnn/ jjj, ccc + + ! CHECK: fir.call @_QMmPtest1 + call test1 + ! CHECK: fir.call @_QMmPtest2 + call test2 + ! CHECK: fir.call @_QMmPtest3 + call test3(wftd, t(17)) + + ! CHECK: %[[V_95:[0-9]+]] = fir.field_index n, !fir.type<_QMmTt{n:i32}> + ! CHECK: %[[V_96:[0-9]+]] = fir.coordinate_of %{{.*}}, %[[V_95]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: fir.store %c4{{.*}} to %[[V_96]] : !fir.ref + ! CHECK: %[[V_97:[0-9]+]] = fir.embox %{{.*}} : (!fir.ref>) -> !fir.box> + ! CHECK: %[[V_98:[0-9]+]] = fir.convert %[[V_97]] : (!fir.box>) -> !fir.box + ! CHECK: %[[V_99:[0-9]+]] = fir.address_of(@_QQF.nonTbpDefinedIoTable) : !fir.ref, !fir.ref, i32, i1>>>, i1>> + ! CHECK: %[[V_100:[0-9]+]] = fir.convert %[[V_99]] : (!fir.ref, !fir.ref, i32, i1>>>, i1>>) -> !fir.ref + ! CHECK: %[[V_101:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_98]], %[[V_100]]) fastmath : (!fir.ref, !fir.box, !fir.ref) -> i1 + print *, 'main, should call wft: ', t(4) +end + +! CHECK: fir.global linkonce @_QQMmFtest1.nonTbpDefinedIoTable.list constant : !fir.array<1xtuple, !fir.ref, i32, i1>> +! CHECK: fir.global linkonce @_QQMmFtest1.nonTbpDefinedIoTable constant : tuple, !fir.ref, i32, i1>>>, i1> +! CHECK: fir.global linkonce @default.nonTbpDefinedIoTable constant : tuple, !fir.ref, i32, i1>>>, i1> +! CHECK: fir.global linkonce @_QQF.nonTbpDefinedIoTable.list constant : !fir.array<1xtuple, !fir.ref, i32, i1>> +! CHECK: fir.global linkonce @_QQF.nonTbpDefinedIoTable constant : tuple, !fir.ref, i32, i1>>>, i1> Index: flang/test/Lower/namelist.f90 =================================================================== --- flang/test/Lower/namelist.f90 +++ flang/test/Lower/namelist.f90 @@ -19,9 +19,9 @@ ! CHECK: fir.insert_value ! CHECK: fir.embox [[ccc]] ! CHECK: fir.insert_value - ! CHECK: fir.alloca tuple, i64, !fir.ref, !fir.ref>>>>> + ! CHECK: fir.alloca tuple, i64, !fir.ref, !fir.ref>>>>, !fir.ref> ! CHECK: fir.address_of - ! CHECK-COUNT-3: fir.insert_value + ! CHECK-COUNT-4: fir.insert_value ! CHECK: fir.call @_FortranAioOutputNamelist([[cookie]] ! CHECK: fir.call @_FortranAioEndIoStatement([[cookie]] write(*, nnn) @@ -39,9 +39,9 @@ ! CHECK: fir.insert_value ! CHECK: fir.embox [[ccc]] ! CHECK: fir.insert_value - ! CHECK: fir.alloca tuple, i64, !fir.ref, !fir.ref>>>>> + ! CHECK: fir.alloca tuple, i64, !fir.ref, !fir.ref>>>>, !fir.ref> ! CHECK: fir.address_of - ! CHECK-COUNT-3: fir.insert_value + ! CHECK-COUNT-4: fir.insert_value ! CHECK: fir.call @_FortranAioOutputNamelist([[cookie]] ! CHECK: fir.call @_FortranAioEndIoStatement([[cookie]] write(*, nnn) Index: flang/test/Lower/parent-component.f90 =================================================================== --- flang/test/Lower/parent-component.f90 +++ flang/test/Lower/parent-component.f90 @@ -146,7 +146,7 @@ ! CHECK: %[[BOX:.*]] = fir.embox %{{.*}} : (!fir.ref>) -> !fir.box> ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[BOX]] : (!fir.box>) -> !fir.box - ! CHECK: %{{.*}} = fir.call @_FortranAioOutputDescriptor(%{{.*}}, %[[BOX_NONE]]) {{.*}}: (!fir.ref, !fir.box) -> i1 + ! CHECK: %{{.*}} = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[BOX_NONE]], %{{.*}}) {{.*}}: (!fir.ref, !fir.box, !fir.ref) -> i1 subroutine init_assumed(y) type(c) :: y(:) Index: flang/test/Lower/vector-subscript-io.f90 =================================================================== --- flang/test/Lower/vector-subscript-io.f90 +++ flang/test/Lower/vector-subscript-io.f90 @@ -413,7 +413,7 @@ ! CHECK: %[[VAL_286:.*]] = fir.array_coor %[[VAL_287]](%[[VAL_277]]) {{\[}}%[[VAL_278]]] %[[VAL_285]] : (!fir.ref}>>>, !fir.shapeshift<1>, !fir.slice<1>, index) -> !fir.ref}>> ! CHECK: %[[VAL_288:.*]] = fir.embox %[[VAL_286]] : (!fir.ref}>>) -> !fir.box}>> ! CHECK: %[[VAL_289:.*]] = fir.convert %[[VAL_288]] : (!fir.box}>>) -> !fir.box -! CHECK: %[[VAL_290:.*]] = fir.call @_FortranAioInputDescriptor(%[[VAL_276]], %[[VAL_289]]) {{.*}}: (!fir.ref, !fir.box) -> i1 +! CHECK: %[[VAL_290:.*]] = fir.call @_FortranAioInputDerivedType(%[[VAL_276]], %[[VAL_289]], {{.*}}) {{.*}}: (!fir.ref, !fir.box, !fir.ref) -> i1 ! CHECK: %[[VAL_291:.*]] = arith.addi %[[VAL_279]], %[[VAL_273]] : index ! CHECK: %[[VAL_292:.*]] = arith.subi %[[VAL_280]], %[[VAL_273]] : index ! CHECK: cf.br ^bb1(%[[VAL_291]], %[[VAL_292]] : index, index)