[flang] Fold IS_CONTIGUOUS() to .FALSE. when it is known to be

[klausler]

Summary

At present, IS_CONTIGUOUS() can only either fold to .TRUE. or
remain unknown. The underlying analysis, however, is capable
of returning a tri-state result (true, false, or unknown).
Extend and expose it to folding so that IS_CONTIGUOUS() can
fold to .FALSE. as well as to .TRUE. when contiguity is
known.

[clementval]

LGTM

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

extern template void CheckSpecificationExpr(
     FoldingContext &);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SomeInteger>> &x, const semantics::Scope &,
     FoldingContext &);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SubscriptInteger>> &x, const semantics::Scope &,
     FoldingContext &);
 
-// Simple contiguity (9.5.4)
-template <typename A> bool IsSimplyContiguous(const A &, FoldingContext &);
-extern template bool IsSimplyContiguous(
+// Contiguity & "simple contiguity" (9.5.4)
+template <typename A>
+std::optional<bool> IsContiguous(const A &, FoldingContext &);
+extern template std::optional<bool> IsContiguous(
     const Expr<SomeType> &, FoldingContext &);
+template <typename A>
+bool IsSimplyContiguous(const A &x, FoldingContext &context) {
+  return IsContiguous(x, context).value_or(false);
+}
 
 template <typename A> bool IsErrorExpr(const A &);
 extern template bool IsErrorExpr(const Expr<SomeType> &);
 
 } // namespace Fortran::evaluate
 #endif

flang/include/flang/Evaluate/variable.h

const Expr<SubscriptInteger> *GetUpper() const {
     return upper_.has_value() ? &upper_->value() : nullptr;
   }
   Triplet &set_upper(Expr<SubscriptInteger> &&);
   Expr<SubscriptInteger> stride() const; // N.B. result is not optional<>
   const Expr<SubscriptInteger> &GetStride() const { return stride_.value(); }
   Triplet &set_stride(Expr<SubscriptInteger> &&);
 
   bool operator==(const Triplet &) const;
-  bool IsStrideOne() const;
+  std::optional<bool> IsStrideOne() const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
 private:
   std::optional<IndirectSubscriptIntegerExpr> lower_, upper_;
   IndirectSubscriptIntegerExpr stride_;
 };
 
 // R919 subscript when rank 0, R923 vector-subscript when rank 1

flang/lib/Evaluate/check-expression.cpp

 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
     const semantics::Scope &, FoldingContext &);
 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
     const semantics::Scope &, FoldingContext &);
 template void CheckSpecificationExpr(
     const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
     FoldingContext &);
 
-// IsSimplyContiguous() -- 9.5.4
-class IsSimplyContiguousHelper
-    : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> {
+// IsContiguous() -- 9.5.4
+class IsContiguousHelper
+    : public AnyTraverse<IsContiguousHelper, std::optional<bool>> {
 public:
   using Result = std::optional<bool>; // tri-state
-  using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
-  explicit IsSimplyContiguousHelper(FoldingContext &c)
-      : Base{*this}, context_{c} {}
+  using Base = AnyTraverse<IsContiguousHelper, Result>;
+  explicit IsContiguousHelper(FoldingContext &c) : Base{*this}, context_{c} {}
   using Base::operator();
 
   Result operator()(const semantics::Symbol &symbol) const {
     const auto &ultimate{symbol.GetUltimate()};
     if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) {
       return true;
     } else if (ultimate.Rank() == 0) {
       // Extension: accept scalars as a degenerate case of
       // simple contiguity to allow their use in contexts like
       // data targets in pointer assignments with remapping.
       return true;
     } else if (semantics::IsPointer(ultimate) ||
         semantics::IsAssumedShape(ultimate)) {
-      return false;
+      return std::nullopt;
     } else if (const auto *details{
                    ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
       return !details->IsAssumedRank();
-    } else if (auto assoc{Base::operator()(ultimate)}) {
-      return assoc;
     } else {
-      return false;
+      return Base::operator()(ultimate);
     }
   }
 
   Result operator()(const ArrayRef &x) const {
-    const auto &symbol{x.GetLastSymbol()};
-    if (!(*this)(symbol).has_value()) {
-      return false;
-    } else if (auto rank{CheckSubscripts(x.subscript())}) {
-      if (x.Rank() == 0) {
-        return true;
-      } else if (*rank > 0) {
-        // a(1)%b(:,:) is contiguous if an only if a(1)%b is contiguous.
-        return (*this)(x.base());
-      } else {
-        // a(:)%b(1,1) is not contiguous.
-        return false;
-      }
+      return true; // scalars considered contiguous
+    int subscriptRank{0};
+    auto subscripts{CheckSubscripts(x.subscript(), subscriptRank)};
+    if (!subscripts.value_or(false)) {
+      return subscripts; // subscripts not known to be contiguous
+    } else if (subscriptRank > 0) {
+      // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous.
+      return (*this)(x.base());
     } else {
-      return false;
+      // a(:)%b(1,1) is (probably) not contiguous.
+      return std::nullopt;
     }
   }
   Result operator()(const CoarrayRef &x) const {
-    return CheckSubscripts(x.subscript()).has_value();
+    int rank{0};
+    return CheckSubscripts(x.subscript(), rank).has_value();
   }
   Result operator()(const Component &x) const {
-    return x.base().Rank() == 0 && (*this)(x.GetLastSymbol()).value_or(false);
+    if (x.base().Rank() == 0) {
+      return (*this)(x.GetLastSymbol());
+    } else {
+      // TODO could be true if base contiguous and this is only component, or
+      // if base has only one element?
+      return std::nullopt;
+    }
   }
-  Result operator()(const ComplexPart &) const { return false; }
-  Result operator()(const Substring &) const { return false; }
+  Result operator()(const ComplexPart &x) const {
+    return x.complex().Rank() == 0;
+  }
+  Result operator()(const Substring &) const { return std::nullopt; }
 
   Result operator()(const ProcedureRef &x) const {
     if (auto chars{
             characteristics::Procedure::Characterize(x.proc(), context_)}) {
       if (chars->functionResult) {
         const auto &result{*chars->functionResult};
         return !result.IsProcedurePointer() &&
             result.attrs.test(characteristics::FunctionResult::Attr::Pointer) &&
             result.attrs.test(
                 characteristics::FunctionResult::Attr::Contiguous);
       }
     }
-    return false;
+    return std::nullopt;
   }
 
+  Result operator()(const NullPointer &) const { return true; }
+
 private:
-  // If the subscripts can possibly be on a simply-contiguous array reference,
-  // return the rank.
-  static std::optional<int> CheckSubscripts(
-      const std::vector<Subscript> &subscript) {
+  static std::optional<bool> CheckSubscripts(
+      const std::vector<Subscript> &subscript, int &rank) {
     bool anyTriplet{false};
-    int rank{0};
+    rank = 0;
     for (auto j{subscript.size()}; j-- > 0;) {
       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
-        if (!triplet->IsStrideOne()) {
-          return std::nullopt;
+        auto isStride1{triplet->IsStrideOne()};
+        if (!isStride1.value_or(false)) {
+          return isStride1;
         } else if (anyTriplet) {
           if (triplet->lower() || triplet->upper()) {
-            // all triplets before the last one must be just ":"
+            // all triplets before the last one must be just ":" for
+            // simple contiguity
             return std::nullopt;
           }
         } else {
           anyTriplet = true;
         }
         ++rank;
       } else if (anyTriplet || subscript[j].Rank() > 0) {
-        return std::nullopt;
+        return false;
       }
     }
-    return rank;
+    return true;
   }
 
   FoldingContext &context_;
 };
 
 template <typename A>
-bool IsSimplyContiguous(const A &x, FoldingContext &context) {
+std::optional<bool> IsContiguous(const A &x, FoldingContext &context) {
   if (IsVariable(x)) {
-    auto known{IsSimplyContiguousHelper{context}(x)};
-    return known && *known;
+    return IsContiguousHelper{context}(x);
   } else {
     return true; // not a variable
   }
 }
 
-template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &);
+template std::optional<bool> IsContiguous(
+    const Expr<SomeType> &, FoldingContext &);
 
 // IsErrorExpr()
 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
   using Result = bool;
   using Base = AnyTraverse<IsErrorExprHelper, Result>;
   IsErrorExprHelper() : Base{*this} {}
   using Base::operator();
 

flang/lib/Evaluate/fold-logical.cpp

if (name == "all") {
     using DefaultReal = Type<TypeCategory::Real, 4>;
     return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
         ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {
           return Scalar<T>{x.IsNormal()};
         }));
   } else if (name == "is_contiguous") {
     if (args.at(0)) {
       if (auto *expr{args[0]->UnwrapExpr()}) {
-        if (IsSimplyContiguous(*expr, context)) {
-          return Expr<T>{true};
+        if (auto contiguous{IsContiguous(*expr, context)}) {
+          return Expr<T>{*contiguous};
         }
       }
     }
   } else if (name == "lge" || name == "lgt" || name == "lle" || name == "llt") {
     // Rewrite LGE/LGT/LLE/LLT into ASCII character relations
     auto *cx0{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
     auto *cx1{UnwrapExpr<Expr<SomeCharacter>>(args[1])};
     if (cx0 && cx1) {

flang/lib/Evaluate/variable.cpp

 
 Expr<SubscriptInteger> Triplet::stride() const { return stride_.value(); }
 
 Triplet &Triplet::set_stride(Expr<SubscriptInteger> &&expr) {
   stride_.value() = std::move(expr);
   return *this;
 }
 
-bool Triplet::IsStrideOne() const {
+std::optional<bool> Triplet::IsStrideOne() const {
   if (auto stride{ToInt64(stride_.value())}) {
     return stride == 1;
   } else {
-    return false;
+    return std::nullopt;
   }
 }
 
 CoarrayRef::CoarrayRef(SymbolVector &&base, std::vector<Subscript> &&ss,
     std::vector<Expr<SubscriptInteger>> &&css)
     : base_{std::move(base)}, subscript_(std::move(ss)),
       cosubscript_(std::move(css)) {
   CHECK(!base_.empty());

flang/test/Semantics/assign03.f90

subroutine s11
     real, pointer :: q(:)
     p(1:100) => x(:,:)
     q(1:10) => x(1,:)%im
     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
     q(1:100) => x(:,:)%re
   end
 
   ! Check is_contiguous, which is usually the same as when pointer bounds
-  ! remapping is used. If it's not simply contiguous it's not constant so
-  ! an error is reported.
+  ! remapping is used.
   subroutine s12
     integer, pointer :: p(:)
+    integer, pointer, contiguous :: pc(:)
     type :: t
       integer :: a(4, 4)
       integer :: b
     end type
     type(t), target :: x
     type(t), target :: y(10,10)
     integer :: v(10)
-    logical, parameter :: l1 = is_contiguous(x%a(:,:))
-    logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1))
+    logical(kind=merge(1,-1,is_contiguous(x%a(:,:)))) :: l1 ! known true
+    logical(kind=merge(1,-1,is_contiguous(y(1,1)%a(1,1)))) :: l2 ! known true
     !ERROR: Must be a constant value
-    logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1))
+    logical(kind=merge(-1,-2,is_contiguous(y(:,1)%a(1,1)))) :: l3 ! unknown
     !ERROR: Must be a constant value
-    logical, parameter :: l4 = is_contiguous(x%a(:,v))
+    logical(kind=merge(-1,-2,is_contiguous(y(:,1)%a(1,1)))) :: l4 ! unknown
+    logical(kind=merge(-1,1,is_contiguous(x%a(:,v)))) :: l5 ! known false
     !ERROR: Must be a constant value
-    logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1))
+    logical(kind=merge(-1,-2,is_contiguous(y(v,1)%a(1,1)))) :: l6 ! unknown
     !ERROR: Must be a constant value
-    logical, parameter :: l6 = is_contiguous(p(:))
+    logical(kind=merge(-1,-2,is_contiguous(p(:)))) :: l7 ! unknown
+    logical(kind=merge(1,-1,is_contiguous(pc(:)))) :: l8 ! known true
+    logical(kind=merge(-1,1,is_contiguous(pc(1:10:2)))) :: l9 ! known false
+    logical(kind=merge(-1,1,is_contiguous(pc(10:1:-1)))) :: l10 ! known false
   end
   subroutine test3(b)
     integer, intent(inout) :: b(..)
     !ERROR: Must be a constant value
     integer, parameter :: i = rank(b)
   end subroutine
 
   subroutine s13
     external :: s_external
     procedure(), pointer :: ptr
     !Ok - don't emit an error about incompatible Subroutine attribute
     ptr => s_external
     call ptr
   end subroutine
 end