[flang] Improve constant folding for type parameter inquiries

[PeteSteinfeld]

Summary

We were not folding type parameter inquiries for the form 'var%typeParam'
where 'typeParam' was a KIND or LEN type parameter of a derived type and 'var'
was a designator of the derived type. I fixed this by adding code to the
function 'FoldOperation()' for 'TypeParamInquiry's to handle this case. I also
cleaned up the code for the case where there is no designator.

In order to make the error messages correctly refer to both the points of
declaration and instantiation, I needed to add an argument to the function
'InstantiateIntrinsicType()' for the location of the instantiation.

I also changed the formatting of 'TypeParamInquiry' to correctly format this
case. I also added tests for both KIND and LEN type parameter inquiries in
resolve104.f90.

Making these changes revealed an error in resolve89.f90 and caused one of the
error messages in assign04.f90 to be different.

[klausler]

flang/lib/Evaluate/fold-integer.cpp

664

LEN type parameter inquiries are not safe to fold in all cases; the actual LEN parameter expression may not be constant. Consider

subroutine foo(n)
  type :: t(len)
  integer, len :: len
  end type t
  type(t(n)) :: x
  n = n + 1
  print *, x%len
end

The value of x%len at its point of use needs to return the original value of the dummy argument, not its later updated value.

In general, folding type parameter inquiries can be done only for KIND= parameters and for LEN= parameters whose expressions are constant expressions.

[PeteSteinfeld]

Yes, the value of the type parameter is derived from the associated object at the time that the object is instantiated. I believe that the current code is folding the value of the type parameter from the instantiated value. Here's a modified version of your example that illustrates that:

subroutine foo(n)
  type :: t(len)
  integer, len :: len
  end type t

  type(t(n)) :: x1
  real(x1%len) :: r1 ! Error since the KIND of r1 isn't constant
  type(t(4)) :: x2
  real(x2%len) :: r2

  block
    real(x2%len) :: r3 ! OK, the KIND of r3 is x2%len, which is folded to 4
  end block
  n = 99
  block
    real(x2%len) :: r4 ! Still OK, because the x2%len gets folded to 4
  end block
end

[klausler]

In D99892#2669498, @PeteSteinfeld wrote:

Yes, the value of the type parameter is derived from the associated object at the time that the object is instantiated. I believe that the current code is folding the value of the type parameter from the instantiated value. Here's a modified version of your example that illustrates that:

subroutine foo(n)
  type :: t(len)
  integer, len :: len
  end type t

  type(t(n)) :: x1
  real(x1%len) :: r1 ! Error since the KIND of r1 isn't constant
  type(t(4)) :: x2
  real(x2%len) :: r2

  block
    real(x2%len) :: r3 ! OK, the KIND of r3 is x2%len, which is folded to 4
  end block
  n = 99
  block
    real(x2%len) :: r4 ! Still OK, because the x2%len gets folded to 4
  end block
end

You're using non-constant expressions to define the LEN type parameter and then catching the error in the outer context, which requires a constant expression. But what about cases where a non-constant expression is used to define a LEN type parameter that is referenced in a context that does not require a constant expression? If the type parameter inquiry is replaced with the actual parameter expression, we'll produce bad results.

subroutine foo(n)
  type :: t(len)
    integer, len :: len
  end type
  type(t(n)) :: x
  print *, x%len
  n = n + 1
  print *, x%len   ! <--- must not be changed due to modification to 'n'
end subroutine

[PeteSteinfeld]

flang/lib/Evaluate/fold-integer.cpp

664

D'oh! I had intended for this new code to be specific to constant expressions, and I just realized that I didn't test for that. Stay tuned for an update.

[PeteSteinfeld]

Responding to Peter's comments to make these changes specific to constant
expressions.

[kiranchandramohan]

We have a buildbot CI failure due to this patch.
https://lab.llvm.org/buildbot/#/builders/33/builds/3463

FAILED: lib/libFortranEvaluate.so.13git 
: && /usr/bin/clang++-10 -fPIC -stdlib=libc++ -fPIC -fvisibility-inlines-hidden -Werror=date-time -Werror=unguarded-availability-new -Wall -Wextra -Wno-unused-parameter -Wwrite-strings -Wcast-qual -Wmissing-field-initializers -pedantic -Wno-long-long -Wc++98-compat-extra-semi -Wimplicit-fallthrough -Wcovered-switch-default -Wno-noexcept-type -Wnon-virtual-dtor -Wdelete-non-virtual-dtor -Wstring-conversion -fdiagnostics-color -ffunction-sections -fdata-sections -Werror -Wno-deprecated-copy -Wno-string-conversion -Wno-unused-command-line-argument -Wstring-conversion           -Wcovered-switch-default -Wno-nested-anon-types -O3  -stdlib=libc++ -Wl,-z,defs -Wl,-z,nodelete   -Wl,-rpath-link,/home/flang/flang-aarch64-ubuntu-clang/flang-aarch64-ubuntu-clang/build/./lib  -Wl,-O3 -Wl,--gc-sections -shared -Wl,-soname,libFortranEvaluate.so.13git -o lib/libFortranEvaluate.so.13git tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/call.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/characteristics.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/check-expression.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/common.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/complex.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/constant.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/expression.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold-character.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold-complex.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold-designator.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold-integer.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold-logical.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold-real.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/formatting.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/host.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/initial-image.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/integer.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/intrinsics.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/intrinsics-library.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/logical.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/real.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/shape.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/static-data.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/tools.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/type.cpp.o tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/variable.cpp.o  -Wl,-rpath,"\$ORIGIN/../lib"  lib/libFortranDecimal.so.13git  lib/libFortranParser.so.13git  lib/libFortranCommon.so.13git  lib/libLLVMSupport.so.13git  -Wl,-rpath-link,/home/flang/flang-aarch64-ubuntu-clang/flang-aarch64-ubuntu-clang/build/lib && :
/usr/bin/ld: tools/flang/lib/Evaluate/CMakeFiles/obj.FortranEvaluate.dir/fold-integer.cpp.o: in function `Fortran::evaluate::FoldOperation(Fortran::evaluate::FoldingContext&, Fortran::evaluate::TypeParamInquiry&&)':
fold-integer.cpp:(.text._ZN7Fortran8evaluate13FoldOperationERNS0_14FoldingContextEONS0_16TypeParamInquiryE+0xe8): undefined reference to `Fortran::semantics::DerivedTypeSpec::DerivedTypeSpec(Fortran::semantics::DerivedTypeSpec const&)'
clang: error: linker command failed with exit code 1 (use -v to see invocation)

[kiranchandramohan]

@PeteSteinfeld I have reverted this patch since I could not find a quick fix.
https://reviews.llvm.org/rGb7ef804807855e607da3eba221c1fc59e27f778e

[awarzynski]

In D99892#2670484, @kiranchandramohan wrote:

@PeteSteinfeld I have reverted this patch since I could not find a quick fix.
https://reviews.llvm.org/rGb7ef804807855e607da3eba221c1fc59e27f778e

Thank you @kiranchandramohan ! @PeteSteinfeld , you can reproduce this by using -DBUILD_SHARED_LIBS=On (I was having a look anyway).

[PeteSteinfeld]

In D99892#2670576, @awarzynski wrote:

In D99892#2670484, @kiranchandramohan wrote:

@PeteSteinfeld I have reverted this patch since I could not find a quick fix.
https://reviews.llvm.org/rGb7ef804807855e607da3eba221c1fc59e27f778e

Thank you @kiranchandramohan ! @PeteSteinfeld , you can reproduce this by using -DBUILD_SHARED_LIBS=On (I was having a look anyway).

Thank you, @awarzynski . I'll take a look ...

[PeteSteinfeld]

I'll be submitting a fix for the problem with building shared libraries soon ...

[PeteSteinfeld]

Fix building with shared libraries.

[PeteSteinfeld]

@awarzynski or @kiranchandramohan , can you please verify that this now builds with shared libraries?

[awarzynski]

In D99892#2671730, @PeteSteinfeld wrote:

@awarzynski or @kiranchandramohan , can you please verify that this now builds with shared libraries?

Tested with -DBUILD_SHARED_LIBS=On. Builds fine for me, thank you for fixing this!

flang/lib/Evaluate/fold-integer.cpp

Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
   // minloc, minval, not, pack, product, reduce,
   // sign, spread, sum, transfer, transpose, unpack
   return Expr<T>{std::move(funcRef)};
 }
 
 // Substitute a bare type parameter reference with its value if it has one now
 Expr<TypeParamInquiry::Result> FoldOperation(
     FoldingContext &context, TypeParamInquiry &&inquiry) {
-  if (!inquiry.base()) {
+  std::optional<NamedEntity> base{inquiry.base()};
+  parser::CharBlock parameterName{inquiry.parameter().name()};
+  if (base) {
+    // Handling "designator%typeParam".  Get the value of the type parameter
+    // from the instantiation of the base
+    if (const semantics::DeclTypeSpec *
+        declType{base->GetLastSymbol().GetType()}) {
+      if (const semantics::ParamValue *
+          paramValue{
+              declType->derivedTypeSpec().FindParameter(parameterName)}) {
+        const semantics::MaybeIntExpr &paramExpr{paramValue->GetExplicit()};
+        if (paramExpr && IsConstantExpr(*paramExpr)) {
+          Expr<SomeInteger> intExpr{*paramExpr};
+          return Fold(context,
+              ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));
+        }
+      }
+    }
+  } else {
     // A "bare" type parameter: replace with its value, if that's now known.
     if (const auto *pdt{context.pdtInstance()}) {
       if (const semantics::Scope * scope{context.pdtInstance()->scope()}) {
-        auto iter{scope->find(inquiry.parameter().name())};
+        auto iter{scope->find(parameterName)};
         if (iter != scope->end()) {
           const Symbol &symbol{*iter->second};
           const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
-          if (details && details->init() &&
-              (details->attr() == common::TypeParamAttr::Kind ||
-                  IsConstantExpr(*details->init()))) {
-            Expr<SomeInteger> expr{*details->init()};
+          if (details) {
+            const semantics::MaybeIntExpr &initExpr{details->init()};
+            if (initExpr && IsConstantExpr(*initExpr)) {
+              Expr<SomeInteger> expr{*initExpr};
               return Fold(context,
                   ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
             }
           }
         }
-      if (const auto *value{pdt->FindParameter(inquiry.parameter().name())}) {
+      }
+      if (const auto *value{pdt->FindParameter(parameterName)}) {
         if (value->isExplicit()) {
           return Fold(context,
               AsExpr(ConvertToType<TypeParamInquiry::Result>(
                   Expr<SomeInteger>{value->GetExplicit().value()})));
         }
       }
     }
   }

flang/lib/Evaluate/formatting.cpp

 }
 
 llvm::raw_ostream &BaseObject::AsFortran(llvm::raw_ostream &o) const {
   return EmitVar(o, u);
 }
 
 llvm::raw_ostream &TypeParamInquiry::AsFortran(llvm::raw_ostream &o) const {
   if (base_) {
-    return base_->AsFortran(o) << '%';
+    base_.value().AsFortran(o) << '%';
   }
   return EmitVar(o, parameter_);
 }
 
 llvm::raw_ostream &Component::AsFortran(llvm::raw_ostream &o) const {
   base_.value().AsFortran(o);
   return EmitVar(o << '%', symbol_);
 }

flang/lib/Semantics/type.cpp

private:
   evaluate::FoldingContext &foldingContext() {
     return context_.foldingContext();
   }
   template <typename T> T Fold(T &&expr) {
     return evaluate::Fold(foldingContext(), std::move(expr));
   }
   void InstantiateComponent(const Symbol &);
   const DeclTypeSpec *InstantiateType(const Symbol &);
-  const DeclTypeSpec &InstantiateIntrinsicType(const DeclTypeSpec &);
+  const DeclTypeSpec &InstantiateIntrinsicType(
+      SourceName, const DeclTypeSpec &);
   DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool);
 
   SemanticsContext &context_;
   Scope &scope_;
 };
 
 void DerivedTypeSpec::Instantiate(
     Scope &containingScope, SemanticsContext &context) {
const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {
   const DeclTypeSpec *type{symbol.GetType()};
   if (!type) {
     return nullptr; // error has occurred
   } else if (const DerivedTypeSpec * spec{type->AsDerived()}) {
     return &FindOrInstantiateDerivedType(scope_,
         CreateDerivedTypeSpec(*spec, symbol.test(Symbol::Flag::ParentComp)),
         context_, type->category());
   } else if (type->AsIntrinsic()) {
-    return &InstantiateIntrinsicType(*type);
+    return &InstantiateIntrinsicType(symbol.name(), *type);
   } else if (type->category() == DeclTypeSpec::ClassStar) {
     return type;
   } else {
     common::die("InstantiateType: %s", type->AsFortran().c_str());
   }
 }
 
 // Apply type parameter values to an intrinsic type spec.
 const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
-    const DeclTypeSpec &spec) {
+    SourceName symbolName, const DeclTypeSpec &spec) {
   const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())};
   if (evaluate::ToInt64(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(
+      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:

flang/test/Semantics/assign04.f90

 ! RUN: %S/test_errors.sh %s %t %f18
 ! 9.4.5
 subroutine s1
   type :: t(k, l)
     integer, kind :: k
     integer, len :: l
   end type
   type(t(1, 2)) :: x
   !ERROR: Assignment to constant 'x%k' is not allowed
   x%k = 4
-  !ERROR: Left-hand side of assignment is not modifiable
+  !ERROR: Assignment to constant 'x%l' is not allowed
   x%l = 3
 end
 
 ! C901
 subroutine s2(x)
   !ERROR: A dummy argument may not also be a named constant
   real, parameter :: x = 0.0
   real, parameter :: a(*) = [1, 2, 3]

flang/test/Semantics/resolve104.f90

+! RUN: %S/test_errors.sh %s %t %f18
+! Test constant folding of type parameter values both a base value and a
+! parameter name are supplied.
+! 
+! Type parameters are described in 7.5.3 and constant expressions are described 
+! in 10.1.12.  10.1.12, paragraph 4 defines whether a specification inquiry is 
+! a constant expression.  Section 10.1.11, paragraph 3, item (2) states that a 
+! type parameter inquiry is a specification inquiry.  
+
+module m1
+  type dtype(goodDefaultKind, badDefaultKind)
+    integer, kind :: goodDefaultKind = 4
+    integer, kind :: badDefaultKind = 343
+    ! next field OK only if instantiated with a good value of goodDefaultKind
+    !ERROR: KIND parameter value (99) of intrinsic type REAL did not resolve to a supported value
+    real(goodDefaultKind) :: goodDefaultField
+    ! next field OK only if instantiated with a good value of goodDefaultKind
+    !ERROR: KIND parameter value (343) of intrinsic type REAL did not resolve to a supported value
+    !ERROR: KIND parameter value (99) of intrinsic type REAL did not resolve to a supported value
+    real(badDefaultKind) :: badDefaultField
+  end type dtype
+  type(dtype) :: v1
+  type(dtype(4, 4)) :: v2
+  type(dtype(99, 4)) :: v3
+  type(dtype(4, 99)) :: v4
+end module m1
+
+module m2
+  type baseType(baseParam)
+    integer, kind :: baseParam = 4
+  end type baseType
+  type dtype(dtypeParam)
+    integer, kind :: dtypeParam = 4
+    type(baseType(dtypeParam)) :: baseField
+    !ERROR: KIND parameter value (343) of intrinsic type REAL did not resolve to a supported value
+    real(baseField%baseParam) :: realField
+  end type dtype
+
+  type(dtype) :: v1
+  type(dtype(8)) :: v2
+  type(dtype(343)) :: v3
+end module m2
+
+module m3
+  type dtype(goodDefaultLen, badDefaultLen)
+    integer, len :: goodDefaultLen = 4
+    integer, len :: badDefaultLen = 343
+  end type dtype
+  type(dtype) :: v1
+  type(dtype(4, 4)) :: v2
+  type(dtype(99, 4)) :: v3
+  type(dtype(4, 99)) :: v4
+  real(v1%goodDefaultLen), pointer :: pGood1
+  !ERROR: REAL(KIND=343) is not a supported type
+  real(v1%badDefaultLen), pointer :: pBad1
+  real(v2%goodDefaultLen), pointer :: pGood2
+  real(v2%badDefaultLen), pointer :: pBad2
+  !ERROR: REAL(KIND=99) is not a supported type
+  real(v3%goodDefaultLen), pointer :: pGood3
+  real(v3%badDefaultLen), pointer :: pBad3
+  real(v4%goodDefaultLen), pointer :: pGood4
+  !ERROR: REAL(KIND=99) is not a supported type
+  real(v4%badDefaultLen), pointer :: pBad4
+end module m3

flang/test/Semantics/resolve89.f90

subroutine inner (derivedArg)
       type(derived), intent(in), dimension(3) :: derivedArg
       integer :: localInt
 
       type(derived), parameter :: localderived = derived()
 
       type localDerivedType
         ! OK because the specification inquiry is a constant
         integer, dimension(localDerived%kindParam) :: goodField
-        !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components or type parameter values
+        ! OK because the value of lenParam is constant in this context
         integer, dimension(derivedArg%lenParam) :: badField
       end type localDerivedType
 
       ! OK because we're not defining a component
       integer, dimension(derivedArg%kindParam) :: localVar
     end subroutine inner
 end subroutine s1