[flang] Allow -fdefault-integer-8 with defined I/O (#148927)

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.

Author: klausler

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

@@ -34,11 +34,16 @@ namespace Fortran::runtime::io {
 
 RT_OFFLOAD_API_GROUP_BEGIN
 
+enum NonTbpDefinedIoFlags {
+  IsDtvArgPolymorphic = 1 << 0, // first dummy arg is CLASS(T)
+  DefinedIoInteger8 = 1 << 1, // -fdefault-integer-8 affected UNIT= & IOSTAT=
+};
+
 struct NonTbpDefinedIo {
   const typeInfo::DerivedType &derivedType;
   void (*subroutine)(); // null means no non-TBP defined I/O here
   common::DefinedIo definedIo;
-  bool isDtvArgPolymorphic; // first dummy arg is CLASS(T)
+  std::uint8_t flags;
 };
 
 struct NonTbpDefinedIoTable {

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

@@ -143,23 +143,21 @@ class SpecialBinding {
   // I/O procedures that are not type-bound.
   RT_API_ATTRS SpecialBinding(Which which, ProcedurePointer proc,
       std::uint8_t isArgDescSet, std::uint8_t isTypeBound,
-      std::uint8_t isArgContiguousSet)
+      std::uint8_t specialCaseFlag)
       : which_{which}, isArgDescriptorSet_{isArgDescSet},
-        isTypeBound_{isTypeBound}, isArgContiguousSet_{isArgContiguousSet},
+        isTypeBound_{isTypeBound}, specialCaseFlag_{specialCaseFlag},
         proc_{proc} {}
 
   static constexpr RT_API_ATTRS Which RankFinal(int rank) {
     return static_cast<Which>(static_cast<int>(Which::ScalarFinal) + rank);
   }
 
   RT_API_ATTRS Which which() const { return which_; }
+  RT_API_ATTRS bool specialCaseFlag() const { return specialCaseFlag_; }
   RT_API_ATTRS bool IsArgDescriptor(int zeroBasedArg) const {
     return (isArgDescriptorSet_ >> zeroBasedArg) & 1;
   }
   RT_API_ATTRS bool IsTypeBound() const { return isTypeBound_ != 0; }
-  RT_API_ATTRS bool IsArgContiguous(int zeroBasedArg) const {
-    return (isArgContiguousSet_ >> zeroBasedArg) & 1;
-  }
   template <typename PROC>
   RT_API_ATTRS PROC GetProc(const Binding *bindings = nullptr) const {
     if (bindings && isTypeBound_ > 0) {
@@ -203,10 +201,10 @@ class SpecialBinding {
   // When a special binding is type-bound, this is its binding's index (plus 1,
   // so that 0 signifies that it's not type-bound).
   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};
-
+  // For a FINAL subroutine, set when it has a dummy argument that is an array
+  // that is CONTIGUOUS or neither assumed-rank nor assumed-shape.
+  // For a defined I/O subroutine, set when UNIT= and IOSTAT= are INTEGER(8).
+  std::uint8_t specialCaseFlag_{0};
   ProcedurePointer proc_{nullptr};
 };
 

flang-rt/lib/runtime/derived.cpp

@@ -270,7 +270,7 @@ static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
       StaticDescriptor<maxRank, true, 10> statDesc;
       Descriptor &copy{statDesc.descriptor()};
       const Descriptor *argDescriptor{&descriptor};
-      if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
+      if (descriptor.rank() > 0 && special->specialCaseFlag() &&
           !descriptor.IsContiguous()) {
         // The FINAL subroutine demands a contiguous array argument, but
         // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.

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

@@ -67,13 +67,29 @@ static RT_API_ATTRS Fortran::common::optional<bool> DefinedFormattedIo(
           ioType, io.mutableModes().inNamelist ? "NAMELIST" : "LISTDIRECTED");
       ioTypeLen = runtime::strlen(ioType);
     }
+    // V_LIST= argument
     StaticDescriptor<1, true> vListStatDesc;
     Descriptor &vListDesc{vListStatDesc.descriptor()};
-    vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
-    vListDesc.set_base_addr(edit.vList);
-    vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
-    vListDesc.GetDimension(0).SetByteStride(
-        static_cast<SubscriptValue>(sizeof(int)));
+    bool integer8{special.specialCaseFlag()};
+    std::int64_t vList64[edit.maxVListEntries];
+    if (integer8) {
+      // Convert v_list values to INTEGER(8)
+      for (int j{0}; j < edit.vListEntries; ++j) {
+        vList64[j] = edit.vList[j];
+      }
+      vListDesc.Establish(
+          TypeCategory::Integer, sizeof(std::int64_t), nullptr, 1);
+      vListDesc.set_base_addr(vList64);
+      vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
+      vListDesc.GetDimension(0).SetByteStride(
+          static_cast<SubscriptValue>(sizeof(std::int64_t)));
+    } else {
+      vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
+      vListDesc.set_base_addr(edit.vList);
+      vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
+      vListDesc.GetDimension(0).SetByteStride(
+          static_cast<SubscriptValue>(sizeof(int)));
+    }
     ExternalFileUnit *actualExternal{io.GetExternalFileUnit()};
     ExternalFileUnit *external{actualExternal};
     if (!external) {
@@ -84,8 +100,8 @@ static RT_API_ATTRS Fortran::common::optional<bool> DefinedFormattedIo(
     ChildIo &child{external->PushChildIo(io)};
     // Child formatted I/O is nonadvancing by definition (F'2018 12.6.2.4).
     auto restorer{common::ScopedSet(io.mutableModes().nonAdvancing, true)};
-    int unit{external->unitNumber()};
-    int ioStat{IostatOk};
+    std::int32_t unit{external->unitNumber()};
+    std::int32_t ioStat{IostatOk};
     char ioMsg[100];
     Fortran::common::optional<std::int64_t> startPos;
     if (edit.descriptor == DataEdit::DefinedDerivedType &&
@@ -98,23 +114,45 @@ static RT_API_ATTRS Fortran::common::optional<bool> DefinedFormattedIo(
         derived.binding().OffsetElement<const typeInfo::Binding>()};
     if (special.IsArgDescriptor(0)) {
       // "dtv" argument is "class(t)", pass a descriptor
-      auto *p{special.GetProc<void (*)(const Descriptor &, int &, char *,
-          const Descriptor &, int &, char *, std::size_t, std::size_t)>(
-          bindings)};
       StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
       Descriptor &elementDesc{elementStatDesc.descriptor()};
       elementDesc.Establish(
           derived, nullptr, 0, nullptr, CFI_attribute_pointer);
       elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
-      p(elementDesc, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
-          sizeof ioMsg);
+      if (integer8) { // 64-bit UNIT=/IOSTAT=
+        std::int64_t unit64{unit};
+        std::int64_t ioStat64{ioStat};
+        auto *p{special.GetProc<void (*)(const Descriptor &, std::int64_t &,
+            char *, const Descriptor &, std::int64_t &, char *, std::size_t,
+            std::size_t)>(bindings)};
+        p(elementDesc, unit64, ioType, vListDesc, ioStat64, ioMsg, ioTypeLen,
+            sizeof ioMsg);
+        ioStat = ioStat64;
+      } else { // 32-bit UNIT=/IOSTAT=
+        auto *p{special.GetProc<void (*)(const Descriptor &, std::int32_t &,
+            char *, const Descriptor &, std::int32_t &, char *, std::size_t,
+            std::size_t)>(bindings)};
+        p(elementDesc, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
+            sizeof ioMsg);
+      }
     } else {
       // "dtv" argument is "type(t)", pass a raw pointer
-      auto *p{special.GetProc<void (*)(const void *, int &, char *,
-          const Descriptor &, int &, char *, std::size_t, std::size_t)>(
-          bindings)};
-      p(descriptor.Element<char>(subscripts), unit, ioType, vListDesc, ioStat,
-          ioMsg, ioTypeLen, sizeof ioMsg);
+      if (integer8) { // 64-bit UNIT= and IOSTAT=
+        std::int64_t unit64{unit};
+        std::int64_t ioStat64{ioStat};
+        auto *p{special.GetProc<void (*)(const void *, std::int64_t &, char *,
+            const Descriptor &, std::int64_t &, char *, std::size_t,
+            std::size_t)>(bindings)};
+        p(descriptor.Element<char>(subscripts), unit64, ioType, vListDesc,
+            ioStat64, ioMsg, ioTypeLen, sizeof ioMsg);
+        ioStat = ioStat64;
+      } else { // 32-bit UNIT= and IOSTAT=
+        auto *p{special.GetProc<void (*)(const void *, std::int32_t &, char *,
+            const Descriptor &, std::int32_t &, char *, std::size_t,
+            std::size_t)>(bindings)};
+        p(descriptor.Element<char>(subscripts), unit, ioType, vListDesc, ioStat,
+            ioMsg, ioTypeLen, sizeof ioMsg);
+      }
     }
     handler.Forward(ioStat, ioMsg, sizeof ioMsg);
     external->PopChildIo(child);
@@ -458,11 +496,16 @@ RT_API_ATTRS int DescriptorIoTicket<DIR>::Begin(WorkQueue &workQueue) {
                       ? common::DefinedIo::ReadUnformatted
                       : common::DefinedIo::WriteUnformatted)}) {
             if (definedIo->subroutine) {
+              std::uint8_t isArgDescriptorSet{0};
+              if (definedIo->flags & IsDtvArgPolymorphic) {
+                isArgDescriptorSet = 1;
+              }
               typeInfo::SpecialBinding special{DIR == Direction::Input
                       ? typeInfo::SpecialBinding::Which::ReadUnformatted
                       : typeInfo::SpecialBinding::Which::WriteUnformatted,
-                  definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
-                  false};
+                  definedIo->subroutine, isArgDescriptorSet,
+                  /*IsTypeBound=*/false,
+                  /*specialCaseFlag=*/!!(definedIo->flags & DefinedIoInteger8)};
               if (DefinedUnformattedIo(io_, instance_, *type, special)) {
                 anyIoTookPlace_ = true;
                 return StatOk;
@@ -719,8 +762,11 @@ RT_API_ATTRS int DescriptorIoTicket<DIR>::Begin(WorkQueue &workQueue) {
             nonTbpSpecial_.emplace(DIR == Direction::Input
                     ? typeInfo::SpecialBinding::Which::ReadFormatted
                     : typeInfo::SpecialBinding::Which::WriteFormatted,
-                definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
-                false);
+                definedIo->subroutine,
+                /*isArgDescriptorSet=*/
+                (definedIo->flags & IsDtvArgPolymorphic) ? 1 : 0,
+                /*isTypeBound=*/false,
+                /*specialCaseFlag=*/!!(definedIo->flags & DefinedIoInteger8));
             special_ = &*nonTbpSpecial_;
           }
         }

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

@@ -17,7 +17,7 @@ const NonTbpDefinedIo *NonTbpDefinedIoTable::Find(
   for (const auto *p{item}; j-- > 0; ++p) {
     if (&p->derivedType == &type && p->definedIo == definedIo) {
       return p;
-    } else if (p->isDtvArgPolymorphic) {
+    } else if (p->flags & IsDtvArgPolymorphic) {
       for (const typeInfo::DerivedType *t{type.GetParentType()}; t;
            t = t->GetParentType()) {
         if (&p->derivedType == t && p->definedIo == definedIo) {

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

@@ -330,7 +330,7 @@ FILE *SpecialBinding::Dump(FILE *f) const {
   }
   std::fprintf(f, "    isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_);
   std::fprintf(f, "    isTypeBound: %d\n", isTypeBound_);
-  std::fprintf(f, "    isArgContiguousSet: 0x%x\n", isArgContiguousSet_);
+  std::fprintf(f, "    specialCaseFlag 0x%x\n", specialCaseFlag_);
   std::fprintf(f, "    proc: %p\n", reinterpret_cast<void *>(proc_));
   return f;
 }

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

@@ -52,10 +52,15 @@ constexpr char procCompName[]{"proc"};
 
 SymbolVector CollectBindings(const Scope &dtScope);
 
+enum NonTbpDefinedIoFlags {
+  IsDtvArgPolymorphic = 1 << 0,
+  DefinedIoInteger8 = 1 << 1,
+};
+
 struct NonTbpDefinedIo {
   const Symbol *subroutine;
   common::DefinedIo definedIo;
-  bool isDtvArgPolymorphic;
+  std::uint8_t flags;
 };
 
 std::multimap<const Symbol *, NonTbpDefinedIo>

flang/lib/Lower/IO.cpp

@@ -269,10 +269,12 @@ getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter,
   mlir::Type sizeTy =
       fir::runtime::getModel<std::size_t>()(builder.getContext());
   mlir::Type intTy = fir::runtime::getModel<int>()(builder.getContext());
+  mlir::Type byteTy =
+      fir::runtime::getModel<std::uint8_t>()(builder.getContext());
   mlir::Type boolTy = fir::runtime::getModel<bool>()(builder.getContext());
   mlir::Type listTy = fir::SequenceType::get(
       definedIoProcMap.size(),
-      mlir::TupleType::get(context, {refTy, refTy, intTy, boolTy}));
+      mlir::TupleType::get(context, {refTy, refTy, intTy, byteTy}));
   mlir::Type tableTy = mlir::TupleType::get(
       context, {sizeTy, fir::ReferenceType::get(listTy), boolTy});
 
@@ -339,9 +341,9 @@ getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter,
       insert(builder.createIntegerConstant(
           loc, intTy, static_cast<int>(iface.second.definedIo)));
       // polymorphic flag is set if first defined IO dummy arg is CLASS(T)
+      // defaultInt8 flag is set if -fdefined-integer-8
       // [bool isDtvArgPolymorphic]
-      insert(builder.createIntegerConstant(loc, boolTy,
-                                           iface.second.isDtvArgPolymorphic));
+      insert(builder.createIntegerConstant(loc, byteTy, iface.second.flags));
     }
     if (tableIsLocal)
       builder.create<fir::StoreOp>(loc, list, listAddr);

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

@@ -1131,7 +1131,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
   if (auto proc{evaluate::characteristics::Procedure::Characterize(
           specific, context_.foldingContext())}) {
     std::uint8_t isArgDescriptorSet{0};
-    std::uint8_t isArgContiguousSet{0};
+    bool specialCaseFlag{0};
     int argThatMightBeDescriptor{0};
     MaybeExpr which;
     if (isAssignment) {
@@ -1197,7 +1197,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
                         TypeAndShape::Attr::AssumedShape) ||
                 dummyData.attrs.test(evaluate::characteristics::
                         DummyDataObject::Attr::Contiguous)) {
-              isArgContiguousSet |= 1;
+              specialCaseFlag = true;
             }
           }
         }
@@ -1216,7 +1216,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
         return;
       }
       if (ddo->type.type().IsPolymorphic()) {
-        isArgDescriptorSet |= 1;
+        argThatMightBeDescriptor = 1;
       }
       switch (io.value()) {
       case common::DefinedIo::ReadFormatted:
@@ -1232,6 +1232,9 @@ void RuntimeTableBuilder::DescribeSpecialProc(
         which = writeUnformattedEnum_;
         break;
       }
+      if (context_.defaultKinds().GetDefaultKind(TypeCategory::Integer) == 8) {
+        specialCaseFlag = true; // UNIT= & IOSTAT= INTEGER(8)
+      }
     }
     if (argThatMightBeDescriptor != 0) {
       if (const auto *dummyData{
@@ -1262,8 +1265,8 @@ void RuntimeTableBuilder::DescribeSpecialProc(
     }
     CHECK(bindingIndex <= 255);
     AddValue(values, specialSchema_, "istypebound"s, IntExpr<1>(bindingIndex));
-    AddValue(values, specialSchema_, "isargcontiguousset"s,
-        IntExpr<1>(isArgContiguousSet));
+    AddValue(values, specialSchema_, "specialcaseflag"s,
+        IntExpr<1>(specialCaseFlag));
     AddValue(values, specialSchema_, procCompName,
         SomeExpr{evaluate::ProcedureDesignator{specific}});
     // index might already be present in the case of an override
@@ -1383,19 +1386,26 @@ CollectNonTbpDefinedIoGenericInterfaces(
               } else {
                 // Local scope's specific overrides host's for this type
                 bool updated{false};
+                std::uint8_t flags{0};
+                if (declType->IsPolymorphic()) {
+                  flags |= IsDtvArgPolymorphic;
+                }
+                if (scope.context().GetDefaultKind(TypeCategory::Integer) ==
+                    8) {
+                  flags |= DefinedIoInteger8;
+                }
                 for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end;
                      ++iter) {
                   NonTbpDefinedIo &nonTbp{iter->second};
                   if (nonTbp.definedIo == which) {
                     nonTbp.subroutine = &*specific;
-                    nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic();
+                    nonTbp.flags = flags;
                     updated = true;
                   }
                 }
                 if (!updated) {
-                  result.emplace(dtDesc,
-                      NonTbpDefinedIo{
-                          &*specific, which, declType->IsPolymorphic()});
+                  result.emplace(
+                      dtDesc, NonTbpDefinedIo{&*specific, which, flags});
                 }
               }
             }

flang/module/__fortran_type_info.f90

@@ -118,7 +118,7 @@
     integer(1) :: which ! SpecialBinding::Which
     integer(1) :: isArgDescriptorSet
     integer(1) :: isTypeBound ! binding index + 1, if any
-    integer(1) :: isArgContiguousSet
+    integer(1) :: specialCaseFlag
     integer(1) :: __padding0(4)
     type(__builtin_c_funptr) :: proc
   end type