[flang-commits] [flang] [flang] Diagnose the impure procedure reference in finalization according to the rank of the entity (PR #85475)
Kelvin Li via flang-commits
flang-commits at lists.llvm.org
Fri Mar 15 15:29:35 PDT 2024
https://github.com/kkwli updated https://github.com/llvm/llvm-project/pull/85475
>From 39651864e36d2e1d4676e75bc5f779e5a82ea7a8 Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Fri, 15 Mar 2024 17:45:11 -0400
Subject: [PATCH 1/3] [flang] Diagnose the impure procedure reference in
finalization according to the rank of the entity
Use the rank of the array section to determine which final procedure
would be called in diagnosing whether that procedure is impure or not.
---
flang/include/flang/Semantics/tools.h | 2 +-
flang/lib/Semantics/check-do-forall.cpp | 7 +++-
flang/lib/Semantics/tools.cpp | 16 +++++---
flang/test/Semantics/doconcurrent08.f90 | 49 ++++++++++++++++++++++---
4 files changed, 61 insertions(+), 13 deletions(-)
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index df66e1adb55023..f728291103049b 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -180,7 +180,7 @@ const Symbol *IsFinalizable(const Symbol &,
const Symbol *IsFinalizable(const DerivedTypeSpec &,
std::set<const DerivedTypeSpec *> * = nullptr,
bool withImpureFinalizer = false, std::optional<int> rank = std::nullopt);
-const Symbol *HasImpureFinal(const Symbol &);
+const Symbol *HasImpureFinal(const Symbol &, std::optional<int> rank = std::nullopt);
// Is this type finalizable or does it contain any polymorphic allocatable
// ultimate components?
bool MayRequireFinalization(const DerivedTypeSpec &derived);
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 4e8578d0e1daff..9dfc3092856102 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -220,8 +220,11 @@ class DoConcurrentBodyEnforce {
if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) {
SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason);
}
- if (const Symbol * impure{HasImpureFinal(*entity)}) {
- SayDeallocateWithImpureFinal(*entity, reason, *impure);
+ if (const auto *assignment{GetAssignment(stmt)}) {
+ const auto lhs{assignment->lhs};
+ if (const Symbol * impure{HasImpureFinal(*entity, lhs.Rank())}) {
+ SayDeallocateWithImpureFinal(*entity, reason, *impure);
+ }
}
}
if (const auto *assignment{GetAssignment(stmt)}) {
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index bf999b090419c6..3636b62bfef8c9 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -827,15 +827,21 @@ static const Symbol *HasImpureFinal(
return IsFinalizable(derived, nullptr, /*withImpureFinalizer=*/true, rank);
}
-const Symbol *HasImpureFinal(const Symbol &original) {
+const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) {
const Symbol &symbol{ResolveAssociations(original)};
if (symbol.has<ObjectEntityDetails>()) {
if (const DeclTypeSpec * symType{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
- // finalizable assumed-rank not allowed (C839)
- return evaluate::IsAssumedRank(symbol)
- ? nullptr
- : HasImpureFinal(*derived, symbol.Rank());
+ if (evaluate::IsAssumedRank(symbol)) {
+ // finalizable assumed-rank not allowed (C839)
+ return nullptr;
+ } else {
+ int actualRank = symbol.Rank();
+ if (rank) {
+ actualRank = rank.value();
+ }
+ return HasImpureFinal(*derived, actualRank);
+ }
}
}
}
diff --git a/flang/test/Semantics/doconcurrent08.f90 b/flang/test/Semantics/doconcurrent08.f90
index 41cd71e233d0d3..52b382741d0731 100644
--- a/flang/test/Semantics/doconcurrent08.f90
+++ b/flang/test/Semantics/doconcurrent08.f90
@@ -209,6 +209,8 @@ module m2
type :: impureFinal
contains
final :: impureSub
+ final :: impureSubRank1
+ final :: impureSubRank2
end type
type :: pureFinal
@@ -222,16 +224,27 @@ impure subroutine impureSub(x)
type(impureFinal), intent(in) :: x
end subroutine
+ impure subroutine impureSubRank1(x)
+ type(impureFinal), intent(in) :: x(:)
+ end subroutine
+
+ impure subroutine impureSubRank2(x)
+ type(impureFinal), intent(in) :: x(:,:)
+ end subroutine
+
pure subroutine pureSub(x)
type(pureFinal), intent(in) :: x
end subroutine
subroutine s4()
type(impureFinal), allocatable :: ifVar, ifvar1
+ type(impureFinal), allocatable :: ifArr1(:), ifArr2(:,:)
+ type(impureFinal) :: if0
type(pureFinal), allocatable :: pfVar
allocate(ifVar)
allocate(ifVar1)
allocate(pfVar)
+ allocate(ifArr1(5), ifArr2(5,5))
! OK for an ordinary DO loop
do i = 1,10
@@ -239,11 +252,9 @@ subroutine s4()
end do
! OK to invoke a PURE FINAL procedure in a DO CONCURRENT
- ! This case does not work currently because the compiler's test for
- ! HasImpureFinal() in .../lib/Semantics/tools.cc doesn't work correctly
-! do concurrent (i = 1:10)
-! if (i .eq. 1) deallocate(pfVar)
-! end do
+ do concurrent (i = 1:10)
+ if (i .eq. 1) deallocate(pfVar)
+ end do
! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT
do concurrent (i = 1:10)
@@ -271,6 +282,34 @@ subroutine s4()
ifvar = ifvar1
end if
end do
+
+ do concurrent (i = 1:5)
+ if (i .eq. 1) then
+ !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT
+ ifArr1(i) = if0
+ end if
+ end do
+
+ do concurrent (i = 1:5)
+ if (i .eq. 1) then
+ !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT
+ ifArr1 = if0
+ end if
+ end do
+
+ do concurrent (i = 1:5)
+ if (i .eq. 1) then
+ !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank1' caused by assignment not allowed in DO CONCURRENT
+ ifArr2(i,:) = if0
+ end if
+ end do
+
+ do concurrent (i = 1:5)
+ if (i .eq. 1) then
+ !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresubrank2' caused by assignment not allowed in DO CONCURRENT
+ ifArr2(:,:) = if0
+ end if
+ end do
end subroutine s4
end module m2
>From 2e1542db8c7d5001c0405f431d4f49dd18dde5b0 Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Fri, 15 Mar 2024 18:17:14 -0400
Subject: [PATCH 2/3] fix format
---
flang/include/flang/Semantics/tools.h | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index f728291103049b..dc3cd6c894a2c2 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -180,7 +180,8 @@ const Symbol *IsFinalizable(const Symbol &,
const Symbol *IsFinalizable(const DerivedTypeSpec &,
std::set<const DerivedTypeSpec *> * = nullptr,
bool withImpureFinalizer = false, std::optional<int> rank = std::nullopt);
-const Symbol *HasImpureFinal(const Symbol &, std::optional<int> rank = std::nullopt);
+const Symbol *HasImpureFinal(
+ const Symbol &, std::optional<int> rank = std::nullopt);
// Is this type finalizable or does it contain any polymorphic allocatable
// ultimate components?
bool MayRequireFinalization(const DerivedTypeSpec &derived);
>From 99f9b059492f6b58bb8b937d97e83aa0e4a53daf Mon Sep 17 00:00:00 2001
From: Kelvin Li <kli at ca.ibm.com>
Date: Fri, 15 Mar 2024 18:28:46 -0400
Subject: [PATCH 3/3] address review comments
---
flang/lib/Semantics/check-do-forall.cpp | 2 +-
flang/lib/Semantics/tools.cpp | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 9dfc3092856102..36340a4c5259a7 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -221,7 +221,7 @@ class DoConcurrentBodyEnforce {
SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason);
}
if (const auto *assignment{GetAssignment(stmt)}) {
- const auto lhs{assignment->lhs};
+ const auto &lhs{assignment->lhs};
if (const Symbol * impure{HasImpureFinal(*entity, lhs.Rank())}) {
SayDeallocateWithImpureFinal(*entity, reason, *impure);
}
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 3636b62bfef8c9..b08d160e23581b 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -836,7 +836,7 @@ const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) {
// finalizable assumed-rank not allowed (C839)
return nullptr;
} else {
- int actualRank = symbol.Rank();
+ int actualRank{symbol.Rank()};
if (rank) {
actualRank = rank.value();
}
More information about the flang-commits
mailing list