From 79caf69cc08a72022f968020eab486b698fd4178 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Thu, 17 Jun 2021 13:13:19 -0700 Subject: [PATCH] [flang] Runtime implementation for default derived type formatted I/O This is *not* user-defined derived type I/O, but rather Fortran's built-in capabilities for using derived type data in I/O lists and NAMELIST groups. This feature depends on having the derived type description tables that are created by Semantics available, passed through compilation as initialized static objects to which pointers can be targeted in the descriptors of I/O list items and NAMELIST groups. NAMELIST processing now handles component references on input (e.g., "&GROUP x%component = 123 /"). The C++ perspectives of the derived type information records were transformed into proper classes when it was necessary to add member functions to them. The code in Semantics that generates derived type information was changed to emit derived type components in component order, not alphabetic order. Differential Revision: https://reviews.llvm.org/D104485 --- flang/include/flang/Semantics/runtime-type-info.h | 1 - flang/lib/Semantics/runtime-type-info.cpp | 19 ++- flang/runtime/CMakeLists.txt | 1 + flang/runtime/copy.cpp | 10 +- flang/runtime/derived.cpp | 48 ++---- flang/runtime/descriptor-io.h | 74 ++++++++- flang/runtime/descriptor.cpp | 16 +- flang/runtime/descriptor.h | 5 +- flang/runtime/namelist.cpp | 76 +++++++-- flang/runtime/tools.h | 1 + flang/runtime/type-info.cpp | 183 ++++++++++++++++++++++ flang/runtime/type-info.h | 129 +++++++++++---- flang/test/Semantics/typeinfo01.f90 | 4 +- 13 files changed, 460 insertions(+), 107 deletions(-) create mode 100644 flang/runtime/type-info.cpp diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h index 71b5cac..7521a93 100644 --- a/flang/include/flang/Semantics/runtime-type-info.h +++ b/flang/include/flang/Semantics/runtime-type-info.h @@ -33,6 +33,5 @@ struct RuntimeDerivedTypeTables { RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(SemanticsContext &); -void Dump(llvm::raw_ostream &, const RuntimeDerivedTypeTables &); } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_ diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp index a5a0199..f336117 100644 --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -427,7 +427,7 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds))); // Traverse the components of the derived type if (!isPDTdefinition) { - std::vector dataComponents; + std::vector dataComponentSymbols; std::vector procPtrComponents; std::vector specials; for (const auto &pair : dtScope) { @@ -438,9 +438,8 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { [&](const TypeParamDetails &) { // already handled above in declaration order }, - [&](const ObjectEntityDetails &object) { - dataComponents.emplace_back(DescribeComponent( - symbol, object, scope, dtScope, distinctName, parameters)); + [&](const ObjectEntityDetails &) { + dataComponentSymbols.push_back(&symbol); }, [&](const ProcEntityDetails &proc) { if (IsProcedurePointer(symbol)) { @@ -461,6 +460,18 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { }, symbol.details()); } + // Sort the data component symbols by offset before emitting them + std::sort(dataComponentSymbols.begin(), dataComponentSymbols.end(), + [](const Symbol *x, const Symbol *y) { + return x->offset() < y->offset(); + }); + std::vector dataComponents; + for (const Symbol *symbol : dataComponentSymbols) { + auto locationRestorer{common::ScopedSet(location_, symbol->name())}; + dataComponents.emplace_back( + DescribeComponent(*symbol, symbol->get(), scope, + dtScope, distinctName, parameters)); + } AddValue(dtValues, derivedTypeSchema_, "component"s, SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName), std::move(dataComponents), diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt index e5e6657..5f4bbc7 100644 --- a/flang/runtime/CMakeLists.txt +++ b/flang/runtime/CMakeLists.txt @@ -70,6 +70,7 @@ add_flang_library(FortranRuntime tools.cpp transformational.cpp type-code.cpp + type-info.cpp unit.cpp unit-map.cpp diff --git a/flang/runtime/copy.cpp b/flang/runtime/copy.cpp index 458b8f0..1315472 100644 --- a/flang/runtime/copy.cpp +++ b/flang/runtime/copy.cpp @@ -26,20 +26,20 @@ void CopyElement(const Descriptor &to, const SubscriptValue toAt[], if (const auto *derived{addendum->derivedType()}) { RUNTIME_CHECK(terminator, from.Addendum() && derived == from.Addendum()->derivedType()); - const Descriptor &componentDesc{derived->component.descriptor()}; + const Descriptor &componentDesc{derived->component()}; const typeInfo::Component *component{ componentDesc.OffsetElement()}; std::size_t nComponents{componentDesc.Elements()}; for (std::size_t j{0}; j < nComponents; ++j, ++component) { - if (component->genre == typeInfo::Component::Genre::Allocatable || - component->genre == typeInfo::Component::Genre::Automatic) { + if (component->genre() == typeInfo::Component::Genre::Allocatable || + component->genre() == typeInfo::Component::Genre::Automatic) { Descriptor &toDesc{ - *reinterpret_cast(toPtr + component->offset)}; + *reinterpret_cast(toPtr + component->offset())}; if (toDesc.raw().base_addr != nullptr) { toDesc.set_base_addr(nullptr); RUNTIME_CHECK(terminator, toDesc.Allocate() == CFI_SUCCESS); const Descriptor &fromDesc{*reinterpret_cast( - fromPtr + component->offset)}; + fromPtr + component->offset())}; CopyArray(toDesc, fromDesc, terminator); } } diff --git a/flang/runtime/derived.cpp b/flang/runtime/derived.cpp index db743ba..ef4bddc 100644 --- a/flang/runtime/derived.cpp +++ b/flang/runtime/derived.cpp @@ -15,7 +15,7 @@ namespace Fortran::runtime { static const typeInfo::SpecialBinding *FindFinal( const typeInfo::DerivedType &derived, int rank) { const typeInfo::SpecialBinding *elemental{nullptr}; - const Descriptor &specialDesc{derived.special.descriptor()}; + const Descriptor &specialDesc{derived.special()}; std::size_t totalSpecialBindings{specialDesc.Elements()}; for (std::size_t j{0}; j < totalSpecialBindings; ++j) { const auto &special{ @@ -59,15 +59,6 @@ static void CallFinalSubroutine( } } -static inline SubscriptValue GetValue( - const typeInfo::Value &value, const Descriptor &descriptor) { - if (value.genre == typeInfo::Value::Genre::LenParameter) { - return descriptor.Addendum()->LenParameterValue(value.value); - } else { - return value.value; - } -} - // The order of finalization follows Fortran 2018 7.5.6.2, with // deallocation of non-parent components (and their consequent finalization) // taking place before parent component finalization. @@ -76,46 +67,39 @@ void Destroy(const Descriptor &descriptor, bool finalize, if (finalize) { CallFinalSubroutine(descriptor, derived); } - const Descriptor &componentDesc{derived.component.descriptor()}; - std::int64_t myComponents{componentDesc.GetDimension(0).Extent()}; + const Descriptor &componentDesc{derived.component()}; + auto myComponents{static_cast(componentDesc.Elements())}; std::size_t elements{descriptor.Elements()}; std::size_t byteStride{descriptor.ElementBytes()}; for (unsigned k{0}; k < myComponents; ++k) { const auto &comp{ *componentDesc.ZeroBasedIndexedElement(k)}; - if (comp.genre == typeInfo::Component::Genre::Allocatable || - comp.genre == typeInfo::Component::Genre::Automatic) { + if (comp.genre() == typeInfo::Component::Genre::Allocatable || + comp.genre() == typeInfo::Component::Genre::Automatic) { for (std::size_t j{0}; j < elements; ++j) { - descriptor.OffsetElement(j * byteStride + comp.offset) + descriptor.OffsetElement(j * byteStride + comp.offset()) ->Deallocate(finalize); } - } else if (comp.genre == typeInfo::Component::Genre::Data && - comp.derivedType.descriptor().raw().base_addr) { + } else if (comp.genre() == typeInfo::Component::Genre::Data && + comp.derivedType()) { SubscriptValue extent[maxRank]; - const Descriptor &boundsDesc{comp.bounds.descriptor()}; - for (int dim{0}; dim < comp.rank; ++dim) { - extent[dim] = - GetValue( - *boundsDesc.ZeroBasedIndexedElement(2 * dim), - descriptor) - - GetValue(*boundsDesc.ZeroBasedIndexedElement( - 2 * dim + 1), - descriptor) + - 1; + const typeInfo::Value *bounds{comp.bounds()}; + for (int dim{0}; dim < comp.rank(); ++dim) { + extent[dim] = bounds[2 * dim].GetValue(&descriptor).value_or(0) - + bounds[2 * dim + 1].GetValue(&descriptor).value_or(0) + 1; } StaticDescriptor staticDescriptor; Descriptor &compDesc{staticDescriptor.descriptor()}; - const auto &compType{*comp.derivedType.descriptor() - .OffsetElement()}; + const typeInfo::DerivedType &compType{*comp.derivedType()}; for (std::size_t j{0}; j < elements; ++j) { compDesc.Establish(compType, - descriptor.OffsetElement(j * byteStride + comp.offset), - comp.rank, extent); + descriptor.OffsetElement(j * byteStride + comp.offset()), + comp.rank(), extent); Destroy(compDesc, finalize, compType); } } } - const Descriptor &parentDesc{derived.parent.descriptor()}; + const Descriptor &parentDesc{derived.parent()}; if (const auto *parent{parentDesc.OffsetElement()}) { Destroy(descriptor, finalize, *parent); } diff --git a/flang/runtime/descriptor-io.h b/flang/runtime/descriptor-io.h index e664f4c..09d0686 100644 --- a/flang/runtime/descriptor-io.h +++ b/flang/runtime/descriptor-io.h @@ -17,6 +17,7 @@ #include "edit-output.h" #include "io-stmt.h" #include "terminator.h" +#include "type-info.h" #include "flang/Common/uint128.h" namespace Fortran::runtime::io::descr { @@ -25,7 +26,8 @@ inline A &ExtractElement(IoStatementState &io, const Descriptor &descriptor, const SubscriptValue subscripts[]) { A *p{descriptor.Element(subscripts)}; if (!p) { - io.GetIoErrorHandler().Crash("ExtractElement: subscripts out of range"); + io.GetIoErrorHandler().Crash( + "ExtractElement: null base address or subscripts out of range"); } return *p; } @@ -217,6 +219,67 @@ inline bool FormattedLogicalIO( } template +static bool DescriptorIO(IoStatementState &, const Descriptor &); + +template +static bool DefaultFormattedComponentIO(IoStatementState &io, + const typeInfo::Component &component, const Descriptor &origDescriptor, + const SubscriptValue origSubscripts[], Terminator &terminator) { + if (component.genre() == typeInfo::Component::Genre::Data) { + // Create a descriptor for the component + StaticDescriptor statDesc; + Descriptor &desc{statDesc.descriptor()}; + component.EstablishDescriptor( + desc, origDescriptor, origSubscripts, terminator); + return DescriptorIO(io, desc); + } else { + // Component is itself a descriptor + char *pointer{ + origDescriptor.Element(origSubscripts) + component.offset()}; + RUNTIME_CHECK( + terminator, component.genre() == typeInfo::Component::Genre::Automatic); + const Descriptor &compDesc{*reinterpret_cast(pointer)}; + return DescriptorIO(io, compDesc); + } +} + +template +static bool FormattedDerivedTypeIO( + IoStatementState &io, const Descriptor &descriptor) { + Terminator &terminator{io.GetIoErrorHandler()}; + const DescriptorAddendum *addendum{descriptor.Addendum()}; + RUNTIME_CHECK(terminator, addendum != nullptr); + const typeInfo::DerivedType *type{addendum->derivedType()}; + RUNTIME_CHECK(terminator, type != nullptr); + if (false) { + // TODO: user-defined derived type formatted I/O + } else { + // Default derived type formatting + const Descriptor &compArray{type->component()}; + RUNTIME_CHECK(terminator, compArray.rank() == 1); + std::size_t numComponents{compArray.Elements()}; + std::size_t numElements{descriptor.Elements()}; + SubscriptValue subscripts[maxRank]; + descriptor.GetLowerBounds(subscripts); + for (std::size_t j{0}; j < numElements; + ++j, descriptor.IncrementSubscripts(subscripts)) { + SubscriptValue at[maxRank]; + compArray.GetLowerBounds(at); + for (std::size_t k{0}; k < numComponents; + ++k, compArray.IncrementSubscripts(at)) { + const typeInfo::Component &component{ + *compArray.Element(at)}; + if (!DefaultFormattedComponentIO( + io, component, descriptor, subscripts, terminator)) { + return false; + } + } + } + } + return true; +} + +template static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) { if (!io.get_if>()) { io.GetIoErrorHandler().Crash( @@ -233,7 +296,9 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) { SubscriptValue subscripts[maxRank]; descriptor.GetLowerBounds(subscripts); std::size_t numElements{descriptor.Elements()}; - if (descriptor.IsContiguous()) { // contiguous unformatted I/O + if (false) { + // TODO: user-defined derived type unformatted I/O + } else if (descriptor.IsContiguous()) { // contiguous unformatted I/O char &x{ExtractElement(io, descriptor, subscripts)}; auto totalBytes{numElements * elementBytes}; if constexpr (DIR == Direction::Output) { @@ -360,10 +425,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) { return false; } case TypeCategory::Derived: - io.GetIoErrorHandler().Crash( - "DescriptorIO: Unimplemented: derived type I/O", - static_cast(descriptor.type().raw())); - return false; + return FormattedDerivedTypeIO(io, descriptor); } } io.GetIoErrorHandler().Crash("DescriptorIO: Bad type code (%d) in descriptor", diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp index 6747b38..ba97b87 100644 --- a/flang/runtime/descriptor.cpp +++ b/flang/runtime/descriptor.cpp @@ -42,9 +42,12 @@ void Descriptor::Establish(TypeCode t, std::size_t elementBytes, void *p, // incoming element length is replaced by 4 so that it will be valid // for all CHARACTER kinds. std::size_t workaroundElemLen{elementBytes ? elementBytes : 4}; - RUNTIME_CHECK(terminator, - ISO::CFI_establish(&raw_, p, attribute, t.raw(), workaroundElemLen, rank, - extent) == CFI_SUCCESS); + int cfiStatus{ISO::CFI_establish( + &raw_, p, attribute, t.raw(), workaroundElemLen, rank, extent)}; + if (cfiStatus != CFI_SUCCESS) { + terminator.Crash( + "Descriptor::Establish: CFI_establish returned %d", cfiStatus, t.raw()); + } if (elementBytes == 0) { raw_.elem_len = 0; for (int j{0}; j < rank; ++j) { @@ -75,7 +78,8 @@ void Descriptor::Establish(int characterKind, std::size_t characters, void *p, void Descriptor::Establish(const typeInfo::DerivedType &dt, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) { - Establish(CFI_type_struct, dt.sizeInBytes, p, rank, extent, attribute, true); + Establish(TypeCode{TypeCategory::Derived, 0}, dt.sizeInBytes(), p, rank, + extent, attribute, true); DescriptorAddendum *a{Addendum()}; Terminator terminator{__FILE__, __LINE__}; RUNTIME_CHECK(terminator, a != nullptr); @@ -109,8 +113,8 @@ OwningPtr Descriptor::Create(int characterKind, OwningPtr Descriptor::Create(const typeInfo::DerivedType &dt, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) { - return Create(TypeCode{CFI_type_struct}, dt.sizeInBytes, p, rank, extent, - attribute, dt.LenParameters()); + return Create(TypeCode{TypeCategory::Derived, 0}, dt.sizeInBytes(), p, rank, + extent, attribute, dt.LenParameters()); } std::size_t Descriptor::SizeInBytes() const { diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h index d31023b..e5cf0d2 100644 --- a/flang/runtime/descriptor.h +++ b/flang/runtime/descriptor.h @@ -109,8 +109,9 @@ public: return len_[which]; } static constexpr std::size_t SizeInBytes(int lenParameters) { - return sizeof(DescriptorAddendum) - sizeof(typeInfo::TypeParameterValue) + - lenParameters * sizeof(typeInfo::TypeParameterValue); + // TODO: Don't waste that last word if lenParameters == 0 + return sizeof(DescriptorAddendum) + + std::max(lenParameters - 1, 0) * sizeof(typeInfo::TypeParameterValue); } std::size_t SizeInBytes() const; diff --git a/flang/runtime/namelist.cpp b/flang/runtime/namelist.cpp index f26ae84..0b334b4 100644 --- a/flang/runtime/namelist.cpp +++ b/flang/runtime/namelist.cpp @@ -15,6 +15,10 @@ namespace Fortran::runtime::io { +// Max size of a group, symbol or component identifier that can appear in +// NAMELIST input, plus a byte for NUL termination. +static constexpr std::size_t nameBufferSize{201}; + bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) { IoStatementState &io{*cookie}; io.CheckFormattedStmtType("OutputNamelist"); @@ -56,22 +60,29 @@ bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) { return EmitWithAdvance('/'); } +static constexpr bool IsLegalIdStart(char32_t ch) { + return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '_' || + ch == '@' || ch == '$'; +} + +static constexpr bool IsLegalIdChar(char32_t ch) { + return IsLegalIdStart(ch) || (ch >= '0' && ch <= '9'); +} + +static constexpr char NormalizeIdChar(char32_t ch) { + return static_cast(ch >= 'A' && ch <= 'Z' ? ch - 'A' + 'a' : ch); +} + static bool GetLowerCaseName( IoStatementState &io, char buffer[], std::size_t maxLength) { - if (auto ch{io.GetCurrentChar()}) { - static const auto IsLegalIdStart{[](char32_t ch) -> bool { - return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || - ch == '_' || ch == '@' || ch == '$'; - }}; + if (auto ch{io.GetNextNonBlank()}) { if (IsLegalIdStart(*ch)) { std::size_t j{0}; do { - buffer[j] = - static_cast(*ch >= 'A' && *ch <= 'Z' ? *ch - 'A' + 'a' : *ch); + buffer[j] = NormalizeIdChar(*ch); io.HandleRelativePosition(1); ch = io.GetCurrentChar(); - } while (++j < maxLength && ch && - (IsLegalIdStart(*ch) || (*ch >= '0' && *ch <= '9'))); + } while (++j < maxLength && ch && IsLegalIdChar(*ch)); buffer[j++] = '\0'; if (j <= maxLength) { return true; @@ -118,8 +129,8 @@ static bool HandleSubscripts(IoStatementState &io, Descriptor &desc, const Descriptor &source, const char *name) { IoErrorHandler &handler{io.GetIoErrorHandler()}; io.HandleRelativePosition(1); // skip '(' - // Allow for blanks in subscripts; it's nonstandard, but not ambiguous - // within the parentheses + // Allow for blanks in subscripts; they're nonstandard, but not + // ambiguous within the parentheses. SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank]; int j{0}; std::size_t elemLen{source.ElementBytes()}; @@ -211,6 +222,38 @@ static bool HandleSubscripts(IoStatementState &io, Descriptor &desc, return false; } +static bool HandleComponent(IoStatementState &io, Descriptor &desc, + const Descriptor &source, const char *name) { + IoErrorHandler &handler{io.GetIoErrorHandler()}; + io.HandleRelativePosition(1); // skip '%' + char compName[nameBufferSize]; + if (GetLowerCaseName(io, compName, sizeof compName)) { + const DescriptorAddendum *addendum{source.Addendum()}; + if (const typeInfo::DerivedType * + type{addendum ? addendum->derivedType() : nullptr}) { + if (const typeInfo::Component * + comp{type->FindDataComponent(compName, std::strlen(compName))}) { + comp->EstablishDescriptor(desc, source, nullptr, handler); + return true; + } else { + handler.SignalError( + "NAMELIST component reference '%%%s' of input group item %s is not " + "a component of its derived type", + compName, name); + } + } else { + handler.SignalError("NAMELIST component reference '%%%s' of input group " + "item %s for non-derived type", + compName, name); + } + } else { + handler.SignalError("NAMELIST component reference of input group item %s " + "has no name after '%'", + name); + } + return false; +} + bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) { IoStatementState &io{*cookie}; io.CheckFormattedStmtType("InputNamelist"); @@ -225,7 +268,7 @@ bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) { return false; } io.HandleRelativePosition(1); - char name[101]; + char name[nameBufferSize]; if (!GetLowerCaseName(io, name, sizeof name)) { handler.SignalError("NAMELIST input group has no name"); return false; @@ -268,15 +311,14 @@ bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) { next = io.GetCurrentChar(); if (next && (*next == '(' || *next == '%')) { do { + Descriptor &mutableDescriptor{staticDesc[whichStaticDesc].descriptor()}; + whichStaticDesc ^= 1; if (*next == '(') { - Descriptor &mutableDescriptor{ - staticDesc[whichStaticDesc].descriptor()}; - whichStaticDesc ^= 1; HandleSubscripts(io, mutableDescriptor, *useDescriptor, name); - useDescriptor = &mutableDescriptor; } else { - handler.Crash("unimplemented: component references in NAMELIST"); + HandleComponent(io, mutableDescriptor, *useDescriptor, name); } + useDescriptor = &mutableDescriptor; next = io.GetCurrentChar(); } while (next && (*next == '(' || *next == '%')); } diff --git a/flang/runtime/tools.h b/flang/runtime/tools.h index d4a0708..2daa53a 100644 --- a/flang/runtime/tools.h +++ b/flang/runtime/tools.h @@ -333,5 +333,6 @@ std::optional> inline constexpr GetResultType( } return std::nullopt; } + } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_TOOLS_H_ diff --git a/flang/runtime/type-info.cpp b/flang/runtime/type-info.cpp new file mode 100644 index 0000000..ef3c472 --- /dev/null +++ b/flang/runtime/type-info.cpp @@ -0,0 +1,183 @@ +//===-- runtime/type-info.cpp ---------------------------------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#include "type-info.h" +#include "terminator.h" +#include + +namespace Fortran::runtime::typeInfo { + +std::optional Value::GetValue( + const Descriptor *descriptor) const { + switch (genre_) { + case Genre::Explicit: + return value_; + case Genre::LenParameter: + if (descriptor) { + if (const auto *addendum{descriptor->Addendum()}) { + return addendum->LenParameterValue(value_); + } + } + return std::nullopt; + default: + return std::nullopt; + } +} + +void Component::EstablishDescriptor(Descriptor &descriptor, + const Descriptor &container, const SubscriptValue subscripts[], + Terminator &terminator) const { + RUNTIME_CHECK(terminator, genre_ == Genre::Data); + TypeCategory cat{category()}; + if (cat == TypeCategory::Character) { + auto length{characterLen_.GetValue(&container)}; + RUNTIME_CHECK(terminator, length.has_value()); + descriptor.Establish(kind_, *length / kind_, nullptr, rank_); + } else if (cat == TypeCategory::Derived) { + const DerivedType *type{derivedType()}; + RUNTIME_CHECK(terminator, type != nullptr); + descriptor.Establish(*type, nullptr, rank_); + } else { + descriptor.Establish(cat, kind_, nullptr, rank_); + } + if (rank_) { + const typeInfo::Value *boundValues{bounds()}; + RUNTIME_CHECK(terminator, boundValues != nullptr); + auto byteStride{static_cast(descriptor.ElementBytes())}; + for (int j{0}; j < rank_; ++j) { + auto lb{boundValues++->GetValue(&container)}; + auto ub{boundValues++->GetValue(&container)}; + RUNTIME_CHECK(terminator, lb.has_value() && ub.has_value()); + Dimension &dim{descriptor.GetDimension(j)}; + dim.SetBounds(*lb, *ub); + dim.SetByteStride(byteStride); + byteStride *= dim.Extent(); + } + } + descriptor.set_base_addr(container.Element(subscripts) + offset_); +} + +const Component *DerivedType::FindDataComponent( + const char *compName, std::size_t compNameLen) const { + const Descriptor &compDesc{component()}; + std::size_t n{compDesc.Elements()}; + SubscriptValue at[maxRank]; + compDesc.GetLowerBounds(at); + for (std::size_t j{0}; j < n; ++j, compDesc.IncrementSubscripts(at)) { + const Component *component{compDesc.Element(at)}; + INTERNAL_CHECK(component != nullptr); + const Descriptor &nameDesc{component->name()}; + if (nameDesc.ElementBytes() == compNameLen && + std::memcmp(compName, nameDesc.OffsetElement(), compNameLen) == 0) { + return component; + } + } + const DerivedType *ancestor{parent().OffsetElement()}; + return ancestor ? ancestor->FindDataComponent(compName, compNameLen) + : nullptr; +} + +static void DumpScalarCharacter( + FILE *f, const Descriptor &desc, const char *what) { + if (desc.raw().version == CFI_VERSION && + desc.type() == TypeCode{TypeCategory::Character, 1} && + desc.ElementBytes() > 0 && desc.rank() == 0 && + desc.OffsetElement() != nullptr) { + std::fwrite(desc.OffsetElement(), desc.ElementBytes(), 1, f); + } else { + std::fprintf(f, "bad %s descriptor: ", what); + desc.Dump(f); + } +} + +FILE *DerivedType::Dump(FILE *f) const { + std::fprintf( + f, "DerivedType @ 0x%p:\n", reinterpret_cast(this)); + const std::uint64_t *uints{reinterpret_cast(this)}; + for (int j{0}; j < 64; ++j) { + int offset{j * static_cast(sizeof *uints)}; + std::fprintf(f, " [+%3d](0x%p) %#016jx", offset, + reinterpret_cast(&uints[j]), + static_cast(uints[j])); + if (offset == offsetof(DerivedType, binding_)) { + std::fputs(" <-- binding_\n", f); + } else if (offset == offsetof(DerivedType, name_)) { + std::fputs(" <-- name_\n", f); + } else if (offset == offsetof(DerivedType, sizeInBytes_)) { + std::fputs(" <-- sizeInBytes_\n", f); + } else if (offset == offsetof(DerivedType, parent_)) { + std::fputs(" <-- parent_\n", f); + } else if (offset == offsetof(DerivedType, uninstantiated_)) { + std::fputs(" <-- uninstantiated_\n", f); + } else if (offset == offsetof(DerivedType, typeHash_)) { + std::fputs(" <-- typeHash_\n", f); + } else if (offset == offsetof(DerivedType, kindParameter_)) { + std::fputs(" <-- kindParameter_\n", f); + } else if (offset == offsetof(DerivedType, lenParameterKind_)) { + std::fputs(" <-- lenParameterKind_\n", f); + } else if (offset == offsetof(DerivedType, component_)) { + std::fputs(" <-- component_\n", f); + } else if (offset == offsetof(DerivedType, procPtr_)) { + std::fputs(" <-- procPtr_\n", f); + } else if (offset == offsetof(DerivedType, special_)) { + std::fputs(" <-- special_\n", f); + } else { + std::fputc('\n', f); + } + } + std::fputs(" name: ", f); + DumpScalarCharacter(f, name(), "DerivedType::name"); + const Descriptor &bindingDesc{binding()}; + std::fprintf( + f, "\n binding descriptor (byteSize 0x%zx): ", binding_.byteSize); + bindingDesc.Dump(f); + const Descriptor &compDesc{component()}; + std::fputs("\n components:\n", f); + if (compDesc.raw().version == CFI_VERSION && + compDesc.type() == TypeCode{TypeCategory::Derived, 0} && + compDesc.ElementBytes() == sizeof(Component) && compDesc.rank() == 1) { + std::size_t n{compDesc.Elements()}; + for (std::size_t j{0}; j < n; ++j) { + const Component &comp{*compDesc.ZeroBasedIndexedElement(j)}; + std::fprintf(f, " [%3zd] ", j); + comp.Dump(f); + } + } else { + std::fputs(" bad descriptor: ", f); + compDesc.Dump(f); + } + return f; +} + +FILE *Component::Dump(FILE *f) const { + std::fprintf(f, "Component @ 0x%p:\n", reinterpret_cast(this)); + std::fputs(" name: ", f); + DumpScalarCharacter(f, name(), "Component::name"); + switch (genre_) { + case Genre::Data: + std::fputs(" Data ", f); + break; + case Genre::Pointer: + std::fputs(" Pointer ", f); + break; + case Genre::Allocatable: + std::fputs(" Allocatable", f); + break; + case Genre::Automatic: + std::fputs(" Automatic ", f); + break; + default: + std::fprintf(f, " (bad genre 0x%x)", static_cast(genre_)); + break; + } + std::fprintf(f, " category %d kind %d rank %d offset 0x%zx\n", category_, + kind_, rank_, static_cast(offset_)); + return f; +} + +} // namespace Fortran::runtime::typeInfo diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h index c83a5f2..21c955d 100644 --- a/flang/runtime/type-info.h +++ b/flang/runtime/type-info.h @@ -16,24 +16,54 @@ #include "flang/Common/Fortran.h" #include #include +#include namespace Fortran::runtime::typeInfo { +struct Component; + class DerivedType { public: - ~DerivedType(); + ~DerivedType(); // never defined + + const Descriptor &binding() const { return binding_.descriptor(); } + const Descriptor &name() const { return name_.descriptor(); } + std::uint64_t sizeInBytes() const { return sizeInBytes_; } + const Descriptor &parent() const { return parent_.descriptor(); } + std::uint64_t typeHash() const { return typeHash_; } + const Descriptor &uninstatiated() const { + return uninstantiated_.descriptor(); + } + const Descriptor &kindParameter() const { + return kindParameter_.descriptor(); + } + const Descriptor &lenParameterKind() const { + return lenParameterKind_.descriptor(); + } + const Descriptor &component() const { return component_.descriptor(); } + const Descriptor &procPtr() const { return procPtr_.descriptor(); } + const Descriptor &special() const { return special_.descriptor(); } + + std::size_t LenParameters() const { return lenParameterKind().Elements(); } + + // Finds a data component by name in this derived type or tis ancestors. + const Component *FindDataComponent( + const char *name, std::size_t nameLen) const; + FILE *Dump(FILE * = stdout) const; + +private: // This member comes first because it's used like a vtable by generated code. // It includes all of the ancestor types' bindings, if any, first, // with any overrides from descendants already applied to them. Local // bindings then follow in alphabetic order of binding name. StaticDescriptor<1, true> - binding; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS + binding_; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS - StaticDescriptor<0> name; // CHARACTER(:), POINTER + StaticDescriptor<0> name_; // CHARACTER(:), POINTER - std::uint64_t sizeInBytes{0}; - StaticDescriptor<0, true> parent; // TYPE(DERIVEDTYPE), POINTER + std::uint64_t sizeInBytes_{0}; + StaticDescriptor<0, true> parent_; // TYPE(DERIVEDTYPE), POINTER // Instantiations of a parameterized derived type with KIND type // parameters will point this data member to the description of @@ -41,32 +71,30 @@ public: // module via use association. The original uninstantiated derived // type description will point to itself. Derived types that have // no KIND type parameters will have a null pointer here. - StaticDescriptor<0, true> uninstantiated; // TYPE(DERIVEDTYPE), POINTER + StaticDescriptor<0, true> uninstantiated_; // TYPE(DERIVEDTYPE), POINTER // TODO: flags for SEQUENCE, BIND(C), any PRIVATE component(? see 7.5.2) - std::uint64_t typeHash{0}; + std::uint64_t typeHash_{0}; // These pointer targets include all of the items from the parent, if any. - StaticDescriptor<1> kindParameter; // pointer to rank-1 array of INTEGER(8) - StaticDescriptor<1> lenParameterKind; // pointer to rank-1 array of INTEGER(1) + StaticDescriptor<1> kindParameter_; // pointer to rank-1 array of INTEGER(8) + StaticDescriptor<1> + lenParameterKind_; // pointer to rank-1 array of INTEGER(1) // This array of local data components includes the parent component. // Components are in alphabetic order. + // TODO pmk: fix to be "component order" // It does not include procedure pointer components. StaticDescriptor<1, true> - component; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS + component_; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS // Procedure pointer components StaticDescriptor<1, true> - procPtr; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS + procPtr_; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS // Does not include special bindings from ancestral types. StaticDescriptor<1, true> - special; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS - - std::size_t LenParameters() const { - return lenParameterKind.descriptor().Elements(); - } + special_; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS }; using ProcedurePointer = void (*)(); // TYPE(C_FUNPTR) @@ -76,33 +104,70 @@ struct Binding { StaticDescriptor<0> name; // CHARACTER(:), POINTER }; -struct Value { +class Value { +public: enum class Genre : std::uint8_t { Deferred = 1, Explicit = 2, LenParameter = 3 }; - Genre genre{Genre::Explicit}; + + std::optional GetValue(const Descriptor *) const; + +private: + Genre genre_{Genre::Explicit}; // The value encodes an index into the table of LEN type parameters in // a descriptor's addendum for genre == Genre::LenParameter. - TypeParameterValue value{0}; + TypeParameterValue value_{0}; }; -struct Component { - enum class Genre : std::uint8_t { Data, Pointer, Allocatable, Automatic }; - StaticDescriptor<0> name; // CHARACTER(:), POINTER - Genre genre{Genre::Data}; - std::uint8_t category; // common::TypeCategory - std::uint8_t kind{0}; - std::uint8_t rank{0}; - std::uint64_t offset{0}; - Value characterLen; // for TypeCategory::Character - StaticDescriptor<0, true> derivedType; // TYPE(DERIVEDTYPE), POINTER +class Component { +public: + enum class Genre : std::uint8_t { + Data = 1, + Pointer = 2, + Allocatable = 3, + Automatic = 4 + }; + + const Descriptor &name() const { return name_.descriptor(); } + Genre genre() const { return genre_; } + TypeCategory category() const { return static_cast(category_); } + int kind() const { return kind_; } + int rank() const { return rank_; } + std::uint64_t offset() const { return offset_; } + const Value &characterLen() const { return characterLen_; } + const DerivedType *derivedType() const { + return derivedType_.descriptor().OffsetElement(); + } + const Value *lenValue() const { + return lenValue_.descriptor().OffsetElement(); + } + const Value *bounds() const { + return bounds_.descriptor().OffsetElement(); + } + const char *initialization() const { return initialization_; } + + // Creates a pointer descriptor from a component description. + void EstablishDescriptor(Descriptor &, const Descriptor &container, + const SubscriptValue[], Terminator &) const; + + FILE *Dump(FILE * = stdout) const; + +private: + StaticDescriptor<0> name_; // CHARACTER(:), POINTER + Genre genre_{Genre::Data}; + std::uint8_t category_; // common::TypeCategory + std::uint8_t kind_{0}; + std::uint8_t rank_{0}; + std::uint64_t offset_{0}; + Value characterLen_; // for TypeCategory::Character + StaticDescriptor<0, true> derivedType_; // TYPE(DERIVEDTYPE), POINTER StaticDescriptor<1, true> - lenValue; // TYPE(VALUE), POINTER, DIMENSION(:), CONTIGUOUS + lenValue_; // TYPE(VALUE), POINTER, DIMENSION(:), CONTIGUOUS StaticDescriptor<2, true> - bounds; // TYPE(VALUE), POINTER, DIMENSION(2,:), CONTIGUOUS - char *initialization{nullptr}; // for Genre::Data and Pointer + bounds_; // TYPE(VALUE), POINTER, DIMENSION(2,:), CONTIGUOUS + const char *initialization_{nullptr}; // for Genre::Data and Pointer // TODO: cobounds // TODO: `PRIVATE` attribute }; diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90 index b429882..a68c392 100644 --- a/flang/test/Semantics/typeinfo01.f90 +++ b/flang/test/Semantics/typeinfo01.f90 @@ -20,7 +20,7 @@ module m02 type, extends(parent) :: child integer :: cn end type -!CHECK: .c.child, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:1_8 init:[component::component(name=.n.cn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=4_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.parent,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.parent,lenvalue=NULL(),bounds=NULL(),initialization=NULL())] +!CHECK: .c.child, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:1_8 init:[component::component(name=.n.parent,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.parent,lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.cn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=4_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())] !CHECK: .c.parent, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.pn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())] !CHECK: .dt.child, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.child,sizeinbytes=8_8,parent=.dt.parent,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL()) !CHECK: .dt.parent, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL()) @@ -232,7 +232,7 @@ module m11 contains subroutine s1(x) !CHECK: .b.t.1.automatic, SAVE, TARGET: ObjectEntity type: TYPE(value) shape: 0_8:1_8,0_8:0_8 init:reshape([value::value(genre=2_1,value=1_8),value(genre=3_1,value=0_8)],shape=[2,1]) -!CHECK: .c.t.1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:3_8 init:[component::component(name=.n.allocatable,genre=3_1,category=1_1,kind=4_1,rank=1_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.automatic,genre=4_1,category=1_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.automatic,initialization=NULL()),component(name=.n.chauto,genre=4_1,category=3_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=1_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=target)] +!CHECK: .c.t.1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:3_8 init:[component::component(name=.n.allocatable,genre=3_1,category=1_1,kind=4_1,rank=1_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=1_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=target),component(name=.n.chauto,genre=4_1,category=3_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.automatic,genre=4_1,category=1_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.automatic,initialization=NULL())] !CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,parent=NULL(),uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL()) !CHECK: .lpk.t.1, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1] type(t(*)), intent(in) :: x -- 2.7.4