Skip to content

Commit b21c24c

Browse files
klauslerklausler
committed
[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
1 parent ca76281 commit b21c24c

File tree

17 files changed

+218
-89
lines changed

17 files changed

+218
-89
lines changed

‎flang/include/flang/Runtime/descriptor.h

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ class DerivedType;
3636
namespace Fortran::runtime {
3737

3838
using SubscriptValue = ISO::CFI_index_t;
39+
class Terminator;
3940

4041
RT_VAR_GROUP_BEGIN
4142
static constexpr RT_CONST_VAR_ATTRS int maxRank{CFI_MAX_RANK};
@@ -369,7 +370,8 @@ class Descriptor {
369370

370371
// Deallocates storage, including allocatable and automatic
371372
// components. Optionally invokes FINAL subroutines.
372-
RT_API_ATTRS int Destroy(bool finalize = false, bool destroyPointers = false);
373+
RT_API_ATTRS int Destroy(bool finalize = false, bool destroyPointers = false,
374+
Terminator * = nullptr);
373375

374376
RT_API_ATTRS bool IsContiguous(int leadingDimensions = maxRank) const {
375377
auto bytes{static_cast<SubscriptValue>(ElementBytes())};

‎flang/lib/Semantics/runtime-type-info.cpp

Lines changed: 33 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -163,14 +163,14 @@ class RuntimeTableBuilder {
163163
RuntimeTableBuilder::RuntimeTableBuilder(
164164
SemanticsContext &c, RuntimeDerivedTypeTables &t)
165165
: context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},
166-
componentSchema_{GetSchema("component")}, procPtrSchema_{GetSchema(
167-
"procptrcomponent")},
168-
valueSchema_{GetSchema("value")}, bindingSchema_{GetSchema(
169-
bindingDescCompName)},
170-
specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue(
171-
"deferred")},
172-
explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue(
173-
"lenparameter")},
166+
componentSchema_{GetSchema("component")},
167+
procPtrSchema_{GetSchema("procptrcomponent")},
168+
valueSchema_{GetSchema("value")},
169+
bindingSchema_{GetSchema(bindingDescCompName)},
170+
specialSchema_{GetSchema("specialbinding")},
171+
deferredEnum_{GetEnumValue("deferred")},
172+
explicitEnum_{GetEnumValue("explicit")},
173+
lenParameterEnum_{GetEnumValue("lenparameter")},
174174
scalarAssignmentEnum_{GetEnumValue("scalarassignment")},
175175
elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
176176
readFormattedEnum_{GetEnumValue("readformatted")},
@@ -588,8 +588,9 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
588588
DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
589589
if (derivedTypeSpec) {
590590
for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {
591-
DescribeSpecialProc(specials, *ref, false /*!isAssignment*/, true,
592-
std::nullopt, nullptr, derivedTypeSpec, true);
591+
DescribeSpecialProc(specials, *ref, /*isAssignment-*/ false,
592+
/*isFinal=*/true, std::nullopt, nullptr, derivedTypeSpec,
593+
/*isTypeBound=*/true);
593594
}
594595
IncorporateDefinedIoGenericInterfaces(specials,
595596
common::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
@@ -1039,8 +1040,9 @@ void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
10391040
[&](const GenericKind::OtherKind &k) {
10401041
if (k == GenericKind::OtherKind::Assignment) {
10411042
for (auto ref : generic.specificProcs()) {
1042-
DescribeSpecialProc(specials, *ref, true, false /*!final*/,
1043-
std::nullopt, &dtScope, derivedTypeSpec, true);
1043+
DescribeSpecialProc(specials, *ref, /*isAssignment=*/true,
1044+
/*isFinal=*/false, std::nullopt, &dtScope, derivedTypeSpec,
1045+
/*isTypeBound=*/true);
10441046
}
10451047
}
10461048
},
@@ -1051,8 +1053,9 @@ void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
10511053
case common::DefinedIo::WriteFormatted:
10521054
case common::DefinedIo::WriteUnformatted:
10531055
for (auto ref : generic.specificProcs()) {
1054-
DescribeSpecialProc(specials, *ref, false, false /*!final*/, io,
1055-
&dtScope, derivedTypeSpec, true);
1056+
DescribeSpecialProc(specials, *ref, /*isAssignment=*/false,
1057+
/*isFinal=*/false, io, &dtScope, derivedTypeSpec,
1058+
/*isTypeBound=*/true);
10561059
}
10571060
break;
10581061
}
@@ -1076,6 +1079,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
10761079
if (auto proc{evaluate::characteristics::Procedure::Characterize(
10771080
specific, context_.foldingContext())}) {
10781081
std::uint8_t isArgDescriptorSet{0};
1082+
std::uint8_t isArgContiguousSet{0};
10791083
int argThatMightBeDescriptor{0};
10801084
MaybeExpr which;
10811085
if (isAssignment) {
@@ -1115,19 +1119,27 @@ void RuntimeTableBuilder::DescribeSpecialProc(
11151119
if (proc->IsElemental()) {
11161120
which = elementalFinalEnum_;
11171121
} else {
1118-
const auto &typeAndShape{
1122+
const auto &dummyData{
11191123
std::get<evaluate::characteristics::DummyDataObject>(
1120-
proc->dummyArguments.at(0).u)
1121-
.type};
1124+
proc->dummyArguments.at(0).u)};
1125+
const auto &typeAndShape{dummyData.type};
11221126
if (typeAndShape.attrs().test(
11231127
evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
11241128
which = assumedRankFinalEnum_;
11251129
isArgDescriptorSet |= 1;
11261130
} else {
11271131
which = scalarFinalEnum_;
11281132
if (int rank{evaluate::GetRank(typeAndShape.shape())}; rank > 0) {
1129-
argThatMightBeDescriptor = 1;
11301133
which = IntExpr<1>(ToInt64(which).value() + rank);
1134+
if (!proc->dummyArguments[0].CanBePassedViaImplicitInterface()) {
1135+
argThatMightBeDescriptor = 1;
1136+
}
1137+
if (!typeAndShape.attrs().test(evaluate::characteristics::
1138+
TypeAndShape::Attr::AssumedShape) ||
1139+
dummyData.attrs.test(evaluate::characteristics::
1140+
DummyDataObject::Attr::Contiguous)) {
1141+
isArgContiguousSet |= 1;
1142+
}
11311143
}
11321144
}
11331145
}
@@ -1176,6 +1188,8 @@ void RuntimeTableBuilder::DescribeSpecialProc(
11761188
IntExpr<1>(isArgDescriptorSet));
11771189
AddValue(values, specialSchema_, "istypebound"s,
11781190
IntExpr<1>(isTypeBound ? 1 : 0));
1191+
AddValue(values, specialSchema_, "isargcontiguousset"s,
1192+
IntExpr<1>(isArgContiguousSet));
11791193
AddValue(values, specialSchema_, procCompName,
11801194
SomeExpr{evaluate::ProcedureDesignator{specific}});
11811195
// index might already be present in the case of an override
@@ -1219,9 +1233,7 @@ RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
12191233
// dummy argument. Returns a non-null DeclTypeSpec pointer only if that
12201234
// dtv argument exists and is a derived type.
12211235
static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) {
1222-
const Symbol *interface {
1223-
&specific.GetUltimate()
1224-
};
1236+
const Symbol *interface{&specific.GetUltimate()};
12251237
if (const auto *procEntity{specific.detailsIf<ProcEntityDetails>()}) {
12261238
interface = procEntity->procInterface();
12271239
}

‎flang/module/__fortran_type_info.f90

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -109,7 +109,8 @@
109109
integer(1) :: which ! SpecialBinding::Which
110110
integer(1) :: isArgDescriptorSet
111111
integer(1) :: isTypeBound
112-
integer(1) :: __padding0(5)
112+
integer(1) :: isArgContiguousSet
113+
integer(1) :: __padding0(4)
113114
type(__builtin_c_funptr) :: proc
114115
end type
115116

‎flang/runtime/allocatable.cpp

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -78,7 +78,8 @@ std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
7878
}
7979

8080
if (to.IsAllocated()) {
81-
int stat{to.Destroy(/*finalize=*/true)};
81+
int stat{
82+
to.Destroy(/*finalize=*/true, /*destroyPointers=*/false, &terminator)};
8283
if (stat != StatOk) {
8384
return ReturnError(terminator, stat, errMsg, hasStat);
8485
}
@@ -188,7 +189,10 @@ int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
188189
if (!descriptor.IsAllocated()) {
189190
return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
190191
}
191-
return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat);
192+
return ReturnError(terminator,
193+
descriptor.Destroy(
194+
/*finalize=*/true, /*destroyPointers=*/false, &terminator),
195+
errMsg, hasStat);
192196
}
193197

194198
int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
@@ -218,7 +222,9 @@ void RTNAME(AllocatableDeallocateNoFinal)(
218222
} else if (!descriptor.IsAllocated()) {
219223
ReturnError(terminator, StatBaseNull);
220224
} else {
221-
ReturnError(terminator, descriptor.Destroy(false));
225+
ReturnError(terminator,
226+
descriptor.Destroy(
227+
/*finalize=*/false, /*destroyPointers=*/false, &terminator));
222228
}
223229
}
224230

‎flang/runtime/assign.cpp

Lines changed: 10 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@
1111
#include "derived.h"
1212
#include "stat.h"
1313
#include "terminator.h"
14+
#include "tools.h"
1415
#include "type-info.h"
1516
#include "flang/Runtime/descriptor.h"
1617

@@ -299,18 +300,7 @@ static void Assign(
299300
RTNAME(AssignTemporary)
300301
(newFrom, from, terminator.sourceFileName(), terminator.sourceLine());
301302
} else {
302-
char *toAt{newFrom.OffsetElement()};
303-
std::size_t fromElements{from.Elements()};
304-
if (from.IsContiguous()) {
305-
std::memcpy(
306-
toAt, from.OffsetElement(), fromElements * fromElementBytes);
307-
} else {
308-
SubscriptValue fromAt[maxRank];
309-
for (from.GetLowerBounds(fromAt); fromElements-- > 0;
310-
toAt += fromElementBytes, from.IncrementSubscripts(fromAt)) {
311-
std::memcpy(toAt, from.Element<char>(fromAt), fromElementBytes);
312-
}
313-
}
303+
ShallowCopy(newFrom, from, true, from.IsContiguous());
314304
}
315305
Assign(to, newFrom, terminator,
316306
flags &
@@ -325,11 +315,12 @@ static void Assign(
325315
if (mustDeallocateLHS) {
326316
if (deferDeallocation) {
327317
if ((flags & NeedFinalization) && toDerived) {
328-
Finalize(to, *toDerived);
318+
Finalize(to, *toDerived, &terminator);
329319
flags &= ~NeedFinalization;
330320
}
331321
} else {
332-
to.Destroy((flags & NeedFinalization) != 0);
322+
to.Destroy((flags & NeedFinalization) != 0, /*destroyPointers=*/false,
323+
&terminator);
333324
flags &= ~NeedFinalization;
334325
}
335326
} else if (to.rank() != from.rank() && !to.IsAllocated()) {
@@ -394,7 +385,7 @@ static void Assign(
394385
// for all components, including parent components (10.2.1.2-3).
395386
// The target is first finalized if still necessary (7.5.6.3(1))
396387
if (flags & NeedFinalization) {
397-
Finalize(to, *updatedToDerived);
388+
Finalize(to, *updatedToDerived, &terminator);
398389
}
399390
// Copy the data components (incl. the parent) first.
400391
const Descriptor &componentDesc{updatedToDerived->component()};
@@ -467,7 +458,8 @@ static void Assign(
467458
// This is just a shortcut, because the recursive Assign()
468459
// below would initiate the destruction for to.
469460
// No finalization is required.
470-
toDesc->Destroy();
461+
toDesc->Destroy(
462+
/*finalize=*/false, /*destroyPointers=*/false, &terminator);
471463
continue; // F'2018 10.2.1.3(13)(2)
472464
}
473465
}
@@ -526,7 +518,8 @@ static void Assign(
526518
if (deferDeallocation) {
527519
// deferDeallocation is used only when LHS is an allocatable.
528520
// The finalization has already been run for it.
529-
deferDeallocation->Destroy();
521+
deferDeallocation->Destroy(
522+
/*finalize=*/false, /*destroyPointers=*/false, &terminator);
530523
}
531524
}
532525

‎flang/runtime/derived-api.cpp

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,9 @@ void RTNAME(Destroy)(const Descriptor &descriptor) {
3333
if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
3434
if (const auto *derived{addendum->derivedType()}) {
3535
if (!derived->noDestructionNeeded()) {
36-
Destroy(descriptor, true, *derived);
36+
// TODO: Pass source file & line information to the API
37+
// so that a good Terminator can be passed
38+
Destroy(descriptor, true, *derived, nullptr);
3739
}
3840
}
3941
}
@@ -160,7 +162,7 @@ void RTNAME(DestroyWithoutFinalization)(const Descriptor &descriptor) {
160162
if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
161163
if (const auto *derived{addendum->derivedType()}) {
162164
if (!derived->noDestructionNeeded()) {
163-
Destroy(descriptor, /*finalize=*/false, *derived);
165+
Destroy(descriptor, /*finalize=*/false, *derived, nullptr);
164166
}
165167
}
166168
}

0 commit comments

Comments
 (0)