[flang-commits] [flang] b21c24c - [flang][runtime] Recognize and handle FINAL subroutines with contiguous dummy arrays when data are not so
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue Aug 1 13:46:59 PDT 2023
Author: Peter Klausler
Date: 2023-08-01T13:46:45-07:00
New Revision: b21c24c3080394e41db4019be3e646296e7f5b05
URL: https://github.com/llvm/llvm-project/commit/b21c24c3080394e41db4019be3e646296e7f5b05
DIFF: https://github.com/llvm/llvm-project/commit/b21c24c3080394e41db4019be3e646296e7f5b05.diff
LOG: [flang][runtime] Recognize and handle FINAL subroutines with contiguous dummy arrays when data are not so
When a FINAL subroutine is being invoked for a discontiguous array, which can
happen for INTENT(OUT) dummy arguments and for some left-hand side variables
in intrinsic assignment statements, it may be the case that the subroutine
being called was defined with a dummy argument that requires contiguous data.
Extend the derived type descriptions used by the runtime to signify when
a special procedure binding requires contiguity; set the flags accordingly;
check them in the runtime support library, and, when necessary, use a
temporary shallow copy of the finalized array data in the call to the
final subroutine.
Differential Revision: https://reviews.llvm.org/D156760
Added:
Modified:
flang/include/flang/Runtime/descriptor.h
flang/lib/Semantics/runtime-type-info.cpp
flang/module/__fortran_type_info.f90
flang/runtime/allocatable.cpp
flang/runtime/assign.cpp
flang/runtime/derived-api.cpp
flang/runtime/derived.cpp
flang/runtime/derived.h
flang/runtime/descriptor-io.h
flang/runtime/descriptor.cpp
flang/runtime/pointer.cpp
flang/runtime/tools.cpp
flang/runtime/tools.h
flang/runtime/type-info.cpp
flang/runtime/type-info.h
flang/test/Semantics/typeinfo01.f90
flang/test/Semantics/typeinfo02.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Runtime/descriptor.h b/flang/include/flang/Runtime/descriptor.h
index e41b99c20bec1e..318c0ab47d209e 100644
--- a/flang/include/flang/Runtime/descriptor.h
+++ b/flang/include/flang/Runtime/descriptor.h
@@ -36,6 +36,7 @@ class DerivedType;
namespace Fortran::runtime {
using SubscriptValue = ISO::CFI_index_t;
+class Terminator;
RT_VAR_GROUP_BEGIN
static constexpr RT_CONST_VAR_ATTRS int maxRank{CFI_MAX_RANK};
@@ -369,7 +370,8 @@ class Descriptor {
// Deallocates storage, including allocatable and automatic
// components. Optionally invokes FINAL subroutines.
- RT_API_ATTRS int Destroy(bool finalize = false, bool destroyPointers = false);
+ RT_API_ATTRS int Destroy(bool finalize = false, bool destroyPointers = false,
+ Terminator * = nullptr);
RT_API_ATTRS bool IsContiguous(int leadingDimensions = maxRank) const {
auto bytes{static_cast<SubscriptValue>(ElementBytes())};
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index cfce8c2e57d7b5..9612c2368e9e9e 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -163,14 +163,14 @@ class RuntimeTableBuilder {
RuntimeTableBuilder::RuntimeTableBuilder(
SemanticsContext &c, RuntimeDerivedTypeTables &t)
: context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},
- componentSchema_{GetSchema("component")}, procPtrSchema_{GetSchema(
- "procptrcomponent")},
- valueSchema_{GetSchema("value")}, bindingSchema_{GetSchema(
- bindingDescCompName)},
- specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue(
- "deferred")},
- explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue(
- "lenparameter")},
+ componentSchema_{GetSchema("component")},
+ procPtrSchema_{GetSchema("procptrcomponent")},
+ valueSchema_{GetSchema("value")},
+ bindingSchema_{GetSchema(bindingDescCompName)},
+ specialSchema_{GetSchema("specialbinding")},
+ deferredEnum_{GetEnumValue("deferred")},
+ explicitEnum_{GetEnumValue("explicit")},
+ lenParameterEnum_{GetEnumValue("lenparameter")},
scalarAssignmentEnum_{GetEnumValue("scalarassignment")},
elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
readFormattedEnum_{GetEnumValue("readformatted")},
@@ -588,8 +588,9 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
if (derivedTypeSpec) {
for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {
- DescribeSpecialProc(specials, *ref, false /*!isAssignment*/, true,
- std::nullopt, nullptr, derivedTypeSpec, true);
+ DescribeSpecialProc(specials, *ref, /*isAssignment-*/ false,
+ /*isFinal=*/true, std::nullopt, nullptr, derivedTypeSpec,
+ /*isTypeBound=*/true);
}
IncorporateDefinedIoGenericInterfaces(specials,
common::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
@@ -1039,8 +1040,9 @@ void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
[&](const GenericKind::OtherKind &k) {
if (k == GenericKind::OtherKind::Assignment) {
for (auto ref : generic.specificProcs()) {
- DescribeSpecialProc(specials, *ref, true, false /*!final*/,
- std::nullopt, &dtScope, derivedTypeSpec, true);
+ DescribeSpecialProc(specials, *ref, /*isAssignment=*/true,
+ /*isFinal=*/false, std::nullopt, &dtScope, derivedTypeSpec,
+ /*isTypeBound=*/true);
}
}
},
@@ -1051,8 +1053,9 @@ void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
case common::DefinedIo::WriteFormatted:
case common::DefinedIo::WriteUnformatted:
for (auto ref : generic.specificProcs()) {
- DescribeSpecialProc(specials, *ref, false, false /*!final*/, io,
- &dtScope, derivedTypeSpec, true);
+ DescribeSpecialProc(specials, *ref, /*isAssignment=*/false,
+ /*isFinal=*/false, io, &dtScope, derivedTypeSpec,
+ /*isTypeBound=*/true);
}
break;
}
@@ -1076,6 +1079,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
if (auto proc{evaluate::characteristics::Procedure::Characterize(
specific, context_.foldingContext())}) {
std::uint8_t isArgDescriptorSet{0};
+ std::uint8_t isArgContiguousSet{0};
int argThatMightBeDescriptor{0};
MaybeExpr which;
if (isAssignment) {
@@ -1115,10 +1119,10 @@ void RuntimeTableBuilder::DescribeSpecialProc(
if (proc->IsElemental()) {
which = elementalFinalEnum_;
} else {
- const auto &typeAndShape{
+ const auto &dummyData{
std::get<evaluate::characteristics::DummyDataObject>(
- proc->dummyArguments.at(0).u)
- .type};
+ proc->dummyArguments.at(0).u)};
+ const auto &typeAndShape{dummyData.type};
if (typeAndShape.attrs().test(
evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
which = assumedRankFinalEnum_;
@@ -1126,8 +1130,16 @@ void RuntimeTableBuilder::DescribeSpecialProc(
} else {
which = scalarFinalEnum_;
if (int rank{evaluate::GetRank(typeAndShape.shape())}; rank > 0) {
- argThatMightBeDescriptor = 1;
which = IntExpr<1>(ToInt64(which).value() + rank);
+ if (!proc->dummyArguments[0].CanBePassedViaImplicitInterface()) {
+ argThatMightBeDescriptor = 1;
+ }
+ if (!typeAndShape.attrs().test(evaluate::characteristics::
+ TypeAndShape::Attr::AssumedShape) ||
+ dummyData.attrs.test(evaluate::characteristics::
+ DummyDataObject::Attr::Contiguous)) {
+ isArgContiguousSet |= 1;
+ }
}
}
}
@@ -1176,6 +1188,8 @@ void RuntimeTableBuilder::DescribeSpecialProc(
IntExpr<1>(isArgDescriptorSet));
AddValue(values, specialSchema_, "istypebound"s,
IntExpr<1>(isTypeBound ? 1 : 0));
+ AddValue(values, specialSchema_, "isargcontiguousset"s,
+ IntExpr<1>(isArgContiguousSet));
AddValue(values, specialSchema_, procCompName,
SomeExpr{evaluate::ProcedureDesignator{specific}});
// index might already be present in the case of an override
@@ -1219,9 +1233,7 @@ RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
// dummy argument. Returns a non-null DeclTypeSpec pointer only if that
// dtv argument exists and is a derived type.
static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) {
- const Symbol *interface {
- &specific.GetUltimate()
- };
+ const Symbol *interface{&specific.GetUltimate()};
if (const auto *procEntity{specific.detailsIf<ProcEntityDetails>()}) {
interface = procEntity->procInterface();
}
diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90
index 72c55fa8d06f55..8a517bd1d5422d 100644
--- a/flang/module/__fortran_type_info.f90
+++ b/flang/module/__fortran_type_info.f90
@@ -109,7 +109,8 @@
integer(1) :: which ! SpecialBinding::Which
integer(1) :: isArgDescriptorSet
integer(1) :: isTypeBound
- integer(1) :: __padding0(5)
+ integer(1) :: isArgContiguousSet
+ integer(1) :: __padding0(4)
type(__builtin_c_funptr) :: proc
end type
diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp
index 758c814025b961..96da5868f5f87d 100644
--- a/flang/runtime/allocatable.cpp
+++ b/flang/runtime/allocatable.cpp
@@ -78,7 +78,8 @@ std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
}
if (to.IsAllocated()) {
- int stat{to.Destroy(/*finalize=*/true)};
+ int stat{
+ to.Destroy(/*finalize=*/true, /*destroyPointers=*/false, &terminator)};
if (stat != StatOk) {
return ReturnError(terminator, stat, errMsg, hasStat);
}
@@ -188,7 +189,10 @@ int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
if (!descriptor.IsAllocated()) {
return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
}
- return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat);
+ return ReturnError(terminator,
+ descriptor.Destroy(
+ /*finalize=*/true, /*destroyPointers=*/false, &terminator),
+ errMsg, hasStat);
}
int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
@@ -218,7 +222,9 @@ void RTNAME(AllocatableDeallocateNoFinal)(
} else if (!descriptor.IsAllocated()) {
ReturnError(terminator, StatBaseNull);
} else {
- ReturnError(terminator, descriptor.Destroy(false));
+ ReturnError(terminator,
+ descriptor.Destroy(
+ /*finalize=*/false, /*destroyPointers=*/false, &terminator));
}
}
diff --git a/flang/runtime/assign.cpp b/flang/runtime/assign.cpp
index c0d50e4e7ead47..3a7ade9421ccf2 100644
--- a/flang/runtime/assign.cpp
+++ b/flang/runtime/assign.cpp
@@ -11,6 +11,7 @@
#include "derived.h"
#include "stat.h"
#include "terminator.h"
+#include "tools.h"
#include "type-info.h"
#include "flang/Runtime/descriptor.h"
@@ -299,18 +300,7 @@ static void Assign(
RTNAME(AssignTemporary)
(newFrom, from, terminator.sourceFileName(), terminator.sourceLine());
} else {
- char *toAt{newFrom.OffsetElement()};
- std::size_t fromElements{from.Elements()};
- if (from.IsContiguous()) {
- std::memcpy(
- toAt, from.OffsetElement(), fromElements * fromElementBytes);
- } else {
- SubscriptValue fromAt[maxRank];
- for (from.GetLowerBounds(fromAt); fromElements-- > 0;
- toAt += fromElementBytes, from.IncrementSubscripts(fromAt)) {
- std::memcpy(toAt, from.Element<char>(fromAt), fromElementBytes);
- }
- }
+ ShallowCopy(newFrom, from, true, from.IsContiguous());
}
Assign(to, newFrom, terminator,
flags &
@@ -325,11 +315,12 @@ static void Assign(
if (mustDeallocateLHS) {
if (deferDeallocation) {
if ((flags & NeedFinalization) && toDerived) {
- Finalize(to, *toDerived);
+ Finalize(to, *toDerived, &terminator);
flags &= ~NeedFinalization;
}
} else {
- to.Destroy((flags & NeedFinalization) != 0);
+ to.Destroy((flags & NeedFinalization) != 0, /*destroyPointers=*/false,
+ &terminator);
flags &= ~NeedFinalization;
}
} else if (to.rank() != from.rank() && !to.IsAllocated()) {
@@ -394,7 +385,7 @@ static void Assign(
// for all components, including parent components (10.2.1.2-3).
// The target is first finalized if still necessary (7.5.6.3(1))
if (flags & NeedFinalization) {
- Finalize(to, *updatedToDerived);
+ Finalize(to, *updatedToDerived, &terminator);
}
// Copy the data components (incl. the parent) first.
const Descriptor &componentDesc{updatedToDerived->component()};
@@ -467,7 +458,8 @@ static void Assign(
// This is just a shortcut, because the recursive Assign()
// below would initiate the destruction for to.
// No finalization is required.
- toDesc->Destroy();
+ toDesc->Destroy(
+ /*finalize=*/false, /*destroyPointers=*/false, &terminator);
continue; // F'2018 10.2.1.3(13)(2)
}
}
@@ -526,7 +518,8 @@ static void Assign(
if (deferDeallocation) {
// deferDeallocation is used only when LHS is an allocatable.
// The finalization has already been run for it.
- deferDeallocation->Destroy();
+ deferDeallocation->Destroy(
+ /*finalize=*/false, /*destroyPointers=*/false, &terminator);
}
}
diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp
index 8df49c5841a1ce..32d4bb26608b4d 100644
--- a/flang/runtime/derived-api.cpp
+++ b/flang/runtime/derived-api.cpp
@@ -33,7 +33,9 @@ void RTNAME(Destroy)(const Descriptor &descriptor) {
if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
if (const auto *derived{addendum->derivedType()}) {
if (!derived->noDestructionNeeded()) {
- Destroy(descriptor, true, *derived);
+ // TODO: Pass source file & line information to the API
+ // so that a good Terminator can be passed
+ Destroy(descriptor, true, *derived, nullptr);
}
}
}
@@ -160,7 +162,7 @@ void RTNAME(DestroyWithoutFinalization)(const Descriptor &descriptor) {
if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
if (const auto *derived{addendum->derivedType()}) {
if (!derived->noDestructionNeeded()) {
- Destroy(descriptor, /*finalize=*/false, *derived);
+ Destroy(descriptor, /*finalize=*/false, *derived, nullptr);
}
}
}
diff --git a/flang/runtime/derived.cpp b/flang/runtime/derived.cpp
index ac9b1c5906f424..5224c1426479a2 100644
--- a/flang/runtime/derived.cpp
+++ b/flang/runtime/derived.cpp
@@ -9,6 +9,7 @@
#include "derived.h"
#include "stat.h"
#include "terminator.h"
+#include "tools.h"
#include "type-info.h"
#include "flang/Runtime/descriptor.h"
@@ -124,11 +125,9 @@ static const typeInfo::SpecialBinding *FindFinal(
}
}
-static void CallFinalSubroutine(
- const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+static void CallFinalSubroutine(const Descriptor &descriptor,
+ const typeInfo::DerivedType &derived, Terminator *terminator) {
if (const auto *special{FindFinal(derived, descriptor.rank())}) {
- // The following code relies on the fact that finalizable objects
- // must be contiguous.
if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
std::size_t byteStride{descriptor.ElementBytes()};
std::size_t elements{descriptor.Elements()};
@@ -150,28 +149,51 @@ static void CallFinalSubroutine(
p(descriptor.OffsetElement<char>(j * byteStride));
}
}
- } else if (special->IsArgDescriptor(0)) {
- StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
- Descriptor &tmpDesc{statDesc.descriptor()};
- tmpDesc = descriptor;
- tmpDesc.raw().attribute = CFI_attribute_pointer;
- tmpDesc.Addendum()->set_derivedType(&derived);
- auto *p{special->GetProc<void (*)(const Descriptor &)>()};
- p(tmpDesc);
} else {
- auto *p{special->GetProc<void (*)(char *)>()};
- p(descriptor.OffsetElement<char>());
+ StaticDescriptor<maxRank, true, 10> statDesc;
+ Descriptor ©{statDesc.descriptor()};
+ const Descriptor *argDescriptor{&descriptor};
+ if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
+ !descriptor.IsContiguous()) {
+ // The FINAL subroutine demands a contiguous array argument, but
+ // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.
+ // Finalize a shallow copy of the data.
+ copy = descriptor;
+ copy.set_base_addr(nullptr);
+ copy.raw().attribute = CFI_attribute_allocatable;
+ Terminator stubTerminator{"CallFinalProcedure() in Fortran runtime", 0};
+ RUNTIME_CHECK(terminator ? *terminator : stubTerminator,
+ copy.Allocate() == CFI_SUCCESS);
+ ShallowCopyDiscontiguousToContiguous(copy, descriptor);
+ argDescriptor = ©
+ }
+ if (special->IsArgDescriptor(0)) {
+ StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
+ Descriptor &tmpDesc{statDesc.descriptor()};
+ tmpDesc = *argDescriptor;
+ tmpDesc.raw().attribute = CFI_attribute_pointer;
+ tmpDesc.Addendum()->set_derivedType(&derived);
+ auto *p{special->GetProc<void (*)(const Descriptor &)>()};
+ p(tmpDesc);
+ } else {
+ auto *p{special->GetProc<void (*)(char *)>()};
+ p(argDescriptor->OffsetElement<char>());
+ }
+ if (argDescriptor == ©) {
+ ShallowCopyContiguousToDiscontiguous(descriptor, copy);
+ copy.Deallocate();
+ }
}
}
}
// Fortran 2018 subclause 7.5.6.2
-void Finalize(
- const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+void Finalize(const Descriptor &descriptor,
+ const typeInfo::DerivedType &derived, Terminator *terminator) {
if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
return;
}
- CallFinalSubroutine(descriptor, derived);
+ CallFinalSubroutine(descriptor, derived, terminator);
const auto *parentType{derived.GetParentType()};
bool recurse{parentType && !parentType->noFinalizationNeeded()};
// If there's a finalizable parent component, handle it last, as required
@@ -181,9 +203,9 @@ void Finalize(
std::size_t myComponents{componentDesc.Elements()};
std::size_t elements{descriptor.Elements()};
std::size_t byteStride{descriptor.ElementBytes()};
- for (auto k{recurse
- ? std::size_t{1} /* skip first component, it's the parent */
- : 0};
+ for (auto k{recurse ? std::size_t{1}
+ /* skip first component, it's the parent */
+ : 0};
k < myComponents; ++k) {
const auto &comp{
*componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
@@ -195,7 +217,7 @@ void Finalize(
const Descriptor &compDesc{*descriptor.OffsetElement<Descriptor>(
j * byteStride + comp.offset())};
if (compDesc.IsAllocated()) {
- Finalize(compDesc, *compType);
+ Finalize(compDesc, *compType, terminator);
}
}
}
@@ -217,12 +239,12 @@ void Finalize(
compDesc.Establish(compType,
descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
comp.rank(), extent);
- Finalize(compDesc, compType);
+ Finalize(compDesc, compType, terminator);
}
}
}
if (recurse) {
- Finalize(descriptor, *parentType);
+ Finalize(descriptor, *parentType, terminator);
}
}
@@ -231,12 +253,12 @@ void Finalize(
// before parent component finalization, and with all finalization
// preceding any deallocation.
void Destroy(const Descriptor &descriptor, bool finalize,
- const typeInfo::DerivedType &derived) {
+ const typeInfo::DerivedType &derived, Terminator *terminator) {
if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
return;
}
if (finalize && !derived.noFinalizationNeeded()) {
- Finalize(descriptor, derived);
+ Finalize(descriptor, derived, terminator);
}
const Descriptor &componentDesc{derived.component()};
std::size_t myComponents{componentDesc.Elements()};
diff --git a/flang/runtime/derived.h b/flang/runtime/derived.h
index 894cdfd9a598c3..747a93303e0dbc 100644
--- a/flang/runtime/derived.h
+++ b/flang/runtime/derived.h
@@ -25,11 +25,13 @@ int Initialize(const Descriptor &, const typeInfo::DerivedType &, Terminator &,
bool hasStat = false, const Descriptor *errMsg = nullptr);
// Call FINAL subroutines, if any
-void Finalize(const Descriptor &, const typeInfo::DerivedType &derived);
+void Finalize(
+ const Descriptor &, const typeInfo::DerivedType &derived, Terminator *);
// Call FINAL subroutines, deallocate allocatable & automatic components.
// Does not deallocate the original descriptor.
-void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &);
+void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &,
+ Terminator *);
// Return true if the passed descriptor is for a derived type
// entity that has a dynamic (allocatable, automatic) component.
diff --git a/flang/runtime/descriptor-io.h b/flang/runtime/descriptor-io.h
index 80b5d87a6efb88..840d73b8e857cf 100644
--- a/flang/runtime/descriptor-io.h
+++ b/flang/runtime/descriptor-io.h
@@ -315,7 +315,8 @@ static bool FormattedDerivedTypeIO(IoStatementState &io,
typeInfo::SpecialBinding special{DIR == Direction::Input
? typeInfo::SpecialBinding::Which::ReadFormatted
: typeInfo::SpecialBinding::Which::WriteFormatted,
- definedIo->subroutine, definedIo->isDtvArgPolymorphic, false};
+ definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
+ false};
if (std::optional<bool> wasDefined{
DefinedFormattedIo(io, descriptor, *type, special)}) {
return *wasDefined;
@@ -359,7 +360,8 @@ static bool UnformattedDescriptorIO(IoStatementState &io,
typeInfo::SpecialBinding special{DIR == Direction::Input
? typeInfo::SpecialBinding::Which::ReadUnformatted
: typeInfo::SpecialBinding::Which::WriteUnformatted,
- definedIo->subroutine, definedIo->isDtvArgPolymorphic, false};
+ definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
+ false};
if (std::optional<bool> wasDefined{
DefinedUnformattedIo(io, descriptor, *type, special)}) {
return *wasDefined;
diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp
index 37d6a504143450..1964a6798776b1 100644
--- a/flang/runtime/descriptor.cpp
+++ b/flang/runtime/descriptor.cpp
@@ -159,14 +159,15 @@ int Descriptor::Allocate() {
return 0;
}
-int Descriptor::Destroy(bool finalize, bool destroyPointers) {
+int Descriptor::Destroy(
+ bool finalize, bool destroyPointers, Terminator *terminator) {
if (!destroyPointers && raw_.attribute == CFI_attribute_pointer) {
return StatOk;
} else {
if (auto *addendum{Addendum()}) {
if (const auto *derived{addendum->derivedType()}) {
if (!derived->noDestructionNeeded()) {
- runtime::Destroy(*this, finalize, *derived);
+ runtime::Destroy(*this, finalize, *derived, terminator);
}
}
}
diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp
index 216e8c70be0299..4024b78c88e33e 100644
--- a/flang/runtime/pointer.cpp
+++ b/flang/runtime/pointer.cpp
@@ -175,7 +175,9 @@ int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat,
if (!pointer.IsAllocated()) {
return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
}
- return ReturnError(terminator, pointer.Destroy(true, true), errMsg, hasStat);
+ return ReturnError(terminator,
+ pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator),
+ errMsg, hasStat);
}
int RTNAME(PointerDeallocatePolymorphic)(Descriptor &pointer,
diff --git a/flang/runtime/tools.cpp b/flang/runtime/tools.cpp
index ccea7956ccae40..36cfa456a08234 100644
--- a/flang/runtime/tools.cpp
+++ b/flang/runtime/tools.cpp
@@ -110,4 +110,63 @@ void CheckIntegerKind(Terminator &terminator, int kind, const char *intrinsic) {
"not yet implemented: %s: KIND=%d argument", intrinsic, kind);
}
}
+
+void ShallowCopyDiscontiguousToDiscontiguous(
+ const Descriptor &to, const Descriptor &from) {
+ SubscriptValue toAt[maxRank], fromAt[maxRank];
+ to.GetLowerBounds(toAt);
+ from.GetLowerBounds(fromAt);
+ std::size_t elementBytes{to.ElementBytes()};
+ for (std::size_t n{to.Elements()}; n-- > 0;
+ to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
+ std::memcpy(
+ to.Element<char>(toAt), from.Element<char>(fromAt), elementBytes);
+ }
+}
+
+void ShallowCopyDiscontiguousToContiguous(
+ const Descriptor &to, const Descriptor &from) {
+ char *toAt{to.OffsetElement()};
+ SubscriptValue fromAt[maxRank];
+ from.GetLowerBounds(fromAt);
+ std::size_t elementBytes{to.ElementBytes()};
+ for (std::size_t n{to.Elements()}; n-- > 0;
+ toAt += elementBytes, from.IncrementSubscripts(fromAt)) {
+ std::memcpy(toAt, from.Element<char>(fromAt), elementBytes);
+ }
+}
+
+void ShallowCopyContiguousToDiscontiguous(
+ const Descriptor &to, const Descriptor &from) {
+ SubscriptValue toAt[maxRank];
+ to.GetLowerBounds(toAt);
+ char *fromAt{from.OffsetElement()};
+ std::size_t elementBytes{to.ElementBytes()};
+ for (std::size_t n{to.Elements()}; n-- > 0;
+ to.IncrementSubscripts(toAt), fromAt += elementBytes) {
+ std::memcpy(to.Element<char>(toAt), fromAt, elementBytes);
+ }
+}
+
+void ShallowCopy(const Descriptor &to, const Descriptor &from,
+ bool toIsContiguous, bool fromIsContiguous) {
+ if (toIsContiguous) {
+ if (fromIsContiguous) {
+ std::memcpy(to.OffsetElement(), from.OffsetElement(),
+ to.Elements() * to.ElementBytes());
+ } else {
+ ShallowCopyDiscontiguousToContiguous(to, from);
+ }
+ } else {
+ if (fromIsContiguous) {
+ ShallowCopyContiguousToDiscontiguous(to, from);
+ } else {
+ ShallowCopyDiscontiguousToDiscontiguous(to, from);
+ }
+ }
+}
+
+void ShallowCopy(const Descriptor &to, const Descriptor &from) {
+ ShallowCopy(to, from, to.IsContiguous(), from.IsContiguous());
+}
} // namespace Fortran::runtime
diff --git a/flang/runtime/tools.h b/flang/runtime/tools.h
index d22093a2ada07c..521dd1e30f81d4 100644
--- a/flang/runtime/tools.h
+++ b/flang/runtime/tools.h
@@ -381,5 +381,18 @@ inline const char *FindCharacter(const char *data, char ch, std::size_t chars) {
std::memchr(data, static_cast<int>(ch), chars));
}
+// Copy payload data from one allocated descriptor to another.
+// Assumes element counts and element sizes match, and that both
+// descriptors are allocated.
+void ShallowCopyDiscontiguousToDiscontiguous(
+ const Descriptor &to, const Descriptor &from);
+void ShallowCopyDiscontiguousToContiguous(
+ const Descriptor &to, const Descriptor &from);
+void ShallowCopyContiguousToDiscontiguous(
+ const Descriptor &to, const Descriptor &from);
+void ShallowCopy(const Descriptor &to, const Descriptor &from,
+ bool toIsContiguous, bool fromIsContiguous);
+void ShallowCopy(const Descriptor &to, const Descriptor &from);
+
} // namespace Fortran::runtime
#endif // FORTRAN_RUNTIME_TOOLS_H_
diff --git a/flang/runtime/type-info.cpp b/flang/runtime/type-info.cpp
index 9b624a664a2f59..5bd0258cbbf7ff 100644
--- a/flang/runtime/type-info.cpp
+++ b/flang/runtime/type-info.cpp
@@ -313,6 +313,8 @@ FILE *SpecialBinding::Dump(FILE *f) const {
break;
}
std::fprintf(f, " isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_);
+ std::fprintf(f, " isTypeBound: 0x%x\n", isTypeBound_);
+ std::fprintf(f, " isArgContiguousSet: 0x%x\n", isArgContiguousSet_);
std::fprintf(f, " proc: %p\n", reinterpret_cast<void *>(proc_));
return f;
}
diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h
index 3e6a51c57a3eac..1f6c56742b6f7c 100644
--- a/flang/runtime/type-info.h
+++ b/flang/runtime/type-info.h
@@ -136,9 +136,10 @@ class SpecialBinding {
// Special bindings can be created during execution to handle defined
// I/O procedures that are not type-bound.
SpecialBinding(Which which, ProcedurePointer proc, std::uint8_t isArgDescSet,
- std::uint8_t isTypeBound)
+ std::uint8_t isTypeBound, std::uint8_t isArgContiguousSet)
: which_{which}, isArgDescriptorSet_{isArgDescSet},
- isTypeBound_{isTypeBound}, proc_{proc} {}
+ isTypeBound_{isTypeBound}, isArgContiguousSet_{isArgContiguousSet},
+ proc_{proc} {}
static constexpr Which RankFinal(int rank) {
return static_cast<Which>(static_cast<int>(Which::ScalarFinal) + rank);
@@ -149,6 +150,9 @@ class SpecialBinding {
return (isArgDescriptorSet_ >> zeroBasedArg) & 1;
}
bool isTypeBound() const { return isTypeBound_; }
+ bool IsArgContiguous(int zeroBasedArg) const {
+ return (isArgContiguousSet_ >> zeroBasedArg) & 1;
+ }
template <typename PROC> PROC GetProc() const {
return reinterpret_cast<PROC>(proc_);
}
@@ -185,6 +189,9 @@ class SpecialBinding {
// called via a generic interface, not a generic TBP.
std::uint8_t isArgDescriptorSet_{0};
std::uint8_t isTypeBound_{0};
+ // True when a FINAL subroutine has a dummy argument that is an array that
+ // is CONTIGUOUS or neither assumed-rank nor assumed-shape.
+ std::uint8_t isArgContiguousSet_{0};
ProcedurePointer proc_{nullptr};
};
diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90
index 336a5cb6236927..bc43bdbfc32fbe 100644
--- a/flang/test/Semantics/typeinfo01.f90
+++ b/flang/test/Semantics/typeinfo01.f90
@@ -88,7 +88,7 @@ subroutine s2(x, y)
!CHECK: .c.t2, SAVE, TARGET (CompilerCreated, ReadOnly): 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 (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,proc=s1)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1)]
!CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
!CHECK: .v.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s2,name=.n.s1)]
end module
@@ -105,14 +105,14 @@ impure elemental subroutine s1(x, y)
class(t), intent(in) :: y
end subroutine
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=4_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,proc=s1)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1)]
!CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): 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
+ final :: s1, s2, s3, s4
end type
contains
subroutine s1(x)
@@ -124,8 +124,11 @@ subroutine s2(x)
impure elemental subroutine s3(x)
type(t), intent(in) :: x
end subroutine
-!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=3200_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,istypebound=1_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,istypebound=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,istypebound=1_1,proc=s2)]
+ subroutine s4(x)
+ type(t), contiguous :: x(:,:,:)
+ end subroutine
+!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=7296_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1)
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,istypebound=1_1,isargcontiguousset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,istypebound=1_1,isargcontiguousset=1_1,proc=s2),specialbinding(which=12_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=1_1,proc=s4)]
end module
module m09
@@ -167,7 +170,7 @@ subroutine wu(x,u,iostat,iomsg)
character(len=*), intent(inout) :: iomsg
end subroutine
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,istypebound=1_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,istypebound=1_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,istypebound=1_1,proc=wu)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wu)]
!CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): 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
@@ -216,7 +219,7 @@ subroutine wu(x,u,iostat,iomsg)
character(len=*), intent(inout) :: iomsg
end subroutine
!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,istypebound=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,istypebound=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,istypebound=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,istypebound=0_1,proc=wu)]
+!CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=wu)]
end module
module m11
@@ -259,7 +262,7 @@ module m13
contains
procedure :: assign1, assign2
generic :: assignment(=) => assign1, assign2
- ! CHECK: .s.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,proc=assign1)]
+ ! CHECK: .s.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=assign1)]
end type
contains
impure elemental subroutine assign1(to, from)
diff --git a/flang/test/Semantics/typeinfo02.f90 b/flang/test/Semantics/typeinfo02.f90
index 35b6bd67462f3a..29d14c7a0f196b 100644
--- a/flang/test/Semantics/typeinfo02.f90
+++ b/flang/test/Semantics/typeinfo02.f90
@@ -29,5 +29,5 @@ subroutine wf2(x,u,iot,v,iostat,iomsg)
character(len=*), intent(inout) :: iomsg
end subroutine
end module
-!CHECK: .s.base, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf1)]
-!CHECK: .s.extended, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,proc=wf2)]
+!CHECK: .s.base, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wf1)]
+!CHECK: .s.extended, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wf2)]
More information about the flang-commits
mailing list