diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h --- a/flang/include/flang/Semantics/runtime-type-info.h +++ b/flang/include/flang/Semantics/runtime-type-info.h @@ -33,6 +33,5 @@ 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 --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -427,7 +427,7 @@ 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 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 @@ }, 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 --- a/flang/runtime/CMakeLists.txt +++ b/flang/runtime/CMakeLists.txt @@ -70,6 +70,7 @@ 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 --- a/flang/runtime/copy.cpp +++ b/flang/runtime/copy.cpp @@ -26,20 +26,20 @@ 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 --- a/flang/runtime/derived.cpp +++ b/flang/runtime/derived.cpp @@ -15,7 +15,7 @@ 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 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 @@ 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 --- 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 @@ 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; } @@ -216,6 +218,67 @@ return true; } +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>()) { @@ -233,7 +296,9 @@ 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 @@ 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.h b/flang/runtime/descriptor.h --- a/flang/runtime/descriptor.h +++ b/flang/runtime/descriptor.h @@ -109,8 +109,9 @@ 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/descriptor.cpp b/flang/runtime/descriptor.cpp --- a/flang/runtime/descriptor.cpp +++ b/flang/runtime/descriptor.cpp @@ -42,9 +42,12 @@ // 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(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(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/namelist.cpp b/flang/runtime/namelist.cpp --- 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/flang/runtime/tools.h +++ b/flang/runtime/tools.h @@ -333,5 +333,6 @@ } return std::nullopt; } + } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_TOOLS_H_ diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h --- 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 @@ // 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 @@ 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/runtime/type-info.cpp b/flang/runtime/type-info.cpp new file mode 100644 --- /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/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90 --- a/flang/test/Semantics/typeinfo01.f90 +++ b/flang/test/Semantics/typeinfo01.f90 @@ -20,7 +20,7 @@ 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 @@ 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