Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -166,8 +166,10 @@ inline bool IsImpliedDoIndex(const Symbol &symbol) { return symbol.owner().kind() == Scope::Kind::ImpliedDos; } -bool IsFinalizable(const Symbol &); -bool IsFinalizable(const DerivedTypeSpec &); +bool IsFinalizable( + const Symbol &, std::set * = nullptr); +bool IsFinalizable( + const DerivedTypeSpec &, std::set * = nullptr); bool HasImpureFinal(const DerivedTypeSpec &); bool IsCoarray(const Symbol &); bool IsInBlankCommon(const Symbol &); Index: flang/include/flang/Semantics/type.h =================================================================== --- flang/include/flang/Semantics/type.h +++ flang/include/flang/Semantics/type.h @@ -258,6 +258,7 @@ bool IsForwardReferenced() const; bool HasDefaultInitialization() const; bool HasDestruction() const; + bool HasFinalization() const; // The "raw" type parameter list is a simple transcription from the // parameter list in the parse tree, built by calling AddRawParamValue(). Index: flang/lib/Semantics/runtime-type-info.cpp =================================================================== --- flang/lib/Semantics/runtime-type-info.cpp +++ flang/lib/Semantics/runtime-type-info.cpp @@ -14,6 +14,7 @@ #include "flang/Evaluate/type.h" #include "flang/Semantics/scope.h" #include "flang/Semantics/tools.h" +#include #include #include #include @@ -68,12 +69,12 @@ std::vector DescribeBindings( const Scope &dtScope, Scope &); void DescribeGeneric( - const GenericDetails &, std::vector &); - void DescribeSpecialProc(std::vector &, + const GenericDetails &, std::map &); + void DescribeSpecialProc(std::map &, const Symbol &specificOrBinding, bool isAssignment, bool isFinal, std::optional); void IncorporateDefinedIoGenericInterfaces( - std::vector &, SourceName, + std::map &, SourceName, GenericKind::DefinedIo, const Scope *); // Instantiated for ParamValue and Bound @@ -124,16 +125,16 @@ SomeExpr deferredEnum_; // Value::Genre::Deferred SomeExpr explicitEnum_; // Value::Genre::Explicit SomeExpr lenParameterEnum_; // Value::Genre::LenParameter - SomeExpr assignmentEnum_; // SpecialBinding::Which::Assignment + SomeExpr scalarAssignmentEnum_; // SpecialBinding::Which::ScalarAssignment SomeExpr elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment - SomeExpr finalEnum_; // SpecialBinding::Which::Final - SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal - SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted + SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal + SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal + SomeExpr scalarFinalEnum_; // SpecialBinding::Which::ScalarFinal parser::CharBlock location_; std::set ignoreScopes_; }; @@ -148,15 +149,15 @@ "deferred")}, explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue( "lenparameter")}, - assignmentEnum_{GetEnumValue("assignment")}, + scalarAssignmentEnum_{GetEnumValue("scalarassignment")}, elementalAssignmentEnum_{GetEnumValue("elementalassignment")}, - finalEnum_{GetEnumValue("final")}, elementalFinalEnum_{GetEnumValue( - "elementalfinal")}, - assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")}, readFormattedEnum_{GetEnumValue("readformatted")}, readUnformattedEnum_{GetEnumValue("readunformatted")}, writeFormattedEnum_{GetEnumValue("writeformatted")}, - writeUnformattedEnum_{GetEnumValue("writeunformatted")} { + writeUnformattedEnum_{GetEnumValue("writeunformatted")}, + elementalFinalEnum_{GetEnumValue("elementalfinal")}, + assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")}, + scalarFinalEnum_{GetEnumValue("scalarfinal")} { ignoreScopes_.insert(tables_.schemata); } @@ -399,9 +400,6 @@ AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s, SomeExpr{evaluate::NullPointer{}}); } - - // TODO: compute typeHash - using Int8 = evaluate::Type; using Int1 = evaluate::Type; std::vector kinds; @@ -442,7 +440,7 @@ if (!isPDTdefinition) { std::vector dataComponentSymbols; std::vector procPtrComponents; - std::vector specials; + std::map specials; for (const auto &pair : dtScope) { const Symbol &symbol{*pair.second}; auto locationRestorer{common::ScopedSet(location_, symbol.name())}; @@ -507,12 +505,10 @@ static_cast(bindings.size())})); // Describe "special" bindings to defined assignments, FINAL subroutines, // and user-defined derived type I/O subroutines. - if (dtScope.symbol()) { - for (const auto &pair : - dtScope.symbol()->get().finals()) { - DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/, - true, std::nullopt); - } + const DerivedTypeDetails &dtDetails{dtSymbol->get()}; + for (const auto &pair : dtDetails.finals()) { + DescribeSpecialProc( + specials, *pair.second, false /*!isAssignment*/, true, std::nullopt); } IncorporateDefinedIoGenericInterfaces(specials, SourceName{"read(formatted)", 15}, @@ -526,11 +522,24 @@ IncorporateDefinedIoGenericInterfaces(specials, SourceName{"write(unformatted)", 18}, GenericKind::DefinedIo::WriteUnformatted, &scope); + // Pack the special procedure bindings in ascending order of their "which" + // code values, and compile a little-endian bit-set of those codes for + // use in O(1) look-up at run time. + std::vector sortedSpecials; + std::uint32_t specialBitSet{0}; + for (auto &pair : specials) { + auto bit{std::uint32_t{1} << pair.first}; + CHECK(!(specialBitSet & bit)); + specialBitSet |= bit; + sortedSpecials.emplace_back(std::move(pair.second)); + } AddValue(dtValues, derivedTypeSchema_, "special"s, SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName), - std::move(specials), + std::move(sortedSpecials), evaluate::ConstantSubscripts{ static_cast(specials.size())})); + AddValue(dtValues, derivedTypeSchema_, "specialbitset"s, + IntExpr<4>(specialBitSet)); // Note the presence/absence of a parent component AddValue(dtValues, derivedTypeSchema_, "hasparent"s, IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr)); @@ -543,6 +552,9 @@ // Similarly, a flag to short-circuit destruction when not needed. AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s, IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction())); + // Similarly, a flag to short-circuit finalization when not needed. + AddValue(dtValues, derivedTypeSchema_, "nofinalizationneeded"s, + IntExpr<1>(derivedTypeSpec && !IsFinalizable(*derivedTypeSpec))); } dtObject.get().set_init(MaybeExpr{ StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))}); @@ -904,7 +916,7 @@ } void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic, - std::vector &specials) { + std::map &specials) { std::visit(common::visitors{ [&](const GenericKind::OtherKind &k) { if (k == GenericKind::OtherKind::Assignment) { @@ -933,21 +945,21 @@ } void RuntimeTableBuilder::DescribeSpecialProc( - std::vector &specials, + std::map &specials, const Symbol &specificOrBinding, bool isAssignment, bool isFinal, std::optional io) { const auto *binding{specificOrBinding.detailsIf()}; const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)}; if (auto proc{evaluate::characteristics::Procedure::Characterize( specific, context_.foldingContext())}) { - std::uint8_t rank{0}; std::uint8_t isArgDescriptorSet{0}; int argThatMightBeDescriptor{0}; MaybeExpr which; if (isAssignment) { // only type-bound asst's are germane to runtime CHECK(binding != nullptr); CHECK(proc->dummyArguments.size() == 2); - which = proc->IsElemental() ? elementalAssignmentEnum_ : assignmentEnum_; + which = proc->IsElemental() ? elementalAssignmentEnum_ + : scalarAssignmentEnum_; if (binding && binding->passName() && *binding->passName() == proc->dummyArguments[1].name) { argThatMightBeDescriptor = 1; @@ -971,10 +983,10 @@ which = assumedRankFinalEnum_; isArgDescriptorSet |= 1; } else { - which = finalEnum_; - rank = evaluate::GetRank(typeAndShape.shape()); - if (rank > 0) { + which = scalarFinalEnum_; + if (int rank{evaluate::GetRank(typeAndShape.shape())}; rank > 0) { argThatMightBeDescriptor = 1; + which = IntExpr<1>(ToInt64(which).value() + rank); } } } @@ -1004,19 +1016,22 @@ isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1); } evaluate::StructureConstructorValues values; + auto index{evaluate::ToInt64(which)}; + CHECK(index.has_value()); AddValue( values, specialSchema_, "which"s, SomeExpr{std::move(which.value())}); - AddValue(values, specialSchema_, "rank"s, IntExpr<1>(rank)); AddValue(values, specialSchema_, "isargdescriptorset"s, IntExpr<1>(isArgDescriptorSet)); AddValue(values, specialSchema_, "proc"s, SomeExpr{evaluate::ProcedureDesignator{specific}}); - specials.emplace_back(DEREF(specialSchema_.AsDerived()), std::move(values)); + auto pair{specials.try_emplace( + *index, DEREF(specialSchema_.AsDerived()), std::move(values))}; + CHECK(pair.second); // ensure not already present } } void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces( - std::vector &specials, SourceName name, + std::map &specials, SourceName name, GenericKind::DefinedIo definedIo, const Scope *scope) { for (; !scope->IsGlobal(); scope = &scope->parent()) { if (auto asst{scope->find(name)}; asst != scope->end()) { Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -687,7 +687,8 @@ return false; } -bool IsFinalizable(const Symbol &symbol) { +bool IsFinalizable( + const Symbol &symbol, std::set *inProgress) { if (IsPointer(symbol)) { return false; } @@ -696,19 +697,33 @@ return false; } const DeclTypeSpec *type{object->type()}; - const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr}; - return derived && IsFinalizable(*derived); + const DerivedTypeSpec *typeSpec{type ? type->AsDerived() : nullptr}; + return typeSpec && IsFinalizable(*typeSpec, inProgress); } return false; } -bool IsFinalizable(const DerivedTypeSpec &derived) { +bool IsFinalizable(const DerivedTypeSpec &derived, + std::set *inProgress) { if (!derived.typeSymbol().get().finals().empty()) { return true; } - DirectComponentIterator components{derived}; - return bool{std::find_if(components.begin(), components.end(), - [](const Symbol &component) { return IsFinalizable(component); })}; + std::set basis; + if (inProgress) { + if (inProgress->find(&derived) != inProgress->end()) { + return false; // don't loop on recursive type + } + } else { + inProgress = &basis; + } + auto iterator{inProgress->insert(&derived).first}; + PotentialComponentIterator components{derived}; + bool result{bool{std::find_if( + components.begin(), components.end(), [=](const Symbol &component) { + return IsFinalizable(component, inProgress); + })}}; + inProgress->erase(iterator); + return result; } bool HasImpureFinal(const DerivedTypeSpec &derived) { Index: flang/module/__fortran_type_info.f90 =================================================================== --- flang/module/__fortran_type_info.f90 +++ flang/module/__fortran_type_info.f90 @@ -36,7 +36,6 @@ ! Instances of parameterized derived types use the "uninstantiated" ! component to point to the pristine original definition. type(DerivedType), pointer :: uninstantiated - integer(kind=int64) :: typeHash integer(kind=int64), pointer, contiguous :: kindParameter(:) ! values of instance integer(1), pointer, contiguous :: lenParameterKind(:) ! INTEGER kinds of LEN types ! Data components appear in component order. @@ -44,11 +43,15 @@ type(Component), pointer, contiguous :: component(:) ! data components type(ProcPtrComponent), pointer, contiguous :: procptr(:) ! procedure pointers ! Special bindings of the ancestral types are not duplicated here. + ! Bindings are in ascending order of their "which" code values. type(SpecialBinding), pointer, contiguous :: special(:) + ! A little-endian bit set of SpecialBinding::Which codes present in "special" + integer(4) :: specialBitSet integer(1) :: hasParent integer(1) :: noInitializationNeeded ! 1 if no component w/ init integer(1) :: noDestructionNeeded ! 1 if no component w/ dealloc/final - integer(1) :: __padding0(5) + integer(1) :: noFinalizationNeeded ! 1 if nothing finalizaable + integer(1) :: __padding0(4) end type type :: Binding @@ -101,17 +104,17 @@ end type enum, bind(c) ! SpecialBinding::Which - enumerator :: Assignment = 4, ElementalAssignment = 5 - enumerator :: Final = 8, ElementalFinal = 9, AssumedRankFinal = 10 - enumerator :: ReadFormatted = 16, ReadUnformatted = 17 - enumerator :: WriteFormatted = 18, WriteUnformatted = 19 + enumerator :: ScalarAssignment = 1, ElementalAssignment = 2 + enumerator :: ReadFormatted = 3, ReadUnformatted = 4 + enumerator :: WriteFormatted = 5, WriteUnformatted = 6 + enumerator :: ElementalFinal = 7, AssumedRankFinal = 8 + enumerator :: ScalarFinal = 9 ! higher-rank final procedures follow end enum type, bind(c) :: SpecialBinding integer(1) :: which ! SpecialBinding::Which - integer(1) :: rank ! for which == SpecialBinding::Which::Final only integer(1) :: isArgDescriptorSet - integer(1) :: __padding0(5) + integer(1) :: __padding0(6) type(__builtin_c_funptr) :: proc end type Index: flang/runtime/CMakeLists.txt =================================================================== --- flang/runtime/CMakeLists.txt +++ flang/runtime/CMakeLists.txt @@ -33,6 +33,7 @@ add_flang_library(FortranRuntime ISO_Fortran_binding.cpp allocatable.cpp + assign.cpp buffer.cpp complex-reduction.c copy.cpp Index: flang/runtime/allocatable.h =================================================================== --- flang/runtime/allocatable.h +++ flang/runtime/allocatable.h @@ -89,15 +89,6 @@ bool hasStat = false, const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, int sourceLine = 0); -// Assigns to a whole allocatable, with automatic (re)allocation when the -// destination is unallocated or nonconforming (Fortran 2003 semantics). -// The descriptor must be initialized. -// Recursively assigns components with (re)allocation as necessary. -// TODO: Consider renaming to a more general name that will work for -// assignments to pointers, dummy arguments, and anything else with a -// descriptor. -void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor &from); - // Implements the intrinsic subroutine MOVE_ALLOC (16.9.137 in F'2018, // but note the order of first two arguments is reversed for consistency // with the other APIs for allocatables.) The destination descriptor Index: flang/runtime/allocatable.cpp =================================================================== --- flang/runtime/allocatable.cpp +++ flang/runtime/allocatable.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "allocatable.h" +#include "assign.h" #include "derived.h" #include "stat.h" #include "terminator.h" @@ -37,10 +38,6 @@ derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable); } -void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) { - INTERNAL_CHECK(false); // TODO: AllocatableAssign is not yet implemented -} - int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/, bool /*hasStat*/, const Descriptor * /*errMsg*/, const char * /*sourceFile*/, int /*sourceLine*/) { Index: flang/runtime/assign.h =================================================================== --- /dev/null +++ flang/runtime/assign.h @@ -0,0 +1,45 @@ +//===-- runtime/assign.h --------------------------------------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// External and internal APIs for data assignment (both intrinsic assignment +// and TBP defined generic ASSIGNMENT(=)). Should be called by lowering +// for any assignments possibly needing special handling. Intrinsic assignment +// to non-allocatable variables whose types are intrinsic need not come through +// here (though they may do so). Assignments to allocatables, and assignments +// whose types may be polymorphic or are monomorphic and of derived types with +// finalization, allocatable components, or components with type-bound defined +// assignments, in the original type or the types of its non-pointer components +// (recursively) must arrive here. +// +// Non-type-bound generic INTERFACE ASSIGNMENT(=) is resolved in semantics and +// need not be handled here in the runtime; ditto for type conversions on +// intrinsic assignments. + +#ifndef FLANG_RUNTIME_ASSIGN_H_ +#define FLANG_RUNTIME_ASSIGN_H_ + +#include "entry-names.h" + +namespace Fortran::runtime { +class Descriptor; +class Terminator; + +// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or +// type-bound (only!) defined assignment (10.2.1.4), as appropriate. Performs +// finalization, scalar expansion, & allocatable (re)allocation as needed. +// Does not perform intrinsic assignment implicit type conversion. Both +// descriptors must be initialized. Recurses as needed to handle components. +void Assign(Descriptor &, const Descriptor &, Terminator &); + +extern "C" { +// API for lowering assignment +void RTNAME(Assign)(Descriptor &to, const Descriptor &from, + const char *sourceFile = nullptr, int sourceLine = 0); +} // extern "C" +} // namespace Fortran::runtime +#endif // FLANG_RUNTIME_ASSIGN_H_ Index: flang/runtime/assign.cpp =================================================================== --- /dev/null +++ flang/runtime/assign.cpp @@ -0,0 +1,285 @@ +//===-- runtime/assign.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 "assign.h" +#include "derived.h" +#include "descriptor.h" +#include "stat.h" +#include "terminator.h" +#include "type-info.h" + +namespace Fortran::runtime { + +static void DoScalarDefinedAssignment(const Descriptor &to, + const Descriptor &from, const typeInfo::SpecialBinding &special) { + bool toIsDesc{special.IsArgDescriptor(0)}; + bool fromIsDesc{special.IsArgDescriptor(1)}; + if (toIsDesc) { + if (fromIsDesc) { + auto *p{ + special.GetProc()}; + p(to, from); + } else { + auto *p{special.GetProc()}; + p(to, from.raw().base_addr); + } + } else { + if (fromIsDesc) { + auto *p{special.GetProc()}; + p(to.raw().base_addr, from); + } else { + auto *p{special.GetProc()}; + p(to.raw().base_addr, from.raw().base_addr); + } + } +} + +static void DoElementalDefinedAssignment(const Descriptor &to, + const Descriptor &from, const typeInfo::SpecialBinding &special, + std::size_t toElements, SubscriptValue toAt[], SubscriptValue fromAt[]) { + StaticDescriptor statDesc[2]; + Descriptor &toElementDesc{statDesc[0].descriptor()}; + Descriptor &fromElementDesc{statDesc[1].descriptor()}; + toElementDesc = to; + toElementDesc.raw().attribute = CFI_attribute_pointer; + toElementDesc.raw().rank = 0; + fromElementDesc = from; + fromElementDesc.raw().attribute = CFI_attribute_pointer; + fromElementDesc.raw().rank = 0; + for (std::size_t j{0}; j < toElements; + ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + toElementDesc.set_base_addr(to.Element(toAt)); + fromElementDesc.set_base_addr(from.Element(fromAt)); + DoScalarDefinedAssignment(toElementDesc, fromElementDesc, special); + } +} + +void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) { + DescriptorAddendum *toAddendum{to.Addendum()}; + const typeInfo::DerivedType *toDerived{ + toAddendum ? toAddendum->derivedType() : nullptr}; + const DescriptorAddendum *fromAddendum{from.Addendum()}; + const typeInfo::DerivedType *fromDerived{ + fromAddendum ? fromAddendum->derivedType() : nullptr}; + bool wasJustAllocated{false}; + if (to.IsAllocatable()) { + std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0}; + if (to.IsAllocated()) { + // Top-level assignments to allocatable variables (*not* components) + // may first deallocate existing content if there's about to be a + // change in type or shape; see F'2018 10.2.1.3(3). + bool deallocate{false}; + if (to.type() != from.type()) { + deallocate = true; + } else if (toDerived != fromDerived) { + deallocate = true; + } else { + if (toAddendum) { + // Distinct LEN parameters? Deallocate + for (std::size_t j{0}; j < lenParms; ++j) { + if (toAddendum->LenParameterValue(j) != + fromAddendum->LenParameterValue(j)) { + deallocate = true; + break; + } + } + } + if (from.rank() > 0) { + // Distinct shape? Deallocate + int rank{to.rank()}; + for (int j{0}; j < rank; ++j) { + if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) { + deallocate = true; + break; + } + } + } + } + if (deallocate) { + to.Destroy(true /*finalize*/); + } + } else if (to.rank() != from.rank()) { + terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to " + "unallocated allocatable", + to.rank(), from.rank()); + } + if (!to.IsAllocated()) { + to.raw().type = from.raw().type; + to.raw().elem_len = from.ElementBytes(); + if (toAddendum) { + toDerived = fromDerived; + toAddendum->set_derivedType(toDerived); + for (std::size_t j{0}; j < lenParms; ++j) { + toAddendum->SetLenParameterValue( + j, fromAddendum->LenParameterValue(j)); + } + } + // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3)) + int rank{from.rank()}; + auto stride{static_cast(to.ElementBytes())}; + for (int j{0}; j < rank; ++j) { + auto &toDim{to.GetDimension(j)}; + const auto &fromDim{from.GetDimension(j)}; + toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound()); + toDim.SetByteStride(stride); + stride *= toDim.Extent(); + } + ReturnError(terminator, to.Allocate()); + if (fromDerived && !fromDerived->noInitializationNeeded()) { + ReturnError(terminator, Initialize(to, *toDerived, terminator)); + } + wasJustAllocated = true; + } + } + SubscriptValue toAt[maxRank]; + to.GetLowerBounds(toAt); + // Scalar expansion of the RHS is implied by using the same empty + // subscript values on each (seemingly) elemental reference into + // "from". + SubscriptValue fromAt[maxRank]; + from.GetLowerBounds(fromAt); + std::size_t toElements{to.Elements()}; + if (from.rank() > 0 && toElements != from.Elements()) { + terminator.Crash("Assign: mismatching element counts in array assignment " + "(to %zd, from %zd)", + toElements, from.Elements()); + } + if (to.type() != from.type()) { + terminator.Crash("Assign: mismatching types (to code %d != from code %d)", + to.type().raw(), from.type().raw()); + } + std::size_t elementBytes{to.ElementBytes()}; + if (elementBytes != from.ElementBytes()) { + terminator.Crash( + "Assign: mismatching element sizes (to %zd bytes != from %zd bytes)", + elementBytes, from.ElementBytes()); + } + if (toDerived) { // Derived type assignment + // Check for defined assignment type-bound procedures (10.2.1.4-5) + if (to.rank() == 0) { + if (const auto *special{toDerived->FindSpecialBinding( + typeInfo::SpecialBinding::Which::ScalarAssignment)}) { + return DoScalarDefinedAssignment(to, from, *special); + } + } + if (const auto *special{toDerived->FindSpecialBinding( + typeInfo::SpecialBinding::Which::ElementalAssignment)}) { + return DoElementalDefinedAssignment( + to, from, *special, toElements, toAt, fromAt); + } + // Derived type intrinsic assignment, which is componentwise and elementwise + // for all components, including parent components (10.2.1.2-3). + // The target is first finalized if still necessary (7.5.6.3(1)) + if (!wasJustAllocated && !toDerived->noFinalizationNeeded()) { + Finalize(to, *toDerived); + } + // Copy the data components (incl. the parent) first. + const Descriptor &componentDesc{toDerived->component()}; + std::size_t numComponents{componentDesc.Elements()}; + for (std::size_t k{0}; k < numComponents; ++k) { + const auto &comp{ + *componentDesc.ZeroBasedIndexedElement( + k)}; // TODO: exploit contiguity here + switch (comp.genre()) { + case typeInfo::Component::Genre::Data: + if (comp.category() == TypeCategory::Derived) { + StaticDescriptor statDesc[2]; + Descriptor &toCompDesc{statDesc[0].descriptor()}; + Descriptor &fromCompDesc{statDesc[1].descriptor()}; + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + comp.CreatePointerDescriptor(toCompDesc, to, toAt, terminator); + comp.CreatePointerDescriptor( + fromCompDesc, from, fromAt, terminator); + Assign(toCompDesc, fromCompDesc, terminator); + } + } else { // Component has intrinsic type; simply copy raw bytes + std::size_t componentByteSize{comp.SizeInBytes(to)}; + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt) + comp.offset(), + from.Element(fromAt) + comp.offset(), + componentByteSize); + } + } + break; + case typeInfo::Component::Genre::Pointer: { + std::size_t componentByteSize{comp.SizeInBytes(to)}; + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt) + comp.offset(), + from.Element(fromAt) + comp.offset(), + componentByteSize); + } + } break; + case typeInfo::Component::Genre::Allocatable: + case typeInfo::Component::Genre::Automatic: + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + auto *toDesc{reinterpret_cast( + to.Element(toAt) + comp.offset())}; + const auto *fromDesc{reinterpret_cast( + from.Element(fromAt) + comp.offset())}; + if (toDesc->IsAllocatable()) { + if (toDesc->IsAllocated()) { + // Allocatable components of the LHS are unconditionally + // deallocated before assignment (F'2018 10.2.1.3(13)(1)), + // unlike a "top-level" assignment to a variable, where + // deallocation is optional. + // TODO: Consider skipping this step and deferring the + // deallocation to the recursive activation of Assign(), + // which might be able to avoid deallocation/reallocation + // when the existing allocation can be reoccupied. + toDesc->Destroy(false /*already finalized*/); + } + if (!fromDesc->IsAllocated()) { + continue; // F'2018 10.2.1.3(13)(2) + } + } + Assign(*toDesc, *fromDesc, terminator); + } + break; + } + } + // Copy procedure pointer components + const Descriptor &procPtrDesc{toDerived->procPtr()}; + std::size_t numProcPtrs{procPtrDesc.Elements()}; + for (std::size_t k{0}; k < numProcPtrs; ++k) { + const auto &procPtr{ + *procPtrDesc.ZeroBasedIndexedElement(k)}; + for (std::size_t j{0}; j < toElements; ++j, to.IncrementSubscripts(toAt), + from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt) + procPtr.offset, + from.Element(fromAt) + procPtr.offset, + sizeof(typeInfo::ProcedurePointer)); + } + } + } else { // intrinsic type, intrinsic assignment + if (to.rank() == from.rank() && to.IsContiguous() && from.IsContiguous()) { + // Everything is contiguous; do a single big copy + std::memmove( + to.raw().base_addr, from.raw().base_addr, toElements * elementBytes); + } else { // elemental copies + for (std::size_t n{toElements}; n-- > 0; + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt), from.Element(fromAt), + elementBytes); + } + } + } +} + +extern "C" { +void RTNAME(Assign)(Descriptor &to, const Descriptor &from, + const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + Assign(to, from, terminator); +} + +} // extern "C" +} // namespace Fortran::runtime Index: flang/runtime/derived.h =================================================================== --- flang/runtime/derived.h +++ flang/runtime/derived.h @@ -24,16 +24,12 @@ int Initialize(const Descriptor &, const typeInfo::DerivedType &, Terminator &, bool hasStat = false, const Descriptor *errMsg = nullptr); +// Call FINAL subroutines, if any +void Finalize(const Descriptor &, const typeInfo::DerivedType &derived); + // Call FINAL subroutines, deallocate allocatable & automatic components. // Does not deallocate the original descriptor. void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &); -// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or -// defined assignment (10.2.1.4), as appropriate. Performs scalar expansion -// or allocatable reallocation as needed. Does not perform intrinsic -// assignment implicit type conversion. -void Assign(Descriptor &, const Descriptor &, const typeInfo::DerivedType &, - Terminator &); - } // namespace Fortran::runtime #endif // FLANG_RUNTIME_DERIVED_H_ Index: flang/runtime/derived.cpp =================================================================== --- flang/runtime/derived.cpp +++ flang/runtime/derived.cpp @@ -95,27 +95,16 @@ static const typeInfo::SpecialBinding *FindFinal( const typeInfo::DerivedType &derived, int rank) { - const typeInfo::SpecialBinding *elemental{nullptr}; - const Descriptor &specialDesc{derived.special()}; - std::size_t totalSpecialBindings{specialDesc.Elements()}; - for (std::size_t j{0}; j < totalSpecialBindings; ++j) { - const auto &special{ - *specialDesc.ZeroBasedIndexedElement(j)}; - switch (special.which()) { - case typeInfo::SpecialBinding::Which::Final: - if (special.rank() == rank) { - return &special; - } - break; - case typeInfo::SpecialBinding::Which::ElementalFinal: - elemental = &special; - break; - case typeInfo::SpecialBinding::Which::AssumedRankFinal: - return &special; - default:; - } + if (const auto *ranked{derived.FindSpecialBinding( + typeInfo::SpecialBinding::RankFinal(rank))}) { + return ranked; + } else if (const auto *assumed{derived.FindSpecialBinding( + typeInfo::SpecialBinding::Which::AssumedRankFinal)}) { + return assumed; + } else { + return derived.FindSpecialBinding( + typeInfo::SpecialBinding::Which::ElementalFinal); } - return elemental; } static void CallFinalSubroutine( @@ -159,24 +148,22 @@ } } -// 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. -void Destroy(const Descriptor &descriptor, bool finalize, - const typeInfo::DerivedType &derived) { - if (finalize) { - CallFinalSubroutine(descriptor, derived); +// Fortran 2018 subclause 7.5.6.2 +void Finalize( + const Descriptor &descriptor, const typeInfo::DerivedType &derived) { + if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) { + return; } + CallFinalSubroutine(descriptor, derived); + const auto *parentType{derived.GetParentType()}; + bool recurse{parentType && !parentType->noFinalizationNeeded()}; + // If there's a finalizable parent component, handle it last, as required + // by the Fortran standard (7.5.6.2), and do so recursively with the same + // descriptor so that the rank is preserved. const Descriptor &componentDesc{derived.component()}; std::size_t myComponents{componentDesc.Elements()}; std::size_t elements{descriptor.Elements()}; std::size_t byteStride{descriptor.ElementBytes()}; - // If there's a finalizable parent component, handle it last, as required - // by the Fortran standard (7.5.6.2), and do so recursively with the same - // descriptor so that the rank is preserved. Otherwise, destroy the parent - // component like any other. - const auto *parentType{derived.GetParentType()}; - bool recurse{finalize && parentType && !parentType->noDestructionNeeded()}; for (auto k{recurse ? std::size_t{1} /* skip first component, it's the parent */ : 0}; @@ -186,20 +173,18 @@ if (comp.genre() == typeInfo::Component::Genre::Allocatable || comp.genre() == typeInfo::Component::Genre::Automatic) { if (const typeInfo::DerivedType * compType{comp.derivedType()}) { - if (!compType->noDestructionNeeded()) { + if (!compType->noFinalizationNeeded()) { for (std::size_t j{0}; j < elements; ++j) { - Destroy(*descriptor.OffsetElement( - j * byteStride + comp.offset()), - finalize, *compType); + const Descriptor &compDesc{*descriptor.OffsetElement( + j * byteStride + comp.offset())}; + if (compDesc.IsAllocated()) { + Finalize(compDesc, *compType); + } } } } - for (std::size_t j{0}; j < elements; ++j) { - descriptor.OffsetElement(j * byteStride + comp.offset()) - ->Deallocate(); - } } else if (comp.genre() == typeInfo::Component::Genre::Data && - comp.derivedType() && !comp.derivedType()->noDestructionNeeded()) { + comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) { SubscriptValue extent[maxRank]; const typeInfo::Value *bounds{comp.bounds()}; for (int dim{0}; dim < comp.rank(); ++dim) { @@ -213,15 +198,41 @@ compDesc.Establish(compType, descriptor.OffsetElement(j * byteStride + comp.offset()), comp.rank(), extent); - Destroy(compDesc, finalize, compType); + Finalize(compDesc, compType); } } } if (recurse) { - Destroy(descriptor, finalize, *parentType); + Finalize(descriptor, *parentType); } } -// TODO: Assign() +// The order of finalization follows Fortran 2018 7.5.6.2, with +// elementwise deallocation of non-parent components (and their consequent +// finalizations) taking place before parent component finalization. +void Destroy(const Descriptor &descriptor, bool finalize, + const typeInfo::DerivedType &derived) { + if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) { + return; + } + if (finalize && !derived.noFinalizationNeeded()) { + Finalize(descriptor, derived); + } + const Descriptor &componentDesc{derived.component()}; + std::size_t myComponents{componentDesc.Elements()}; + std::size_t elements{descriptor.Elements()}; + std::size_t byteStride{descriptor.ElementBytes()}; + for (std::size_t k{0}; k < myComponents; ++k) { + const auto &comp{ + *componentDesc.ZeroBasedIndexedElement(k)}; + 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()) + ->Deallocate(); + } + } + } +} } // namespace Fortran::runtime Index: flang/runtime/type-info.h =================================================================== --- flang/runtime/type-info.h +++ flang/runtime/type-info.h @@ -13,7 +13,9 @@ // flang/module/__fortran_type_info.f90. #include "descriptor.h" +#include "terminator.h" #include "flang/Common/Fortran.h" +#include "flang/Common/bit-population-count.h" #include #include #include @@ -118,19 +120,23 @@ public: enum class Which : std::uint8_t { None = 0, - Assignment = 4, - ElementalAssignment = 5, - Final = 8, - ElementalFinal = 9, - AssumedRankFinal = 10, - ReadFormatted = 16, - ReadUnformatted = 17, - WriteFormatted = 18, - WriteUnformatted = 19 + ScalarAssignment = 1, + ElementalAssignment = 2, + ReadFormatted = 3, + ReadUnformatted = 4, + WriteFormatted = 5, + WriteUnformatted = 6, + ElementalFinal = 7, + AssumedRankFinal = 8, + ScalarFinal = 9, + // higher-ranked final procedures follow }; + static constexpr Which RankFinal(int rank) { + return static_cast(static_cast(Which::ScalarFinal) + rank); + } + Which which() const { return which_; } - int rank() const { return rank_; } bool IsArgDescriptor(int zeroBasedArg) const { return (isArgDescriptorSet_ >> zeroBasedArg) & 1; } @@ -143,12 +149,6 @@ private: Which which_{Which::None}; - // Used for Which::Final only. Which::Assignment always has rank 0, as - // type-bound defined assignment for rank > 0 must be elemental - // due to the required passed object dummy argument, which are scalar. - // User defined derived type I/O is always scalar. - std::uint8_t rank_{0}; - // The following little bit-set identifies which dummy arguments are // passed via descriptors for their derived type arguments. // Which::Assignment and Which::ElementalAssignment: @@ -175,6 +175,7 @@ // When false, the user derived type I/O subroutine must have been // called via a generic interface, not a generic TBP. std::uint8_t isArgDescriptorSet_{0}; + std::uint8_t __padding0_[6]; ProcedurePointer proc_{nullptr}; }; @@ -186,7 +187,6 @@ const Descriptor &binding() const { return binding_.descriptor(); } const Descriptor &name() const { return name_.descriptor(); } std::uint64_t sizeInBytes() const { return sizeInBytes_; } - std::uint64_t typeHash() const { return typeHash_; } const Descriptor &uninstatiated() const { return uninstantiated_.descriptor(); } @@ -202,6 +202,7 @@ bool hasParent() const { return hasParent_; } bool noInitializationNeeded() const { return noInitializationNeeded_; } bool noDestructionNeeded() const { return noDestructionNeeded_; } + bool noFinalizationNeeded() const { return noFinalizationNeeded_; } std::size_t LenParameters() const { return lenParameterKind().Elements(); } @@ -211,7 +212,24 @@ const Component *FindDataComponent( const char *name, std::size_t nameLen) const; - const SpecialBinding *FindSpecialBinding(SpecialBinding::Which) const; + // O(1) look-up of special procedure bindings + const SpecialBinding *FindSpecialBinding(SpecialBinding::Which which) const { + auto bitIndex{static_cast(which)}; + auto bit{std::uint32_t{1} << bitIndex}; + if (specialBitSet_ & bit) { + // The index of this special procedure in the sorted array is the + // number of special bindings that are present with smaller "which" + // code values. + int offset{common::BitPopulationCount(specialBitSet_ & (bit - 1))}; + const auto *binding{ + special_.descriptor().ZeroBasedIndexedElement( + offset)}; + INTERNAL_CHECK(binding && binding->which() == which); + return binding; + } else { + return nullptr; + } + } FILE *Dump(FILE * = stdout) const; @@ -235,9 +253,6 @@ // no KIND type parameters will have a null pointer here. 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}; - // 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> @@ -253,13 +268,21 @@ StaticDescriptor<1, true> procPtr_; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS + // Packed in ascending order of "which" code values. // Does not include special bindings from ancestral types. StaticDescriptor<1, true> special_; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS + // Little-endian bit-set of special procedure binding "which" code values + // for O(1) look-up in FindSpecialBinding() above. + std::uint32_t specialBitSet_{0}; + + // Flags bool hasParent_{false}; bool noInitializationNeeded_{false}; bool noDestructionNeeded_{false}; + bool noFinalizationNeeded_{false}; + bool __padding0_[4]; }; } // namespace Fortran::runtime::typeInfo Index: flang/runtime/type-info.cpp =================================================================== --- flang/runtime/type-info.cpp +++ flang/runtime/type-info.cpp @@ -153,21 +153,6 @@ return parent ? parent->FindDataComponent(compName, compNameLen) : nullptr; } -const SpecialBinding *DerivedType::FindSpecialBinding( - SpecialBinding::Which which) const { - const Descriptor &specialDesc{special()}; - std::size_t n{specialDesc.Elements()}; - SubscriptValue at[maxRank]; - specialDesc.GetLowerBounds(at); - for (std::size_t j{0}; j < n; ++j, specialDesc.IncrementSubscripts(at)) { - const SpecialBinding &special{*specialDesc.Element(at)}; - if (special.which() == which) { - return &special; - } - } - return nullptr; -} - static void DumpScalarCharacter( FILE *f, const Descriptor &desc, const char *what) { if (desc.raw().version == CFI_VERSION && @@ -198,8 +183,6 @@ std::fputs(" <-- sizeInBytes_\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_)) { @@ -210,12 +193,10 @@ std::fputs(" <-- procPtr_\n", f); } else if (offset == offsetof(DerivedType, special_)) { std::fputs(" <-- special_\n", f); - } else if (offset == offsetof(DerivedType, special_)) { - std::fputs(" <-- special_\n", f); + } else if (offset == offsetof(DerivedType, specialBitSet_)) { + std::fputs(" <-- specialBitSet_\n", f); } else if (offset == offsetof(DerivedType, hasParent_)) { - std::fputs( - " <-- hasParent_, noInitializationNeeded_, noDestructionNeeded_\n", - f); + std::fputs(" <-- (flags)\n", f); } else { std::fputc('\n', f); } @@ -286,21 +267,12 @@ std::fprintf( f, "SpecialBinding @ 0x%p:\n", reinterpret_cast(this)); switch (which_) { - case Which::Assignment: - std::fputs(" Assignment", f); + case Which::ScalarAssignment: + std::fputs(" ScalarAssignment", f); break; case Which::ElementalAssignment: std::fputs(" ElementalAssignment", f); break; - case Which::Final: - std::fputs(" Final", f); - break; - case Which::ElementalFinal: - std::fputs(" ElementalFinal", f); - break; - case Which::AssumedRankFinal: - std::fputs(" AssumedRankFinal", f); - break; case Which::ReadFormatted: std::fputs(" ReadFormatted", f); break; @@ -313,12 +285,17 @@ case Which::WriteUnformatted: std::fputs(" WriteUnformatted", f); break; + case Which::ElementalFinal: + std::fputs(" ElementalFinal", f); + break; + case Which::AssumedRankFinal: + std::fputs(" AssumedRankFinal", f); + break; default: - std::fprintf( - f, " Unknown which: 0x%x", static_cast(which_)); + std::fprintf(f, " rank-%d final:", + static_cast(which_) - static_cast(Which::ScalarFinal)); break; } - std::fprintf(f, "\n rank: %d\n", rank_); std::fprintf(f, " isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_); std::fprintf(f, " proc: 0x%p\n", reinterpret_cast(proc_)); return f; Index: flang/test/Semantics/typeinfo01.f90 =================================================================== --- flang/test/Semantics/typeinfo01.f90 +++ flang/test/Semantics/typeinfo01.f90 @@ -7,7 +7,7 @@ end type !CHECK: Module scope: m01 !CHECK: .c.t1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.n,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.t1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) +!CHECK: .dt.t1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) !CHECK: .n.n, SAVE, TARGET: ObjectEntity type: CHARACTER(1_8,1) init:"n" !CHECK: .n.t1, SAVE, TARGET: ObjectEntity type: CHARACTER(2_8,1) init:"t1" !CHECK: DerivedType scope: t1 @@ -22,8 +22,8 @@ end type !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,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL(),hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1) -!CHECK: .dt.parent, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) +!CHECK: .dt.child, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.child,sizeinbytes=8_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.parent, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) end module module m03 @@ -34,7 +34,7 @@ type(kpdt(4)) :: x !CHECK: .c.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.a,genre=1_1,category=1_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.kpdt, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.kpdt,uninstantiated=NULL(),kindparameter=.kp.kpdt,lenparameterkind=NULL()) -!CHECK: .dt.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.0,lenparameterkind=NULL(),component=.c.kpdt.0,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) +!CHECK: .dt.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.0,lenparameterkind=NULL(),component=.c.kpdt.0,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) !CHECK: .kp.kpdt, SAVE, TARGET: ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::1_8] !CHECK: .kp.kpdt.0, SAVE, TARGET: ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::4_8] end module @@ -49,7 +49,7 @@ subroutine s1(x) class(tbps), intent(in) :: x end subroutine -!CHECK: .dt.tbps, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.tbps,name=.n.tbps,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) +!CHECK: .dt.tbps, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.tbps,name=.n.tbps,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) !CHECK: .v.tbps, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=s1,name=.n.b1),binding(proc=s1,name=.n.b2)] end module @@ -61,7 +61,7 @@ subroutine s1(x) class(t), intent(in) :: x end subroutine -!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=24_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL(),hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=24_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) !CHECK: .p.t, SAVE, TARGET: ObjectEntity type: TYPE(procptrcomponent) shape: 0_8:0_8 init:[procptrcomponent::procptrcomponent(name=.n.p1,offset=0_8,initialization=s1)] end module @@ -85,9 +85,9 @@ class(t), intent(in) :: y end subroutine !CHECK: .c.t2, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.t,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.t,lenvalue=NULL(),bounds=NULL(),initialization=NULL())] -!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) -!CHECK: .dt.t2, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1) -!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=4_1,rank=0_1,isargdescriptorset=3_1,proc=s1)] +!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t2, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,proc=s1)] !CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)] !CHECK: .v.t2, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s2,name=.n.s1)] end module @@ -103,8 +103,8 @@ class(t), intent(out) :: x class(t), intent(in) :: y end subroutine -!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) -!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,rank=0_1,isargdescriptorset=3_1,proc=s1)] +!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=4_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,proc=s1)] !CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)] end module @@ -123,8 +123,8 @@ impure elemental subroutine s3(x) type(t) :: x end subroutine -!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1) -!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=8_1,rank=1_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=8_1,rank=2_1,isargdescriptorset=0_1,proc=s2),specialbinding(which=9_1,rank=0_1,isargdescriptorset=0_1,proc=s3)] +!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=3200_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) +!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,proc=s2)] end module module m09 @@ -165,8 +165,8 @@ integer, intent(out) :: iostat character(len=*), intent(inout) :: iomsg end subroutine -!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) -!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=16_1,rank=0_1,isargdescriptorset=1_1,proc=rf),specialbinding(which=17_1,rank=0_1,isargdescriptorset=1_1,proc=ru),specialbinding(which=18_1,rank=0_1,isargdescriptorset=1_1,proc=wf),specialbinding(which=19_1,rank=0_1,isargdescriptorset=1_1,proc=wu)] +!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,proc=wu)] !CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:3_8 init:[binding::binding(proc=rf,name=.n.rf),binding(proc=ru,name=.n.ru),binding(proc=wf,name=.n.wf),binding(proc=wu,name=.n.wu)] end module @@ -214,8 +214,8 @@ integer, intent(out) :: iostat character(len=*), intent(inout) :: iomsg end subroutine -!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1) -!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=16_1,rank=0_1,isargdescriptorset=0_1,proc=rf),specialbinding(which=17_1,rank=0_1,isargdescriptorset=0_1,proc=ru),specialbinding(which=18_1,rank=0_1,isargdescriptorset=0_1,proc=wf),specialbinding(which=19_1,rank=0_1,isargdescriptorset=0_1,proc=wu)] +!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,proc=wu)] end module module m11 @@ -235,7 +235,7 @@ !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=.di.t.1.pointer),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: .di.t.1.pointer, SAVE, TARGET: ObjectEntity type: TYPE(.dp.t.1.pointer) init:.dp.t.1.pointer(pointer=target) !CHECK: .dp.t.1.pointer: DerivedType components: pointer -!CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL(),hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1) +!CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1) !CHECK: .lpk.t.1, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1] !CHECK: DerivedType scope: .dp.t.1.pointer size=24 alignment=8 instantiation of .dp.t.1.pointer !CHECK: pointer, POINTER size=24 offset=0: ObjectEntity type: REAL(4)