[flang] Fold instantiated PDT character component length when needed

[jeanPerier]

Summary

In case a character component PDT length only depends on kind parameters,
fold it while instantiating the PDT. This is especially important if the
component has an initializer because later semantic phases (offset
computation or runtime type info generation) might get confused and
generate offset/type info that will lead to crashes in lowering.

[klausler]

flang/lib/Semantics/type.cpp

402

Odd formatting without substantive change.

449

The newer IsActuallyConstant() predicate might be better here than ToInt64() since you're changing this line anyway.

[jeanPerier]

Use IsActuallyConstant and make the required instantiation available to the linker.
Revert unrelated format change.

[klausler]

flang/lib/Semantics/type.cpp

433

Typo in name (and also below at the use site): should be FoldCharacterLength with a 'c' before the first 't'.

[jeanPerier]

Fix typo in FoldCharacterLength.

flang/include/flang/Evaluate/check-expression.h

 extern template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
 extern template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
 
 // Predicate: true when an expression actually is a typed Constant<T>,
 // perhaps with parentheses and wrapping around it.  False for all typeless
 // expressions, including BOZ literals.
 template <typename A> bool IsActuallyConstant(const A &);
 extern template bool IsActuallyConstant(const Expr<SomeType> &);
+extern template bool IsActuallyConstant(const Expr<SomeInteger> &);
+extern template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
 
 // Checks whether an expression is an object designator with
 // constant addressing and no vector-valued subscript.
 // If a non-null ContextualMessages pointer is passed, an error message
 // will be generated if and only if the result of the function is false.
 bool IsInitialDataTarget(
     const Expr<SomeType> &, parser::ContextualMessages * = nullptr);
 

flang/lib/Evaluate/check-expression.cpp

struct IsActuallyConstantHelper {
   }
 };
 
 template <typename A> bool IsActuallyConstant(const A &x) {
   return IsActuallyConstantHelper{}(x);
 }
 
 template bool IsActuallyConstant(const Expr<SomeType> &);
+template bool IsActuallyConstant(const Expr<SomeInteger> &);
+template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
 
 // Object pointer initialization checking predicate IsInitialDataTarget().
 // This code determines whether an expression is allowable as the static
 // data address used to initialize a pointer with "=> x".  See C765.
 class IsInitialDataTargetHelper
     : public AllTraverse<IsInitialDataTargetHelper, true> {
 public:
   using Base = AllTraverse<IsInitialDataTargetHelper, true>;

flang/lib/Semantics/type.cpp

if (MaybeExpr & init{details->init()}) {
       init = IsPointer(newSymbol)
           ? Fold(std::move(*init))
           : evaluate::NonPointerInitializationExpr(
                 newSymbol, std::move(*init), foldingContext());
     }
   } else if (auto *procDetails{newSymbol.detailsIf<ProcEntityDetails>()}) {
     // We have a procedure pointer.  Instantiate its return type
     if (const DeclTypeSpec * returnType{InstantiateType(newSymbol)}) {
       ProcInterface &interface{procDetails->interface()};
       if (!interface.symbol()) {
         // Don't change the type for interfaces based on symbols
         interface.set_type(*returnType);
       }
     }
   }
 }
 
if (!type) {
     return &InstantiateIntrinsicType(symbol.name(), *type);
   } else if (type->category() == DeclTypeSpec::ClassStar) {
     return type;
   } else {
     common::die("InstantiateType: %s", type->AsFortran().c_str());
   }
 }
 
+/// Fold explicit length parameters of character components when the explicit
+/// expression is a constant expression (if it only depends on KIND parameters).
+/// Do not fold `character(len=pdt_length)`, even if the length parameter is
+/// constant in the pdt instantiation, in order to avoid losing the information
+/// that the character component is automatic (and must be a descriptor).
+static ParamValue FoldCharacterLength(evaluate::FoldingContext &foldingContext,
+    const CharacterTypeSpec &characterSpec) {
+  if (const auto &len{characterSpec.length().GetExplicit()}) {
+    if (evaluate::IsConstantExpr(*len)) {
+      return ParamValue{evaluate::Fold(foldingContext, common::Clone(*len)),
+          common::TypeParamAttr::Len};
+    }
+  }
+  return characterSpec.length();
+}
+
 // Apply type parameter values to an intrinsic type spec.
 const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
     SourceName symbolName, const DeclTypeSpec &spec) {
   const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())};
-  if (evaluate::ToInt64(intrinsic.kind())) {
+  if (spec.category() != DeclTypeSpec::Character &&
+      evaluate::IsActuallyConstant(intrinsic.kind())) {
     return spec; // KIND is already a known constant
   }
   // The expression was not originally constant, but now it must be so
   // in the context of a parameterized derived type instantiation.
   KindExpr copy{Fold(common::Clone(intrinsic.kind()))};
   int kind{context().GetDefaultKind(intrinsic.category())};
   if (auto value{evaluate::ToInt64(copy)}) {
     if (evaluate::IsValidKindOfIntrinsicType(intrinsic.category(), *value)) {
       kind = *value;
     } else {
       foldingContext().messages().Say(symbolName,
           "KIND parameter value (%jd) of intrinsic type %s "
           "did not resolve to a supported value"_err_en_US,
           *value,
           parser::ToUpperCaseLetters(EnumToString(intrinsic.category())));
     }
   }
   switch (spec.category()) {
   case DeclTypeSpec::Numeric:
     return scope_.MakeNumericType(intrinsic.category(), KindExpr{kind});
   case DeclTypeSpec::Logical:
     return scope_.MakeLogicalType(KindExpr{kind});
   case DeclTypeSpec::Character:
     return scope_.MakeCharacterType(
-        ParamValue{spec.characterTypeSpec().length()}, KindExpr{kind});
+        FoldCharacterLength(foldingContext(), spec.characterTypeSpec()),
+        KindExpr{kind});
   default:
     CRASH_NO_CASE;
   }
 }
 
 DerivedTypeSpec InstantiateHelper::CreateDerivedTypeSpec(
     const DerivedTypeSpec &spec, bool isParentComp) {
   DerivedTypeSpec result{spec};

flang/test/Lower/derived-types-kind-params.f90

 
 contains
 
 ! -----------------------------------------------------------------------------
 !            Test mangling of derived type with kind parameters
 ! -----------------------------------------------------------------------------
 
   ! CHECK-LABEL: func @_QMmPfoo
-  ! CHECK-SAME: !fir.ref<!fir.type<_QMmTtK7K12{c:!fir.array<12x!fir.char<1,?>>
+  ! CHECK-SAME: !fir.ref<!fir.type<_QMmTtK7K12{c:!fir.array<12x!fir.char<1,7>>
   subroutine foo(at)
     type(t(k2=12)) :: at
   end subroutine
 
   ! CHECK-LABEL: func @_QMmPfoo2
-  ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt2K12K13{at:!fir.type<_QMmTtK15K17{c:!fir.array<17x!fir.char<1,?>>}>}>>
+  ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt2K12K13{at:!fir.type<_QMmTtK15K17{c:!fir.array<17x!fir.char<1,15>>}>}>>
   subroutine foo2(at2)
     type(t2(12, 13)) :: at2
   end subroutine
 
   ! CHECK-LABEL: func @_QMmPfoo3
   ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt3K7{at3:!fir.box<!fir.ptr<!fir.type<_QMmTt3K7>>>}>>
   subroutine foo3(at3)
     type(t3(7)) :: at3
   end subroutine
 
   ! CHECK-LABEL: func @_QMmPfoo4
   ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt4KN4{i:f32}>>
   subroutine foo4(at4)
     type(t4(-4)) :: at4
   end subroutine
 end module

flang/test/Semantics/offsets02.f90

subroutine s3
   type(t(2, 10)) :: x3
   !CHECK: DerivedType scope: size=64 alignment=8 instantiation of t(k=4_4,l=20_4)
   !CHECK: a3 size=4 offset=0:
   !CHECK: b3 size=4 offset=4:
   !CHECK: c3 size=32 offset=8:
   !CHECK: d3 size=24 offset=40:
   type(t(4, 20)) :: x4
 end
+
+subroutine s4
+  type t(k)
+    integer, kind :: k
+    character(len=k) :: c
+  end type
+  type(t(7)) :: x4
+  !CHECK: DerivedType scope: size=7 alignment=1 instantiation of t(k=7_4)
+  !CHECK: c size=7 offset=0: ObjectEntity type: CHARACTER(7_4,1)
+end subroutine