diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h index 7eee1994a888c..0cf12f340ec5c 100644 --- a/flang/include/flang/Evaluate/check-expression.h +++ b/flang/include/flang/Evaluate/check-expression.h @@ -113,21 +113,29 @@ extern template void CheckSpecificationExpr( // read-only data. template std::optional IsContiguous(const A &, FoldingContext &, - bool namedConstantSectionsAreContiguous = true); + bool namedConstantSectionsAreContiguous = true, + bool firstDimensionStride1 = false); extern template std::optional IsContiguous(const Expr &, - FoldingContext &, bool namedConstantSectionsAreContiguous); + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); extern template std::optional IsContiguous(const ArrayRef &, - FoldingContext &, bool namedConstantSectionsAreContiguous); + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); extern template std::optional IsContiguous(const Substring &, - FoldingContext &, bool namedConstantSectionsAreContiguous); + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); extern template std::optional IsContiguous(const Component &, - FoldingContext &, bool namedConstantSectionsAreContiguous); + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); extern template std::optional IsContiguous(const ComplexPart &, - FoldingContext &, bool namedConstantSectionsAreContiguous); + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); extern template std::optional IsContiguous(const CoarrayRef &, - FoldingContext &, bool namedConstantSectionsAreContiguous); -extern template std::optional IsContiguous( - const Symbol &, FoldingContext &, bool namedConstantSectionsAreContiguous); + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); +extern template std::optional IsContiguous(const Symbol &, + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); static inline std::optional IsContiguous(const SymbolRef &s, FoldingContext &c, bool namedConstantSectionsAreContiguous = true) { return IsContiguous(s.get(), c, namedConstantSectionsAreContiguous); diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 78268cd13377a..d8baaf2e2a7ac 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -881,10 +881,12 @@ class IsContiguousHelper public: using Result = std::optional; // tri-state using Base = AnyTraverse; - explicit IsContiguousHelper( - FoldingContext &c, bool namedConstantSectionsAreContiguous) - : Base{*this}, context_{c}, namedConstantSectionsAreContiguous_{ - namedConstantSectionsAreContiguous} {} + explicit IsContiguousHelper(FoldingContext &c, + bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1 = false) + : Base{*this}, context_{c}, + namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous}, + firstDimensionStride1_{firstDimensionStride1} {} using Base::operator(); template Result operator()(const Constant &) const { @@ -956,13 +958,14 @@ class IsContiguousHelper if (!*baseIsContiguous) { return false; } - // TODO could be true if base contiguous and this is only component, or - // if base has only one element? + // TODO: should be true if base is contiguous and this is only + // component, or when the base has at most one element } return std::nullopt; } } Result operator()(const ComplexPart &x) const { + // TODO: should be true when base is empty array, too return x.complex().Rank() == 0; } Result operator()(const Substring &x) const { @@ -1061,6 +1064,9 @@ class IsContiguousHelper auto dims{subscript.size()}; std::vector knownPartialSlice(dims, false); for (auto j{dims}; j-- > 0;) { + if (j == 0 && firstDimensionStride1_ && !result.value_or(true)) { + result.reset(); // ignore problems on later dimensions + } std::optional dimLbound; std::optional dimUbound; std::optional dimExtent; @@ -1083,18 +1089,20 @@ class IsContiguousHelper dimExtent = 0; } } - if (const auto *triplet{std::get_if(&subscript[j].u)}) { ++rank; + const Expr *lowerBound{triplet->GetLower()}; + const Expr *upperBound{triplet->GetUpper()}; + std::optional lowerVal{lowerBound + ? ToInt64(Fold(context_, Expr{*lowerBound})) + : dimLbound}; + std::optional upperVal{upperBound + ? ToInt64(Fold(context_, Expr{*upperBound})) + : dimUbound}; if (auto stride{ToInt64(triplet->stride())}) { - const Expr *lowerBound{triplet->GetLower()}; - const Expr *upperBound{triplet->GetUpper()}; - std::optional lowerVal{lowerBound - ? ToInt64(Fold(context_, Expr{*lowerBound})) - : dimLbound}; - std::optional upperVal{upperBound - ? ToInt64(Fold(context_, Expr{*upperBound})) - : dimUbound}; + if (j == 0 && *stride == 1 && firstDimensionStride1_) { + result = *stride == 1; // contiguous or empty if so + } if (lowerVal && upperVal) { if (*lowerVal < *upperVal) { if (*stride < 0) { @@ -1110,23 +1118,31 @@ class IsContiguousHelper *lowerVal + *stride >= *upperVal) { result = false; // discontiguous if not empty } - } else { - mayBeEmpty = true; + } else { // bounds known and equal + if (j == 0 && firstDimensionStride1_) { + result = true; // stride doesn't matter + } + } + } else { // bounds not both known + mayBeEmpty = true; + } + } else { // stride not known + if (lowerVal && upperVal && *lowerVal == *upperVal) { + // stride doesn't matter when bounds are equal + if (j == 0 && firstDimensionStride1_) { + result = true; } } else { mayBeEmpty = true; } - } else { - mayBeEmpty = true; } - } else if (subscript[j].Rank() > 0) { + } else if (subscript[j].Rank() > 0) { // vector subscript ++rank; if (!result) { - result = false; // vector subscript + result = false; } mayBeEmpty = true; - } else { - // Scalar subscript. + } else { // scalar subscript if (dimExtent && *dimExtent > 1) { knownPartialSlice[j] = true; } @@ -1138,7 +1154,7 @@ class IsContiguousHelper if (result) { return result; } - // Not provably discontiguous at this point. + // Not provably contiguous or discontiguous at this point. // Return "true" if simply contiguous, otherwise nullopt. for (auto j{subscript.size()}; j-- > 0;) { if (const auto *triplet{std::get_if(&subscript[j].u)}) { @@ -1170,33 +1186,36 @@ class IsContiguousHelper FoldingContext &context_; bool namedConstantSectionsAreContiguous_{false}; + bool firstDimensionStride1_{false}; }; template std::optional IsContiguous(const A &x, FoldingContext &context, - bool namedConstantSectionsAreContiguous) { + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1) { if (!IsVariable(x) && (namedConstantSectionsAreContiguous || !ExtractDataRef(x, true, true))) { return true; } else { - return IsContiguousHelper{context, namedConstantSectionsAreContiguous}(x); + return IsContiguousHelper{ + context, namedConstantSectionsAreContiguous, firstDimensionStride1}(x); } } template std::optional IsContiguous(const Expr &, - FoldingContext &, bool namedConstantSectionsAreContiguous); + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); template std::optional IsContiguous(const ArrayRef &, FoldingContext &, - bool namedConstantSectionsAreContiguous); + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); template std::optional IsContiguous(const Substring &, FoldingContext &, - bool namedConstantSectionsAreContiguous); + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); template std::optional IsContiguous(const Component &, FoldingContext &, - bool namedConstantSectionsAreContiguous); + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); template std::optional IsContiguous(const ComplexPart &, FoldingContext &, - bool namedConstantSectionsAreContiguous); + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); template std::optional IsContiguous(const CoarrayRef &, FoldingContext &, - bool namedConstantSectionsAreContiguous); -template std::optional IsContiguous( - const Symbol &, FoldingContext &, bool namedConstantSectionsAreContiguous); + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +template std::optional IsContiguous(const Symbol &, FoldingContext &, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); // IsErrorExpr() struct IsErrorExprHelper : public AnyTraverse { diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index ef8282143451c..dfaa0e028d698 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -1015,10 +1015,26 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, actualDataAttr = common::CUDADataAttr::Device; } } + if (dummyDataAttr == common::CUDADataAttr::Device && + (dummyIsAssumedShape || dummyIsAssumedRank)) { + if (auto contig{evaluate::IsContiguous(actual, foldingContext, + /*namedConstantSectionsAreContiguous=*/true, + /*firstDimensionStride1=*/true)}) { + if (!*contig) { + messages.Say( + "actual argument associated with assumed shape/rank device %s is known to be discontiguous on its first dimension"_err_en_US, + dummyName); + } + } else { + messages.Say( + "actual argument associated with assumed shape/rank device %s is not known to be contiguous on its first dimension"_warn_en_US, + dummyName); + } + } std::optional warning; - bool isHostDeviceProc = procedure.cudaSubprogramAttrs && + bool isHostDeviceProc{procedure.cudaSubprogramAttrs && *procedure.cudaSubprogramAttrs == - common::CUDASubprogramAttrs::HostDevice; + common::CUDASubprogramAttrs::HostDevice}; if (!common::AreCompatibleCUDADataAttrs(dummyDataAttr, actualDataAttr, dummy.ignoreTKR, &warning, /*allowUnifiedMatchingRule=*/true, isHostDeviceProc, &context.languageFeatures())) { diff --git a/flang/test/Semantics/cuf19.cuf b/flang/test/Semantics/cuf19.cuf new file mode 100644 index 0000000000000..8bec943f99006 --- /dev/null +++ b/flang/test/Semantics/cuf19.cuf @@ -0,0 +1,30 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +interface + subroutine foo(a) + real, device, dimension(:,:) :: a + end +end interface + +real, device, allocatable :: a(:,:) +complex, device, allocatable :: z(:,:) +integer :: i = 2, j = 3 +allocate(a(10,10)) +allocate(z(10,10)) +call foo(a) ! ok +call foo(a(:,:)) ! ok +call foo(a(1:10,1:10)) ! ok +!ERROR: actual argument associated with assumed shape/rank device dummy argument 'a=' is known to be discontiguous on its first dimension +call foo(a(1:10:2,1:10)) +call foo(a(1:0:2,1:10)) ! empty dimension is ok +call foo(a(1:10:2,1:0)) ! any empty dimension is ok +call foo(a(1:10,1:10:2)) ! discontiguous second dimension is ok +!WARNING: actual argument associated with assumed shape/rank device dummy argument 'a=' is not known to be contiguous on its first dimension +call foo(a(1:10:i,1:10)) +!WARNING: actual argument associated with assumed shape/rank device dummy argument 'a=' is not known to be contiguous on its first dimension +call foo(a(1:i:2,1:10)) +call foo(a(i:j:1,1:10)) ! stride 1, okay, despite unknown bounds +!WARNING: actual argument associated with assumed shape/rank device dummy argument 'a=' is not known to be contiguous on its first dimension +call foo(a(i:j:-1,1:10)) +!ERROR: actual argument associated with assumed shape/rank device dummy argument 'a=' is known to be discontiguous on its first dimension +call foo(z%re) +end