From a48e41683ae1a9b9a5bde750d3b418a205c28cc8 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Mon, 19 Jul 2021 11:53:20 -0700 Subject: [PATCH] [flang] Run-time derived type initialization and destruction Use derived type information tables to drive default component initialization (when needed), component destruction, and calls to final subroutines. Perform these operations automatically for ALLOCATE()/DEALLOCATE() APIs for allocatables, automatics, and pointers. Add APIs for use in lowering to perform these operations for non-allocatable/automatic non-pointer variables. Data pointer component initialization supports arbitrary constant designators, a F'2008 feature, which may be a first for Fortran implementations. Differential Revision: https://reviews.llvm.org/D106297 --- flang/docs/Extensions.md | 10 ++ flang/include/flang/Semantics/tools.h | 2 + flang/include/flang/Semantics/type.h | 1 + flang/lib/Evaluate/shape.cpp | 2 +- flang/lib/Evaluate/tools.cpp | 6 +- flang/lib/Semantics/check-declarations.cpp | 6 +- flang/lib/Semantics/compute-offsets.cpp | 12 +-- flang/lib/Semantics/resolve-names.cpp | 3 + flang/lib/Semantics/runtime-type-info.cpp | 147 ++++++++++++++++++++++------- flang/lib/Semantics/tools.cpp | 17 ++++ flang/lib/Semantics/type.cpp | 65 +++++++++---- flang/module/__fortran_type_info.f90 | 9 +- flang/runtime/CMakeLists.txt | 1 + flang/runtime/allocatable.cpp | 33 ++++++- flang/runtime/allocatable.h | 6 +- flang/runtime/derived-api.cpp | 45 +++++++++ flang/runtime/derived-api.h | 43 +++++++++ flang/runtime/derived.cpp | 146 +++++++++++++++++++++++++--- flang/runtime/derived.h | 21 ++++- flang/runtime/descriptor-io.h | 2 +- flang/runtime/descriptor.cpp | 30 +++--- flang/runtime/descriptor.h | 18 ++-- flang/runtime/namelist.cpp | 2 +- flang/runtime/pointer.cpp | 17 +++- flang/runtime/type-info.cpp | 105 ++++++++++++++++++--- flang/runtime/type-info.h | 28 +++++- flang/test/Semantics/call10.f90 | 2 +- flang/test/Semantics/offsets01.f90 | 4 +- flang/test/Semantics/typeinfo01.f90 | 36 +++---- 29 files changed, 668 insertions(+), 151 deletions(-) create mode 100644 flang/runtime/derived-api.cpp create mode 100644 flang/runtime/derived-api.h diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 87dcb0c..e55be8b 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -223,3 +223,13 @@ accepted if enabled by command-line options. from `COS(3.14159)`, for example. f18 will complain when a generic intrinsic function's inferred result type does not match an explicit declaration. This message is a warning. + +## Standard features that might as well not be + +* f18 supports designators with constant expressions, properly + constrained, as initial data targets for data pointers in + initializers of variable and component declarations and in + `DATA` statements; e.g., `REAL, POINTER :: P => T(1:10:2)`. + This Fortran 2008 feature might as well be viewed like an + extension; no other compiler that we've tested can handle + it yet. diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index 776594e..9b1a431 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -113,6 +113,8 @@ bool IsStaticallyInitialized(const Symbol &, bool ignoreDATAstatements = false); // Is the symbol explicitly or implicitly initialized in any way? bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false, const Symbol *derivedType = nullptr); +// Is the symbol a component subject to deallocation or finalization? +bool IsDestructible(const Symbol &, const Symbol *derivedType = nullptr); bool HasIntrinsicTypeName(const Symbol &); bool IsSeparateModuleProcedureInterface(const Symbol *); bool IsAutomatic(const Symbol &); diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h index 764b659..4406818 100644 --- a/flang/include/flang/Semantics/type.h +++ b/flang/include/flang/Semantics/type.h @@ -257,6 +257,7 @@ public: bool MightBeParameterized() const; bool IsForwardReferenced() const; bool HasDefaultInitialization() const; + bool HasDestruction() const; // The "raw" type parameter list is a simple transcription from the // parameter list in the parse tree, built by calling AddRawParamValue(). diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index 988d11e..7e8158d 100644 --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -226,7 +226,7 @@ bool ContainsAnyImpliedDoIndex(const ExtentExpr &expr) { // Determines lower bound on a dimension. This can be other than 1 only // for a reference to a whole array object or component. (See LBOUND, 16.9.109). -// ASSOCIATE construct entities may require tranversal of their referents. +// ASSOCIATE construct entities may require traversal of their referents. class GetLowerBoundHelper : public Traverse { public: using Result = ExtentExpr; diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 7b21893..80b1cda 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1107,10 +1107,12 @@ bool IsSaved(const Symbol &original) { return false; // ASSOCIATE(non-variable) } else if (scopeKind == Scope::Kind::Module) { return true; // BLOCK DATA entities must all be in COMMON, handled below - } else if (symbol.attrs().test(Attr::SAVE)) { - return true; } else if (scopeKind == Scope::Kind::DerivedType) { return false; // this is a component + } else if (symbol.attrs().test(Attr::SAVE)) { + return true; + } else if (symbol.test(Symbol::Flag::InDataStmt)) { + return true; } else if (IsNamedConstant(symbol)) { return false; } else if (const auto *object{symbol.detailsIf()}; diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index b57d19b..e27000d 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -329,12 +329,14 @@ void CheckHelper::Check(const Symbol &symbol) { messages_.Say( "A dummy argument may not also be a named constant"_err_en_US); } - if (IsSaved(symbol)) { + if (!symbol.test(Symbol::Flag::InDataStmt) /*caught elsewhere*/ && + IsSaved(symbol)) { messages_.Say( "A dummy argument may not have the SAVE attribute"_err_en_US); } } else if (IsFunctionResult(symbol)) { - if (IsSaved(symbol)) { + if (!symbol.test(Symbol::Flag::InDataStmt) /*caught elsewhere*/ && + IsSaved(symbol)) { messages_.Say( "A function result may not have the SAVE attribute"_err_en_US); } diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp index 4b1538c..2ceb8f4 100644 --- a/flang/lib/Semantics/compute-offsets.cpp +++ b/flang/lib/Semantics/compute-offsets.cpp @@ -304,13 +304,11 @@ auto ComputeOffsetsHelper::GetSizeAndAlignment( // of length type parameters). auto &foldingContext{context_.foldingContext()}; if (IsDescriptor(symbol) || IsProcedurePointer(symbol)) { - int lenParams{0}; - if (const auto *derived{evaluate::GetDerivedTypeSpec( - evaluate::DynamicType::From(symbol))}) { - lenParams = CountLenParameters(*derived); - } - std::size_t size{ - runtime::Descriptor::SizeInBytes(symbol.Rank(), false, lenParams)}; + const auto *derived{ + evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(symbol))}; + int lenParams{derived ? CountLenParameters(*derived) : 0}; + std::size_t size{runtime::Descriptor::SizeInBytes( + symbol.Rank(), derived != nullptr, lenParams)}; return {size, foldingContext.maxAlignment()}; } if (IsProcedure(symbol)) { diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 7fa3dee..b7db7d4 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3986,6 +3986,9 @@ void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) { currScope().IsParameterizedDerivedType()) { // Defer instantiation; use the derived type's definition's scope. derived.set_scope(DEREF(spec->typeSymbol().scope())); + } else if (&currScope() == spec->typeSymbol().scope()) { + // Direct recursive use of a type in the definition of one of its + // components: defer instantiation } else { auto restorer{ GetFoldingContext().messages().SetLocation(currStmtSource().value())}; diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp index f336117..cb833cf 100644 --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -38,7 +38,7 @@ static int FindLenParameterIndex( class RuntimeTableBuilder { public: RuntimeTableBuilder(SemanticsContext &, RuntimeDerivedTypeTables &); - void DescribeTypes(Scope &scope); + void DescribeTypes(Scope &scope, bool inSchemata); private: const Symbol *DescribeType(Scope &); @@ -58,6 +58,9 @@ private: const std::string &distinctName, const SymbolVector *parameters); evaluate::StructureConstructor DescribeComponent( const Symbol &, const ProcEntityDetails &, Scope &); + bool InitializeDataPointer(evaluate::StructureConstructorValues &, + const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope, + Scope &dtScope, const std::string &distinctName); evaluate::StructureConstructor PackageIntValue( const SomeExpr &genre, std::int64_t = 0) const; SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const; @@ -132,6 +135,7 @@ private: SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted parser::CharBlock location_; + std::set ignoreScopes_; }; RuntimeTableBuilder::RuntimeTableBuilder( @@ -152,18 +156,21 @@ RuntimeTableBuilder::RuntimeTableBuilder( readFormattedEnum_{GetEnumValue("readformatted")}, readUnformattedEnum_{GetEnumValue("readunformatted")}, writeFormattedEnum_{GetEnumValue("writeformatted")}, - writeUnformattedEnum_{GetEnumValue("writeunformatted")} {} + writeUnformattedEnum_{GetEnumValue("writeunformatted")} { + ignoreScopes_.insert(tables_.schemata); +} -void RuntimeTableBuilder::DescribeTypes(Scope &scope) { - if (&scope == tables_.schemata) { - return; // don't loop trying to describe a schema... - } +void RuntimeTableBuilder::DescribeTypes(Scope &scope, bool inSchemata) { + inSchemata |= ignoreScopes_.find(&scope) != ignoreScopes_.end(); if (scope.IsDerivedType()) { - DescribeType(scope); - } else { - for (Scope &child : scope.children()) { - DescribeTypes(child); + if (!inSchemata) { // don't loop trying to describe a schema + DescribeType(scope); } + } else { + scope.InstantiateDerivedTypes(); + } + for (Scope &child : scope.children()) { + DescribeTypes(child, inSchemata); } } @@ -314,11 +321,29 @@ static SomeExpr SaveObjectInit( evaluate::Designator{symbol}); } +template static SomeExpr IntExpr(std::int64_t n) { + return evaluate::AsGenericExpr( + evaluate::Constant>{n}); +} + const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { if (const Symbol * info{dtScope.runtimeDerivedTypeDescription()}) { return info; } const DerivedTypeSpec *derivedTypeSpec{dtScope.derivedTypeSpec()}; + if (!derivedTypeSpec && !dtScope.IsParameterizedDerivedType() && + dtScope.symbol()) { + // This derived type was declared (obviously, there's a Scope) but never + // used in this compilation (no instantiated DerivedTypeSpec points here). + // Create a DerivedTypeSpec now for it so that ComponentIterator + // will work. This covers the case of a derived type that's declared in + // a module but used only by clients and submodules, enabling the + // run-time "no initialization needed here" flag to work. + DerivedTypeSpec derived{dtScope.symbol()->name(), *dtScope.symbol()}; + DeclTypeSpec &decl{ + dtScope.MakeDerivedType(DeclTypeSpec::TypeDerived, std::move(derived))}; + derivedTypeSpec = &decl.derivedTypeSpec(); + } const Symbol *dtSymbol{ derivedTypeSpec ? &derivedTypeSpec->typeSymbol() : dtScope.symbol()}; if (!dtSymbol) { @@ -361,18 +386,6 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { AddValue( dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes)); } - const Symbol *parentDescObject{nullptr}; - if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) { - parentDescObject = DescribeType(*const_cast(parentScope)); - } - if (parentDescObject) { - AddValue(dtValues, derivedTypeSchema_, "parent"s, - evaluate::AsGenericExpr(evaluate::Expr{ - evaluate::Designator{*parentDescObject}})); - } else { - AddValue(dtValues, derivedTypeSchema_, "parent"s, - SomeExpr{evaluate::NullPointer{}}); - } bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()}; if (isPDTinstantiation) { // is PDT instantiation @@ -518,6 +531,18 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { std::move(specials), evaluate::ConstantSubscripts{ static_cast(specials.size())})); + // Note the presence/absence of a parent component + AddValue(dtValues, derivedTypeSchema_, "hasparent"s, + IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr)); + // To avoid wasting run time attempting to initialize derived type + // instances without any initialized components, analyze the type + // and set a flag if there's nothing to do for it at run time. + AddValue(dtValues, derivedTypeSchema_, "noinitializationneeded"s, + IntExpr<1>( + derivedTypeSpec && !derivedTypeSpec->HasDefaultInitialization())); + // Similarly, a flag to short-circuit destruction when not needed. + AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s, + IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction())); } dtObject.get().set_init(MaybeExpr{ StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))}); @@ -563,11 +588,6 @@ const DeclTypeSpec &RuntimeTableBuilder::GetSchema( return *spec; } -template static SomeExpr IntExpr(std::int64_t n) { - return evaluate::AsGenericExpr( - evaluate::Constant>{n}); -} - SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const { const Symbol &symbol{GetSchemaSymbol(name)}; auto value{evaluate::ToInt64(symbol.get().init())}; @@ -723,11 +743,8 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent( AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable")); } else if (IsPointer(symbol)) { AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer")); - hasDataInit = object.init().has_value(); - if (hasDataInit) { - AddValue(values, componentSchema_, "initialization"s, - SomeExpr{*object.init()}); - } + hasDataInit = InitializeDataPointer( + values, symbol, object, scope, dtScope, distinctName); } else if (IsAutomaticObject(symbol)) { AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic")); } else { @@ -764,6 +781,70 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent( return {DEREF(procPtrSchema_.AsDerived()), std::move(values)}; } +// Create a static pointer object with the same initialization +// from whence the runtime can memcpy() the data pointer +// component initialization. +// Creates and interconnects the symbols, scopes, and types for +// TYPE :: ptrDt +// type, POINTER :: name +// END TYPE +// TYPE(ptrDt), TARGET, SAVE :: ptrInit = ptrDt(designator) +// and then initializes the original component by setting +// initialization = ptrInit +// which takes the address of ptrInit because the type is C_PTR. +// This technique of wrapping the data pointer component into +// a derived type instance disables any reason for lowering to +// attempt to dereference the RHS of an initializer, thereby +// allowing the runtime to actually perform the initialization +// by means of a simple memcpy() of the wrapped descriptor in +// ptrInit to the data pointer component being initialized. +bool RuntimeTableBuilder::InitializeDataPointer( + evaluate::StructureConstructorValues &values, const Symbol &symbol, + const ObjectEntityDetails &object, Scope &scope, Scope &dtScope, + const std::string &distinctName) { + if (object.init().has_value()) { + SourceName ptrDtName{SaveObjectName( + ".dp."s + distinctName + "."s + symbol.name().ToString())}; + Symbol &ptrDtSym{ + *scope.try_emplace(ptrDtName, Attrs{}, UnknownDetails{}).first->second}; + Scope &ptrDtScope{scope.MakeScope(Scope::Kind::DerivedType, &ptrDtSym)}; + ignoreScopes_.insert(&ptrDtScope); + ObjectEntityDetails ptrDtObj; + ptrDtObj.set_type(DEREF(object.type())); + ptrDtObj.set_shape(object.shape()); + Symbol &ptrDtComp{*ptrDtScope + .try_emplace(symbol.name(), Attrs{Attr::POINTER}, + std::move(ptrDtObj)) + .first->second}; + DerivedTypeDetails ptrDtDetails; + ptrDtDetails.add_component(ptrDtComp); + ptrDtSym.set_details(std::move(ptrDtDetails)); + ptrDtSym.set_scope(&ptrDtScope); + DeclTypeSpec &ptrDtDeclType{ + scope.MakeDerivedType(DeclTypeSpec::Category::TypeDerived, + DerivedTypeSpec{ptrDtName, ptrDtSym})}; + DerivedTypeSpec &ptrDtDerived{DEREF(ptrDtDeclType.AsDerived())}; + ptrDtDerived.set_scope(ptrDtScope); + ptrDtDerived.CookParameters(context_.foldingContext()); + ptrDtDerived.Instantiate(scope); + ObjectEntityDetails ptrInitObj; + ptrInitObj.set_type(ptrDtDeclType); + evaluate::StructureConstructorValues ptrInitValues; + AddValue( + ptrInitValues, ptrDtDeclType, symbol.name().ToString(), *object.init()); + ptrInitObj.set_init(evaluate::AsGenericExpr( + Structure(ptrDtDeclType, std::move(ptrInitValues)))); + AddValue(values, componentSchema_, "initialization"s, + SaveObjectInit(scope, + SaveObjectName( + ".di."s + distinctName + "."s + symbol.name().ToString()), + ptrInitObj)); + return true; + } else { + return false; + } +} + evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue( const SomeExpr &genre, std::int64_t n) const { evaluate::StructureConstructorValues xs; @@ -961,7 +1042,7 @@ RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables( result.schemata = reader.Read(schemataModule); if (result.schemata) { RuntimeTableBuilder builder{context, result}; - builder.DescribeTypes(context.globalScope()); + builder.DescribeTypes(context.globalScope(), false); } return result; } diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index e84629b..feb07f7 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -602,6 +602,23 @@ bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements, return false; } +bool IsDestructible(const Symbol &symbol, const Symbol *derivedTypeSymbol) { + if (IsAllocatable(symbol) || IsAutomatic(symbol)) { + return true; + } else if (IsNamedConstant(symbol) || IsFunctionResult(symbol) || + IsPointer(symbol)) { + return false; + } else if (const auto *object{symbol.detailsIf()}) { + if (!object->isDummy() && object->type()) { + if (const auto *derived{object->type()->AsDerived()}) { + return &derived->typeSymbol() != derivedTypeSymbol && + derived->HasDestruction(); + } + } + } + return false; +} + bool HasIntrinsicTypeName(const Symbol &symbol) { std::string name{symbol.name().ToString()}; if (name == "doubleprecision") { diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index 81a87c3..dc9be00 100644 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -185,6 +185,17 @@ bool DerivedTypeSpec::HasDefaultInitialization() const { })}; } +bool DerivedTypeSpec::HasDestruction() const { + if (!typeSymbol().get().finals().empty()) { + return true; + } + DirectComponentIterator components{*this}; + return bool{std::find_if( + components.begin(), components.end(), [&](const Symbol &component) { + return IsDestructible(component, &typeSymbol()); + })}; +} + ParamValue *DerivedTypeSpec::FindParameter(SourceName target) { return const_cast( const_cast(this)->FindParameter(target)); @@ -233,6 +244,34 @@ static int PlumbPDTInstantiationDepth(const Scope *scope) { return depth; } +// Completes component derived type instantiation and initializer folding +// for a non-parameterized derived type Scope. +static void InstantiateNonPDTScope(Scope &typeScope, Scope &containingScope) { + auto &context{containingScope.context()}; + auto &foldingContext{context.foldingContext()}; + for (auto &pair : typeScope) { + Symbol &symbol{*pair.second}; + if (DeclTypeSpec * type{symbol.GetType()}) { + if (DerivedTypeSpec * derived{type->AsDerived()}) { + if (!(derived->IsForwardReferenced() && + IsAllocatableOrPointer(symbol))) { + derived->Instantiate(containingScope); + } + } + } + if (!IsPointer(symbol)) { + if (auto *object{symbol.detailsIf()}) { + if (MaybeExpr & init{object->init()}) { + auto restorer{foldingContext.messages().SetLocation(symbol.name())}; + init = evaluate::NonPointerInitializationExpr( + symbol, std::move(*init), foldingContext); + } + } + } + } + ComputeOffsets(context, typeScope); +} + void DerivedTypeSpec::Instantiate(Scope &containingScope) { if (instantiated_) { return; @@ -251,27 +290,13 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) { const Scope &typeScope{DEREF(typeSymbol_.scope())}; if (!MightBeParameterized()) { scope_ = &typeScope; - for (auto &pair : typeScope) { - Symbol &symbol{*pair.second}; - if (DeclTypeSpec * type{symbol.GetType()}) { - if (DerivedTypeSpec * derived{type->AsDerived()}) { - if (!(derived->IsForwardReferenced() && - IsAllocatableOrPointer(symbol))) { - derived->Instantiate(containingScope); - } - } - } - if (!IsPointer(symbol)) { - if (auto *object{symbol.detailsIf()}) { - if (MaybeExpr & init{object->init()}) { - auto restorer{foldingContext.messages().SetLocation(symbol.name())}; - init = evaluate::NonPointerInitializationExpr( - symbol, std::move(*init), foldingContext); - } - } - } + if (typeScope.derivedTypeSpec()) { + CHECK(*this == *typeScope.derivedTypeSpec()); + } else { + Scope &mutableTypeScope{const_cast(typeScope)}; + mutableTypeScope.set_derivedTypeSpec(*this); + InstantiateNonPDTScope(mutableTypeScope, containingScope); } - ComputeOffsets(context, const_cast(typeScope)); return; } // New PDT instantiation. Create a new scope and populate it diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90 index c2a9ed1..dcdc561 100644 --- a/flang/module/__fortran_type_info.f90 +++ b/flang/module/__fortran_type_info.f90 @@ -33,19 +33,22 @@ module __Fortran_type_info type(Binding), pointer, contiguous :: binding(:) character(len=:), pointer :: name integer(kind=int64) :: sizeInBytes - type(DerivedType), pointer :: parent ! 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 alphabetic order. - ! The parent component, if any, appears explicitly. + ! Data components appear in component order. + ! The parent component, if any, appears explicitly and first. type(Component), pointer, contiguous :: component(:) ! data components type(ProcPtrComponent), pointer, contiguous :: procptr(:) ! procedure pointers ! Special bindings of the ancestral types are not duplicated here. type(SpecialBinding), pointer, contiguous :: special(:) + 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) end type type :: Binding diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt index 69f68e43..971ce90 100644 --- a/flang/runtime/CMakeLists.txt +++ b/flang/runtime/CMakeLists.txt @@ -39,6 +39,7 @@ add_flang_library(FortranRuntime character.cpp connection.cpp derived.cpp + derived-api.cpp descriptor.cpp descriptor-io.cpp dot-product.cpp diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp index ffdee67..9416590 100644 --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -7,8 +7,10 @@ //===----------------------------------------------------------------------===// #include "allocatable.h" +#include "derived.h" #include "stat.h" #include "terminator.h" +#include "type-info.h" namespace Fortran::runtime { extern "C" { @@ -36,13 +38,13 @@ void RTNAME(AllocatableInitDerived)(Descriptor &descriptor, } void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) { - INTERNAL_CHECK(false); // AllocatableAssign is not yet implemented + 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*/) { - INTERNAL_CHECK(false); // MoveAlloc is not yet implemented + INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented return StatOk; } @@ -76,8 +78,17 @@ int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, if (descriptor.IsAllocated()) { return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat); } - return ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat); - // TODO: default component initialization + int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)}; + if (stat == StatOk) { + if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { + if (const auto *derived{addendum->derivedType()}) { + if (!derived->noInitializationNeeded()) { + stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg); + } + } + } + } + return stat; } int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, @@ -89,7 +100,19 @@ int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, if (!descriptor.IsAllocated()) { return ReturnError(terminator, StatBaseNull, errMsg, hasStat); } - return ReturnError(terminator, descriptor.Deallocate(), errMsg, hasStat); + return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat); +} + +void RTNAME(AllocatableDeallocateNoFinal)( + Descriptor &descriptor, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + if (!descriptor.IsAllocatable()) { + ReturnError(terminator, StatInvalidDescriptor); + } else if (!descriptor.IsAllocated()) { + ReturnError(terminator, StatBaseNull); + } else { + ReturnError(terminator, descriptor.Destroy(false)); + } } // TODO: AllocatableCheckLengthParameter, AllocatableAllocateSource diff --git a/flang/runtime/allocatable.h b/flang/runtime/allocatable.h index cd2c566..91c58c6 100644 --- a/flang/runtime/allocatable.h +++ b/flang/runtime/allocatable.h @@ -112,6 +112,10 @@ int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor &from, int RTNAME(AllocatableDeallocate)(Descriptor &, bool hasStat = false, const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, int sourceLine = 0); -} + +// Variant of above that does not finalize; for intermediate results +void RTNAME(AllocatableDeallocateNoFinal)( + Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0); +} // extern "C" } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_ALLOCATABLE_H_ diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp new file mode 100644 index 0000000..98a0096 --- /dev/null +++ b/flang/runtime/derived-api.cpp @@ -0,0 +1,45 @@ +//===-- runtime/derived-api.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 "derived-api.h" +#include "derived.h" +#include "descriptor.h" +#include "terminator.h" +#include "type-info.h" + +namespace Fortran::runtime { + +extern "C" { + +void RTNAME(Initialize)( + const Descriptor &descriptor, const char *sourceFile, int sourceLine) { + if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { + if (const auto *derived{addendum->derivedType()}) { + if (!derived->noInitializationNeeded()) { + Terminator terminator{sourceFile, sourceLine}; + Initialize(descriptor, *derived, terminator); + } + } + } +} + +void RTNAME(Destroy)(const Descriptor &descriptor) { + if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { + if (const auto *derived{addendum->derivedType()}) { + if (!derived->noDestructionNeeded()) { + Destroy(descriptor, true, *derived); + } + } + } +} + +// TODO: Assign() + +} // extern "C" +} // namespace Fortran::runtime diff --git a/flang/runtime/derived-api.h b/flang/runtime/derived-api.h new file mode 100644 index 0000000..44cd5d6 --- /dev/null +++ b/flang/runtime/derived-api.h @@ -0,0 +1,43 @@ +//===-- runtime/derived-api.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 +// +//===----------------------------------------------------------------------===// + +// API for lowering to use for operations on derived type objects. +// Initialiaztion and finalization are implied for pointer and allocatable +// ALLOCATE()/DEALLOCATE() respectively, so these APIs should be used only for +// local variables. Whole allocatable assignment should use AllocatableAssign() +// instead of this Assign(). + +#ifndef FLANG_RUNTIME_DERIVED_API_H_ +#define FLANG_RUNTIME_DERIVED_API_H_ + +#include "entry-names.h" + +namespace Fortran::runtime { +class Descriptor; + +extern "C" { + +// Initializes and allocates an object's components, if it has a derived type +// with any default component initialization or automatic components. +// The descriptor must be initialized and non-null. +void RTNAME(Initialize)( + const Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0); + +// Finalizes an object and its components. Deallocates any +// allocatable/automatic components. Does not deallocate the descriptor's +// storage. +void RTNAME(Destroy)(const Descriptor &); + +// Intrinsic or defined assignment, with scalar expansion but not type +// conversion. +void RTNAME(Assign)(const Descriptor &, const Descriptor &, + const char *sourceFile = nullptr, int sourceLine = 0); + +} // extern "C" +} // namespace Fortran::runtime +#endif // FLANG_RUNTIME_DERIVED_API_H_ diff --git a/flang/runtime/derived.cpp b/flang/runtime/derived.cpp index 4875ef2..61511b5 100644 --- a/flang/runtime/derived.cpp +++ b/flang/runtime/derived.cpp @@ -8,10 +8,91 @@ #include "derived.h" #include "descriptor.h" +#include "stat.h" +#include "terminator.h" #include "type-info.h" namespace Fortran::runtime { +int Initialize(const Descriptor &instance, const typeInfo::DerivedType &derived, + Terminator &terminator, bool hasStat, const Descriptor *errMsg) { + const Descriptor &componentDesc{derived.component()}; + std::size_t elements{instance.Elements()}; + std::size_t byteStride{instance.ElementBytes()}; + int stat{StatOk}; + // Initialize data components in each element; the per-element iteration + // constitutes the inner loops, not outer + std::size_t myComponents{componentDesc.Elements()}; + 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 &allocDesc{*instance.OffsetElement( + j * byteStride + comp.offset())}; + comp.EstablishDescriptor(allocDesc, instance, terminator); + allocDesc.raw().attribute = CFI_attribute_allocatable; + if (comp.genre() == typeInfo::Component::Genre::Automatic) { + stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat); + if (stat == StatOk) { + stat = Initialize(allocDesc, derived, terminator, hasStat, errMsg); + } + if (stat != StatOk) { + break; + } + } + } + } else if (const void *init{comp.initialization()}) { + // Explicit initialization of data pointers and + // non-allocatable non-automatic components + std::size_t bytes{comp.SizeInBytes(instance)}; + for (std::size_t j{0}; j < elements; ++j) { + char *ptr{instance.OffsetElement(j * byteStride + comp.offset())}; + std::memcpy(ptr, init, bytes); + } + } else if (comp.genre() == typeInfo::Component::Genre::Data && + comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) { + // Default initialization of non-pointer non-allocatable/automatic + // data component. Handles parent component's elements. Recursive. + SubscriptValue extent[maxRank]; + const typeInfo::Value *bounds{comp.bounds()}; + for (int dim{0}; dim < comp.rank(); ++dim) { + typeInfo::TypeParameterValue lb{ + bounds[2 * dim].GetValue(&instance).value_or(0)}; + typeInfo::TypeParameterValue ub{ + bounds[2 * dim + 1].GetValue(&instance).value_or(0)}; + extent[dim] = ub >= lb ? ub - lb + 1 : 0; + } + StaticDescriptor staticDescriptor; + Descriptor &compDesc{staticDescriptor.descriptor()}; + const typeInfo::DerivedType &compType{*comp.derivedType()}; + for (std::size_t j{0}; j < elements; ++j) { + compDesc.Establish(compType, + instance.OffsetElement(j * byteStride + comp.offset()), + comp.rank(), extent); + stat = Initialize(compDesc, compType, terminator, hasStat, errMsg); + if (stat != StatOk) { + break; + } + } + } + } + // Initialize procedure pointer components in each element + const Descriptor &procPtrDesc{derived.procPtr()}; + std::size_t myProcPtrs{procPtrDesc.Elements()}; + for (std::size_t k{0}; k < myProcPtrs; ++k) { + const auto &comp{ + *procPtrDesc.ZeroBasedIndexedElement(k)}; + for (std::size_t j{0}; j < elements; ++j) { + auto &pptr{*instance.OffsetElement( + j * byteStride + comp.offset)}; + pptr = comp.procInitialization; + } + } + return stat; +} + static const typeInfo::SpecialBinding *FindFinal( const typeInfo::DerivedType &derived, int rank) { const typeInfo::SpecialBinding *elemental{nullptr}; @@ -40,19 +121,38 @@ static const typeInfo::SpecialBinding *FindFinal( static void CallFinalSubroutine( const Descriptor &descriptor, const typeInfo::DerivedType &derived) { if (const auto *special{FindFinal(derived, descriptor.rank())}) { + // The following code relies on the fact that finalizable objects + // must be contiguous. if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) { std::size_t byteStride{descriptor.ElementBytes()}; - auto *p{special->GetProc()}; - // Finalizable objects must be contiguous. std::size_t elements{descriptor.Elements()}; - for (std::size_t j{0}; j < elements; ++j) { - p(descriptor.OffsetElement(j * byteStride)); + if (special->IsArgDescriptor(0)) { + StaticDescriptor statDesc; + Descriptor &elemDesc{statDesc.descriptor()}; + elemDesc = descriptor; + elemDesc.raw().attribute = CFI_attribute_pointer; + elemDesc.raw().rank = 0; + auto *p{special->GetProc()}; + for (std::size_t j{0}; j < elements; ++j) { + elemDesc.set_base_addr( + descriptor.OffsetElement(j * byteStride)); + p(elemDesc); + } + } else { + auto *p{special->GetProc()}; + for (std::size_t j{0}; j < elements; ++j) { + p(descriptor.OffsetElement(j * byteStride)); + } } } else if (special->IsArgDescriptor(0)) { + StaticDescriptor statDesc; + Descriptor &tmpDesc{statDesc.descriptor()}; + tmpDesc = descriptor; + tmpDesc.raw().attribute = CFI_attribute_pointer; + tmpDesc.Addendum()->set_derivedType(&derived); auto *p{special->GetProc()}; - p(descriptor); + p(tmpDesc); } else { - // Finalizable objects must be contiguous. auto *p{special->GetProc()}; p(descriptor.OffsetElement()); } @@ -68,20 +168,38 @@ void Destroy(const Descriptor &descriptor, bool finalize, CallFinalSubroutine(descriptor, derived); } const Descriptor &componentDesc{derived.component()}; - auto myComponents{static_cast(componentDesc.Elements())}; + std::size_t myComponents{componentDesc.Elements()}; std::size_t elements{descriptor.Elements()}; std::size_t byteStride{descriptor.ElementBytes()}; - for (unsigned k{0}; k < myComponents; ++k) { + // 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}; + k < myComponents; ++k) { const auto &comp{ *componentDesc.ZeroBasedIndexedElement(k)}; if (comp.genre() == typeInfo::Component::Genre::Allocatable || comp.genre() == typeInfo::Component::Genre::Automatic) { + if (const typeInfo::DerivedType * compType{comp.derivedType()}) { + if (!compType->noDestructionNeeded()) { + for (std::size_t j{0}; j < elements; ++j) { + Destroy(*descriptor.OffsetElement( + j * byteStride + comp.offset()), + finalize, *compType); + } + } + } for (std::size_t j{0}; j < elements; ++j) { descriptor.OffsetElement(j * byteStride + comp.offset()) - ->Deallocate(finalize); + ->Deallocate(); } } else if (comp.genre() == typeInfo::Component::Genre::Data && - comp.derivedType()) { + comp.derivedType() && !comp.derivedType()->noDestructionNeeded()) { SubscriptValue extent[maxRank]; const typeInfo::Value *bounds{comp.bounds()}; for (int dim{0}; dim < comp.rank(); ++dim) { @@ -99,9 +217,11 @@ void Destroy(const Descriptor &descriptor, bool finalize, } } } - const Descriptor &parentDesc{derived.parent()}; - if (const auto *parent{parentDesc.OffsetElement()}) { - Destroy(descriptor, finalize, *parent); + if (recurse) { + Destroy(descriptor, finalize, *parentType); } } + +// TODO: Assign() + } // namespace Fortran::runtime diff --git a/flang/runtime/derived.h b/flang/runtime/derived.h index 314c057..7239d82 100644 --- a/flang/runtime/derived.h +++ b/flang/runtime/derived.h @@ -6,6 +6,8 @@ // //===----------------------------------------------------------------------===// +// Internal runtime utilities for derived type operations. + #ifndef FLANG_RUNTIME_DERIVED_H_ #define FLANG_RUNTIME_DERIVED_H_ @@ -15,6 +17,23 @@ class DerivedType; namespace Fortran::runtime { class Descriptor; +class Terminator; + +// Perform default component initialization, allocate automatic components. +// Returns a STAT= code (0 when all's well). +int Initialize(const Descriptor &, const typeInfo::DerivedType &, Terminator &, + bool hasStat = false, const Descriptor *errMsg = nullptr); + +// 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_FINAL_H_ +#endif // FLANG_RUNTIME_DERIVED_H_ diff --git a/flang/runtime/descriptor-io.h b/flang/runtime/descriptor-io.h index 2ebb449..52b328b 100644 --- a/flang/runtime/descriptor-io.h +++ b/flang/runtime/descriptor-io.h @@ -233,7 +233,7 @@ static bool DefaultFormattedComponentIO(IoStatementState &io, // Create a descriptor for the component StaticDescriptor statDesc; Descriptor &desc{statDesc.descriptor()}; - component.EstablishDescriptor( + component.CreatePointerDescriptor( desc, origDescriptor, origSubscripts, terminator); return DescriptorIO(io, desc); } else { diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp index 0103f46..274cdd7 100644 --- a/flang/runtime/descriptor.cpp +++ b/flang/runtime/descriptor.cpp @@ -9,6 +9,7 @@ #include "descriptor.h" #include "derived.h" #include "memory.h" +#include "stat.h" #include "terminator.h" #include "type-info.h" #include @@ -19,12 +20,6 @@ namespace Fortran::runtime { Descriptor::Descriptor(const Descriptor &that) { *this = that; } -Descriptor::~Descriptor() { - if (raw_.attribute != CFI_attribute_pointer) { - Deallocate(); - } -} - Descriptor &Descriptor::operator=(const Descriptor &that) { std::memcpy(this, &that, that.SizeInBytes()); return *this; @@ -139,7 +134,6 @@ int Descriptor::Allocate() { return CFI_ERROR_MEM_ALLOCATION; } // TODO: image synchronization - // TODO: derived type initialization raw_.base_addr = p; if (int dims{rank()}) { std::size_t stride{ElementBytes()}; @@ -152,19 +146,23 @@ int Descriptor::Allocate() { return 0; } -int Descriptor::Deallocate(bool finalize) { - Destroy(finalize); - return ISO::CFI_deallocate(&raw_); -} - -void Descriptor::Destroy(bool finalize) const { - if (const DescriptorAddendum * addendum{Addendum()}) { - if (const typeInfo::DerivedType * dt{addendum->derivedType()}) { - runtime::Destroy(*this, finalize, *dt); +int Descriptor::Destroy(bool finalize) { + if (raw_.attribute == CFI_attribute_pointer) { + return StatOk; + } else { + if (auto *addendum{Addendum()}) { + if (const auto *derived{addendum->derivedType()}) { + if (!derived->noDestructionNeeded()) { + runtime::Destroy(*this, finalize, *derived); + } + } } + return Deallocate(); } } +int Descriptor::Deallocate() { return ISO::CFI_deallocate(&raw_); } + bool Descriptor::IncrementSubscripts( SubscriptValue *subscript, const int *permutation) const { for (int j{0}; j < raw_.rank; ++j) { diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h index 88e306c..f524b54 100644 --- a/flang/runtime/descriptor.h +++ b/flang/runtime/descriptor.h @@ -113,6 +113,7 @@ public: private: const typeInfo::DerivedType *derivedType_; + std::uint64_t __unused_flags_{0}; // TODO: delete typeInfo::TypeParameterValue len_[1]; // must be the last component // The LEN type parameter values can also include captured values of // specification expressions that were used for bounds and for LEN type @@ -135,7 +136,6 @@ public: // descriptor. Descriptor(const Descriptor &); - ~Descriptor(); Descriptor &operator=(const Descriptor &); static constexpr std::size_t BytesFor(TypeCategory category, int kind) { @@ -291,11 +291,17 @@ public: // Allocate() assumes Elements() and ElementBytes() work; // define the extents of the dimensions and the element length // before calling. It (re)computes the byte strides after - // allocation. - // TODO: SOURCE= and MOLD= + // allocation. Does not allocate automatic components or + // perform default component initialization. int Allocate(); - int Deallocate(bool finalize = true); - void Destroy(bool finalize = true) const; + + // Deallocates storage; does not call FINAL subroutines or + // deallocate allocatable/automatic components. + int Deallocate(); + + // Deallocates storage, including allocatable and automatic + // components. Optionally invokes FINAL subroutines. + int Destroy(bool finalize = false); bool IsContiguous(int leadingDimensions = maxRank) const { auto bytes{static_cast(ElementBytes())}; @@ -342,8 +348,6 @@ public: static constexpr std::size_t byteSize{ Descriptor::SizeInBytes(maxRank, hasAddendum, maxLengthTypeParameters)}; - ~StaticDescriptor() { descriptor().~Descriptor(); } - Descriptor &descriptor() { return *reinterpret_cast(storage_); } const Descriptor &descriptor() const { return *reinterpret_cast(storage_); diff --git a/flang/runtime/namelist.cpp b/flang/runtime/namelist.cpp index 0b334b4..72d669f 100644 --- a/flang/runtime/namelist.cpp +++ b/flang/runtime/namelist.cpp @@ -233,7 +233,7 @@ static bool HandleComponent(IoStatementState &io, Descriptor &desc, type{addendum ? addendum->derivedType() : nullptr}) { if (const typeInfo::Component * comp{type->FindDataComponent(compName, std::strlen(compName))}) { - comp->EstablishDescriptor(desc, source, nullptr, handler); + comp->CreatePointerDescriptor(desc, source, nullptr, handler); return true; } else { handler.SignalError( diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp index 6f34feb..9b6bfee 100644 --- a/flang/runtime/pointer.cpp +++ b/flang/runtime/pointer.cpp @@ -7,9 +7,11 @@ //===----------------------------------------------------------------------===// #include "pointer.h" +#include "derived.h" #include "stat.h" #include "terminator.h" #include "tools.h" +#include "type-info.h" namespace Fortran::runtime { extern "C" { @@ -115,8 +117,17 @@ int RTNAME(PointerAllocate)(Descriptor &pointer, bool hasStat, if (!pointer.IsPointer()) { return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); } - return ReturnError(terminator, pointer.Allocate(), errMsg, hasStat); - // TODO: default component initialization + int stat{ReturnError(terminator, pointer.Allocate(), errMsg, hasStat)}; + if (stat == StatOk) { + if (const DescriptorAddendum * addendum{pointer.Addendum()}) { + if (const auto *derived{addendum->derivedType()}) { + if (!derived->noInitializationNeeded()) { + stat = Initialize(pointer, *derived, terminator, hasStat, errMsg); + } + } + } + } + return stat; } int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat, @@ -128,7 +139,7 @@ int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat, if (!pointer.IsAllocated()) { return ReturnError(terminator, StatBaseNull, errMsg, hasStat); } - return ReturnError(terminator, pointer.Deallocate(), errMsg, hasStat); + return ReturnError(terminator, pointer.Destroy(true), errMsg, hasStat); } bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) { diff --git a/flang/runtime/type-info.cpp b/flang/runtime/type-info.cpp index 9385eab..0268a20 100644 --- a/flang/runtime/type-info.cpp +++ b/flang/runtime/type-info.cpp @@ -29,10 +29,64 @@ std::optional Value::GetValue( } } +std::size_t Component::GetElementByteSize(const Descriptor &instance) const { + switch (category()) { + case TypeCategory::Integer: + case TypeCategory::Real: + case TypeCategory::Logical: + return kind_; + case TypeCategory::Complex: + return 2 * kind_; + case TypeCategory::Character: + if (auto value{characterLen_.GetValue(&instance)}) { + return kind_ * *value; + } + break; + case TypeCategory::Derived: + if (const auto *type{derivedType()}) { + return type->sizeInBytes(); + } + break; + } + return 0; +} + +std::size_t Component::GetElements(const Descriptor &instance) const { + std::size_t elements{1}; + if (int rank{rank_}) { + if (const Value * boundValues{bounds()}) { + for (int j{0}; j < rank; ++j) { + TypeParameterValue lb{ + boundValues[2 * j].GetValue(&instance).value_or(0)}; + TypeParameterValue ub{ + boundValues[2 * j + 1].GetValue(&instance).value_or(0)}; + if (ub >= lb) { + elements *= ub - lb + 1; + } else { + return 0; + } + } + } else { + return 0; + } + } + return elements; +} + +std::size_t Component::SizeInBytes(const Descriptor &instance) const { + if (genre() == Genre::Data) { + return GetElementByteSize(instance) * GetElements(instance); + } else if (category() == TypeCategory::Derived) { + const DerivedType *type{derivedType()}; + return Descriptor::SizeInBytes( + rank_, true, type ? type->LenParameters() : 0); + } else { + return Descriptor::SizeInBytes(rank_); + } +} + void Component::EstablishDescriptor(Descriptor &descriptor, - const Descriptor &container, const SubscriptValue subscripts[], - Terminator &terminator) const { - RUNTIME_CHECK(terminator, genre_ == Genre::Data); + const Descriptor &container, Terminator &terminator) const { TypeCategory cat{category()}; if (cat == TypeCategory::Character) { auto length{characterLen_.GetValue(&container)}; @@ -45,7 +99,7 @@ void Component::EstablishDescriptor(Descriptor &descriptor, } else { descriptor.Establish(cat, kind_, nullptr, rank_); } - if (rank_) { + if (rank_ && genre_ != Genre::Allocatable) { const typeInfo::Value *boundValues{bounds()}; RUNTIME_CHECK(terminator, boundValues != nullptr); auto byteStride{static_cast(descriptor.ElementBytes())}; @@ -59,7 +113,25 @@ void Component::EstablishDescriptor(Descriptor &descriptor, byteStride *= dim.Extent(); } } +} + +void Component::CreatePointerDescriptor(Descriptor &descriptor, + const Descriptor &container, const SubscriptValue subscripts[], + Terminator &terminator) const { + RUNTIME_CHECK(terminator, genre_ == Genre::Data); + EstablishDescriptor(descriptor, container, terminator); descriptor.set_base_addr(container.Element(subscripts) + offset_); + descriptor.raw().attribute = CFI_attribute_pointer; +} + +const DerivedType *DerivedType::GetParentType() const { + if (hasParent_) { + const Descriptor &compDesc{component()}; + const Component &component{*compDesc.OffsetElement()}; + return component.derivedType(); + } else { + return nullptr; + } } const Component *DerivedType::FindDataComponent( @@ -77,9 +149,8 @@ const Component *DerivedType::FindDataComponent( return component; } } - const DerivedType *ancestor{parent().OffsetElement()}; - return ancestor ? ancestor->FindDataComponent(compName, compNameLen) - : nullptr; + const DerivedType *parent{GetParentType()}; + return parent ? parent->FindDataComponent(compName, compNameLen) : nullptr; } const SpecialBinding *DerivedType::FindSpecialBinding( @@ -116,7 +187,7 @@ FILE *DerivedType::Dump(FILE *f) const { 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, + std::fprintf(f, " [+%3d](0x%p) 0x%016jx", offset, reinterpret_cast(&uints[j]), static_cast(uints[j])); if (offset == offsetof(DerivedType, binding_)) { @@ -125,8 +196,6 @@ FILE *DerivedType::Dump(FILE *f) const { 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_)) { @@ -141,6 +210,12 @@ FILE *DerivedType::Dump(FILE *f) const { 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, hasParent_)) { + std::fputs( + " <-- hasParent_, noInitializationNeeded_, noDestructionNeeded_\n", + f); } else { std::fputc('\n', f); } @@ -195,6 +270,14 @@ FILE *Component::Dump(FILE *f) const { } std::fprintf(f, " category %d kind %d rank %d offset 0x%zx\n", category_, kind_, rank_, static_cast(offset_)); + if (initialization_) { + std::fprintf(f, " initialization @ 0x%p:\n", initialization_); + for (int j{0}; j < 128; j += sizeof(std::uint64_t)) { + std::fprintf(f, " [%3d] 0x%016jx\n", j, + static_cast( + *reinterpret_cast(initialization_ + j))); + } + } return f; } @@ -235,7 +318,7 @@ FILE *SpecialBinding::Dump(FILE *f) const { break; } std::fprintf(f, "\n rank: %d\n", rank_); - std::fprintf(f, " isArgDescriptoSetr: 0x%x\n", isArgDescriptorSet_); + std::fprintf(f, " isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_); std::fprintf(f, " proc: 0x%p\n", reinterpret_cast(proc_)); return f; } diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h index 0dfb4b6..fc1bf7a 100644 --- a/flang/runtime/type-info.h +++ b/flang/runtime/type-info.h @@ -73,8 +73,19 @@ public: } const char *initialization() const { return initialization_; } - // Creates a pointer descriptor from a component description. - void EstablishDescriptor(Descriptor &, const Descriptor &container, + std::size_t GetElementByteSize(const Descriptor &) const; + std::size_t GetElements(const Descriptor &) const; + + // For ocmponents that are descriptors, returns size of descriptor; + // for Genre::Data, returns elemental byte size times element count. + std::size_t SizeInBytes(const Descriptor &) const; + + // Establishes a descriptor from this component description. + void EstablishDescriptor( + Descriptor &, const Descriptor &container, Terminator &) const; + + // Creates a pointer descriptor from this component description. + void CreatePointerDescriptor(Descriptor &, const Descriptor &container, const SubscriptValue[], Terminator &) const; FILE *Dump(FILE * = stdout) const; @@ -100,7 +111,7 @@ private: struct ProcPtrComponent { StaticDescriptor<0> name; // CHARACTER(:), POINTER std::uint64_t offset{0}; - ProcedurePointer procInitialization; // for Genre::Procedure + ProcedurePointer procInitialization; }; class SpecialBinding { @@ -175,7 +186,6 @@ public: 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(); @@ -189,9 +199,14 @@ public: const Descriptor &component() const { return component_.descriptor(); } const Descriptor &procPtr() const { return procPtr_.descriptor(); } const Descriptor &special() const { return special_.descriptor(); } + bool hasParent() const { return hasParent_; } + bool noInitializationNeeded() const { return noInitializationNeeded_; } + bool noDestructionNeeded() const { return noDestructionNeeded_; } std::size_t LenParameters() const { return lenParameterKind().Elements(); } + const DerivedType *GetParentType() const; + // Finds a data component by name in this derived type or tis ancestors. const Component *FindDataComponent( const char *name, std::size_t nameLen) const; @@ -211,7 +226,6 @@ private: StaticDescriptor<0> name_; // CHARACTER(:), 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 @@ -242,6 +256,10 @@ private: // Does not include special bindings from ancestral types. StaticDescriptor<1, true> special_; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS + + bool hasParent_{false}; + bool noInitializationNeeded_{false}; + bool noDestructionNeeded_{false}; }; } // namespace Fortran::runtime::typeInfo diff --git a/flang/test/Semantics/call10.f90 b/flang/test/Semantics/call10.f90 index 7fa4a80..2ef3a5a 100644 --- a/flang/test/Semantics/call10.f90 +++ b/flang/test/Semantics/call10.f90 @@ -88,7 +88,7 @@ module m real, save :: v1 !ERROR: A pure subprogram may not have a variable with the SAVE attribute real :: v2 = 0. - !TODO: once we have DATA: !ERROR: A pure subprogram may not have a variable with the SAVE attribute + !ERROR: A pure subprogram may not have a variable with the SAVE attribute real :: v3 data v3/0./ !ERROR: A pure subprogram may not have a variable with the SAVE attribute diff --git a/flang/test/Semantics/offsets01.f90 b/flang/test/Semantics/offsets01.f90 index c3d66a5..5097487 100644 --- a/flang/test/Semantics/offsets01.f90 +++ b/flang/test/Semantics/offsets01.f90 @@ -47,8 +47,8 @@ subroutine s5(n) integer, len :: l2 real :: b(l1, l2) end type - type(t1(n)) :: x1 !CHECK: x1 size=40 offset= - type(t2(n,n)) :: x2 !CHECK: x2 size=48 offset= + type(t1(n)) :: x1 !CHECK: x1 size=48 offset= + type(t2(n,n)) :: x2 !CHECK: x2 size=56 offset= !CHECK: a size=48 offset=0: !CHECK: b size=72 offset=0: end diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90 index 088c6e5..2e33ba8 100644 --- a/flang/test/Semantics/typeinfo01.f90 +++ b/flang/test/Semantics/typeinfo01.f90 @@ -7,7 +7,7 @@ module m01 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=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: .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 @@ module m02 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,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()) +!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) end module module m03 @@ -33,8 +33,8 @@ module m03 end type 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,parent=NULL(),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,parent=NULL(),uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.0,lenparameterkind=NULL(),component=.c.kpdt.0,procptr=NULL(),special=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: .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 @@ module m04 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL()) +!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: .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 @@ module m05 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL()) +!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: .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,8 +85,8 @@ module m06 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t) -!CHECK: .dt.t2, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,parent=.dt.t,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=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: .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)] @@ -103,7 +103,7 @@ module m07 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t) +!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: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)] end module @@ -123,7 +123,7 @@ module m08 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t) +!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)] end module @@ -165,7 +165,7 @@ module m09 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t) +!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: .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,7 +214,7 @@ module m10 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,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t) +!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)] end module @@ -227,14 +227,18 @@ module m11 character(len=len) :: chauto real :: automatic(len) end type -!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.t) +!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.t) !CHECK: .lpk.t, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1] 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.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: .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: .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) type(t(*)), intent(in) :: x end subroutine end module -- 2.7.4