Skip to content

Commit 1a581cc

Browse files
klauslerklausler
committed
[flang] Allow -fdefault-integer-8 with defined I/O
Defined I/O subroutines have UNIT= and IOSTAT= dummy arguments that are required to have type INTEGER with its default kind. When that default kind is modified via -fdefault-integer-8, calls to defined I/O subroutines from the runtime don't work. Add a flag to the two data structures shared between the compiler and the runtime support library to indicate that a defined I/O subroutine was compiled under -fdefault-integer-8. This has been done in a compatible manner, so that existing binaries are compatible with the new library and new binaries are compatible with the old library, unless of course -fdefault-integer-8 is used. Fixes #148638.
1 parent 5c4877e commit 1a581cc

File tree

17 files changed

+164
-98
lines changed

17 files changed

+164
-98
lines changed

‎flang-rt/include/flang-rt/runtime/non-tbp-dio.h

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -34,11 +34,16 @@ namespace Fortran::runtime::io {
3434

3535
RT_OFFLOAD_API_GROUP_BEGIN
3636

37+
enum NonTbpDefinedIoFlags {
38+
IsDtvArgPolymorphic = 1 << 0, // first dummy arg is CLASS(T)
39+
DefinedIoInteger8 = 1 << 1, // -fdefault-integer-8 affected UNIT= & IOSTAT=
40+
};
41+
3742
struct NonTbpDefinedIo {
3843
const typeInfo::DerivedType &derivedType;
3944
void (*subroutine)(); // null means no non-TBP defined I/O here
4045
common::DefinedIo definedIo;
41-
bool isDtvArgPolymorphic; // first dummy arg is CLASS(T)
46+
std::uint8_t flags;
4247
};
4348

4449
struct NonTbpDefinedIoTable {

‎flang-rt/include/flang-rt/runtime/type-info.h

Lines changed: 7 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -143,23 +143,21 @@ class SpecialBinding {
143143
// I/O procedures that are not type-bound.
144144
RT_API_ATTRS SpecialBinding(Which which, ProcedurePointer proc,
145145
std::uint8_t isArgDescSet, std::uint8_t isTypeBound,
146-
std::uint8_t isArgContiguousSet)
146+
std::uint8_t specialCaseFlag)
147147
: which_{which}, isArgDescriptorSet_{isArgDescSet},
148-
isTypeBound_{isTypeBound}, isArgContiguousSet_{isArgContiguousSet},
148+
isTypeBound_{isTypeBound}, specialCaseFlag_{specialCaseFlag},
149149
proc_{proc} {}
150150

151151
static constexpr RT_API_ATTRS Which RankFinal(int rank) {
152152
return static_cast<Which>(static_cast<int>(Which::ScalarFinal) + rank);
153153
}
154154

155155
RT_API_ATTRS Which which() const { return which_; }
156+
RT_API_ATTRS bool specialCaseFlag() const { return specialCaseFlag_; }
156157
RT_API_ATTRS bool IsArgDescriptor(int zeroBasedArg) const {
157158
return (isArgDescriptorSet_ >> zeroBasedArg) & 1;
158159
}
159160
RT_API_ATTRS bool IsTypeBound() const { return isTypeBound_ != 0; }
160-
RT_API_ATTRS bool IsArgContiguous(int zeroBasedArg) const {
161-
return (isArgContiguousSet_ >> zeroBasedArg) & 1;
162-
}
163161
template <typename PROC>
164162
RT_API_ATTRS PROC GetProc(const Binding *bindings = nullptr) const {
165163
if (bindings && isTypeBound_ > 0) {
@@ -203,10 +201,10 @@ class SpecialBinding {
203201
// When a special binding is type-bound, this is its binding's index (plus 1,
204202
// so that 0 signifies that it's not type-bound).
205203
std::uint8_t isTypeBound_{0};
206-
// True when a FINAL subroutine has a dummy argument that is an array that
207-
// is CONTIGUOUS or neither assumed-rank nor assumed-shape.
208-
std::uint8_t isArgContiguousSet_{0};
209-
204+
// For a FINAL subroutine, set when it has a dummy argument that is an array
205+
// that is CONTIGUOUS or neither assumed-rank nor assumed-shape.
206+
// For a defined I/O subroutine, set when UNIT= and IOSTAT= are INTEGER(8).
207+
std::uint8_t specialCaseFlag_{0};
210208
ProcedurePointer proc_{nullptr};
211209
};
212210

‎flang-rt/lib/runtime/derived.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -270,7 +270,7 @@ static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
270270
StaticDescriptor<maxRank, true, 10> statDesc;
271271
Descriptor &copy{statDesc.descriptor()};
272272
const Descriptor *argDescriptor{&descriptor};
273-
if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
273+
if (descriptor.rank() > 0 && special->specialCaseFlag() &&
274274
!descriptor.IsContiguous()) {
275275
// The FINAL subroutine demands a contiguous array argument, but
276276
// this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.

‎flang-rt/lib/runtime/descriptor-io.cpp

Lines changed: 67 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -67,13 +67,29 @@ static RT_API_ATTRS Fortran::common::optional<bool> DefinedFormattedIo(
6767
ioType, io.mutableModes().inNamelist ? "NAMELIST" : "LISTDIRECTED");
6868
ioTypeLen = runtime::strlen(ioType);
6969
}
70+
// V_LIST= argument
7071
StaticDescriptor<1, true> vListStatDesc;
7172
Descriptor &vListDesc{vListStatDesc.descriptor()};
72-
vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
73-
vListDesc.set_base_addr(edit.vList);
74-
vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
75-
vListDesc.GetDimension(0).SetByteStride(
76-
static_cast<SubscriptValue>(sizeof(int)));
73+
bool integer8{special.specialCaseFlag()};
74+
std::int64_t vList64[edit.maxVListEntries];
75+
if (integer8) {
76+
// Convert v_list values to INTEGER(8)
77+
for (int j{0}; j < edit.vListEntries; ++j) {
78+
vList64[j] = edit.vList[j];
79+
}
80+
vListDesc.Establish(
81+
TypeCategory::Integer, sizeof(std::int64_t), nullptr, 1);
82+
vListDesc.set_base_addr(vList64);
83+
vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
84+
vListDesc.GetDimension(0).SetByteStride(
85+
static_cast<SubscriptValue>(sizeof(std::int64_t)));
86+
} else {
87+
vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
88+
vListDesc.set_base_addr(edit.vList);
89+
vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
90+
vListDesc.GetDimension(0).SetByteStride(
91+
static_cast<SubscriptValue>(sizeof(int)));
92+
}
7793
ExternalFileUnit *actualExternal{io.GetExternalFileUnit()};
7894
ExternalFileUnit *external{actualExternal};
7995
if (!external) {
@@ -84,8 +100,8 @@ static RT_API_ATTRS Fortran::common::optional<bool> DefinedFormattedIo(
84100
ChildIo &child{external->PushChildIo(io)};
85101
// Child formatted I/O is nonadvancing by definition (F'2018 12.6.2.4).
86102
auto restorer{common::ScopedSet(io.mutableModes().nonAdvancing, true)};
87-
int unit{external->unitNumber()};
88-
int ioStat{IostatOk};
103+
std::int32_t unit{external->unitNumber()};
104+
std::int32_t ioStat{IostatOk};
89105
char ioMsg[100];
90106
Fortran::common::optional<std::int64_t> startPos;
91107
if (edit.descriptor == DataEdit::DefinedDerivedType &&
@@ -98,23 +114,45 @@ static RT_API_ATTRS Fortran::common::optional<bool> DefinedFormattedIo(
98114
derived.binding().OffsetElement<const typeInfo::Binding>()};
99115
if (special.IsArgDescriptor(0)) {
100116
// "dtv" argument is "class(t)", pass a descriptor
101-
auto *p{special.GetProc<void (*)(const Descriptor &, int &, char *,
102-
const Descriptor &, int &, char *, std::size_t, std::size_t)>(
103-
bindings)};
104117
StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
105118
Descriptor &elementDesc{elementStatDesc.descriptor()};
106119
elementDesc.Establish(
107120
derived, nullptr, 0, nullptr, CFI_attribute_pointer);
108121
elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
109-
p(elementDesc, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
110-
sizeof ioMsg);
122+
if (integer8) { // 64-bit UNIT=/IOSTAT=
123+
std::int64_t unit64{unit};
124+
std::int64_t ioStat64{ioStat};
125+
auto *p{special.GetProc<void (*)(const Descriptor &, std::int64_t &,
126+
char *, const Descriptor &, std::int64_t &, char *, std::size_t,
127+
std::size_t)>(bindings)};
128+
p(elementDesc, unit64, ioType, vListDesc, ioStat64, ioMsg, ioTypeLen,
129+
sizeof ioMsg);
130+
ioStat = ioStat64;
131+
} else { // 32-bit UNIT=/IOSTAT=
132+
auto *p{special.GetProc<void (*)(const Descriptor &, std::int32_t &,
133+
char *, const Descriptor &, std::int32_t &, char *, std::size_t,
134+
std::size_t)>(bindings)};
135+
p(elementDesc, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
136+
sizeof ioMsg);
137+
}
111138
} else {
112139
// "dtv" argument is "type(t)", pass a raw pointer
113-
auto *p{special.GetProc<void (*)(const void *, int &, char *,
114-
const Descriptor &, int &, char *, std::size_t, std::size_t)>(
115-
bindings)};
116-
p(descriptor.Element<char>(subscripts), unit, ioType, vListDesc, ioStat,
117-
ioMsg, ioTypeLen, sizeof ioMsg);
140+
if (integer8) { // 64-bit UNIT= and IOSTAT=
141+
std::int64_t unit64{unit};
142+
std::int64_t ioStat64{ioStat};
143+
auto *p{special.GetProc<void (*)(const void *, std::int64_t &, char *,
144+
const Descriptor &, std::int64_t &, char *, std::size_t,
145+
std::size_t)>(bindings)};
146+
p(descriptor.Element<char>(subscripts), unit64, ioType, vListDesc,
147+
ioStat64, ioMsg, ioTypeLen, sizeof ioMsg);
148+
ioStat = ioStat64;
149+
} else { // 32-bit UNIT= and IOSTAT=
150+
auto *p{special.GetProc<void (*)(const void *, std::int32_t &, char *,
151+
const Descriptor &, std::int32_t &, char *, std::size_t,
152+
std::size_t)>(bindings)};
153+
p(descriptor.Element<char>(subscripts), unit, ioType, vListDesc, ioStat,
154+
ioMsg, ioTypeLen, sizeof ioMsg);
155+
}
118156
}
119157
handler.Forward(ioStat, ioMsg, sizeof ioMsg);
120158
external->PopChildIo(child);
@@ -458,11 +496,16 @@ RT_API_ATTRS int DescriptorIoTicket<DIR>::Begin(WorkQueue &workQueue) {
458496
? common::DefinedIo::ReadUnformatted
459497
: common::DefinedIo::WriteUnformatted)}) {
460498
if (definedIo->subroutine) {
499+
std::uint8_t isArgDescriptorSet{0};
500+
if (definedIo->flags & IsDtvArgPolymorphic) {
501+
isArgDescriptorSet = 1;
502+
}
461503
typeInfo::SpecialBinding special{DIR == Direction::Input
462504
? typeInfo::SpecialBinding::Which::ReadUnformatted
463505
: typeInfo::SpecialBinding::Which::WriteUnformatted,
464-
definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
465-
false};
506+
definedIo->subroutine, isArgDescriptorSet,
507+
/*IsTypeBound=*/false,
508+
/*specialCaseFlag=*/!!(definedIo->flags & DefinedIoInteger8)};
466509
if (DefinedUnformattedIo(io_, instance_, *type, special)) {
467510
anyIoTookPlace_ = true;
468511
return StatOk;
@@ -719,8 +762,11 @@ RT_API_ATTRS int DescriptorIoTicket<DIR>::Begin(WorkQueue &workQueue) {
719762
nonTbpSpecial_.emplace(DIR == Direction::Input
720763
? typeInfo::SpecialBinding::Which::ReadFormatted
721764
: typeInfo::SpecialBinding::Which::WriteFormatted,
722-
definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
723-
false);
765+
definedIo->subroutine,
766+
/*isArgDescriptorSet=*/
767+
(definedIo->flags & IsDtvArgPolymorphic) ? 1 : 0,
768+
/*isTypeBound=*/false,
769+
/*specialCaseFlag=*/!!(definedIo->flags & DefinedIoInteger8));
724770
special_ = &*nonTbpSpecial_;
725771
}
726772
}

‎flang-rt/lib/runtime/non-tbp-dio.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ const NonTbpDefinedIo *NonTbpDefinedIoTable::Find(
1717
for (const auto *p{item}; j-- > 0; ++p) {
1818
if (&p->derivedType == &type && p->definedIo == definedIo) {
1919
return p;
20-
} else if (p->isDtvArgPolymorphic) {
20+
} else if (p->flags & IsDtvArgPolymorphic) {
2121
for (const typeInfo::DerivedType *t{type.GetParentType()}; t;
2222
t = t->GetParentType()) {
2323
if (&p->derivedType == t && p->definedIo == definedIo) {

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -330,7 +330,7 @@ FILE *SpecialBinding::Dump(FILE *f) const {
330330
}
331331
std::fprintf(f, " isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_);
332332
std::fprintf(f, " isTypeBound: %d\n", isTypeBound_);
333-
std::fprintf(f, " isArgContiguousSet: 0x%x\n", isArgContiguousSet_);
333+
std::fprintf(f, " specialCaseFlag 0x%x\n", specialCaseFlag_);
334334
std::fprintf(f, " proc: %p\n", reinterpret_cast<void *>(proc_));
335335
return f;
336336
}

‎flang/include/flang/Semantics/runtime-type-info.h

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -52,10 +52,15 @@ constexpr char procCompName[]{"proc"};
5252

5353
SymbolVector CollectBindings(const Scope &dtScope);
5454

55+
enum NonTbpDefinedIoFlags {
56+
IsDtvArgPolymorphic = 1 << 0,
57+
DefinedIoInteger8 = 1 << 1,
58+
};
59+
5560
struct NonTbpDefinedIo {
5661
const Symbol *subroutine;
5762
common::DefinedIo definedIo;
58-
bool isDtvArgPolymorphic;
63+
std::uint8_t flags;
5964
};
6065

6166
std::multimap<const Symbol *, NonTbpDefinedIo>

‎flang/lib/Lower/IO.cpp

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -269,10 +269,12 @@ getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter,
269269
mlir::Type sizeTy =
270270
fir::runtime::getModel<std::size_t>()(builder.getContext());
271271
mlir::Type intTy = fir::runtime::getModel<int>()(builder.getContext());
272+
mlir::Type byteTy =
273+
fir::runtime::getModel<std::uint8_t>()(builder.getContext());
272274
mlir::Type boolTy = fir::runtime::getModel<bool>()(builder.getContext());
273275
mlir::Type listTy = fir::SequenceType::get(
274276
definedIoProcMap.size(),
275-
mlir::TupleType::get(context, {refTy, refTy, intTy, boolTy}));
277+
mlir::TupleType::get(context, {refTy, refTy, intTy, byteTy}));
276278
mlir::Type tableTy = mlir::TupleType::get(
277279
context, {sizeTy, fir::ReferenceType::get(listTy), boolTy});
278280

@@ -339,9 +341,9 @@ getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter,
339341
insert(builder.createIntegerConstant(
340342
loc, intTy, static_cast<int>(iface.second.definedIo)));
341343
// polymorphic flag is set if first defined IO dummy arg is CLASS(T)
344+
// defaultInt8 flag is set if -fdefined-integer-8
342345
// [bool isDtvArgPolymorphic]
343-
insert(builder.createIntegerConstant(loc, boolTy,
344-
iface.second.isDtvArgPolymorphic));
346+
insert(builder.createIntegerConstant(loc, byteTy, iface.second.flags));
345347
}
346348
if (tableIsLocal)
347349
builder.create<fir::StoreOp>(loc, list, listAddr);

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

Lines changed: 19 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1131,7 +1131,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
11311131
if (auto proc{evaluate::characteristics::Procedure::Characterize(
11321132
specific, context_.foldingContext())}) {
11331133
std::uint8_t isArgDescriptorSet{0};
1134-
std::uint8_t isArgContiguousSet{0};
1134+
bool specialCaseFlag{0};
11351135
int argThatMightBeDescriptor{0};
11361136
MaybeExpr which;
11371137
if (isAssignment) {
@@ -1197,7 +1197,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
11971197
TypeAndShape::Attr::AssumedShape) ||
11981198
dummyData.attrs.test(evaluate::characteristics::
11991199
DummyDataObject::Attr::Contiguous)) {
1200-
isArgContiguousSet |= 1;
1200+
specialCaseFlag = true;
12011201
}
12021202
}
12031203
}
@@ -1216,7 +1216,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
12161216
return;
12171217
}
12181218
if (ddo->type.type().IsPolymorphic()) {
1219-
isArgDescriptorSet |= 1;
1219+
argThatMightBeDescriptor = 1;
12201220
}
12211221
switch (io.value()) {
12221222
case common::DefinedIo::ReadFormatted:
@@ -1232,6 +1232,9 @@ void RuntimeTableBuilder::DescribeSpecialProc(
12321232
which = writeUnformattedEnum_;
12331233
break;
12341234
}
1235+
if (context_.defaultKinds().GetDefaultKind(TypeCategory::Integer) == 8) {
1236+
specialCaseFlag = true; // UNIT= & IOSTAT= INTEGER(8)
1237+
}
12351238
}
12361239
if (argThatMightBeDescriptor != 0) {
12371240
if (const auto *dummyData{
@@ -1262,8 +1265,8 @@ void RuntimeTableBuilder::DescribeSpecialProc(
12621265
}
12631266
CHECK(bindingIndex <= 255);
12641267
AddValue(values, specialSchema_, "istypebound"s, IntExpr<1>(bindingIndex));
1265-
AddValue(values, specialSchema_, "isargcontiguousset"s,
1266-
IntExpr<1>(isArgContiguousSet));
1268+
AddValue(values, specialSchema_, "specialcaseflag"s,
1269+
IntExpr<1>(specialCaseFlag));
12671270
AddValue(values, specialSchema_, procCompName,
12681271
SomeExpr{evaluate::ProcedureDesignator{specific}});
12691272
// index might already be present in the case of an override
@@ -1383,19 +1386,26 @@ CollectNonTbpDefinedIoGenericInterfaces(
13831386
} else {
13841387
// Local scope's specific overrides host's for this type
13851388
bool updated{false};
1389+
std::uint8_t flags{0};
1390+
if (declType->IsPolymorphic()) {
1391+
flags |= IsDtvArgPolymorphic;
1392+
}
1393+
if (scope.context().GetDefaultKind(TypeCategory::Integer) ==
1394+
8) {
1395+
flags |= DefinedIoInteger8;
1396+
}
13861397
for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end;
13871398
++iter) {
13881399
NonTbpDefinedIo &nonTbp{iter->second};
13891400
if (nonTbp.definedIo == which) {
13901401
nonTbp.subroutine = &*specific;
1391-
nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic();
1402+
nonTbp.flags = flags;
13921403
updated = true;
13931404
}
13941405
}
13951406
if (!updated) {
1396-
result.emplace(dtDesc,
1397-
NonTbpDefinedIo{
1398-
&*specific, which, declType->IsPolymorphic()});
1407+
result.emplace(
1408+
dtDesc, NonTbpDefinedIo{&*specific, which, flags});
13991409
}
14001410
}
14011411
}

‎flang/module/__fortran_type_info.f90

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -118,7 +118,7 @@
118118
integer(1) :: which ! SpecialBinding::Which
119119
integer(1) :: isArgDescriptorSet
120120
integer(1) :: isTypeBound ! binding index + 1, if any
121-
integer(1) :: isArgContiguousSet
121+
integer(1) :: specialCaseFlag
122122
integer(1) :: __padding0(4)
123123
type(__builtin_c_funptr) :: proc
124124
end type

0 commit comments

Comments
 (0)