diff --git a/flang/docs/RuntimeTypeInfo.md b/flang/docs/RuntimeTypeInfo.md --- a/flang/docs/RuntimeTypeInfo.md +++ b/flang/docs/RuntimeTypeInfo.md @@ -216,7 +216,7 @@ comprise: * address(es) of the subroutine * whether the first, second, or both arguments are descriptors -* whether the subroutine is elemental +* whether the subroutine is elemental (necessarily also impure) ### User defined derived type I/O diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Semantics/runtime-type-info.h @@ -0,0 +1,38 @@ +//===-- include/flang/Semantics/runtime-type-info.h -------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +// BuildRuntimeDerivedTypeTables() translates the scopes of derived types +// and parameterized derived type instantiations into the type descriptions +// defined in module/__fortran_type_info.f90, packaging these descriptions +// as static initializers for compiler-created objects. + +#ifndef FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_ +#define FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_ + +#include +#include + +namespace llvm { +class raw_ostream; +} + +namespace Fortran::semantics { +class Scope; +class SemanticsContext; +class Symbol; + +struct RuntimeDerivedTypeTables { + Scope *schemata{nullptr}; + std::set names; +}; + +RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(SemanticsContext &); + +void Dump(llvm::raw_ostream &, const RuntimeDerivedTypeTables &); +} // namespace Fortran::semantics +#endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_ diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h --- a/flang/include/flang/Semantics/scope.h +++ b/flang/include/flang/Semantics/scope.h @@ -197,8 +197,11 @@ std::size_t size() const { return size_; } void set_size(std::size_t size) { size_ = size; } - std::size_t alignment() const { return alignment_; } - void set_alignment(std::size_t alignment) { alignment_ = alignment; } + std::optional alignment() const { return alignment_; } + + void SetAlignment(std::size_t n) { + alignment_ = std::max(alignment_.value_or(0), n); + } ImportKind GetImportKind() const; // Names appearing in IMPORT statements in this scope @@ -242,11 +245,18 @@ void InstantiateDerivedTypes(SemanticsContext &); + const Symbol *runtimeDerivedTypeDescription() const { + return runtimeDerivedTypeDescription_; + } + void set_runtimeDerivedTypeDescription(const Symbol &symbol) { + runtimeDerivedTypeDescription_ = &symbol; + } + private: Scope &parent_; // this is enclosing scope, not extended derived type base const Kind kind_; std::size_t size_{0}; // size in bytes - std::size_t alignment_{0}; // required alignment in bytes + std::optional alignment_; // required alignment in bytes parser::CharBlock sourceRange_; Symbol *const symbol_; // if not null, symbol_->scope() == this std::list children_; @@ -261,6 +271,7 @@ DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this parser::Message::Reference instantiationContext_; bool hasSAVE_{false}; // scope has a bare SAVE statement + const Symbol *runtimeDerivedTypeDescription_{nullptr}; // When additional data members are added to Scope, remember to // copy them, if appropriate, in InstantiateDerivedType(). diff --git a/flang/lib/Semantics/CMakeLists.txt b/flang/lib/Semantics/CMakeLists.txt --- a/flang/lib/Semantics/CMakeLists.txt +++ b/flang/lib/Semantics/CMakeLists.txt @@ -36,6 +36,7 @@ resolve-names-utils.cpp resolve-names.cpp rewrite-parse-tree.cpp + runtime-type-info.cpp scope.cpp semantics.cpp symbol.cpp diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp --- a/flang/lib/Semantics/compute-offsets.cpp +++ b/flang/lib/Semantics/compute-offsets.cpp @@ -85,12 +85,16 @@ if (scope.symbol() && scope.IsParameterizedDerivedType()) { return; // only process instantiations of parameterized derived types } + if (scope.alignment().has_value()) { + return; // prevent infinite recursion in error cases + } + scope.SetAlignment(0); // Build dependents_ from equivalences: symbol -> symbol+offset for (const EquivalenceSet &set : scope.equivalenceSets()) { DoEquivalenceSet(set); } offset_ = 0; - alignment_ = 0; + alignment_ = 1; // Compute a base symbol and overall block size for each // disjoint EQUIVALENCE storage sequence. for (auto &[symbol, dep] : dependents_) { @@ -128,7 +132,7 @@ } } scope.set_size(offset_); - scope.set_alignment(alignment_); + scope.SetAlignment(alignment_); // Assign offsets in COMMON blocks. for (auto &pair : scope.commonBlocks()) { DoCommonBlock(*pair.second); @@ -357,8 +361,9 @@ } } else if (const DerivedTypeSpec * derived{type->AsDerived()}) { if (derived->scope()) { + DoScope(*const_cast(derived->scope())); result.size = derived->scope()->size(); - result.alignment = derived->scope()->alignment(); + result.alignment = derived->scope()->alignment().value_or(0); } } else { DIE("not intrinsic or derived"); diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp new file mode 100644 --- /dev/null +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -0,0 +1,964 @@ +//===-- lib/Semantics/runtime-type-info.cpp ---------------------*- C++ -*-===// +// +// 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 "flang/Semantics/runtime-type-info.h" +#include "mod-file.h" +#include "flang/Evaluate/fold-designator.h" +#include "flang/Evaluate/fold.h" +#include "flang/Evaluate/tools.h" +#include "flang/Evaluate/type.h" +#include "flang/Semantics/scope.h" +#include "flang/Semantics/tools.h" +#include +#include +#include + +namespace Fortran::semantics { + +static int FindLenParameterIndex( + const SymbolVector ¶meters, const Symbol &symbol) { + int lenIndex{0}; + for (SymbolRef ref : parameters) { + if (&*ref == &symbol) { + return lenIndex; + } + if (ref->get().attr() == common::TypeParamAttr::Len) { + ++lenIndex; + } + } + DIE("Length type parameter not found in parameter order"); + return -1; +} + +class RuntimeTableBuilder { +public: + RuntimeTableBuilder(SemanticsContext &, RuntimeDerivedTypeTables &); + void DescribeTypes(Scope &scope); + +private: + const Symbol *DescribeType(Scope &); + const Symbol &GetSchemaSymbol(const char *) const; + const DeclTypeSpec &GetSchema(const char *) const; + SomeExpr GetEnumValue(const char *) const; + Symbol &CreateObject(const std::string &, const DeclTypeSpec &, Scope &); + // The names of created symbols are saved in and owned by the + // RuntimeDerivedTypeTables instance returned by + // BuildRuntimeDerivedTypeTables() so that references to those names remain + // valid for lowering. + SourceName SaveObjectName(const std::string &); + SomeExpr SaveNameAsPointerTarget(Scope &, const std::string &); + const SymbolVector *GetTypeParameters(const Symbol &); + evaluate::StructureConstructor DescribeComponent(const Symbol &, + const ObjectEntityDetails &, Scope &, const std::string &distinctName, + const SymbolVector *parameters); + evaluate::StructureConstructor DescribeComponent( + const Symbol &, const ProcEntityDetails &, Scope &); + evaluate::StructureConstructor PackageIntValue( + const SomeExpr &genre, std::int64_t = 0) const; + SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const; + std::vector CollectBindings(const Scope &dtScope) const; + std::vector DescribeBindings( + const Scope &dtScope, Scope &); + void DescribeGeneric( + const GenericDetails &, std::vector &); + void DescribeSpecialProc(std::vector &, + const Symbol &specificOrBinding, bool isAssignment, bool isFinal, + std::optional); + void IncorporateDefinedIoGenericInterfaces( + std::vector &, SourceName, + GenericKind::DefinedIo, const Scope *); + + // Instantiated for ParamValue and Bound + template + evaluate::StructureConstructor GetValue( + const A &x, const SymbolVector *parameters) { + if (x.isExplicit()) { + return GetValue(x.GetExplicit(), parameters); + } else { + return PackageIntValue(deferredEnum_); + } + } + + // Specialization for optional> + template + evaluate::StructureConstructor GetValue( + const std::optional> &expr, + const SymbolVector *parameters) { + if (auto constValue{evaluate::ToInt64(expr)}) { + return PackageIntValue(explicitEnum_, *constValue); + } + if (parameters) { + if (const auto *typeParam{ + evaluate::UnwrapExpr(expr)}) { + if (!typeParam->base()) { + const Symbol &symbol{typeParam->parameter()}; + if (const auto *tpd{symbol.detailsIf()}) { + if (tpd->attr() == common::TypeParamAttr::Len) { + return PackageIntValue(lenParameterEnum_, + FindLenParameterIndex(*parameters, symbol)); + } + } + } + } + } + if (expr) { + context_.Say(location_, + "Specification expression '%s' is neither constant nor a length type parameter"_err_en_US, + expr->AsFortran()); + } + return PackageIntValue(deferredEnum_); + } + + SemanticsContext &context_; + RuntimeDerivedTypeTables &tables_; + std::map orderedTypeParameters_; + int anonymousTypes_{0}; + + const DeclTypeSpec &derivedTypeSchema_; // TYPE(DerivedType) + const DeclTypeSpec &componentSchema_; // TYPE(Component) + const DeclTypeSpec &procPtrSchema_; // TYPE(ProcPtrComponent) + const DeclTypeSpec &valueSchema_; // TYPE(Value) + const DeclTypeSpec &bindingSchema_; // TYPE(Binding) + const DeclTypeSpec &specialSchema_; // TYPE(SpecialBinding) + SomeExpr deferredEnum_; // Value::Genre::Deferred + SomeExpr explicitEnum_; // Value::Genre::Explicit + SomeExpr lenParameterEnum_; // Value::Genre::LenParameter + SomeExpr assignmentEnum_; // SpecialBinding::Which::Assignment + 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 + parser::CharBlock location_; +}; + +RuntimeTableBuilder::RuntimeTableBuilder( + SemanticsContext &c, RuntimeDerivedTypeTables &t) + : context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")}, + componentSchema_{GetSchema("component")}, procPtrSchema_{GetSchema( + "procptrcomponent")}, + valueSchema_{GetSchema("value")}, bindingSchema_{GetSchema("binding")}, + specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue( + "deferred")}, + explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue( + "lenparameter")}, + assignmentEnum_{GetEnumValue("assignment")}, + elementalAssignmentEnum_{GetEnumValue("elementalassignment")}, + finalEnum_{GetEnumValue("final")}, elementalFinalEnum_{GetEnumValue( + "elementalfinal")}, + assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")}, + readFormattedEnum_{GetEnumValue("readformatted")}, + readUnformattedEnum_{GetEnumValue("readunformatted")}, + writeFormattedEnum_{GetEnumValue("writeformatted")}, + writeUnformattedEnum_{GetEnumValue("writeunformatted")} {} + +void RuntimeTableBuilder::DescribeTypes(Scope &scope) { + if (&scope == tables_.schemata) { + return; // don't loop trying to describe a schema... + } + if (scope.IsDerivedType()) { + DescribeType(scope); + } else { + for (Scope &child : scope.children()) { + DescribeTypes(child); + } + } +} + +// Returns derived type instantiation's parameters in declaration order +const SymbolVector *RuntimeTableBuilder::GetTypeParameters( + const Symbol &symbol) { + auto iter{orderedTypeParameters_.find(&symbol)}; + if (iter != orderedTypeParameters_.end()) { + return &iter->second; + } else { + return &orderedTypeParameters_ + .emplace(&symbol, OrderParameterDeclarations(symbol)) + .first->second; + } +} + +static Scope &GetContainingNonDerivedScope(Scope &scope) { + Scope *p{&scope}; + while (p->IsDerivedType()) { + p = &p->parent(); + } + return *p; +} + +static const Symbol &GetSchemaField( + const DerivedTypeSpec &derived, const std::string &name) { + const Scope &scope{ + DEREF(derived.scope() ? derived.scope() : derived.typeSymbol().scope())}; + auto iter{scope.find(SourceName(name))}; + CHECK(iter != scope.end()); + return *iter->second; +} + +static const Symbol &GetSchemaField( + const DeclTypeSpec &derived, const std::string &name) { + return GetSchemaField(DEREF(derived.AsDerived()), name); +} + +static evaluate::StructureConstructorValues &AddValue( + evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec, + const std::string &name, SomeExpr &&x) { + values.emplace(GetSchemaField(spec, name), std::move(x)); + return values; +} + +static evaluate::StructureConstructorValues &AddValue( + evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec, + const std::string &name, const SomeExpr &x) { + values.emplace(GetSchemaField(spec, name), x); + return values; +} + +static SomeExpr IntToExpr(std::int64_t n) { + return evaluate::AsGenericExpr(evaluate::ExtentExpr{n}); +} + +static evaluate::StructureConstructor Structure( + const DeclTypeSpec &spec, evaluate::StructureConstructorValues &&values) { + return {DEREF(spec.AsDerived()), std::move(values)}; +} + +static SomeExpr StructureExpr(evaluate::StructureConstructor &&x) { + return SomeExpr{evaluate::Expr{std::move(x)}}; +} + +static int GetIntegerKind(const Symbol &symbol) { + auto dyType{evaluate::DynamicType::From(symbol)}; + CHECK(dyType && dyType->category() == TypeCategory::Integer); + return dyType->kind(); +} + +// Save a rank-1 array constant of some numeric type as an +// initialized data object in a scope. +template +static SomeExpr SaveNumericPointerTarget( + Scope &scope, SourceName name, std::vector &&x) { + if (x.empty()) { + return SomeExpr{evaluate::NullPointer{}}; + } else { + ObjectEntityDetails object; + if (const auto *spec{scope.FindType( + DeclTypeSpec{NumericTypeSpec{T::category, KindExpr{T::kind}}})}) { + object.set_type(*spec); + } else { + object.set_type(scope.MakeNumericType(T::category, KindExpr{T::kind})); + } + auto elements{static_cast(x.size())}; + ArraySpec arraySpec; + arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{elements - 1})); + object.set_shape(arraySpec); + object.set_init(evaluate::AsGenericExpr(evaluate::Constant{ + std::move(x), evaluate::ConstantSubscripts{elements}})); + const Symbol &symbol{ + *scope + .try_emplace( + name, Attrs{Attr::TARGET, Attr::SAVE}, std::move(object)) + .first->second}; + return evaluate::AsGenericExpr( + evaluate::Expr{evaluate::Designator{symbol}}); + } +} + +// Save an arbitrarily shaped array constant of some derived type +// as an initialized data object in a scope. +static SomeExpr SaveDerivedPointerTarget(Scope &scope, SourceName name, + std::vector &&x, + evaluate::ConstantSubscripts &&shape) { + if (x.empty()) { + return SomeExpr{evaluate::NullPointer{}}; + } else { + const auto &derivedType{x.front().GetType().GetDerivedTypeSpec()}; + ObjectEntityDetails object; + DeclTypeSpec typeSpec{DeclTypeSpec::TypeDerived, derivedType}; + if (const DeclTypeSpec * spec{scope.FindType(typeSpec)}) { + object.set_type(*spec); + } else { + object.set_type(scope.MakeDerivedType( + DeclTypeSpec::TypeDerived, common::Clone(derivedType))); + } + if (!shape.empty()) { + ArraySpec arraySpec; + for (auto n : shape) { + arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{n - 1})); + } + object.set_shape(arraySpec); + } + object.set_init( + evaluate::AsGenericExpr(evaluate::Constant{ + derivedType, std::move(x), std::move(shape)})); + const Symbol &symbol{ + *scope + .try_emplace( + name, Attrs{Attr::TARGET, Attr::SAVE}, std::move(object)) + .first->second}; + return evaluate::AsGenericExpr( + evaluate::Designator{symbol}); + } +} + +static SomeExpr SaveObjectInit( + Scope &scope, SourceName name, const ObjectEntityDetails &object) { + const Symbol &symbol{*scope + .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE}, + ObjectEntityDetails{object}) + .first->second}; + CHECK(symbol.get().init().has_value()); + return evaluate::AsGenericExpr( + evaluate::Designator{symbol}); +} + +const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) { + if (const Symbol * info{dtScope.runtimeDerivedTypeDescription()}) { + return info; + } + const DerivedTypeSpec *derivedTypeSpec{dtScope.derivedTypeSpec()}; + const Symbol *dtSymbol{ + derivedTypeSpec ? &derivedTypeSpec->typeSymbol() : dtScope.symbol()}; + if (!dtSymbol) { + return nullptr; + } + auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())}; + // Check for an existing description that can be imported from a USE'd module + std::string typeName{dtSymbol->name().ToString()}; + if (typeName.empty() || typeName[0] == '.') { + return nullptr; + } + std::string distinctName{typeName}; + if (&dtScope != dtSymbol->scope()) { + distinctName += "."s + std::to_string(anonymousTypes_++); + } + std::string dtDescName{".dt."s + distinctName}; + Scope &scope{GetContainingNonDerivedScope(dtScope)}; + if (distinctName == typeName && scope.IsModule()) { + if (const Symbol * description{scope.FindSymbol(SourceName{dtDescName})}) { + dtScope.set_runtimeDerivedTypeDescription(*description); + return description; + } + } + // Create a new description object before populating it so that mutual + // references will work as pointer targets. + Symbol &dtObject{CreateObject(dtDescName, derivedTypeSchema_, scope)}; + dtScope.set_runtimeDerivedTypeDescription(dtObject); + evaluate::StructureConstructorValues dtValues; + AddValue(dtValues, derivedTypeSchema_, "name"s, + SaveNameAsPointerTarget(scope, typeName)); + bool isPDTdefinition{ + !derivedTypeSpec && dtScope.IsParameterizedDerivedType()}; + if (!isPDTdefinition) { + auto sizeInBytes{static_cast(dtScope.size())}; + if (auto alignment{dtScope.alignment().value_or(0)}) { + sizeInBytes += alignment - 1; + sizeInBytes /= alignment; + sizeInBytes *= alignment; + } + 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 + const Symbol *uninstDescObject{ + DescribeType(DEREF(const_cast(dtSymbol->scope())))}; + AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s, + evaluate::AsGenericExpr(evaluate::Expr{ + evaluate::Designator{ + DEREF(uninstDescObject)}})); + } else { + AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s, + SomeExpr{evaluate::NullPointer{}}); + } + + // TODO: compute typeHash + + using Int8 = evaluate::Type; + using Int1 = evaluate::Type; + std::vector kinds; + std::vector lenKinds; + const SymbolVector *parameters{GetTypeParameters(*dtSymbol)}; + if (parameters) { + // Package the derived type's parameters in declaration order for + // each category of parameter. KIND= type parameters are described + // by their instantiated (or default) values, while LEN= type + // parameters are described by their INTEGER kinds. + for (SymbolRef ref : *parameters) { + const auto &tpd{ref->get()}; + if (tpd.attr() == common::TypeParamAttr::Kind) { + auto value{evaluate::ToInt64(tpd.init()).value_or(0)}; + if (derivedTypeSpec) { + if (const auto *pv{derivedTypeSpec->FindParameter(ref->name())}) { + if (pv->GetExplicit()) { + if (auto instantiatedValue{ + evaluate::ToInt64(*pv->GetExplicit())}) { + value = *instantiatedValue; + } + } + } + } + kinds.emplace_back(value); + } else { // LEN= parameter + lenKinds.emplace_back(GetIntegerKind(*ref)); + } + } + } + AddValue(dtValues, derivedTypeSchema_, "kindparameter"s, + SaveNumericPointerTarget( + scope, SaveObjectName(".kp."s + distinctName), std::move(kinds))); + AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s, + SaveNumericPointerTarget( + scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds))); + // Traverse the components of the derived type + if (!isPDTdefinition) { + std::vector dataComponents; + std::vector procPtrComponents; + std::vector specials; + for (const auto &pair : dtScope) { + const Symbol &symbol{*pair.second}; + auto locationRestorer{common::ScopedSet(location_, symbol.name())}; + std::visit( + common::visitors{ + [&](const TypeParamDetails &) { + // already handled above in declaration order + }, + [&](const ObjectEntityDetails &object) { + dataComponents.emplace_back(DescribeComponent( + symbol, object, scope, distinctName, parameters)); + }, + [&](const ProcEntityDetails &proc) { + if (IsProcedurePointer(symbol)) { + procPtrComponents.emplace_back( + DescribeComponent(symbol, proc, scope)); + } + }, + [&](const ProcBindingDetails &) { // handled in a later pass + }, + [&](const GenericDetails &generic) { + DescribeGeneric(generic, specials); + }, + [&](const auto &) { + common::die( + "unexpected details on symbol '%s' in derived type scope", + symbol.name().ToString().c_str()); + }, + }, + symbol.details()); + } + AddValue(dtValues, derivedTypeSchema_, "component"s, + SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName), + std::move(dataComponents), + evaluate::ConstantSubscripts{ + static_cast( + dataComponents.size())})); + AddValue(dtValues, derivedTypeSchema_, "procptr"s, + SaveDerivedPointerTarget(scope, SaveObjectName(".p."s + distinctName), + std::move(procPtrComponents), + evaluate::ConstantSubscripts{ + static_cast( + procPtrComponents.size())})); + // Compile the "vtable" of type-bound procedure bindings + std::vector bindings{ + DescribeBindings(dtScope, scope)}; + AddValue(dtValues, derivedTypeSchema_, "binding"s, + SaveDerivedPointerTarget(scope, SaveObjectName(".v."s + distinctName), + std::move(bindings), + evaluate::ConstantSubscripts{ + 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); + } + } + IncorporateDefinedIoGenericInterfaces(specials, + SourceName{"read(formatted)", 15}, + GenericKind::DefinedIo::ReadFormatted, &scope); + IncorporateDefinedIoGenericInterfaces(specials, + SourceName{"read(unformatted)", 17}, + GenericKind::DefinedIo::ReadUnformatted, &scope); + IncorporateDefinedIoGenericInterfaces(specials, + SourceName{"write(formatted)", 16}, + GenericKind::DefinedIo::WriteFormatted, &scope); + IncorporateDefinedIoGenericInterfaces(specials, + SourceName{"write(unformatted)", 18}, + GenericKind::DefinedIo::WriteUnformatted, &scope); + AddValue(dtValues, derivedTypeSchema_, "special"s, + SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName), + std::move(specials), + evaluate::ConstantSubscripts{ + static_cast(specials.size())})); + } + dtObject.get().set_init(MaybeExpr{ + StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))}); + return &dtObject; +} + +static const Symbol &GetSymbol(const Scope &schemata, SourceName name) { + auto iter{schemata.find(name)}; + CHECK(iter != schemata.end()); + const Symbol &symbol{*iter->second}; + return symbol; +} + +const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const { + return GetSymbol( + DEREF(tables_.schemata), SourceName{name, std::strlen(name)}); +} + +const DeclTypeSpec &RuntimeTableBuilder::GetSchema( + const char *schemaName) const { + Scope &schemata{DEREF(tables_.schemata)}; + SourceName name{schemaName, std::strlen(schemaName)}; + const Symbol &symbol{GetSymbol(schemata, name)}; + CHECK(symbol.has()); + CHECK(symbol.scope()); + CHECK(symbol.scope()->IsDerivedType()); + const DeclTypeSpec *spec{nullptr}; + if (symbol.scope()->derivedTypeSpec()) { + DeclTypeSpec typeSpec{ + DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()}; + spec = schemata.FindType(typeSpec); + } + if (!spec) { + DeclTypeSpec typeSpec{ + DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}}; + spec = schemata.FindType(typeSpec); + } + if (!spec) { + spec = &schemata.MakeDerivedType( + DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}); + } + CHECK(spec->AsDerived()); + 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())}; + CHECK(value.has_value()); + return IntExpr<1>(*value); +} + +Symbol &RuntimeTableBuilder::CreateObject( + const std::string &name, const DeclTypeSpec &type, Scope &scope) { + ObjectEntityDetails object; + object.set_type(type); + auto pair{scope.try_emplace(SaveObjectName(name), + Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))}; + CHECK(pair.second); + Symbol &result{*pair.first->second}; + return result; +} + +SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) { + return *tables_.names.insert(name).first; +} + +SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget( + Scope &scope, const std::string &name) { + CHECK(!name.empty()); + CHECK(name.front() != '.'); + ObjectEntityDetails object; + auto len{static_cast(name.size())}; + if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{ + ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) { + object.set_type(*spec); + } else { + object.set_type(scope.MakeCharacterType( + ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1})); + } + using Ascii = evaluate::Type; + using AsciiExpr = evaluate::Expr; + object.set_init(evaluate::AsGenericExpr(AsciiExpr{name})); + const Symbol &symbol{ + *scope + .try_emplace(SaveObjectName(".n."s + name), + Attrs{Attr::TARGET, Attr::SAVE}, std::move(object)) + .first->second}; + return evaluate::AsGenericExpr( + AsciiExpr{evaluate::Designator{symbol}}); +} + +evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent( + const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope, + const std::string &distinctName, const SymbolVector *parameters) { + evaluate::StructureConstructorValues values; + auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize( + object, context_.foldingContext())}; + CHECK(typeAndShape.has_value()); + auto dyType{typeAndShape->type()}; + const auto &shape{typeAndShape->shape()}; + AddValue(values, componentSchema_, "name"s, + SaveNameAsPointerTarget(scope, symbol.name().ToString())); + AddValue(values, componentSchema_, "category"s, + IntExpr<1>(static_cast(dyType.category()))); + if (dyType.IsUnlimitedPolymorphic() || + dyType.category() == TypeCategory::Derived) { + AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0)); + } else { + AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind())); + } + AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset())); + // CHARACTER length + const auto &len{typeAndShape->LEN()}; + if (dyType.category() == TypeCategory::Character && len) { + AddValue(values, componentSchema_, "characterlen"s, + evaluate::AsGenericExpr(GetValue(len, parameters))); + } else { + AddValue(values, componentSchema_, "characterlen"s, + PackageIntValueExpr(deferredEnum_)); + } + // Describe component's derived type + std::vector lenParams; + if (dyType.category() == TypeCategory::Derived && + !dyType.IsUnlimitedPolymorphic()) { + const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()}; + Scope *derivedScope{const_cast( + spec.scope() ? spec.scope() : spec.typeSymbol().scope())}; + const Symbol *derivedDescription{DescribeType(DEREF(derivedScope))}; + AddValue(values, componentSchema_, "derived"s, + evaluate::AsGenericExpr(evaluate::Expr{ + evaluate::Designator{ + DEREF(derivedDescription)}})); + // Package values of LEN parameters, if any + if (const SymbolVector * specParams{GetTypeParameters(spec.typeSymbol())}) { + for (SymbolRef ref : *specParams) { + const auto &tpd{ref->get()}; + if (tpd.attr() == common::TypeParamAttr::Len) { + if (const ParamValue * paramValue{spec.FindParameter(ref->name())}) { + lenParams.emplace_back(GetValue(*paramValue, parameters)); + } else { + lenParams.emplace_back(GetValue(tpd.init(), parameters)); + } + } + } + } + } else { + // Subtle: a category of Derived with a null derived type pointer + // signifies CLASS(*) + AddValue(values, componentSchema_, "derived"s, + SomeExpr{evaluate::NullPointer{}}); + } + // LEN type parameter values for the component's type + if (!lenParams.empty()) { + AddValue(values, componentSchema_, "lenvalue"s, + SaveDerivedPointerTarget(scope, + SaveObjectName( + ".lv."s + distinctName + "."s + symbol.name().ToString()), + std::move(lenParams), + evaluate::ConstantSubscripts{ + static_cast(lenParams.size())})); + } else { + AddValue(values, componentSchema_, "lenvalue"s, + SomeExpr{evaluate::NullPointer{}}); + } + // Shape information + int rank{evaluate::GetRank(shape)}; + AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank)); + if (rank > 0) { + std::vector bounds; + evaluate::NamedEntity entity{symbol}; + auto &foldingContext{context_.foldingContext()}; + for (int j{0}; j < rank; ++j) { + bounds.emplace_back(GetValue(std::make_optional(evaluate::GetLowerBound( + foldingContext, entity, j)), + parameters)); + bounds.emplace_back(GetValue( + evaluate::GetUpperBound(foldingContext, entity, j), parameters)); + } + AddValue(values, componentSchema_, "bounds"s, + SaveDerivedPointerTarget(scope, + SaveObjectName( + ".b."s + distinctName + "."s + symbol.name().ToString()), + std::move(bounds), evaluate::ConstantSubscripts{2, rank})); + } else { + AddValue( + values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}}); + } + // Default component initialization + bool hasDataInit{false}; + if (IsAllocatable(symbol)) { + 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()}); + } + } else if (IsAutomaticObject(symbol)) { + AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic")); + } else { + AddValue(values, componentSchema_, "genre"s, GetEnumValue("data")); + hasDataInit = object.init().has_value(); + if (hasDataInit) { + AddValue(values, componentSchema_, "initialization"s, + SaveObjectInit(scope, + SaveObjectName( + ".di."s + distinctName + "."s + symbol.name().ToString()), + object)); + } + } + if (!hasDataInit) { + AddValue(values, componentSchema_, "initialization"s, + SomeExpr{evaluate::NullPointer{}}); + } + return {DEREF(componentSchema_.AsDerived()), std::move(values)}; +} + +evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent( + const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) { + evaluate::StructureConstructorValues values; + AddValue(values, procPtrSchema_, "name"s, + SaveNameAsPointerTarget(scope, symbol.name().ToString())); + AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset())); + if (auto init{proc.init()}; init && *init) { + AddValue(values, procPtrSchema_, "initialization"s, + SomeExpr{evaluate::ProcedureDesignator{**init}}); + } else { + AddValue(values, procPtrSchema_, "initialization"s, + SomeExpr{evaluate::NullPointer{}}); + } + return {DEREF(procPtrSchema_.AsDerived()), std::move(values)}; +} + +evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue( + const SomeExpr &genre, std::int64_t n) const { + evaluate::StructureConstructorValues xs; + AddValue(xs, valueSchema_, "genre"s, genre); + AddValue(xs, valueSchema_, "value"s, IntToExpr(n)); + return Structure(valueSchema_, std::move(xs)); +} + +SomeExpr RuntimeTableBuilder::PackageIntValueExpr( + const SomeExpr &genre, std::int64_t n) const { + return StructureExpr(PackageIntValue(genre, n)); +} + +std::vector RuntimeTableBuilder::CollectBindings( + const Scope &dtScope) const { + std::vector result; + std::map localBindings; + // Collect local bindings + for (auto pair : dtScope) { + const Symbol &symbol{*pair.second}; + if (symbol.has()) { + localBindings.emplace(symbol.name(), &symbol); + } + } + if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) { + result = CollectBindings(*parentScope); + // Apply overrides from the local bindings of the extended type + for (auto iter{result.begin()}; iter != result.end(); ++iter) { + const Symbol &symbol{**iter}; + auto overridden{localBindings.find(symbol.name())}; + if (overridden != localBindings.end()) { + *iter = overridden->second; + localBindings.erase(overridden); + } + } + } + // Add remaining (non-overriding) local bindings in name order to the result + for (auto pair : localBindings) { + result.push_back(pair.second); + } + return result; +} + +std::vector +RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) { + std::vector result; + for (const Symbol *symbol : CollectBindings(dtScope)) { + evaluate::StructureConstructorValues values; + AddValue(values, bindingSchema_, "proc"s, + SomeExpr{evaluate::ProcedureDesignator{ + symbol->get().symbol()}}); + AddValue(values, bindingSchema_, "name"s, + SaveNameAsPointerTarget(scope, symbol->name().ToString())); + result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values)); + } + return result; +} + +void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic, + std::vector &specials) { + std::visit(common::visitors{ + [&](const GenericKind::OtherKind &k) { + if (k == GenericKind::OtherKind::Assignment) { + for (auto ref : generic.specificProcs()) { + DescribeSpecialProc(specials, *ref, true, + false /*!final*/, std::nullopt); + } + } + }, + [&](const GenericKind::DefinedIo &io) { + switch (io) { + case GenericKind::DefinedIo::ReadFormatted: + case GenericKind::DefinedIo::ReadUnformatted: + case GenericKind::DefinedIo::WriteFormatted: + case GenericKind::DefinedIo::WriteUnformatted: + for (auto ref : generic.specificProcs()) { + DescribeSpecialProc( + specials, *ref, false, false /*!final*/, io); + } + break; + } + }, + [](const auto &) {}, + }, + generic.kind().u); +} + +void RuntimeTableBuilder::DescribeSpecialProc( + std::vector &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_; + if (binding && binding->passName() && + *binding->passName() == proc->dummyArguments[1].name) { + argThatMightBeDescriptor = 1; + isArgDescriptorSet |= 2; + } else { + argThatMightBeDescriptor = 2; // the non-passed-object argument + isArgDescriptorSet |= 1; + } + } else if (isFinal) { + CHECK(binding == nullptr); // FINALs are not bindings + CHECK(proc->dummyArguments.size() == 1); + if (proc->IsElemental()) { + which = elementalFinalEnum_; + } else { + const auto &typeAndShape{ + std::get( + proc->dummyArguments.at(0).u) + .type}; + if (typeAndShape.attrs().test( + evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) { + which = assumedRankFinalEnum_; + isArgDescriptorSet |= 1; + } else { + which = finalEnum_; + rank = evaluate::GetRank(typeAndShape.shape()); + if (rank > 0) { + argThatMightBeDescriptor = 1; + } + } + } + } else { // user defined derived type I/O + CHECK(proc->dummyArguments.size() >= 4); + bool isArg0Descriptor{ + !proc->dummyArguments.at(0).CanBePassedViaImplicitInterface()}; + // N.B. When the user defined I/O subroutine is a type bound procedure, + // its first argument is always a descriptor, otherwise, when it was an + // interface, it never is. + CHECK(!!binding == isArg0Descriptor); + if (binding) { + isArgDescriptorSet |= 1; + } + switch (io.value()) { + case GenericKind::DefinedIo::ReadFormatted: + which = readFormattedEnum_; + break; + case GenericKind::DefinedIo::ReadUnformatted: + which = readUnformattedEnum_; + break; + case GenericKind::DefinedIo::WriteFormatted: + which = writeFormattedEnum_; + break; + case GenericKind::DefinedIo::WriteUnformatted: + which = writeUnformattedEnum_; + break; + } + } + if (argThatMightBeDescriptor != 0 && + !proc->dummyArguments.at(argThatMightBeDescriptor - 1) + .CanBePassedViaImplicitInterface()) { + isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1); + } + evaluate::StructureConstructorValues values; + 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)); + } +} + +void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces( + std::vector &specials, SourceName name, + GenericKind::DefinedIo definedIo, const Scope *scope) { + for (; !scope->IsGlobal(); scope = &scope->parent()) { + if (auto asst{scope->find(name)}; asst != scope->end()) { + const Symbol &generic{*asst->second}; + const auto &genericDetails{generic.get()}; + CHECK(std::holds_alternative( + genericDetails.kind().u)); + CHECK(std::get(genericDetails.kind().u) == + definedIo); + for (auto ref : genericDetails.specificProcs()) { + DescribeSpecialProc(specials, *ref, false, false, definedIo); + } + } + } +} + +RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables( + SemanticsContext &context) { + ModFileReader reader{context}; + RuntimeDerivedTypeTables result; + static const char schemataName[]{"__fortran_type_info"}; + SourceName schemataModule{schemataName, std::strlen(schemataName)}; + result.schemata = reader.Read(schemataModule); + if (result.schemata) { + RuntimeTableBuilder builder{context, result}; + builder.DescribeTypes(context.globalScope()); + } + return result; +} +} // namespace Fortran::semantics diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp --- a/flang/lib/Semantics/semantics.cpp +++ b/flang/lib/Semantics/semantics.cpp @@ -381,8 +381,8 @@ if (const auto *symbol{scope.symbol()}) { os << ' ' << symbol->name(); } - if (scope.size()) { - os << " size=" << scope.size() << " alignment=" << scope.alignment(); + if (scope.alignment().has_value()) { + os << " size=" << scope.size() << " alignment=" << *scope.alignment(); } if (scope.derivedTypeSpec()) { os << " instantiation of " << *scope.derivedTypeSpec(); diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -490,7 +490,8 @@ } else { const auto &symbol{derived->typeSymbol()}; return symbol.owner().IsModule() && - symbol.owner().GetName().value() == "__fortran_builtins" && + (symbol.owner().GetName().value() == "__fortran_builtins" || + symbol.owner().GetName().value() == "__fortran_type_info") && symbol.name() == "__builtin_"s + name; } } @@ -638,10 +639,16 @@ } bool IsFinalizable(const Symbol &symbol) { - if (const DeclTypeSpec * type{symbol.GetType()}) { - if (const DerivedTypeSpec * derived{type->AsDerived()}) { - return IsFinalizable(*derived); + if (IsPointer(symbol)) { + return false; + } + if (const auto *object{symbol.detailsIf()}) { + if (object->isDummy() && !IsIntentOut(symbol)) { + return false; } + const DeclTypeSpec *type{object->type()}; + const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr}; + return derived && IsFinalizable(*derived); } return false; } diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90 --- a/flang/module/__fortran_builtins.f90 +++ b/flang/module/__fortran_builtins.f90 @@ -12,27 +12,20 @@ ! standard names of the procedures. module __Fortran_builtins + use __Fortran_type_info, only: __builtin_c_ptr, __builtin_c_funptr integer, parameter, private :: int64 = selected_int_kind(18) intrinsic :: __builtin_c_f_pointer - type :: __builtin_c_ptr - integer(kind=int64) :: __address = 0 - end type - - type :: __builtin_c_funptr - integer(kind=int64) :: __address = 0 - end type - type :: __builtin_event_type - integer(kind=int64) :: __count = 0 + integer(kind=int64) :: __count end type type :: __builtin_lock_type - integer(kind=int64) :: __count = 0 + integer(kind=int64) :: __count end type type :: __builtin_team_type - integer(kind=int64) :: __id = 0 + integer(kind=int64) :: __id end type end module diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90 new file mode 100644 --- /dev/null +++ b/flang/module/__fortran_type_info.f90 @@ -0,0 +1,115 @@ +!===-- module/__fortran_type_info.f90 --------------------------------------===! +! +! 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 +! +!===------------------------------------------------------------------------===! + +! Fortran definitions of runtime type description schemata. +! See flang/runtime/type-info.h for C++ perspective. +! The Semantics phase of the compiler requires the module file of this module +! in order to generate description tables for all other derived types. + +module __Fortran_type_info + + private + + integer, parameter :: int64 = selected_int_kind(18) + + type, public :: __builtin_c_ptr + integer(kind=int64) :: __address + end type + + type, public :: __builtin_c_funptr + integer(kind=int64) :: __address + end type + + type :: DerivedType + ! "TBP" bindings appear first. Inherited bindings, with overrides already + ! applied, appear in the initial entries in the same order as they + ! appear in the parent type's bindings, if any. They are followed + ! by new local bindings in alphabetic order of theing binding names. + type(Binding), pointer :: 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 :: kindParameter(:) ! values of instance + integer(1), pointer :: lenParameterKind(:) ! INTEGER kinds of LEN types + ! Data components appear in alphabetic order. + ! The parent component, if any, appears explicitly. + type(Component), pointer :: component(:) ! data components + type(ProcPtrComponent), pointer :: procptr(:) ! procedure pointers + ! Special bindings of the ancestral types are not duplicated here. + type(SpecialBinding), pointer :: special(:) + end type + + type :: Binding + type(__builtin_c_funptr) :: proc + character(len=:), pointer :: name + end type + + ! Array bounds and type parameters of ocmponents are deferred + ! (for allocatables and pointers), explicit constants, or + ! taken from LEN type parameters for automatic components. + enum, bind(c) ! Value::Genre + enumerator :: Deferred = 1, Explicit = 2, LenParameter = 3 + end enum + + type, bind(c) :: Value + integer(1) :: genre ! Value::Genre + integer(1) :: __padding0(7) + integer(kind=int64) :: value + end type + + enum, bind(c) ! Component::Genre + enumerator :: Data = 1, Pointer = 2, Allocatable = 3, Automatic = 4 + end enum + + enum, bind(c) ! common::TypeCategory + enumerator :: CategoryInteger = 0, CategoryReal = 1, & + CategoryComplex = 2, CategoryCharacter = 3, & + CategoryLogical = 4, CategoryDerived = 5 + end enum + + type :: Component ! data components, incl. object pointers + character(len=:), pointer :: name + integer(1) :: genre ! Component::Genre + integer(1) :: category + integer(1) :: kind + integer(1) :: rank + integer(1) :: __padding0(4) + integer(kind=int64) :: offset + type(Value) :: characterLen ! for category == Character + type(DerivedType), pointer :: derived ! for category == Derived + type(Value), pointer :: lenValue(:) ! (SIZE(derived%lenParameterKind)) + type(Value), pointer :: bounds(:, :) ! (2, rank): lower, upper + class(*), pointer :: initialization + end type + + type :: ProcPtrComponent ! procedure pointer components + character(len=:), pointer :: name + integer(kind=int64) :: offset + type(__builtin_c_funptr) :: initialization + 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 + 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) + type(__builtin_c_funptr) :: proc + end type + +end module diff --git a/flang/module/iso_c_binding.f90 b/flang/module/iso_c_binding.f90 --- a/flang/module/iso_c_binding.f90 +++ b/flang/module/iso_c_binding.f90 @@ -15,8 +15,8 @@ c_ptr => __builtin_c_ptr, & c_funptr => __builtin_c_funptr - type(c_ptr), parameter :: c_null_ptr = c_ptr() - type(c_funptr), parameter :: c_null_funptr = c_funptr() + type(c_ptr), parameter :: c_null_ptr = c_ptr(0) + type(c_funptr), parameter :: c_null_funptr = c_funptr(0) ! Table 18.2 (in clause 18.3.1) ! TODO: Specialize (via macros?) for alternative targets diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt --- a/flang/runtime/CMakeLists.txt +++ b/flang/runtime/CMakeLists.txt @@ -36,7 +36,7 @@ buffer.cpp character.cpp connection.cpp - derived-type.cpp + derived.cpp descriptor.cpp edit-input.cpp edit-output.cpp diff --git a/flang/runtime/allocatable.h b/flang/runtime/allocatable.h --- a/flang/runtime/allocatable.h +++ b/flang/runtime/allocatable.h @@ -13,6 +13,10 @@ #include "descriptor.h" #include "entry-names.h" +namespace Fortran::runtime::typeInfo { +class DerivedType; +} + namespace Fortran::runtime { extern "C" { @@ -29,7 +33,7 @@ void RTNAME(AllocatableInitCharacter)(Descriptor &, SubscriptValue length = 0, int kind = 1, int rank = 0, int corank = 0); void RTNAME(AllocatableInitDerived)( - Descriptor &, const DerivedType &, int rank = 0, int corank = 0); + Descriptor &, const typeInfo::DerivedType &, int rank = 0, int corank = 0); // Checks that an allocatable is not already allocated in statements // with STAT=. Use this on a value descriptor before setting bounds or diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -29,7 +29,7 @@ } void RTNAME(AllocatableInitDerived)(Descriptor &descriptor, - const DerivedType &derivedType, int rank, int corank) { + const typeInfo::DerivedType &derivedType, int rank, int corank) { INTERNAL_CHECK(corank == 0); descriptor.Establish( derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable); diff --git a/flang/runtime/derived-type.h b/flang/runtime/derived-type.h deleted file mode 100644 --- a/flang/runtime/derived-type.h +++ /dev/null @@ -1,190 +0,0 @@ -//===-- runtime/derived-type.h ----------------------------------*- C++ -*-===// -// -// 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 -// -//===----------------------------------------------------------------------===// - -#ifndef FORTRAN_RUNTIME_DERIVED_TYPE_H_ -#define FORTRAN_RUNTIME_DERIVED_TYPE_H_ - -#include "type-code.h" -#include "flang/ISO_Fortran_binding.h" -#include -#include - -namespace Fortran::runtime { - -class Descriptor; - -// Static type information about derived type specializations, -// suitable for residence in read-only storage. - -using TypeParameterValue = ISO::CFI_index_t; - -class TypeParameter { -public: - const char *name() const { return name_; } - const TypeCode typeCode() const { return typeCode_; } - - bool IsLenTypeParameter() const { return which_ < 0; } - - // Returns the static value of a KIND type parameter, or the default - // value of a LEN type parameter. - TypeParameterValue StaticValue() const { return value_; } - - // Returns the static value of a KIND type parameter, or an - // instantiated value of LEN type parameter. - TypeParameterValue GetValue(const Descriptor &) const; - -private: - const char *name_; - TypeCode typeCode_; // INTEGER, but not necessarily default kind - int which_{-1}; // index into DescriptorAddendum LEN type parameter values - TypeParameterValue value_; // default in the case of LEN type parameter -}; - -// Components that have any need for a descriptor will either reference -// a static descriptor that applies to all instances, or will *be* a -// descriptor. Be advised: the base addresses in static descriptors -// are null. Most runtime interfaces separate the data address from that -// of the descriptor, and ignore the encapsulated base address in the -// descriptor. Some interfaces, e.g. calls to interoperable procedures, -// cannot pass a separate data address, and any static descriptor being used -// in that kind of situation must be copied and customized. -// Static descriptors are flagged in their attributes. -class Component { -public: - const char *name() const { return name_; } - TypeCode typeCode() const { return typeCode_; } - const Descriptor *staticDescriptor() const { return staticDescriptor_; } - - bool IsParent() const { return (flags_ & PARENT) != 0; } - bool IsPrivate() const { return (flags_ & PRIVATE) != 0; } - bool IsDescriptor() const { return (flags_ & IS_DESCRIPTOR) != 0; } - - template A *Locate(char *dtInstance) const { - return reinterpret_cast(dtInstance + offset_); - } - template const A *Locate(const char *dtInstance) const { - return reinterpret_cast(dtInstance + offset_); - } - - Descriptor *GetDescriptor(char *dtInstance) const { - if (IsDescriptor()) { - return Locate(dtInstance); - } else { - return nullptr; - } - } - - const Descriptor *GetDescriptor(const char *dtInstance) const { - if (staticDescriptor_) { - return staticDescriptor_; - } else if (IsDescriptor()) { - return Locate(dtInstance); - } else { - return nullptr; - } - } - -private: - enum Flag { PARENT = 1, PRIVATE = 2, IS_DESCRIPTOR = 4 }; - const char *name_{nullptr}; - std::uint32_t flags_{0}; - TypeCode typeCode_{CFI_type_other}; - const Descriptor *staticDescriptor_{nullptr}; - std::size_t offset_{0}; // byte offset in derived type instance -}; - -struct ExecutableCode { - ExecutableCode() {} - ExecutableCode(const ExecutableCode &) = default; - ExecutableCode &operator=(const ExecutableCode &) = default; - std::intptr_t host{0}; - std::intptr_t device{0}; -}; - -struct TypeBoundProcedure { - const char *name; - ExecutableCode code; -}; - -// Represents a specialization of a derived type; i.e., any KIND type -// parameters have values set at compilation time. -// Extended derived types have the EXTENDS flag set and place their base -// component first in the component descriptions, which is significant for -// the execution of FINAL subroutines. -class DerivedType { -public: - DerivedType(const char *n, std::size_t kps, std::size_t lps, - const TypeParameter *tp, std::size_t cs, const Component *ca, - std::size_t tbps, const TypeBoundProcedure *tbp, std::size_t sz) - : name_{n}, kindParameters_{kps}, lenParameters_{lps}, typeParameter_{tp}, - components_{cs}, component_{ca}, typeBoundProcedures_{tbps}, - typeBoundProcedure_{tbp}, bytes_{sz} { - if (IsNontrivialAnalysis()) { - flags_ |= NONTRIVIAL; - } - } - - const char *name() const { return name_; } - std::size_t kindParameters() const { return kindParameters_; } - std::size_t lenParameters() const { return lenParameters_; } - - // KIND type parameters come first. - const TypeParameter &typeParameter(int n) const { return typeParameter_[n]; } - - std::size_t components() const { return components_; } - - // The first few type-bound procedure indices are special. - enum SpecialTBP { InitializerTBP, CopierTBP, FinalTBP }; - - std::size_t typeBoundProcedures() const { return typeBoundProcedures_; } - const TypeBoundProcedure &typeBoundProcedure(int n) const { - return typeBoundProcedure_[n]; - } - - DerivedType &set_sequence() { - flags_ |= SEQUENCE; - return *this; - } - DerivedType &set_bind_c() { - flags_ |= BIND_C; - return *this; - } - - std::size_t SizeInBytes() const { return bytes_; } - bool Extends() const { return components_ > 0 && component_[0].IsParent(); } - bool AnyPrivate() const; - bool IsSequence() const { return (flags_ & SEQUENCE) != 0; } - bool IsBindC() const { return (flags_ & BIND_C) != 0; } - bool IsNontrivial() const { return (flags_ & NONTRIVIAL) != 0; } - - bool IsSameType(const DerivedType &) const; - - void Initialize(char *instance) const; - void Destroy(char *instance, bool finalize = true) const; - -private: - enum Flag { SEQUENCE = 1, BIND_C = 2, NONTRIVIAL = 4 }; - - // True when any descriptor of data of this derived type will require - // an addendum pointing to a DerivedType, possibly with values of - // LEN type parameters. Conservative. - bool IsNontrivialAnalysis() const; - - const char *name_{""}; // NUL-terminated constant text - std::size_t kindParameters_{0}; - std::size_t lenParameters_{0}; - const TypeParameter *typeParameter_{nullptr}; // array - std::size_t components_{0}; // *not* including type parameters - const Component *component_{nullptr}; // array - std::size_t typeBoundProcedures_{0}; - const TypeBoundProcedure *typeBoundProcedure_{nullptr}; // array - std::uint64_t flags_{0}; - std::size_t bytes_{0}; -}; -} // namespace Fortran::runtime -#endif // FORTRAN_RUNTIME_DERIVED_TYPE_H_ diff --git a/flang/runtime/derived-type.cpp b/flang/runtime/derived-type.cpp deleted file mode 100644 --- a/flang/runtime/derived-type.cpp +++ /dev/null @@ -1,77 +0,0 @@ -//===-- runtime/derived-type.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-type.h" -#include "descriptor.h" -#include - -namespace Fortran::runtime { - -TypeParameterValue TypeParameter::GetValue(const Descriptor &descriptor) const { - if (which_ < 0) { - return value_; - } else { - return descriptor.Addendum()->LenParameterValue(which_); - } -} - -bool DerivedType::IsNontrivialAnalysis() const { - if (kindParameters_ > 0 || lenParameters_ > 0 || typeBoundProcedures_ > 0) { - return true; - } - for (std::size_t j{0}; j < components_; ++j) { - if (component_[j].IsDescriptor()) { - return true; - } - if (const Descriptor * staticDescriptor{component_[j].staticDescriptor()}) { - if (const DescriptorAddendum * addendum{staticDescriptor->Addendum()}) { - if (const DerivedType * dt{addendum->derivedType()}) { - if (dt->IsNontrivial()) { - return true; - } - } - } - } - } - return false; -} - -void DerivedType::Initialize(char *instance) const { - if (typeBoundProcedures_ > InitializerTBP) { - if (auto f{reinterpret_cast( - typeBoundProcedure_[InitializerTBP].code.host)}) { - f(instance); - } - } -#if 0 // TODO - for (std::size_t j{0}; j < components_; ++j) { - if (const Descriptor * descriptor{component_[j].GetDescriptor(instance)}) { - // invoke initialization TBP - } - } -#endif -} - -void DerivedType::Destroy(char *instance, bool finalize) const { - if (finalize && typeBoundProcedures_ > FinalTBP) { - if (auto f{reinterpret_cast( - typeBoundProcedure_[FinalTBP].code.host)}) { - f(instance); - } - } - const char *constInstance{instance}; - for (std::size_t j{0}; j < components_; ++j) { - if (Descriptor * descriptor{component_[j].GetDescriptor(instance)}) { - descriptor->Deallocate(finalize); - } else if (const Descriptor * - descriptor{component_[j].GetDescriptor(constInstance)}) { - descriptor->Destroy(component_[j].Locate(instance), finalize); - } - } -} -} // namespace Fortran::runtime diff --git a/flang/runtime/derived.h b/flang/runtime/derived.h new file mode 100644 --- /dev/null +++ b/flang/runtime/derived.h @@ -0,0 +1,20 @@ +//===-- runtime/derived.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 +// +//===----------------------------------------------------------------------===// + +#ifndef FLANG_RUNTIME_DERIVED_H_ +#define FLANG_RUNTIME_DERIVED_H_ + +namespace Fortran::runtime::typeInfo { +class DerivedType; +} + +namespace Fortran::runtime { +class Descriptor; +void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &); +} // namespace Fortran::runtime +#endif // FLANG_RUNTIME_FINAL_H_ diff --git a/flang/runtime/derived.cpp b/flang/runtime/derived.cpp new file mode 100644 --- /dev/null +++ b/flang/runtime/derived.cpp @@ -0,0 +1,123 @@ +//===-- runtime/derived.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.h" +#include "descriptor.h" +#include "type-info.h" + +namespace Fortran::runtime { + +static const typeInfo::SpecialBinding *FindFinal( + const typeInfo::DerivedType &derived, int rank) { + const typeInfo::SpecialBinding *elemental{nullptr}; + const Descriptor &specialDesc{derived.special.descriptor()}; + 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:; + } + } + return elemental; +} + +static void CallFinalSubroutine( + const Descriptor &descriptor, const typeInfo::DerivedType &derived) { + if (const auto *special{FindFinal(derived, descriptor.rank())}) { + if (special->which == typeInfo::SpecialBinding::Which::ElementalFinal) { + std::size_t byteStride{descriptor.ElementBytes()}; + auto p{reinterpret_cast(special->proc)}; + // 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)); + } + } else if (special->isArgDescriptorSet & 1) { + auto p{reinterpret_cast(special->proc)}; + p(descriptor); + } else { + // Finalizable objects must be contiguous. + auto p{reinterpret_cast(special->proc)}; + p(descriptor.OffsetElement()); + } + } +} + +static inline SubscriptValue GetValue( + const typeInfo::Value &value, const Descriptor &descriptor) { + if (value.genre == typeInfo::Value::Genre::LenParameter) { + return descriptor.Addendum()->LenParameterValue(value.value); + } else { + return value.value; + } +} + +// The order of finalization follows Fortran 2018 7.5.6.2, with +// deallocation of non-parent components (and their consequent finalization) +// taking place before parent component finalization. +void Destroy(const Descriptor &descriptor, bool finalize, + const typeInfo::DerivedType &derived) { + if (finalize) { + CallFinalSubroutine(descriptor, derived); + } + const Descriptor &componentDesc{derived.component.descriptor()}; + std::int64_t myComponents{componentDesc.GetDimension(0).Extent()}; + std::size_t elements{descriptor.Elements()}; + std::size_t byteStride{descriptor.ElementBytes()}; + for (unsigned k{0}; k < myComponents; ++k) { + const auto &comp{ + *componentDesc.ZeroBasedIndexedElement(k)}; + if (comp.genre == typeInfo::Component::Genre::Allocatable || + comp.genre == typeInfo::Component::Genre::Automatic) { + for (std::size_t j{0}; j < elements; ++j) { + descriptor.OffsetElement(j * byteStride + comp.offset) + ->Deallocate(finalize); + } + } else if (comp.genre == typeInfo::Component::Genre::Data && + comp.derivedType.descriptor().raw().base_addr) { + SubscriptValue extent[maxRank]; + const Descriptor &boundsDesc{comp.bounds.descriptor()}; + for (int dim{0}; dim < comp.rank; ++dim) { + extent[dim] = + GetValue( + *boundsDesc.ZeroBasedIndexedElement(2 * dim), + descriptor) - + GetValue(*boundsDesc.ZeroBasedIndexedElement( + 2 * dim + 1), + descriptor) + + 1; + } + StaticDescriptor staticDescriptor; + Descriptor &compDesc{staticDescriptor.descriptor()}; + const auto &compType{*comp.derivedType.descriptor() + .OffsetElement()}; + for (std::size_t j{0}; j < elements; ++j) { + compDesc.Establish(compType, + descriptor.OffsetElement(j * byteStride + comp.offset), + comp.rank, extent); + Destroy(compDesc, finalize, compType); + } + } + } + const Descriptor &parentDesc{derived.parent.descriptor()}; + if (const auto *parent{parentDesc.OffsetElement()}) { + Destroy(descriptor, finalize, *parent); + } +} +} // namespace Fortran::runtime diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h --- a/flang/runtime/descriptor.h +++ b/flang/runtime/descriptor.h @@ -18,7 +18,6 @@ // User C code is welcome to depend on that ISO_Fortran_binding.h file, // but should never reference this internal header. -#include "derived-type.h" #include "memory.h" #include "type-code.h" #include "flang/ISO_Fortran_binding.h" @@ -28,6 +27,11 @@ #include #include +namespace Fortran::runtime::typeInfo { +using TypeParameterValue = std::int64_t; +class DerivedType; +} // namespace Fortran::runtime::typeInfo + namespace Fortran::runtime { using SubscriptValue = ISO::CFI_index_t; @@ -63,7 +67,7 @@ // descriptors serve as POINTER and ALLOCATABLE components of derived type // instances. The presence of this structure is implied by the flag // CFI_cdesc_t.f18Addendum, and the number of elements in the len_[] -// array is determined by DerivedType::lenParameters(). +// array is determined by derivedType_->LenParameters(). class DescriptorAddendum { public: enum Flags { @@ -74,41 +78,38 @@ }; explicit DescriptorAddendum( - const DerivedType *dt = nullptr, std::uint64_t flags = 0) + const typeInfo::DerivedType *dt = nullptr, std::uint64_t flags = 0) : derivedType_{dt}, flags_{flags} {} - const DerivedType *derivedType() const { return derivedType_; } - DescriptorAddendum &set_derivedType(const DerivedType *dt) { + const typeInfo::DerivedType *derivedType() const { return derivedType_; } + DescriptorAddendum &set_derivedType(const typeInfo::DerivedType *dt) { derivedType_ = dt; return *this; } std::uint64_t &flags() { return flags_; } const std::uint64_t &flags() const { return flags_; } - std::size_t LenParameters() const { - if (derivedType_) { - return derivedType_->lenParameters(); - } - return 0; - } + std::size_t LenParameters() const; - TypeParameterValue LenParameterValue(int which) const { return len_[which]; } + typeInfo::TypeParameterValue LenParameterValue(int which) const { + return len_[which]; + } static constexpr std::size_t SizeInBytes(int lenParameters) { - return sizeof(DescriptorAddendum) - sizeof(TypeParameterValue) + - lenParameters * sizeof(TypeParameterValue); + return sizeof(DescriptorAddendum) - sizeof(typeInfo::TypeParameterValue) + + lenParameters * sizeof(typeInfo::TypeParameterValue); } std::size_t SizeInBytes() const; - void SetLenParameterValue(int which, TypeParameterValue x) { + void SetLenParameterValue(int which, typeInfo::TypeParameterValue x) { len_[which] = x; } void Dump(FILE * = stdout) const; private: - const DerivedType *derivedType_{nullptr}; + const typeInfo::DerivedType *derivedType_; std::uint64_t flags_{0}; - TypeParameterValue len_[1]; // must be the last component + 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 // parameters of components. The values have been truncated to the LEN @@ -155,8 +156,8 @@ int rank = maxRank, const SubscriptValue *extent = nullptr, ISO::CFI_attribute_t attribute = CFI_attribute_other, bool addendum = false); - void Establish(const DerivedType &dt, void *p = nullptr, int rank = maxRank, - const SubscriptValue *extent = nullptr, + void Establish(const typeInfo::DerivedType &dt, void *p = nullptr, + int rank = maxRank, const SubscriptValue *extent = nullptr, ISO::CFI_attribute_t attribute = CFI_attribute_other); static OwningPtr Create(TypeCode t, std::size_t elementBytes, @@ -171,8 +172,9 @@ SubscriptValue characters, void *p = nullptr, int rank = maxRank, const SubscriptValue *extent = nullptr, ISO::CFI_attribute_t attribute = CFI_attribute_other); - static OwningPtr Create(const DerivedType &dt, void *p = nullptr, - int rank = maxRank, const SubscriptValue *extent = nullptr, + static OwningPtr Create(const typeInfo::DerivedType &dt, + void *p = nullptr, int rank = maxRank, + const SubscriptValue *extent = nullptr, ISO::CFI_attribute_t attribute = CFI_attribute_other); ISO::CFI_cdesc_t &raw() { return raw_; } @@ -284,7 +286,7 @@ int Allocate(); int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]); int Deallocate(bool finalize = true); - void Destroy(char *data, bool finalize = true) const; + void Destroy(bool finalize = true) const; bool IsContiguous(int leadingDimensions = maxRank) const { auto bytes{static_cast(ElementBytes())}; @@ -341,11 +343,7 @@ assert(descriptor().SizeInBytes() <= byteSize); if (DescriptorAddendum * addendum{descriptor().Addendum()}) { assert(hasAddendum); - if (const DerivedType * dt{addendum->derivedType()}) { - assert(dt->lenParameters() <= maxLengthTypeParameters); - } else { - assert(maxLengthTypeParameters == 0); - } + assert(addendum->LenParameters() <= maxLengthTypeParameters); } else { assert(!hasAddendum); assert(maxLengthTypeParameters == 0); diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp --- a/flang/runtime/descriptor.cpp +++ b/flang/runtime/descriptor.cpp @@ -7,8 +7,10 @@ //===----------------------------------------------------------------------===// #include "descriptor.h" +#include "derived.h" #include "memory.h" #include "terminator.h" +#include "type-info.h" #include #include #include @@ -54,10 +56,9 @@ characterKind * characters, p, rank, extent, attribute, addendum); } -void Descriptor::Establish(const DerivedType &dt, void *p, int rank, +void Descriptor::Establish(const typeInfo::DerivedType &dt, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) { - Establish( - CFI_type_struct, dt.SizeInBytes(), p, rank, extent, attribute, true); + Establish(CFI_type_struct, dt.sizeInBytes, p, rank, extent, attribute, true); DescriptorAddendum *a{Addendum()}; Terminator terminator{__FILE__, __LINE__}; RUNTIME_CHECK(terminator, a != nullptr); @@ -88,10 +89,11 @@ characterKind * characters, p, rank, extent, attribute); } -OwningPtr Descriptor::Create(const DerivedType &dt, void *p, - int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) { - return Create(TypeCode{CFI_type_struct}, dt.SizeInBytes(), p, rank, extent, - attribute, dt.lenParameters()); +OwningPtr Descriptor::Create(const typeInfo::DerivedType &dt, + void *p, int rank, const SubscriptValue *extent, + ISO::CFI_attribute_t attribute) { + return Create(TypeCode{CFI_type_struct}, dt.sizeInBytes, p, rank, extent, + attribute, dt.LenParameters()); } std::size_t Descriptor::SizeInBytes() const { @@ -138,25 +140,17 @@ } int Descriptor::Deallocate(bool finalize) { - if (raw_.base_addr) { - Destroy(static_cast(raw_.base_addr), finalize); - } + Destroy(finalize); return ISO::CFI_deallocate(&raw_); } -void Descriptor::Destroy(char *data, bool finalize) const { - if (data) { - if (const DescriptorAddendum * addendum{Addendum()}) { +void Descriptor::Destroy(bool finalize) const { + if (const DescriptorAddendum * addendum{Addendum()}) { + if (const typeInfo::DerivedType * dt{addendum->derivedType()}) { if (addendum->flags() & DescriptorAddendum::DoNotFinalize) { finalize = false; } - if (const DerivedType * dt{addendum->derivedType()}) { - std::size_t elements{Elements()}; - std::size_t elementBytes{ElementBytes()}; - for (std::size_t j{0}; j < elements; ++j) { - dt->Destroy(data + j * elementBytes, finalize); - } - } + runtime::Destroy(*this, finalize, *dt); } } } @@ -254,6 +248,11 @@ return SizeInBytes(LenParameters()); } +std::size_t DescriptorAddendum::LenParameters() const { + const auto *type{derivedType()}; + return type ? type->LenParameters() : 0; +} + void DescriptorAddendum::Dump(FILE *f) const { std::fprintf( f, " derivedType @ %p\n", reinterpret_cast(derivedType_)); diff --git a/flang/runtime/transformational.cpp b/flang/runtime/transformational.cpp --- a/flang/runtime/transformational.cpp +++ b/flang/runtime/transformational.cpp @@ -90,7 +90,7 @@ // Create and populate the result's descriptor. const DescriptorAddendum *sourceAddendum{source.Addendum()}; - const DerivedType *sourceDerivedType{ + const typeInfo::DerivedType *sourceDerivedType{ sourceAddendum ? sourceAddendum->derivedType() : nullptr}; OwningPtr result; if (sourceDerivedType) { @@ -105,7 +105,7 @@ RUNTIME_CHECK(terminator, resultAddendum); resultAddendum->flags() |= DescriptorAddendum::DoNotFinalize; if (sourceDerivedType) { - std::size_t lenParameters{sourceDerivedType->lenParameters()}; + std::size_t lenParameters{sourceAddendum->LenParameters()}; for (std::size_t j{0}; j < lenParameters; ++j) { resultAddendum->SetLenParameterValue( j, sourceAddendum->LenParameterValue(j)); diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h new file mode 100644 --- /dev/null +++ b/flang/runtime/type-info.h @@ -0,0 +1,161 @@ +//===-- runtime/type-info.h -------------------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_RUNTIME_TYPE_INFO_H_ +#define FORTRAN_RUNTIME_TYPE_INFO_H_ + +// A C++ perspective of the derived type description schemata in +// flang/module/__fortran_type_info.f90. + +#include "descriptor.h" +#include "flang/Common/Fortran.h" +#include +#include + +namespace Fortran::runtime::typeInfo { + +class DerivedType { +public: + ~DerivedType(); + + // This member comes first because it's used like a vtable by generated code. + // It includes all of the ancestor types' bindings, if any, first, + // with any overrides from descendants already applied to them. Local + // bindings then follow in alphabetic order of binding name. + StaticDescriptor<1> binding; // TYPE(BINDING), DIMENSION(:), POINTER + + StaticDescriptor<0> name; // CHARACTER(:), POINTER + + std::uint64_t sizeInBytes{0}; + StaticDescriptor<0> parent; // TYPE(DERIVEDTYPE), POINTER + + // Instantiations of a parameterized derived type with KIND type + // parameters will point this data member to the description of + // the original uninstantiated type, which may be shared from a + // module via use association. The original uninstantiated derived + // type description will point to itself. Derived types that have + // no KIND type parameters will have a null pointer here. + StaticDescriptor<0> 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> lenParameterKind; // pointer to rank-1 array of INTEGER(1) + + // This array of local data components includes the parent component. + // Components are in alphabetic order. + // It does not include procedure pointer components. + StaticDescriptor<1, true> component; // TYPE(COMPONENT), POINTER, DIMENSION(:) + + // Procedure pointer components + StaticDescriptor<1, true> procPtr; // TYPE(PROCPTR), POINTER, DIMENSION(:) + + // Does not include special bindings from ancestral types. + StaticDescriptor<1, true> + special; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:) + + std::size_t LenParameters() const { + return lenParameterKind.descriptor().Elements(); + } +}; + +using ProcedurePointer = void (*)(); // TYPE(C_FUNPTR) + +struct Binding { + ProcedurePointer proc; + StaticDescriptor<0> name; // CHARACTER(:), POINTER +}; + +struct Value { + enum class Genre : std::uint8_t { + Deferred = 1, + Explicit = 2, + LenParameter = 3 + }; + Genre genre{Genre::Explicit}; + // The value encodes an index into the table of LEN type parameters in + // a descriptor's addendum for genre == Genre::LenParameter. + TypeParameterValue value{0}; +}; + +struct Component { + enum class Genre : std::uint8_t { Data, Pointer, Allocatable, Automatic }; + StaticDescriptor<0> name; // CHARACTER(:), POINTER + Genre genre{Genre::Data}; + std::uint8_t category; // common::TypeCategory + std::uint8_t kind{0}; + std::uint8_t rank{0}; + std::uint64_t offset{0}; + Value characterLen; // for TypeCategory::Character + StaticDescriptor<0, true> derivedType; // TYPE(DERIVEDTYPE), POINTER + StaticDescriptor<1, true> lenValue; // TYPE(VALUE), POINTER, DIMENSION(:) + StaticDescriptor<2, true> bounds; // TYPE(VALUE), POINTER, DIMENSION(2,:) + char *initialization{nullptr}; // for Genre::Data and Pointer + // TODO: cobounds + // TODO: `PRIVATE` attribute +}; + +struct ProcPtrComponent { + StaticDescriptor<0> name; // CHARACTER(:), POINTER + std::uint64_t offset{0}; + ProcedurePointer procInitialization; // for Genre::Procedure +}; + +struct SpecialBinding { + 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 + } 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: + // Set to 1, 2, or (usually 3). + // The passed-object argument (usually the "to") is always passed via a + // a descriptor in the cases where the runtime will call a defined + // assignment because these calls are to type-bound generics, + // not generic interfaces, and type-bound generic defined assigment + // may appear only in an extensible type and requires a passed-object + // argument (see C774), and passed-object arguments to TBPs must be + // both polymorphic and scalar (C760). The non-passed-object argument + // (usually the "from") is usually, but not always, also a descriptor. + // Which::Final and Which::ElementalFinal: + // Set to 1 when dummy argument is assumed-shape; otherwise, the + // argument can be passed by address. (Fortran guarantees that + // any finalized object must be whole and contiguous by restricting + // the use of DEALLOCATE on pointers. The dummy argument of an + // elemental final subroutine must be scalar and monomorphic, but + // use a descriptors when the type has LEN parameters.) + // Which::AssumedRankFinal: flag must necessarily be set + // User derived type I/O: + // Set to 1 when "dtv" initial dummy argument is polymorphic, which is + // the case when and only when the derived type is extensible. + // 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}; + + ProcedurePointer proc{nullptr}; +}; +} // namespace Fortran::runtime::typeInfo +#endif // FORTRAN_RUNTIME_TYPE_INFO_H_ diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/typeinfo01.f90 @@ -0,0 +1,239 @@ +!RUN: %f18 -fdebug-dump-symbols -fparse-only %s | FileCheck %s +! Tests for derived type runtime descriptions + +module m01 + type :: t1 + integer :: n + end type +!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: .n.n, SAVE, TARGET: ObjectEntity type: CHARACTER(2_8,1) init:"n" +!CHECK: .n.t1, SAVE, TARGET: ObjectEntity type: CHARACTER(2_8,1) init:"t1" +end module + +module m02 + type :: parent + integer :: pn + end type + type, extends(parent) :: child + integer :: cn + end type +!CHECK: .c.child, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:1_8 init:[component::component(name=.n.cn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=4_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.parent,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.parent,lenvalue=NULL(),bounds=NULL(),initialization=NULL())] +!CHECK: .c.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()) +end module + +module m03 + type :: kpdt(k) + integer(kind=1), kind :: k = 1 + real(kind=k) :: a + 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: .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 + +module m04 + type :: tbps + contains + procedure :: b2 => s1 + procedure :: b1 => s1 + end type + contains + 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: .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 + +module m05 + type :: t + procedure(s1), pointer :: p1 => s1 + end type + contains + 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=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL()) +!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 + +module m06 + type :: t + contains + procedure :: s1 + generic :: assignment(=) => s1 + end type + type, extends(t) :: t2 + contains + procedure :: s1 => s2 ! override + end type + contains + subroutine s1(x, y) + class(t), intent(out) :: x + class(t), intent(in) :: y + end subroutine + subroutine s2(x, y) + class(t2), intent(out) :: x + 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: .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)] +end module + +module m07 + type :: t + contains + procedure :: s1 + generic :: assignment(=) => s1 + end type + contains + impure elemental subroutine s1(x, y) + 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: .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 + +module m08 + type :: t + contains + final :: s1, s2, s3 + end type + contains + subroutine s1(x) + type(t) :: x(:) + end subroutine + subroutine s2(x) + type(t) :: x(3,3) + end subroutine + 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: .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 + +module m09 + type :: t + contains + procedure :: rf, ru, wf, wu + generic :: read(formatted) => rf + generic :: read(unformatted) => ru + generic :: write(formatted) => wf + generic :: write(unformatted) => wu + end type + contains + subroutine rf(x,u,iot,v,iostat,iomsg) + class(t), intent(inout) :: x + integer, intent(in) :: u + character(len=*), intent(in) :: iot + integer, intent(in) :: v(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end subroutine + subroutine ru(x,u,iostat,iomsg) + class(t), intent(inout) :: x + integer, intent(in) :: u + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end subroutine + subroutine wf(x,u,iot,v,iostat,iomsg) + class(t), intent(in) :: x + integer, intent(in) :: u + character(len=*), intent(in) :: iot + integer, intent(in) :: v(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end subroutine + subroutine wu(x,u,iostat,iomsg) + class(t), intent(in) :: x + integer, intent(in) :: u + 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: .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 + +module m10 + type :: t + end type + interface read(formatted) + procedure :: rf + end interface + interface read(unformatted) + procedure :: ru + end interface + interface write(formatted) + procedure ::wf + end interface + interface write(unformatted) + procedure :: wu + end interface + contains + subroutine rf(x,u,iot,v,iostat,iomsg) + type(t), intent(inout) :: x + integer, intent(in) :: u + character(len=*), intent(in) :: iot + integer, intent(in) :: v(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end subroutine + subroutine ru(x,u,iostat,iomsg) + type(t), intent(inout) :: x + integer, intent(in) :: u + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end subroutine + subroutine wf(x,u,iot,v,iostat,iomsg) + type(t), intent(in) :: x + integer, intent(in) :: u + character(len=*), intent(in) :: iot + integer, intent(in) :: v(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end subroutine + subroutine wu(x,u,iostat,iomsg) + type(t), intent(in) :: x + integer, intent(in) :: u + 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: .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 + +module m11 + real, target :: target + type :: t(len) + integer(kind=8), len :: len + real, allocatable :: allocatable(:) + real, pointer :: pointer => target + 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: .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.allocatable, SAVE, TARGET: ObjectEntity type: TYPE(value) shape: 0_8:1_8,0_8:0_8 init:reshape([value::value(genre=1_1,value=0_8),value(genre=1_1,value=0_8)],shape=[2,1]) +!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=.b.t.1.allocatable,initialization=NULL()),component(name=.n.automatic,genre=4_1,category=1_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.automatic,initialization=NULL()),component(name=.n.chauto,genre=4_1,category=3_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=1_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=target)] +!CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,parent=NULL(),uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL()) +!CHECK: .lpk.t.1, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1] + type(t(*)), intent(in) :: x + end subroutine +end module diff --git a/flang/tools/f18/CMakeLists.txt b/flang/tools/f18/CMakeLists.txt --- a/flang/tools/f18/CMakeLists.txt +++ b/flang/tools/f18/CMakeLists.txt @@ -18,6 +18,8 @@ ) set(MODULES + "__fortran_builtins" + "__fortran_type_info" "ieee_arithmetic" "ieee_exceptions" "ieee_features" @@ -25,6 +27,7 @@ "iso_fortran_env" "omp_lib" "__fortran_builtins" + "__fortran_type_info" ) set(include ${FLANG_BINARY_DIR}/include/flang) @@ -35,8 +38,10 @@ # Create module files directly from the top-level module source directory foreach(filename ${MODULES}) - if(${filename} MATCHES "__fortran_builtins") + if(${filename} MATCHES "__fortran_type_info") set(depends "") + elseif(${filename} MATCHES "__fortran_builtins") + set(depends ${include}/__fortran_type_info.mod) else() set(depends ${include}/__fortran_builtins.mod) endif() diff --git a/flang/tools/f18/f18.cpp b/flang/tools/f18/f18.cpp --- a/flang/tools/f18/f18.cpp +++ b/flang/tools/f18/f18.cpp @@ -22,6 +22,7 @@ #include "flang/Parser/provenance.h" #include "flang/Parser/unparse.h" #include "flang/Semantics/expression.h" +#include "flang/Semantics/runtime-type-info.h" #include "flang/Semantics/semantics.h" #include "flang/Semantics/unparse-with-symbols.h" #include "llvm/Support/Errno.h" @@ -253,10 +254,10 @@ parsing.cooked().AsCharBlock(), driver.debugModuleWriter}; semantics.Perform(); semantics.EmitMessages(llvm::errs()); - if (driver.dumpSymbols) { - semantics.DumpSymbols(llvm::outs()); - } if (semantics.AnyFatalError()) { + if (driver.dumpSymbols) { + semantics.DumpSymbols(llvm::outs()); + } llvm::errs() << driver.prefix << "semantic errors in " << path << '\n'; exitStatus = EXIT_FAILURE; if (driver.dumpParseTree) { @@ -264,6 +265,15 @@ } return {}; } + auto tables{ + Fortran::semantics::BuildRuntimeDerivedTypeTables(semanticsContext)}; + if (!tables.schemata) { + llvm::errs() << driver.prefix + << "could not find module file for __fortran_type_info\n"; + } + if (driver.dumpSymbols) { + semantics.DumpSymbols(llvm::outs()); + } if (driver.dumpUnparseWithSymbols) { Fortran::semantics::UnparseWithSymbols( llvm::outs(), parseTree, driver.encoding);